diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index 4e51aaa7d554260a4fb6026efca732dc77187b75..c71b7d8cb10dbb4fc92fdde4297126b8fee02cb2 100755 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -45,9 +45,11 @@ (cond ((functionp definition) (multiple-value-bind (form lexenv) (function-lambda-expression definition) (when form - (if lexenv - (setf definition (si:eval-with-env form lexenv)) - (setf definition (si:eval-with-env form nil nil nil t))))) + (cond ((eq lexenv t) + (warn "COMPILE can not compile C closures") + (return-from bc-compile (values definition t nil))) + (lexenv (setf definition (si:eval-with-env form lexenv))) + (t (setf definition (si:eval-with-env form nil nil nil t)))))) (when name (setf (fdefinition name) definition)) (return-from bc-compile (values (or name definition) nil nil))) ((not (null definition)) @@ -66,9 +68,11 @@ (multiple-value-bind (form lexenv) (function-lambda-expression (fdefinition name)) (when form - (if lexenv - (setf definition (si:eval-with-env form lexenv)) - (setf definition (si:eval-with-env form nil nil nil t))))) + (cond ((eq lexenv t) + (warn "The bytecodes compiler can not compile C closures") + (return-from bc-compile (values definition t nil))) + (lexenv (setf definition (si:eval-with-env form lexenv))) + (t (setf definition (si:eval-with-env form nil nil nil t)))))) (when (null definition) (warn "We have lost the original function definition for ~s." name) (return-from bc-compile (values name t nil))) diff --git a/src/c/assignment.d b/src/c/assignment.d index 368c8fbc1cf3aec04c326380a2e0a287b00a4f7d..e5cc0bf298190fc7068e2290c594ed1116bbe9b5 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -114,7 +114,7 @@ ecl_rem_setf_definition(cl_object sym) int type; @ if (Null(cl_functionp(def))) - FEinvalid_function(def); + FEinvalid_function(def); pack = ecl_symbol_package(sym); if (pack != ECL_NIL && pack->pack.locked diff --git a/src/c/compiler.d b/src/c/compiler.d index 7523ca1939c71d88dc26434345e92b03d20d51fe..6c603ca28c5cf6ab1f75c25146bc3ef90c2efed6 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -371,7 +371,7 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * SI:UNWIND-PROTECT-BOUNDARY * (:declare declaration-arguments*) * macro-record = (function-name FUNCTION [| function-object]) | - * (macro-name si::macro macro-function) + * (macro-name si::macro macro-function) | * SI:FUNCTION-BOUNDARY | * SI:UNWIND-PROTECT-BOUNDARY * @@ -453,18 +453,15 @@ static void c_register_symbol_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), - c_env->variables); + c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), c_env->variables); } -/* UNUSED - static void - c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) - { - const cl_compiler_ptr c_env = env->c_env; - c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); - } -*/ +static void +c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) +{ + const cl_compiler_ptr c_env = env->c_env; + c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); +} static void c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound) @@ -486,7 +483,7 @@ c_register_boundary(cl_env_ptr env, cl_object type) } static void -guess_environment(cl_env_ptr env, cl_object interpreter_env) +guess_compiler_environment(cl_env_ptr env, cl_object interpreter_env) { if (!LISTP(interpreter_env)) return; @@ -501,14 +498,23 @@ guess_environment(cl_env_ptr env, cl_object interpreter_env) { cl_object record = ECL_CONS_CAR(interpreter_env); if (!LISTP(record)) { - c_register_function(env, record); + if (ecl_t_of(record) == t_bclosure) + record = record->bclosure.code; + c_register_function(env, record->bytecodes.name); } else { cl_object record0 = ECL_CONS_CAR(record); cl_object record1 = ECL_CONS_CDR(record); if (ECL_SYMBOLP(record0)) { - c_register_var(env, record0, FALSE, TRUE); + if (record0 == @'si::macro') + c_register_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); + else if (record0 == @'si::symbol-macro') + c_register_symbol_macro(env, ECL_CONS_CDR(record1), ECL_CONS_CAR(record1)); + else + c_register_var(env, record0, FALSE, TRUE); } else if (record1 == ecl_make_fixnum(0)) { - c_register_tags(env, ECL_NIL); + /* We have lost the information, which tag corresponds to + the lex-env record. If we are compiling a closure over a + tag, we will get an error later on. */ } else { c_register_block(env, record1); } @@ -931,11 +937,11 @@ c_call(cl_env_ptr env, cl_object args, int flags) { flags = FLAG_VALUES; } else if (ECL_SYMBOLP(name) && ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) - { - asm_op2(env, OP_CALLG, nargs); - asm_c(env, name); - flags = FLAG_VALUES; - } else { + { + asm_op2(env, OP_CALLG, nargs); + asm_c(env, name); + flags = FLAG_VALUES; + } else { /* Fixme!! We can optimize the case of global functions! */ asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); asm_op2(env, OP_CALL, nargs); @@ -1384,6 +1390,30 @@ c_function(cl_env_ptr env, cl_object args, int flags) { return asm_function(env, function, flags); } +static cl_object +create_macro_lexenv(cl_compiler_ptr c_env) +{ + /* Creates a new lexenv out of the macros in the current compiler + * environment */ + cl_object lexenv = ECL_NIL; + cl_object records; + for (records = c_env->macros; !Null(records); records = ECL_CONS_CDR(records)) { + cl_object record = ECL_CONS_CAR(records); + if (ECL_ATOM(record)) + continue; + if (CADR(record) == @'si::macro') + lexenv = CONS(CONS(@'si::macro', CONS(CADDR(record), CAR(record))), lexenv); + } + for (records = c_env->variables; !Null(records); records = ECL_CONS_CDR(records)) { + cl_object record = ECL_CONS_CAR(records); + if (ECL_ATOM(record)) + continue; + if (CADR(record) == @'si::symbol-macro') + lexenv = CONS(CONS(@'si::symbol-macro', CONS(CADDR(record), CAR(record))), lexenv); + } + return lexenv; +} + static int /* XXX: here we look for function in cmpenv */ asm_function(cl_env_ptr env, cl_object function, int flags) { if (!Null(si_valid_function_name_p(function))) { @@ -1412,10 +1442,26 @@ asm_function(cl_env_ptr env, cl_object function, int flags) { } const cl_compiler_ptr c_env = env->c_env; - asm_op2c(env, - (Null(c_env->variables) && Null(c_env->macros)) ? OP_QUOTE : OP_CLOSE, - ecl_make_lambda(env, name, body)); - + cl_object lambda = ecl_make_lambda(env, name, body); + cl_object macro_lexenv = create_macro_lexenv(c_env); + if (Null(macro_lexenv)) { + if (Null(c_env->variables)) { + /* No closure */ + asm_op2c(env, OP_QUOTE, lambda); + } else { + /* Close only around functions and variables */ + asm_op2c(env, OP_CLOSE, lambda); + } + } else { + lambda = ecl_close_around(lambda, macro_lexenv); + if (Null(c_env->variables)) { + /* Close only around macros */ + asm_op2c(env, OP_QUOTE, lambda); + } else { + /* Close around macros, functions and variables */ + asm_op2c(env, OP_CLOSE, lambda); + } + } return FLAG_REG0; } ERROR: @@ -2430,7 +2476,8 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) */ if (c_env->load_time_forms != ECL_NIL) { cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); - /* Make sure the forms are compiled in the right order */ + /* reverse the load time forms list to make sure the forms are + * compiled in the right order */ cl_object p, forms_list = cl_nreverse(c_env->load_time_forms); c_env->load_time_forms = ECL_NIL; p = forms_list; @@ -3101,14 +3148,17 @@ si_make_lambda(cl_object name, cl_object rest) } old_c_env = the_env->c_env; c_new_env(the_env, &new_c_env, compiler_env, 0); - guess_environment(the_env, interpreter_env); - new_c_env.lex_env = env; + guess_compiler_environment(the_env, interpreter_env); + if (compiler_env_p == ECL_NIL) { + new_c_env.lex_env = env; + } else { + new_c_env.lex_env = ECL_NIL; + } new_c_env.stepping = stepping != ECL_NIL; ECL_UNWIND_PROTECT_BEGIN(the_env) { if (Null(execute)) { cl_index handle = asm_begin(the_env); new_c_env.mode = FLAG_LOAD; - /*cl_print(1,form);*/ compile_with_load_time_forms(the_env, form, FLAG_VALUES); asm_op(the_env, OP_EXIT); the_env->values[0] = asm_end(the_env, handle, form); diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 489df72038d53105ca88d4ee98a6a08d9648aea9..fff44b87fc06d4413b3ce637385b0d9a57f7229f 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -429,7 +429,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Returns from the block whose record in the lexical environment occuppies the n-th position. */ - case OP_RETURN: string = "RETFROM"; + case OP_RETURN: string = "RETFROM\t"; GET_OPARG(n, vector); goto OPARG; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2baeaf86b50349adcaef61af5b96be49026732a2..cf4088a6d2e76ed97825cba1c4859abdf4902672 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -164,6 +164,20 @@ ecl_stack_frame_close(cl_object f) } /* ------------------------------ LEXICAL ENV. ------------------------------ */ +/* + * A lexical environment is a list of pairs, each one containing + * either a variable definition, a tagbody or block tag, or a local + * function or macro definition. + * + * lex_env ---> ( { record }* ) + * record = variable | function | block_tag | tagbody_tag | macro + * + * variable = ( var_name[symbol] . value ) + * function = function[bytecodes] + * block_tag = ( tag[fixnum] . block_name[symbol] ) + * tagbody_tag = ( tag[fixnum] . 0 ) + * macro = ( { si::macro | si::symbol-macro } macro_function[bytecodes] . macro_name ) + */ #define bind_var(env, var, val) CONS(CONS(var, val), (env)) #define bind_function(env, name, fun) CONS(fun, (env)) @@ -206,16 +220,28 @@ _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) return output; } -static cl_object -close_around(cl_object fun, cl_object lex) { +cl_object +ecl_close_around(cl_object fun, cl_object lex) { cl_object v; if (Null(lex)) return fun; - if (ecl_t_of(fun) != t_bytecodes) - FEerror("Internal error: close_around should be called on t_bytecodes.", 0); - v = ecl_alloc_object(t_bclosure); - v->bclosure.code = fun; - v->bclosure.lex = lex; - v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + switch (ecl_t_of(fun)) { + case t_bytecodes: + v = ecl_alloc_object(t_bclosure); + v->bclosure.code = fun; + v->bclosure.lex = lex; + v->bclosure.entry = _ecl_bclosure_dispatch_vararg; + break; + case t_bclosure: + v = ecl_alloc_object(t_bclosure); + v->bclosure.code = fun->bclosure.code; + /* Put the predefined macros in fun->bclosure.lex at the end of + the lexenv so that lexenv indices are still valid */ + v->bclosure.lex = ecl_append(lex, fun->bclosure.lex); + v->bclosure.entry = fun->bclosure.entry; + break; + default: + FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); + } return v; } @@ -671,7 +697,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) do { cl_object f; GET_DATA(f, vector, data); - f = close_around(f, old_lex); + f = ecl_close_around(f, old_lex); lex_env = bind_function(lex_env, f->bytecodes.name, f); } while (--nfun); THREAD_NEXT; @@ -702,7 +728,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) { cl_object l = lex_env; do { - ECL_RPLACA(l, close_around(ECL_CONS_CAR(l), lex_env)); + ECL_RPLACA(l, ecl_close_around(ECL_CONS_CAR(l), lex_env)); l = ECL_CONS_CDR(l); } while (--nfun); } @@ -730,14 +756,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } - /* OP_CLOSE name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. + /* OP_CLOSE name{symbol} + Creates a closure around the current lexical environment for + the function associated to the given symbol. */ CASE(OP_CLOSE); { GET_DATA(reg0, vector, data); - reg0 = close_around(reg0, lex_env); + reg0 = ecl_close_around(reg0, lex_env); THREAD_NEXT; } /* OP_GO n{arg}, tag-ndx{arg} diff --git a/src/clos/method.lsp b/src/clos/method.lsp index de3177528ca3e918ad07c3219201f3fedf303133..335b0fd5f66c1dc22ad82f1385714ed98389d248 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -251,6 +251,7 @@ ;; explicitely the bytecodes compiler with an environment, no ;; stepping, compiler-env-p = t and execute = nil, so that the ;; form does not get executed. + ;; FIXME: Why is execute t then? (si::eval-with-env method-lambda env nil t t))) (values call-next-method-p next-method-p-p diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 1892c4b6efbf1ccf4da1e704d3ba2c19599ab045..78d8ae89f07d7b61c9ab8c9d01475cd193e9c882 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -25,6 +25,54 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-copy (&optional (env *cmp-env*)) (cons (car env) (cdr env))) +(defun set-closure-env (definition lexenv &optional (env *cmp-env*)) + "Set up an environment for compilation of closures: Register closed +over macros in the compiler environment and enclose the definition of +the closure in let/flet forms for variables/functions it closes over." + (loop for record in lexenv + do (cond ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (cond ((eql (car record-def) 'LAMBDA) + (setf record-def (cdr record-def))) + ((eql (car record-def) 'EXT:LAMBDA-BLOCK) + (setf record-def (cddr record-def))) + (t + (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) + ;; allow for closures which close over closures. + ;; (first record-def) is the lambda list, (rest + ;; record-def) the definition of the local function + ;; in record + (setf (rest record-def) + (list (set-closure-env (if (= (length record-def) 2) + (second record-def) + `(progn ,@(rest record-def))) + record-lexenv env))) + (setf definition + `(flet ((,(compiled-function-name record) + ,@record-def)) + ,definition)))) + ((and (listp record) (symbolp (car record))) + (cond ((eq (car record) 'si::macro) + (cmp-env-register-macro (cddr record) (cadr record) env)) + ((eq (car record) 'si::symbol-macro) + (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) + (t + (setf definition + `(let ((,(car record) ',(cdr record))) + ,definition))) + )) + ;; ((and (integerp (cdr record)) (= (cdr record) 0)) + ;; Tags: We have lost the information, which tag + ;; corresponds to the lex-env record. If we are + ;; compiling a closure over a tag, we will get an + ;; error later on. + ;; ) + ;; (t + ;; Blocks: Not yet implemented + ) + finally (return definition))) + (defmacro cmp-env-variables (&optional (env '*cmp-env*)) `(car ,env)) @@ -102,6 +150,11 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) +(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*)) + (push (list name 'si::symbol-macro function) + (cmp-env-variables env)) + env) + (defun cmp-env-register-block (blk &optional (env *cmp-env*)) (push (list :block (blk-name blk) blk) (cmp-env-variables env)) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index e842260e79d65a7d702281fc333710860aa7b8bb..6d50babce8563ec394b8be55558b7126bdd13048 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -45,8 +45,8 @@ (cmp-env-register-function fun new-env) (push (cons fun (cdr def)) defs))) - ;; Now we compile the functions, either in an empty environment - ;; in which there are no new functions + ;; Now we compile the functions, either in the current environment + ;; or in an empty environment in which there are no new functions (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env)))) (dolist (def (nreverse defs)) (let ((fun (first def))) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 736ab439223a467ff16fe6a829c5861415a8e4d4..e68d936be7b6e5b76db099db473f8666a1f132e8 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -734,6 +734,7 @@ compiled successfully, returns the pathname of the compiled file" #+dlopen (defun compile (name &optional (def nil supplied-p) &aux form data-pathname + (lexenv nil) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*))) (*compiler-in-use* *compiler-in-use*) @@ -761,7 +762,11 @@ after compilation." (when (functionp def) (unless (function-lambda-expression def) (return-from compile def)) - (setf def (function-lambda-expression def))) + (multiple-value-setq (def lexenv) + (function-lambda-expression def)) + (when (eq lexenv t) + (warn "COMPILE can not compile C closures") + (return-from compile (values def t nil)))) (setq form (if name `(setf (fdefinition ',name) #',def) `(set 'GAZONK #',def)))) @@ -777,17 +782,20 @@ after compilation." (t (setq form `(setf (fdefinition ',name) #',form)))) - (let*((*load-time-values* 'values) ;; Only the value is kept - (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) - (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) - (compiler-conditions nil)) + (let* ((*load-time-values* 'values) ;; Only the value is kept + (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) + (data-pathname (first tmp-names)) + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil) + (*permanent-data* t) ; needed for literal objects in closures + (*cmp-env-root* *cmp-env-root*)) (with-compiler-env (compiler-conditions) + (setf form (set-closure-env form lexenv *cmp-env-root*)) (print-compiler-info) (data-init) (t1expr form) diff --git a/src/doc/new-doc/developer-guide/interpreter.txi b/src/doc/new-doc/developer-guide/interpreter.txi index 0ccf101e5cbb9f4e8c78d5a7340247e07f27bcc9..e664448e4af706340c5e53b5dc87a48d9452d6f1 100644 --- a/src/doc/new-doc/developer-guide/interpreter.txi +++ b/src/doc/new-doc/developer-guide/interpreter.txi @@ -1,6 +1,14 @@ @node The interpreter @section The interpreter +@menu +* ECL stacks:: +* Procedure Call Conventions:: +* The lexical environment:: +* The interpreter stack:: +@end menu + +@node ECL stacks @subsection ECL stacks ECL uses the following stacks: @multitable @columnfractions .3 .7 @@ -14,6 +22,7 @@ ECL uses the following stacks: @tab used for arguments/values passing, typed lexical variables, temporary values, and function invocation. @end multitable +@node Procedure Call Conventions @subsection Procedure Call Conventions ECL employs standard C calling conventions to achieve efficiency and interoperability with other languages. Each Lisp function is @@ -69,20 +78,22 @@ instance, the actual source code for @code{cl_cons} in @) @end verbatim +@node The lexical environment @subsection The lexical environment -The ECL interpreter uses two A-lists (Association lists) to represent -lexical environments. - -@itemize -@item One for variable bindings -@item One for local function/macro/tag/block bindings -@end itemize - -When a function closure is created, the current two A-lists are saved -in the closure along with the lambda expression. Later, when the -closure is invoked, the saved A-lists are used to recover the lexical +The ECL interpreter uses a list containing local functions and macros, +variables, tags and blocks to represent the lexical environment. When +a function closure is created, the current lexical environment is +saved in the closure along with the lambda expression. Later, when the +closure is invoked, this list is used to recover the lexical environment. +Note that this list is different from what the Common Lisp standard +calls a lexical environment, which is the content of a +@code{&environment} parameter to @code{defmacro}. For the differences +between this two environments see the comments in +@code{src/c/compiler.d} and @code{src/c/interpreter.d}. + +@node The interpreter stack @subsection The interpreter stack The bytecodes interpreter uses a stack of its own to save and restore diff --git a/src/doc/new-doc/developer-guide/objects.txi b/src/doc/new-doc/developer-guide/objects.txi index c31b894273dff0170fc64e91b57b33524f42d04e..1173e0b08d519a7c39db31d958f4bb7dd99e6f68 100644 --- a/src/doc/new-doc/developer-guide/objects.txi +++ b/src/doc/new-doc/developer-guide/objects.txi @@ -756,7 +756,9 @@ make_lambda function. @cppindex cl_eval @deftypefun cl_object si_safe_eval (cl_object form, cl_object env, ...) -@code{si_safe_eval} evaluates @code{form} in the lexical environment +@code{si_safe_eval} evaluates @code{form} in the lexical +environment@footnote{Note that @code{env} must be a lexical +environment as used in the interpreter, @xref{The lexical environment}} @code{env}, which can be @var{ECL_NIL}. Before evaluating it, the expression form must be bytecompiled. @@ -769,7 +771,7 @@ compatibility with previous versions. Equivalent of @code{si_safe_eval} (macro define). @end table -@subheading Exmaple +@subheading Example @exindex @code{cl_safe_eval} @example si_object form = c_string_to_object("(print 1)"); diff --git a/src/h/internal.h b/src/h/internal.h index f27411a092e59de16117abab7f015f514ad995f2..f069e27247930cb0b4b87027852693e8bb4506eb 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -228,6 +228,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form, extern cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...); extern cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...); +extern cl_object ecl_close_around(cl_object fun, cl_object env); /* ffi/backtrace.d */ diff --git a/src/h/stacks.h b/src/h/stacks.h index 3b5c9ecb0db36b0cf9e1731055ef01abe6accb6b..49f83fd53cd7d93f98bbc76d87798787377cd24d 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -387,23 +387,6 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje __ecl_env->nvalues = 3; return __aux1; \ } while (0) -/***************************** - * LEXICAL ENVIRONMENT STACK - *****************************/ -/* - * A lexical environment is a list of pairs, each one containing either - * a variable definition, a tagbody or block tag, or a local function - * definition. - * - * lex_env ---> ( { record }* ) - * record = variable | function | block_tag | tagbody_tag - * - * variable = ( var_name[symbol] . value ) - * function = ( function[bytecodes] . fun_name[symbol] ) - * block_tag = ( tag[fixnum] . block_name[symbol] ) - * tagbody_tag = ( tag[fixnum] . 0 ) - */ - /************* * LISP STACK *************/ diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index c306e31c7632ccb6e55a530b607c6dc6e2b52f64..35cfe204cc2b80806b00c21b2be696bad004e5b7 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -348,37 +348,37 @@ environment can be used to bytecompile the functions in MACROLET or SYMBOL-MACRO forms, and also to evaluate other forms." (declare (si::c-local)) (flet ((local-var-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error -"In a MACROLET function you tried to access a local variable, ~A, + #'(lambda (whole env) + (declare (ignore whole env)) + (error + "In a MACROLET function you tried to access a local variable, ~A, from the function in which it appears." name))) (local-fun-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error -"In a MACROLET function you tried to access a local function, ~A, + #'(lambda (whole env) + (declare (ignore whole env)) + (error + "In a MACROLET function you tried to access a local function, ~A, from the function in which it appears." name)))) (cons (do ((env (car old-env) (cdr env)) (variables '())) ((endp env) (nreverse variables)) (let ((i (car env))) (if (consp i) - (let ((name (first i))) - (if (not (keywordp name)) - (push (if (second i) - i - (list name 'si::symbol-macro (local-var-error-function name))) - variables)))))) + (let ((name (first i))) + (if (not (keywordp name)) + (push (if (second i) + i + (list name 'si::symbol-macro (local-var-error-function name))) + variables)))))) (do ((env (cdr old-env) (cdr env)) (macros '())) ((endp env) (nreverse macros)) (let ((i (car env))) (if (consp i) - (push (if (eq (second i) 'SI::MACRO) - i - (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) - macros))))))) + (push (if (eq (second i) 'SI::MACRO) + i + (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) + macros))))))) (defun macrolet-functions (definitions old-env) (declare (si::c-local)) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index f8c0b92028ce2edd0f9ebb2203feb10af5a4a63d..23f3974115f0dd0f2cfa40140e9ce4b407d3a86f 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -1334,20 +1334,20 @@ Use special code 0 to cancel this operation.") Use the following functions to directly access ECL stacks. Invocation History Stack: -(sys:IHS-TOP) Returns the index of the TOP of the IHS. +(SYS:IHS-TOP) Returns the index of the TOP of the IHS. (SYS:IHS-FUN i) Returns the function of the i-th entity in IHS. (SYS:IHS-ENV i) (SYS:IHS-PREV i) (SYS:IHS-NEXT i) Frame (catch, block) Stack: -(sys:FRS-TOP) Returns the index of the TOP of the FRS. +(SYS:FRS-TOP) Returns the index of the TOP of the FRS. (SYS:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. (SYS:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. (SYS:FRS-TAG i) Binding Stack: -(sys:BDS-TOP) Returns the index of the TOP of the BDS. +(SYS:BDS-TOP) Returns the index of the TOP of the BDS. (SYS:BDS-VAR i) Returns the symbol of the i-th entity in BDS. (SYS:BDS-VAL i) Returns the value of the i-th entity in BDS. diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 36b0f9d170e0ff3cdf0dec1a63f318fba69e4978..e106c03e5a2c7979eb31695cfa08b642ae4a5ee8 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1359,37 +1359,45 @@ (let ((fun-1 (lambda () :fun-1-nil)) (fun-2 (let ((fun-2-var :var)) (lambda () fun-2-var))) (fun-3 (flet ((fun-3-fun () :fun)) (lambda () (fun-3-fun)))) - (fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac))))) + (fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac)))) + (fun-5 (symbol-macrolet ((fun-5-sym :sym)) (lambda () fun-5-sym)))) (is (eq :fun-1-nil (funcall fun-1))) (is (eq :var (funcall fun-2))) (is (eq :fun (funcall fun-3))) (is (eq :mac (funcall fun-4))) + (is (eq :sym (funcall fun-5))) (let ((fun-1 (ext::bc-compile nil fun-1)) (fun-2 (ext::bc-compile nil fun-2)) (fun-3 (ext::bc-compile nil fun-3)) - (fun-4 (ext::bc-compile nil fun-4))) + (fun-4 (ext::bc-compile nil fun-4)) + (fun-5 (ext::bc-compile nil fun-5))) (is (eq :fun-1-nil (funcall fun-1))) (is (eq :var (ignore-errors (funcall fun-2))) "fun-2-var from lexenv is not used.") (is (eq :fun (ignore-errors (funcall fun-3))) "fun-3-fun from lexenv is not used.") - (is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.")))) + (is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.") + (is (eq :sym (ignore-errors (funcall fun-5))) "fun-5-sym from lexenv is not used.")))) (test cmp.0065.cmp-compile-bclosure (let ((fun-1 (lambda () :fun-1-nil)) (fun-2 (let ((fun-2-var :var)) (lambda () fun-2-var))) (fun-3 (flet ((fun-3-fun () :fun)) (lambda () (fun-3-fun)))) - (fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac))))) + (fun-4 (macrolet ((fun-4-mac () :mac)) (lambda () (fun-4-mac)))) + (fun-5 (symbol-macrolet ((fun-5-sym :sym)) (lambda () fun-5-sym)))) (is (eq :fun-1-nil (funcall fun-1))) (is (eq :var (funcall fun-2))) (is (eq :fun (funcall fun-3))) (is (eq :mac (funcall fun-4))) + (is (eq :sym (funcall fun-5))) (let ((fun-1 (compile nil fun-1)) (fun-2 (compile nil fun-2)) (fun-3 (compile nil fun-3)) - (fun-4 (compile nil fun-4))) + (fun-4 (compile nil fun-4)) + (fun-5 (compile nil fun-5))) (is (eq :fun-1-nil (funcall fun-1))) (is (eq :var (ignore-errors (funcall fun-2))) "fun-2-var from lexenv is not used.") (is (eq :fun (ignore-errors (funcall fun-3))) "fun-3-fun from lexenv is not used.") - (is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.")))) + (is (eq :mac (ignore-errors (funcall fun-4))) "fun-4-mac from lexenv is not used.") + (is (eq :sym (ignore-errors (funcall fun-5))) "fun-5-sym from lexenv is not used.")))) ;;; Date 2018-02-12 ;;; Description