[movitz-cvs] CVS update: movitz/compiler-types.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Jul 8 11:27:19 UTC 2004
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 at 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)
More information about the Movitz-cvs
mailing list