mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 07:12:26 -08:00
cmp: utils: introduce a macro with-lexical-scope
This macro introduces a semantical demarcation of an inner lexical scope.
This commit is contained in:
Daniel Kochmański
parent
f57fa4fab3
commit
c2057879e4
6 changed files with 110 additions and 113 deletions
|
|
@ -147,6 +147,12 @@
|
|||
(let ((code (incf *next-cfun*)))
|
||||
(format nil prefix code (lisp-to-c-name lisp-name))))
|
||||
|
||||
(defmacro with-lexical-scope (() &body body)
|
||||
`(progn
|
||||
(wt-nl-open-brace)
|
||||
,@body
|
||||
(wt-nl-close-brace)))
|
||||
|
||||
|
||||
;;; *LAST-LABEL* holds the label# of the last used label. This is used by the
|
||||
;;; code generator to avoid duplicated labels in the same scope.
|
||||
|
|
@ -177,25 +183,23 @@
|
|||
;;; RETURN-FROM to intercept the control and eval UNWIND-PROTECT cleanup forms.
|
||||
;;; ecl_frs_pop is emited by the exit manager or the caller. -- jd 2023-11-19
|
||||
(defmacro with-unwind-frame ((tag) handler-form &body body)
|
||||
`(let ((*unwind-exit* (list* 'FRAME *unwind-exit*)))
|
||||
(wt-nl-open-brace)
|
||||
(wt-nl "ecl_frs_push(cl_env_copy," ,tag ");")
|
||||
(wt-nl "if (__ecl_frs_push_result!=0) {")
|
||||
,handler-form
|
||||
,@(when body
|
||||
`((wt-nl "} else {")
|
||||
,@body))
|
||||
(wt-nl "}")
|
||||
(wt-nl-close-brace)))
|
||||
`(with-lexical-scope ()
|
||||
(let ((*unwind-exit* (list* 'FRAME *unwind-exit*)))
|
||||
(wt-nl "ecl_frs_push(cl_env_copy," ,tag ");")
|
||||
(wt-nl "if (__ecl_frs_push_result!=0) {")
|
||||
,handler-form
|
||||
,@(when body
|
||||
`((wt-nl "} else {")
|
||||
,@body))
|
||||
(wt-nl "}"))))
|
||||
|
||||
(defmacro with-stack-frame ((var &optional loc) &body body)
|
||||
(ext:with-gensyms (hlp)
|
||||
`(let* ((,var ,(or loc "_ecl_inner_frame"))
|
||||
(,hlp "_ecl_inner_frame_aux")
|
||||
(*unwind-exit* (list* (list 'STACK ,var) *unwind-exit*)))
|
||||
(wt-nl-open-brace)
|
||||
(wt-nl "struct ecl_stack_frame " ,hlp ";")
|
||||
(wt-nl *volatile* "cl_object " ,var
|
||||
"=ecl_stack_frame_open(cl_env_copy,(cl_object)&" ,hlp ",0);")
|
||||
,@body
|
||||
(wt-nl-close-brace))))
|
||||
`(with-lexical-scope ()
|
||||
(let* ((,var ,(or loc "_ecl_inner_frame"))
|
||||
(,hlp "_ecl_inner_frame_aux")
|
||||
(*unwind-exit* (list* (list 'STACK ,var) *unwind-exit*)))
|
||||
(wt-nl "struct ecl_stack_frame " ,hlp ";")
|
||||
(wt-nl *volatile* "cl_object " ,var
|
||||
"=ecl_stack_frame_open(cl_env_copy,(cl_object)&" ,hlp ",0);")
|
||||
,@body))))
|
||||
|
|
|
|||
|
|
@ -23,21 +23,20 @@
|
|||
(let* ((blk-var (blk-var blk))
|
||||
(*env-lvl* *env-lvl*))
|
||||
(check-vref blk-var)
|
||||
(wt-nl-open-brace)
|
||||
(when (eq :object (var-kind blk-var))
|
||||
(setf (var-loc blk-var) (next-lcl))
|
||||
(wt-nl "cl_object " blk-var ";"))
|
||||
(when (env-grows (var-ref-ccb blk-var))
|
||||
;; var is referenced from a closure which may escape.
|
||||
(let ((env-lvl *env-lvl*))
|
||||
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
|
||||
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
|
||||
(with-unwind-frame (blk-var)
|
||||
(unwind-exit 'VALUEZ)
|
||||
(c2expr body))
|
||||
(when (var-ref-ccb blk-var)
|
||||
(decf *env*))
|
||||
(wt-nl-close-brace))
|
||||
(with-lexical-scope ()
|
||||
(when (eq :object (var-kind blk-var))
|
||||
(setf (var-loc blk-var) (next-lcl))
|
||||
(wt-nl "cl_object " blk-var ";"))
|
||||
(when (env-grows (var-ref-ccb blk-var))
|
||||
;; var is referenced from a closure which may escape.
|
||||
(let ((env-lvl *env-lvl*))
|
||||
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
|
||||
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
|
||||
(with-unwind-frame (blk-var)
|
||||
(unwind-exit 'VALUEZ)
|
||||
(c2expr body))
|
||||
(when (var-ref-ccb blk-var)
|
||||
(decf *env*))))
|
||||
(c2expr body)))
|
||||
|
||||
(defun c2return-from (c1form blk nonlocal val)
|
||||
|
|
|
|||
|
|
@ -90,21 +90,20 @@
|
|||
(setf comma ","))
|
||||
(wt ")")
|
||||
(wt-h ");")
|
||||
(wt-nl-open-brace)
|
||||
(when return-p
|
||||
(wt-nl return-type-name " output;"))
|
||||
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
|
||||
(wt-nl "cl_object aux;")
|
||||
(with-stack-frame (frame)
|
||||
(loop for var in vars
|
||||
and type in arg-types
|
||||
and ct in arg-type-constants
|
||||
do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");"))
|
||||
(wt-nl "aux = ecl_apply_from_stack_frame(" frame ","
|
||||
"ecl_fdefinition(" c-name-constant "));")
|
||||
;; No UNWIND-EXIT, so we must close the frame manually.
|
||||
(wt-nl "ecl_stack_frame_close(" frame ");"))
|
||||
(when return-p
|
||||
(set-loc `(ffi-data-ref "output" ,return-type-code) "aux")
|
||||
(wt-nl "return output;"))
|
||||
(wt-nl-close-brace)))
|
||||
(with-lexical-scope ()
|
||||
(when return-p
|
||||
(wt-nl return-type-name " output;"))
|
||||
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
|
||||
(wt-nl "cl_object aux;")
|
||||
(with-stack-frame (frame)
|
||||
(loop for var in vars
|
||||
and type in arg-types
|
||||
and ct in arg-type-constants
|
||||
do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");"))
|
||||
(wt-nl "aux = ecl_apply_from_stack_frame(" frame ","
|
||||
"ecl_fdefinition(" c-name-constant "));")
|
||||
;; No UNWIND-EXIT, so we must close the frame manually.
|
||||
(wt-nl "ecl_stack_frame_close(" frame ");"))
|
||||
(when return-p
|
||||
(set-loc `(ffi-data-ref "output" ,return-type-code) "aux")
|
||||
(wt-nl "return output;")))))
|
||||
|
|
|
|||
|
|
@ -212,27 +212,26 @@
|
|||
;; which is what we do here.
|
||||
(let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)))
|
||||
;; counter for optionals
|
||||
(wt-nl-open-brace)
|
||||
(wt-nl "int i = " nreq ";")
|
||||
(do ((opt optionals (cdddr opt))
|
||||
(type-check optional-type-check-forms (cdr type-check)))
|
||||
((endp opt))
|
||||
(wt-nl "if (i >= narg) {")
|
||||
(let ((*opened-c-braces* (1+ *opened-c-braces*)))
|
||||
(bind-init (second opt) (first opt))
|
||||
(when (third opt)
|
||||
(bind *vv-nil* (third opt))))
|
||||
(wt-nl "} else {")
|
||||
(let ((*opened-c-braces* (1+ *opened-c-braces*))
|
||||
(*unwind-exit* *unwind-exit*))
|
||||
(wt-nl "i++;")
|
||||
(bind va-arg-loc (first opt))
|
||||
(if (car type-check)
|
||||
(c2expr* (car type-check)))
|
||||
(when (third opt)
|
||||
(bind *vv-t* (third opt))))
|
||||
(wt-nl "}"))
|
||||
(wt-nl-close-brace)))
|
||||
(with-lexical-scope ()
|
||||
(wt-nl "int i = " nreq ";")
|
||||
(do ((opt optionals (cdddr opt))
|
||||
(type-check optional-type-check-forms (cdr type-check)))
|
||||
((endp opt))
|
||||
(wt-nl "if (i >= narg) {")
|
||||
(let ((*opened-c-braces* (1+ *opened-c-braces*)))
|
||||
(bind-init (second opt) (first opt))
|
||||
(when (third opt)
|
||||
(bind *vv-nil* (third opt))))
|
||||
(wt-nl "} else {")
|
||||
(let ((*opened-c-braces* (1+ *opened-c-braces*))
|
||||
(*unwind-exit* *unwind-exit*))
|
||||
(wt-nl "i++;")
|
||||
(bind va-arg-loc (first opt))
|
||||
(if (car type-check)
|
||||
(c2expr* (car type-check)))
|
||||
(when (third opt)
|
||||
(bind *vv-t* (third opt))))
|
||||
(wt-nl "}")))))
|
||||
|
||||
(when (or rest key-flag allow-other-keys)
|
||||
(cond ((not (or key-flag allow-other-keys))
|
||||
|
|
|
|||
|
|
@ -192,11 +192,9 @@
|
|||
(plusp *max-temp*)
|
||||
(plusp *max-env*)
|
||||
*ihs-used-p*)
|
||||
(progn
|
||||
(wt-nl-open-brace)
|
||||
(with-lexical-scope ()
|
||||
(wt-function-locals)
|
||||
(write-sequence body *compiler-output1*)
|
||||
(wt-nl-close-brace))
|
||||
(write-sequence body *compiler-output1*))
|
||||
(write-sequence body *compiler-output1*)))))
|
||||
|
||||
(defun t2compiler-let (c1form symbols values body)
|
||||
|
|
|
|||
|
|
@ -132,14 +132,14 @@
|
|||
;; Optionally register the variables with the IHS frame for debugging
|
||||
(if (policy-debug-variable-bindings)
|
||||
(let ((*unwind-exit* *unwind-exit*))
|
||||
(wt-nl-open-brace)
|
||||
(let* ((env (build-debug-lexical-env vars)))
|
||||
(when env (push 'IHS-ENV *unwind-exit*))
|
||||
(c2expr body)
|
||||
(wt-nl-close-brace)
|
||||
(when env (pop-debug-lexical-env))))
|
||||
(with-lexical-scope ()
|
||||
(ext:if-let ((env (build-debug-lexical-env vars)))
|
||||
(progn
|
||||
(push 'IHS-ENV *unwind-exit*)
|
||||
(c2expr body)
|
||||
(pop-debug-lexical-env))
|
||||
(c2expr body))))
|
||||
(c2expr body))
|
||||
|
||||
(close-inline-blocks))
|
||||
|
||||
(defun c2multiple-value-bind (c1form vars init-form body)
|
||||
|
|
@ -209,14 +209,13 @@
|
|||
(lcl (next-lcl))
|
||||
(sym-loc (make-lcl-var))
|
||||
(val-loc (make-lcl-var)))
|
||||
(wt-nl-open-brace)
|
||||
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
|
||||
(let ((*destination* sym-loc)) (c2expr* symbols))
|
||||
(let ((*destination* val-loc)) (c2expr* values))
|
||||
(let ((*unwind-exit* (cons lcl *unwind-exit*)))
|
||||
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
|
||||
(c2expr body)
|
||||
(wt-nl-close-brace))))
|
||||
(with-lexical-scope ()
|
||||
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
|
||||
(let ((*destination* sym-loc)) (c2expr* symbols))
|
||||
(let ((*destination* val-loc)) (c2expr* values))
|
||||
(let ((*unwind-exit* (cons lcl *unwind-exit*)))
|
||||
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
|
||||
(c2expr body)))))
|
||||
|
||||
(defun c2psetq (c1form vrefs forms
|
||||
&aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*))
|
||||
|
|
@ -373,29 +372,28 @@
|
|||
(let* ((*lcl* *lcl*)
|
||||
(useful-extra-vars (some #'useful-var-p (nthcdr min-values vars)))
|
||||
(nr (make-lcl-var :type :int)))
|
||||
(wt-nl-open-brace)
|
||||
(when useful-extra-vars
|
||||
;; Make a copy of env->nvalues before assigning to any variables
|
||||
(wt-nl "const int " nr " = cl_env_copy->nvalues;"))
|
||||
(with-lexical-scope ()
|
||||
(when useful-extra-vars
|
||||
;; Make a copy of env->nvalues before assigning to any variables
|
||||
(wt-nl "const int " nr " = cl_env_copy->nvalues;"))
|
||||
|
||||
;; We know that at least MIN-VALUES variables will get a value
|
||||
(dotimes (i min-values)
|
||||
(when vars
|
||||
(let ((v (pop vars))
|
||||
(loc (values-loc-or-value0 i)))
|
||||
(bind-or-set loc v use-bind))))
|
||||
;; We know that at least MIN-VALUES variables will get a value
|
||||
(dotimes (i min-values)
|
||||
(when vars
|
||||
(let ((v (pop vars))
|
||||
(loc (values-loc-or-value0 i)))
|
||||
(bind-or-set loc v use-bind))))
|
||||
|
||||
;; Assign to other variables only when the form returns enough values
|
||||
(when useful-extra-vars
|
||||
(let ((tmp (make-lcl-var)))
|
||||
(wt-nl "cl_object " tmp ";")
|
||||
(loop for v in vars
|
||||
for i from min-values
|
||||
for loc = (values-loc-or-value0 i)
|
||||
do (when (useful-var-p v)
|
||||
(wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
|
||||
(bind-or-set tmp v use-bind)))))
|
||||
(wt-nl-close-brace))
|
||||
;; Assign to other variables only when the form returns enough values
|
||||
(when useful-extra-vars
|
||||
(let ((tmp (make-lcl-var)))
|
||||
(wt-nl "cl_object " tmp ";")
|
||||
(loop for v in vars
|
||||
for i from min-values
|
||||
for loc = (values-loc-or-value0 i)
|
||||
do (when (useful-var-p v)
|
||||
(wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
|
||||
(bind-or-set tmp v use-bind)))))))
|
||||
'VALUE0))
|
||||
|
||||
(defun c2multiple-value-setq (c1form vars form)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue