Changeset 11820
- Timestamp:
- 05/03/09 10:10:21 (15 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r11819 r11820 361 361 (cond ((eq (tag-compiland tag) *current-compiland*) 362 362 ;; Does the GO leave an enclosing UNWIND-PROTECT? 363 (when (enclosed-by-protected-block-p tag-block) 364 (setf (block-non-local-go-p tag-block) t))) 363 (if (enclosed-by-protected-block-p tag-block) 364 (setf (block-non-local-go-p tag-block) t) 365 ;; non-local GO's ensure environment restoration 366 ;; find out about this local GO 367 (when (null (block-needs-environment-restoration tag-block)) 368 (setf (block-needs-environment-restoration tag-block) 369 (enclosed-by-environment-setting-block-p tag-block))))) 365 370 (t 366 371 (setf (block-non-local-go-p tag-block) t))))) -
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r11819 r11820 4450 4450 (END-BLOCK (gensym)) 4451 4451 (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)) 4453 4457 ;; Scan for tags. 4454 4458 (dolist (subform body) … … 4457 4461 (push tag local-tags) 4458 4462 (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)) 4459 4478 (label BEGIN-BLOCK) 4460 4479 (do* ((rest body (cdr rest)) … … 4523 4542 (declare (ignore representation)) 4524 4543 (let* ((name (cadr form)) 4525 (tag (find-tag name))) 4544 (tag (find-tag name)) 4545 (tag-block (when tag (tag-block tag)))) 4526 4546 (unless tag 4527 4547 (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)) 4546 4561 ;; Non-local GO. 4547 4562 (emit 'new +lisp-go-class+) -
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
r11819 r11820 362 362 ;; True if a tag in this tagbody is the target of a non-local GO. 363 363 non-local-go-p 364 ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the 365 ;; environment, with GO forms in them which target tags in this TAGBODY 366 needs-environment-restoration 364 367 ;; If non-nil, register containing saved dynamic environment for this block. 365 368 environment-register … … 410 413 (return-from enclosed-by-protected-block-p t)))) 411 414 415 (defknown enclosed-by-environment-setting-block-p (&optional outermost-block) 416 boolean) 417 (defun enclosed-by-environment-setting-block-p (&optional outermost-block) 418 (dolist (enclosing-block *blocks*) 419 (when (eq enclosing-block outermost-block) 420 (return nil)) 421 (when (block-environment-register enclosing-block) 422 (return t)))) 412 423 413 424 (defstruct tag
Note: See TracChangeset
for help on using the changeset viewer.