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))))) |
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)) |
(ta (type-and rt type))) |
714 |
(cond ((subtypep rt type) |
; (format t "~a ~a ~a ~a~%" type rt ta (eq ta rt)) |
715 |
|
(cond ((eq ta rt) |
716 |
(setq new t) |
(setq new t) |
717 |
(return-from co1typep (c1expr new))) |
(return-from co1typep (c1expr new))) |
718 |
;;FIXME only need type-and here when finalized |
((and type (not ta)) |
|
((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 |
969 |
|
|
970 |
|
|
971 |
|
|
972 |
(defvar *aet-types* |
(defvar *aet-types* ;FIXME generate and centralize |
973 |
#(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT |
#(T STRING-CHAR SIGNED-CHAR FIXNUM NON-NEGATIVE-FIXNUM SHORT-FLOAT LONG-FLOAT |
974 |
SIGNED-CHAR |
SIGNED-CHAR NON-NEGATIVE-CHAR |
975 |
UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) |
UNSIGNED-CHAR SIGNED-SHORT NON-NEGATIVE-SHORT UNSIGNED-SHORT)) |
976 |
|
|
977 |
|
|
978 |
(defun aet-c-type (type) |
(defun aet-c-type (type) |
979 |
(ecase type |
(ecase type |
980 |
((t) "object") |
((t) "object") |
981 |
((string-char signed-char) "char") |
((string-char signed-char non-negative-char) "char") |
982 |
(fixnum "fixnum") |
((non-negative-fixnum fixnum) "fixnum") |
983 |
(unsigned-char "unsigned char") |
(unsigned-char "unsigned char") |
984 |
(signed-short "short") |
((signed-short non-negative-short) "short") |
985 |
(unsigned-short "unsigned short") |
(unsigned-short "unsigned short") |
986 |
(long-float "longfloat") |
(long-float "longfloat") |
987 |
(short-float "shortfloat"))) |
(short-float "shortfloat"))) |