Changeset 3790


Ignore:
Timestamp:
09/15/03 05:00:42 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/subtypep.lisp

    r3762 r3790  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.7 2003-09-14 16:03:26 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.8 2003-09-15 05:00:42 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2424(defparameter *known-types* (make-hash-table))
    2525
    26 (dolist (i '((BASE-STRING SIMPLE-STRING)
     26(dolist (i '((ARRAY)
     27             (BASE-STRING SIMPLE-STRING)
    2728             (BIGNUM INTEGER)
    2829             (BIT INTEGER)
     
    3031             (BOOLEAN SYMBOL)
    3132             (BUILT-IN-CLASS STANDARD-CLASS)
    32              (CHARACTER ATOM)
     33             (CHARACTER)
    3334             (CLASS STANDARD-OBJECT)
     35             (COMPILED-FUNCTION FUNCTION)
    3436             (COMPLEX NUMBER)
     37             (CONDITION)
    3538             (CONS LIST)
    3639             (EXTENDED-CHAR CHARACTER NIL)
    3740             (FIXNUM INTEGER)
    3841             (FLOAT REAL)
     42             (FUNCTION)
     43             (GENERIC-FUNCTION FUNCTION)
    3944             (HASH-TABLE)
    4045             (INTEGER RATIONAL)
     
    4247             (LIST SEQUENCE)
    4348             (NULL SYMBOL LIST)
    44              (NUMBER ATOM)
     49             (NUMBER)
     50             (PACKAGE)
    4551             (PACKAGE-ERROR ERROR)
     52             (PATHNAME)
    4653             (PROGRAM-ERROR ERROR)
     54             (RANDOM-STATE)
    4755             (RATIO RATIONAL)
    4856             (RATIONAL REAL)
     57             (READTABLE)
    4958             (REAL NUMBER)
     59             (RESTART)
    5060             (SERIOUS-CONDITION CONDITION)
    5161             (SIMPLE-ARRAY ARRAY)
     
    5666             (STANDARD-CHAR CHARACTER)
    5767             (STANDARD-CLASS CLASS)
    58              (STANDARD-OBJECT ATOM)
     68             (STANDARD-GENERIC-FUNCTION GENERIC-FUNCTION)
     69             (STANDARD-OBJECT)
     70             (STREAM)
    5971             (STRING VECTOR)
    60              (SYMBOL ATOM)
     72             (STRUCTURE-CLASS CLASS STANDARD-OBJECT)
     73             (SYMBOL)
    6174             (TWO-WAY-STREAM STREAM)
    6275             (TYPE-ERROR ERROR)
     
    6982
    7083(defun known-type-p (type)
    71   (if (values (gethash type *known-types*)) t nil))
     84  (multiple-value-bind (value present-p) (gethash type *known-types*)
     85    present-p))
    7286
    7387(defun normalize-type (type)
     
    166180        (i1 (cdr type1))
    167181        (i2 (cdr type2)))
     182    (when (eq t2 'atom)
     183      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
     184                                  ((known-type-p t1) (values t t))
     185                                  (t (values nil nil)))))
    168186    (unless (or i1 i2)
    169187      (return-from subtypep (values (simple-subtypep t1 t2) t)))
    170     (cond ((eq t2 'atom)
    171            (cond ((member t1 '(cons list)) (values nil t))
    172                  ((known-type-p t1) (values t t))
    173                  (t (values nil nil))))
    174           ((eq t2 'sequence)
     188    (cond ((eq t2 'sequence)
    175189           (values (simple-subtypep t2 t2) t))
    176190          ((eq t2 'simple-string)
Note: See TracChangeset for help on using the changeset viewer.