Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6843

Modified Files: compiler-types.lisp Log Message: Improved handling of integer types.

Date: Thu Jul 8 04:27:19 2004 Author: ffjeld

Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.15 movitz/compiler-types.lisp:1.16 --- movitz/compiler-types.lisp:1.15 Tue Jun 29 16:17:22 2004 +++ movitz/compiler-types.lisp Thu Jul 8 04:27:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.15 2004/06/29 23:17:22 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.16 2004/07/08 11:27:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -60,7 +60,7 @@ (multiple-value-call #'encoded-type-singleton (type-specifier-encode type-specifier)))

-;;; +;;; A numscope is a subset of the integers.

(defun make-numscope (&optional minimum maximum) (check-type minimum (or number null)) @@ -195,6 +195,14 @@ epsilon) epsilon)))

+(defun numscope-equalp (range0 range1) + ;; Numscopes should always be kept on canonical form. + (equal range0 range1)) + +(defun numscope-subsetp (range0 range1) + "Is range0 included in range1?" + (numscope-equalp range1 (numscope-union range0 range1))) + (defun numscope-allp (range) "Does this numscope include every number?" (let ((x (car range))) @@ -205,7 +213,7 @@ ;;;

(defparameter *tb-bitmap* - '(hash-table character function cons keyword symbol vector array integer :tail) + '(hash-table character function cons keyword symbol vector array :tail) "The union of these types must be t.")

(defun basic-typep (x type) @@ -243,11 +251,37 @@ (case x (symbol (logior code (code 'keyword))) (array (logior code (code 'vector))) - ;; (number (logior code (code 'integer))) (t code))))))) (reduce #'logior (mapcar #'code types) :initial-value (code first-type)))))

+(defun type-values (codes &key integer-range members include complement) + ;; Members: A list of objects explicitly included in type. + ;; Include: A list of (non-encodable) type-specs included in type. + (check-type include list) + (check-type members list) + (check-type integer-range list) + (let ((new-intscope integer-range) + (new-members ())) + (dolist (member members) ; move integer members into integer-range + (let ((member (movitz-read member))) + (etypecase member + (movitz-fixnum + (setf new-intscope + (numscope-union new-intscope + (make-numscope (movitz-fixnum-value member) + (movitz-fixnum-value member))))) + (movitz-object + (pushnew member new-members :test #'movitz-eql))))) + (let ((new-code (if (atom codes) + (type-code codes) + (apply #'type-code codes)))) + (values new-code + new-intscope + new-members + include + complement)))) + (defun encoded-type-decode (code integer-range members include complement) (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*))))) (= mask (logand mask code))) @@ -277,38 +311,6 @@ (t (if (not complement) (cons 'or sub-specs) (list 'not (cons 'or sub-specs)))))))) - -(defun type-values (codes &key integer-range members include complement) - ;; Members: A list of objects explicitly included in type. - ;; Include: A list of (non-encodable) type-specs included in type. - (check-type include list) - (check-type members list) - (check-type integer-range list) - (let ((new-intscope integer-range) - (new-members ())) - (dolist (member members) ; move integer members into integer-range - (let ((member (movitz-read member))) - (etypecase member - (movitz-fixnum - (setf new-intscope - (numscope-union new-intscope - (make-numscope (movitz-fixnum-value member) - (movitz-fixnum-value member))))) - (movitz-object - (pushnew member new-members :test #'movitz-eql))))) - (let ((new-code (logior (if (atom codes) - (type-code codes) - (apply #'type-code codes)) - (if (numscope-allp new-intscope) - (type-code 'integer) - 0)))) - (values new-code - (if (type-code-p 'integer new-code) - (make-numscope nil nil) - new-intscope) - new-members - include - complement))))

(defun star-is-t (x) (if (eq x '*) t x)) @@ -326,13 +328,9 @@ ((typep x 'movitz-nil) (type-code-p 'symbol code)) ((basic-typep x 'fixnum) - (or (type-code-p 'integer code) - (and integer-range - (numscope-memberp integer-range (movitz-fixnum-value x))))) + (numscope-memberp integer-range (movitz-fixnum-value x))) ((basic-typep x 'bignum) - (or (type-code-p 'integer code) - (and integer-range - (numscope-memberp integer-range (movitz-bignum-value x))))) + (numscope-memberp integer-range (movitz-bignum-value x))) (t (dolist (bt '(symbol character function cons hash-table vector) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) @@ -411,13 +409,9 @@ (values code0 integer-range0 members0 include0 complement0)) ((and (not complement0) (not complement1)) (let* ((new-inumscope (numscope-union integer-range0 integer-range1)) - (new-code (logior code0 code1 (if (numscope-allp new-inumscope) - (type-code 'integer) - 0)))) + (new-code (logior code0 code1))) (values new-code - (if (type-code-p 'integer new-code) - nil - new-inumscope) + new-inumscope (remove-if (lambda (x) (or (encoded-typep nil t x code0 integer-range0 nil include0 nil) (encoded-typep nil t x code1 integer-range1 nil include1 nil))) @@ -447,8 +441,10 @@ (bignum (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+)) (integer ,(1+ +movitz-most-positive-fixnum+) *)))) - ((t nil cons symbol keyword function array vector integer hash-table character) + ((t nil cons symbol keyword function array vector hash-table character) (type-values type-specifier)) + ((integer) + (type-values () :integer-range (make-numscope))) (null (type-values () :members '(nil))) (list @@ -574,7 +570,11 @@ ((null include) (values nil t)) (t (values nil nil)))) - + +(defun encoded-integerp (code integer-range members include complement) + "Is the encoded-type a subset/subtype of integer?" + (declare (ignore integer-range)) + (and (= 0 code) (null members) (null include) (not complement)))

(defun encoded-subtypep (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) @@ -599,14 +599,18 @@ (and (not all1) confident))) ;; type0 is t, and type1 isn't. (result-is nil t)) + ((and (encoded-integerp code0 integer-range0 members0 include0 complement0) + (not complement1) + (numscope-subsetp integer-range0 integer-range1)) + ;; type0 is an integer type which is included in type1. + (result-is t t)) ((and (not complement0) (not complement1)) (dolist (st *tb-bitmap*) (when (type-code-p st code0) (unless (type-code-p st code1) (result-is nil t)))) - (when integer-range0 - (unless (type-code-p 'integer code1) - (result-is nil nil))) + (unless (numscope-subsetp integer-range0 integer-range1) + (result-is nil t)) (dolist (m members0) (ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil) ((nil)