/[gcl]/gcl/lsp/predlib.lsp
ViewVC logotype

Diff of /gcl/lsp/predlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Wed Oct 9 03:46:33 2002 UTC revision 1.7 by camm, Fri Jan 24 18:38:28 2003 UTC
# Line 134  Line 134 
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)))
# Line 270  Line 282 
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))
# Line 676  Line 695 
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

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26