/[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.16 by camm, Sat Dec 11 00:34:35 2004 UTC revision 1.17 by camm, Tue Dec 14 03:34:06 2004 UTC
# Line 113  Line 113 
113    (declare (fixnum i))    (declare (fixnum i))
114    (dolist    (dolist
115        (v        (v
116         '((allocates-new-storage ans); might invoke gbc         '((allocates-new-storage ans)            ;; might invoke gbc
117           (side-effect-p set)        ; no effect on arguments           (side-effect-p set)                    ;; no effect on arguments
118           (constantp)                ; always returns same result,           (constantp)                            ;; always returns same result,
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'.
123             (result-type-from-bounded-args rfba))) ;; result bounds inferred from arg bounds
124      (cond ((member flag v :test 'eq)      (cond ((member flag v :test 'eq)
125             (return-from flags-pos i)))             (return-from flags-pos i)))
126      (setq i (+ i 1)))      (setq i (+ i 1)))
# Line 203  Line 204 
204                      (b (car w) (cdr b)))                      (b (car w) (cdr b)))
205                     ((null a) t)                     ((null a) t)
206                   (unless (or  (eq (car a) (car b))                   (unless (or  (eq (car a) (car b))
207                                (type>= (car b)(car a) ))                                (type>= (car b) (car a)))
208                           (return nil))))                           (return nil))))
209            (return-from result-type-from-args (second w)))))))            (return-from result-type-from-args (second w)))
210                                  (when (and
211                   (flag-p (third w) result-type-from-bounded-args)
212                   (= 2 (length args) (length (car w)))
213                   (type>= (caar w) (car args))
214                   (type>= (cadar w) (cadr args)))
215              (return-from result-type-from-args (super-range f (car args) (cadr args))))))))
216    
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 289  Line 296 
296  ;     ,form)))  ;     ,form)))
297    
298  (defmacro let-wrap (lets form)  (defmacro let-wrap (lets form)
299    (let ((decls (gensym)))    `(if lets
300      `(if lets         (list 'let* ,lets ,form)
301           (list 'let* ,lets ,form)       ,form))
      ,form)))  
302    
303  (defun binary-nest (form env)  (defun binary-nest (form env)
304    (declare (ignore env))    (declare (ignore env))
# Line 366  Line 372 
372  (si::putprop 'char/= (function logical-outer-nest) 'compiler-macro)  (si::putprop 'char/= (function logical-outer-nest) 'compiler-macro)
373    
374    
375    (defun incr-to-plus (form env)
376      (declare (ignore env))
377      `(+ ,(cadr form) 1))
378    
379    (defun decr-to-minus (form env)
380      (declare (ignore env))
381      `(- ,(cadr form) 1))
382    
383    (si::putprop '1+ (function incr-to-plus) 'compiler-macro)
384    (si::putprop '1- (function decr-to-minus) 'compiler-macro)
385    
386  (defun c1symbol-fun (fname args &aux fd)  (defun c1symbol-fun (fname args &aux fd)
387    (cond ((setq fd (get fname 'c1special)) (funcall fd args))    (cond ((setq fd (get fname 'c1special)) (funcall fd args))
388          ((and (setq fd (get fname 'co1special))          ((and (setq fd (get fname 'co1special))
# Line 438  Line 455 
455          (t (let* ((info (make-info          (t (let* ((info (make-info
456                          :sp-change (null (get fname 'no-sp-change))))                          :sp-change (null (get fname 'no-sp-change))))
457                    (forms (c1args args info))) ;; info updated by args here                    (forms (c1args args info))) ;; info updated by args here
458                  (let ((return-type (get-return-type fname)))               (let ((return-type (get-return-type fname)))
459                    (when return-type                    (when return-type
460                          (if (equal return-type '(*))                          (if (equal return-type '(*))
461                              (setf return-type nil)                              (setf return-type nil)
# Line 505  Line 522 
522                                    ))))                                    ))))
523                  ;; some functions can have result type deduced from                  ;; some functions can have result type deduced from
524                  ;; arg types.                  ;; arg types.
525                    
526                  (let ((tem (result-type-from-args fname                  (let ((tem (result-type-from-args fname
527                                                    (mapcar #'(lambda (x) (info-type (cadr x)))                                                    (mapcar #'(lambda (x) (info-type (cadr x)))
528                                                            forms))))                                                            forms))))
# Line 747  Line 764 
764          (list x y (list 'call-global (make-info) 'side-effects nil))          (list x y (list 'call-global (make-info) 'side-effects nil))
765          (if (eq type t) '(t t t)          (if (eq type t) '(t t t)
766     `(t ,tftype t))))     `(t ,tftype t))))
767      
768    (setq ix (car locs))    (setq ix (car locs))
769    (setq iy (cadr locs))    (setq iy (cadr locs))
770    (if *safe-compile* (wfs-error))    (if *safe-compile* (wfs-error))
# Line 762  Line 779 
779     ((eq val nil) (c1nil))     ((eq val nil) (c1nil))
780     ((eq val t) (c1t))     ((eq val t) (c1t))
781     ((si:fixnump val)     ((si:fixnump val)
782      (list 'LOCATION (make-info :type 'fixnum)      (list 'LOCATION (make-info :type (list 'integer val val)) ;;FIXME -- 1024 should be small fixnum limit
783            (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val))            (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val))
784                  val)))                  val)))
785     ((characterp val)     ((characterp val)

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

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