mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 23:50:56 -08:00
c2aa136143
and the interpreter to understand (SETF fname) function names, and to handle them without creating auxiliary symbols.
146 lines
3 KiB
D
146 lines
3 KiB
D
/*
|
|
cfun.c -- Compiled functions.
|
|
*/
|
|
/*
|
|
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
Copyright (c) 1990, Giuseppe Attardi.
|
|
Copyright (c) 2001, Juan Jose Garcia Ripoll.
|
|
|
|
ECL is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU Library General Public
|
|
License as published by the Free Software Foundation; either
|
|
version 2 of the License, or (at your option) any later version.
|
|
|
|
See file '../Copyright' for full details.
|
|
*/
|
|
|
|
#include "ecl.h"
|
|
#include <string.h> /* for memmove() */
|
|
|
|
cl_object
|
|
cl_make_cfun(cl_object (*self)(), cl_object name, cl_object cblock, int narg)
|
|
{
|
|
cl_object cf;
|
|
|
|
cf = cl_alloc_object(t_cfun);
|
|
cf->cfun.entry = self;
|
|
cf->cfun.name = name;
|
|
cf->cfun.block = cblock;
|
|
cf->cfun.narg = narg;
|
|
if (narg < 0 || narg >= C_ARGUMENTS_LIMIT)
|
|
FEprogram_error("cl_make_cfun: function requires too many arguments.",0);
|
|
return(cf);
|
|
}
|
|
|
|
cl_object
|
|
cl_make_cfun_va(cl_objectfn self, cl_object name, cl_object cblock)
|
|
{
|
|
cl_object cf;
|
|
|
|
cf = cl_alloc_object(t_cfun);
|
|
cf->cfun.entry = self;
|
|
cf->cfun.name = name;
|
|
cf->cfun.block = cblock;
|
|
cf->cfun.narg = -1;
|
|
return(cf);
|
|
}
|
|
|
|
cl_object
|
|
cl_make_cclosure_va(cl_objectfn self, cl_object env, cl_object block)
|
|
{
|
|
cl_object cc;
|
|
|
|
cc = cl_alloc_object(t_cclosure);
|
|
cc->cclosure.entry = self;
|
|
cc->cclosure.env = env;
|
|
cc->cclosure.block = block;
|
|
return(cc);
|
|
}
|
|
|
|
void
|
|
cl_def_c_function(cl_object sym, cl_object (*self)(), int narg)
|
|
{
|
|
si_fset(2, sym,
|
|
cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), narg));
|
|
}
|
|
|
|
void
|
|
cl_def_c_macro_va(cl_object sym, cl_objectfn self)
|
|
{
|
|
si_fset(3, sym, cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')),
|
|
Ct);
|
|
}
|
|
|
|
void
|
|
cl_def_c_function_va(cl_object sym, cl_objectfn self)
|
|
{
|
|
si_fset(2, sym,
|
|
cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')));
|
|
}
|
|
|
|
cl_object
|
|
si_compiled_function_name(cl_object fun)
|
|
{
|
|
cl_object output;
|
|
|
|
switch(type_of(fun)) {
|
|
case t_bytecodes:
|
|
output = fun->bytecodes.name; break;
|
|
case t_cfun:
|
|
output = fun->cfun.name; break;
|
|
case t_cclosure:
|
|
output = Cnil; break;
|
|
default:
|
|
FEinvalid_function(fun);
|
|
}
|
|
@(return output)
|
|
}
|
|
|
|
cl_object
|
|
cl_function_lambda_expression(cl_object fun)
|
|
{
|
|
cl_object output, name = Cnil, lex = Cnil;
|
|
|
|
switch(type_of(fun)) {
|
|
case t_bytecodes:
|
|
lex = fun->bytecodes.lex;
|
|
name = fun->bytecodes.name;
|
|
output = fun->bytecodes.definition;
|
|
if (!CONSP(output))
|
|
output = Cnil;
|
|
else if (name == Cnil)
|
|
output = cl_cons(@'lambda', output);
|
|
else
|
|
output = @list*(3, @'lambda-block', name, output);
|
|
break;
|
|
case t_cfun:
|
|
name = fun->cfun.name;
|
|
lex = Cnil;
|
|
output = Cnil;
|
|
break;
|
|
case t_cclosure:
|
|
name = Cnil;
|
|
lex = Ct;
|
|
output = Cnil;
|
|
break;
|
|
default:
|
|
FEinvalid_function(fun);
|
|
}
|
|
@(return output lex name)
|
|
}
|
|
|
|
cl_object
|
|
si_compiled_function_block(cl_object fun)
|
|
{
|
|
cl_object output;
|
|
|
|
switch(type_of(fun)) {
|
|
case t_cfun:
|
|
output = fun->cfun.block; break;
|
|
case t_cclosure:
|
|
output = fun->cclosure.block; break;
|
|
default:
|
|
FEerror("~S is not a compiled-function.", 1, fun);
|
|
}
|
|
@(return output)
|
|
}
|