mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 07:30:55 -08:00
Code Issues Projects Releases Packages Wiki Activity

Additional functions for the environment.

Browse source
This commit is contained in:
jgarcia 2006-06-12 08:52:02 +00:00
parent b03e07bd12
commit d7c23c3ad5
3 changed files with 65 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

55
src/cmp/cmpenv.lsp
View file

@ -117,7 +117,7 @@
(defun add-function-declaration (fname arg-types return-types)
(if (si::valid-function-name-p fname)
(let ((fun (cmp-env-search-function fname *cmp-env* t)))
(let ((fun (cmp-env-search-function fname)))
(if (functionp fun)
(warn "Found function declaration for local macro ~A" fname)
(push (list fun
@ -446,7 +446,11 @@
(push (list name 'si::macro function)
(cmp-env-functions env)))
(defun cmp-env-search-function (name &optional (env *cmp-env*) macro-allowed)
(defun cmp-env-register-block (blk &optional (env *cmp-env*))
(push (list :block (blk-name blk) blk)
(cmp-env-variables env)))
(defun cmp-env-search-function (name &optional (env *cmp-env*))
(let ((ccb nil)
(clb nil)
(unw nil)
@ -462,14 +466,53 @@
(baboon))
((eq (first record) name)
(setf found (first (last record)))
(when (and (functionp found) (not macro-allowed))
;; Macro definition appears in #'.... This should not happen.
(cmperr "The name of a macro ~A was found in special form FUNCTION." name))
(return))))
(values found ccb clb unw)))
(defun cmp-env-search-variables (type name env)
(let ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-variables env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
((not (eq (first record) type)))
((and (eq type :block) (eq name (second record)))
(setf found record)
(return))
((and (eq type :tag) (member name (second record)))
(setf found record)
(return))
((eq (second record) 'si::symbol-macro)
(when (eq name 'si::symbol-macro)
(setf found record))
(return))
(t
(setf found record)
(return))))
(values (first (last found)) ccb clb unw)))
(defun cmp-env-search-block (name &optional (env *cmp-env*))
(cmp-env-search-variables :block name env))
(defun cmp-env-search-tag (name &optional (env *cmp-env*))
(cmp-env-search-variables :tag name env))
(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*))
(cmp-env-search-variables name 'si::symbol-macro env))
(defun cmp-env-search-var (name &optional (env *cmp-env*))
(cmp-env-search-variables name t env))
(defun cmp-env-search-macro (name &optional (env *cmp-env*))
(let ((f (cmp-env-search-function name env t)))
(let ((f (cmp-env-search-function name env)))
(if (functionp f) f nil)))
(defun cmp-env-mark (mark &optional (env *cmp-env*))

7
src/cmp/cmpflet.lsp
View file

@ -216,8 +216,13 @@
(defun local-function-ref (fname &optional build-object)
(multiple-value-bind (fun ccb clb unw)
(cmp-env-search-function fname *cmp-env* (not build-object))
(cmp-env-search-function fname)
(when fun
(when (functionp fun)
(when build-object
;; Macro definition appears in #'.... This should not happen.
(cmperr "The name of a macro ~A was found in special form FUNCTION." name))
(return-from local-function-ref nil))
(incf (fun-ref fun))
(cond (build-object
(setf (fun-ref-ccb fun) t))

17
src/cmp/cmputil.lsp
View file

@ -116,13 +116,16 @@
)
(defmacro with-cmp-protection (main-form error-form)
`(let* ((sys::*ihs-base* sys::*ihs-top*)
(sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval))
(*break-enable* *compiler-break-enable*)
(sys::*break-hidden-packages*
(cons (find-package 'compiler)
sys::*break-hidden-packages*))
(throw-flag t))
`(let* #+nil
((sys::*ihs-base* sys::*ihs-top*)
(sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval))
(*break-enable* *compiler-break-enable*)
(sys::*break-hidden-packages*
(cons (find-package 'compiler)
sys::*break-hidden-packages*))
(throw-flag t))
((*break-enable* *compiler-break-enable*)
(throw-flag t))
(unwind-protect
(multiple-value-prog1 ,main-form
(setf throw-flag nil))