/[gcl]/gcl/cmpnew/gcl_cmpeval.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpeval.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by camm, Thu Nov 25 19:46:20 2004 UTC revision 1.10 by camm, Sat Nov 27 15:39:58 2004 UTC
# Line 221  Line 221 
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    
# Line 256  Line 281 
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)
# Line 276  Line 304 
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)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26