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