void Ffind_all_symbols(CL_FORM *base)
{
GEN_HEAPVAR(ARG(0), ARG(1));
LOAD_NIL(ARG(1));
GEN_HEAPVAR(ARG(1), ARG(2));
if(CL_SYMBOLP(INDIRECT(ARG(0))) || CL_NILP(INDIRECT(ARG(0))))
{
COPY(INDIRECT(ARG(0)), ARG(2));
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), INDIRECT(ARG(0)));
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], INDIRECT(ARG(0))); /* NIL */
}
}
LOAD_NIL(ARG(2));
{
GEN_CLOSURE(array, ARG(3), 5, Z133_lambda, 1);
COPY(ARG(1), &array[3]);
COPY(ARG(0), &array[4]);
LOAD_CLOSURE(array, ARG(3));
}
COPY(ARG(3), ARG(3));
COPY(SYMVAL(Slisp, 389), ARG(4)); /* *PACKAGE-ARRAY* */
Fmap(ARG(2), 3);
COPY(INDIRECT(ARG(1)), ARG(0));
}
int OMP_depend_op(expv v)
{
char *s;
if(EXPR_CODE(v) != IDENT) fatal("OMP_depend_op: no IDENT");
s = SYM_NAME(EXPR_SYM(v));
if(strcmp("in",s) == 0) return (int)OMP_DATA_DEPEND_IN;
if(strcmp("out",s) == 0) return (int)OMP_DATA_DEPEND_OUT;
if(strcmp("inout",s) == 0) return (int)OMP_DATA_DEPEND_INOUT;
error("bad intrinsic function in REPEND clause of OpenMP");
return OMP_DATA_DEPEND_IN; /* dummy */
}
int OMP_reduction_op(expr v)
{
char *s;
if(EXPR_CODE(v) != IDENT) fatal("OMP_reduction_op: no IDENT");
s = SYM_NAME(EXPR_SYM(v));
if(strcmp("max",s) == 0) return (int)OMP_DATA_REDUCTION_MAX;
if(strcmp("min",s) == 0) return (int)OMP_DATA_REDUCTION_MIN;
if(strcmp("iand",s) == 0) return (int)OMP_DATA_REDUCTION_BITAND;
if(strcmp("ior",s) == 0) return (int)OMP_DATA_REDUCTION_BITOR;
if(strcmp("ieor",s) == 0) return (int)OMP_DATA_REDUCTION_BITXOR;
error("bad intrinsic function in REDUCTION clause of OpenMP");
return OMP_DATA_REDUCTION_PLUS; /* dummy */
}
static void
gen_expr(tree *expr)
{
struct variable *var;
switch(expr->tag) {
case node_arg:
var = get_global(ARG_NAME(expr));
codegen_load_file(expr, var);
break;
case node_call:
analyze_call(expr, true, codegen_size);
break;
case node_constant:
LOAD_CONSTANT(expr->value.constant, codegen_size);
break;
case node_symbol:
var = get_global(SYM_NAME(expr));
if (var->tag == sym_const) {
LOAD_CONSTANT(var->value, codegen_size);
} else {
codegen_load_file(expr, var);
}
break;
case node_unop:
gen_unop_expr(expr);
break;
case node_binop:
if (expr->value.binop.op == op_assign) {
analyze_error(expr, "assign operator = should be equal operator ==");
} else if ((expr->value.binop.op == op_lsh) ||
(expr->value.binop.op == op_rsh)) {
/* for shifts it is best to calculate the left side first */
gen_binop_expr(expr->value.binop.op,
expr->value.binop.p1,
expr->value.binop.p0);
} else {
/* for all others calculate the right side first */
gen_binop_expr(expr->value.binop.op,
expr->value.binop.p0,
expr->value.binop.p1);
}
break;
default:
assert(0);
}
}
static void
gen_binop_expr(enum node_op op, tree *p0, tree *p1)
{
char *reg1 = NULL;
char *reg2 = NULL;
struct variable *var;
gen_expr(p1);
if (p0->tag == node_call) {
reg1 = codegen_get_temp(codegen_size);
STORE_FILE(reg1, codegen_size, 0, false);
analyze_call(p0, true, codegen_size);
CODEGEN(op, codegen_size, false, 0, reg1);
} else if (p0->tag == node_constant) {
CODEGEN(op, codegen_size, true, p0->value.constant, NULL);
} else if (p0->tag == node_symbol) {
var = get_global(SYM_NAME(p0));
if (var->tag == sym_const) {
CODEGEN(op, codegen_size, true, var->value, NULL);
} else if (SYM_OFST(p0)) {
/* it is a complex expression, so save temp data */
reg1 = codegen_get_temp(codegen_size);
reg2 = codegen_get_temp(codegen_size);
STORE_FILE(reg1, codegen_size, 0, false);
codegen_load_file(p0, var);
STORE_FILE(reg2, codegen_size, 0, false);
LOAD_FILE(reg1, codegen_size, 0, false);
CODEGEN(op, codegen_size, false, 0, reg2);
} else {
CODEGEN(op, codegen_size, false, 0, var->name);
}
} else {
/* it is a complex expression so save temp data */
reg1 = codegen_get_temp(codegen_size);
STORE_FILE(reg1, codegen_size, 0, false);
gen_expr(p0);
CODEGEN(op, codegen_size, false, 0, reg1);
}
if (reg1)
free(reg1);
if (reg2)
free(reg2);
}
static void
codegen_load_file(tree *symbol, struct variable *var)
{
int offset;
int element_size;
if ((symbol->tag == node_symbol) && (SYM_OFST(symbol))) {
/* access an array */
element_size = type_size(var->type->prim);
if ((var) && (var->type) && (var->type->tag == type_array)) {
if (can_evaluate(SYM_OFST(symbol), false)) {
/* direct access */
offset = analyze_check_array(symbol, var) * element_size;
if (is_far(var)) {
LOAD_FILE(var->name, codegen_size, offset, true);
} else {
LOAD_FILE(var->name, codegen_size, offset, false);
}
} else {
codegen_indirect(SYM_OFST(symbol), var, element_size, false);
if (is_far(var)) {
LOAD_INDIRECT(var->name, codegen_size, 0, true);
} else {
LOAD_INDIRECT(var->name, codegen_size, 0, false);
}
}
} else {
analyze_error(symbol, "symbol %s is not an array",
SYM_NAME(symbol));
}
} else {
if (is_far(var)) {
LOAD_FILE(var->name, codegen_size, 0, true);
} else {
LOAD_FILE(var->name, codegen_size, 0, false);
}
}
return;
}
void rt_setup_symbol(CL_FORM *base)
{
if(CL_SYMBOLP(ARG(0)))
{
COPY(SYM_PACKAGE(ARG(0)), ARG(2));
}
else
{
if(CL_TRUEP(ARG(0)))
{
LOAD_NIL(ARG(2));
}
else
{
COPY(SYMVAL(Slisp, 679), ARG(2)); /* *NIL-PACKAGE* */
}
}
if(CL_TRUEP(ARG(2)))
{
COPY(ARG(1), ARG(3));
COPY(ARG(2), ARG(4));
Fminusp(ARG(4));
if(CL_TRUEP(ARG(4)))
{
COPY(ARG(2), ARG(4));
Fminus(ARG(4), 1);
}
else
{
COPY(ARG(2), ARG(4));
}
Fsvref(ARG(3));
if(CL_SYMBOLP(ARG(0)))
{
LOAD_SMSTR(SYM_NAME(ARG(0)), ARG(4));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(4)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(5));
Ferror(ARG(4), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(4)); /* NIL */
}
}
LOAD_FIXNUM(ARG(5), 101, ARG(5));
COPY(ARG(4), ARG(6));
string_to_simple_string(ARG(6));
rt_sxhash_string(ARG(6));
COPY(ARG(6), ARG(7));
LOAD_FIXNUM(ARG(8), 101, ARG(8));
rt_floor(ARG(7));
COPY(&mv_buf[0], ARG(8));
mv_count = 1;
{
COPY(ARG(8), ARG(4));
}
COPY(ARG(0), ARG(5));
COPY(ARG(3), ARG(6));
set_symbol_package(ARG(5));
COPY(ARG(2), ARG(5));
Fplusp(ARG(5));
if(CL_TRUEP(ARG(5)))
{
COPY(ARG(3), ARG(5));
Ppackage_internal(ARG(5));
COPY(ARG(5), ARG(7));
COPY(ARG(4), ARG(8));
Fsvref(ARG(7));
ALLOC_CONS(ARG(8), ARG(0), ARG(7), ARG(6));
COPY(ARG(5), ARG(7));
COPY(ARG(4), ARG(8));
Fset_svref(ARG(6));
COPY(ARG(6), ARG(0));
}
else
{
COPY(ARG(3), ARG(5));
Ppackage_external(ARG(5));
COPY(ARG(5), ARG(7));
COPY(ARG(4), ARG(8));
Fsvref(ARG(7));
ALLOC_CONS(ARG(8), ARG(0), ARG(7), ARG(6));
COPY(ARG(5), ARG(7));
COPY(ARG(4), ARG(8));
Fset_svref(ARG(6));
COPY(ARG(6), ARG(0));
}
}
else
{
LOAD_NIL(ARG(0));
}
}
void copy_symbol1(CL_FORM *base)
{
if(CL_SYMBOLP(ARG(0)))
{
LOAD_SMSTR(SYM_NAME(ARG(0)), ARG(2));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(2)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(3));
Ferror(ARG(2), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(2)); /* NIL */
}
}
Fmake_symbol(ARG(2));
if(CL_TRUEP(ARG(1)))
{
COPY(ARG(0), ARG(3));
Fboundp(ARG(3));
if(CL_TRUEP(ARG(3)))
{
COPY(ARG(2), ARG(3));
if(CL_SYMBOLP(ARG(0)))
{
COPY(SYM_VALUE(ARG(0)), ARG(4));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(4)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(5));
Ferror(ARG(4), 2);
}
else
{
LOAD_NIL(ARG(4));
}
}
Fset(ARG(3));
}
if(CL_SYMBOLP(ARG(0)))
{
COPY(SYM_PLIST(ARG(0)), ARG(3));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(3)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(4));
Ferror(ARG(3), 2);
}
else
{
COPY(SYMVAL(Slisp, 678), ARG(3)); /* *NIL-PLIST* */
}
}
Fcopy_list(ARG(3));
COPY(ARG(3), ARG(4));
COPY(ARG(2), ARG(5));
Fset_symbol_plist(ARG(4));
}
COPY(ARG(2), ARG(0));
}
void export1(CL_FORM *base)
{
coerce_to_package(ARG(1));
if(CL_LISTP(ARG(0)))
{
}
else
{
COPY(ARG(0), ARG(2));
Flist(ARG(2), 1);
COPY(ARG(2), ARG(0));
}
LOAD_NIL(ARG(2));
COPY(ARG(0), ARG(3));
M1_1:;
if(CL_ATOMP(ARG(3)))
{
LOAD_NIL(ARG(2));
goto RETURN1;
}
COPY(ARG(3), ARG(4));
COPY(GET_CAR(ARG(4)), ARG(2));
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), ARG(4));
}
else
{
if(CL_TRUEP(ARG(2)))
{
COPY(SYMVAL(Slisp, 676), ARG(4)); /* SYM_EXPECTED */
COPY(ARG(2), ARG(5));
Ferror(ARG(4), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(4)); /* NIL */
}
}
COPY(ARG(1), ARG(5));
find_symbol1(ARG(4));
COPY(&mv_buf[0], ARG(5));
{
int nargs;
nargs = 2;
mv_count = 1;
{
switch(nargs)
{
case 0:
LOAD_NIL(ARG(4));
case 1:
LOAD_NIL(ARG(5));
nargs = 2;
}
if(CL_TRUEP(ARG(5)))
{
LOAD_NIL(ARG(6));
}
else
{
LOAD_SYMBOL(SYMBOL(Slisp, 48), ARG(6)); /* T */
}
if(CL_TRUEP(ARG(6)))
{
goto THEN1;
}
else
{
if(EQ(ARG(4), ARG(2)))
{
goto ELSE2;
}
else
{
goto THEN1;
}
}
{
THEN1:;
LOAD_SMSTR((CL_FORM *)&Kexport1[0], ARG(6)); /* ~S is not accessible in ~S */
COPY(ARG(2), ARG(7));
COPY(ARG(1), ARG(8));
Ferror(ARG(6), 3);
}
ELSE2:;
if(CL_SYMBOLP(ARG(5)) && GET_SYMBOL(ARG(5)) == SYMBOL(Slisp, 385)) /* EXTERNAL */
{
goto RETURN1;
}
LOAD_NIL(ARG(6));
COPY(ARG(1), ARG(7));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(8)); /* PACKAGE */
rt_struct_typep(ARG(7));
if(CL_TRUEP(ARG(7)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 6 + 1), ARG(7));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(7)); /* NO_STRUCT */
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
Ferror(ARG(7), 3);
}
M2_1:;
if(CL_ATOMP(ARG(7)))
{
LOAD_NIL(ARG(6));
goto RETURN2;
}
COPY(ARG(7), ARG(8));
COPY(GET_CAR(ARG(8)), ARG(6));
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), ARG(8));
}
else
{
if(CL_TRUEP(ARG(2)))
{
COPY(SYMVAL(Slisp, 676), ARG(8)); /* SYM_EXPECTED */
COPY(ARG(2), ARG(9));
Ferror(ARG(8), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(8)); /* NIL */
}
}
COPY(ARG(6), ARG(9));
find_symbol1(ARG(8));
COPY(&mv_buf[0], ARG(9));
{
int nargs;
nargs = 2;
mv_count = 1;
{
switch(nargs)
{
case 0:
LOAD_NIL(ARG(8));
case 1:
LOAD_NIL(ARG(9));
nargs = 2;
}
if(CL_TRUEP(ARG(9)))
{
if(EQ(ARG(8), ARG(2)))
{
goto ELSE3;
}
else
{
COPY(ARG(6), ARG(10));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(11)); /* PACKAGE */
rt_struct_typep(ARG(10));
if(CL_TRUEP(ARG(10)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(6))), 4 + 1), ARG(10));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(10)); /* NO_STRUCT */
COPY(ARG(6), ARG(11));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(12)); /* PACKAGE */
Ferror(ARG(10), 3);
}
COPY(ARG(8), ARG(11));
COPY(ARG(10), ARG(12));
LOAD_NIL(ARG(13));
LOAD_NIL(ARG(14));
LOAD_NIL(ARG(15));
member1(ARG(11));
COPY(ARG(11), ARG(10));
if(CL_TRUEP(ARG(10)))
{
goto ELSE3;
}
else
{
goto THEN4;
}
}
}
else
{
goto ELSE3;
}
{
THEN4:;
LOAD_SMSTR((CL_FORM *)&Kexport1[2], ARG(10)); /* ~S will cause a name conflict in ~S */
COPY(ARG(2), ARG(11));
COPY(ARG(6), ARG(12));
Ferror(ARG(10), 3);
}
ELSE3:;
}
}
COPY(ARG(7), ARG(8));
COPY(GET_CDR(ARG(8)), ARG(7));
goto M2_1;
RETURN2:;
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), ARG(6));
}
else
{
if(CL_TRUEP(ARG(2)))
{
COPY(SYMVAL(Slisp, 676), ARG(6)); /* SYM_EXPECTED */
COPY(ARG(2), ARG(7));
Ferror(ARG(6), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(6)); /* NIL */
}
}
LOAD_FIXNUM(ARG(7), 101, ARG(7));
COPY(ARG(6), ARG(8));
string_to_simple_string(ARG(8));
rt_sxhash_string(ARG(8));
COPY(ARG(8), ARG(9));
LOAD_FIXNUM(ARG(10), 101, ARG(10));
rt_floor(ARG(9));
COPY(&mv_buf[0], ARG(10));
mv_count = 1;
{
COPY(ARG(10), ARG(6));
}
if(CL_SYMBOLP(ARG(5)) && GET_SYMBOL(ARG(5)) == SYMBOL(Slisp, 384)) /* INTERNAL */
{
COPY(ARG(2), ARG(7));
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 2 + 1), ARG(8));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(8)); /* NO_STRUCT */
COPY(ARG(1), ARG(9));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(10)); /* PACKAGE */
Ferror(ARG(8), 3);
}
COPY(ARG(6), ARG(9));
del_pack_sym(ARG(7));
}
COPY(ARG(1), ARG(7));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(8)); /* PACKAGE */
rt_struct_typep(ARG(7));
if(CL_TRUEP(ARG(7)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 3 + 1), ARG(7));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(7)); /* NO_STRUCT */
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
Ferror(ARG(7), 3);
}
COPY(ARG(7), ARG(9));
COPY(ARG(6), ARG(10));
Fsvref(ARG(9));
ALLOC_CONS(ARG(10), ARG(2), ARG(9), ARG(8));
COPY(ARG(8), ARG(9));
COPY(ARG(7), ARG(10));
COPY(ARG(6), ARG(11));
Fset_svref(ARG(9));
}
}
COPY(ARG(3), ARG(4));
COPY(GET_CDR(ARG(4)), ARG(3));
goto M1_1;
RETURN1:;
LOAD_SYMBOL(SYMBOL(Slisp, 48), ARG(0)); /* T */
}
struct lisp_object *c_eval(struct lisp_object *obj) {
if (!obj) {
lisp_error();
return NULL;
}
if (obj->quoted) {
struct lisp_object *new_obj = lisp_object_deep_copy(obj);
new_obj->quoted = C_FALSE;
return new_obj;
}
switch (obj->obj_type) {
case LIST:
{
struct lisp_object *ret = make_lisp_object(LIST, NULL);
struct lisp_object *head = HEAD(obj);
if (!head) {
// It already is nil
return ret;
}
struct lisp_object *func = c_eval(head);
if (!func) {
set_error("Function %s doesn't exist.", TOSTR(head));
return NULL;
}
if (func->obj_type != BUILTIN && func->obj_type != FUNCTION) {
set_error("First object in list is not a function.", SYM_NAME(head));
return NULL;
}
/* Allocate an object to be used to store the copied arguments list */
struct lisp_object *args = make_lisp_object(LIST, NULL);
if (head->next) {
struct lisp_object *args_head;
if (func->obj_type == BUILTIN && (TOBUILTIN(func)->spec & UNEVAL_ARGS)) {
args_head = lisp_object_deep_copy(head->next);
}
else {
args_head = c_eval(head->next);
if (!args_head) {
return NULL;
}
}
args_head->next = NULL;
args_head->prev = NULL;
struct lisp_object *current = head->next->next;
struct lisp_object *args_current = NULL;
struct lisp_object *args_prev = args_head;
while (current) {
if (func->obj_type == BUILTIN && (TOBUILTIN(func)->spec & UNEVAL_ARGS)) {
args_current = lisp_object_deep_copy(current);
}
else {
args_current = c_eval(current);
if (!args_current) {
return NULL;
}
}
args_current->prev = args_prev;
args_current->next = NULL;
args_prev->next = args_current;
args_prev = args_current;
current = current->next;
}
/* Finish constructing the arguments list */
args->data = args_head;
}
/* Perform the function call. */
if (func->obj_type == BUILTIN) {
int count = list_length(args);
struct lisp_builtin *builtin = TOBUILTIN(func);
if (builtin->max_params != -1 && count > builtin->max_params) {
set_error("Incorrect number of arguments (%d) to function %s!", count, TOSTR(head));
}
if (builtin->min_params != -1 && count < builtin->min_params) {
set_error("Incorrect number of arguments (%d) to function %s!", count, TOSTR(head));
}
return builtin->func(args);
}
else if (func->obj_type == FUNCTION) {
struct lisp_function *func_obj = TOFUNC(func);
int count = list_length(args);
char *func_name = head->obj_type == SYMBOL ? TOSTR(head) : "<unnamed lambda>";
if (count != func_obj->numparams) {
set_error("Incorrect number of arguments (%d) to function %s!", count, func_name);
return NULL;
}
int i = 0;
struct lisp_object *params_current = HEAD(func_obj->params);
struct lisp_object *args_current = HEAD(args);
struct symbol *syms = malloc(sizeof(struct symbol)*count);
while (params_current) {
syms[i].symbol_name = SYM_NAME(params_current);
syms[i].value = args_current;
i++;
params_current = params_current->next;
args_current = args_current->next;
}
set_local_symbols(syms, count);
struct lisp_object *form_current = func_obj->forms;
struct lisp_object *sub = nil;
while (form_current) {
sub = c_eval(form_current);
if (!sub) {
return NULL;
}
// Keep track of the return value
ret = sub;
form_current = form_current->next;
}
unset_local_symbols();
free(syms);
return ret;
}
}
case SYMBOL:
{
/* Do a lookup of the symbol and return the value. */
struct lisp_object *value = symbol_value(SYM_NAME(obj));
if (!value) {
set_error("Symbol %s does not exist!", SYM_NAME(obj));
}
return value;
}
default:
{
return lisp_object_deep_copy(obj);
}
}
}
void shadowing_import1(CL_FORM *base)
{
coerce_to_package(ARG(1));
if(CL_LISTP(ARG(0)))
{
}
else
{
COPY(ARG(0), ARG(2));
Flist(ARG(2), 1);
COPY(ARG(2), ARG(0));
}
LOAD_NIL(ARG(2));
COPY(ARG(0), ARG(3));
M1_1:;
if(CL_ATOMP(ARG(3)))
{
LOAD_NIL(ARG(2));
goto RETURN1;
}
COPY(ARG(3), ARG(4));
COPY(GET_CAR(ARG(4)), ARG(2));
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), ARG(4));
}
else
{
if(CL_TRUEP(ARG(2)))
{
COPY(SYMVAL(Slisp, 676), ARG(4)); /* SYM_EXPECTED */
COPY(ARG(2), ARG(5));
Ferror(ARG(4), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(4)); /* NIL */
}
}
COPY(ARG(1), ARG(5));
find_symbol1(ARG(4));
COPY(&mv_buf[0], ARG(5));
{
int nargs;
nargs = 2;
mv_count = 1;
{
switch(nargs)
{
case 0:
LOAD_NIL(ARG(4));
case 1:
LOAD_NIL(ARG(5));
nargs = 2;
}
if(CL_SYMBOLP(ARG(2)))
{
LOAD_SMSTR(SYM_NAME(ARG(2)), ARG(6));
}
else
{
if(CL_TRUEP(ARG(2)))
{
COPY(SYMVAL(Slisp, 676), ARG(6)); /* SYM_EXPECTED */
COPY(ARG(2), ARG(7));
Ferror(ARG(6), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(6)); /* NIL */
}
}
LOAD_FIXNUM(ARG(7), 101, ARG(7));
COPY(ARG(6), ARG(8));
string_to_simple_string(ARG(8));
rt_sxhash_string(ARG(8));
COPY(ARG(8), ARG(9));
LOAD_FIXNUM(ARG(10), 101, ARG(10));
rt_floor(ARG(9));
COPY(&mv_buf[0], ARG(10));
mv_count = 1;
{
COPY(ARG(10), ARG(6));
}
if(CL_SYMBOLP(ARG(5)) && GET_SYMBOL(ARG(5)) == SYMBOL(Slisp, 384)) /* INTERNAL */
{
COPY(ARG(4), ARG(7));
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 2 + 1), ARG(8));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(8)); /* NO_STRUCT */
COPY(ARG(1), ARG(9));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(10)); /* PACKAGE */
Ferror(ARG(8), 3);
}
COPY(ARG(6), ARG(9));
del_pack_sym(ARG(7));
}
else
{
if(CL_SYMBOLP(ARG(5)) && GET_SYMBOL(ARG(5)) == SYMBOL(Slisp, 385)) /* EXTERNAL */
{
COPY(ARG(4), ARG(7));
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 3 + 1), ARG(8));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(8)); /* NO_STRUCT */
COPY(ARG(1), ARG(9));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(10)); /* PACKAGE */
Ferror(ARG(8), 3);
}
COPY(ARG(6), ARG(9));
del_pack_sym(ARG(7));
}
}
}
}
COPY(ARG(2), ARG(4));
COPY(ARG(1), ARG(5));
internal_import(ARG(4));
COPY(ARG(1), ARG(5));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(6)); /* PACKAGE */
rt_struct_typep(ARG(5));
if(CL_TRUEP(ARG(5)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 4 + 1), ARG(5));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(5)); /* NO_STRUCT */
COPY(ARG(1), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
Ferror(ARG(5), 3);
}
ALLOC_CONS(ARG(6), ARG(2), ARG(5), ARG(4));
LOAD_FIXNUM(ARG(5), 4, ARG(5));
COPY(ARG(1), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
rt_struct_typep(ARG(6));
if(CL_TRUEP(ARG(6)))
{
COPY(ARG(4), OFFSET(AR_BASE(GET_FORM(ARG(1))), 4 + 1));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(6)); /* NO_STRUCT */
COPY(ARG(1), ARG(7));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(8)); /* PACKAGE */
Ferror(ARG(6), 3);
}
COPY(ARG(3), ARG(4));
COPY(GET_CDR(ARG(4)), ARG(3));
goto M1_1;
RETURN1:;
LOAD_SYMBOL(SYMBOL(Slisp, 48), ARG(0)); /* T */
}
void unintern1(CL_FORM *base)
{
LOAD_NIL(ARG(2));
LOAD_NIL(ARG(3));
if(CL_SYMBOLP(ARG(0)))
{
LOAD_SMSTR(SYM_NAME(ARG(0)), ARG(4));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(4)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(5));
Ferror(ARG(4), 2);
}
else
{
LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(4)); /* NIL */
}
}
LOAD_NIL(ARG(5));
COPY(ARG(1), ARG(6));
coerce_to_package(ARG(6));
COPY(ARG(6), ARG(1));
COPY(ARG(4), ARG(6));
COPY(ARG(1), ARG(7));
find_symbol1(ARG(6));
COPY(&mv_buf[0], ARG(7));
{
int nargs;
nargs = 2;
mv_count = 1;
{
switch(nargs)
{
case 0:
LOAD_NIL(ARG(6));
case 1:
LOAD_NIL(ARG(7));
nargs = 2;
}
COPY(ARG(6), ARG(2));
COPY(ARG(7), ARG(3));
}
}
if(EQ(ARG(2), ARG(0)))
{
LOAD_BOOL(CL_SYMBOLP(ARG(3)) && GET_SYMBOL(ARG(3)) == SYMBOL(Slisp, 384), ARG(6)); /* INTERNAL */
if(CL_TRUEP(ARG(6)))
{
goto THEN1;
}
else
{
} /* EXTERNAL */
}
else
{
goto ELSE2;
}
if(CL_SYMBOLP(ARG(3)) && GET_SYMBOL(ARG(3)) == SYMBOL(Slisp, 385))
{
THEN1:;
if(CL_SYMBOLP(ARG(3)) && GET_SYMBOL(ARG(3)) == SYMBOL(Slisp, 385)) /* EXTERNAL */
{
COPY(ARG(1), ARG(6));
COPY(ARG(6), ARG(7));
COPY(ARG(7), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(7))), 3 + 1), ARG(5));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(5)); /* NO_STRUCT */
COPY(ARG(7), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
Ferror(ARG(5), 3);
}
}
else
{
COPY(ARG(1), ARG(6));
COPY(ARG(6), ARG(7));
COPY(ARG(7), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(7))), 2 + 1), ARG(5));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(5)); /* NO_STRUCT */
COPY(ARG(7), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
Ferror(ARG(5), 3);
}
}
COPY(ARG(1), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
rt_struct_typep(ARG(6));
if(CL_TRUEP(ARG(6)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 4 + 1), ARG(6));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(6)); /* NO_STRUCT */
COPY(ARG(1), ARG(7));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(8)); /* PACKAGE */
Ferror(ARG(6), 3);
}
COPY(ARG(0), ARG(7));
COPY(ARG(6), ARG(8));
LOAD_NIL(ARG(9));
LOAD_NIL(ARG(10));
LOAD_NIL(ARG(11));
member1(ARG(7));
if(CL_TRUEP(ARG(7)))
{
LOAD_FIXNUM(ARG(6), 0, ARG(6));
LOAD_NIL(ARG(7));
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 5 + 1), ARG(8));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(8)); /* NO_STRUCT */
COPY(ARG(1), ARG(9));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(10)); /* PACKAGE */
Ferror(ARG(8), 3);
}
M1_1:;
if(CL_ATOMP(ARG(8)))
{
LOAD_NIL(ARG(7));
goto RETURN1;
}
COPY(ARG(8), ARG(9));
COPY(GET_CAR(ARG(9)), ARG(7));
COPY(ARG(4), ARG(9));
COPY(ARG(7), ARG(10));
find_symbol1(ARG(9));
COPY(&mv_buf[0], ARG(10));
{
int nargs;
nargs = 2;
mv_count = 1;
{
switch(nargs)
{
case 0:
LOAD_NIL(ARG(9));
case 1:
LOAD_NIL(ARG(10));
nargs = 2;
}
COPY(ARG(9), ARG(2));
COPY(ARG(10), ARG(3));
}
}
if(CL_SYMBOLP(ARG(3)) && GET_SYMBOL(ARG(3)) == SYMBOL(Slisp, 385)) /* EXTERNAL */
{
if(CL_FIXNUMP(ARG(6)) && GET_FIXNUM(ARG(6)) == 0)
{
COPY(ARG(2), ARG(6));
}
else
{
if(EQ(ARG(2), ARG(6)))
{
}
else
{
LOAD_SMSTR((CL_FORM *)&Kunintern1[0], ARG(9)); /* ~S and ~S will cause a name conflict */
COPY(ARG(6), ARG(10));
COPY(ARG(2), ARG(11));
Ferror(ARG(9), 3);
}
}
}
COPY(ARG(8), ARG(9));
COPY(GET_CDR(ARG(9)), ARG(8));
goto M1_1;
RETURN1:;
COPY(ARG(1), ARG(6));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(7)); /* PACKAGE */
rt_struct_typep(ARG(6));
if(CL_TRUEP(ARG(6)))
{
COPY(OFFSET(AR_BASE(GET_FORM(ARG(1))), 4 + 1), ARG(6));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(6)); /* NO_STRUCT */
COPY(ARG(1), ARG(7));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(8)); /* PACKAGE */
Ferror(ARG(6), 3);
}
LOAD_SYMBOL(SYMBOL(Slisp, 392), ARG(7)); /* COUNT */
LOAD_FIXNUM(ARG(8), 1, ARG(8));
Flist(ARG(7), 2);
LOAD_GLOBFUN(&CFremove, ARG(8));
COPY(ARG(0), ARG(9));
COPY(ARG(6), ARG(10));
COPY(ARG(7), ARG(11));
Fapply(ARG(8), 4);
mv_count = 1;
COPY(ARG(8), ARG(6));
LOAD_FIXNUM(ARG(7), 4, ARG(7));
COPY(ARG(1), ARG(8));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(9)); /* PACKAGE */
rt_struct_typep(ARG(8));
if(CL_TRUEP(ARG(8)))
{
COPY(ARG(6), OFFSET(AR_BASE(GET_FORM(ARG(1))), 4 + 1));
}
else
{
COPY(SYMVAL(Slisp, 352), ARG(8)); /* NO_STRUCT */
COPY(ARG(1), ARG(9));
LOAD_SYMBOL(SYMBOL(Slisp, 354), ARG(10)); /* PACKAGE */
Ferror(ARG(8), 3);
}
}
COPY(ARG(0), ARG(6));
COPY(ARG(5), ARG(7));
LOAD_FIXNUM(ARG(8), 101, ARG(8));
COPY(ARG(4), ARG(9));
string_to_simple_string(ARG(9));
rt_sxhash_string(ARG(9));
COPY(ARG(9), ARG(10));
LOAD_FIXNUM(ARG(11), 101, ARG(11));
rt_floor(ARG(10));
COPY(&mv_buf[0], ARG(11));
mv_count = 1;
{
COPY(ARG(11), ARG(8));
}
del_pack_sym(ARG(6));
if(CL_SYMBOLP(ARG(0)))
{
COPY(SYM_PACKAGE(ARG(0)), ARG(6));
}
else
{
if(CL_TRUEP(ARG(0)))
{
COPY(SYMVAL(Slisp, 676), ARG(6)); /* SYM_EXPECTED */
COPY(ARG(0), ARG(7));
Ferror(ARG(6), 2);
}
else
{
COPY(SYMVAL(Slisp, 679), ARG(6)); /* *NIL-PACKAGE* */
}
}
if(EQ(ARG(6), ARG(1)))
{
COPY(ARG(0), ARG(6));
LOAD_NIL(ARG(7));
set_symbol_package(ARG(6));
}
LOAD_SYMBOL(SYMBOL(Slisp, 48), ARG(0)); /* T */
}
else
{
ELSE2:;
LOAD_NIL(ARG(0));
}
}
expv
compile_intrinsic_call0(ID id, expv args, int ignoreTypeMismatch) {
intrinsic_entry *ep = NULL;
int found = 0;
int nArgs = 0;
int nIntrArgs = 0;
int i;
expv ret = NULL;
expv a = NULL;
TYPE_DESC tp = NULL, ftp;
list lp;
INTR_OPS iOps = INTR_END;
const char *iName = NULL;
expv kindV = NULL;
int typeNotMatch = 0;
int isVarArgs = 0;
EXT_ID extid;
if (SYM_TYPE(ID_SYM(id)) != S_INTR) {
if (args == NULL) {
args = list0(LIST);
}
tp = ID_TYPE(id);
if (tp == NULL) {
warning_at_node(args,
"unknown type of '%s' declared as intrinsic",
SYM_NAME(ID_SYM(id)));
ID_TYPE(id) = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
TYPE_ATTR_FLAGS(ID_TYPE(id)) = TYPE_ATTR_FLAGS(id);
tp = ID_TYPE(id);
}
expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id));
if (IS_PROCEDURE_TYPE(tp)) {
ftp = tp;
tp = FUNCTION_TYPE_RETURN_TYPE(ftp);
} else {
ftp = intrinsic_function_type(tp);
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if (TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}
else {
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
}
EXPV_TYPE(symV) = ftp;
return expv_cons(FUNCTION_CALL, tp, symV, args);
}
ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]);
iOps = INTR_OP(ep);
iName = ID_NAME(id);
/* Count a number of argument, first. */
nArgs = 0;
if (args == NULL) {
args = list0(LIST);
}
FOR_ITEMS_IN_LIST(lp, args) {
nArgs++;
}
/* Search an intrinsic by checking argument types. */
found = 0;
for (;
((INTR_OP(ep) == iOps) &&
((strcasecmp(iName, INTR_NAME(ep)) == 0) ||
!(isValidString(INTR_NAME(ep)))));
ep++) {
kindV = NULL;
typeNotMatch = 0;
isVarArgs = 0;
/* Check a number of arguments. */
if (INTR_N_ARGS(ep) < 0 ||
INTR_N_ARGS(ep) == nArgs) {
/* varriable args or no kind arg. */
if (INTR_N_ARGS(ep) < 0) {
isVarArgs = 1;
}
nIntrArgs = nArgs;
} else if (INTR_HAS_KIND_ARG(ep) &&
((INTR_N_ARGS(ep) + 1) == nArgs)) {
/* could be intrinsic call with kind arg. */
expv lastV = expr_list_get_n(args, nArgs - 1);
if (lastV == NULL) {
return NULL; /* error recovery */
}
if (EXPV_KW_IS_KIND(lastV)) {
goto gotKind;
}
tp = EXPV_TYPE(lastV);
if (!(isValidType(tp))) {
return NULL; /* error recovery */
}
if (TYPE_BASIC_TYPE(tp) != TYPE_INT) {
/* kind arg must be integer type. */
continue;
}
gotKind:
nIntrArgs = INTR_N_ARGS(ep);
kindV = lastV;
} else {
continue;
}
/* The number of arguments matchs. Then check types. */
for (i = 0; i < nIntrArgs; i++) {
a = expr_list_get_n(args, i);
if (a == NULL) {
return NULL; /* error recovery */
}
tp = EXPV_TYPE(a);
if (!(isValidType(tp))) {
//return NULL; /* error recovery */
continue;
}
if (i == 1 &&
INTR_ARG_TYPE(ep)[i] == INTR_TYPE_PASSIGNABLE) {
if (expv_is_pointer_assignable(NULL, expr_list_get_n(args, 0), a)) {
break;
}
}
if (compare_intrinsic_arg_type(a, tp,
((isVarArgs == 0) ?
INTR_ARG_TYPE(ep)[i] :
INTR_ARG_TYPE(ep)[0])) != 0) {
/* Type mismatch. */
typeNotMatch = 1;
break;
}
}
if (typeNotMatch == 1) {
continue;
} else {
found = 1;
break;
}
}
if (found == 1) {
/* Yes we found an intrinsic to use. */
SYMBOL sp = NULL;
expv symV = NULL;
/* Then we have to determine return type. */
if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) {
tp = get_intrinsic_return_type(ep, args, kindV);
if (!(isValidType(tp))) {
//fatal("%s: can't determine return type.", __func__);
//return NULL;
tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
} else {
tp = type_VOID;
}
/* Finally find symbol for the intrinsic and make it expv. */
sp = find_symbol((char *)iName);
if (sp == NULL) {
fatal("%s: symbol '%s' is not created??",
__func__,
INTR_NAME(ep));
/* not reached */
return NULL;
}
symV = expv_sym_term(F_FUNC, NULL, sp);
if (symV == NULL) {
fatal("%s: symbol expv creation failure.", __func__);
/* not reached */
return NULL;
}
if (IS_VOID(tp)) {
TYPE_DESC ret = new_type_desc();
*ret = *tp;
tp = intrinsic_subroutine_type();
} else {
TYPE_DESC ret = new_type_desc();
*ret = *tp;
tp = intrinsic_function_type(ret);
}
if (ID_TYPE(id)) {
*ID_TYPE(id) = *tp;
} else {
ID_TYPE(id) = tp;
}
/* set external id for functionType's type ID.
* dont call declare_external_id() */
extid = new_external_id_for_external_decl(ID_SYM(id), tp);
PROC_EXT_ID(id) = extid;
if(TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, FUNCTION_TYPE_RETURN_TYPE(tp), symV, args);
}
if (ret == NULL && !ignoreTypeMismatch) {
error_at_node((expr)args,
"argument(s) mismatch for an intrinsic '%s()'.",
iName);
}
return ret;
}