Changeset 5726


Ignore:
Timestamp:
02/09/04 11:25:00 (17 years ago)
Author:
piso
Message:

SUBTYPEP

File:
1 edited

Legend:

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

    r5674 r5726  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.43 2004-02-02 20:53:26 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.44 2004-02-09 11:25:00 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    211211                                  (and (symbolp type2) (find-class type2 nil)))))
    212212        (return-from subtypep
    213                      (if (member class2 (class-precedence-list class1))
    214                          (values t t)
    215                          (values nil t))))
     213                     (values (if (member class2 (class-precedence-list class1)) t nil) t)))
    216214      (when (or classp-1 classp-2)
    217215        (let ((t1 (if classp-1 (class-name type1) type1))
     
    224222  (let (t1 t2 i1 i2)
    225223    (if (atom type1)
    226         (setq t1 type1 i1 nil)
    227         (setq t1 (car type1) i1 (cdr type1)))
     224        (setf t1 type1 i1 nil)
     225        (setf t1 (car type1) i1 (cdr type1)))
    228226    (if (atom type2)
    229         (setq t2 type2 i2 nil)
    230         (setq t2 (car type2) i2 (cdr type2)))
     227        (setf t2 type2 i2 nil)
     228        (setf t2 (car type2) i2 (cdr type2)))
    231229    (cond ((eq t1 'atom)
    232230           (return-from subtypep (values (eq t2 t) t)))
     
    334332               (values nil (known-type-p t2))))
    335333          ((and (eq t1 #.(find-class 'array)) (eq t2 'array))
    336            (cond ((equal i2 '(* *))
    337                   (values t t))
    338                  (t
    339                   (values nil t))))
     334           (values (equal i2 '(* *)) t))
    340335          ((and (memq t1 '(array simple-array)) (eq t2 'array))
    341336           (let ((e1 (car i1))
     
    399394                   (return-from subtypep (values t t))
    400395                   (return-from subtypep (values nil t))))))
    401           ((and (eq t1 'simple-array) (eq t2 'simple-array))
    402            (let ((e1 (car i1))
    403                  (e2 (car i2))
    404                  (d1 (cadr i1))
    405                  (d2 (cadr i2)))
    406              (cond ((and (eq e2 '*) (eq d2 '*))
    407                     (values t t))
    408                    ((or (eq e2 '*)
    409                         (equal e1 e2)
    410                         (equal (upgraded-array-element-type e1)
    411                                (upgraded-array-element-type e2)))
    412                     (values (dimension-subtypep d1 d2) t))
    413                    (t
    414                     (values nil t)))))
    415           ((and (eq t1 'simple-string) (eq t2 'simple-array))
    416            (let ((element-type (car i2))
    417                  (dim (cadr i2))
    418                  (size (car i1)))
    419              (unless (eq element-type '*)
    420                (return-from subtypep (values nil t)))
    421              (when (integerp size)
    422                (if (or (eq dim '*)
    423                        (and (consp dim) (= (length dim) 1) (eql (car dim) size)))
    424                    (return-from subtypep (values t t))
    425                    (return-from subtypep (values nil t))))
    426              (when (or (null size) (eql size '*))
    427                (if (or (eq dim '*)
    428                        (eql dim 1)
    429                        (and (consp dim) (= (length dim) 1)))
    430                    (return-from subtypep (values t t))
    431                    (return-from subtypep (values nil t))))))
    432396          ((eq t2 'simple-array)
    433            (values nil t))
     397           (case t1
     398             (simple-array
     399              (let ((e1 (car i1))
     400                    (e2 (car i2))
     401                    (d1 (cadr i1))
     402                    (d2 (cadr i2)))
     403                (cond ((and (eq e2 '*) (eq d2 '*))
     404                       (values t t))
     405                      ((or (eq e2 '*)
     406                           (equal e1 e2)
     407                           (equal (upgraded-array-element-type e1)
     408                                  (upgraded-array-element-type e2)))
     409                       (values (dimension-subtypep d1 d2) t))
     410                      (t
     411                       (values nil t)))))
     412             (simple-string
     413              (let ((element-type (car i2))
     414                    (dim (cadr i2))
     415                    (size (car i1)))
     416                (unless (eq element-type '*)
     417                  (return-from subtypep (values nil t)))
     418                (when (integerp size)
     419                  (if (or (eq dim '*)
     420                          (and (consp dim) (= (length dim) 1) (eql (car dim) size)))
     421                      (return-from subtypep (values t t))
     422                      (return-from subtypep (values nil t))))
     423                (when (or (null size) (eql size '*))
     424                  (if (or (eq dim '*)
     425                          (eql dim 1)
     426                          (and (consp dim) (= (length dim) 1)))
     427                      (return-from subtypep (values t t))
     428                      (return-from subtypep (values nil t))))))
     429             (t
     430              (values nil t))))
    434431          (t
    435432           (values nil nil)))))
    436433
    437 (when (and (fboundp 'jvm::jvmcompile) (not (autoloadp 'jvm::jvm-compile)))
     434(when (and (fboundp 'jvm::jvm-compile) (not (autoloadp 'jvm::jvm-compile)))
    438435  (mapcar #'jvm::jvm-compile '(normalize-type
    439436                               sub-interval-p
Note: See TracChangeset for help on using the changeset viewer.