/[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.21 by camm, Fri Jan 7 17:58:33 2005 UTC revision 1.22 by camm, Wed Jun 29 04:15:51 2005 UTC
# Line 190  Line 190 
190  )                                      )                                    
191                                                                    
192    
193  (defun result-type-from-args (f args &aux tem)  (defun result-type-from-args (f args)
194    (when (and (setq tem (get f 'return-type))    (when (not (eq '* (get f 'return-type))) ;;FIXME  make sure return-type and proclaimed-return-type are in sync
              (not (eq tem '*)))  
 ;            (not (consp tem))) ;; propagate multiple-value types, CM 20041221  
195      (let* ((be (get f 'type-propagator))      (let* ((be (get f 'type-propagator))
196             (ba (and be (apply be f (mapcar #'coerce-to-one-value args)))))             (ba (and be (apply be f (mapcar #'coerce-to-one-value args)))))
197        (when ba        (when ba
# Line 448  Line 446 
446                (cons (bind-all-vars (caddr form))                (cons (bind-all-vars (caddr form))
447                      (if (cadddr form) (list (bind-all-vars (cadddr form))))))))                      (if (cadddr form) (list (bind-all-vars (cadddr form))))))))
448                                    
   
449  (defun c1symbol-fun (fname args &aux fd)  (defun c1symbol-fun (fname args &aux fd)
450    (cond ((setq fd (get fname 'c1special)) (funcall fd args))    (cond ((setq fd (get fname 'c1special)) (funcall fd args))
451          ((and (setq fd (get fname 'co1special))          ((and (setq fd (get fname 'co1special))
# Line 476  Line 473 
473                                    (setq forms (reverse fl)))))                                    (setq forms (reverse fl)))))
474                    (list 'call-local info (cddr fd) forms))                    (list 'call-local info (cddr fd) forms))
475               (c1expr (cmp-expand-macro fd fname args))))               (c1expr (cmp-expand-macro fd fname args))))
476            ((let ((fn (get fname 'compiler-macro)) (res (cons fname args)))
477               (and fn
478                    (let ((fd (cmp-eval `(funcall ',fn ',res nil))))
479                     (and (not (eq res fd))
480                          (c1expr fd))))))
481          ((and (setq fd (get fname 'co1))          ((and (setq fd (get fname 'co1))
482                (inline-possible fname)                (inline-possible fname)
483                (funcall fd fname args)))                (funcall fd fname args)))
# Line 497  Line 499 
499          ;;continue          ;;continue
500          ((setq fd (macro-function fname))          ((setq fd (macro-function fname))
501           (c1expr (cmp-expand-macro fd fname args)))           (c1expr (cmp-expand-macro fd fname args)))
         ((let ((fn (get fname 'compiler-macro)) res)  
            (and fn  
                 (setq res (cons fname args))  
                 (setq fd (cmp-eval `(funcall ',fn ',res nil)))  
                 (not (eq res fd))))  
          (c1expr fd))  
502          ((and (setq fd (get fname 'si::structure-access))          ((and (setq fd (get fname 'si::structure-access))
503                (inline-possible fname)                (inline-possible fname)
504                ;;; Structure hack.                ;;; Structure hack.

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

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