Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 253 lines (221 sloc) 9.592 kB
4c437ac @VincentToups changed some names
VincentToups authored
1 (require 'macro-utils)
2 (require 'utils)
3 (require 'functional)
4 (require 'parse-lambda-list)
5 (require 'lambda-star)
edf37e2 @VincentToups Big monads.md doc
VincentToups authored
6 (require 'cl)
4c437ac @VincentToups changed some names
VincentToups authored
7 (provide 'recur)
8
9
10 (defun simple-expand-recur-progn (code symbols in-tail loop-sentinal)
11 "Handle expansion of tail recursion for a PROGN form."
12 (let* ((r-code (reverse (cdr code)))
13 (tail (car r-code))
14 (rest (cdr r-code)))
15 `(progn ,@(reverse (cons (simple-expand-recur tail symbols in-tail loop-sentinal)
16 (mapcar (par #'simple-expand-recur symbols nil nil) rest))))))
17
18 (defun simple-recurp (form)
19 "Test to see if this is a recur form."
20 (and (listp form)
21 (eq (car form) 'recur)))
22
23 (defun simple-expand-recur-recur (code symbols in-tail loop-sentinal)
24 "Expand a RECUR form. Might be useful to shadow for special kinds of recursion bindings."
25 (if (not in-tail) (error "The recur form %S is not in a tail position, can't expand." code))
26 (let* ((val-exprs (cdr code))
27 (psetq-forms (flatten-once (zip (cons loop-sentinal symbols) (cons t val-exprs)))))
28 `(psetq ,@psetq-forms)))
29
30
31
32 (defun simple-expand-recur-let-like (form symbols in-tail loop-sentinal)
33 "Handle recursion expansion for LET forms."
34 (let* ((body (cdr (simple-expand-recur `(progn ,@(get-let-body form)) symbols in-tail loop-sentinal)))
35 (bindings (get-let-binders form))
36 (symbols (mapcar #'car bindings))
37 (expressions (mapcar
38 (comp (par #'simple-expand-recur nil nil nil) #'cadr)
39 bindings))
40 (bindings (zip symbols expressions)))
d09d144 @VincentToups fixed, at least, recur.
VincentToups authored
41 `(,(car form) ,bindings ,@body)))
4c437ac @VincentToups changed some names
VincentToups authored
42
43 (defun simple-expand-recur-if (form symbols in-tail loop-sentinal)
44 "Handle recursion expansion for IF forms."
45 (let* ((predicate-expr (simple-expand-recur (elt form 1) nil nil nil))
46 (true-branch
47 (simple-expand-recur (elt form 2) symbols in-tail loop-sentinal))
48 (false-branch
49 (simple-expand-recur (elt form 3) symbols in-tail loop-sentinal)))
50 `(if ,predicate-expr ,true-branch ,false-branch)))
51
52 (defun simple-expand-recur-cond (form symbols in-tail loop-sentinal)
53 "Handle recursion expansion for COND forms."
54 `(cond ,@(loop for sub-form in (cdr form)
55 collect
56 (let ((condition (car sub-form))
57 (body (cdr sub-form)))
58 `(
59 ,(simple-expand-recur condition symbols nil nil)
60 ,@(cdr (simple-expand-recur
bccfb64 @VincentToups fixed recur.el bug in cond expansion, started kanren implementation i…
VincentToups authored
61 `(progn ,@body) symbols in-tail loop-sentinal)))))))
4c437ac @VincentToups changed some names
VincentToups authored
62
63 (defun simple-expand-recur-funcall (code symbols in-tail loop-sentinal)
64 "Handle recursion expansion for FUNCALL forms. The de-factor default when the head of a list is not recognized."
65 (let ((f (car code))
66 (args (mapcar (par #'simple-expand-recur symbols nil loop-sentinal) (cdr code))))
67 `(,f ,@args)))
68
69 (defun simple-expand-recur-flet (code symbols in-tail loop-sentinal)
70 "Handle recursion expansion for FLET forms."
71 (let ((bindings (elt code 1))
72 (body (cddr code)))
73 `(flet ,bindings
74 ,@(cdr (simple-expand-recur (cons 'progn body) symbols in-tail loop-sentinal)))))
75
76 (defun lambdap (code)
77 "Returns true if CODE is a list starting with LAMBDA"
78 (and (listp code)
79 (eq (car code) 'lambda)))
80
81
82 (defun defunp (code)
83 "Returns true if CODE is a list starting with DEFUN."
84 (and (listp code)
85 (eq (car code) 'defun)))
86
87 (defun function-listp (code)
88 "Returns true if CODE is a list starting with FUNCTION"
89 (and (listp code)
90 (eq (car code) 'function)))
91
92 (defun recur-ignorable-p (code)
93 "Returns true for code which recur does not expand."
94 (or (lambdap code)
95 (defunp code)
96 (function-listp code)))
97
98 (defun* simple-expand-recur (code symbols &optional (in-tail t) (loop-sentinal (gensym "recur-loop-sentinal-")))
99 "Work horse of recur-enabled forms. Recursively walks CODE, finding RECUR forms and
100 expanding them if they are in tail position or marking an error if they are not in tail
101 position and marking an error otherwise. When a recur form is found in tail position,
102 it generates the appropriate setters and sets the loop-sentinal symbol to t, ensuring
103 a loop continues. Building this loop is handled by the caller."
104 (cond
105 ((or (atom code) (recur-ignorable-p code)) code)
106 ((quotep code) code)
107 ((functionp code) code)
108 ((prog-like code)
109 (simple-expand-recur-progn code symbols in-tail loop-sentinal))
110 ((let/*p code)
111 (simple-expand-recur-let-like code symbols in-tail loop-sentinal))
112 ((ifp code)
113 (simple-expand-recur-if code symbols in-tail loop-sentinal))
114 ((condp code)
115 (simple-expand-recur-cond code symbols in-tail loop-sentinal))
116 ((fletp code)
117 (simple-expand-recur-flet code symbols in-tail loop-sentinal))
118 ((simple-recurp code)
119 (simple-expand-recur-recur code symbols in-tail loop-sentinal))
120 ((listp code)
121 (simple-expand-recur-funcall code symbols nil loop-sentinal))))
122
123 (dont-do
124 (simple-expand-recur-recur '(recur (+ x 1) (+ y 2)) '(r s) t)
125 (simple-expand-recur '(progn a b c (recur a b))
126 '(x y) t)
127 (simple-expand-recur '(let ((x 10) (y 11)) (recur (+ x 1) y)) '(q r) t 'loop-sent)
128 (simple-expand-recur '(if (< x 10) (recur (+ x 1) x) (recur (+ z 2) x)) '(q r) t 'loop-sent)
129 (simple-expand-recur-cond '(cond ((< x 1) a b (recur (+ x 1)))
130 ((= x 0) q r (recur (- x 1))))
131 '(z) t 'loop-sent)
132 )
133
134
135 (defmacro lambda-list-parsing-lambda (lambda-list)
136 "Builds a lambda which turns its arguments into a table reflecting the LAMBDA-LIST. Useful for
137 macro expansion."
138 (let* ((arg-alist (parse-lambda-list lambda-list))
139 (normal-names (alist arg-alist :normal))
140 (normal-names-forms
141 (mapcar (lambda (x)
142 `(list (quote ,x) ,x)) normal-names))
143 (optional-names (mapcar #'car-or-thing (alist arg-alist :optional)))
144 (optional-names-forms
145 (mapcar (lambda (x)
146 `(list (quote ,x) ,x)) optional-names))
147 (key-names (mapcar #'car-or-thing (alist arg-alist :key)))
148 (key-names-forms
149 (mapcar (lambda (x)
150 `(list (quote ,x) ,x)) key-names))
151 (rest-name (alist arg-alist :rest))
152 (rest-name-form `(list (quote ,rest-name) ,rest-name)))
153 `(lambda* ,lambda-list
154 (alist>> :normal (list ,@normal-names-forms)
155 :optional (list ,@optional-names-forms)
156 :rest ,rest-name-form
157 :key (list ,@key-names-forms)))))
158
159 (defun setq-ll-normal-part (table)
160 "Build the normal argument part of a lambda-list table."
161 (flatten-once (alist table :normal)))
162
163 (defun setq-ll-optional-part (table)
164 "Build the optional argument part of a lambda-list table."
165 (flatten-once (alist table :optional)))
166
167 (defun print-and-return (x)
168 "Print and return a value."
169 (print x)
170 x)
171
172 (defun setq-ll-key-part (table)
173 "Build the key part of a lambda-list table."
174 (flatten-once (alist table :key)))
175
176 (defun setq-ll-rest-part (table)
177 "Build a rest part of a lambda list table."
178 (let* ((rest (alist table :rest))
179 (name (car rest))
180 (forms (cadr rest)))
181 (if name
182 `(,name (list ,@forms)) nil)))
183
184 (defmacro setq-lambda-list (lambda-list &rest args)
185 "Set variables with specifications from a lambda-list (common-lisp-style)."
186 (if (not (listp lambda-list)) (error "lambda-list must be a static list conforming to the lambda lisp specifier."))
187 (let* ((parser (eval `(lambda-list-parsing-lambda ,lambda-list)))
188 (table (apply parser args)))
189 `(psetq ,@(setq-ll-normal-part table) ,@(setq-ll-optional-part table)
190 ,@(setq-ll-key-part table) ,@(setq-ll-rest-part table))))
191
192 (defmacro recur-let (bindings &rest body)
193 "Like let, but allows recursion, as if the let form was itself a function which can be called from inside itself."
194 (let* ((loop-sentinal (gensym "recur-loop-sentinal-"))
195 (symbols (mapcar #'car bindings))
196 (return-value (gensym "recur-loop-return-value-"))
197 (expressions (mapcar #'cdr bindings)))
198 `(let ((,loop-sentinal t)
199 (,return-value nil))
200 (let ,bindings
201 (while ,loop-sentinal
202 (setq ,loop-sentinal nil)
203 (setq ,return-value
204 ,(simple-expand-recur
205 (macroexpand-all
206 (cons 'progn body))
207 symbols
208 t
209 loop-sentinal))))
210 ,return-value)))
211
212 (defun simple-expand-recur-recur-lambda-list (code in-tail loop-sentinal lambda-list)
213 "Special recur form expansion function for recur-defun* to support setq with lamba-list bindings."
214 (if (not in-tail) (error "The recur form %S is not in a tail position, can't expand." code))
215 (let* ((val-exprs (cdr code)))
216 `(progn
217 (setq ,loop-sentinal t)
218 ,(macroexpand-all `(setq-lambda-list ,lambda-list ,@val-exprs)))))
219
220 (dont-do
221 (macroexpand-all (simple-expand-recur-recur-lambda-list '(recur 1 (+ 2 b) 3) t 'loop-sent '(a b &rest c))))
222
223 (defmacro* recur-defun* (name arglist &body body)
224 "Define a recur-enabled function. It can call itself with a RECUR form without growing the stack.
225 Otherwise conforms to a Common-Lisp style defun form."
bccfb64 @VincentToups fixed recur.el bug in cond expansion, started kanren implementation i…
VincentToups authored
226 (declare (indent defun))
4c437ac @VincentToups changed some names
VincentToups authored
227 (let* ((doc (if (stringp (car body)) (car body) ""))
228 (body (if (stringp (car body)) (cdr body) body)))
229 (with-gensyms
230 (loop-sentinal return-value)
231 (lexical-let ((recur-defun-arglist arglist))
232 (let ((expanded-body (macroexpand-all body)))
233 `(defun* ,name ,arglist
234 ,doc
235 (let ((,loop-sentinal t)
236 (,return-value nil))
237 (while ,loop-sentinal
238 (setq ,loop-sentinal nil)
239 (setq ,return-value
240 ,(flet
241 ((simple-expand-recur-recur (code symbols in-tail loop-sentinal)
242 (simple-expand-recur-recur-lambda-list code in-tail loop-sentinal recur-defun-arglist)))
243 (simple-expand-recur
244 (macroexpand-all
245 (cons 'progn body))
246 nil
247 t
248 loop-sentinal))))
249 ,return-value)))))))
250 (dont-do
251 (recur-defun* eleven (&optional (x 0)) "counts to eleven" (if (< x 11) (recur (+ x 1)) x)))
252
Something went wrong with that request. Please try again.