/[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.5 by camm, Sat Oct 5 18:34:15 2002 UTC revision 1.6 by camm, Wed Oct 9 03:46:33 2002 UTC
# Line 86  Line 86 
86    `(array ,element-type (,size)))    `(array ,element-type (,size)))
87  (deftype string (&optional size)  (deftype string (&optional size)
88    `(vector string-char ,size))    `(vector string-char ,size))
89    (deftype base-string (&optional size)
90      `(vector base-char ,size))
91  (deftype bit-vector (&optional size)  (deftype bit-vector (&optional size)
92    `(vector bit ,size))    `(vector bit ,size))
93    
# Line 93  Line 95 
95    `(simple-array t (,size)))    `(simple-array t (,size)))
96  (deftype simple-string (&optional size)  (deftype simple-string (&optional size)
97    `(simple-array string-char (,size)))    `(simple-array string-char (,size)))
98    (deftype simple-base-string (&optional size)
99      `(simple-array base-char (,size)))
100  (deftype simple-bit-vector (&optional size)  (deftype simple-bit-vector (&optional size)
101    `(simple-array bit (,size)))    `(simple-array bit (,size)))
102    
# Line 182  Line 186 
186                (typep (imagpart object) (car i))))                (typep (imagpart object) (car i))))
187       ))       ))
188      (sequence (or (listp object) (vectorp object)))      (sequence (or (listp object) (vectorp object)))
189      (string      ((base-string string) ;FIXME
190       (and (stringp object)       (and (stringp object)
191            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (null i) (match-dimensions (array-dimensions object) i))))
192      (bit-vector      (bit-vector
193       (and (bit-vector-p object)       (and (bit-vector-p object)
194            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (null i) (match-dimensions (array-dimensions object) i))))
195      (simple-string      ((simple-base-string simple-string) ;FIXME
196       (and (simple-string-p object)       (and (simple-string-p object)
197            (or (null i) (match-dimensions (array-dimensions object) i))))            (or (null i) (match-dimensions (array-dimensions object) i))))
198      (simple-bit-vector      (simple-bit-vector
# Line 320  Line 324 
324           (cond ((member t1 '(null cons)) (values t t))           (cond ((member t1 '(null cons)) (values t t))
325                 (t (values nil ntp1))))                 (t (values nil ntp1))))
326          ((eq t2 'sequence)          ((eq t2 'sequence)
327           (cond ((member t1 '(null cons list base-string simple-base-string))           (cond ((member t1 '(null cons list))
328                  (values t t))                  (values t t))
329                 ((or (eq t1 'simple-array) (eq t1 'array))                 ((or (eq t1 'simple-array) (eq t1 'array))
330                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
# Line 511  Line 515 
515              (if (member t2 '(base-char string-char character))              (if (member t2 '(base-char string-char character))
516                  (values t t)                  (values t t)
517                  (values nil ntp2)))                  (values nil ntp2)))
            (base-string  
             (if (member t2 '(string vector array sequence))  
                 (values t t)  
                 (values nil ntp2)))  
518             (base-char             (base-char
519              (if (member t2 '(character string-char))              (if (member t2 '(character string-char))
520                  (values t t)                  (values t t)
# Line 523  Line 523 
523              (if (member t2 '(character string-char))              (if (member t2 '(character string-char))
524                  (values t t)                  (values t t)
525                  (values nil ntp2)))                  (values nil ntp2)))
            (simple-base-string  
             (if (member t2 '(string simple-string base-string vector  
                                     simple-vector simple-array array sequence))  
                 (values t t)  
                 (values nil ntp2)))  
526             (string-char             (string-char
527              (if (eq t2 'character)              (if (eq t2 'character)
528                  (values t t)                  (values t t)
# Line 566  Line 561 
561                         (unless (or (endp i2) (eq (car i2) '*))                         (unless (or (endp i2) (eq (car i2) '*))
562                                 (return-from subtypep (values nil t)))                                 (return-from subtypep (values nil t)))
563                         (unless (or (endp i2) (eq (car i2) '*))                         (unless (or (endp i2) (eq (car i2) '*))
564                                 (unless (equal (car i1) (car i2))                                 (unless (or (equal (car i1) (car i2))
565                                               ; FIXME
566                                               (and (eq (car i1) 'base-char)
567                                                    (eq (car i2) 'string-char)))
568                                         ;; Unless the element type matches,                                         ;; Unless the element type matches,
569                                         ;;  return NIL T.                                         ;;  return NIL T.
570                                         ;; Is this too strict?                                         ;; Is this too strict?
# Line 586  Line 584 
584                         (unless (or (endp i2) (eq (car i2) '*))                         (unless (or (endp i2) (eq (car i2) '*))
585                                 (return-from subtypep (values nil t)))                                 (return-from subtypep (values nil t)))
586                         (unless (or (endp i2) (eq (car i2) '*))                         (unless (or (endp i2) (eq (car i2) '*))
587                                 (unless (equal (car i1) (car i2))                                 (unless (or (equal (car i1) (car i2))
588                                               ; FIXME
589                                               (and (eq (car i1) 'base-char)
590                                                    (eq (car i2) 'string-char)))
591                                         (return-from subtypep                                         (return-from subtypep
592                                                      (values nil t)))))                                                      (values nil t)))))
593                     (when (or (endp (cdr i1)) (eq (cadr i1) '*))                     (when (or (endp (cdr i1)) (eq (cadr i1) '*))

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

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