mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-23 04:52:42 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-429-compile-closure' into 'develop'

Browse source 
Fix #429

Closes #429

See merge request embeddable-common-lisp/ecl!110
This commit is contained in:
Daniel Kochmański 2018-07-04 14:58:57 +00:00
commit d595f98a5b
16 changed files with 266 additions and 120 deletions
Download patch file Download diff file Expand all files Collapse all files

16
contrib/bytecmp/bytecmp.lsp
View file

@ -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)))

2
src/c/assignment.d
View file

@ -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

106
src/c/compiler.d
View file

@ -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);

2
src/c/disassembler.d
View file

@ -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;

55
src/c/interpreter.d
View file

@ -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}

1
src/clos/method.lsp
View file

@ -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

53
src/cmp/cmpenv-api.lsp
View file

@ -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))

4
src/cmp/cmpflet.lsp
View file

@ -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)))

28
src/cmp/cmpmain.lsp
View file

@ -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)

33
src/doc/new-doc/developer-guide/interpreter.txi
View file

@ -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

6
src/doc/new-doc/developer-guide/objects.txi
View file

@ -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)");

1
src/h/internal.h
View file

@ -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 */

17
src/h/stacks.h
View file

@ -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
*************/

36
src/lsp/defmacro.lsp
View file

@ -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))

6
src/lsp/top.lsp
View file

@ -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.

20
src/tests/normal-tests/compiler.lsp
View file

@ -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