LDB/DPB do not check for negative indexes.
[sbcl.git] / src / pcl / walk.lisp
index ff5c160..e8eb382 100644 (file)
   ;; FLET and LABELS, so we have no idea what to use for the
   ;; environment. So we just blow it off, 'cause anything real we do
   ;; would be wrong. But we still have to make an entry so we can tell
-  ;; functions from macros.
+  ;; functions from macros -- same for telling variables apart from
+  ;; symbol macros.
   (let ((lexenv (sb!kernel::coerce-to-lexenv env)))
     (sb!c::make-lexenv
      :default lexenv
      :vars (when (eql (caar macros) *key-to-walker-environment*)
-             (copy-tree (remove :lexical-var (fourth (cadar macros))
-                                :key #'cadr)))
+             (copy-tree (mapcar (lambda (b)
+                                  (let ((name (car b))
+                                        (info (cadr b)))
+                                    (if (eq info :lexical-var)
+                                        (cons name
+                                              (if (var-special-p name env)
+                                                  (sb!c::make-global-var
+                                                   :kind :special
+                                                   :%source-name name)
+                                                  (sb!c::make-lambda-var
+                                                   :%source-name name)))
+                                        b)))
+                                (fourth (cadar macros)))))
      :funs (append (mapcar (lambda (f)
                              (cons (car f)
                                    (sb!c::make-functional :lexenv lexenv)))
 (defun env-declarations (env)
   (caddr (env-lock env)))
 
+(defun env-var-type (var env)
+  (dolist (decl (env-declarations env) t)
+    (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq))
+      (return (cadr decl)))))
+
 (defun env-lexical-variables (env)
   (cadddr (env-lock env)))
 
 (defun note-declaration (declaration env)
   (push declaration (caddr (env-lock env))))
 
-(defun note-lexical-binding (thing env)
+(defun note-var-binding (thing env)
   (push (list thing :lexical-var) (cadddr (env-lock env))))
 
 (defun var-lexical-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) :lexical-var)
       entry)))
 
 (defun variable-symbol-macro-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) 'sb!sys:macro)
       entry)))
 
-(defvar *var-declarations* '(special))
+(defun walked-var-declaration-p (declaration)
+  (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special)))
 
