/[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.17 by camm, Tue Dec 14 03:34:06 2004 UTC revision 1.18 by camm, Fri Dec 17 21:29:29 2004 UTC
# Line 119  Line 119 
119                                                  ;; double eval ok.                                                  ;; double eval ok.
120           (result-type-from-args rfa)            ;; if passed args of matching           (result-type-from-args rfa)            ;; if passed args of matching
121                                                  ;; type result is of result type                                                  ;; type result is of result type
122           (is)                                   ;; extends the `integer stack'.           (is)))                                 ;; extends the `integer stack'.
          (result-type-from-bounded-args rfba))) ;; result bounds inferred from arg bounds  
123      (cond ((member flag v :test 'eq)      (cond ((member flag v :test 'eq)
124             (return-from flags-pos i)))             (return-from flags-pos i)))
125      (setq i (+ i 1)))      (setq i (+ i 1)))
# Line 190  Line 189 
189  )                                      )                                    
190                                                                    
191    
192  (defun result-type-from-args(f args &aux tem)  (defun result-type-from-args (f args &aux tem)
193    (when (and (setq tem (get f 'return-type))    (when (and (setq tem (get f 'return-type))
194               (not (eq tem '*))               (not (eq tem '*))
195               (not (consp tem)))               (not (consp tem)))
196        (let* ((be (and (not (cddr args)) (get f 'result-type-from-bounded-args)))
197               (ba (and be
198                        (or (atom be)
199                            (and (type>= (nil-to-t (car be)) (car args))
200                                 (type>= (nil-to-t (cadr be)) (cadr args))))
201                        (super-range f (car args) (cadr args)))))
202          (when ba
203            (return-from result-type-from-args ba)))
204      (dolist (v '(inline-always inline-unsafe))      (dolist (v '(inline-always inline-unsafe))
205        (dolist (w (get f v))        (dolist (w (get f v))
206          (fix-opt w)          (fix-opt w)
207          (when (and          (when (and
208                 (flag-p (third w) result-type-from-args)                 (flag-p (third w) result-type-from-args)
209                 (eql (length args) (length (car w)))                 (= (length args) (length (car w)))
210                 (do ((a args (cdr a))                 (do ((a args (cdr a)) (b (car w) (cdr b)))
                     (b (car w) (cdr b)))  
211                     ((null a) t)                     ((null a) t)
212                   (unless (or  (eq (car a) (car b))                   (unless (or  (eq (car a) (car b))
213                                (type>= (car b) (car a)))                                (type>= (car b) (car a)))
214                           (return nil))))                     (return nil))))
215            (return-from result-type-from-args (second w)))            (return-from result-type-from-args (second w)))))))
216          (when (and          
                (flag-p (third w) result-type-from-bounded-args)  
                (= 2 (length args) (length (car w)))  
                (type>= (caar w) (car args))  
                (type>= (cadar w) (cadr args)))  
           (return-from result-type-from-args (super-range f (car args) (cadr args))))))))  
   
217    
218  ;; omitting a flag means it is set to nil.  ;; omitting a flag means it is set to nil.
219  (defmacro flags (&rest lis &aux (i 0))  (defmacro flags (&rest lis &aux (i 0))
# Line 305  Line 305 
305    (let ((len (length form)))    (let ((len (length form)))
306      (declare (fixnum len))      (declare (fixnum len))
307      (if (> len 3)      (if (> len 3)
308          (multiple-value-bind (form lets) (pull-evals form)          (multiple-value-bind (form lets) (values form nil);(pull-evals form)
309            (let-wrap lets (binary-nest-int form len)))            (let-wrap lets (binary-nest-int form len)))
310        form)))        form)))
311    
# Line 383  Line 383 
383  (si::putprop '1+ (function incr-to-plus) 'compiler-macro)  (si::putprop '1+ (function incr-to-plus) 'compiler-macro)
384  (si::putprop '1- (function decr-to-minus) 'compiler-macro)  (si::putprop '1- (function decr-to-minus) 'compiler-macro)
385    
386    (defun bind-all-vars-int (form nf bindings)
387      (cond ((null form)
388             (list bindings (nreverse nf)))
389            ((consp (car form))
390             (let ((lwf (bind-all-vars-int (cdar form) (list (caar form)) bindings)))
391               (bind-all-vars-int (cdr form) (cons (cadr lwf) nf) (car lwf))))
392            (t
393             (let* ((sym (if (symbolp (car form)) (cdr (assoc (car form) bindings)) (car form)))
394                    (bindings (if sym bindings (cons (cons (car form) (gensym)) bindings)))
395                    (sym (or sym (cdar bindings))))
396               (bind-all-vars-int (cdr form) (cons sym nf) bindings)))))
397    
398    (defun bind-all-vars (form)
399      (if (atom form) form
400        (let ((res (bind-all-vars-int (cdr form) (list (car form)) nil)))
401          (if (car res)
402              (list 'let* (mapcar (lambda (x) (list (cdr x) (car x))) (nreverse (car res)))
403                    (cadr res))
404            (cadr res)))))
405    
406    
407    (defun if-protect-fun-inf (form env)
408      (declare (ignore env))
409      (cons (car form)
410            (cons (cadr form)
411                  (cons (bind-all-vars (caddr form))
412                        (if (cadddr form) (list (bind-all-vars (cadddr form))))))))
413                    
414    
415  (defun c1symbol-fun (fname args &aux fd)  (defun c1symbol-fun (fname args &aux fd)
416    (cond ((setq fd (get fname 'c1special)) (funcall fd args))    (cond ((setq fd (get fname 'c1special)) (funcall fd args))
417          ((and (setq fd (get fname 'co1special))          ((and (setq fd (get fname 'co1special))
# Line 495  Line 524 
524                                    (setq etype                                    (setq etype
525                                          (type-and (info-type info) etype))                                          (type-and (info-type info) etype))
526                                    (when (null etype)                                    (when (null etype)
527                                          (cmpwarn                                      (cmpwarn
528                                           "Type mismatch was found in ~s."                                           "Type mismatch was found in ~s."
529                                           (cons fname args)))                                           (cons fname args)))
530                                    (setf (info-type info) etype))))                                    (setf (info-type info) etype))))

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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