/[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.22 by camm, Wed Jun 29 04:15:51 2005 UTC revision 1.23 by camm, Sat Jul 23 08:47:27 2005 UTC
# Line 1  Line 1 
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
# Line 197  Line 198 
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.
# Line 418  Line 422 
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)))
# Line 481  Line 620 
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))
# Line 519  Line 662 
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)))
# Line 609  Line 752 
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)

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

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