-(defun var-declaration (declaration var env)
-  (if (not (member declaration *var-declarations*))
-      (error "~S is not a recognized variable declaration." declaration)
-      (let ((id (or (var-lexical-p var env) var)))
+(defun %var-declaration (declaration var env)
+  (let ((id (or (var-lexical-p var env) var)))
+    (if (eq 'special declaration)
+        (dolist (decl (env-declarations env))
+          (when (and (eq (car decl) declaration)
+                     (or (member var (cdr decl))
+                         (and id (member id (cdr decl)))))
+            (return decl)))
         (dolist (decl (env-declarations env))
           (when (and (eq (car decl) declaration)
                      (eq (cadr decl) id))
             (return decl))))))
 
+(defun var-declaration (declaration var env)
+  (if (walked-var-declaration-p declaration)
+      (%var-declaration declaration var env)
+      (error "Not a variable declaration the walker cares about: ~S" declaration)))
+
+#-sb-xc-host
+(define-compiler-macro var-declaration (&whole form declaration var env
+                                        &environment lexenv)
+  (if (sb!xc:constantp declaration lexenv)
+      (let ((decl (constant-form-value declaration lexenv)))
+        (if (walked-var-declaration-p decl)
+            `(%var-declaration ,declaration ,var ,env)
+            form))
+      form))
+
 (defun var-special-p (var env)
-  (or (not (null (var-declaration 'special var env)))
-      (var-globally-special-p var)))
+  (and (or (var-declaration 'special var env)
+           (var-globally-special-p var))
+       t))
 
 (defun var-globally-special-p (symbol)
   (eq (info :variable :kind symbol) :special))
+
 \f
 ;;;; handling of special forms
 
          ((not (consp newform))
           (let ((symmac (car (variable-symbol-macro-p newform env))))
             (if symmac
-                (let ((newnewform (walk-form-internal (cddr symmac)
-                                                      context
-                                                      env)))
-                  (if (eq newnewform (cddr symmac))
-                      (if *walk-form-expand-macros-p* newnewform newform)
-                      newnewform))
+                (let* ((newnewform (walk-form-internal (cddr symmac)
+                                                       context
+                                                       env))
+                       (resultform
+                        (if (eq newnewform (cddr symmac))
+                            (if *walk-form-expand-macros-p* newnewform newform)
+                            newnewform))
+                       (type (env-var-type newform env)))
+                  (if (eq t type)
+                      resultform
+                      `(the ,type ,resultform)))
                 newform)))
          (t
           (let* ((fn (car newform))
                 (multiple-value-bind (newnewform macrop)
                     (walker-environment-bind
                         (new-env env :walk-form newform)
-                      (sb-xc:macroexpand-1 newform new-env))
+                      (%macroexpand-1 newform new-env))
                   (cond
                    (macrop
                     (let ((newnewnewform (walk-form-internal newnewform
            (let ((type (car declaration))
                  (name (cadr declaration))
                  (args (cddr declaration)))
-             (if (member type *var-declarations*)
+             (if (walked-var-declaration-p type)
                  (note-declaration `(,type
                                      ,(or (var-lexical-p name env) name)
                                      ,.args)
                                    env)
-                 (note-declaration declaration env))
+                 (note-declaration (sb!c::canonized-decl-spec declaration) env))
              (push declaration declarations)))
          (recons body
                  form
               (null (get-walker-template (car form) form))
               (progn
                 (multiple-value-setq (new-form macrop)
-                                     (sb-xc:macroexpand-1 form env))
+                                     (%macroexpand-1 form env))
                 macrop))
          ;; This form was a call to a macro. Maybe it expanded
          ;; into a declare?  Recurse to find out.
                                          &aux arg)
   (cond ((null arglist) ())
         ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
-             (note-lexical-binding arg env))
+         (or (member arg sb!xc:lambda-list-keywords :test #'eq)
+             (note-var-binding arg env))
          (recons arglist
                  arg
                  (walk-arglist (cdr arglist)
                                context
                                env
                                (and destructuringp
-                                    (not (member arg
-                                                 lambda-list-keywords))))))
+                                    (not (member arg sb!xc:lambda-list-keywords))))))
         ((consp arg)
          (prog1 (recons arglist
                         (if destructuringp
                                      (cddr arg)))
                         (walk-arglist (cdr arglist) context env nil))
                 (if (symbolp (car arg))
-                    (note-lexical-binding (car arg) env)
-                    (note-lexical-binding (cadar arg) env))
+                    (note-var-binding (car arg) env)
+                    (note-var-binding (cadar arg) env))
                 (or (null (cddr arg))
                     (not (symbolp (caddr arg)))
-                    (note-lexical-binding (caddr arg) env))))
+                    (note-var-binding (caddr arg) env))))
           (t
            (error "can't understand something in the arglist ~S" arglist))))
 
     (let* ((let/let* (car form))
            (bindings (cadr form))
            (body (cddr form))
-           (walked-bindings
-             (walk-bindings-1 bindings
-                              old-env
-                              new-env
-                              context
-                              sequentialp))
+           walked-bindings
            (walked-body
-             (walk-declarations body #'walk-repeat-eval new-env)))
+             (walk-declarations
+              body
+              (lambda (real-body real-env)
+                (setf walked-bindings
+                      (walk-bindings-1 bindings
+                                       old-env
+                                       new-env
+                                       context
+                                       sequentialp))
+                (walk-repeat-eval real-body real-env))
+              new-env)))
       (relist*
-        form let/let* walked-bindings walked-body))))
+       form let/let* walked-bindings walked-body))))
 
-(defun walk-locally (form context env)
+(defun walk-locally (form context old-env)
   (declare (ignore context))
-  (let* ((locally (car form))
-         (body (cdr form))
-         (walked-body
-          (walk-declarations body #'walk-repeat-eval env)))
-    (relist*
-     form locally walked-body)))
+  (walker-environment-bind (new-env old-env)
+    (let* ((locally (car form))
+           (body (cdr form))
+           (walked-body
+            (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist*
+       form locally walked-body))))
 
 (defun walk-multiple-value-setq (form context env)
   (let ((vars (cadr form)))
          (recons bindings
                  (if (symbolp binding)
                      (prog1 binding
-                            (note-lexical-binding binding new-env))
+                       (note-var-binding binding new-env))
                      (prog1 (relist* binding
                                      (car binding)
                                      (walk-form-internal (cadr binding)
                                      ;; the next value form. Don't
                                      ;; walk it now, though.
                                      (cddr binding))
-                            (note-lexical-binding (car binding) new-env)))
+                            (note-var-binding (car binding) new-env)))
                  (walk-bindings-1 (cdr bindings)
                                   old-env
                                   new-env
              (val (caddr form))
              (symmac (car (variable-symbol-macro-p var env))))
         (if symmac
-            (let* ((expanded `(setf ,(cddr symmac) ,val))
+            (let* ((type (env-var-type var env))
+                   (expanded (if (eq t type)
+                                 `(setf ,(cddr symmac) ,val)
+                                 `(setf ,(cddr symmac) (the ,type ,val))))
                    (walked (walk-form-internal expanded context env)))
               (if (eq expanded walked)
                   form
                (walk-tagbody-1 (cdr form) context env))))
 
 (defun walk-macrolet (form context old-env)
-  (walker-environment-bind (macro-env
-                            nil
-                            :walk-function (env-walk-function old-env))
-    (labels ((walk-definitions (definitions)
-               (and definitions
-                    (let ((definition (car definitions)))
-                      (recons definitions
-                              (relist* definition
-                                       (car definition)
-                                       (walk-arglist (cadr definition)
-                                                     context
-                                                     macro-env
-                                                     t)
-                                       (walk-declarations (cddr definition)
-                                                          #'walk-repeat-eval
-                                                          macro-env))
-                              (walk-definitions (cdr definitions)))))))
-      (with-new-definition-in-environment (new-env old-env form)
-        (relist* form
-                 (car form)
-                 (walk-definitions (cadr form))
-                 (walk-declarations (cddr form)
-                                    #'walk-repeat-eval
-                                    new-env))))))
+  (walker-environment-bind (old-env old-env)
+    (walker-environment-bind (macro-env
+                              nil
+                              :walk-function (env-walk-function old-env))
+      (labels ((walk-definitions (definitions)
+                 (and definitions
+                      (let ((definition (car definitions)))
+                        (recons definitions
+                                (relist* definition
+                                         (car definition)
+                                         (walk-arglist (cadr definition)
+                                                       context
+                                                       macro-env
+                                                       t)
+                                         (walk-declarations (cddr definition)
+                                                            #'walk-repeat-eval
+                                                            macro-env))
+                                (walk-definitions (cdr definitions)))))))
+        (with-new-definition-in-environment (new-env old-env form)
+          (relist* form
+                   (car form)
+                   (walk-definitions (cadr form))
+                   (walk-declarations (cddr form)
+                                      #'walk-repeat-eval
+                                      new-env)))))))
 
 (defun walk-flet (form context old-env)
-  (labels ((walk-definitions (definitions)
-             (if (null definitions)
-                 ()
-                 (recons definitions
-                         (walk-lambda (car definitions) context old-env)
-                         (walk-definitions (cdr definitions))))))
-    (recons form
-            (car form)
-            (recons (cdr form)
-                    (walk-definitions (cadr form))
-                    (with-new-definition-in-environment (new-env old-env form)
-                      (walk-declarations (cddr form)
-                                         #'walk-repeat-eval
-                                         new-env))))))
-
-(defun walk-labels (form context old-env)
-  (with-new-definition-in-environment (new-env old-env form)
+  (walker-environment-bind (old-env old-env)
     (labels ((walk-definitions (definitions)
                (if (null definitions)
                    ()
                    (recons definitions
-                           (walk-lambda (car definitions) context new-env)
+                           (walk-lambda (car definitions) context old-env)
                            (walk-definitions (cdr definitions))))))
       (recons form
               (car form)
               (recons (cdr form)
                       (walk-definitions (cadr form))
-                      (walk-declarations (cddr form)
-                                         #'walk-repeat-eval
-                                         new-env))))))
+                      (with-new-definition-in-environment (new-env old-env form)
+                        (walk-declarations (cddr form)
+                                           #'walk-repeat-eval
+                                           new-env)))))))
+
+(defun walk-labels (form context old-env)
+  (walker-environment-bind (old-env old-env)
+    (with-new-definition-in-environment (new-env old-env form)
+      (labels ((walk-definitions (definitions)
+                 (if (null definitions)
+                     ()
+                     (recons definitions
+                             (walk-lambda (car definitions) context new-env)
+                             (walk-definitions (cdr definitions))))))
+        (recons form
+                (car form)
+                (recons (cdr form)
+                        (walk-definitions (cadr form))
+                        (walk-declarations (cddr form)
+                                           #'walk-repeat-eval
+                                           new-env)))))))
 
 (defun walk-if (form context env)
   (destructuring-bind (if predicate arm1 &optional arm2) form