diff --git a/code/type.lisp b/code/type.lisp index 852fb80916fe0cf6851b5054e1172d3638560160..94837b62f3313d795ec8fb4eedfa6fe242cbdb16 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.53 2003/04/13 21:20:40 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.54 2003/04/15 23:07:10 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -884,15 +884,29 @@ (logand (sxhash x) #xff))) ((input-types equal)) (let ((simplified (simplify-union-types input-types))) - (case (length simplified) - (0 *empty-type*) - (1 (aref simplified 0)) - (t (make-union-type (loop for type across simplified collect type)))))) + (cond ((null simplified) *empty-type*) + ((null (cdr simplified)) (car simplified)) + (t (make-union-type simplified))))) + +;;; +;;; FIXME: Recode the simplification of union and intersection types, +;;; so that it doesn't have the somewhat twisted cycle TYPE-UNION -> +;;; SIMPLIFY-UNION-TYPES -> TYPE-UNION2 -> TYPE-UNION. +;;; +(defvar *ctype-arrays*) +(cold-load-init (setq *ctype-arrays* nil)) + +(defmacro with-types-array ((var) &body body) + `(let ((,var (or (pop *ctype-arrays*) + (make-array 10 :fill-pointer 0 :adjustable t + :element-type 'ctype)))) + (setf (fill-pointer ,var) 0) + (locally ,@body) + (prog1 (loop for tp across ,var collect tp) + (push ,var *ctype-arrays*)))) (defun simplify-union-types (types) - (let ((result (make-array (length types) :fill-pointer 0 - :adjustable t :element-type 'ctype - :initial-element *empty-type*))) + (with-types-array (result) (labels ((accumulate1 (type) (dotimes (i (length result) (vector-push-extend type result)) (let ((simple (type-union2 type (aref result i)))) @@ -904,8 +918,7 @@ (map nil #'accumulate1 (union-type-types type)) (accumulate1 type)))) (dolist (type types) - (accumulate type)) - result))) + (accumulate type))))) (defun %type-union2 (type1 type2) ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give @@ -1019,7 +1032,7 @@ (logand (sxhash x) #xff))) ((input-types equal)) (let ((simplified (simplify-intersection-types input-types))) - (declare (type (vector ctype) simplified)) + ;(declare (type (vector ctype) simplified)) ;; We want to have a canonical representation of types (or failing ;; that, punt to HAIRY-TYPE). Canonical representation would have ;; intersections inside unions but not vice versa, since you can @@ -1028,26 +1041,23 @@ ;; to end up with unreasonably huge type expressions. So instead ;; we try to generate a simple type by distributing the union; if ;; the type can't be made simple, we punt to HAIRY-TYPE. - (if (and (> (length simplified) 1) - (some #'union-type-p simplified)) + (if (and (cdr simplified) (some #'union-type-p simplified)) (let* ((first-union (find-if #'union-type-p simplified)) - (other-types (coerce (remove first-union simplified) 'list)) + (other-types (remove first-union simplified)) (distributed (maybe-distribute-one-union first-union other-types))) (if distributed (apply #'type-union distributed) (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified))))) - (case (length simplified) - (0 *universal-type*) - (1 (aref simplified 0)) + :specifier `(and ,@(mapcar #'type-specifier simplified))))) + (cond + ((null simplified) *universal-type*) + ((null (cdr simplified)) (car simplified)) (t (make-intersection-type (some #'type-enumerable simplified) - (loop for type across simplified collect type))))))) + simplified)))))) (defun simplify-intersection-types (types) - (let ((result (make-array (length types) :fill-pointer 0 - :adjustable t :element-type 'ctype - :initial-element *empty-type*))) + (with-types-array (result) (labels ((accumulate1 (type) (dotimes (i (length result) (vector-push-extend type result)) (let ((simple (type-intersection2 type (aref result i)))) @@ -1059,8 +1069,7 @@ (map nil #'accumulate1 (intersection-type-types type)) (accumulate1 type)))) (dolist (type types) - (accumulate type)) - result))) + (accumulate type))))) (defun maybe-distribute-one-union (union-type types) (let* ((intersection (apply #'type-intersection types))