387 |
(defun do-num-relations (fn args) |
(defun do-num-relations (fn args) |
388 |
(let* ((info (make-info)) |
(let* ((info (make-info)) |
389 |
(nargs (c1args args info)) |
(nargs (c1args args info)) |
390 |
(t1 (and (cddr args) (info-type (cadar nargs)))) |
(t1 (and (car args) (info-type (cadar nargs)))) |
391 |
(t2 (and (cddr args) (info-type (cadadr nargs)))) |
(t2 (and (cadr args) (info-type (cadadr nargs)))) |
392 |
(r (and t1 t2 (num-type-rel fn t1 t2)))) |
(r (and t1 t2 (num-type-rel fn t1 t2)))) |
393 |
(cond ((cddr args) (list 'call-global info fn nargs)) |
(cond ((cddr args) (list 'call-global info fn nargs)) |
394 |
((car r) (c1expr t)) |
((car r) (c1expr t)) |
409 |
|
|
410 |
|
|
411 |
(defun list-tp-test (tf lt) |
(defun list-tp-test (tf lt) |
412 |
(cond ((null lt) (values t t)) |
(cond ((atom lt) (let ((z (funcall tf lt))) (values z z))) |
|
((atom lt) (values nil nil)) |
|
413 |
((eq (car lt) 'cons) |
((eq (car lt) 'cons) |
414 |
(multiple-value-bind |
(multiple-value-bind |
415 |
(m1 f1) (funcall tf (cadr lt)) |
(m1 f1) (funcall tf (cadr lt)) |
416 |
(multiple-value-bind |
(multiple-value-bind |
417 |
(m2 f2) (list-tp-test tf (caddr lt)) |
(m2 f2) (list-tp-test tf (caddr lt)) |
418 |
(values (and m1 m2) (or f1 f2))))) |
(values (and m1 m2) (or f1 f2))))) |
419 |
(t (values nil nil)))) |
((list-tp-test tf (car lt))))) |
420 |
|
; (t (values nil nil)))) |
421 |
|
|
422 |
(defun test-to-tf (test) |
(defun test-to-tf (test) |
423 |
(let ((test (if (constantp test) (cmp-eval test) test))) |
(let ((test (if (constantp test) (cmp-eval test) test))) |
457 |
((list 'call-global info fn nargs)))))) |
((list 'call-global info fn nargs)))))) |
458 |
(dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g))) |
(dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g))) |
459 |
|
|
460 |
(defun c1or (args) |
;(defun c1or (args) |
461 |
(cond ((null args) (c1expr nil)) |
; (cond ((null args) (c1expr nil)) |
462 |
((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args))))) |
; ((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args))))) |
463 |
((null (cdr args)) (c1expr (car args))) |
; ((null (cdr args)) (c1expr (car args))) |
464 |
((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args)))) |
; ((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args)))) |
465 |
((let ((info (make-info))) (list 'call-global info 'or (c1args args info)))))) |
; ((let ((info (make-info))) (list 'call-global info 'or (c1args args info)))))) |
466 |
(si::putprop 'or 'c1or 'c1) |
;(si::putprop 'or 'c1or 'c1) |
467 |
|
|
468 |
(defun cmp-array-element-type (&rest args) |
(defun cmp-array-element-type (&rest args) |
469 |
(and |
(and |
706 |
(t t))) |
(t t))) |
707 |
|
|
708 |
|
|
|
;(defvar *std-instance-class-type* nil) |
|
|
;(defvar *std-instance-symbol* nil) |
|
|
|
|
709 |
(defun co1typep (f args &aux tem) f |
(defun co1typep (f args &aux tem) f |
710 |
(let* ((x (car args)) new |
(let* ((x (car args)) new |
711 |
(type (and (literalp (cadr args)) (cmp-eval (cadr args))))) |
(type (and (literalp (cadr args)) (cmp-eval (cadr args))))) |
|
; (unless *std-instance-symbol* |
|
|
; (setq *std-instance-symbol* (let ((p (find-package 'pcl))) (and p (find-symbol "STD-INSTANCE" p))))) |
|
|
; (when (eq type *std-instance-symbol*) |
|
|
; (unless *std-instance-class-type* |
|
|
; (let* ((p (find-package 'pcl)) |
|
|
; (s (and p (find-symbol "SLOT-OBJECT" p))) |
|
|
; (si (and s (import s 'compiler))) |
|
|
; (q (and p (find-symbol "FUNCALLABLE-STANDARD-OBJECT" p))) |
|
|
; (qi (and q (import q 'compiler)))) |
|
|
; (when (and si qi) |
|
|
; (setq *std-instance-class-type* `(and ,s (not ,q))))))) |
|
|
; (let ((type (or (and (eq type *std-instance-symbol*) *std-instance-class-type*) type))) |
|
712 |
(let ((rt (result-type (car args)))) |
(let ((rt (result-type (car args)))) |
713 |
; (format t "~a ~a ~a ~a ~a ~a~%" type rt (car args) (subtypep rt type) (multiple-value-list (subtypep type rt)) (type-and type rt)) |
; (format t "~a ~a ~a ~a ~a ~a~%" type rt (car args) (subtypep rt type) (multiple-value-list (subtypep type rt)) (type-and type rt)) |
714 |
(cond ((subtypep rt type) |
(cond ((subtypep rt type) |
715 |
(setq new t) |
(setq new t) |
716 |
(return-from co1typep (c1expr new))) |
(return-from co1typep (c1expr new))) |
717 |
|
;;FIXME only need type-and here when finalized |
718 |
((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt))) |
((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt))) |
719 |
(setq new nil) |
(setq new nil) |
720 |
(return-from co1typep (c1expr new))))) |
(return-from co1typep (c1expr new))))) |
|
;) |
|
721 |
(setq new |
(setq new |
722 |
(cond |
(cond |
723 |
((null type) nil) |
((null type) nil) |
1092 |
(defun c1list (args) |
(defun c1list (args) |
1093 |
(let* ((info (make-info)) |
(let* ((info (make-info)) |
1094 |
(nargs (c1args args info))) |
(nargs (c1args args info))) |
1095 |
(setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(nil)) :from-end t))) |
(setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(null)) :from-end t))) |
1096 |
(list 'call-global info 'list nargs))); |
(list 'call-global info 'list nargs))); |
1097 |
(si::putprop 'list 'c1list 'c1) |
(si::putprop 'list 'c1list 'c1) |
1098 |
|
|