[movitz-cvs] CVS update: movitz/compiler-types.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sat Aug 20 20:30:15 UTC 2005
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv26351
Modified Files:
compiler-types.lisp
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.
Date: Sat Aug 20 22:30:14 2005
Author: ffjeld
Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.22 movitz/compiler-types.lisp:1.23
--- movitz/compiler-types.lisp:1.22 Mon Jan 3 12:52:33 2005
+++ movitz/compiler-types.lisp Sat Aug 20 22:30:14 2005
@@ -1,6 +1,6 @@
;;;;------------------------------------------------------------------
;;;;
-;;;; Copyright (C) 2001, 2003-2004,
+;;;; Copyright (C) 2001, 2003-2005,
;;;; Department of Computer Science, University of Tromso, Norway.
;;;;
;;;; For distribution policy, see the accompanying file COPYING.
@@ -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.22 2005/01/03 11:52:33 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.23 2005/08/20 20:30:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -153,7 +153,7 @@
(<= max (+ (car sub-range) epsilon))))
(d (and min (cdr sub-range) ; subtrahend starts above sub-range?
(<= (+ (cdr sub-range) epsilon) min))))
- ;; (warn "abcd: ~S ~S ~S ~S" a b c d)
+ #+ignore (warn "abcd: ~S ~S ~S ~S" a b c d)
(cond
((and a b)
;; sub-range is eclipsed by the subtrahend.
@@ -173,8 +173,8 @@
(numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon)))
((and (not d) b) ; (warn "right prune ~D with [~D-~D]" sub-range min max)
(setf new-numscope
- (numscope-add-range new-numscope (car sub-range) min epsilon)))
- (t (error "I am confused!")))))
+ (numscope-add-range new-numscope (car sub-range) (- min epsilon) epsilon)))
+ (t (break "I am confused!")))))
new-numscope))))
(defun numscope-complement (numscope &optional (epsilon 1))
@@ -277,34 +277,35 @@
:initial-value (code first-type)))))
(defun encoded-type-decode (code integer-range members include complement)
- (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
- (= mask (logand mask code)))
- (not complement)
- (let ((sub-specs include))
- (loop for x in *tb-bitmap* as bit upfrom 0
- do (when (logbitp bit code)
- (push x sub-specs)))
- (when (not (null members))
- (push (cons 'member members) sub-specs))
- (when (numscope-allp integer-range)
- (pushnew 'integer sub-specs))
- (when (and (not (member 'integer sub-specs))
- integer-range)
- (dolist (sub-range integer-range)
- (push (list 'integer
- (or (car sub-range) '*)
- (or (cdr sub-range) '*))
- sub-specs)))
- (cond
- ((null sub-specs)
- (if complement t nil))
- ((not (cdr sub-specs))
- (if (not complement)
- (car sub-specs)
- (list 'not (car sub-specs))))
- (t (if (not complement)
- (cons 'or sub-specs)
- (list 'not (cons 'or sub-specs))))))))
+ (cond
+ ((let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
+ (= mask (logand mask code)))
+ (not complement))
+ (t (let ((sub-specs include))
+ (loop for x in *tb-bitmap* as bit upfrom 0
+ do (when (logbitp bit code)
+ (push x sub-specs)))
+ (when (not (null members))
+ (push (cons 'member members) sub-specs))
+ (when (numscope-allp integer-range)
+ (pushnew 'integer sub-specs))
+ (when (and (not (member 'integer sub-specs))
+ integer-range)
+ (dolist (sub-range integer-range)
+ (push (list 'integer
+ (or (car sub-range) '*)
+ (or (cdr sub-range) '*))
+ sub-specs)))
+ (cond
+ ((null sub-specs)
+ (if complement t nil))
+ ((not (cdr sub-specs))
+ (if (not complement)
+ (car sub-specs)
+ (list 'not (car sub-specs))))
+ (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.
@@ -312,6 +313,8 @@
(check-type include list)
(check-type members list)
(check-type integer-range list)
+ (when (eq 'and (car include))
+ (break "foo"))
(let ((new-intscope integer-range)
(new-members ()))
(dolist (member members) ; move integer members into integer-range
@@ -392,6 +395,19 @@
(not (encoded-typep t nil x code0 integer-range0 members0 include0 nil)))
members1)
nil nil))
+ ((and (or integer-range0 integer-range1)
+ (encoded-emptyp code0 nil members0 nil complement0)
+ (encoded-emptyp code1 nil members1 nil complement1)
+ (flet ((integer-super-p (x)
+ (member x '(rational real number t))))
+ (and (every #'integer-super-p include0)
+ (every #'integer-super-p include1))))
+ (type-values () :integer-range (numscope-intersection integer-range0
+ integer-range1)))
+ ((and (= code0 code1) (equal integer-range0 integer-range1)
+ (equal members0 members1) (equal include0 include1)
+ (eq complement0 complement1))
+ (values code0 integer-range0 members0 include0 complement0))
((and include0 (null include1))
;; (and (or a b c) d) => (or (and a d) (and b d) (and c d))
(values (logand code0 code1)
@@ -413,19 +429,19 @@
include1)
nil))
(t ;; (warn "and with two includes: ~S ~S" include0 include1)
- (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
- include0 complement0)
- ,(encoded-type-decode code1 integer-range1 members1
- include1 complement1))))))
+ (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
+ include0 complement0)
+ ,(encoded-type-decode code1 integer-range1 members1
+ include1 complement1)))))))
((and complement0 complement1)
(multiple-value-bind (code integer-range members include complement)
(encoded-types-or code0 integer-range0 members0 include0 (not complement0)
code1 integer-range1 members1 include1 (not complement1))
(values code integer-range members include (not complement))))
- (t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
- include0 complement0)
- ,(encoded-type-decode code1 integer-range1 members1
- include1 complement1))))))
+ (t (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
+ include0 complement0)
+ ,(encoded-type-decode code1 integer-range1 members1
+ include1 complement1)))))))
(defun encoded-types-or (code0 integer-range0 members0 include0 complement0
code1 integer-range1 members1 include1 complement1)
@@ -659,7 +675,8 @@
(cond
((or complement include (not (= 0 code)))
nil)
- ((= 1 (length members))
+ ((and (= 1 (length members))
+ (= 0 code) (null intscope) (null include) (not complement))
members)
((and (= 1 (length intscope))
(caar intscope)
@@ -680,7 +697,7 @@
"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 members0 members1)
+ ((or include0 include1 members0 members1 (/= 0 code0) (/= 0 code1))
;; We can't know..
'number)
((or complement0 complement1)
More information about the Movitz-cvs
mailing list