gcl.git - GNU Common Lisp

diff --git a/gcl/cmpnew/gcl_cmpeval.lsp b/gcl/cmpnew/gcl_cmpeval.lsp
index bb3760997..52f432baa 100755
--- a/gcl/cmpnew/gcl_cmpeval.lsp
+++ b/gcl/cmpnew/gcl_cmpeval.lsp

@@ -1740,12 +1740,9 @@

(defun or-ccb-assignments (fms)

(mapc (lambda (x &aux (i (cadr x)))

- (mapc (lambda (v)

- (when (var-p v)

- (let ((tp (get (var-store v) 'ccb-tp)));FIXME setq tp nil?

- (when tp

- (do-setq-tp v '(ccb-ref) (type-or1 (var-type v) (get (var-store v) 'ccb-tp)))

- (setf (var-store v) +opaque+))))) (append (info-ref-ccb i) (info-ref-clb i)))) fms))

+ (mapc (lambda (x &aux (v (pop x)))

+ (do-setq-tp v '(ccb-ref) (type-or1 (var-type v) x))

+ (setf (var-store v) +opaque+)) (info-ch-ccb i))) fms))

(defun mi6 (fn fms)

(or-ccb-assignments fms)

diff --git a/gcl/cmpnew/gcl_cmpif.lsp b/gcl/cmpnew/gcl_cmpif.lsp
index 67e939ec5..14ce39438 100755
--- a/gcl/cmpnew/gcl_cmpif.lsp
+++ b/gcl/cmpnew/gcl_cmpif.lsp

@@ -105,7 +105,8 @@

(<= (cmp-norm-tp `(real * ,(or (caddr t2) '*))))))))

(defmacro vl-name (x) `(var-name (car (third ,x))))

-(defmacro vl-type (x) `(var-type (car (third ,x))))

+;(defmacro vl-type (x) `(var-type (car (third ,x)))) ; Won't work, ref might be across a function boundary

+(defmacro vl-type (x) `(itp ,x))

(defmacro itp (x) `(info-type (second ,x)))

(defmacro vlp (x) `(and (eq 'var (car ,x)) (member (car (third ,x)) *vars*)))

;(defmacro vlp (x) `(and (eq 'var (car ,x)) (eq (var-kind (car (third ,x))) 'lexical)))

diff --git a/gcl/cmpnew/gcl_cmpinline.lsp b/gcl/cmpnew/gcl_cmpinline.lsp
index 8672e850e..95b15edc4 100755
--- a/gcl/cmpnew/gcl_cmpinline.lsp
+++ b/gcl/cmpnew/gcl_cmpinline.lsp

@@ -57,6 +57,7 @@

(ref-ccb nil :type list)

(ref-clb nil :type list)

(ref nil :type list)

+ (ch-ccb nil :type list)

)

(si::freeze-defstruct 'info)

@@ -183,6 +184,12 @@

(mrg info-ref))

(when (/= (info-sp-change from-info) 0) (setf (info-sp-change to-info) 1))

(setf (info-flags to-info) (logior (info-flags to-info) (info-flags from-info)))

+ (setf (info-ch-ccb to-info)

+ (reduce (lambda (y x &aux (v (car x))(z (assoc v y)))

+ (cond (z (setf (cdr z) (type-or1 (cdr z) (cdr x))) y)

+ ((member v (info-ch to-info)) (cons x y))

+ (y))) (info-ch-ccb from-info)

+ :initial-value (remove-if-not (lambda (x) (member (car x) (info-ch to-info))) (info-ch-ccb to-info))))

to-info)

;; (defun add-info (to-info from-info)

diff --git a/gcl/cmpnew/gcl_cmpvar.lsp b/gcl/cmpnew/gcl_cmpvar.lsp
index 2ef13563b..8c0e71207 100755
--- a/gcl/cmpnew/gcl_cmpvar.lsp
+++ b/gcl/cmpnew/gcl_cmpvar.lsp

@@ -995,7 +995,8 @@

(assert st)

; (assert (info-type (cadr form1)))

(setq type (info-type (cadr form1)))

- (unless (eq st +opaque+) (setf (get st 'ccb-tp) (type-or1 (get st 'ccb-tp) (info-type (cadr form1))))))

+ (unless (type>= (var-type (car name1)) (info-type (cadr form1)))

+ (setf (info-ch-ccb info) (list (cons (car name1) (info-type (cadr form1)))))))

(t

(do-setq-tp v (list form form1) (info-type (cadr form1)))

(setq type (var-type (car name1)))