Changeset 4694


Ignore:
Timestamp:
11/11/03 18:05:44 (18 years ago)
Author:
piso
Message:

SUBTYPEP: optimization.

File:
1 edited

Legend:

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

    r4693 r4694  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.23 2003-11-11 17:37:18 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.24 2003-11-11 18:05:44 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    219219            (eq type2 t))
    220220    (return-from subtypep (values t t)))
    221   (let* ((c1 (classp type1)) (c2 (classp type2))
    222          (t1 (if c1
    223                  type1
    224                  (and (symbolp type1) (find-class type1 nil))))
    225          (t2 (if c2
    226                  type2
    227                  (and (symbolp type2) (find-class type2 nil)))))
    228     (when (and t1 t2)
    229       (return-from subtypep
    230        (if (member t2 (class-precedence-list t1))
    231            (values t t) (values nil t))))
    232     (when (or c1 c2)
    233       (return-from subtypep (values nil t))))
     221  (when (and (atom type1) (atom type2))
     222    (let* ((classp-1 (classp type1))
     223           (classp-2 (classp type2))
     224           class1 class2)
     225      (when (and (setf class1 (if classp-1
     226                                  type1
     227                                  (and (symbolp type1) (find-class type1 nil))))
     228                 (setf class2 (if classp-2
     229                                  type2
     230                                  (and (symbolp type2) (find-class type2 nil)))))
     231        (return-from subtypep
     232                     (if (member class2 (class-precedence-list class1))
     233                         (values t t)
     234                         (values nil t))))
     235      (when (or classp-1 classp-2)
     236        (return-from subtypep (values nil t)))))
    234237  (setq type1 (subtypep-normalize-type type1)
    235238        type2 (subtypep-normalize-type type2))
Note: See TracChangeset for help on using the changeset viewer.