diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 1a87861e2..e81217969 100755 --- a/src/cmp/cmpffi.lsp +++ b/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) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index cb4460a6b..af761b69f 100644 --- a/src/cmp/cmploc.lsp +++ b/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) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index e5b54fd56..1178e4299 100644 --- a/src/cmp/cmpspecial.lsp +++ b/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)) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 7f949416a..210990527 100644 --- a/src/cmp/cmptables.lsp +++ b/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 diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 89ca31834..7bd85f4da 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/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))))))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index a7406b2e3..a5cf20aeb 100644 --- a/src/cmp/cmpvar.lsp +++ b/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)