/[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.9 by camm, Wed Aug 25 22:48:24 2004 UTC revision 1.10 by camm, Thu Sep 16 21:16:47 2004 UTC
# Line 329  Line 329 
329        t        t
330        nil))        nil))
331    
332  (defun implicit-symbol (x)  (defun implicit-symbol (a b)
333    (cond ((symbolp x) x)    (cond ((not (consp a))
334          ((consp x)           (or (and (symbolp a) a) b))
335           (let ((is (car x)))          ((null b)
336             (when (symbolp is)           (let ((b (car a)))
337               (dolist (y (cdr x) is)             (and (symbolp b) (implicit-symbol (cdr a) b))))
338                 (unless (or (eq y t) (eq y '*))          ((let ((a (car a))) (or (eq a '*) (eq a t)))
339                   (return-from implicit-symbol nil))))))))           (implicit-symbol (cdr a) b))))
340    
341  ;;; SUBTYPEP predicate.  ;;; SUBTYPEP predicate.
342  (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)  (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
343    (declare (ignore env))    (declare (ignore env))
344    (let* ((c1 (classp type1)) (c2 (classp type2))    (let* ((c1 (classp type1)) (c2 (classp type2))
345          (t1 (if c1 type1 (let ((nt (implicit-symbol type1))) (and nt (find-class nt nil)))))          (t1 (if c1 type1 (let ((nt (implicit-symbol type1 nil))) (and nt (find-class nt nil)))))
346          (t2 (if c2 type2 (let ((nt (implicit-symbol type2))) (and nt (find-class nt nil))))))          (t2 (if c2 type2 (let ((nt (implicit-symbol type2 nil))) (and nt (find-class nt nil))))))
347      (when (and t1 t2)      (when (and t1 t2)
348        (return-from subtypep        (return-from subtypep
349                     (if (member t2 (class-precedence-list t1))                     (if (member t2 (class-precedence-list t1))
# Line 651  Line 651 
651                  (values nil ntp2)))                  (values nil ntp2)))
652             ((simple-array array)             ((simple-array array)
653              (cond ((or (eq t1 t2) (eq t2 'array))              (cond ((or (eq t1 t2) (eq t2 'array))
654                     (macrolet ((ty (x) (let ((tmp (gensym)))                     (labels ((all-sym (a s &optional (b a) (c 0))
655                                          `(or (not ,x)                                       (cond ((null b) c)
656                                               (let ((,tmp (car ,x)))                                             ((eq (car b) s) (all-sym a s (cdr b) (1+ c)))
657                                                 (or (eq ,tmp '*) ,tmp)))))                                             (t a))))
658                                (di (x) (let ((tmp (gensym)))                       (macrolet ((ty (x) (let ((tmp (gensym)))
659                                          `(or (not (cdr ,x))                                            `(or (not ,x)
660                                               (let ((,tmp (cadr ,x)))                                                 (let ((,tmp (car ,x)))
661                                                 (or (eq ,tmp '*)                                                   (or (eq ,tmp '*) ,tmp)))))
662                                                     (and (consp ,tmp) ,tmp)                                  (di (x) (let ((tmp (gensym)))
663                                                     (and (integerp ,tmp)                                            `(or (not (cdr ,x))
664                                                          (make-list ,tmp :initial-element '*))))))))                                                 (let ((,tmp (cadr ,x)))
665                     (let* ((at1 (ty i1))                                                   (or (eq ,tmp '*)
666                            (at2 (ty i2))                                                       (and (integerp ,tmp) ,tmp)
667                            (at2 (or (and (eq at2 'string-char) 'character) at2)))                                                       (all-sym ,tmp '*)))))))
668                       (unless (equal at1 at2)                         (let* ((at1 (ty i1))
669                         (return-from subtypep (values nil t))))                                (at2 (ty i2))
670                     (let ((ad1 (di i1))                                (at2 (or (and (eq at2 'string-char) 'character) at2)))
671                           (ad2 (di i2)))                           (unless (equal at1 at2)
672                       (when (eq ad2 t)                             (return-from subtypep (values nil t))))
673                         (return-from subtypep (values t t)))                         (let ((ad1 (di i1))
674                       (when (eq ad1 t)                               (ad2 (di i2)))
675                         (return-from subtypep (values nil t)))                           (when (eq ad2 t)
676                       (values (match-dimensions ad1 ad2) t))))                             (return-from subtypep (values t t)))
677                             (when (eq ad1 t)
678                               (return-from subtypep (values nil t)))
679                             (values (match-dimensions ad1 ad2) t)))))
680                    (t (values nil ntp2))))                    (t (values nil ntp2))))
681             (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))             (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))
682    
# Line 750  Line 753 
753  (defun match-dimensions (dim pat)  (defun match-dimensions (dim pat)
754    (cond ((null dim)    (cond ((null dim)
755           (null pat))           (null pat))
756          ((not (consp dim))          ((integerp dim)
757           (eql dim pat))           (eql dim pat))
758            ((integerp pat)
759             (eql (length dim) pat))
760          (t          (t
761           (and (or (eq (car pat) '*)           (and (or (eq (car pat) '*)
762                    (eql (car dim) (car pat)))                    (eql (car dim) (car pat)))

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

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