Ignore:
Timestamp:
05/03/09 10:10:21 (14 years ago)
Author:
ehuelsmann
Message:

Make local GO restore the environment of the TAGBODY,
in case it jumps out of blocks setting the environment.

File:
1 edited

Legend:

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

    r11819 r11820  
    44504450         (END-BLOCK (gensym))
    44514451         (EXIT (gensym))
    4452          (must-clear-values nil))
     4452         (must-clear-values nil)
     4453         environment-register)
     4454    (when (block-needs-environment-restoration block)
     4455      (setf environment-register (allocate-register)
     4456            (block-environment-register block) environment-register))
    44534457    ;; Scan for tags.
    44544458    (dolist (subform body)
     
    44574461          (push tag local-tags)
    44584462          (push tag *visible-tags*))))
     4463
     4464    (when environment-register
     4465      ;; Note: we store the environment register,
     4466      ;; but since we don't manipulate the environment,
     4467      ;; we don't need to restore.
     4468      ;;
     4469      ;; It's here so local transfers of control can restore
     4470      ;; what we started with.
     4471      ;;
     4472      ;; Non-local transfers of control restore the environment
     4473      ;; themselves (in the finally of LET/LET*, etc.
     4474      (emit-push-current-thread)
     4475      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding"
     4476            +lisp-special-binding+)
     4477      (astore environment-register))
    44594478    (label BEGIN-BLOCK)
    44604479    (do* ((rest body (cdr rest))
     
    45234542  (declare (ignore representation))
    45244543  (let* ((name (cadr form))
    4525          (tag (find-tag name)))
     4544         (tag (find-tag name))
     4545         (tag-block (when tag (tag-block tag))))
    45264546    (unless tag
    45274547      (error "p2-go: tag not found: ~S" name))
    4528     (when (eq (tag-compiland tag) *current-compiland*)
    4529       ;; Local case.
    4530       (let* ((tag-block (tag-block tag))
    4531              (register nil))
    4532         (unless (enclosed-by-protected-block-p tag-block)
    4533           (dolist (block *blocks*)
    4534             (if (eq block tag-block)
    4535                 (return)
    4536                 (setf register (or (block-environment-register block) register))))
    4537           (when register
    4538             ;; Restore dynamic environment.
    4539             (aload *thread*)
    4540             (aload register)
    4541             (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
    4542                   +lisp-special-binding+))
    4543           (maybe-generate-interrupt-check)
    4544           (emit 'goto (tag-label tag))
    4545           (return-from p2-go))))
     4548    (when (and (eq (tag-compiland tag) *current-compiland*)
     4549               (not (enclosed-by-protected-block-p tag-block)))
     4550      ;; Local case with local transfer of control
     4551      ;;   Note: Local case with non-local transfer of control handled below
     4552      (when (block-environment-register tag-block)
     4553        ;; If there's a dynamic environment to restore, do it.
     4554        (aload *thread*)
     4555        (aload (block-environment-register tag-block))
     4556        (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
     4557              +lisp-special-binding+))
     4558      (maybe-generate-interrupt-check)
     4559      (emit 'goto (tag-label tag))
     4560      (return-from p2-go))
    45464561    ;; Non-local GO.
    45474562    (emit 'new +lisp-go-class+)
Note: See TracChangeset for help on using the changeset viewer.