134 |
((endp l)) |
((endp l)) |
135 |
(si:putprop (caar l) (cdar l) 'type-predicate)) |
(si:putprop (caar l) (cdar l) 'type-predicate)) |
136 |
|
|
137 |
|
(defun class-of (object) |
138 |
|
(declare (ignore object)) |
139 |
|
nil) |
140 |
|
(defun classp (object) |
141 |
|
(declare (ignore object)) |
142 |
|
nil) |
143 |
|
(defun class-precedence-list (object) |
144 |
|
(declare (ignore object)) |
145 |
|
nil) |
146 |
|
|
147 |
;;; TYPEP predicate. |
;;; TYPEP predicate. |
148 |
|
;;; FIXME --optimize with most likely cases first |
149 |
(defun typep (object type &aux tp i tem) |
(defun typep (object type &aux tp i tem) |
150 |
|
(when (classp type) |
151 |
|
(return-from typep (eq (funcall 'class-of object) type))) |
152 |
(if (atom type) |
(if (atom type) |
153 |
(setq tp type i nil) |
(setq tp type i nil) |
154 |
(setq tp (car type) i (cdr type))) |
(setq tp (car type) i (cdr type))) |
282 |
|
|
283 |
;;; SUBTYPEP predicate. |
;;; SUBTYPEP predicate. |
284 |
(defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
(defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
285 |
|
(let ((c1 (classp type1)) (c2 (classp type2))) |
286 |
|
(when (and c1 c2) |
287 |
|
(return-from subtypep |
288 |
|
(if (member type2 (class-precedence-list type1)) |
289 |
|
(values t t) (values nil t)))) |
290 |
|
(when (or c1 c2) |
291 |
|
(return-from subtypep (values nil t)))) |
292 |
(setq t1 (normalize-type type1)) |
(setq t1 (normalize-type type1)) |
293 |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
294 |
(setq t2 (normalize-type type2)) |
(setq t2 (normalize-type type2)) |
695 |
(when (typep object type) |
(when (typep object type) |
696 |
;; Just return as it is. |
;; Just return as it is. |
697 |
(return-from coerce object)) |
(return-from coerce object)) |
698 |
|
(when (classp type) |
699 |
|
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S~%" object type)) |
700 |
(setq type (normalize-type type)) |
(setq type (normalize-type type)) |
701 |
(case (car type) |
(case (car type) |
702 |
(list |
(list |