/[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.8 by camm, Sun Feb 9 23:34:17 2003 UTC revision 1.9 by camm, Mon Feb 17 16:50:21 2003 UTC
# Line 143  Line 143 
143  (defun class-precedence-list (object)  (defun class-precedence-list (object)
144    (declare (ignore object))    (declare (ignore object))
145    nil)    nil)
146    (defun find-class (object)
147      (declare (ignore object))
148      nil)
149    
150  ;;; TYPEP predicate.  ;;; TYPEP predicate.
151  ;;; FIXME --optimize with most likely cases first  ;;; FIXME --optimize with most likely cases first
# Line 200  Line 203 
203      (sequence (or (listp object) (vectorp object)))      (sequence (or (listp object) (vectorp object)))
204      ((base-string string) ;FIXME      ((base-string string) ;FIXME
205       (and (stringp object)       (and (stringp object)
206            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
207      (bit-vector      (bit-vector
208       (and (bit-vector-p object)       (and (bit-vector-p object)
209            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
210      ((simple-base-string simple-string) ;FIXME      ((simple-base-string simple-string) ;FIXME
211       (and (simple-string-p object)       (and (simple-string-p object)
212            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
213      (simple-bit-vector      (simple-bit-vector
214       (and (simple-bit-vector-p object)       (and (simple-bit-vector-p object)
215            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
216      (simple-vector      (simple-vector
217       (and (simple-vector-p object)       (and (simple-vector-p object)
218            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (eq (car i) '*)
219                  (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))
220                  (equal (array-element-type object) (best-array-element-type (car i))))
221              (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
222        (vector
223         (and (vectorp object)
224              (or (endp i) (eq (car i) '*)
225                  (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))
226                  (equal (array-element-type object) (best-array-element-type (car i))))
227              (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
228      (simple-array      (simple-array
229       (and (simple-array-p object)       (and (simple-array-p object)
230            (or (endp i) (eq (car i) '*)            (or (endp i) (eq (car i) '*)
231                (equal (array-element-type object)(best-array-element-type (car i))))                (equal (array-element-type object)(best-array-element-type (car i))))
232            (or (endp (cdr i)) (eq (cadr i) '*)            (or (endp (cdr i)) (eq (cadr i) '*)
233                (match-dimensions (array-dimensions object) (cadr i)))))                (if (listp (cadr i))
234                      (match-dimensions (array-dimensions object) (cadr i))
235                    (eql (array-rank object) (cadr i))))))
236      (array      (array
237       (and (arrayp object)       (and (arrayp object)
238            (or (endp i) (eq (car i) '*)            (or (endp i) (eq (car i) '*)
# Line 226  Line 240 
240                ;; Is this too strict?                ;; Is this too strict?
241                (equal (array-element-type object) (best-array-element-type (car i))))                (equal (array-element-type object) (best-array-element-type (car i))))
242            (or (endp (cdr i)) (eq (cadr i) '*)            (or (endp (cdr i)) (eq (cadr i) '*)
243                (match-dimensions (array-dimensions object) (cadr i)))))                (if (listp (cadr i))
244                      (match-dimensions (array-dimensions object) (cadr i))
245                    (eql (array-rank object) (cadr i))))))
246      (t      (t
247       (cond ((setq tem (get tp 'si::s-data))       (cond ((setq tem (get tp 'si::s-data))
248              (structure-subtype-p object tem))              (structure-subtype-p object tem))
# Line 287  Line 303 
303        (return-from subtypep        (return-from subtypep
304                     (if (member type2 (class-precedence-list type1))                     (if (member type2 (class-precedence-list type1))
305                         (values t t) (values nil t))))                         (values t t) (values nil t))))
306        (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object)))
307          (return-from subtypep
308                       (if (member (find-class type2) (class-precedence-list type1))
309                           (values t t) (values nil t))))
310      (when (or c1 c2)      (when (or c1 c2)
311        (return-from subtypep (values nil t))))        (return-from subtypep (values nil t))))
312    (setq t1 (normalize-type type1))    (setq t1 (normalize-type type1))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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