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

Factor out the guts of PROGV into a function ecl_progv() shared by the interpreter and the compiler.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-06-19 14:49:29 +02:00
parent f89b5dd1b6
commit 0bf0cfbbae
4 changed files with 32 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

13
src/c/interpreter.d
View file

@ -1154,22 +1154,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
CASE(OP_PROGV); {
cl_object values = reg0;
cl_object vars = ECL_STACK_POP_UNSAFE(the_env);
cl_index n;
for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) {
cl_object var = ECL_CONS_CAR(vars);
if (values == Cnil) {
ecl_bds_bind(the_env, var, OBJNULL);
} else {
ecl_bds_bind(the_env, var, cl_car(values));
values = ECL_CONS_CDR(values);
}
}
cl_index n = ecl_progv(the_env, vars, values);
ECL_STACK_PUSH(the_env, MAKE_FIXNUM(n));
THREAD_NEXT;
}
CASE(OP_EXIT_PROGV); {
cl_index n = fix(ECL_STACK_POP_UNSAFE(the_env));
ecl_bds_unwind_n(the_env, n);
ecl_bds_unwind(the_env, n);
THREAD_NEXT;
}

23
src/c/stacks.d
View file

@ -227,6 +227,29 @@ ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index)
env->bds_top = new_bds_top;
}
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
{
cl_object vars = vars0, values = values0;
cl_index n = env->bds_top - env->bds_org;
for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
if (Null(vars)) {
return n;
} else {
cl_object var = ECL_CONS_CAR(vars);
if (Null(values)) {
ecl_bds_bind(env, var, OBJNULL);
} else {
ecl_bds_bind(env, var, ECL_CONS_CAR(values));
values = ECL_CONS_CDR(values);
}
}
}
FEerror("Wrong arguments to special form PROGV. Either~%"
"~A~%or~%~A~%are not proper lists",
2, vars0, values0);
}
static bds_ptr
get_bds_ptr(cl_object x)
{

27
src/cmp/cmpvar.lsp
View file

@ -329,34 +329,19 @@
(make-c1form* 'PROGV :type (c1form-type forms)
:args symbols values forms)))
(defun c2progv (symbols values body
&aux (*unwind-exit* *unwind-exit*))
(defun c2progv (symbols values body)
(let* ((*lcl* *lcl*)
(lcl (next-lcl))
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var)))
(wt-nl "{cl_object " sym-loc "," val-loc ";")
(wt-nl "cl_index " lcl " = cl_env_copy->bds_top - cl_env_copy->bds_org;")
(push lcl *unwind-exit*)
(val-loc (make-lcl-var))
(*unwind-exit* (cons lcl *unwind-exit*)))
(wt-nl "{cl_object " sym-loc "," val-loc "; cl_index " lcl ";")
(let ((*destination* sym-loc)) (c2expr* symbols))
(let ((*destination* val-loc)) (c2expr* values))
(wt-nl "while(!ecl_endp(" sym-loc ")) {")
(when (safe-compile)
(wt-nl "if(type_of(CAR(" sym-loc "))!=t_symbol)")
(wt-nl
"FEinvalid_variable(\"~s is not a symbol.\",CAR(" sym-loc "));"))
(wt-nl "if(ecl_endp(" val-loc "))ecl_bds_bind(cl_env_copy,CAR(" sym-loc "),OBJNULL);")
(wt-nl "else{ecl_bds_bind(cl_env_copy,CAR(" sym-loc "),CAR(" val-loc "));")
(wt-nl val-loc "=CDR(" val-loc ");}")
(wt-nl sym-loc "=CDR(" sym-loc ");}")
(wt-nl lcl "= ecl_progv(cl_env_copy," sym-loc "," val-loc ");")
(c2expr body)
(wt "}")
)
)
))
(defun c1psetq (old-args &aux (args nil) (use-psetf nil))
(do (var (l old-args (cddr l)))

1
src/h/external.h
View file

@ -1417,6 +1417,7 @@ extern ECL_API cl_object si_set_limit(cl_object type, cl_object size);
extern ECL_API cl_object si_get_limit(cl_object type);
extern ECL_API void ecl_bds_overflow(void) /*__attribute__((noreturn))*/;
extern ECL_API cl_index ecl_progv(cl_env_ptr env, cl_object vars, cl_object values);
extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index);
extern ECL_API void ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) /*__attribute__((noreturn))*/;
extern ECL_API ecl_frame_ptr frs_sch(cl_object frame_id);