[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Mon Jan 3 11:55:29 UTC 2005
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv9113
Modified Files:
special-operators-cl.lisp
Log Message:
Started support for stack-allocating functions (of dynamic
extent). Primary purpose is to evaluate e.g. handler-case without
having to cons up a function for each handler.
Date: Mon Jan 3 12:55:28 2005
Author: ffjeld
Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.39 movitz/special-operators-cl.lisp:1.40
--- movitz/special-operators-cl.lisp:1.39 Thu Dec 9 23:45:36 2004
+++ movitz/special-operators-cl.lisp Mon Jan 3 12:55:27 2005
@@ -1,6 +1,6 @@
;;;;------------------------------------------------------------------
;;;;
-;;;; Copyright (C) 2000-2004,
+;;;; Copyright (C) 2000-2005,
;;;; Department of Computer Science, University of Tromso, Norway
;;;;
;;;; Filename: special-operators-cl.lisp
@@ -9,7 +9,7 @@
;;;; Created at: Fri Nov 24 16:31:11 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: special-operators-cl.lisp,v 1.39 2004/12/09 22:45:36 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.40 2005/01/03 11:55:27 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -862,24 +862,29 @@
(let ((block-env (movitz-env-get block-name :block-name nil env)))
(assert block-env (block-name)
"Block-name not found for return-from: ~S." block-name)
- (cond
- ((and (eq funobj (movitz-environment-funobj block-env))
- (null (nth-value 2 (stack-delta env block-env))))
- (compiler-values-bind (&code return-code &returns return-mode)
- (compiler-call #'compile-form
- :forward all
- :form result-form
- :result-mode (exit-result-mode block-env))
- (compiler-values ()
- :returns :non-local-exit
- :code (append return-code
- `((:lexical-control-transfer nil ,return-mode ,env ,block-env))))))
- ((not (and (eq funobj (movitz-environment-funobj block-env))
- (null (nth-value 2 (stack-delta env block-env)))))
- (compiler-call #'compile-form-unprotected
- :forward all
- :form `(muerte::exact-throw ,(save-esp-variable block-env)
- ,result-form)))))))
+ (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects)
+ (stack-delta env block-env)
+ (declare (ignore stack-distance))
+ (cond
+ ((and (eq funobj (movitz-environment-funobj block-env))
+ (not (eq t num-dynamic-slots))
+ (null unwind-protects))
+ (compiler-values-bind (&code return-code &returns return-mode)
+ (compiler-call #'compile-form
+ :forward all
+ :form result-form
+ :result-mode (exit-result-mode block-env))
+ (compiler-values ()
+ :returns :non-local-exit
+ :code (append return-code
+ `((:lexical-control-transfer nil ,return-mode ,env ,block-env))))))
+ ((not (and (eq funobj (movitz-environment-funobj block-env))
+ (not (eq t num-dynamic-slots))
+ (null unwind-protects)))
+ (compiler-call #'compile-form-unprotected
+ :forward all
+ :form `(muerte::exact-throw ,(save-esp-variable block-env)
+ ,result-form))))))))
(define-special-operator require (&form form)
(let ((*require-dependency-chain*
@@ -1023,31 +1028,7 @@
:functional-p t
:returns lambda-result-mode
:modifies nil
- :code `((:load-lambda ,lambda-binding ,lambda-result-mode)))))
- #+old-compiler
- (cond
- ((movitz-funobj-borrowed-bindings closure-funobj)
- (compiler-values ()
- :type 'function
- :functional-p nil
- :returns :edx
- :modifies (movitz-funobj-borrowed-bindings closure-funobj)
- :code (append
- (compiler-call #'compile-form
- :env env
- :funobj funobj
- :result-mode :edx
- :form `(muerte::copy-funobj ,closure-funobj))
- (loop for borrowing-binding in (movitz-funobj-borrowed-bindings closure-funobj)
- as lended-binding = (borrowed-binding-target borrowing-binding)
- append
- `((:lend-lexical ,lended-binding ,borrowing-binding :edx))))))
- ((null (movitz-funobj-borrowed-bindings closure-funobj))
- (compiler-call #'compile-self-evaluating
- :env env
- :funobj funobj
- :result-mode result-mode
- :form closure-funobj))))))))))
+ :code `((:load-lambda ,lambda-binding ,lambda-result-mode ,env))))))))))))
(define-special-operator flet (&all forward &form form &env env &funobj funobj)
(destructuring-bind (flet-specs &body declarations-and-body)
@@ -1063,18 +1044,28 @@
(multiple-value-bind (flet-body flet-declarations flet-docstring)
(parse-docstring-declarations-and-body flet-dd-body)
(declare (ignore flet-docstring))
- (make-instance 'function-binding
- :name flet-name
- :parent-funobj funobj
- :funobj (make-compiled-funobj-pass1 (list 'muerte.cl::flet
- (movitz-funobj-name funobj)
- flet-name)
- flet-lambda-list
- flet-declarations
- (list* 'muerte.cl:block
- (compute-function-block-name flet-name)
- flet-body)
- env nil)))
+ (let ((flet-funobj
+ (make-compiled-funobj-pass1 (list 'muerte.cl::flet
+ (movitz-funobj-name funobj)
+ flet-name)
+ flet-lambda-list
+ flet-declarations
+ (list* 'muerte.cl:block
+ (compute-function-block-name flet-name)
+ flet-body)
+ env nil)))
+ (when (find-if (lambda (declaration)
+ (and (eq 'muerte.cl:dynamic-extent (car declaration))
+ (member `(muerte.cl:function ,flet-name)
+ (cdr declaration)
+ :test #'equal)))
+ declarations)
+ (setf (movitz-funobj-extent flet-funobj) :dynamic-extent)
+ (warn "dynamic-extent flet: ~S" flet-name))
+ (make-instance 'function-binding
+ :name flet-name
+ :parent-funobj funobj
+ :funobj flet-funobj)))
do (movitz-env-add-binding flet-env flet-binding)
collect `(:local-function-init ,flet-binding))))
(compiler-values-bind (&all body-values &code body-code)
@@ -1089,7 +1080,7 @@
(destructuring-bind (symbols-form values-form &body body)
(cdr form)
(compiler-values-bind (&code body-code &returns body-returns)
- (let ((body-env (make-instance 'with-things-on-stack-env
+ (let ((body-env (make-instance 'progv-env
:uplink env
:funobj funobj
:stack-used t
More information about the Movitz-cvs
mailing list