Changeset 11833


Ignore:
Timestamp:
05/05/09 21:42:17 (14 years ago)
Author:
ehuelsmann
Message:

Special bindings fixes:

compiler-pass1.lisp: set BLOCK-ENVIRONMENT-REGISTER to T,

for ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P to find.

p1-progv: correctness; the symbol and values forms are

outside of the progv-block-scope

p2-progv-node: from p2-progv. A node is required to

indicate to code inside the PROGV scope that bindings
restoration is in order

p1-return-from: indicate to the associated block that

a RETURN-FROM instruction will want to

p2-block-node: p2-progv-node doesn't register variables,

yet it does require a block restoration. Now that
PROGV uses a block (with an environment-register!)
it's incorrect to look at *all-variables*.

... and a little bit of re-indenting.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r11829 r11833  
    211211      (dolist (variable vars)
    212212        (when (special-variable-p (variable-name variable))
    213           (setf (variable-special-p variable) t)))
     213          (setf (variable-special-p variable) t
     214                (block-environment-register block) t)))
    214215      ;; For processing declarations, we want to walk the variable list from
    215216      ;; last to first, since declarations apply to the last-defined variable
    216217      ;; with the specified name.
    217       (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars)))
     218      (setf (block-free-specials block)
     219            (process-declarations-for-vars body (reverse vars)))
    218220      (setf (block-vars block) vars)
    219221      ;; Make free specials visible.
    … …  
    256258      (dolist (variable vars)
    257259        (when (special-variable-p (variable-name variable))
    258           (setf (variable-special-p variable) t)))
    259       (setf (block-free-specials block) (process-declarations-for-vars body vars))
     260          (setf (variable-special-p variable) t
     261                (block-environment-register block) t)))
     262      (setf (block-free-specials block)
     263            (process-declarations-for-vars body vars))
    260264      (setf (block-vars block) (nreverse vars)))
    261265    (setf body (p1-body body))
    … …  
    325329           (let ((protected (enclosed-by-protected-block-p block)))
    326330             (dformat t "p1-return-from protected = ~S~%" protected)
    327              (when protected
    328                (setf (block-non-local-return-p block) t))))
     331             (if protected
     332                 (setf (block-non-local-return-p block) t)
     333                 ;; non-local GO's ensure environment restoration
     334                 ;; find out about this local GO
     335                 (when (null (block-needs-environment-restoration block))
     336                   (setf (block-needs-environment-restoration block)
     337                         (enclosed-by-environment-setting-block-p block))))))
    329338          (t
    330339           (setf (block-non-local-return-p block) t)))
    … …  
    375384    (let ((tag-block (tag-block tag)))
    376385      (cond ((eq (tag-compiland tag) *current-compiland*)
    377              ;; Does the GO leave an enclosing UNWIND-PROTECT?
     386             ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
    378387             (if (enclosed-by-protected-block-p tag-block)
    379388                 (setf (block-non-local-go-p tag-block) t)
    … …  
    711720    (when (neq new-form form)
    712721      (return-from p1-progv (p1 new-form))))
    713   (let ((symbols-form (cadr form))
    714         (values-form (caddr form))
    715         (body (cdddr form)))
    716     `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body))))
     722  (let* ((symbols-form (p1 (cadr form)))
     723         (values-form (p1 (caddr form)))
     724         (block (make-block-node '(PROGV)))
     725         (*blocks* (cons block *blocks*))
     726         (body (cdddr form)))
     727    (setf (block-form block)
     728          `(progv ,symbols-form ,values-form ,@(p1-body body))
     729          (block-environment-register block) t)
     730    block))
    717731
    718732(defknown rewrite-progv (t) t)

  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11832 r11833  
    46364636           (setf (block-target block) target)
    46374637           (dformat t "p2-block-node lastSpecialBinding~%")
    4638            (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
    4639            (cond ((some #'variable-special-p *all-variables*)
    4640                   ;; Save the current dynamic environment.
    4641                   (setf (block-environment-register block) (allocate-register))
    4642       (save-dynamic-environment (block-environment-register block)))
    4643                  (t
    4644                   (dformat t "no specials~%")))
     4638           (dformat t "*all-variables* = ~S~%"
     4639                    (mapcar #'variable-name *all-variables*))
     4640           (when (block-needs-environment-restoration block)
     4641             ;; Save the current dynamic environment.
     4642             (setf (block-environment-register block) (allocate-register))
     4643             (save-dynamic-environment (block-environment-register block)))
    46454644           (setf (block-catch-tag block) (gensym))
    46464645           (let* ((*register* *register*)
    … …  
    47864785         (compile-constant (eval (second form)) target representation))))
    47874786
    4788 (defun p2-progv (form target representation)
    4789   (let* ((symbols-form (cadr form))
     4787(defun p2-progv-node (block target representation)
     4788  (let* ((form (block-form block))
     4789         (symbols-form (cadr form))
    47904790         (values-form (caddr form))
    47914791         (*register* *register*)
    4792          (environment-register (allocate-register))
     4792         (environment-register
     4793          (setf (block-environment-register block) (allocate-register)))
    47934794         (label-START (gensym))
    47944795         (label-END (gensym))
    … …  
    48054806    (emit-invokestatic +lisp-class+ "progvBindVars"
    48064807                       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
    4807     ;; Implicit PROGN.
    4808     (compile-progn-body (cdddr form) target)
    4809     (emit 'goto label-EXIT)
    4810     (label label-END)
    4811     (restore-dynamic-environment environment-register)
    4812     (emit 'athrow)
     4808      ;; Implicit PROGN.
     4809    (let ((*blocks* (cons block *blocks*)))
     4810      (compile-progn-body (cdddr form) target)
     4811      (emit 'goto label-EXIT)
     4812      (label label-END)
     4813      (restore-dynamic-environment environment-register)
     4814      (emit 'athrow))
    48134815
    48144816    ;; Restore dynamic environment.
    … …  
    79397941         (cond ((equal (block-name form) '(TAGBODY))
    79407942                (p2-tagbody-node form target)
    7941                 (fix-boxing representation nil)
    7942                 )
     7943                (fix-boxing representation nil))
    79437944               ((equal (block-name form) '(LET))
    7944                 (p2-let/let*-node form target representation)
    7945 ;;                 (fix-boxing representation nil)
    7946                 )
     7945                (p2-let/let*-node form target representation))
    79477946               ((equal (block-name form) '(MULTIPLE-VALUE-BIND))
    79487947                (p2-m-v-b-node form target)
    7949                 (fix-boxing representation nil)
    7950                 )
     7948                (fix-boxing representation nil))
    79517949               ((equal (block-name form) '(UNWIND-PROTECT))
    79527950                (p2-unwind-protect-node form target)
    7953                 (fix-boxing representation nil)
    7954                 )
     7951                (fix-boxing representation nil))
    79557952               ((equal (block-name form) '(CATCH))
    79567953                (p2-catch-node form target)
    7957                 (fix-boxing representation nil)
    7958                 )
     7954                (fix-boxing representation nil))
     7955               ((equal (block-name form) '(PROGV))
     7956                (p2-progv-node form target representation))
    79597957               (t
    7960                 (p2-block-node form target representation)
    7961 ;;                 (fix-boxing representation nil)
    7962                 ))
    7963 ;;          (fix-boxing representation nil)
    7964          )
     7958                (p2-block-node form target representation))))
    79657959        ((constantp form)
    79667960         (compile-constant form target representation))
    … …  
    87098703  (install-p2-handler 'or                  'p2-or)
    87108704  (install-p2-handler 'packagep            'p2-packagep)
    8711   (install-p2-handler 'progv               'p2-progv)
    87128705  (install-p2-handler 'puthash             'p2-puthash)
    87138706  (install-p2-handler 'quote               'p2-quote)
Note: See TracChangeset for help on using the changeset viewer.