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

Diff of /gcl/lsp/gcl_predlib.lsp

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

revision 1.1.2.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.1.2.2 by camm, Tue Sep 23 18:15:52 2003 UTC
# Line 117  Line 117 
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)
# Line 132  Line 135 
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))
# Line 256  Line 260 
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)
# Line 267  Line 275 
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")
# Line 311  Line 320 
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))

Legend:
Removed from v.1.1.2.1  
changed lines
  Added in v.1.1.2.2

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