391 |
(t2 (and (cadr 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 info)) |
395 |
((cadr r) (c1expr nil)) |
((cadr r) (c1expr** nil info)) |
396 |
((list 'call-global info fn nargs))))) |
((list 'call-global info fn nargs))))) |
397 |
|
|
398 |
(dolist (l `(>= > < <= = /=)) |
(dolist (l `(>= > < <= = /=)) |
435 |
(tf (cadr ltf)) |
(tf (cadr ltf)) |
436 |
(info (make-info))) |
(info (make-info))) |
437 |
(if (not tf) |
(if (not tf) |
438 |
(c1expr nil) |
(c1expr** nil info) |
439 |
(let ((nargs (c1args (cdr args) info))) |
(let ((nargs (c1args (cdr args) info))) |
440 |
(multiple-value-bind |
(multiple-value-bind |
441 |
(m1 f1) (funcall tf (info-type (cadar nargs))) |
(m1 f1) (funcall tf (info-type (cadar nargs))) |
442 |
(multiple-value-bind |
(multiple-value-bind |
443 |
(m2 f2) (list-tp-test tf (info-type (cadadr nargs))) |
(m2 f2) (list-tp-test tf (info-type (cadadr nargs))) |
444 |
(declare (ignore f2)) |
(declare (ignore f2)) |
445 |
(cond ((or m1 m2) (c1expr t)) |
(cond ((or m1 m2) (c1expr** t info)) |
446 |
(f1 (c1expr nil)) |
(f1 (c1expr** nil info)) |
447 |
((let ((info (make-info))) (list 'call-global info (car ltf) (c1args (list (cadr args)) info))))))))))) |
((let ((info (make-info))) |
448 |
|
(list 'call-global info (car ltf) (c1args (list (cadr args)) info))))))))))) |
449 |
(si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1) |
(si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1) |
450 |
|
|
451 |
(defun do-predicate (fn args) |
(defun do-predicate (fn args) |
452 |
(let* ((info (make-info)) |
(let* ((info (make-info)) |
453 |
(nargs (c1args args info)) |
(nargs (c1args args info)) |
454 |
(tp (car (rassoc fn *type-alist*)))) |
(tp (car (rassoc fn *type-alist*)))) |
455 |
(let ((at (and (not (cdr args)) (info-type (cadar nargs))))) |
(let ((at (and (not (cdr args)) (info-type (cadar nargs))))) |
456 |
(cond ((and at (subtypep at tp)) (c1expr t)) |
(cond ((and at (subtypep at tp)) (c1expr** t info)) |
457 |
((not (type-and at tp)) (c1expr nil)) |
((not (type-and at tp)) (c1expr** nil info)) |
458 |
((list 'call-global info fn nargs)))))) |
((list 'call-global info fn nargs)))))) |
459 |
(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))) |
460 |
|
|
733 |
(equal (third type) '(*))))) |
(equal (third type) '(*))))) |
734 |
(setq tem (si::best-array-element-type |
(setq tem (si::best-array-element-type |
735 |
(second type))) |
(second type))) |
736 |
(cond ((eq tem 'string-char) `(stringp ,x)) |
(cond ((eq tem 'character) `(stringp ,x)) |
737 |
((eq tem 'bit) `(bit-vector-p ,x)) |
((eq tem 'bit) `(bit-vector-p ,x)) |
738 |
((setq tem (position tem *aet-types*)) |
((setq tem (position tem +array-types+)) |
739 |
`(the boolean (vector-type ,x ,tem))))) |
`(the boolean (vector-type ,x ,tem))))) |
740 |
((and (consp type) |
((and (consp type) |
741 |
(eq (car type) 'satisfies) |
(eq (car type) 'satisfies) |
970 |
|
|
971 |
|
|
972 |
|
|
|
(defvar *aet-types* ;FIXME generate and centralize |
|
|
#(T STRING-CHAR SIGNED-CHAR FIXNUM NON-NEGATIVE-FIXNUM SHORT-FLOAT LONG-FLOAT |
|
|
SIGNED-CHAR NON-NEGATIVE-CHAR |
|
|
UNSIGNED-CHAR SIGNED-SHORT NON-NEGATIVE-SHORT UNSIGNED-SHORT)) |
|
|
|
|
973 |
|
|
974 |
(defun aet-c-type (type) |
(defun aet-c-type (type) |
975 |
(ecase type |
(ecase type |
976 |
((t) "object") |
((t) "object") |
977 |
((string-char signed-char non-negative-char) "char") |
((character signed-char non-negative-char) "char") |
978 |
((non-negative-fixnum fixnum) "fixnum") |
((non-negative-fixnum fixnum) "fixnum") |
979 |
(unsigned-char "unsigned char") |
(unsigned-char "unsigned char") |
980 |
((signed-short non-negative-short) "short") |
((signed-short non-negative-short) "short") |
981 |
(unsigned-short "unsigned short") |
(unsigned-short "unsigned short") |
982 |
|
((signed-int non-negative-int) "int") |
983 |
|
(unsigned-int "unsigned int") |
984 |
(long-float "longfloat") |
(long-float "longfloat") |
985 |
(short-float "shortfloat"))) |
(short-float "shortfloat"))) |
986 |
|
|