Changeset 3790

Timestamp:

09/15/03 05:00:42 (20 years ago)

Author:

piso

Message:

Work in progress.

File:

• trunk/j/src/org/armedbear/lisp/subtypep.lisp (modified) (7 diffs)

trunk/j/src/org/armedbear/lisp/subtypep.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: subtypep.lisp,v 1.7 2003-09-14 16:03:26 piso Exp $
+;;; $Id: subtypep.lisp,v 1.8 2003-09-15 05:00:42 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -24 +24 @@
 (defparameter *known-types* (make-hash-table))
 
-(dolist (i '((BASE-STRING SIMPLE-STRING)
+(dolist (i '((ARRAY)
+             (BASE-STRING SIMPLE-STRING)
              (BIGNUM INTEGER)
              (BIT INTEGER)
@@ -30 +31 @@
              (BOOLEAN SYMBOL)
              (BUILT-IN-CLASS STANDARD-CLASS)
-             (CHARACTER ATOM)
+             (CHARACTER)
              (CLASS STANDARD-OBJECT)
+             (COMPILED-FUNCTION FUNCTION)
              (COMPLEX NUMBER)
+             (CONDITION)
              (CONS LIST)
              (EXTENDED-CHAR CHARACTER NIL)
              (FIXNUM INTEGER)
              (FLOAT REAL)
+             (FUNCTION)
+             (GENERIC-FUNCTION FUNCTION)
              (HASH-TABLE)
              (INTEGER RATIONAL)
@@ -42 +47 @@
              (LIST SEQUENCE)
              (NULL SYMBOL LIST)
-             (NUMBER ATOM)
+             (NUMBER)
+             (PACKAGE)
              (PACKAGE-ERROR ERROR)
+             (PATHNAME)
              (PROGRAM-ERROR ERROR)
+             (RANDOM-STATE)
              (RATIO RATIONAL)
              (RATIONAL REAL)
+             (READTABLE)
              (REAL NUMBER)
+             (RESTART)
              (SERIOUS-CONDITION CONDITION)
              (SIMPLE-ARRAY ARRAY)
@@ -56 +66 @@
              (STANDARD-CHAR CHARACTER)
              (STANDARD-CLASS CLASS)
-             (STANDARD-OBJECT ATOM)
+             (STANDARD-GENERIC-FUNCTION GENERIC-FUNCTION)
+             (STANDARD-OBJECT)
+             (STREAM)
              (STRING VECTOR)
-             (SYMBOL ATOM)
+             (STRUCTURE-CLASS CLASS STANDARD-OBJECT)
+             (SYMBOL)
              (TWO-WAY-STREAM STREAM)
              (TYPE-ERROR ERROR)
@@ -69 +82 @@
 
 (defun known-type-p (type)
-  (if (values (gethash type *known-types*)) t nil))
+  (multiple-value-bind (value present-p) (gethash type *known-types*)
+    present-p))
 
 (defun normalize-type (type)
@@ -166 +180 @@
         (i1 (cdr type1))
         (i2 (cdr type2)))
+    (when (eq t2 'atom)
+      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
+                                  ((known-type-p t1) (values t t))
+                                  (t (values nil nil)))))
     (unless (or i1 i2)
       (return-from subtypep (values (simple-subtypep t1 t2) t)))
-    (cond ((eq t2 'atom)
-           (cond ((member t1 '(cons list)) (values nil t))
-                 ((known-type-p t1) (values t t))
-                 (t (values nil nil))))
-          ((eq t2 'sequence)
+    (cond ((eq t2 'sequence)
            (values (simple-subtypep t2 t2) t))
           ((eq t2 'simple-string)