Changeset 11833
- Timestamp:
- 05/05/09 21:42:17 (14 years ago)
- 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 211 211 (dolist (variable vars) 212 212 (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))) 214 215 ;; For processing declarations, we want to walk the variable list from 215 216 ;; last to first, since declarations apply to the last-defined variable 216 217 ;; 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))) 218 220 (setf (block-vars block) vars) 219 221 ;; Make free specials visible. … … 256 258 (dolist (variable vars) 257 259 (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)) 260 264 (setf (block-vars block) (nreverse vars))) 261 265 (setf body (p1-body body)) … … 325 329 (let ((protected (enclosed-by-protected-block-p block))) 326 330 (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)))))) 329 338 (t 330 339 (setf (block-non-local-return-p block) t))) … … 375 384 (let ((tag-block (tag-block tag))) 376 385 (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? 378 387 (if (enclosed-by-protected-block-p tag-block) 379 388 (setf (block-non-local-go-p tag-block) t) … … 711 720 (when (neq new-form form) 712 721 (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)) 717 731 718 732 (defknown rewrite-progv (t) t) -
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r11832 r11833 4636 4636 (setf (block-target block) target) 4637 4637 (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))) 4645 4644 (setf (block-catch-tag block) (gensym)) 4646 4645 (let* ((*register* *register*) … … 4786 4785 (compile-constant (eval (second form)) target representation)))) 4787 4786 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)) 4790 4790 (values-form (caddr form)) 4791 4791 (*register* *register*) 4792 (environment-register (allocate-register)) 4792 (environment-register 4793 (setf (block-environment-register block) (allocate-register))) 4793 4794 (label-START (gensym)) 4794 4795 (label-END (gensym)) … … 4805 4806 (emit-invokestatic +lisp-class+ "progvBindVars" 4806 4807 (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)) 4813 4815 4814 4816 ;; Restore dynamic environment. … … 7939 7941 (cond ((equal (block-name form) '(TAGBODY)) 7940 7942 (p2-tagbody-node form target) 7941 (fix-boxing representation nil) 7942 ) 7943 (fix-boxing representation nil)) 7943 7944 ((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)) 7947 7946 ((equal (block-name form) '(MULTIPLE-VALUE-BIND)) 7948 7947 (p2-m-v-b-node form target) 7949 (fix-boxing representation nil) 7950 ) 7948 (fix-boxing representation nil)) 7951 7949 ((equal (block-name form) '(UNWIND-PROTECT)) 7952 7950 (p2-unwind-protect-node form target) 7953 (fix-boxing representation nil) 7954 ) 7951 (fix-boxing representation nil)) 7955 7952 ((equal (block-name form) '(CATCH)) 7956 7953 (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)) 7959 7957 (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)))) 7965 7959 ((constantp form) 7966 7960 (compile-constant form target representation)) … … 8709 8703 (install-p2-handler 'or 'p2-or) 8710 8704 (install-p2-handler 'packagep 'p2-packagep) 8711 (install-p2-handler 'progv 'p2-progv)8712 8705 (install-p2-handler 'puthash 'p2-puthash) 8713 8706 (install-p2-handler 'quote 'p2-quote)
Note: See TracChangeset
for help on using the changeset viewer.