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

Merged the new function call code

Browse source
This commit is contained in:
jgarcia 2008-02-16 10:28:32 +00:00
parent 35f050abd6
commit 52f4df1901
28 changed files with 645 additions and 600 deletions
Download patch file Download diff file Expand all files Collapse all files

5
contrib/profile/profile.lisp
View file

@ -36,9 +36,6 @@
`(progn ,@body))
)
(ffi:clines "
")
(defconstant +wrap+ (ffi:c-inline () () :object "ecl_make_unsigned_integer(~((size_t)0))"
:one-liner t))
@ -390,7 +387,7 @@ Lisp process."
"~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
(sort no-call-name-list #'string<
:key (lambda (name)
(symbol-name (fun-name-block-name name))))))
(symbol-name name)))))
(values)))

10
msvc/ecl-threads.def
View file

@ -195,6 +195,14 @@ EXPORTS
; interpreter.c
si_interpreter_stack
ecl_stack_frame_reserve
ecl_stack_frame_push
ecl_stack_frame_push_va_list
ecl_stack_frame_close
ecl_stack_frame_pop_values
ecl_stack_frame_elt
ecl_stack_frame_elt_set
ecl_apply_from_stack_frame
cl_stack_push
cl_stack_pop
@ -365,7 +373,7 @@ EXPORTS
;si_set_funcallable
si_generic_function_p
_ecl_compute_method
_ecl_standard_dispatch
; hash.c

10
msvc/ecl.def
View file

@ -200,6 +200,14 @@ EXPORTS
; interpreter.c
si_interpreter_stack
ecl_stack_frame_reserve
ecl_stack_frame_push
ecl_stack_frame_push_va_list
ecl_stack_frame_close
ecl_stack_frame_pop_values
ecl_stack_frame_elt
ecl_stack_frame_elt_set
ecl_apply_from_stack_frame
cl_stack_push
cl_stack_pop
@ -371,7 +379,7 @@ EXPORTS
;si_set_funcallable
si_generic_function_p
_ecl_compute_method
_ecl_standard_dispatch
; hash.c

7
src/CHANGELOG
View file

@ -84,6 +84,13 @@ ECL 0.9k:
- The compiler now inlines and optimizes (FUNCALL (X ..) ... ) where X is a
macro that returns a lambda form.
* System design:
- We introduce a new kind of lisp objects, the stack frames. These are objects
with dynamical extent, which work as adjustable arrays and are mainly used
for collecting the arguments of a function, in MAP, MAPCAR, APPLY, FUNCALL,
MULTIPLE-VALUE-CALL, etc.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***

8
src/c/arch/ffi_x86.d
View file

@ -110,6 +110,8 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer)
union ecl_ffi_values output;
enum ecl_ffi_tag tag;
ECL_BUILD_STACK_FRAME(frame);
fun = CAR(cbk_info);
rtype = CADR(cbk_info);
argtypes = CADDR(cbk_info);
@ -119,7 +121,7 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer)
tag = ecl_foreign_type_code(CAR(argtypes));
size = fix(si_size_of_foreign_elt_type(CAR(argtypes)));
result = ecl_foreign_data_ref_elt(arg_buffer, tag);
cl_stack_push(result);
ecl_stack_frame_push(frame,result);
{
int mask = 3;
int sp = (size + mask) & ~mask;
@ -127,8 +129,8 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer)
}
}
result = cl_apply_from_stack(i, fun);
cl_stack_pop_n(i);
result = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
tag = ecl_foreign_type_code(rtype);
memset(&output, 0, sizeof(output));

12
src/c/compiler.d
View file

@ -1918,7 +1918,8 @@ compile_form(cl_object stmt, int flags) {
stmt = CAR(stmt);
goto QUOTED;
}
for (l = database; l->symbol != OBJNULL; l++)
for (l = database; l->symbol != OBJNULL; l++) {
/*cl_print(1, l->symbol);*/
if (l->symbol == function) {
ENV->lexical_level += l->lexical_increment;
if (ENV->stepping && function != @'function' &&
@ -1930,6 +1931,7 @@ compile_form(cl_object stmt, int flags) {
asm_op(OP_STEPOUT);
goto OUTPUT;
}
}
/*
* Next try to macroexpand
*/
@ -2389,7 +2391,13 @@ ecl_make_lambda(cl_object name, cl_object lambda) {
if (Null(si_valid_function_name_p(name)))
FEprogram_error("LAMBDA: Not a valid function name ~S",1,name);
ENV->constants = reqs; /* Special arguments */
/* We register as special variable a symbol which is not
* to be used. We use this to mark the boundary of a function
* environment and when code-walking */
c_register_var(cl_make_symbol(make_constant_base_string("FUNCTION")),
TRUE, TRUE);
ENV->constants = reqs; /* Required arguments */
reqs = CDR(reqs);
while (!ecl_endp(reqs)) {
cl_object v = pop(&reqs);

169
src/c/eval.d
View file

@ -61,24 +61,11 @@ cl_va_arg(cl_va_list args)
return va_arg(args[0].args, cl_object);
}
/*
*----------------------------------------------------------------------
*
* apply --
* applies a Lisp function to the arguments in array args.
* narg is their count.
*
* Results:
* number of values
*
* Side Effect:
* values are placed into the array Values
*----------------------------------------------------------------------
*/
cl_object
cl_apply_from_stack(cl_index narg, cl_object x)
ecl_apply_from_stack_frame(cl_object frame, cl_object x)
{
cl_index narg = frame->frame.narg;
cl_object *sp = frame->frame.sp + cl_env.stack;
cl_object fun = x;
AGAIN:
if (fun == OBJNULL || fun == Cnil)
@ -89,17 +76,22 @@ cl_apply_from_stack(cl_index narg, cl_object x)
if (narg != (cl_index)fun->cfun.narg)
FEwrong_num_arguments(fun);
return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry,
cl_env.stack_top - narg);
sp);
}
return APPLY(narg, fun->cfun.entry, cl_env.stack_top - narg);
return APPLY(narg, fun->cfun.entry, sp);
case t_cclosure:
return APPLY_closure(narg, fun->cclosure.entry,
fun->cclosure.env, cl_env.stack_top - narg);
fun->cclosure.env, sp);
#ifdef CLOS
case t_instance:
fun = _ecl_compute_method(narg, fun, cl_env.stack_top - narg);
if (fun == NULL)
return VALUES(0);
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
case ECL_USER_DISPATCH:
fun = fun->instance.slots[fun->instance.length - 1];
default:
FEinvalid_function(fun);
}
goto AGAIN;
#endif
case t_symbol:
@ -108,7 +100,7 @@ cl_apply_from_stack(cl_index narg, cl_object x)
fun = SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return ecl_apply_lambda(narg, fun);
return ecl_apply_lambda(frame, fun);
default:
ERROR:
FEinvalid_function(x);
@ -122,15 +114,19 @@ cl_apply_from_stack(cl_index narg, cl_object x)
cl_object
_ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_va_list args)
{
cl_index sp;
cl_object out, fun = ecl_fdefinition(sym);
struct ecl_stack_frame frame_aux;
cl_object frame;
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
frame = (cl_object)&frame_aux;
frame->frame.t = t_frame;
frame->frame.narg = narg;
if (args[0].sp)
sp = args[0].sp;
frame->frame.sp = args[0].sp;
else
sp = cl_stack_push_va_list(args);
frame->frame.sp = cl_stack_push_va_list(args);
AGAIN:
if (fun == OBJNULL)
goto ERROR;
@ -140,7 +136,7 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
if (narg != fun->cfun.narg)
FEwrong_num_arguments(fun);
out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry,
cl_env.stack_top - narg);
cl_env.stack + frame->frame.sp);
} else {
if (pLK) {
si_put_sysprop(sym, @'si::link-from',
@ -151,33 +147,34 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v
cblock->cblock.links =
CONS(sym, cblock->cblock.links);
}
out = APPLY(narg, fun->cfun.entry, cl_env.stack + sp);
out = APPLY(narg, fun->cfun.entry, cl_env.stack + frame->frame.sp);
}
break;
#ifdef CLOS
case t_instance: {
fun = _ecl_compute_method(narg, fun, cl_env.stack + sp);
pLK = NULL;
if (fun == NULL) {
out = VALUES(0);
break;
case t_instance:
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
case ECL_USER_DISPATCH:
fun = fun->instance.slots[fun->instance.length - 1];
default:
FEinvalid_function(fun);
}
goto AGAIN;
}
#endif /* CLOS */
case t_cclosure:
out = APPLY_closure(narg, fun->cclosure.entry,
fun->cclosure.env, cl_env.stack + sp);
fun->cclosure.env, cl_env.stack + frame->frame.sp);
break;
case t_bytecodes:
out = ecl_apply_lambda(narg, fun);
out = ecl_apply_lambda(frame, fun);
break;
default:
ERROR:
FEinvalid_function(fun);
}
if (!args[0].sp)
cl_stack_set_index(sp);
ecl_stack_frame_close(frame);
return out;
}
@ -202,58 +199,64 @@ si_unlink_symbol(cl_object s)
}
@(defun funcall (function &rest funargs)
cl_index sp;
cl_object fun = function, out;
struct ecl_stack_frame frame_aux;
cl_object frame;
cl_object out;
@
narg--;
frame = (cl_object)&frame_aux;
frame->frame.t = t_frame;
frame->frame.narg = narg-1;
if (funargs[0].sp)
sp = funargs[0].sp;
frame->frame.sp = funargs[0].sp;
else
sp = cl_stack_push_va_list(funargs);
AGAIN:
if (fun == OBJNULL || fun == Cnil)
FEundefined_function(function);
switch (type_of(fun)) {
case t_cfun:
if (fun->cfun.narg >= 0) {
if (narg != fun->cfun.narg)
FEwrong_num_arguments(fun);
out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry,
cl_env.stack_top - narg);
} else {
out = APPLY(narg, fun->cfun.entry, cl_env.stack + sp);
}
break;
case t_cclosure:
out = APPLY_closure(narg, fun->cclosure.entry,
fun->cclosure.env, cl_env.stack + sp);
break;
#ifdef CLOS
case t_instance:
fun = _ecl_compute_method(narg, fun, cl_env.stack + sp);
if (fun == NULL) {
out = VALUES(0);
break;
}
goto AGAIN;
#endif
case t_symbol:
if (fun->symbol.mflag)
FEundefined_function(fun);
fun = SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
out = ecl_apply_lambda(narg, fun);
break;
default:
ERROR:
FEinvalid_function(fun);
frame->frame.sp = cl_stack_push_va_list(funargs);
out = ecl_apply_from_stack_frame(frame, function);
if (!funargs[0].sp) {
/* Closing a frame implies popping out all arguments.
* If the arguments had been previously pushed, we must
* avoid this and leave that task to the caller */
ecl_stack_frame_close(frame);
}
if (!funargs[0].sp)
cl_stack_set_index(sp);
return out;
@)
@(defun apply (fun lastarg &rest args)
@
if (narg == 2 && type_of(lastarg) == t_frame) {
return ecl_apply_from_stack_frame(lastarg, fun);
} else {
cl_object out;
cl_index i;
struct ecl_stack_frame frame_aux;
const cl_object frame = (cl_object)&frame_aux;
frame->frame.t = t_frame;
frame->frame.narg = frame->frame.sp = 0;
narg -= 2;
for (i = 0; narg; i++,narg--) {
ecl_stack_frame_push(frame, lastarg);
lastarg = cl_va_arg(args);
}
if (type_of(lastarg) == t_frame) {
ecl_stack_frame_reserve(frame, lastarg->frame.narg);
/* This could be replaced with a memcpy() */
for (i = 0; i < lastarg->frame.narg; i++) {
cl_object o = ecl_stack_frame_elt(lastarg, i);
ecl_stack_frame_elt_set(frame, i, o);
}
} else loop_for_in (lastarg) {
if (i >= CALL_ARGUMENTS_LIMIT) {
ecl_stack_frame_close(frame);
FEprogram_error("CALL-ARGUMENTS-LIMIT exceeded",0);
}
ecl_stack_frame_push(frame, CAR(lastarg));
i++;
} end_loop_for_in;
out = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
return out;
}
@)
cl_object
cl_eval(cl_object form)
{

45
src/c/gfun.d
View file

@ -279,8 +279,10 @@ search_method_hash(cl_object keys, cl_object table)
}
static cl_object
get_spec_vector(cl_narg narg, cl_object gf, cl_object *args)
get_spec_vector(cl_object frame, cl_object gf)
{
cl_object *args = cl_env.stack + frame->frame.sp;
cl_index narg = frame->frame.narg;
cl_object spec_how_list = GFUN_SPEC(gf);
cl_object vector = cl_env.method_spec_vector;
cl_object *argtype = vector->vector.self.t;
@ -307,18 +309,18 @@ get_spec_vector(cl_narg narg, cl_object gf, cl_object *args)
}
static cl_object
compute_applicable_method(cl_narg narg, cl_object gf, cl_object *args)
compute_applicable_method(cl_object frame, cl_object gf)
{
/* method not cached */
cl_object methods, arglist, func;
int i;
for (i = narg, arglist = Cnil; i-- > 0; ) {
arglist = CONS(args[i], arglist);
for (i = frame->frame.narg, arglist = Cnil; i; ) {
arglist = CONS(ecl_stack_frame_elt(frame, --i), arglist);
}
methods = funcall(3, @'compute-applicable-methods', gf, arglist);
if (methods == Cnil) {
func = funcall(3, @'no-applicable-method', gf, arglist);
args[0] = 0;
ecl_stack_frame_elt_set(frame, 0, OBJNULL);
return func;
} else {
return funcall(4, @'clos::compute-effective-method', gf,
@ -326,10 +328,10 @@ compute_applicable_method(cl_narg narg, cl_object gf, cl_object *args)
}
}
static cl_object
standard_dispatch(cl_narg narg, cl_object gf, cl_object *args)
cl_object
_ecl_standard_dispatch(cl_object frame, cl_object gf)
{
cl_object vector;
cl_object func, vector;
#ifdef ECL_THREADS
/* See whether we have to clear the hash from some generic functions right now. */
if (cl_env.method_hash_clear_list != Cnil) {
@ -343,17 +345,17 @@ standard_dispatch(cl_narg narg, cl_object gf, cl_object *args)
THREAD_OP_UNLOCK();
}
#endif
vector = get_spec_vector(narg, gf, args);
vector = get_spec_vector(frame, gf);
if (vector == OBJNULL) {
return compute_applicable_method(narg, gf, args);
func = compute_applicable_method(frame, gf);
} else {
cl_object table = cl_env.method_hash;
cl_object *e = search_method_hash(vector, table);
if (RECORD_KEY(e) != OBJNULL) {
return RECORD_VALUE(e);
func = RECORD_VALUE(e);
} else {
cl_object keys = cl_copy_seq(vector);
cl_object func = compute_applicable_method(narg, gf, args);
func = compute_applicable_method(frame, gf);
if (RECORD_KEY(e) != OBJNULL) {
/* The cache might have changed while we
* computed applicable methods */
@ -361,20 +363,13 @@ standard_dispatch(cl_narg narg, cl_object gf, cl_object *args)
}
RECORD_KEY(e) = keys;
RECORD_VALUE(e) = func;
return func;
}
}
}
cl_object
_ecl_compute_method(cl_narg narg, cl_object gf, cl_object *args)
{
switch (gf->instance.isgf) {
case ECL_STANDARD_DISPATCH:
return standard_dispatch(narg, gf, args);
case ECL_USER_DISPATCH:
return gf->instance.slots[gf->instance.length - 1];
default:
FEinvalid_function(gf);
{
ECL_BUILD_STACK_FRAME(frame1);
ecl_stack_frame_push(frame1, frame);
func = ecl_apply_from_stack_frame(frame1, func);
ecl_stack_frame_close(frame1);
return func;
}
}

2
src/c/instance.d
View file

@ -286,6 +286,8 @@ cl_class_of(cl_object x)
t = @'si::code-block'; break;
case t_foreign:
t = @'si::foreign-data'; break;
case t_frame:
t = @'si::frame'; break;
default:
ecl_internal_error("not a lisp data object");
}

174
src/c/interpreter.d
View file

@ -164,6 +164,93 @@ cl_stack_push_list(cl_object list)
return n;
}
void
ecl_stack_frame_reserve(cl_object f, cl_index size)
{
cl_index sp = cl_stack_index();
cl_index n = f->frame.narg;
if (n == 0) {
f->frame.sp = sp;
} else if (sp != f->frame.sp + n) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
f->frame.narg = n+size;
cl_stack_insert(sp, size);
}
void
ecl_stack_frame_push(cl_object f, cl_object o)
{
cl_index sp = cl_stack_index();
cl_index n = f->frame.narg;
if (n == 0) {
f->frame.sp = sp;
} else if (sp != f->frame.sp + n) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
f->frame.narg = n+1;
cl_stack_push(o);
}
void
ecl_stack_frame_push_values(cl_object f)
{
cl_index sp = cl_stack_index();
cl_index n = f->frame.narg;
if (n == 0) {
f->frame.sp = sp;
} else if (sp != f->frame.sp + n) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
f->frame.narg = n+cl_stack_push_values();
}
void
ecl_stack_frame_push_va_list(cl_object f, cl_va_list args)
{
cl_index sp = cl_stack_index();
cl_index n = f->frame.narg;
if (n == 0) {
f->frame.sp = sp;
} else if (sp != f->frame.sp + n) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
f->frame.narg = n + args[0].narg;
cl_stack_push_va_list(args);
}
cl_object
ecl_stack_frame_pop_values(cl_object f)
{
cl_stack_pop_values(f->frame.narg);
return VALUES(0);
}
cl_object
ecl_stack_frame_elt(cl_object f, cl_index ndx)
{
if (ndx >= f->frame.narg) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
return cl_env.stack[f->frame.sp + ndx];
}
void
ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o)
{
if (ndx >= f->frame.narg) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
cl_env.stack[f->frame.sp + ndx] = o;
}
void
ecl_stack_frame_close(cl_object f)
{
if (f->frame.narg) cl_stack_set_index(f->frame.sp);
}
/* ------------------------------ LEXICAL ENV. ------------------------------ */
#define bind_var(var, val) \
@ -323,9 +410,8 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
}
cl_object
ecl_apply_lambda(cl_narg narg, cl_object fun)
ecl_apply_lambda(cl_object frame, cl_object fun)
{
cl_index args = cl_stack_index() - narg;
cl_object name;
bds_ptr old_bds_top;
struct ihs_frame ihs;
@ -339,7 +425,7 @@ ecl_apply_lambda(cl_narg narg, cl_object fun)
old_bds_top = cl_env.bds_top;
/* Establish bindings */
lambda_bind(narg, fun, args);
lambda_bind(frame->frame.narg, fun, frame->frame.sp);
VALUES(0) = Cnil;
NVALUES = 0;
@ -369,81 +455,20 @@ search_global(register cl_object s) {
* (cl_env.lex_env) needs to be saved.
*/
static cl_object
interpret_funcall(cl_narg narg, cl_object fun) {
interpret_funcall(cl_narg narg, cl_object fun)
{
cl_object lex_env = cl_env.lex_env;
cl_object *args;
cl_object x;
args = cl_env.stack_top - narg;
if (fun == OBJNULL || fun == Cnil)
goto ERROR;
AGAIN:
switch (type_of(fun)) {
case t_cfun: {
struct ihs_frame ihs;
ihs_push(&ihs, fun->cfun.name);
if (fun->cfun.narg >= 0) {
if (narg != fun->cfun.narg)
FEwrong_num_arguments(fun);
x = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, args);
} else {
x = APPLY(narg, fun->cfun.entry, args);
}
ihs_pop();
break;
}
case t_cclosure:{
struct ihs_frame ihs;
ihs_push(&ihs, fun);
x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
ihs_pop();
break;
}
#ifdef CLOS
case t_instance:
fun = _ecl_compute_method(narg, fun, args);
if (fun == NULL) {
x = VALUES(0);
break;
}
goto AGAIN;
#endif
case t_bytecodes:
x = ecl_apply_lambda(narg, fun);
break;
case t_symbol: {
cl_object function = SYM_FUN(fun);
if (function == Cnil || fun->symbol.mflag)
FEundefined_function(fun);
fun = function;
goto AGAIN;
}
default: ERROR:
FEinvalid_function(fun);
}
struct ecl_stack_frame frame_aux;
cl_object frame = (cl_object)&frame_aux;
frame->frame.t = t_frame;
frame->frame.narg = narg;
frame->frame.sp = (cl_env.stack_top - cl_env.stack) - narg;
fun = ecl_apply_from_stack_frame(frame, fun);
cl_env.lex_env = lex_env;
cl_stack_pop_n(narg);
return x;
ecl_stack_frame_close(frame);
return fun;
}
@(defun apply (fun lastarg &rest args)
cl_index i;
@
narg -= 2;
for (i = 0; narg; i++,narg--) {
cl_stack_push(lastarg);
lastarg = cl_va_arg(args);
}
loop_for_in (lastarg) {
if (i >= CALL_ARGUMENTS_LIMIT) {
cl_stack_pop_n(i);
FEprogram_error("CALL-ARGUMENTS-LIMIT exceeded",0);
}
cl_stack_push(CAR(lastarg));
i++;
} end_loop_for_in;
returnn(interpret_funcall(i, fun));
@)
/* -------------------- THE INTERPRETER -------------------- */
static cl_object
@ -1225,6 +1250,7 @@ ecl_interpret(cl_object bytecodes, void *pc) {
cl_stack_pop_values(n);
break;
}
default:
FEerror("Internal error: Unknown code ~S",
1, MAKE_FIXNUM(*(vector-1)));

86
src/c/list.d
View file

@ -24,6 +24,10 @@ struct cl_test {
cl_object test_function;
cl_object item_compared;
cl_object key_function;
cl_object frame_key;
struct ecl_stack_frame frame_key_aux;
cl_object frame_test;
struct ecl_stack_frame frame_test_aux;
};
static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree);
@ -36,17 +40,19 @@ static void nsublis(struct cl_test *t, cl_object alist, cl_object *treep);
static bool
test_compare(struct cl_test *t, cl_object x)
{
cl_object outcome = funcall(3, t->test_function, t->item_compared,
(t->key_c_function)(t, x));
return (outcome != Cnil);
ecl_stack_frame_elt_set(t->frame_test, 0, t->item_compared);
x = (t->key_c_function)(t, x);
ecl_stack_frame_elt_set(t->frame_test, 1, x);
return ecl_apply_from_stack_frame(t->frame_test, t->test_function) != Cnil;
}
static bool
test_compare_not(struct cl_test *t, cl_object x)
{
cl_object outcome = funcall(3, t->test_function, t->item_compared,
(t->key_c_function)(t, x));
return (outcome == Cnil);
ecl_stack_frame_elt_set(t->frame_test, 0, t->item_compared);
x = (t->key_c_function)(t, x);
ecl_stack_frame_elt_set(t->frame_test, 1, x);
return ecl_apply_from_stack_frame(t->frame_test, t->test_function) == Cnil;
}
static bool
@ -76,7 +82,8 @@ test_equalp(struct cl_test *t, cl_object x)
static cl_object
key_function(struct cl_test *t, cl_object x)
{
return funcall(2, t->key_function, x);
ecl_stack_frame_elt_set(t->frame_key, 0, x);
return ecl_apply_from_stack_frame(t->frame_key, t->key_function);
}
static cl_object
@ -86,10 +93,11 @@ key_identity(struct cl_test *t, cl_object x)
}
static void
setupTEST(struct cl_test *t, cl_object item, cl_object test,
cl_object test_not, cl_object key)
setup_test(struct cl_test *t, cl_object item, cl_object test,
cl_object test_not, cl_object key)
{
t->item_compared = item;
t->test_function = t->key_function =Cnil;
if (test != Cnil) {
if (test_not != Cnil)
FEerror("Both :TEST and :TEST-NOT are specified.", 0);
@ -117,6 +125,31 @@ setupTEST(struct cl_test *t, cl_object item, cl_object test,
} else {
t->key_c_function = key_identity;
}
if (t->test_function != Cnil) {
t->frame_test = (cl_object)&(t->frame_test_aux);
t->frame_test_aux.t = t_frame;
t->frame_test_aux.narg = 0;
t->frame_test_aux.sp = 0;
ecl_stack_frame_reserve(t->frame_test, 2);
ecl_stack_frame_elt_set(t->frame_test, 0, item);
}
if (t->key_function != Cnil) {
t->frame_key = (cl_object)&(t->frame_key_aux);
t->frame_key_aux.t = t_frame;
t->frame_key_aux.narg = 0;
t->frame_key_aux.sp = 0;
ecl_stack_frame_reserve(t->frame_key, 1);
}
}
static void close_test(struct cl_test *t)
{
if (t->key_function != Cnil) {
ecl_stack_frame_close(t->frame_key);
}
if (t->test_function != Cnil) {
ecl_stack_frame_close(t->frame_test);
}
}
cl_object
@ -290,9 +323,12 @@ BEGIN:
@(defun tree_equal (x y &key test test_not)
struct cl_test t;
cl_object output;
@
setupTEST(&t, Cnil, test, test_not, Cnil);
@(return (tree_equal(&t, x, y)? Ct : Cnil))
setup_test(&t, Cnil, test, test_not, Cnil);
output = tree_equal(&t, x, y)? Ct : Cnil;
close_test(&t);
@(return output)
@)
cl_object
@ -581,9 +617,12 @@ cl_rplacd(cl_object x, cl_object v)
@(defun subst (new_obj old_obj tree &key test test_not key)
struct cl_test t;
cl_object output;
@
setupTEST(&t, old_obj, test, test_not, key);
@(return subst(&t, new_obj, tree))
setup_test(&t, old_obj, test, test_not, key);
output = subst(&t, new_obj, tree);
close_test(&t);
@(return output)
@)
@ -607,8 +646,9 @@ subst(struct cl_test *t, cl_object new_obj, cl_object tree)
@(defun nsubst (new_obj old_obj tree &key test test_not key)
struct cl_test t;
@
setupTEST(&t, old_obj, test, test_not, key);
setup_test(&t, old_obj, test, test_not, key);
nsubst(&t, new_obj, &tree);
close_test(&t);
@(return tree)
@)
@ -631,8 +671,9 @@ nsubst(struct cl_test *t, cl_object new_obj, cl_object *treep)
@(defun sublis (alist tree &key test test_not key)
struct cl_test t;
@
setupTEST(&t, Cnil, test, test_not, key);
setup_test(&t, Cnil, test, test_not, key);
tree = sublis(&t, alist, tree);
close_test(&t);
@(return tree)
@)
@ -664,8 +705,9 @@ sublis(struct cl_test *t, cl_object alist, cl_object tree)
@(defun nsublis (alist tree &key test test_not key)
struct cl_test t;
@
setupTEST(&t, Cnil, test, test_not, key);
setup_test(&t, Cnil, test, test_not, key);
nsublis(&t, alist, &tree);
close_test(&t);
@(return tree)
@)
@ -697,11 +739,12 @@ nsublis(struct cl_test *t, cl_object alist, cl_object *treep)
@(defun member (item list &key test test_not key)
struct cl_test t;
@
setupTEST(&t, item, test, test_not, key);
setup_test(&t, item, test, test_not, key);
loop_for_in(list) {
if (TEST(&t, CAR(list)))
break;
} end_loop_for_in;
close_test(&t);
@(return list)
@)
@ -754,11 +797,12 @@ si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, c
if (key != Cnil)
item = funcall(2, key, item);
setupTEST(&t, item, test, test_not, key);
setup_test(&t, item, test, test_not, key);
loop_for_in(list) {
if (TEST(&t, CAR(list)))
break;
} end_loop_for_in;
close_test(&t);
@(return list)
}
@ -818,7 +862,7 @@ error: FEerror("The keys ~S and the data ~S are not of the same length",
@(defun assoc (item a_list &key test test_not key)
struct cl_test t;
@
setupTEST(&t, item, test, test_not, key);
setup_test(&t, item, test, test_not, key);
loop_for_in(a_list) {
cl_object pair = CAR(a_list);
if (Null(pair)) {
@ -830,13 +874,14 @@ error: FEerror("The keys ~S and the data ~S are not of the same length",
break;
}
} end_loop_for_in;
close_test(&t);
@(return a_list)
@)
@(defun rassoc (item a_list &key test test_not key)
struct cl_test t;
@
setupTEST(&t, item, test, test_not, key);
setup_test(&t, item, test, test_not, key);
loop_for_in(a_list) {
cl_object pair = CAR(a_list);
if (Null(pair)) {
@ -848,6 +893,7 @@ error: FEerror("The keys ~S and the data ~S are not of the same length",
break;
}
} end_loop_for_in;
close_test(&t);
@(return a_list)
@)

183
src/c/mapfun.d
View file

@ -16,150 +16,163 @@
#include <ecl/ecl.h>
#include <ecl/internal.h>
static cl_index
prepare_map(cl_va_list lists, cl_index *cdrs_sp)
static void
prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame)
{
cl_index i, nlist = lists[0].narg;
*cdrs_sp = cl_stack_index();
if (nlist == 0)
cl_index i;
ecl_stack_frame_push_va_list(cdrs_frame, lists);
if (cdrs_frame->frame.narg == 0) {
FEprogram_error("MAP*: Too few arguments.", 0);
cl_stack_push_va_list(lists);
for (i = 0; i<nlist; i++)
cl_stack_push(Cnil);
return nlist;
}
ecl_stack_frame_reserve(cars_frame, cdrs_frame->frame.narg);
for (i = 0; i < cars_frame->frame.narg; i++) {
ecl_stack_frame_elt_set(cars_frame, i, Cnil);
}
}
@(defun mapcar (fun &rest lists)
cl_object res, *val = &res;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
cl_index i;
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
res = Cnil;
while (TRUE) {
/* INV: The stack does not grow here. */
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
*val = CONS(cl_apply_from_stack(nlist, fun), Cnil);
*val = CONS(ecl_apply_from_stack_frame(cars_frame, fun), Cnil);
val = &CDR(*val);
}
@)
} @)
@(defun maplist (fun &rest lists)
cl_object res, *val = &res;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
res = Cnil;
while (TRUE) {
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
*val = CONS(cl_apply_from_stack(nlist, fun), Cnil);
*val = CONS(ecl_apply_from_stack_frame(cars_frame, fun), Cnil);
val = &CDR(*val);
}
@)
} @)
@(defun mapc (fun &rest lists)
cl_object onelist;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
onelist = cl_env.stack[cdrs_sp];
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
while (TRUE) {
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return onelist)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
cl_apply_from_stack(nlist, fun);
ecl_apply_from_stack_frame(cars_frame, fun);
}
@)
} @)
@(defun mapl (fun &rest lists)
cl_object onelist;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
onelist = cl_env.stack[cdrs_sp];
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
while (TRUE) {
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return onelist)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
cl_apply_from_stack(nlist, fun);
ecl_apply_from_stack_frame(cars_frame, fun);
}
@)
} @)
@(defun mapcan (fun &rest lists)
cl_object res, *val = &res;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
res = Cnil;
while (TRUE) {
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
*val = cl_apply_from_stack(nlist, fun);
*val = ecl_apply_from_stack_frame(cars_frame, fun);
while (CONSP(*val))
val = &CDR(*val);
}
@)
} @)
@(defun mapcon (fun &rest lists)
cl_object res, *val = &res;
cl_index i, nlist, cdrs_sp;
@
nlist = prepare_map(lists, &cdrs_sp);
@ {
ECL_BUILD_STACK_FRAME(cars_frame);
ECL_BUILD_STACK_FRAME(cdrs_frame);
prepare_map(lists, cdrs_frame, cars_frame);
res = Cnil;
while (TRUE) {
cl_object *cdrs = cl_env.stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (ecl_endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
cl_index i;
for (i = 0; i < cdrs_frame->frame.narg; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
}
*val = cl_apply_from_stack(nlist, fun);
*val = ecl_apply_from_stack_frame(cars_frame, fun);
while (CONSP(*val))
val = &CDR(*val);
}
@)
} @)

20
src/c/print.d
View file

@ -922,7 +922,7 @@ write_array(bool vector, cl_object x, cl_object stream)
if (readably) {
write_ch('A', stream);
write_ch('(', stream);
si_write_object_recursive(ecl_elttype_to_symbol(x->array.elttype), stream);
si_write_object_recursive(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream);
write_ch(INDENT, stream);
if (n > 0) {
write_ch('(', stream);
@ -1409,8 +1409,14 @@ si_write_ugly_object(cl_object x, cl_object stream)
break;
case t_random:
write_str("#$", stream);
write_array(1, x->random.value, stream);
if (ecl_print_readably()) {
write_str("#$", stream);
write_array(1, x->random.value, stream);
} else {
write_str("#<random-state ", stream);
write_addr(x->random.value, stream);
write_str("#>", stream);
}
break;
#ifndef CLOS
@ -1520,6 +1526,14 @@ si_write_ugly_object(cl_object x, cl_object stream)
write_addr((cl_object)x->foreign.data, stream);
write_ch('>', stream);
break;
case t_frame:
if (ecl_print_readably()) FEprint_not_readable(x);
write_str("#<frame ", stream);
write_decimal(x->frame.narg, stream);
write_ch(' ', stream);
write_decimal(x->frame.sp, stream);
write_ch('>', stream);
break;
#ifdef ECL_THREADS
case t_process:
if (ecl_print_readably()) FEprint_not_readable(x);

3
src/c/symbols_list.h
View file

@ -1678,6 +1678,9 @@ cl_symbols[] = {
{SYS_ "CLEAR-GFUN-HASH", SI_ORDINARY, si_clear_gfun_hash, 1, OBJNULL},
#endif
{SYS_ "FRAME", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "APPLY-FROM-STACK-FRAME", SI_ORDINARY, si_apply_from_stack_frame, 2, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

3
src/c/symbols_list2.h
View file

@ -1678,6 +1678,9 @@ cl_symbols[] = {
{SYS_ "CLEAR-GFUN-HASH","si_clear_gfun_hash"},
#endif
{SYS_ "FRAME",NULL},
{SYS_ "APPLY-FROM-STACK-FRAME","si_apply_from_stack_frame"},
/* Tag for end of list */
{NULL,NULL}};

2
src/c/typespec.d
View file

@ -186,6 +186,8 @@ ecl_type_to_symbol(cl_type t)
return @'si::code-block';
case t_foreign:
return @'si::foreign-data';
case t_frame:
return @'si::frame';
default:
ecl_internal_error("not a lisp data object");
}

1
src/clos/builtin.lsp
View file

@ -89,6 +89,7 @@
(readtable)
(si::code-block)
(si::foreign-data)
(si::frame)
#+threads (mp::process)
#+threads (mp::lock)))

94
src/clos/combin.lsp
View file

@ -47,26 +47,33 @@
;;; 5) Ordinary forms are turned into lambda forms, much like
;;; what happens with the content of MAKE-METHOD.
;;;
(defun effective-method-function (form)
(if (atom form)
(cond ((method-p form)
(method-function form))
((functionp form)
form)
(t
(error "Malformed effective method form:~%~A" form)))
(case (first form)
(CALL-METHOD
(defun effective-method-function (form &optional top-level)
(cond ((functionp form)
form)
((method-p form)
(wrapped-method-function (method-function form)))
((atom form)
(error "Malformed effective method form:~%~A" form))
((and (not top-level) (eq (first form) 'MAKE-METHOD))
(coerce `(lambda (.combined-method-args. *next-methods*)
(declare (special .combined-method-args. *next-methods*))
,(second form))
'function))
((and top-level (eq (first form) 'CALL-METHOD))
(combine-method-functions
(effective-method-function (second form))
(mapcar #'effective-method-function (third form))))
(MAKE-METHOD
(setq form (second form))
(coerce `(lambda (&rest .combined-method-args.) ,form)
(top-level
(coerce `(lambda (.combined-method-args.)
,form)
'function))
(t
(coerce `(lambda (&rest .combined-method-args.) ,form)
'function)))))
(error "Malformed effective method form:~%~A" form))))
(defun wrapped-method-function (method-function)
#'(lambda (.combined-method-args. *next-methods*)
(declare (special .combined-method-args. *next-methods*))
(apply method-function .combined-method-args.)))
;;;
;;; This function is a combinator of effective methods. It creates a
@ -76,17 +83,30 @@
;;;
(defun combine-method-functions (method rest-methods)
(declare (si::c-local))
#'(lambda (&rest .combined-method-args.)
(let ((*next-methods* rest-methods))
(declare (special *next-methods*))
(apply method .combined-method-args.))))
#'(lambda (.combined-method-args.)
(funcall method .combined-method-args. rest-methods)))
(defmacro call-method (method rest-methods)
(setq method (effective-method-function method)
rest-methods (mapcar #'effective-method-function rest-methods))
`(let ((*next-methods* ,rest-methods))
(declare (special *next-methods*))
(apply ,method .combined-method-args.)))
`(funcall ,(effective-method-function method)
.combined-method-args.
',(mapcar #'effective-method-function rest-methods)))
(defun call-next-method (&rest args)
(unless *next-methods*
(error "No next method."))
(funcall (car *next-methods*) (or args .combined-method-args.) (rest *next-methods*)))
(defun next-method-p ()
*next-methods*)
(define-compiler-macro call-next-method (&rest args)
(print 'call-next-method)
`(if *next-methods*
(funcall (car *next-methods*) ,(if args `(list ,@args) '.combined-method-args.)
(rest *next-methods*))
(error "No next method.")))
(define-compiler-macro next-method-p () clos::*next-methods*)
(defun error-qualifier (m qualifier)
(declare (si::c-local))
@ -97,19 +117,15 @@
(defun standard-main-effective-method (before primary after)
(declare (si::c-local))
#'(lambda (&rest .combined-method-args.)
(let ((*next-methods* nil))
(declare (special *next-methods*))
(dolist (i before)
(apply i .combined-method-args.))
(setf *next-methods* (rest primary))
(if after
(multiple-value-prog1
(apply (first primary) .combined-method-args.)
(setf *next-methods* nil)
(dolist (i after)
(apply i .combined-method-args.)))
(apply (first primary) .combined-method-args.)))))
#'(lambda (.combined-method-args.)
(dolist (i before)
(funcall i .combined-method-args. nil))
(if after
(multiple-value-prog1
(funcall (first primary) .combined-method-args. (rest primary))
(dolist (i after)
(funcall i .combined-method-args. nil)))
(funcall (first primary) .combined-method-args. (rest primary)))))
(defun standard-compute-effective-method (gf methods)
(declare (si::c-local))
@ -119,7 +135,7 @@
(around ()))
(dolist (m methods)
(let* ((qualifiers (method-qualifiers m))
(f (method-function m)))
(f (wrapped-method-function (method-function m))))
(cond ((null qualifiers) (push f primary))
((rest qualifiers) (error-qualifier m qualifiers))
((eq (setq qualifiers (first qualifiers)) :BEFORE)
@ -256,7 +272,7 @@
"Method qualifiers ~S are not allowed in the method~
combination ~S." .method-qualifiers. ,name)))))
,@group-after
(effective-method-function ,@body))))
(effective-method-function ,@body t))))
)))
(defmacro define-method-combination (name &body body)

241
src/clos/method.lsp
View file

@ -98,223 +98,84 @@
,@(and class-declarations `((declare ,@class-declarations)))
,@real-body))
(original-args ())
(applyp nil) ; flag indicating whether or not the
; method takes &mumble arguments. If
; it does, it means call-next-method
; without arguments must be APPLY'd
; to original-args. If this gets set
; true, save-original-args is set so
; as well
(aux-bindings ()) ; Suffice to say that &aux is one of
; damndest things to have put in a
; language.
(plist ()))
(multiple-value-bind (walked-lambda call-next-method-p
save-original-args next-method-p-p)
(multiple-value-bind (call-next-method-p next-method-p-p in-closure-p)
(walk-method-lambda method-lambda required-parameters env)
;; Scan the lambda list to determine whether this method
;; takes &mumble arguments. If it does, we set applyp and
;; save-original-args true.
;;
;; This is also the place where we construct the original
;; arguments lambda list if there has to be one.
(dolist (p lambda-list)
(if (member p '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX)
:test #'eq) ; cant use lambda-list-keywords
(if (eq p '&aux)
(progn
(setq aux-bindings (cdr (member '&AUX lambda-list
:test #'eq)))
(return nil))
(progn
(setq applyp t
save-original-args t)
(push '&REST original-args)
(push (make-symbol "AMPERSAND-ARGS") original-args)
(return nil)))
(push (make-symbol (symbol-name p)) original-args)))
(setq original-args (when save-original-args
(nreverse original-args)))
(when (or call-next-method-p next-method-p-p)
(setf plist '(:needs-next-method-p t)))
(multiple-value-bind (walked-declarations walked-lambda-body)
(sys::find-declarations (cdddr walked-lambda) t)
(declare (ignore ignore))
(when in-closure-p
(setf plist '(:needs-next-method-p FUNCTION))
(setf real-body
`((let* ((.combined-method-args.
(if (listp .combined-method-args.)
.combined-method-args.
(apply #'list .combined-method-args.)))
(.next-methods. *next-methods*))
(flet ((call-next-method (&rest args)
(unless .next-methods.
(error "No next method"))
(funcall (car .next-methods.)
(or args .combined-method-args.)
(rest .next-methods.)))
(next-method-p ()
.next-methods.))
,@real-body)))))
(values
`(ext::lambda-block ,generic-function-name
,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,@real-body)
documentation
plist)))))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p 'T plist)))
(values
(let ((walked-lambda `(ext::lambda-block ,(second walked-lambda)
,lambda-list
,@walked-declarations
,.walked-lambda-body)))
(if (or call-next-method-p next-method-p-p)
`(function ,(add-lexical-functions-to-method-lambda
walked-declarations
walked-lambda-body
generic-function-name
walked-lambda
original-args
lambda-list
save-original-args
applyp
aux-bindings
call-next-method-p
next-method-p-p))
`(function ,walked-lambda)))
documentation
plist))))))
(defun environment-contains-closure (env)
;;
;; As explained in compiler.d (make_lambda()), we use a symbol with name
;; "FUNCTION" to mark the beginning of a function. If we find that symbol
;; twice, it is quite likely that this form will end up in a closure.
;;
(flet ((function-boundary (s)
(and (consp s)
(symbolp (setf s (first s)))
(null (symbol-package s))
(equal (symbol-name s) "FUNCTION"))))
(> (count-if #'function-boundary (car env)) 1)))
(defun walk-method-lambda (method-lambda required-parameters env)
(declare (si::c-local))
(let ((call-next-method-p nil)
(next-method-p-p nil)
(save-original-args-p nil))
(in-closure-p nil))
(flet ((code-walker (form env)
(unless (atom form)
(let ((name (first form)))
(case name
(CALL-NEXT-METHOD
(setf call-next-method-p
(or call-next-method-p T))
(unless (rest form)
(setf save-original-args-p t)))
(or call-next-method-p T)
in-closure-p
(or in-closure-p (environment-contains-closure env))))
(NEXT-METHOD-P
(setf next-method-p-p t))
(setf next-method-p-p t
in-closure-p (or in-closure-p (environment-contains-closure env))))
(FUNCTION
(when (eq (second form) 'CALL-NEXT-METHOD)
(setf save-original-args-p t
(setf in-closure-p t
call-next-method-p 'FUNCTION))
(when (eq (second form) 'NEXT-METHOD-P)
(setf next-method-p-p 'FUNCTION))))))
(setf next-method-p-p 'FUNCTION
in-closure-p t))))))
form))
(let ((si::*code-walker* #'code-walker))
(coerce method-lambda 'function)))
(values method-lambda call-next-method-p
save-original-args-p
next-method-p-p)))
(defun add-lexical-functions-to-method-lambda (walked-declarations
walked-lambda-body
generic-function-name
walked-lambda
original-args
lambda-list
save-original-args
applyp
aux-bindings
call-next-method-p
next-method-p-p)
(declare (si::c-local))
;;
;; WARNING: these &rest/apply combinations produce useless garbage. Beppe
;;
(cond ((and (null save-original-args)
(null applyp))
;;
;; We don't have to save the original arguments. In addition,
;; this method doesn't take any &mumble arguments (this means
;; that there is no way the lexical functions can be used inside
;; of the default value form for an &mumble argument).
;;
;; We can expand this into a simple lambda expression with an
;; FLET to define the lexical functions.
;;
`(ext::lambda-block ,generic-function-name ,lambda-list
,@walked-declarations
(declare (special *next-methods*))
(let* ((.next-method. (car *next-methods*))
(*next-methods* (cdr *next-methods*)))
(declare (special *next-methods*))
(flet (,@(and call-next-method-p
'((CALL-NEXT-METHOD (&REST CNM-ARGS)
;; (declare (static-extent cnm-args))
(IF .NEXT-METHOD.
(APPLY .NEXT-METHOD. CNM-ARGS)
(ERROR "No next method.")))))
,@(and next-method-p-p
'((NEXT-METHOD-P ()
(NOT (NULL .NEXT-METHOD.))))))
,@walked-lambda-body)))
;; Assuming that we can determine statically which is the next method,
;; we could use this solution. Compute-effective-method can set
;; the value of .next-method. within each closure at the appropriate
;; value. Same thing for next case. Beppe
;; `(let (.next-method.)
;; (lambda ,lambda-list
;; ,@walked-declarations
;; (flet (,@(and call-next-method-p
;; '((CALL-NEXT-METHOD (&REST CNM-ARGS)
;; ;; (declare (static-extent cnm-args))
;; (IF .NEXT-METHOD.
;; (APPLY .NEXT-METHOD. CNM-ARGS)
;; (ERROR "No next method.")))))
;; ,@(and next-method-p-p
;; '((NEXT-METHOD-P ()
;; (NOT (NULL .NEXT-METHOD.))))))
;; ,@walked-lambda-body)))
)
((null applyp)
;;
;; This method doesn't accept any &mumble arguments. But we
;; do have to save the original arguments (this is because
;; call-next-method is being called with no arguments).
;; Have to be careful though, there may be multiple calls to
;; call-next-method, all we know is that at least one of them
;; is with no arguments.
;;
`(ext::lambda-block ,generic-function-name ,original-args
(declare (special *next-methods*))
(let* ((.next-method. (car *next-methods*))
(*next-methods* (cdr *next-methods*)))
(declare (special *next-methods*))
(flet (,@(and call-next-method-p
`((call-next-method (&rest cnm-args)
;; (declare (static-extent cnm-args))
(if .next-method.
(if cnm-args
(apply .next-method. cnm-args)
(funcall .next-method. ,@original-args))
(error "No next method.")))))
,@(and next-method-p-p
'((NEXT-METHOD-P ()
(NOT (NULL .NEXT-METHOD.))))))
(let* (,@(mapcar #'list
(subseq lambda-list 0
(position '&AUX lambda-list))
original-args)
,@aux-bindings)
,@walked-declarations
,@walked-lambda-body)))))
(t
;;
;; This is the fully general case.
;; We must allow for the lexical functions being used inside
;; the default value forms of &mumble arguments, and if must
;; allow for call-next-method being called with no arguments.
;;
`(lambda ,original-args
(declare (special *next-methods*))
(let* ((.next-method. (car *next-methods*))
(*next-methods* (cdr *next-methods*)))
(declare (special *next-methods*))
(flet (,@(and call-next-method-p
`((call-next-method (&rest cnm-args)
;; (declare (static-extent cnm-args))
(if .next-method.
(if cnm-args
(apply .next-method. cnm-args)
(apply .next-method.
,@(remove '&REST original-args)))
(error "No next method.")))))
,@(and next-method-p-p
'((NEXT-METHOD-P ()
(NOT (NULL .NEXT-METHOD.))))))
(apply (function ,walked-lambda)
,@(remove '&REST original-args))))))))
(values call-next-method-p
next-method-p-p
in-closure-p)))
;;; ----------------------------------------------------------------------
;;; parsing

5
src/cmp/cmpcall.lsp
View file

@ -25,9 +25,10 @@
(let ((l (length arguments)))
(if (<= l si::c-arguments-limit)
(make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments))
(c1expr `(with-stack
(let ((frame (gensym)))
(c1expr `(with-stack ,frame
,@(loop for i in arguments collect `(stack-push ,i))
(apply-from-stack ,l ,fim))))))
(si::apply-from-stack-frame ,frame ,fim)))))))
(defun c1funcall (args)
(check-args-number 'FUNCALL args 1)

14
src/cmp/cmpeval.lsp
View file

@ -87,9 +87,10 @@
(let ((l (length args)))
(when (> l si::c-arguments-limit)
(return-from c1call-local
(c1expr `(with-stack
,@(loop for i in args collect `(stack-push ,i))
(apply-from-stack ,l #',fname))))))
(let ((frame (gensym)))
(c1expr `(with-stack ,frame
,@(loop for i in args collect `(stack-push ,i))
(si::apply-from-stack-frame ,frame #',fname)))))))
(let* ((forms (c1args* args))
(lambda-form (fun-lambda fun))
(return-type (or (get-local-return-type fun) 'T))
@ -111,9 +112,10 @@
(defun c1call-global (fname args)
(let ((l (length args)))
(if (> l si::c-arguments-limit)
(c1expr `(with-stack
,@(loop for i in args collect `(stack-push ,i))
(apply-from-stack ,l #',fname)))
(c1expr (let ((frame (gensym)))
`(with-stack ,frame
,@(loop for i in args collect `(stack-push ,frame ,i))
(si::apply-from-stack-frame ,frame #',fname))))
(let* ((forms (c1args* args))
(return-type (propagate-types fname forms args)))
(make-c1form* 'CALL-GLOBAL

38
src/cmp/cmpexit.lsp
View file

@ -14,10 +14,12 @@
(in-package "COMPILER")
(defun unwind-bds (bds-lcl bds-bind stack-sp ihs-p)
(defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p)
(declare (fixnum bds-bind))
(when stack-sp
(wt-nl "cl_stack_set_index(" stack-sp ");"))
(when stack-frame
(if (stringp stack-frame)
(wt-nl "ecl_stack_frame_close(" stack-frame ");")
(wt-nl "cl_stack_set_index(" stack-frame ");")))
(when bds-lcl
(wt-nl "bds_unwind(" bds-lcl ");"))
(if (< bds-bind 4)
@ -26,7 +28,7 @@
(when ihs-p
(wt-nl "ihs_pop();")))
(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil))
(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
(declare (fixnum bds-bind))
(when (consp *destination*)
(case (car *destination*)
@ -41,7 +43,7 @@
(cond
((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n)
(cond ((eq (car ue) 'STACK)
(setf stack-sp (second ue)))
(setf stack-frame (second ue)))
((eq (car ue) 'LCL)
(setq bds-lcl ue bds-bind 0))
((eq ue *exit*)
@ -49,8 +51,8 @@
(cond ((and (consp *destination*)
(or (eq (car *destination*) 'JUMP-TRUE)
(eq (car *destination*) 'JUMP-FALSE)))
(unwind-bds bds-lcl bds-bind stack-sp ihs-p))
((not (or bds-lcl (plusp bds-bind) stack-sp))
(unwind-bds bds-lcl bds-bind stack-frame ihs-p))
((not (or bds-lcl (plusp bds-bind) stack-frame))
(set-loc loc))
;; Save the value if LOC may possibly refer
;; to special binding.
@ -60,11 +62,11 @@
(temp (make-temp-var)))
(let ((*destination* temp))
(set-loc loc)) ; temp <- loc
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(set-loc temp))) ; *destination* <- temp
(t
(set-loc loc)
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)))
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)))
(when jump-p (wt-nl) (wt-go *exit*))
(return))
(t (setq jump-p t))))
@ -78,16 +80,16 @@
;; *destination* must be either RETURN or TRASH.
(cond ((eq loc 'VALUES)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return VALUES(0);"))
((eq loc 'RETURN)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;"))
(t
(let* ((*destination* 'RETURN))
(set-loc loc))
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;")))
(return))
((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT
@ -105,7 +107,7 @@
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (make-lcl-var :type (second loc))))
(wt-nl "{cl_fixnum " lcl "= " loc ";")
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return(" lcl ");}"))
(progn
(wt-nl "return(" loc ");")))
@ -121,22 +123,22 @@
;;; Never reached
)
(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil))
(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
(declare (fixnum bds-bind))
(dolist (ue *unwind-exit* (baboon))
(cond
((consp ue)
(cond ((eq ue exit)
(unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(return))
((eq (first ue) 'STACK)
(setf stack-sp (second ue)))))
(setf stack-frame (second ue)))))
((numberp ue) (setq bds-lcl ue bds-bind 0))
((eq ue 'BDS-BIND) (incf bds-bind))
((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER
RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT))
(if (eq exit ue)
(progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(return))
(baboon))
;;; Never reached
@ -144,7 +146,7 @@
((eq ue 'FRAME) (wt-nl "frs_pop();"))
((eq ue 'TAIL-RECURSION-MARK)
(if (eq exit 'TAIL-RECURSION-MARK)
(progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
(progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(return))
(baboon))
;;; Never reached

24
src/cmp/cmpmulti.lsp
View file

@ -31,22 +31,20 @@
(t
(c1expr
(let ((function (gensym))
(nargs (gensym)))
`(with-stack
(let* ((,function ,(first args))
(,nargs (+ ,@(loop for i in (rest args)
collect `(stack-push-values ,i)))))
(declare (fixnum ,nargs))
(apply-from-stack ,nargs ,function))))))))
(frame (gensym)))
`(with-stack ,frame
(let* ((,function ,(first args)))
,@(loop for i in (rest args)
collect `(stack-push-values ,frame ,i))
(si::apply-from-stack-frame ,frame ,function))))))))
(defun c1multiple-value-prog1 (args)
(check-args-number 'MULTIPLE-VALUE-PROG1 args 1)
(c1expr (let ((l (gensym)))
`(with-stack
(let ((,l (stack-push-values ,(first args))))
(declare (fixnum ,l))
,@(rest args)
(stack-pop ,l))))))
(c1expr (let ((frame (gensym)))
`(with-stack ,frame
(stack-push-values ,frame ,(first args))
,@(rest args)
(stack-pop ,frame)))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

59
src/cmp/cmpstack.lsp
View file

@ -23,32 +23,43 @@
(in-package "COMPILER")
(defun c1with-stack (forms)
(let ((body (c1expr `(progn ,@forms))))
(make-c1form* 'WITH-STACK :type (c1form-type body)
:args body)))
(let* ((var (pop forms))
(body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms))))
(make-c1form* 'WITH-STACK
:type (c1form-type body)
:args body)))
(defvar +ecl-stack-frame-variable+ "_ecl_inner_frame")
(defun c2with-stack (body)
(let* ((new-destination (tmp-destination *destination*))
(*temp* *temp*)
(sp (make-lcl-var :rep-type :cl-index)))
(wt-nl "{cl_index " sp "=cl_stack_index();")
(*temp* *temp*))
(wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
(wt-nl *volatile* "cl_object _ecl_inner_frame = (_ecl_inner_frame_aux.narg=0,_ecl_inner_frame_aux.sp=0,_ecl_inner_frame_aux.t=t_frame,(cl_object)&_ecl_inner_frame_aux);")
(let* ((*destination* new-destination)
(*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
(*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*)))
(c2expr* body))
(wt-nl "cl_stack_set_index(" sp ");}")
(wt-nl "ecl_stack_frame_close(_ecl_inner_frame);}")
(unwind-exit new-destination)))
(defun c1innermost-stack-frame (args)
(c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+
:one-liner t :side-effects nil)))
(defun c1stack-push (args)
(c1expr `(progn
(c-inline ,args (t) :void "cl_stack_push(#0)"
(c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)"
:one-liner t :side-effects t)
1)))
(defun c1stack-push-values (args)
(make-c1form* 'STACK-PUSH-VALUES :type 'fixnum
:args (c1expr (first args))
(c1expr `(c-inline () () fixnum "cl_stack_push_values()"
:one-liner t :side-effects t))))
(let ((frame-var (pop args))
(form (pop args)))
(make-c1form* 'STACK-PUSH-VALUES :type '(VALUES)
:args
(c1expr form)
(c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)"
:one-liner t :side-effects t)))))
(defun c2stack-push-values (form push-statement)
(let ((*destination* 'VALUES))
@ -56,26 +67,20 @@
(c2expr push-statement))
(defun c1stack-pop (args)
(let ((action (c1expr `(c-inline ,args (fixnum) :void
"cl_stack_pop_values(#0)"
:one-liner t
:side-effects t))))
(make-c1form* 'STACK-POP :type t :args action)))
(c1expr `(c-inline ,args (t) (values &rest t)
"VALUES(0)=ecl_stack_frame_pop_values(#0);"
:one-liner nil :side-effects t)))
(defun c2stack-pop (action)
(let ((*destination* 'TRASH))
(c2expr* action))
(unwind-exit 'VALUES))
(defun c1apply-from-stack (args)
(c1expr `(c-inline ,args (fixnum t) (values &rest t) "cl_apply_from_stack(#0,#1);"
(defun c1apply-from-stack-frame (args)
(c1expr `(c-inline ,args (t t) (values &rest t)
"VALUES(0)=ecl_apply_from_stack_frame(#0,#1);"
:one-liner nil :side-effects t)))
(put-sysprop 'with-stack 'C1 #'c1with-stack)
(put-sysprop 'with-stack 'c2 #'c2with-stack)
(put-sysprop 'innermost-stack-frame 'C1 #'c1innermost-stack-frame)
(put-sysprop 'stack-push 'C1 #'c1stack-push)
(put-sysprop 'stack-push-values 'C1 #'c1stack-push-values)
(put-sysprop 'stack-push-values 'C2 #'c2stack-push-values)
(put-sysprop 'stack-pop 'C1 #'c1stack-pop)
(put-sysprop 'stack-pop 'C2 #'c2stack-pop)
(put-sysprop 'apply-from-stack 'c1 #'c1apply-from-stack)
(put-sysprop 'si::apply-from-stack-frame 'c1 #'c1apply-from-stack-frame)

14
src/h/external.h
View file

@ -440,6 +440,16 @@ extern cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, ...));
/* interpreter.c */
extern cl_object si_interpreter_stack _ARGS((cl_narg narg));
extern void ecl_stack_frame_reserve(cl_object f, cl_index size);
extern void ecl_stack_frame_push(cl_object f, cl_object o);
extern void ecl_stack_frame_push_values(cl_object f);
extern void ecl_stack_frame_push_va_list(cl_object f, cl_va_list args);
extern void ecl_stack_frame_close(cl_object f);
extern cl_object ecl_stack_frame_pop_values(cl_object f);
extern cl_object ecl_stack_frame_elt(cl_object f, cl_index n);
extern void ecl_stack_frame_elt_set(cl_object f, cl_index n, cl_object o);
extern cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o);
#define si_apply_from_stack_frame ecl_apply_from_stack_frame
extern void cl_stack_push(cl_object o);
extern cl_object cl_stack_pop(void);
@ -454,7 +464,7 @@ extern void cl_stack_push_n(cl_index n, cl_object *args);
extern cl_index cl_stack_push_values(void);
extern void cl_stack_pop_values(cl_index n);
extern cl_object ecl_apply_lambda(cl_narg narg, cl_object fun);
extern cl_object ecl_apply_lambda(cl_object frame, cl_object fun);
extern void *ecl_interpret(cl_object bytecodes, void *pc);
/* disassembler.c */
@ -649,7 +659,7 @@ extern cl_object si_clear_gfun_hash(cl_object what);
extern cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t);
extern cl_object si_generic_function_p(cl_object instance);
extern cl_object _ecl_compute_method(cl_narg narg, cl_object fun, cl_object *args);
extern cl_object _ecl_standard_dispatch(cl_object frame, cl_object fun);
#endif /* CLOS */

4
src/h/internal.h
View file

@ -68,6 +68,10 @@ struct cl_compiler_env {
#define cl_stack_ref(n) cl_env.stack[n]
#define cl_stack_index() (cl_env.stack_top-cl_env.stack)
#define ECL_BUILD_STACK_FRAME(name) \
struct ecl_stack_frame name##_aux;\
cl_object name=(name##_aux.t=t_frame,name##_aux.narg=name##_aux.sp=0,(cl_object)&(name##_aux));
/* ffi.d */
#define ECL_FFICALL_LIMIT 256

10
src/h/object.h
View file

@ -487,6 +487,12 @@ struct ecl_foreign { /* user defined datatype */
char *data; /* the data itself */
};
struct ecl_stack_frame {
HEADER;
cl_index narg; /* Size */
cl_index sp; /* Stack pointer start */
};
/*
dummy type
*/
@ -582,7 +588,8 @@ union cl_lispunion {
struct ecl_condition_variable condition_variable; /* condition-variable */
#endif
struct ecl_codeblock cblock; /* codeblock */
struct ecl_foreign foreign; /* user defined data type */
struct ecl_foreign foreign; /* user defined data type */
struct ecl_stack_frame frame; /* stack frame */
};
/*
@ -635,6 +642,7 @@ typedef enum {
#endif
t_codeblock,
t_foreign,
t_frame,
t_end,
t_other,
t_contiguous, /* contiguous block */

2
src/lsp/config.lsp.in
View file

@ -24,7 +24,7 @@ Returns, as a string, the location of the machine on which ECL runs."
(defun lisp-implementation-version ()
"Args:()
Returns the version of your ECL as a string."
"@PACKAGE_VERSION@ (CVS 2008-02-09 20:37)")
"@PACKAGE_VERSION@ (CVS 2008-02-10 18:53)")
(defun machine-type ()
"Args: ()