/[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.28 by camm, Fri Aug 12 15:48:34 2005 UTC revision 1.29 by pfdietz, Sat Aug 27 00:11:17 2005 UTC
# Line 23  Line 23 
23    
24    
25  (export '(si::define-compiler-macro  (export '(si::define-compiler-macro
26              si::compiler-macro-function
27            si::undef-compiler-macro            si::undef-compiler-macro
28            si::define-inline-function) 'system)            si::define-inline-function) 'system)
29    
# Line 285  Line 286 
286            (let-wrap lets (binary-nest-int form len)))            (let-wrap lets (binary-nest-int form len)))
287        form)))        form)))
288    
289  (si::putprop '* (function binary-nest) 'compiler-macro)  (si::putprop '* (function binary-nest) 'si::compiler-macro-prop)
290  (si::putprop '+ (function binary-nest) 'compiler-macro)  (si::putprop '+ (function binary-nest) 'si::compiler-macro-prop)
291    
292  (si::putprop 'logand (function binary-nest) 'compiler-macro)  (si::putprop 'logand (function binary-nest) 'si::compiler-macro-prop)
293  (si::putprop 'logior (function binary-nest) 'compiler-macro)  (si::putprop 'logior (function binary-nest) 'si::compiler-macro-prop)
294  (si::putprop 'logxor (function binary-nest) 'compiler-macro)  (si::putprop 'logxor (function binary-nest) 'si::compiler-macro-prop)
295    
296  (si::putprop 'max (function binary-nest) 'compiler-macro)  (si::putprop 'max (function binary-nest) 'si::compiler-macro-prop)
297  (si::putprop 'min (function binary-nest) 'compiler-macro)  (si::putprop 'min (function binary-nest) 'si::compiler-macro-prop)
298    
299  (defun invert-binary-nest (form env)  (defun invert-binary-nest (form env)
300    (declare (ignore env))    (declare (ignore env))
# Line 306  Line 307 
307          (list op (cadr form) (cons recip (cddr form))))          (list op (cadr form) (cons recip (cddr form))))
308      form))      form))
309    
310  (si::putprop '- (function invert-binary-nest) 'compiler-macro)  (si::putprop '- (function invert-binary-nest) 'si::compiler-macro-prop)
311  (si::putprop '/ (function invert-binary-nest) 'compiler-macro)  (si::putprop '/ (function invert-binary-nest) 'si::compiler-macro-prop)
312    
313  (defun logical-binary-nest (form env)  (defun logical-binary-nest (form env)
314    (declare (ignore env))    (declare (ignore env))
# Line 320  Line 321 
321              (push (list (car form) (car f) (cadr f)) r))))              (push (list (car form) (car f) (cadr f)) r))))
322          form))          form))
323    
324  (si::putprop '> (function logical-binary-nest) 'compiler-macro)  (si::putprop '> (function logical-binary-nest) 'si::compiler-macro-prop)
325  (si::putprop '>= (function logical-binary-nest) 'compiler-macro)  (si::putprop '>= (function logical-binary-nest) 'si::compiler-macro-prop)
326  (si::putprop '< (function logical-binary-nest) 'compiler-macro)  (si::putprop '< (function logical-binary-nest) 'si::compiler-macro-prop)
327  (si::putprop '<= (function logical-binary-nest) 'compiler-macro)  (si::putprop '<= (function logical-binary-nest) 'si::compiler-macro-prop)
328  (si::putprop '= (function logical-binary-nest) 'compiler-macro)  (si::putprop '= (function logical-binary-nest) 'si::compiler-macro-prop)
329    
330  (si::putprop 'char> (function logical-binary-nest) 'compiler-macro)  (si::putprop 'char> (function logical-binary-nest) 'si::compiler-macro-prop)
331  (si::putprop 'char>= (function logical-binary-nest) 'compiler-macro)  (si::putprop 'char>= (function logical-binary-nest) 'si::compiler-macro-prop)
332  (si::putprop 'char< (function logical-binary-nest) 'compiler-macro)  (si::putprop 'char< (function logical-binary-nest) 'si::compiler-macro-prop)
333  (si::putprop 'char<= (function logical-binary-nest) 'compiler-macro)  (si::putprop 'char<= (function logical-binary-nest) 'si::compiler-macro-prop)
334  (si::putprop 'char= (function logical-binary-nest) 'compiler-macro)  (si::putprop 'char= (function logical-binary-nest) 'si::compiler-macro-prop)
335    
336  (defun logical-outer-nest (form env)  (defun logical-outer-nest (form env)
337    (declare (ignore env))    (declare (ignore env))
# Line 344  Line 345 
345              (push (list (car form) (car f) (car g)) r)))))              (push (list (car form) (car f) (car g)) r)))))
346      form))      form))
347    
348  (si::putprop '/= (function logical-outer-nest) 'compiler-macro)  (si::putprop '/= (function logical-outer-nest) 'si::compiler-macro-prop)
349  (si::putprop 'char/= (function logical-outer-nest) 'compiler-macro)  (si::putprop 'char/= (function logical-outer-nest) 'si::compiler-macro-prop)
350    
351    
352  (defun incr-to-plus (form env)  (defun incr-to-plus (form env)
# Line 356  Line 357 
357    (declare (ignore env))    (declare (ignore env))
358    `(- ,(cadr form) 1))    `(- ,(cadr form) 1))
359    
360  (si::putprop '1+ (function incr-to-plus) 'compiler-macro)  (si::putprop '1+ (function incr-to-plus) 'si::compiler-macro-prop)
361  (si::putprop '1- (function decr-to-minus) 'compiler-macro)  (si::putprop '1- (function decr-to-minus) 'si::compiler-macro-prop)
362    
363  (defun seqind-wrap (form)  (defun seqind-wrap (form)
364    (if *safe-compile*    (if *safe-compile*
# Line 382  Line 383 
383                                  `(* ,first (array-dimension ,ar ,it))) ,second)) ,@rest)                                  `(* ,first (array-dimension ,ar ,it))) ,second)) ,@rest)
384                  nil it))))))                  nil it))))))
385    
386  (si::putprop 'array-row-major-index (function array-row-major-index-expander) 'compiler-macro)  (si::putprop 'array-row-major-index (function array-row-major-index-expander) 'si::compiler-macro-prop)
387    
388  (defmacro with-pulled-array (bindings form &body body)  (defmacro with-pulled-array (bindings form &body body)
389    `(let ((,(car bindings) (cadr ,form)))    `(let ((,(car bindings) (cadr ,form)))
# Line 399  Line 400 
400       (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(cddr form)))))))       (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(cddr form)))))))
401         (let-wrap lets `(compiler::cmp-aref ,sym ,isym))))))         (let-wrap lets `(compiler::cmp-aref ,sym ,isym))))))
402    
403  (si::putprop 'aref (function aref-expander) 'compiler-macro)  (si::putprop 'aref (function aref-expander) 'si::compiler-macro-prop)
404  (si::putprop 'row-major-aref (function aref-expander) 'compiler-macro)  (si::putprop 'row-major-aref (function aref-expander) 'si::compiler-macro-prop)
405    
406  (defun aset-expander (form env)  (defun aset-expander (form env)
407    (declare (ignore env))    (declare (ignore env))
# Line 410  Line 411 
411       (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(butlast (cddr form))))))))       (let ((lets (append lets `((,isym (array-row-major-index ,sym ,@(butlast (cddr form))))))))
412         (let-wrap lets `(compiler::cmp-aset ,sym ,isym ,(car (last form))))))))         (let-wrap lets `(compiler::cmp-aset ,sym ,isym ,(car (last form))))))))
413    
414  (si::putprop 'si::aset (function aset-expander) 'compiler-macro)  (si::putprop 'si::aset (function aset-expander) 'si::compiler-macro-prop)
415  ;FIXME -- test and install this and svref, CM 20050106  ;FIXME -- test and install this and svref, CM 20050106
416  ;(si::putprop 'svset (function aset-expander) 'compiler-macro)  ;(si::putprop 'svset (function aset-expander) 'si::compiler-macro-prop)
417    
418  (defun array-dimension-expander (form env)  (defun array-dimension-expander (form env)
419    (declare (ignore env))    (declare (ignore env))
# Line 420  Line 421 
421     (ar lets sym) form     (ar lets sym) form
422     (let-wrap lets `(compiler::cmp-array-dimension ,sym ,(caddr form)))))     (let-wrap lets `(compiler::cmp-array-dimension ,sym ,(caddr form)))))
423    
424  (si::putprop 'array-dimension (function array-dimension-expander) 'compiler-macro)  (si::putprop 'array-dimension (function array-dimension-expander) 'si::compiler-macro-prop)
425    
426  (defun do-list-search (test list &key (k1 nil k1p) (key nil keyp) (item nil itemp) rev (ret nil retp) test-not ((:test foo)))  (defun do-list-search (test list &key (k1 nil k1p) (key nil keyp) (item nil itemp) rev (ret nil retp) test-not ((:test foo)))
427    (declare (ignore foo))    (declare (ignore foo))
# Line 470  Line 471 
471        `(let (,@syms)        `(let (,@syms)
472           ,(apply 'possible-eq-list-search (car r) (cadr r) specials `(,@overrides ,@(cddr r)))))))           ,(apply 'possible-eq-list-search (car r) (cadr r) specials `(,@overrides ,@(cddr r)))))))
473    
474  (si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'member (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
475  (si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'member-if (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
476  (si::putprop 'member-if-not (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'member-if-not (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
477  (si::putprop 'assoc (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'assoc (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
478  (si::putprop 'assoc-if (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'assoc-if (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
479  (si::putprop 'assoc-if-not (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'assoc-if-not (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
480  (si::putprop 'rassoc (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'rassoc (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
481  (si::putprop 'rassoc-if (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'rassoc-if (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
482  (si::putprop 'rassoc-if-not (macro-function 'member-compiler-macro) 'compiler-macro)  (si::putprop 'rassoc-if-not (macro-function 'member-compiler-macro) 'si::compiler-macro-prop)
483    
484  ;;start end count position  ;;start end count position
485  (defun do-sequence-search (fn vars &key dest newseq (sum nil sump) pos start end count (item nil itemp) ret k1 (key nil keyp) (test ''eql) rev not)  (defun do-sequence-search (fn vars &key dest newseq (sum nil sump) pos start end count (item nil itemp) ret k1 (key nil keyp) (test ''eql) rev not)
# Line 565  Line 566 
566  ;        ((all-vectors ,@(cdr args))  ;        ((all-vectors ,@(cdr args))
567  ;         ,(do-vector-search (car args) (cdr args) :not t))  ;         ,(do-vector-search (car args) (cdr args) :not t))
568  ;        ((funcall (function every) ,@args))))  ;        ((funcall (function every) ,@args))))
569  ;(si::putprop 'every (macro-function 'every-compiler-macro) 'compiler-macro)  ;(si::putprop 'every (macro-function 'every-compiler-macro) 'si::compiler-macro-prop)
570                            
571    
572    
# Line 624  Line 625 
625                                    (setq forms (reverse fl)))))                                    (setq forms (reverse fl)))))
626                    (list 'call-local info (cddr fd) forms))                    (list 'call-local info (cddr fd) forms))
627               (c1expr (cmp-expand-macro fd fname args))))               (c1expr (cmp-expand-macro fd fname args))))
628          ((let ((fn (get fname 'compiler-macro)) (res (cons fname args)))          ((let ((fn (get fname 'si::compiler-macro-prop)) (res (cons fname args)))
629             (and fn             (and fn
630                  (let ((fd (cmp-eval `(funcall ',fn ',res nil))))                  (let ((fd (cmp-eval `(funcall ',fn ',res nil))))
631                   (and (not (eq res fd))                   (and (not (eq res fd))
# Line 1036  Line 1037 
1037  (defmacro si::define-compiler-macro (name vl &rest body)  (defmacro si::define-compiler-macro (name vl &rest body)
1038    `(progn (si:putprop ',name    `(progn (si:putprop ',name
1039                        (caddr (si:defmacro* ',name ',vl ',body))                        (caddr (si:defmacro* ',name ',vl ',body))
1040                        'compiler-macro)                        'si::compiler-macro-prop)
1041            ',name))              ',name))  
1042    
1043    (defun si::compiler-macro-function (name)
1044      (get name 'si::compiler-macro-prop))  
1045    
1046  (defun si::undef-compiler-macro (name)  (defun si::undef-compiler-macro (name)
1047    (remprop name 'compiler-macro))    (remprop name 'si::compiler-macro-prop))
1048    
1049  (defvar *compiler-temps*  (defvar *compiler-temps*
1050          '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9))          '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9))

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29

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