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))) |
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)) |
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)) |
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)) |
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) |
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)))) |
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)) |
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) |