Skip to content
Snippets Groups Projects
Commit a311bb37 authored by phg's avatar phg
Browse files

Changed definition of *subtypep to speed up method definition

using code provided by Richard Harris.
parent 5dc53f49
No related branches found
No related tags found
No related merge requests found
......@@ -361,22 +361,33 @@
(t
(typep object (convert-to-system-type type)))))
;Writing the missing NOT and AND clauses will improve
;the quality of code generated by generate-discrimination-net, but
;calling subtypep in place of just returning (values nil nil) can be
;very slow. *subtypep is used by PCL itself, and must be fast.
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(if (eq *boot-state* 'early)
(values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t)) ; not a descriptive name
(let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*))
;; This changes the way class-applicable-using-class-p works.
;; *in-precompute-effective-methods-p* is not a good name.
;; It changes the way class-applicable-using-class-p works.
(setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2))
(if (member (car type2) '(eql wrapper-eq class-eq class))
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(values app-p (or app-p (not maybe-app-p))))
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2)))))))
(case (car type2)
(not
(values nil nil)) ; Should improve this.
(and
(values nil nil)) ; Should improve this.
((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(values app-p (or app-p (not maybe-app-p)))))
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
(defun do-satisfies-deftype (name predicate)
#+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment