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 |
|
|
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)) |
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)) |
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)) |
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) |
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* |
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))) |
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)) |
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)) |
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)) |
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) |
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 |
|
|
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)) |
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)) |