Changeset 4811


Ignore:
Timestamp:
11/17/03 18:04:26 (18 years ago)
Author:
piso
Message:

Work in progess: CONS types.

File:
1 edited

Legend:

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

    r4802 r4811  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.30 2003-11-17 15:19:47 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.31 2003-11-17 18:04:26 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    113113  (when (symbolp type)
    114114    (case type
     115      (CONS
     116       (return-from subtypep-normalize-type '(cons t t)))
    115117      (FIXNUM
    116118       (return-from subtypep-normalize-type
     
    133135          (return)))
    134136    (case tp
     137      (CONS
     138       (let* ((len (length i))
     139              (car-typespec (if (> len 0) (car i) t))
     140              (cdr-typespec (if (> len 1) (cadr i) t)))
     141         (unless (and car-typespec cdr-typespec)
     142           (return-from subtypep-normalize-type nil))
     143         (when (eq car-typespec '*)
     144           (setf car-typespec t))
     145         (when (eq cdr-typespec '*)
     146           (setf cdr-typespec t))
     147         (setf i (list car-typespec cdr-typespec))))
    135148      ((ARRAY SIMPLE-ARRAY)
    136149       (when (and i (eq (car i) nil)) ; Element type is NIL.
     
    245258        (setq t2 type2 i2 nil)
    246259        (setq t2 (car type2) i2 (cdr type2)))
    247     (cond ((eq t2 'atom)
     260    (cond ((eq t1 'atom)
     261           (return-from subtypep (values (eq t2 t) t)))
     262          ((eq t2 'atom)
    248263           (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
    249264                                       ((known-type-p t1) (values t t))
     
    271286               (when tv (return-from subtypep (values t t)))))
    272287           (return-from subtypep (values nil nil)))
     288          ((eq t1 'cons)
     289           (case t2
     290             ((LIST SEQUENCE)
     291              (return-from subtypep (values t t)))
     292             (CONS
     293              (when (and (subtypep (car i1) (car i2))
     294                         (subtypep (cadr i1) (cadr i2)))
     295                (return-from subtypep (values t t)))))
     296           (return-from subtypep (values nil (known-type-p t2))))
    273297          ((eq t2 'or)
    274298           (dolist (tt i2)
Note: See TracChangeset for help on using the changeset viewer.