221 |
; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)") |
; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)") |
222 |
; (get '+ 'inline-always)) |
; (get '+ 'inline-always)) |
223 |
|
|
224 |
(defun binary-nest (form env) |
(defun pull-evals (x &optional form lets) |
225 |
(if (> (length form) 3) |
(if (consp x) |
226 |
(binary-nest (cons (car form) |
(if (and (consp (car x)) (not (eq (caar x) 'quote))) |
227 |
(cons (list (car form) (cadr form) (caddr form)) |
(let ((s (gensym))) |
228 |
(cdddr form))) |
(pull-evals (cdr x) (cons s form) (cons (list s (car x)) lets))) |
229 |
env) |
(pull-evals (cdr x) (cons (car x) form) lets)) |
230 |
|
(values (nreverse form) (nreverse lets)))) |
231 |
|
|
232 |
|
|
233 |
|
(defun binary-nest-int (form len) |
234 |
|
(declare (fixnum len) (list form)) |
235 |
|
(if (> len 3) |
236 |
|
(binary-nest-int |
237 |
|
(cons (car form) |
238 |
|
(cons (list (car form) (cadr form) (caddr form)) |
239 |
|
(cdddr form))) |
240 |
|
(1- len)) |
241 |
form)) |
form)) |
242 |
|
|
243 |
|
(defmacro let-wrap (lets form) |
244 |
|
`(if lets |
245 |
|
(list 'let* ,lets ,form) |
246 |
|
,form)) |
247 |
|
|
248 |
|
(defun binary-nest (form env) |
249 |
|
(declare (ignore env)) |
250 |
|
(let ((len (length form))) |
251 |
|
(declare (fixnum len)) |
252 |
|
(if (> len 3) |
253 |
|
(multiple-value-bind (form lets) (pull-evals form) |
254 |
|
(let-wrap lets (binary-nest-int form len))) |
255 |
|
form))) |
256 |
|
|
257 |
(si::putprop '* (function binary-nest) 'compiler-macro) |
(si::putprop '* (function binary-nest) 'compiler-macro) |
258 |
(si::putprop '+ (function binary-nest) 'compiler-macro) |
(si::putprop '+ (function binary-nest) 'compiler-macro) |
259 |
|
|
281 |
(defun logical-binary-nest (form env) |
(defun logical-binary-nest (form env) |
282 |
(declare (ignore env)) |
(declare (ignore env)) |
283 |
(if (> (length form) 3) |
(if (> (length form) 3) |
284 |
(let (r) |
(multiple-value-bind (form lets) (pull-evals form) |
285 |
(do ((f (cdr form) (cdr f))) ((null (cdr f)) (cons 'and (nreverse r))) |
(let (r) |
286 |
(push (list (car form) (car f) (cadr f)) r))) |
(do ((f (cdr form) (cdr f))) |
287 |
form)) |
((null (cdr f)) |
288 |
|
(let-wrap lets (cons 'and (nreverse r)))) |
289 |
|
(push (list (car form) (car f) (cadr f)) r)))) |
290 |
|
form)) |
291 |
|
|
292 |
(si::putprop '> (function logical-binary-nest) 'compiler-macro) |
(si::putprop '> (function logical-binary-nest) 'compiler-macro) |
293 |
(si::putprop '>= (function logical-binary-nest) 'compiler-macro) |
(si::putprop '>= (function logical-binary-nest) 'compiler-macro) |
304 |
(defun logical-outer-nest (form env) |
(defun logical-outer-nest (form env) |
305 |
(declare (ignore env)) |
(declare (ignore env)) |
306 |
(if (> (length form) 3) |
(if (> (length form) 3) |
307 |
(let (r) |
(multiple-value-bind (form lets) (pull-evals form) |
308 |
(do ((f (cdr form) (cdr f))) ((null (cdr f)) (cons 'and (nreverse r))) |
(let (r) |
309 |
(do ((g (cdr f) (cdr g))) ((null g)) |
(do ((f (cdr form) (cdr f))) |
310 |
(push (list (car form) (car f) (car g)) r)))) |
((null (cdr f)) |
311 |
|
(let-wrap lets (cons 'and (nreverse r)))) |
312 |
|
(do ((g (cdr f) (cdr g))) ((null g)) |
313 |
|
(push (list (car form) (car f) (car g)) r))))) |
314 |
form)) |
form)) |
315 |
|
|
316 |
(si::putprop '/= (function logical-outer-nest) 'compiler-macro) |
(si::putprop '/= (function logical-outer-nest) 'compiler-macro) |