/[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.4 by camm, Fri Oct 4 03:30:34 2002 UTC revision 1.5 by camm, Sat Oct 5 18:34:15 2002 UTC
# Line 136  Line 136 
136    (if (atom type)    (if (atom type)
137        (setq tp type i nil)        (setq tp type i nil)
138        (setq tp (car type) i (cdr type)))        (setq tp (car type) i (cdr type)))
139      (if (eq tp 'structure-object) (setq tp 'structure))
140    (let ((f (get tp 'type-predicate)))    (let ((f (get tp 'type-predicate)))
141      (when f (return-from typep (funcall f object))))      (when f (return-from typep (funcall f object))))
142    (case tp    (case tp
# Line 158  Line 159 
159      (ratio (eq (type-of object) 'ratio))      (ratio (eq (type-of object) 'ratio))
160      (standard-char      (standard-char
161       (and (characterp object) (standard-char-p object)))       (and (characterp object) (standard-char-p object)))
162      (string-char      ((base-char string-char)
163       (and (characterp object) (string-char-p object)))       (and (characterp object) (string-char-p object)))
164      (integer      (integer
165       (and (integerp object) (in-interval-p object i)))       (and (integerp object) (in-interval-p object i)))
# Line 210  Line 211 
211                (equal (array-element-type object) (best-array-element-type (car i))))                (equal (array-element-type object) (best-array-element-type (car i))))
212            (or (endp (cdr i)) (eq (cadr i) '*)            (or (endp (cdr i)) (eq (cadr i) '*)
213                (match-dimensions (array-dimensions object) (cadr i)))))                (match-dimensions (array-dimensions object) (cadr i)))))
214      (t      (t
215       (cond ((setq tem (get tp 'si::s-data))       (cond ((setq tem (get tp 'si::s-data))
216              (structure-subtype-p object tem))              (structure-subtype-p object tem))
217             ((get tp 'deftype-definition)             ((setq tem (get tp 'deftype-definition))
218              (typep object                (typep object
219                     (apply (get tp 'deftype-definition) i)))))))                       (apply tem nil)))))))
220    
221    
222  ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.  ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
# Line 235  Line 236 
236  ;;; The type may not be normalized.  ;;; The type may not be normalized.
237  (defun known-type-p (type)  (defun known-type-p (type)
238    (when (consp type) (setq type (car type)))    (when (consp type) (setq type (car type)))
239    (if (or (member type    (if (or (equal (string type) "ERROR")
240              (member type
241                    '(t nil boolean null symbol keyword atom cons list sequence                    '(t nil boolean null symbol keyword atom cons list sequence
242                        signed-char unsigned-char signed-short unsigned-short                        signed-char unsigned-char signed-short unsigned-short
243                      number integer bignum rational ratio float                        number integer bignum rational ratio float method-combination
244                      short-float single-float double-float long-float complex                        short-float single-float double-float long-float complex
245                      character standard-char string-char                        character standard-char string-char real
246                      real                        package stream pathname readtable hash-table random-state
247                      package stream pathname readtable hash-table random-state                        structure array simple-array function compiled-function
248                      structure array simple-array function compiled-function                        arithmetic-error base-char base-string broadcast-stream
249                      arithmetic-error base-char base-string broadcast-stream                        built-in-class cell-error class concatenated-stream condition
250                      built-in-class cell-error class concatenated-stream condition                        control-error division-by-zero echo-stream end-of-file error
251                      control-error division-by-zero echo-stream end-of-file error                        extended-char file-error file-stream floating-point-inexact
252                      extended-char file-error file-stream floating-point-inexact                        floating-point-invalid-operation floating-point-overflow
253                      floating-point-invalid-operation floating-point-overflow                        floating-point-underflow generic-function logical-pathname method
254                      floating-point-underflow generic-function logical-pathname method                        package-error parse-error print-not-readable program-error
255                      package-error parse-error print-not-readable program-error                        reader-error serious-condition simple-base-string simple-condition
256                      reader-error serious-condition simple-base-string simple-condition                        simple-type-error simple-warning standard-class
257                      simple-type-error simple-warning standard-class standard-generic-function                        standard-generic-function standard-method standard-object
258                      standard-method standard-object storage-condition stream-error                        storage-condition stream-error string-stream structure-class
259                      string-stream structure-class style-warning synonym-stream two-way-stream                        style-warning synonym-stream two-way-stream structure-object
260                      type-error unbound-slot unbound-variable undefined-function warning ))                        type-error unbound-slot unbound-variable undefined-function
261                          warning ))
262            (get type 's-data))            (get type 's-data))
263        t        t
264        nil))        nil))
# Line 263  Line 266 
266    
267  ;;; SUBTYPEP predicate.  ;;; SUBTYPEP predicate.
268  (defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem)  (defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem)
269    (setq type1 (normalize-type type1))    (setq t1 (normalize-type type1))
270    (setq type2 (normalize-type type2))      (setq type1 (if (eq (car t1) 'satisfies) (list type1) t1))
271      (setq t2 (normalize-type type2))
272      (setq type2 (if (eq (car t2) 'satisfies) (list type2) t2))
273    ;  (setq type1 (normalize-type type1))
274    ;  (setq type2 (normalize-type type2))  
275    (when (equal type1 type2)    (when (equal type1 type2)
276      (return-from subtypep (values t t)))      (return-from subtypep (values t t)))
277    (setq t1 (car type1) t2 (car type2))    (setq t1 (car type1) t2 (car type2))
# Line 310  Line 317 
317          ((eq t1 't) (values nil ntp2))          ((eq t1 't) (values nil ntp2))
318          ((eq t1 'common) (values nil ntp2))          ((eq t1 'common) (values nil ntp2))
319          ((eq t2 'list)          ((eq t2 'list)
320           (cond ((member t1 '(null cons list)) (values t t))           (cond ((member t1 '(null cons)) (values t t))
321                 (t (values nil ntp1))))                 (t (values nil ntp1))))
322          ((eq t2 'sequence)          ((eq t2 'sequence)
323           (cond ((member t1 '(null cons list sequence base-string simple-base-string)) (values t t))           (cond ((member t1 '(null cons list base-string simple-base-string))
324                    (values t t))
325                 ((or (eq t1 'simple-array) (eq t1 'array))                 ((or (eq t1 'simple-array) (eq t1 'array))
326                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
327                      (values t t)                      (values t t)
# Line 327  Line 335 
335                 (t (values nil nil))))                 (t (values nil nil))))
336          ((eq t1 'atom) (values nil ntp2))          ((eq t1 'atom) (values nil ntp2))
337          ((eq t2 'symbol)          ((eq t2 'symbol)
338           (if (member t1 '(symbol keyword boolean null))           (if (member t1 '(keyword boolean null))
339               (values t t)               (values t t)
340               (values nil ntp1)))               (values nil ntp1)))
341          ((eq t2 'function)          ((eq t2 'function)
# Line 338  Line 346 
346           (if (eq t1 'standard-generic-function)           (if (eq t1 'standard-generic-function)
347               (values t t)               (values t t)
348               (values nil ntp1)))               (values nil ntp1)))
349            ((eq t2 'boolean)
350             (if (eq t1 'null)
351                 (values t t)
352                 (values nil ntp1)))
353            ((eq t2 'standard-object)
354             (if (member t1 '(class built-in-class structure-class standard-class
355                                    method standard-method))
356                 (values t t)
357                 (values nil ntp1)))
358            ((eq t2 'class)
359             (if (member t1 '(built-in-class structure-class standard-class ))
360                 (values t t)
361                 (values nil ntp1)))
362            ((eq t2 'condition)
363             (if (or (equal (string t1) "ERROR")
364                     (member t1 '(serious-condition error type-error simple-type-error
365                                                parse-error cell-error unbound-slot
366                                                warning style-warning storage-condition
367                                                simple-warning unbound-variable control-error
368                                                program-error undefined-function
369                                                package-error arithmetic-error
370                                                division-by-zero simple-condition
371                                                floating-point-invalid-operation
372                                                floating-point-inexact
373                                                floating-point-overflow
374                                                floating-point-underflow
375                                                file-error stream-error end-of-file
376                                                print-not-readable
377                                                reader-error)))
378                 (values t t)
379                 (values nil ntp1)))
380            ((eq t2 'serious-condition)
381             (if (or (equal (string t1) "ERROR")
382                     (member t1 '( error type-error simple-type-error
383                                         parse-error cell-error unbound-slot
384                                         storage-condition
385                                         unbound-variable control-error
386                                         program-error undefined-function
387                                         package-error arithmetic-error
388                                         division-by-zero simple-type-error
389                                         floating-point-invalid-operation
390                                         floating-point-inexact
391                                         floating-point-overflow
392                                         floating-point-underflow
393                                         file-error stream-error end-of-file
394                                         print-not-readable
395                                         reader-error)))
396                 (values t t)
397                 (values nil ntp1)))
398            ((eq t2 'type-error)
399             (if (eq t1 'simple-type-error)
400                 (values t t)
401                 (values nil ntp1)))
402            ((eq t2 'parse-error)
403             (if (eq t1 'reader-error)
404                 (values t t)
405                 (values nil ntp1)))
406            ((eq t2 'stream-error)
407             (if (member t1 '(reader-error end-of-file))
408                 (values t t)
409                 (values nil ntp1)))
410            ((or (equal (string t2) "ERROR") (eq t2 'error))
411             (if (member t1 '(simple-type-error type-error
412                              parse-error cell-error unbound-slot
413                              unbound-variable control-error
414                              program-error undefined-function
415                              package-error arithmetic-error
416                              division-by-zero simple-type-error
417                              floating-point-invalid-operation
418                              floating-point-inexact
419                              floating-point-overflow
420                              floating-point-underflow
421                              file-error stream-error end-of-file print-not-readable
422                              reader-error ))
423                 (values t t)
424                 (values nil ntp1)))
425            ((eq t2 'stream)
426             (if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream
427                                               string-stream synonym-stream two-way-stream))
428                 (values t t)
429                 (values nil ntp1)))
430            ((eq t2 'pathname)
431             (if (eq t1 'logical-pathname)
432                 (values t t)
433                 (values nil ntp1)))
434            ((eq t2 'method)
435             (if (eq t1 'standard-method)
436                 (values t t)
437                 (values nil ntp1)))
438            ((eq t2 'simple-condition)
439             (if (member t1 '(simple-type-error simple-warning))
440                 (values t t)
441                 (values nil ntp1)))
442            ((eq t2 'simple-condition)
443             (if (member t1 '(simple-type-error simple-warning))
444                 (values t t)
445                 (values nil ntp1)))
446            ((eq t2 'cell-error)
447             (if (member t1 '(unbound-slot unbound-variable undefined-function))
448                 (values t t)
449                 (values nil ntp1)))
450            ((eq t2 'warning)
451             (if (member t1 '(style-warning simple-warning))
452                 (values t t)
453                 (values nil ntp1)))
454            ((eq t2 'arithmetic-error)
455             (if (member t1 '(division-by-zero
456                              floating-point-invalid-operation
457                              floating-point-inexact
458                              floating-point-overflow
459                              floating-point-underflow ))
460                 (values t t)
461                 (values nil ntp1)))
462          ((eq t2 'keyword)          ((eq t2 'keyword)
463           (if (eq t1 'keyword) (values t t) (values nil ntp1)))           (if (eq t1 'keyword) (values t t) (values nil ntp1)))
464          ((eq t2 'null)          ((eq t2 'null)
# Line 349  Line 470 
470                  (values t t))                  (values t t))
471                 (t (values nil ntp1))))                 (t (values nil ntp1))))
472          ((eq t1 'number) (values nil ntp2))          ((eq t1 'number) (values nil ntp2))
473          ((eq t2 'structure)          ((or (eq t2 'structure) (eq t2 'structure-object))
474           (if (or (eq t1 'structure) (get t1 'si::s-data))           (if (or (eq t1 'structure) (get t1 'si::s-data))
475               (values t t)               (values t t)
476               (values nil ntp1)))               (values nil ntp1)))
# Line 363  Line 484 
484                   (t (values nil ntp2)))))                   (t (values nil ntp2)))))
485          ((eq t2 'real)          ((eq t2 'real)
486           (cond ((and           (cond ((and
487                   (member t1 '(fixnum integer bignum float                   (member t1 '(fixnum integer bignum float short-float
488                                       single-float double-float long-float                                       single-float double-float long-float
489                                       real                                       real ratio
490                                       rational))                                       rational))
491                   (sub-interval-p i1 i2))                   (sub-interval-p i1 i2))
492                  (values t t))                  (values t t))
# Line 383  Line 504 
504                (t (values nil ntp2))))                (t (values nil ntp2))))
505             (ratio             (ratio
506              (case t2              (case t2
               (ratio (values t t))  
507                (rational                (rational
508                 (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))                 (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))
509                (t (values nil ntp2))))                (t (values nil ntp2))))
510             (standard-char             (standard-char
511              (if (member t2 '(standard-char string-char character))              (if (member t2 '(base-char string-char character))
512                  (values t t)                  (values t t)
513                  (values nil ntp2)))                  (values nil ntp2)))
514             (base-string             (base-string
# Line 399  Line 519 
519              (if (member t2 '(character string-char))              (if (member t2 '(character string-char))
520                  (values t t)                  (values t t)
521                  (values nil ntp2)))                  (values nil ntp2)))
522               (extended-char
523                (if (member t2 '(character string-char))
524                    (values t t)
525                    (values nil ntp2)))
526             (simple-base-string             (simple-base-string
527              (if (member t2 '(string simple-string base-string vector              (if (member t2 '(string simple-string base-string vector
528                                      simple-vector simple-array array sequence))                                      simple-vector simple-array array sequence))
529                  (values t t)                  (values t t)
530                  (values nil ntp2)))                  (values nil ntp2)))
531             (string-char             (string-char
532              (if (member t2 '(string-char character))              (if (eq t2 'character)
533                  (values t t)                  (values t t)
534                  (values nil ntp2)))                  (values nil ntp2)))
535             (character             (character
536              (if (member t2 '(string-char character))              (if (eq t2 'string-char)
537                  (values t t)                  (values t t)
538                  (values nil ntp2)))                  (values nil ntp2)))
539             (integer             (integer

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

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