[movitz-cvs] CVS update: movitz/compiler-types.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Fri Jul 9 16:10:26 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv21049
Modified Files:
compiler-types.lisp
Log Message:
Changed handling of integers back again to having both an integer code
and integer-range. Also, added encoded-integer-types-add.
Date: Fri Jul 9 09:10:26 2004
Author: ffjeld
Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.17 movitz/compiler-types.lisp:1.18
--- movitz/compiler-types.lisp:1.17 Fri Jul 9 05:48:01 2004
+++ movitz/compiler-types.lisp Fri Jul 9 09:10:26 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.17 2004/07/09 12:48:01 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.18 2004/07/09 16:10:26 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -211,11 +211,29 @@
(and x (not (car x)) (not (cdr x)))))
+(defun numscope-combine (function range0 range1)
+ (let ((result ()))
+ (dolist (sub-range0 range0)
+ (dolist (sub-range1 range1)
+ (setf result
+ (numscope-union result
+ (funcall function
+ (car sub-range0) (cdr sub-range0)
+ (car sub-range1) (cdr sub-range1))))))
+ result))
+
+(defun numscope-plus (range0 range1)
+ "Return the numscope that covers the sum of any element of range0
+and any element of range1."
+ (numscope-combine (lambda (min0 max0 min1 max1)
+ (make-numscope (and min0 min1 (+ min0 min1))
+ (and max0 max1 (+ max0 max1))))
+ range0 range1))
;;;
(defparameter *tb-bitmap*
- '(hash-table character function cons keyword symbol vector array :tail)
+ '(hash-table character function cons keyword symbol vector array integer :tail)
"The union of these types must be t.")
(defun basic-typep (x type)
@@ -253,37 +271,11 @@
(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)))
@@ -313,6 +305,38 @@
(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))
@@ -330,9 +354,13 @@
((typep x 'movitz-nil)
(type-code-p 'symbol code))
((basic-typep x 'fixnum)
- (numscope-memberp integer-range (movitz-fixnum-value x)))
+ (or (type-code-p 'integer code)
+ (and integer-range
+ (numscope-memberp integer-range (movitz-fixnum-value x)))))
((basic-typep x 'bignum)
- (numscope-memberp integer-range (movitz-bignum-value x)))
+ (or (type-code-p 'integer code)
+ (and integer-range
+ (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,9 +439,13 @@
(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)))
+ (new-code (logior code0 code1 (if (numscope-allp new-inumscope)
+ (type-code 'integer)
+ 0))))
(values new-code
- new-inumscope
+ (if (type-code-p 'integer new-code)
+ nil
+ 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)))
@@ -443,10 +475,8 @@
(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 hash-table character)
+ ((t nil cons symbol keyword function array vector integer hash-table character)
(type-values type-specifier))
- ((integer)
- (type-values () :integer-range (make-numscope)))
(null
(type-values () :members '(nil)))
(list
@@ -573,10 +603,10 @@
(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-numscope (code integer-range)
+ (if (type-code-p 'integer code)
+ (make-numscope nil nil)
+ integer-range))
(defun encoded-subtypep (code0 integer-range0 members0 include0 complement0
code1 integer-range1 members1 include1 complement1)
@@ -601,17 +631,13 @@
(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))))
- (unless (numscope-subsetp integer-range0 integer-range1)
+ (unless (numscope-subsetp (encoded-numscope code0 integer-range0)
+ (encoded-numscope code1 integer-range1))
(result-is nil t))
(dolist (m members0)
(ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil)
@@ -643,8 +669,26 @@
((and (null members) (null intscope))
(warn "Not singleton, nulloton."))))
-(defun movitz-subtypep (type1 type2)
+(defun movitz-subtypep (type0 type1)
"Compile-time subtypep."
(multiple-value-call #'encoded-subtypep
- (type-specifier-encode type1)
- (type-specifier-encode type2)))
+ (type-specifier-encode type0)
+ (type-specifier-encode type1)))
+
+(defun encoded-integer-types-add (code0 integer-range0 members0 include0 complement0
+ code1 integer-range1 members1 include1 complement1)
+ "Return the integer type that can result from adding a member of type0 to a member of type1."
+ (declare (ignore members0 members1))
+ (cond
+ ((or include0 include1)
+ ;; We can't know..
+ 'integer)
+ ((or complement0 complement1)
+ (break "adding complement types..?"))
+ (t (let ((integer-range (numscope-plus (encoded-numscope code0 integer-range0)
+ (encoded-numscope code1 integer-range1))))
+ (encoded-type-decode (if (not (numscope-allp integer-range))
+ 0
+ (type-code 'integer))
+ integer-range
+ nil nil nil)))))
More information about the Movitz-cvs
mailing list