Introduced a new location, THE, which makes a more precise estimate of the location lisp type. This allows the compiler to choose an unsafe cunction when coercing locations.

src/cmp/cmpffi.lsp

@@ -281,6 +281,7 @@
                              (t (rep-type->lisp-type type)))))
 	   (BIND (var-type (second loc)))
 	   (LCL (or (third loc) T))
+	   (THE (second loc))
 	   (otherwise T)))))
 
 (defun loc-representation-type (loc)
@@ -304,6 +305,7 @@
 	   (BIND (var-rep-type (second loc)))
 	   (LCL (lisp-type->rep-type (or (third loc) T)))
            ((JUMP-TRUE JUMP-FALSE) :bool)
+	   (THE (loc-representation-type (third loc)))
 	   (otherwise :object)))))
 
 (defun wt-coerce-loc (dest-rep-type loc)

src/cmp/cmploc.lsp

@@ -42,6 +42,7 @@
 ;;;	( SINGLE-FLOAT-VALUE single-float-value vv )
 ;;;	( STACK-POINTER index )	retrieve a value from the stack
 ;;;	( SYS:STRUCTURE-REF loc slot-name-vv slot-index )
+;;;     ( THE type location )
 ;;;	( KEYVARS n )
 ;;;	VA-ARG
 ;;;	CL-VA-ARG
@@ -65,6 +66,11 @@
     (TRASH 'TRASH)
     (T 'RETURN)))
 
+(defun precise-loc-type (loc new-type)
+  (if (subtypep (loc-type loc) new-type)
+      loc
+      `(the ,new-type ,loc)))
+
 (defun loc-in-c1form-movable-p (loc)
   "A location that is in a C1FORM and can be moved"
   (cond ((member loc '(t nil))
@@ -80,6 +86,8 @@
 	((atom loc)
 	 (baboon :format-control "Unknown location ~A found in C1FORM"
 		 :format-arguments (list loc)))
+	((eq (first loc) 'THE)
+	 (loc-in-c1form-movable-p (third loc)))
 	((member (setf loc (car loc))
 		 '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE
 		   DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE #+long-float LONG-FLOAT-VALUE
@@ -109,6 +117,8 @@
                (values t value))))
         ((atom loc)
          (values nil nil))
+	((eq (first loc) 'THE)
+	 (loc-immediate-value-p (third loc)))
         ((member (first loc)
                  '(fixnum-value long-float-value
                    double-float-value single-float-value))
@@ -136,6 +146,8 @@
            (when (eq txt :not-found)
              (unknown-location 'wt-loc loc))
            (wt txt)))
+	((stringp loc)
+	 (wt loc))
         ((var-p loc)
          (wt-var loc))
         ((vv-p loc)
@@ -170,11 +182,15 @@
 
 (defun wt-keyvars (i) (wt "keyvars[" i "]"))
 
+(defun wt-the (type loc) (wt-loc loc))
+
 (defun loc-refers-to-special (loc)
   (cond ((var-p loc)
 	 (member (var-kind loc) '(SPECIAL GLOBAL)))
 	((atom loc)
 	 nil)
+	((eq (first loc) 'THE)
+	 (loc-refers-to-special (third loc)))
 	((eq (setf loc (first loc)) 'BIND)
 	 t)
 	((eq loc 'C-INLINE)
@@ -212,6 +228,10 @@
                    (wt-nl) (wt-loc destination) (wt "= ")
                    (wt-coerce-loc (loc-representation-type *destination*) loc)
                    (wt ";"))))))))
+
+(defun set-the-loc (loc type orig-loc)
+  (let ((*destination* orig-loc))
+    (set-loc loc)))
                  
 (defun set-values-loc (loc)
   (cond ((eq loc 'VALUES))
@@ -243,6 +263,8 @@
 	((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT)
 		 :test #'eq)
 	 t)
+	((eq name 'THE)
+	 (loc-with-side-effects-p (third loc)))
 	((eq name 'FDEFINITION)
 	 (policy-global-function-checking))
 	((eq name 'C-INLINE)

src/cmp/cmpspecial.lsp

@@ -27,10 +27,10 @@
   (let* ((form (c1expr (second args)))
 	 (the-type (first args))
 	 type)
-    (setf type (values-type-and the-type (c1form-primary-type form)))
+    (setf type (values-type-and the-type (c1form-type form)))
     (if (values-type-primary-type type)
         (setf (c1form-type form) type)
-      (cmpwarn "Type mismatch was found in ~s." (cons 'THE args)))
+	(cmpwarn "Type mismatch was found in ~s." (cons 'THE args)))
     form))
 
 (defun c1compiler-let (args &aux (symbols nil) (values nil))

src/cmp/cmptables.lsp

@@ -238,8 +238,8 @@
     (tagbody . c2tagbody) ; c2
     (go . c2go) ; c2
 
-    (var . c2var) ; c2
-    (location . c2location) ; c2
+    (var . c2var/location) ; c2
+    (location . c2var/location) ; c2
     (setq . c2setq) ; c2
     (progv . c2progv) ; c2
     (psetq . c2psetq) ; c2

src/cmp/cmptype-assert.lsp

@@ -117,7 +117,7 @@
 		    `(let* ((%checked-value ,value))
 		       (declare (:read-only %checked-value))
 		       ,(expand-type-assertion '%checked-value type *cmp-env* nil)
-		       %checked-value))))
+		       (the ,type %checked-value)))))
 	     (make-c1form* 'CHECKED-VALUE
 			   :type type
 			   :args type form (c1expr full-check)))))))

src/cmp/cmpvar.lsp

@@ -262,22 +262,23 @@
     (or (eq kind 'global)
         (eq kind 'special))))
 
-(defun c2var (c1form vref)
-  (unwind-exit vref))
+(defun c2var/location (c1form loc)
+  #+(or)
+  (unwind-exit loc)
+  (unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
 
-(defun c2location (c1form loc) (unwind-exit loc))
-
-(defun wt-var (var &aux (var-loc (var-loc var))) ; ccb
+(defun wt-var (var)
   (declare (type var var))
-  (case (var-kind var)
-    (CLOSURE (wt-env var-loc))
-    (LEXICAL (wt-lex var-loc))
-    ((SPECIAL GLOBAL)
-     (if (safe-compile)
-	 (wt "ecl_symbol_value(" var-loc ")")
-	 (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")")))
-    (t (wt var-loc))
-    ))
+  (let ((var-loc (var-loc var)))
+    (case (var-kind var)
+      (CLOSURE (wt-env var-loc))
+      (LEXICAL (wt-lex var-loc))
+      ((SPECIAL GLOBAL)
+       (if (safe-compile)
+	   (wt "ecl_symbol_value(" var-loc ")")
+	   (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")")))
+      (t (wt var-loc))
+      )))
 
 (defun var-rep-type (var)
   (case (var-kind var)
@@ -371,11 +372,13 @@
       `(setf name ,form)))
 
 (defun c2setq (c1form vref form)
-  (let ((*destination* vref)) (c2expr* form))
+  ;; First comes the assignement
+  (let ((*destination* vref))
+    (c2expr* form))
+  ;; Then the returned value
   (if (eq (c1form-name form) 'LOCATION)
-    (c2location form (c1form-arg 0 form))
-    (unwind-exit vref))
-  )
+      (c2var/location form (c1form-arg 0 form))
+      (unwind-exit vref)))
 
 (defun c1progv (args)
   (check-args-number 'PROGV args 2)