117 |
(atom . atom) |
(atom . atom) |
118 |
(cons . consp) |
(cons . consp) |
119 |
(list . listp) |
(list . listp) |
120 |
|
(fixnum . fixnump) |
121 |
|
(integer . integerp) |
122 |
|
(rational . rationalp) |
123 |
(number . numberp) |
(number . numberp) |
124 |
(character . characterp) |
(character . characterp) |
125 |
(package . packagep) |
(package . packagep) |
135 |
) |
) |
136 |
(cdr l))) |
(cdr l))) |
137 |
((endp l)) |
((endp l)) |
138 |
(si:putprop (caar l) (cdar l) 'type-predicate)) |
(si:putprop (caar l) (cdar l) 'type-predicate) |
139 |
|
(si:putprop (cdar l) (caar l) 'predicate-type)) |
140 |
|
|
141 |
(defun class-of (object) |
(defun class-of (object) |
142 |
(declare (ignore object)) |
(declare (ignore object)) |
260 |
;;; The result is always a list. |
;;; The result is always a list. |
261 |
(defun normalize-type (type &aux tp i ) |
(defun normalize-type (type &aux tp i ) |
262 |
;; Loops until the car of type has no DEFTYPE definition. |
;; Loops until the car of type has no DEFTYPE definition. |
263 |
|
(when (and (consp type) (eq (car type) 'satisfies)) |
264 |
|
(unless (setq tp (get (cadr type) 'predicate-type)) |
265 |
|
(error "Cannot process type ~S~%" type)) |
266 |
|
(setq type tp)) |
267 |
(loop |
(loop |
268 |
(if (atom type) |
(if (atom type) |
269 |
(setq tp type i nil) |
(setq tp type i nil) |
275 |
|
|
276 |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
277 |
;;; The type may not be normalized. |
;;; The type may not be normalized. |
278 |
|
;; FIXME this needs to be more robust |
279 |
(defun known-type-p (type) |
(defun known-type-p (type) |
280 |
(when (consp type) (setq type (car type))) |
(when (consp type) (setq type (car type))) |
281 |
(if (or (equal (string type) "ERROR") |
(if (or (equal (string type) "ERROR") |
320 |
(values t t) (values nil t)))) |
(values t t) (values nil t)))) |
321 |
(when (or c1 c2) |
(when (or c1 c2) |
322 |
(return-from subtypep (values nil t)))) |
(return-from subtypep (values nil t)))) |
323 |
(setq t1 (normalize-type type1)) |
(setq type1 (normalize-type type1)) |
324 |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
(setq type2 (normalize-type type2)) |
|
(setq t2 (normalize-type type2)) |
|
|
(setq type2 (if (eq (car t2) 'satisfies) (list type2) t2)) |
|
|
; (setq type1 (normalize-type type1)) |
|
|
; (setq type2 (normalize-type type2)) |
|
325 |
(when (equal type1 type2) |
(when (equal type1 type2) |
326 |
(return-from subtypep (values t t))) |
(return-from subtypep (values t t))) |
327 |
(setq t1 (car type1) t2 (car type2)) |
(setq t1 (car type1) t2 (car type2)) |