1 |
|
;; -*-Lisp-*- |
2 |
;;; CMPEVAL The Expression Dispatcher. |
;;; CMPEVAL The Expression Dispatcher. |
3 |
;;; |
;;; |
4 |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
198 |
(when ba |
(when ba |
199 |
(return-from result-type-from-args ba))) |
(return-from result-type-from-args ba))) |
200 |
(dolist (v '(inline-always inline-unsafe)) |
(dolist (v '(inline-always inline-unsafe)) |
201 |
(dolist (w (get f v)) |
(let* ((w (get f v))) |
202 |
(fix-opt w) |
(if (and w (symbolp (caar w)) (flag-p (third (car w)) itf)) |
203 |
(when (and |
(return-from result-type-from-args (cadr (apply (caar w) args))) |
204 |
(flag-p (third w) result-type-from-args) |
(dolist (w w) |
205 |
(= (length args) (length (car w))) |
(fix-opt w) |
206 |
(do ((a args (cdr a)) (b (car w) (cdr b))) |
(when (and |
207 |
((null a) t) |
(flag-p (third w) result-type-from-args) |
208 |
(unless (and (car a) (car b) |
(= (length args) (length (car w))) |
209 |
(or (eq (car a) (car b)) |
(do ((a args (cdr a)) (b (car w) (cdr b))) |
210 |
(type>= (car b) (car a)))) |
((null a) t) |
211 |
(return nil)))) |
(unless (and (car a) (car b) |
212 |
(return-from result-type-from-args (second w))))))) |
(or (eq (car a) (car b)) |
213 |
|
(type>= (car b) (car a)))) |
214 |
|
(return nil)))) |
215 |
|
(return-from result-type-from-args (second w))))))))) |
216 |
|
|
217 |
|
|
218 |
;; omitting a flag means it is set to nil. |
;; omitting a flag means it is set to nil. |
422 |
|
|
423 |
(si::putprop 'array-dimension (function array-dimension-expander) 'compiler-macro) |
(si::putprop 'array-dimension (function array-dimension-expander) 'compiler-macro) |
424 |
|
|
425 |
|
(defun do-list-search (test list &key (k1 nil k1p) (key nil keyp) (item nil itemp) rev (ret nil retp) test-not ((:test foo))) |
426 |
|
(declare (ignore foo)) |
427 |
|
(let* ((x (gensym)) |
428 |
|
(rf (if retp `(funcall ,ret ,x) x)) |
429 |
|
(el (if k1p `(funcall ,k1 ,rf) rf)) |
430 |
|
(el (if keyp `(funcall ,key ,el) el)) |
431 |
|
(tf (if itemp `(funcall ,test ,(if rev el item) ,(if rev item el)) `(funcall ,test ,el))) |
432 |
|
(tf (if test-not `(not ,tf) tf)) |
433 |
|
(tf (if retp `(and ,rf ,tf) tf)) |
434 |
|
(ef `(or (not ,x) ,tf))) |
435 |
|
`(do ((,x ,list (cdr ,x))) (,ef ,rf)))) |
436 |
|
|
437 |
|
(defun possible-eq-list-search (item list special-keys &rest r &key key (test ''eql) (test-not nil test-notp)) |
438 |
|
(declare (ignore key)) |
439 |
|
(let* ((test (if test-notp test-not test)) |
440 |
|
(test (if (and (consp test) (eq (car test) 'function)) `(quote ,(cadr test)) test)) |
441 |
|
(r `(,@special-keys ,@r))) |
442 |
|
(let ((form (apply 'do-list-search test list r))) |
443 |
|
(if (member :item special-keys) |
444 |
|
`(if (is-eq-test-item-list ,test ,item ,list); (and (eq ,test 'eql) (eql-is-eq ,item ,test ,list)) |
445 |
|
,(apply 'do-list-search ''eq list r) |
446 |
|
,form) |
447 |
|
form)))) |
448 |
|
|
449 |
|
(defmacro member-compiler-macro (&whole w &rest args) |
450 |
|
(if (or (< (length args) 2) (do ((r (cddr args) (cddr r))) ((not (and r (keywordp (car r)))) r))) |
451 |
|
w |
452 |
|
(let* ((specials (if (member (car w) '(rassoc rassoc-if rassoc-if-not)) '(:k1 'cdr) '(:k1 'car))) |
453 |
|
(specials (if (member (car w) '(member assoc rassoc)) `(:item ,(car args) ,@specials) specials)) |
454 |
|
(specials (if (member (car w) '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not)) |
455 |
|
`(:ret 'car ,@specials) specials)) |
456 |
|
(overrides (if (member (car w) '(member-if assoc-if rassoc-if)) `(:test ,(car args)))) |
457 |
|
(overrides (if (member (car w) '(member-if-not assoc-if-not rassoc-if-not)) |
458 |
|
`(:test-not ,(car args) ,@overrides) overrides))) |
459 |
|
(apply 'possible-eq-list-search (car args) (cadr args) specials `(,@overrides ,@(cddr args)))))) |
460 |
|
|
461 |
|
(si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro) |
462 |
|
(si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro) |
463 |
|
(si::putprop 'member-if-not (macro-function 'member-compiler-macro) 'compiler-macro) |
464 |
|
(si::putprop 'assoc (macro-function 'member-compiler-macro) 'compiler-macro) |
465 |
|
(si::putprop 'assoc-if (macro-function 'member-compiler-macro) 'compiler-macro) |
466 |
|
(si::putprop 'assoc-if-not (macro-function 'member-compiler-macro) 'compiler-macro) |
467 |
|
(si::putprop 'rassoc (macro-function 'member-compiler-macro) 'compiler-macro) |
468 |
|
(si::putprop 'rassoc-if (macro-function 'member-compiler-macro) 'compiler-macro) |
469 |
|
(si::putprop 'rassoc-if-not (macro-function 'member-compiler-macro) 'compiler-macro) |
470 |
|
|
471 |
|
;;start end count position |
472 |
|
(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) |
473 |
|
(let* ( |
474 |
|
|
475 |
|
(gs (mapcar (lambda (x) (list (gensym) x)) vars)) |
476 |
|
|
477 |
|
(l (gensym)) |
478 |
|
(lf (mapcar (lambda (x) `(length ,x)) vars)) |
479 |
|
(lf (if dest `((if (typep ,dest 'list) (length ,dest) (array-dimension ,dest 0)) ,@lf) lf)) |
480 |
|
(lf (if end `(,end ,@lf) lf)) |
481 |
|
(lf (if (> (length lf) 1) (cons 'min lf) (car lf))) |
482 |
|
; (lf `(if (and (not ,dest) (not (eq ,newseq :vector)) ,@(mapcar (lambda (x) `(typep ,x 'list)) vars)) -1 ,lf)) |
483 |
|
(lf `(if (or ,pos ,start ,end ,dest (eq ,newseq :vector) ,@(mapcar (lambda (x) `(typep ,x 'vector)) vars)) ,lf -1)) |
484 |
|
(lf `((,l ,lf))) |
485 |
|
(i (gensym)) |
486 |
|
|
487 |
|
(tf (mapcar (lambda (x) `(if (typep ,(cadr x) 'list) (car ,(car x)) (aref ,(cadr x) ,i))) gs)) |
488 |
|
(tf (if ret (mapcar (lambda (x) `(funcall ,ret ,x)) tf) tf)) |
489 |
|
(tf (if k1 (mapcar (lambda (x) `(funcall ,k1 ,x)) tf) tf)) |
490 |
|
(tf (if keyp (mapcar (lambda (x) `(funcall ,key ,x)) tf) tf)) |
491 |
|
(first (car (if rev (last tf) tf))) |
492 |
|
(out (gensym)) |
493 |
|
(lh (gensym)) |
494 |
|
(sv (gensym)) |
495 |
|
(p (gensym)) |
496 |
|
(cv (gensym)) |
497 |
|
(tmp (gensym)) |
498 |
|
(tf (if sump (cons sv tf) tf)) |
499 |
|
(tf (if itemp (if (and (not sump) (= (length vars) 1)) (cons item tf) (baboon)) tf)) |
500 |
|
(tf (if rev (nreverse tf) tf)) |
501 |
|
(tf `(funcall ,fn ,@tf)) |
502 |
|
(tf (if not `(not ,tf) tf)) |
503 |
|
|
504 |
|
(tf (if (and sump (not sum)) (if (= (length vars) 1) `(if ,sv ,tf ,first) (baboon)) tf)) |
505 |
|
|
506 |
|
(inf (mapcar (lambda (x) `(,(car x) ,(cadr x) (if (typep ,(cadr x) 'list) (cdr ,(car x)) ,(car x)))) gs)) |
507 |
|
(inf `((,i 0 (if (>= ,l 0) (+ ,i 1) ,i)) ,@inf)) |
508 |
|
|
509 |
|
(lf `(,@lf (,out (when (eq ,newseq :vector) |
510 |
|
(make-array ,l :fill-pointer ,l :element-type (cmp-array-element-type ,@vars)))))) |
511 |
|
(lf `(,@lf (,p (when (typep ,dest 'cons) ,dest)))) |
512 |
|
(lf `(,@lf (,sv ,sum))) |
513 |
|
(lf `(,@lf (,cv 0))) |
514 |
|
(lf `(,@lf ,lh)) |
515 |
|
(inf `((,p ,p (if (typep ,dest 'cons) (cdr ,p) ,p)) ,@inf)) |
516 |
|
(tf `(cond ((typep ,dest 'cons) (setf (car ,p) ,tf) nil) |
517 |
|
((typep ,dest 'vector) (setf (aref ,dest ,i) ,tf) nil) |
518 |
|
((eq ,newseq :list) |
519 |
|
(setf |
520 |
|
(car (setq ,p (let ((,tmp (cons nil nil))) (if ,p (cdr (rplacd ,p ,tmp)) (setq ,lh ,tmp))))) |
521 |
|
,tf) nil) |
522 |
|
((eq ,newseq :vector) (setf (aref ,out ,i) ,tf) nil) |
523 |
|
(,sump (setq ,sv ,tf) nil) |
524 |
|
(,count (when ,tf (incf ,cv)) nil) |
525 |
|
(,tf))) |
526 |
|
(tf (if start `(when (>= ,i ,start) ,tf) tf)) |
527 |
|
(tf (if ret `(and (funcall ,ret ,(car vars)) ,tf) tf)) |
528 |
|
;;FIXME the or problem if possible |
529 |
|
(ef `(if (and (>= ,l 0) (= ,i ,l)) t |
530 |
|
,(reduce (lambda (x y) `(if (and (typep ,(cadr x) 'list) (not ,(car x))) t ,y)) gs |
531 |
|
:initial-value tf :from-end t))) |
532 |
|
(rf `(cond (,dest ,dest) ((eq ,newseq :list) ,lh) ((eq ,newseq :vector) ,out) (,sump ,sv) (,count ,cv) (,pos ,i) (,(if ret `(funcall ,ret ,(caar gz)) (caar gs))))) |
533 |
|
|
534 |
|
) |
535 |
|
`(let* ,lf |
536 |
|
(when (typep ,dest 'vector) |
537 |
|
(setf (fill-pointer ,dest) ,l)) |
538 |
|
(do ,inf (,ef ,rf)(declare (seqind ,i ,cv)))))) |
539 |
|
|
540 |
|
(defun do-vector-map (fn vars &key (not nil notp)) |
541 |
|
(let ((i (gensym)) (l (gensym))) |
542 |
|
(let* ((tf `(funcall ,fn ,@(mapcar (lambda (x) `(aref ,x ,i)) vars))) |
543 |
|
(tf (if notp `(not ,tf) tf)) |
544 |
|
(lf (mapcar (lambda (x) `(array-dimension ,x 0)) vars)) |
545 |
|
(lf (if (= (length lf) 1) lf `(min ,@lf)))) |
546 |
|
`(let ((,l ,lf)) |
547 |
|
(do ((,i 0 (+ ,i 1))) ((or (= ,i ,l) ,tf) (= ,i ,l)) |
548 |
|
(declare (seqind ,i)) ))))) |
549 |
|
|
550 |
|
;(defmacro every-compiler-macro (&whole w &rest args) |
551 |
|
; `(cond ((all-lists ,@(cdr args)) |
552 |
|
; (not (member-if-not ,@args))) |
553 |
|
; ((all-vectors ,@(cdr args)) |
554 |
|
; ,(do-vector-search (car args) (cdr args) :not t)) |
555 |
|
; ((funcall (function every) ,@args)))) |
556 |
|
;(si::putprop 'every (macro-function 'every-compiler-macro) 'compiler-macro) |
557 |
|
|
558 |
|
|
559 |
|
|
560 |
(defun bind-all-vars-int (form nf bindings) |
(defun bind-all-vars-int (form nf bindings) |
561 |
(cond ((null form) |
(cond ((null form) |
562 |
(list bindings (nreverse nf))) |
(list bindings (nreverse nf))) |
620 |
((and (setq fd (get fname 'co1)) |
((and (setq fd (get fname 'co1)) |
621 |
(inline-possible fname) |
(inline-possible fname) |
622 |
(funcall fd fname args))) |
(funcall fd fname args))) |
623 |
|
((and (get fname 'c1no-side-effects) (every 'constantp args)) |
624 |
|
(c1expr `(quote ,(cmp-eval `(,fname ,@args))))) |
625 |
((and (setq fd (get fname 'c1)) (inline-possible fname)) |
((and (setq fd (get fname 'c1)) (inline-possible fname)) |
626 |
(funcall fd args)) |
(funcall fd args)) |
627 |
|
((and (setq fd (get fname 'c1g)) (inline-possible fname)) |
628 |
|
(funcall fd fname args)) |
629 |
((and (setq fd (get fname 'c1conditional)) |
((and (setq fd (get fname 'c1conditional)) |
630 |
(inline-possible fname) |
(inline-possible fname) |
631 |
(funcall (car fd) args)) |
(funcall (car fd) args)) |
662 |
(forms (c1args args info))) ;; info updated by args here |
(forms (c1args args info))) ;; info updated by args here |
663 |
(let ((return-type (get-return-type fname))) |
(let ((return-type (get-return-type fname))) |
664 |
(when return-type |
(when return-type |
665 |
(if (equal return-type '(*)) |
(if (or (eq return-type '*) (equal return-type '(*))) |
666 |
(setf return-type nil) |
(setf return-type nil) |
667 |
(setf (info-type info) return-type)))) |
(setf (info-type info) return-type)))) |
668 |
(let ((arg-types (get-arg-types fname))) |
(let ((arg-types (get-arg-types fname))) |
752 |
|
|
753 |
|
|
754 |
(defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t))) |
(defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t))) |
755 |
(setq args (c1args args info)) |
(if (not (intersection '(&optional &rest &key &aux &allow-other-keys) (car lambda-expr))) |
756 |
(setq lambda-expr (c1lambda-expr lambda-expr)) |
(c1expr |
757 |
(add-info info (cadr lambda-expr)) |
`(let* (,@(mapcar (lambda (x y) (list x y)) (car lambda-expr) args)) |
758 |
(list 'call-lambda info lambda-expr args) |
,@(cdr lambda-expr))) |
759 |
) |
(progn |
760 |
|
(setq args (c1args args info)) |
761 |
|
(setq lambda-expr (c1lambda-expr lambda-expr)) |
762 |
|
(add-info info (cadr lambda-expr)) |
763 |
|
(list 'call-lambda info lambda-expr args)))) |
764 |
|
|
765 |
(defun c2expr (form) |
(defun c2expr (form) |
766 |
(if (eq (car form) 'call-global) |
(if (eq (car form) 'call-global) |