object *quotient_proc(object *arguments) {
return make_fixnum(
((car(arguments) )->data.fixnum.value)/
((cadr(arguments))->data.fixnum.value));
}
object *text_of_quotation(object *exp) {
return cadr(exp);
}
object *definition_variable(object *exp) {
return is_symbol(cadr(exp)) ? cadr(exp) : caadr(exp);
}
object *if_predicate(object *exp) {
return cadr(exp);
}
object *binding_argument(object *binding) {
return cadr(binding);
}
/*
* local pprinting function
*
* Do not try to understand how it works. When I wrote it I and God knew how
* it worked. I have forgotten...
* Ask God!
*
* p is the expression is to print.
* k is magic argument to handle non-algorithmic behaviour of pprint.
* (k holds internal beautiness (!) factor of printout. (AI!) :-)
* Serious:
* k=1 we dunno anything about expression
* k=1 the tabulatig spaces were alrady printed!
* k=2 we are in flatc mode
* -dont print tabulating space
* -there is no need to check flatc size.
*/
static LVAL __pprint(tpLspObject pLSP,LVAL p,int k)
#define _pprint(x) __pprint(pLSP,(x),1)
{
LVAL fp;
int j,multiline;
char *s;
if( null(p) )
{
fprintf(pLSP->f,"NIL");
return NIL;
}
switch(gettype(p))
{
case NTYPE_CON:
if( k == 2 || flatc(p) < SCRSIZE-TABPOS )
{
/* Print in flat mode. */
if( k == 1 )
fprintf(pLSP->f,"%*s(",TABPOS,"");
else
fprintf(pLSP->f,"(");
for( fp = p ; fp ; )
{
__pprint(pLSP,car(fp),2);
fp = cdr(fp);
if( fp )
fprintf(pLSP->f," ");
}
fprintf(pLSP->f,")");
return NIL;
}
if( atom(fp=car(p)) || flatc(fp) < (SCRSIZE-TABPOS)/2 )
{
fprintf(pLSP->f,"(");
SCRSIZE--; /* Schrink screen size thinking of the closing paren. */
j = flatc(fp)+2;/* ([flatc]SPACE */
TABPOS += j;
__pprint(pLSP,fp,0);
if( cdr(p) )
{
fprintf(pLSP->f," ");
__pprint(pLSP,cadr(p),0);
fprintf(pLSP->f,"\n");
for( fp = cdr(cdr(p)) ; fp ; )
{
fprintf(pLSP->f,"%*s",TABPOS,"");
__pprint(pLSP,car(fp),0);
fp = cdr(fp);
if( fp )
fprintf(pLSP->f,"\n");
}
}
TABPOS -= j;
fprintf(pLSP->f,")");
SCRSIZE++;
return NIL;
}
fprintf(pLSP->f,"(");
/* Schrink screen size thinking of the closing paren. */
SCRSIZE--;
TABPOS++;
__pprint(pLSP,car(p),0);
if( fp = cdr(p) )
fprintf(pLSP->f,"\n");
while( fp )
{
fprintf(pLSP->f,"%*s",TABPOS,"");
_pprint(car(fp));
fp = cdr(fp);
if( fp )
fprintf(pLSP->f,"\n");
}
TABPOS--;
fprintf(pLSP->f,")");
SCRSIZE++;
return NIL;
case NTYPE_FLO:
fprintf(pLSP->f,"%lf",getfloat(p));
return NIL;
case NTYPE_INT:
fprintf(pLSP->f,"%ld",getint(p));
return NIL;
case NTYPE_STR:
multiline = 0;
for( s=getstring(p) ; *s ; s++ )
if( *s == '\n' ){
multiline = 1;
break;
}
fprintf(pLSP->f,multiline ? "\"\"\"" : "\"");
for( s=getstring(p) ; *s ; s++ )
switch( *s )
{ /* Handle spacial characters. */
case '\"':
fprintf(pLSP->f,"\\\"");
break;
default:
fprintf(pLSP->f,"%c",*s);
break;
}
fprintf(pLSP->f,multiline ? "\"\"\"" : "\"");
return NIL;
case NTYPE_SYM:
fprintf(pLSP->f,"%s",getsymbol(p));
return NIL;
case NTYPE_CHR:
fprintf(pLSP->f,"#\\%c",getchr(p));
return NIL;
default:
return NIL;
}
fprintf(pLSP->f,BUFFER);
return NIL;
}
refObject skolemize(refObject layer, refObject type)
{ struct
{ refFrame link;
int count;
refObject first;
refObject labeler;
refObject last;
refObject layer;
refObject next;
refObject type; } f0;
// IS SKOLEMIZABLE. Test if TYPE, which is ground in LAYER, can be the base of
// a Skolem type. It can be, if it has a subtype that's different from itself.
// For example, OBJ has an infinite number of such subtypes but INT0 has none.
// The WHILE loop helps simulate tail recursions.
bool isSkolemizable(refObject layer, refObject type)
{ while (true)
{ if (isName(type))
{ getKey(r(layer), r(type), layer, type); }
else
// Visit a type. If LABELER says we've been here before, then return false. If
// we haven't, then record TYPE in LABELER so we won't come here again.
if (isPair(type))
{ if (gotKey(toss, toss, f0.labeler, type))
{ return false; }
else
{ refObject pars;
setKey(f0.labeler, type, nil, nil);
switch (toHook(car(type)))
// Visit a trivially Skolemizable type. An ALTS, FORM, or GEN type can have an
// ALTS type as a subtype. A REF or ROW type can have NULL as a subtype.
{ case altsHook:
case arraysHook:
case formHook:
case genHook:
case jokerHook:
case referHook:
case rowHook:
case skoHook:
case tuplesHook:
{ return true; }
// Visit a type that is trivially not Skolemizable.
case cellHook:
case char0Hook:
case char1Hook:
case int0Hook:
case int1Hook:
case int2Hook:
case listHook:
case nullHook:
case real0Hook:
case real1Hook:
case strTypeHook:
case symHook:
case voidHook:
{ return false; }
// Visit an ARRAY type. It's Skolemizable if its base type is.
case arrayHook:
{ type = caddr(type);
break; }
// Visit a PROC type. It's Skolemizable if (1) it has a Skolemizable parameter
// type, (2) it has the missing name NO NAME as a parameter name, (3) it has a
// Skolemizable yield type.
case procHook:
{ type = cdr(type);
pars = car(type);
while (pars != nil)
{ pars = cdr(pars);
if (car(pars) == noName)
{ return true; }
else
{ pars = cdr(pars); }}
pars = car(type);
while (pars != nil)
{ if (isSkolemizable(layer, car(pars)))
{ return true; }
else
{ pars = cddr(pars); }}
type = cadr(type);
break; }
// Visit a TUPLE type. It's Skolemizable if it has a Skolemizable slot type or
// if it has the missing name NO NAME as a slot name.
case tupleHook:
{ pars = cdr(type);
while (pars != nil)
{ pars = cdr(pars);
if (car(pars) == noName)
{ return true; }
else
{ pars = cdr(pars); }}
pars = cdr(type);
while (pars != nil)
{ if (isSkolemizable(layer, car(pars)))
{ return true; }
else
{ pars = cddr(pars); }}
return false; }
// Visit a prefix type. It's Skolemizable if its base type is.
case typeHook:
case varHook:
{ type = cadr(type);
break; }
// Visit an illegal type. We should never get here.
default:
{ fail("Got ?%s(...) in isSkolemizable!", hookTo(car(type))); }}}}
// Visit an illegal object. We should never get here either.
else
{ fail("Got bad type in isSkolemizable!"); }}}
// Lost? This is SKOLEMIZE's body. These identities show what's going on.
//
// S(type T B) => T S(B)
// S(U) => ?sko(U)
// S(V) => V
//
// Here S(X) is the Skolem type for type X. T is a series of zero or more TYPE
// prefixes. B is a type, U is a type with at least one subtype different from
// itself, and V is a type with no subtypes different from itself.
push(f0, 6);
f0.labeler = pushLayer(nil, plainInfo);
f0.layer = layer;
f0.type = type;
while (isName(f0.type))
{ getKey(r(f0.layer), r(f0.type), f0.layer, f0.type); }
if (isCar(f0.type, typeHook))
{ f0.type = cadr(f0.type);
if (isSkolemizable(f0.layer, f0.type))
{ if (isCar(f0.type, typeHook))
{ f0.first = f0.last = makePair(hooks[typeHook], nil);
f0.type = cadr(f0.type);
while (isCar(f0.type, typeHook))
{ f0.next = makePair(hooks[typeHook], nil);
cdr(f0.last) = makePair(f0.next, nil);
f0.last = f0.next;
f0.type = cadr(f0.type); }
f0.next = makePrefix(skoHook, f0.type);
cdr(f0.last) = makePair(f0.next, nil); }
else
{ f0.first = makePrefix(skoHook, f0.type); }}
else
{ f0.first = makePair(car(f0.type), cdr(f0.type)); }}
else
{ fail("Type type expected in skolemize!"); }
pop();
destroyLayer(f0.labeler);
return f0.first; }
// (bye 'cnt|NIL)
any doBye(any ex) {
any x = EVAL(cadr(ex));
bye(isNil(x)? 0 : xCnt(ex,x));
}
// (de sym . any) -> sym
any doDe(any ex) {
redefine(ex, cadr(ex), cddr(ex));
return cadr(ex);
}
object *set_cdr_proc(object *arguments) {
set_cdr(car(arguments), cadr(arguments));
return ok_symbol();
}
sExpression *eval(sExpression *exp, sEnvironment *env){
/* ------------------atom-----------------------*/
/* 1, 10, false, null, "abc" */
if(isSelfEval(exp))
{
return exp;
}
/* a symbol */
else if(isVariable(exp, env))
{
return lookupVariable(toSymb(exp), env);
}
/* ------------------list-----------------------*/
/* (quote blur blur) */
else if(isQuoted(exp))
{
return textOfQuoted(exp);
}
/* (set! name value) */
else if(isAssignment(exp))
{
return evalAssignment(exp, env);
}
/* (define name value) */
else if(isDefinition(exp))
{
return evalDefine(exp, env);
}
/* (define-syntax name ...) */
else if(isDefinitionSyntax(exp))
{
return evalDefineSyntax(exp, env);
}
/* (if blur blur blur) */
else if(isIf(exp))
{
return evalIf(toList(exp), env);
}
/* (lambda (args) (body)) */
else if(isLambdaConst(exp))
{
sList *body;
sList *param = toList( cadr(toList(exp)));
sExpression *temp = cdr(toList( cdr(toList(exp))));
if(isList(temp)){
body = toList(temp);
}else{
body = toList(cons(temp, &sNull));
}
return newLambda(param, body, env);
}
/* (syntax blur blur) syntax rule */
else if(isSymbol(car(toList(exp))) && isSyntaxRule(eval(car(toList(exp)), env)))
{
sExpression *exp2 = evalSyntaxRule(toSyntax(eval(car(toList(exp)), env)), exp);
return eval(exp2, env);
}
/* the other list (x . y) */
else if(isApplication(exp))
{
if(LAZY_EVAL){
sExpression *proexp = actualValue(operator(toList(exp)), env);
if(isLambdaType(proexp) || isPrimitiveProc(proexp)){
sExpression *operand = operands(toList(exp));
return applyLazly(proexp, operand, env);
}
}else{
sExpression *proexp = eval(operator(toList(exp)), env);
if(isLambdaType(proexp) || isPrimitiveProc(proexp)){
sExpression *operand = operands(toList(exp));
sExpression *arguments = listOfValues(operand, env);
return apply(proexp, arguments, env);
}
}
}
return &sError;
}
object *cons_proc(object *arguments) {
return cons(car(arguments), cadr(arguments));
}
/*
* (call <tag_ffi_cif>
* <closure w/C function pointer>
* <rvalue size in bytes>
* )
*/
cons_t* proc_ffi_call(cons_t* p, environment_t*)
{
assert_length(p, 2, 4);
assert_pointer(tag_ffi_cif, car(p));
assert_type(CLOSURE, cadr(p));
assert_type(INTEGER, caddr(p));
/*
* libffi description of function.
*/
ffi_cif *cif = static_cast<ffi_cif*>(car(p)->pointer->value);
/*
* Pointer to function to call.
*/
if ( cadr(p)->closure->function == NULL )
raise(runtime_exception(
"Can only call foreign C functions; not Scheme procedures"));
void (*funptr)() =
reinterpret_cast<void(*)()>(cadr(p)->closure->function);
/*
* Size of return value.
*/
integer_t size = 0;
if ( length(p)>2 )
size = caddr(p)->number.integer;
if ( size < 0 )
raise(runtime_exception(format(
"Cannot allocate a negative number of bytes: %d", size)));
/*
* Allocate enough memory necessary to hold return data.
*/
value_t *retval = new value_t(size);
/*
* Function arguments (currently unsupported).
*/
void **funargs = NULL;
if ( !nullp(cadddr(p)) ) {
cons_t *args = cadddr(p);
if ( length(args) != cif->nargs )
raise(runtime_exception(format(
"Foreign function expects %d arguments",
cif->nargs)));
funargs = static_cast<void**>(malloc(sizeof(void*)*(cif->nargs+1)));
size_t n=0;
for ( cons_t *a = args; !nullp(a); a = cdr(a), ++n ) {
funargs[n] = make_arg(cif->arg_types[n], car(a));
}
funargs[cif->nargs] = NULL; // TODO: is this necessary?
}
/*
* TODO: Destroy allocated funargs data after ffi_call, unless those are
* pointer values used to store returned data.
*/
ffi_call(cif, funptr, &retval->data, funargs);
return pointer(tag_ffi_retval, retval);
}
object *remainder_proc(object *arguments) {
return make_fixnum(
((car(arguments) )->data.fixnum.value)%
((cadr(arguments))->data.fixnum.value));
}
PUBLIC tree lib_call(def d, tree args)
{
int n_args = list_len(args);
tree call = NULL;
bool ok = TRUE;
type t = d->t_type;
switch (d->d_libid) {
case L_CHR:
ok = (n_args == 1
&& same_type(car(args)->t_type, int_type));
break;
case L_ORD:
ok = (n_args == 1
&& (same_type(car(args)->t_type, char_type)
|| same_type(car(args)->t_type, bool_type)));
break;
case L_HALT:
case L_FLUSH:
ok = (n_args == 0);
break;
case L_EOF:
case L_EOLN:
if (n_args == 0)
args = list1((tree) _input_);
else
ok = (n_args = 1
&& same_type(car(args)->t_type, text_type));
break;
case L_READ:
case L_READLN:
case L_WRITE:
case L_WRITELN:
{
tree p = args;
if (p != nil && same_type(car(p)->t_type, text_type))
p = cdr(p);
for (; p != nil; p = cdr(p)) {
type at = car(p)->t_type;
if (! (same_type(at, int_type)
|| same_type(at, char_type)
|| same_type(at, string_type))) {
ok = FALSE;
break;
}
}
return node_t(LIBCALL, (tree) d, args, void_type);
}
case L_ARGC:
ok = (n_args == 0);
break;
case L_ARGV:
ok = (n_args == 2
&& same_type(car(args)->t_type, int_type)
&& is_string_type(cadr(args)->t_type));
break;
case L_OPENIN:
ok = (n_args == 2
&& same_type(car(args)->t_type, text_type)
&& is_string_type(cadr(args)->t_type));
break;
case L_CLOSEIN:
ok = (n_args == 1 && same_type(car(args)->t_type, text_type));
break;
default:
ok = FALSE;
t = err_type;
}
if (! ok) {
error("I choked on a library call");
return (tree) dummy_def;
}
if (call == NULL)
return node_t(CALL, (tree) d, args, t);
return call;
}
// (lit 'any) -> any
any doLit(any x) {
x = cadr(x);
if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x)))
return x;
return cons(Quote, x);
}
/* An explicit control evaluator, taken almost directly from SICP, section
* 5.2. list is a flat list of expressions to evaluate. where is a label to
* begin at. Return value depends on where.
*/
NODE *evaluator(NODE *list, enum labels where) {
/* registers */
NODE *exp = NIL, /* the current expression */
*val = NIL, /* the value of the last expression */
*proc = NIL, /* the procedure definition */
*argl = NIL, /* evaluated argument list */
*unev = NIL, /* list of unevaluated expressions */
*stack = NIL, /* register stack */
*parm = NIL, /* the current formal */
*catch_tag = NIL,
*arg = NIL; /* the current actual */
/* registers that don't get reference counted, so we pretend they're ints */
FIXNUM vsp = 0, /* temp ptr into var_stack */
cont = 0, /* where to go next */
formals = (FIXNUM)NIL; /* list of formal parameters */
int i, nargs;
BOOLEAN tracing; /* are we tracing the current procedure? */
FIXNUM oldtailcall; /* in case of reentrant use of evaluator */
FIXNUM repcount; /* count for repeat */
FIXNUM old_ift_iff;
oldtailcall = tailcall;
old_ift_iff = ift_iff_flag;
save2(var,this_line);
assign(var, var_stack);
save2(fun,ufun);
cont = (FIXNUM)all_done;
numsave((FIXNUM)cont);
newcont(where);
goto fetch_cont;
begin_line:
ref(list);
assign(this_line, list);
newcont(end_line);
begin_seq:
make_tree(list);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
goto eval_sequence;
end_line:
if (val != UNBOUND) {
if (NOT_THROWING) err_logo(DK_WHAT, val);
deref(val);
}
val = NIL;
deref(list);
goto fetch_cont;
/* ----------------- EVAL ---------------------------------- */
tail_eval_dispatch:
tailcall = 1;
eval_dispatch:
switch (nodetype(exp)) {
case QUOTE: /* quoted literal */
assign(val, node__quote(exp));
goto fetch_cont;
case COLON: /* variable */
assign(val, valnode__colon(exp));
while (val == UNBOUND && NOT_THROWING)
assign(val, err_logo(NO_VALUE, node__colon(exp)));
goto fetch_cont;
case CONS: /* procedure application */
if (tailcall == 1 && is_macro(car(exp)) &&
is_list(procnode__caseobj(car(exp)))) {
/* tail call to user-defined macro must be treated as non-tail
* because the expression returned by the macro
* remains to be evaluated in the caller's context */
assign(unev, NIL);
goto non_tail_eval;
}
assign(fun, car(exp));
if (cdr(exp) != NIL)
goto ev_application;
else
goto ev_no_args;
default:
assign(val, exp); /* self-evaluating */
goto fetch_cont;
}
ev_no_args:
/* Evaluate an application of a procedure with no arguments. */
assign(argl, NIL);
goto apply_dispatch; /* apply the procedure */
ev_application:
/* Evaluate an application of a procedure with arguments. */
assign(unev, cdr(exp));
assign(argl, NIL);
mixsave(tailcall,var);
num2save(val_status,ift_iff_flag);
save2(didnt_get_output,didnt_output_name);
eval_arg_loop:
if (unev == NIL) goto eval_args_done;
assign(exp, car(unev));
if (exp == Not_Enough_Node) {
if (NOT_THROWING)
err_logo(NOT_ENOUGH, NIL);
goto eval_args_done;
}
save(argl);
save2(unev,fun);
save2(ufun,last_ufun);
save2(this_line,last_line);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
assign(didnt_get_output,
cons_list(0,fun,ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
newcont(accumulate_arg);
goto eval_dispatch; /* evaluate the current argument */
accumulate_arg:
/* Put the evaluated argument into the argl list. */
reset_args(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
assign(last_call, fun);
restore2(unev,fun);
restore(argl);
while (NOT_THROWING && val == UNBOUND) {
assign(val, err_logo(DIDNT_OUTPUT, NIL));
}
push(val, argl);
pop(unev);
goto eval_arg_loop;
eval_args_done:
restore2(didnt_get_output,didnt_output_name);
num2restore(val_status,ift_iff_flag);
mixrestore(tailcall,var);
if (stopping_flag == THROWING) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(argl, reverse(argl));
/* --------------------- APPLY ---------------------------- */
apply_dispatch:
/* Load in the procedure's definition and decide whether it's a compound
* procedure or a primitive procedure.
*/
proc = procnode__caseobj(fun);
if (is_macro(fun)) {
num2save(val_status,tailcall);
val_status = 1;
newcont(macro_return);
}
if (proc == UNDEFINED) {
if (ufun != NIL) {
untreeify_proc(ufun);
}
if (NOT_THROWING)
assign(val, err_logo(DK_HOW, fun));
else
assign(val, UNBOUND);
goto fetch_cont;
}
if (is_list(proc)) goto compound_apply;
/* primitive_apply */
if (NOT_THROWING)
assign(val, (*getprimfun(proc))(argl));
else
assign(val, UNBOUND);
#define do_case(x) case x: goto x;
fetch_cont:
{
enum labels x = (enum labels)cont;
cont = (FIXNUM)car(stack);
numpop(&stack);
switch (x) {
do_list(do_case)
default: abort();
}
}
compound_apply:
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
for (i = 0; i < trace_level; i++) print_space(writestream);
trace_level++;
ndprintf(writestream, "( %s ", fun);
}
/* Bind the actuals to the formals */
vsp = (FIXNUM)var_stack; /* remember where we came in */
for (formals = (FIXNUM)formals__procnode(proc);
formals != (FIXNUM)NIL;
formals = (FIXNUM)cdr((NODE *)formals)) {
parm = car((NODE *)formals);
if (nodetype(parm) == INT) break; /* default # args */
if (argl != NIL) {
arg = car(argl);
if (tracing) {
print_node(writestream, maybe_quote(arg));
print_space(writestream);
}
} else
arg = UNBOUND;
if (nodetype(parm) == CASEOBJ) {
if (not_local(parm,(NODE *)vsp)) {
push(parm, var_stack);
setobject(var_stack, valnode__caseobj(parm));
}
tell_shadow(parm);
setvalnode__caseobj(parm, arg);
} else if (nodetype(parm) == CONS) {
/* parm is optional or rest */
if (not_local(car(parm),(NODE *)vsp)) {
push(car(parm), var_stack);
setobject(var_stack, valnode__caseobj(car(parm)));
}
tell_shadow(car(parm));
if (cdr(parm) == NIL) { /* parm is rest */
setvalnode__caseobj(car(parm), argl);
break;
}
if (arg == UNBOUND) { /* use default */
save2(fun,var);
save2(ufun,last_ufun);
save2(this_line,last_line);
save2(didnt_output_name,didnt_get_output);
num2save(ift_iff_flag,val_status);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
mixsave(formals,argl);
numsave(vsp);
assign(list, cdr(parm));
if (NOT_THROWING)
make_tree(list);
else
assign(list, NIL);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto set_args_continue;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
newcont(set_args_continue);
goto eval_sequence;
set_args_continue:
numrestore(vsp);
mixrestore(formals,argl);
parm = car((NODE *)formals);
reset_args(var);
num2restore(ift_iff_flag,val_status);
restore2(didnt_output_name,didnt_get_output);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
restore2(fun,var);
arg = val;
}
setvalnode__caseobj(car(parm), arg);
}
if (argl != NIL) pop(argl);
}
if (check_throwing) {
assign(val, UNBOUND);
goto fetch_cont;
}
vsp = 0;
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
if (NOT_THROWING) print_char(writestream, ')');
new_line(writestream);
save(fun);
newcont(compound_apply_continue);
}
assign(val, UNBOUND);
assign(last_ufun, ufun);
assign(ufun, fun);
assign(last_line, this_line);
assign(this_line, NIL);
proc = procnode__caseobj(fun);
assign(list, bodylist__procnode(proc)); /* get the body ... */
make_tree_from_body(list);
if (!is_tree(list)) {
goto fetch_cont;
}
assign(unev, tree__tree(list));
if (NOT_THROWING) stopping_flag = RUN;
assign(output_node, UNBOUND);
if (val_status == 1) val_status = 2;
else if (val_status == 5) val_status = 3;
else val_status = 0;
eval_sequence:
/* Evaluate each expression in the sequence. Stop as soon as
* val != UNBOUND.
*/
if (!RUNNING || val != UNBOUND) {
goto fetch_cont;
}
if (nodetype(unev) == LINE) {
assign(this_line, unparsed__line(unev));
if (flag__caseobj(ufun, PROC_STEPPED)) {
char junk[20];
if (tracing) {
int i = 1;
while (i++ < trace_level) print_space(stdout);
}
print_node(stdout, this_line);
ndprintf(stdout, " >>> ");
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef __ZTC__
ztc_getcr();
#else
fgets(junk, 19, stdin);
#endif
input_blocking = 0;
update_coords('\n');
}
}
assign(exp, car(unev));
pop(unev);
if (is_list(exp) && (is_tailform(procnode__caseobj(car(exp))))) {
if (nameis(car(exp),Output) || nameis(car(exp),Op)) {
assign(didnt_get_output,
cons_list(0,car(exp),ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
if (val_status == 2 || val_status == 3) {
val_status = 1;
assign(exp, cadr(exp));
goto tail_eval_dispatch;
} else if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
val_status = 1;
assign(exp, cadr(exp));
assign(unev, NIL);
goto non_tail_eval; /* compute value then give error */
}
} else if (nameis(car(exp),Stop)) {
if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status == 0 || val_status == 3) {
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
assign(val, UNBOUND);
goto fetch_cont;
}
} else { /* maybeoutput */
assign(exp, cadr(exp));
val_status = 5;
goto tail_eval_dispatch;
}
}
if (unev == NIL) {
if (val_status == 2 || val_status == 4) {
assign(didnt_output_name, fun);
assign(unev, UNBOUND);
goto non_tail_eval;
} else {
goto tail_eval_dispatch;
}
}
if (is_list(car(unev)) && nameis(car(car(unev)),Stop)) {
if ((val_status == 0 || val_status == 3) && ufun != NIL) {
goto tail_eval_dispatch;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
goto tail_eval_dispatch;
}
}
non_tail_eval:
save2(unev,fun);
num2save(ift_iff_flag,val_status);
save2(ufun,last_ufun);
save2(this_line,last_line);
save(var);
assign(var, var_stack);
tailcall = 0;
newcont(eval_sequence_continue);
goto eval_dispatch;
eval_sequence_continue:
reset_args(var);
restore(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
if (dont_fix_ift) {
num2restore(dont_fix_ift,val_status);
dont_fix_ift = 0;
} else
num2restore(ift_iff_flag,val_status);
restore2(unev,fun);
if (stopping_flag == MACRO_RETURN) {
if (unev == UNBOUND) assign(unev, NIL);
assign(unev, append(val, unev));
assign(val, UNBOUND);
stopping_flag = RUN;
if (unev == NIL) goto fetch_cont;
} else if (val_status < 4) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2 && NOT_THROWING) {
assign(didnt_output_name,Output);
err_logo(DIDNT_OUTPUT,Output);
}
if (val == UNBOUND && val_status == 1 && NOT_THROWING) {
assign(didnt_output_name,Stop);
err_logo(DIDNT_OUTPUT,Output);
}
goto fetch_cont;
}
}
if (val != UNBOUND) {
err_logo((unev == NIL ? DK_WHAT_UP : DK_WHAT), val);
assign(val, UNBOUND);
}
if (NOT_THROWING && (unev == NIL || unev == UNBOUND)) {
if (val_status != 4) err_logo(DIDNT_OUTPUT,NIL);
goto fetch_cont;
}
goto eval_sequence;
compound_apply_continue:
/* Only get here if tracing */
restore(fun);
--trace_level;
if (NOT_THROWING) {
for (i = 0; i < trace_level; i++) print_space(writestream);
print_node(writestream, fun);
if (val == UNBOUND)
ndprintf(writestream, " stops\n");
else {
ref(val);
ndprintf(writestream, " outputs %s\n", maybe_quote(val));
deref(val);
}
}
goto fetch_cont;
/* --------------------- MACROS ---------------------------- */
macro_return:
num2restore(val_status,tailcall);
while (!is_list(val) && NOT_THROWING) {
assign(val,err_logo(ERR_MACRO,val));
}
if (NOT_THROWING) {
if (is_cont(val)) {
newcont(cont__cont(val));
val->n_car = NIL;
assign(val, val__cont(val));
goto fetch_cont;
}
macro_reval:
if (tailcall == 0) {
make_tree(val);
stopping_flag = MACRO_RETURN;
if (!is_tree(val)) assign(val, NIL);
else assign(val, tree__tree(val));
goto fetch_cont;
}
assign(list,val);
goto begin_seq;
}
assign(val, UNBOUND);
goto fetch_cont;
runresult_continuation:
assign(list, val);
newcont(runresult_followup);
val_status = 5;
goto begin_seq;
runresult_followup:
if (val == UNBOUND) {
assign(val, NIL);
} else {
assign(val, cons(val, NIL));
}
goto fetch_cont;
repeat_continuation:
assign(list, cdr(val));
repcount = getint(car(val));
repeat_again:
assign(val, UNBOUND);
if (repcount == 0) goto fetch_cont;
mixsave(repcount,list);
num2save(val_status,tailcall);
val_status = 4;
newcont(repeat_followup);
goto begin_seq;
repeat_followup:
if (val != UNBOUND && NOT_THROWING) {
ref(val);
err_logo(DK_WHAT, val);
unref(val);
}
num2restore(val_status,tailcall);
mixrestore(repcount,list);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
goto fetch_cont;
}
}
if (repcount > 0) /* negative means forever */
--repcount;
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (RUNNING) goto repeat_again;
assign(val, UNBOUND);
goto fetch_cont;
catch_continuation:
assign(list, cdr(val));
assign(catch_tag, car(val));
if (compare_node(catch_tag,Error,TRUE) == 0) {
push(Erract, var_stack);
setobject(var_stack, valnode__caseobj(Erract));
setvalnode__caseobj(Erract, UNBOUND);
}
save(catch_tag);
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(catch_followup);
val_status = 5;
goto begin_seq;
catch_followup:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
restore(catch_tag);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
if (stopping_flag == THROWING &&
compare_node(throw_node, catch_tag, TRUE) == 0) {
throw_node = reref(throw_node, UNBOUND);
stopping_flag = RUN;
assign(val, output_node);
}
goto fetch_cont;
begin_apply:
/* This is for lapply. */
assign(fun, car(val));
while (nodetype(fun) == ARRAY && NOT_THROWING)
assign(fun, err_logo(APPLY_BAD_DATA, fun));
assign(argl, cadr(val));
assign(val, UNBOUND);
while (!is_list(argl) && NOT_THROWING)
assign(argl, err_logo(APPLY_BAD_DATA, argl));
if (NOT_THROWING && fun != NIL) {
if (is_list(fun)) { /* template */
if (is_list(car(fun)) && cdr(fun) != NIL) {
/* lambda form */
formals = (FIXNUM)car(fun);
numsave(tailcall);
tailcall = 0;
llocal((NODE *)formals); /* bind the formals locally */
numrestore(tailcall);
for ( ;
formals && argl && NOT_THROWING;
formals = (FIXNUM)cdr((NODE *)formals),
assign(argl, cdr(argl)))
setvalnode__caseobj(car((NODE *)formals), car(argl));
assign(val, cdr(fun));
goto macro_reval;
} else { /* question-mark form */
save(qm_list);
assign(qm_list, argl);
assign(list, fun);
make_tree(list);
if (list == NIL || !is_tree(list)) {
goto qm_failed;
}
assign(unev, tree__tree(list));
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(qm_continue);
val_status = 5;
goto eval_sequence;
qm_continue:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
qm_failed:
restore(qm_list);
goto fetch_cont;
}
} else { /* name of procedure to apply */
int min, max, n;
NODE *arg;
assign(fun, intern(fun));
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, NULL); /* try ./<fun>.lg */
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, logolib); /* try <logolib>/<fun> */
proc = procnode__caseobj(fun);
while (proc == UNDEFINED && NOT_THROWING) {
assign(val, err_logo(DK_HOW_UNREC, fun));
}
if (NOT_THROWING) {
if (nodetype(proc) == CONS) {
min = getint(minargs__procnode(proc));
max = getint(maxargs__procnode(proc));
} else {
if (getprimdflt(proc) < 0) { /* special form */
err_logo(DK_HOW_UNREC, fun); /* can't apply */
goto fetch_cont;
} else {
min = getprimmin(proc);
max = getprimmax(proc);
}
}
for (n = 0, arg = argl; arg != NIL; n++, arg = cdr(arg));
if (n < min) {
err_logo(NOT_ENOUGH, NIL);
} else if (n > max && max >= 0) {
err_logo(TOO_MUCH, NIL);
} else {
goto apply_dispatch;
}
}
}
}
goto fetch_cont;
all_done:
tailcall = oldtailcall;
ift_iff_flag = old_ift_iff;
restore2(fun,ufun);
reset_args(var);
restore2(var,this_line);
deref(argl);deref(unev);deref(stack);deref(catch_tag);deref(exp);
return(val);
}
// (bool 'any) -> flg
any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;}
void
derivative_of_integral(void)
{
push(cadr(p1));
}
void
eval_nroots(void)
{
volatile int h, i, k, n;
push(cadr(p1));
eval();
push(caddr(p1));
eval();
p2 = pop();
if (p2 == symbol(NIL))
guess();
else
push(p2);
p2 = pop();
p1 = pop();
if (!ispoly(p1, p2))
stop("nroots: polynomial?");
// mark the stack
h = tos;
// get the coefficients
push(p1);
push(p2);
n = coeff();
if (n > YMAX)
stop("nroots: degree?");
// convert the coefficients to real and imaginary doubles
for (i = 0; i < n; i++) {
push(stack[h + i]);
real();
yyfloat();
eval();
p1 = pop();
push(stack[h + i]);
imag();
yyfloat();
eval();
p2 = pop();
if (!isdouble(p1) || !isdouble(p2))
stop("nroots: coefficients?");
c[i].r = p1->u.d;
c[i].i = p2->u.d;
}
// pop the coefficients
tos = h;
// n is the number of coefficients, n = deg(p) + 1
monic(n);
for (k = n; k > 1; k--) {
findroot(k);
if (fabs(a.r) < DELTA)
a.r = 0.0;
if (fabs(a.i) < DELTA)
a.i = 0.0;
push_double(a.r);
push_double(a.i);
push(imaginaryunit);
multiply();
add();
divpoly(k);
}
// now make n equal to the number of roots
n = tos - h;
if (n > 1) {
sort_stack(n);
p1 = alloc_tensor(n);
p1->u.tensor->ndim = 1;
p1->u.tensor->dim[0] = n;
for (i = 0; i < n; i++)
p1->u.tensor->elem[i] = stack[h + i];
tos = h;
push(p1);
}
}
refObject devar(refObject type)
{ if (isCar(type, varHook))
{ return cadr(type); }
else
{ return type; }}
void emitStatement(refObject term, set wraps)
// PRE EMIT. Write an open brace if needed.
{ void preEmit(int hook)
{ if (isInSet(hook, wraps))
{ writeChar(target, '{'); }}
// POST EMIT. Write a close brace if needed.
void postEmit(int hook)
{ if (isInSet(hook, wraps))
{ writeChar(target, '}'); }}
// Dispatch to an appropriate case based on TERM's outer hook.
if (isPair(term))
{ switch (toHook(car(term)))
// Write C code for a CASE clause.
{ case caseHook:
{ refObject subterm;
preEmit(caseHook);
term = cdr(term);
writeFormat(target, "switch");
writeChar(target, '(');
emitExpression(car(term), 13);
writeChar(target, ')');
writeChar(target, '{');
term = cdr(term);
while (cdr(term) != nil)
{ emitLabels(car(term));
term = cdr(term);
subterm = car(term);
if (isEffected(subterm))
{ emitStatement(subterm, withSet); }
writeFormat(target, "break");
writeChar(target, ';');
term = cdr(term); }
subterm = car(term);
if (isEffected(subterm))
{ writeFormat(target, "default");
writeChar(target, ':');
emitStatement(subterm, withSet); }
writeChar(target, '}');
postEmit(caseHook);
break; }
// Write C code for an IF clause.
case ifHook:
{ refObject subterm;
preEmit(ifHook);
term = cdr(term);
while (true)
{ writeFormat(target, "if");
writeChar(target, '(');
emitExpression(car(term), 13);
writeChar(target, ')');
term = cdr(term);
subterm = car(term);
if (isEffected(subterm))
{ emitStatement(subterm, ifLastWithSet); }
else
{ writeChar(target, ';'); }
term = cdr(term);
if (cdr(term) == nil)
{ subterm = car(term);
if (isEffected(subterm))
{ writeFormat(target, "else");
writeBlank(target);
if (isCar(subterm, ifHook))
{ term = cdr(subterm); }
else
{ emitStatement(subterm, lastWithSet);
break; }}
else
{ break; }}
else
{ writeFormat(target, "else");
writeBlank(target); }}
postEmit(ifHook);
break; }
// Write C code for a LAST clause.
case lastHook:
{ refObject subterm;
preEmit(lastHook);
term = cdr(term);
while (term != nil)
{ subterm = car(term);
if (isEffected(subterm))
{ emitStatement(subterm, withSet); }
term = cdr(term); }
postEmit(lastHook);
break; }
// Write C code for a WHILE clause.
case whileHook:
{ preEmit(whileHook);
term = cdr(term);
writeFormat(target, "while");
writeChar(target, '(');
emitExpression(car(term), 13);
writeChar(target, ')');
term = cadr(term);
if (isEffected(term))
{ emitStatement(term, lastWithSet); }
else
{ writeChar(target, ';'); }
postEmit(whileHook);
break; }
// Write C code for a WITH clause.
case withHook:
{ refObject frame;
preEmit(withHook);
term = cdr(term);
frame = car(term);
term = cdr(term);
if (frame == nil)
{ emitVariableDeclarations(term);
emitFunctionDefinitions(true, term);
emitVariableDefinitions(nil, term);
term = car(lastPair(term));
if (isEffected(term))
{ emitStatement(term, withSet); }}
else
{ emitFrameDeclaration(frame, term);
emitVariableDeclarations(term);
emitFunctionDefinitions(true, term);
emitFramePush(frame, frameLength(term));
emitFrameInitialization(frame, term);
emitVariableDefinitions(frame, term);
term = car(lastPair(term));
if (isEffected(term))
{ emitStatement(term, withSet); }
emitFramePop(frame); }
postEmit(withHook);
break; }
// Other TERMs become C expressions.
default:
{ if (isEffected(term))
{ emitExpression(term, 13);
writeChar(target, ';'); }
break; }}}
else
{ if (isEffected(term))
{ emitExpression(term, 13);
writeChar(target, ';'); }}}
object *let_bindings(object *exp) {
return cadr(exp);
}
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {
char comeback = 1;
while(comeback) {
comeback = 0;
if(is_self_evaluating(exp)) {
return exp;
}
if(list_begins_with(exp, quote_symbol)) {
return cadr(exp);
}
// (define... )
if(list_begins_with(exp, define_symbol)) {
object_t *var = cadr(exp);
// (define a b)
if(issymbol(var)) {
object_t *val = caddr(exp);
return define_var(env, var, val);
}
// (define (a ...) ...) TODO use scheme macro
if(ispair(var)) {
object_t *name = car(cadr(exp)),
*formals = cdr(cadr(exp)),
*body = cddr(exp),
*lambda = cons(lambda_symbol,
cons(formals, body));
exp = cons(define_symbol,
cons(name, cons(lambda, empty_list)));
comeback = 1;
continue;
}
fprintf(stderr, "Syntax error.\n");
exit(-1);
}
// (set! a b)
if(list_begins_with(exp, set_symbol)) {
object_t *var = cadr(exp);
object_t *val = caddr(exp);
return set_var(env, var, val);
}
// (if c a b)
if(list_begins_with(exp, if_symbol)) {
exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
comeback = 1;
continue;
}
// (cond ...)
if(list_begins_with(exp, cond_symbol)) {
object_t *tail = cons(void_symbol, empty_list);
object_t *ifs = tail; //empty_list;
object_t *rules = reverse_list(cdr(exp));
while(!isemptylist(rules)) {
object_t *rule = car(rules),
*condition = car(rule),
*consequence = cadr(rule);
if(isemptylist(consequence)) {
consequence = cons(void_obj, empty_list);
}
ifs = cons(if_symbol,
cons(condition,
cons(consequence,
cons(ifs, empty_list))));
rules = cdr(rules);
}
exp = ifs;
comeback = 1;
continue;
}
// (begin ...)
if(list_begins_with(exp, begin_symbol)) {
object_t *result = empty_list, *exps;
for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
result = eval(car(exps), env);
}
return result;
}
if(list_begins_with(exp, lambda_symbol)) {
object_t *fn = cons(begin_symbol,
cdr(cdr(exp)));
return make_compound_proc(empty_list, cadr(exp),
fn,
env);
}
// (let ...)
if(list_begins_with(exp, let_symbol)) {
//if(! issymbol(cadr(exp)))
object_t *bindings = cadr(exp);
object_t *body = cddr(exp);
object_t *formals = empty_list;
object_t *values = empty_list;
while(!isemptylist(bindings)) {
formals = cons(caar(bindings), formals);
values = cons(cadr(car(bindings)), values);
bindings = cdr(bindings);
}
exp = cons(cons(lambda_symbol, cons(formals, body)),
values);
comeback = 1;
continue;
}
if(issymbol(exp)) {
return var_get_value(env, exp);
}
if(ispair(exp)) {
object_t *exp_car = car(exp);
object_t *fn = eval(exp_car, env); //var_get_value(env, car);
if(!iscallable(fn)) {
fprintf(stderr, "object_t is not callable\n");
exit(-1);
}
object_t *args = cdr(exp);
object_t *evaluated_args = evaluate_list(env, args, empty_list);
if(isprimitiveproc(fn)) {
return fn->value.prim_proc.fn(evaluated_args);
} else if(iscompoundproc(fn)) {
object_t *fn_formals = fn->value.compound_proc.formals;
object_t *fn_body = fn->value.compound_proc.body;
object_t *fn_env = fn->value.compound_proc.env;
ARGS_EQ(evaluated_args, list_size(fn_formals));
exp = fn_body;
env = extend_environment(fn_formals, evaluated_args, fn_env);
comeback = 1;
continue;
}
assert(0);
}
}
fprintf(stderr, "Unable to evaluate expression: \n");
write(exp);
exit(-1);
}
object *eval_environment(object *arguments) {
return cadr(arguments);
}
static OBJ analyze_r(const struct analyze_t *arg)
{
OBJ op;
OBJ ret;
struct analyze_t new_arg;
new_arg = *arg;
ret = OBJ_NULL;
if (is_self_evaluating(new_arg.sexp))
ret = new_arg.sexp;
else if (is_variable(new_arg.sexp))
ret = analyze_variable_cell(new_arg.sexp,new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
else if(obj_pairp(new_arg.sexp))
{
if(obj_pairp(car(new_arg.sexp)))
{
new_arg.sexp = car(new_arg.sexp);
op = fake_eval(&new_arg);
new_arg = *arg;
}
else
op = analyze_variable_value(car(new_arg.sexp),new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
if(op == OBJ_NULL) /* error handle---fixme!! */
return OBJ_NULL;
if(obj_corep(op))
{
switch(obj_core_type(op))
{
case DEFINE:
case DEFINE_SYNTAX:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_define(&new_arg);
break;
case SET:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_set(&new_arg);
break;
case IF:
ret = analyze_if(cdr(new_arg.sexp),new_arg.env,new_arg.tail);
break;
case QUOTE:
ret = obj_make_quote(cadr(new_arg.sexp));
break;
case BEGIN:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_begin(&new_arg);
break;
case LAMBDA:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_lambda(&new_arg);
break;
case SYNTAX_RULES:
ret = analyze_syntax_rules(cdr(new_arg.sexp),new_arg.env);
break;
default:
fprintf(stderr,"unknown core tag\n");
}
}
else if(obj_syntaxp(op))
{
OBJ params;
OBJ data;
OBJ patten;
OBJ template;
int match;
match = 0;
data = obj_syntax_data(op);
while(obj_pairp(data))
{
patten = caar(data);
object *assignment_variable(object *exp) {
return cadr(exp);
}
void
yypower(void)
{
int n;
p2 = pop();
p1 = pop();
// both base and exponent are rational numbers?
if (isrational(p1) && isrational(p2)) {
push(p1);
push(p2);
qpow();
return;
}
// both base and exponent are either rational or double?
if (isnum(p1) && isnum(p2)) {
push(p1);
push(p2);
dpow();
return;
}
if (istensor(p1)) {
power_tensor();
return;
}
if (p1 == symbol(E) && car(p2) == symbol(LOG)) {
push(cadr(p2));
return;
}
if (p1 == symbol(E) && isdouble(p2)) {
push_double(exp(p2->u.d));
return;
}
// 1 ^ a -> 1
// a ^ 0 -> 1
if (equal(p1, one) || iszero(p2)) {
push(one);
return;
}
// a ^ 1 -> a
if (equal(p2, one)) {
push(p1);
return;
}
// (a * b) ^ c -> (a ^ c) * (b ^ c)
if (car(p1) == symbol(MULTIPLY)) {
p1 = cdr(p1);
push(car(p1));
push(p2);
power();
p1 = cdr(p1);
while (iscons(p1)) {
push(car(p1));
push(p2);
power();
multiply();
p1 = cdr(p1);
}
return;
}
// (a ^ b) ^ c -> a ^ (b * c)
if (car(p1) == symbol(POWER)) {
push(cadr(p1));
push(caddr(p1));
push(p2);
multiply();
power();
return;
}
// (a + b) ^ n -> (a + b) * (a + b) ...
if (expanding && isadd(p1) && isnum(p2)) {
push(p2);
n = pop_integer();
// this && n != 0x80000000 added by DDC
// as it's not always the case that 0x80000000
// is negative
if (n > 1 && n != 0x80000000) {
power_sum(n);
return;
}
}
// sin(x) ^ 2n -> (1 - cos(x) ^ 2) ^ n
if (trigmode == 1 && car(p1) == symbol(SIN) && iseveninteger(p2)) {
push_integer(1);
push(cadr(p1));
cosine();
push_integer(2);
power();
subtract();
push(p2);
push_rational(1, 2);
multiply();
power();
return;
}
// cos(x) ^ 2n -> (1 - sin(x) ^ 2) ^ n
if (trigmode == 2 && car(p1) == symbol(COS) && iseveninteger(p2)) {
push_integer(1);
push(cadr(p1));
sine();
push_integer(2);
power();
subtract();
push(p2);
push_rational(1, 2);
multiply();
power();
return;
}
// complex number? (just number, not expression)
if (iscomplexnumber(p1)) {
// integer power?
// n will be negative here, positive n already handled
if (isinteger(p2)) {
// / \ n
// -n | a - ib |
// (a + ib) = | -------- |
// | 2 2 |
// \ a + b /
push(p1);
conjugate();
p3 = pop();
push(p3);
push(p3);
push(p1);
multiply();
divide();
push(p2);
negate();
power();
return;
}
// noninteger or floating power?
if (isnum(p2)) {
#if 1 // use polar form
push(p1);
mag();
push(p2);
power();
push_integer(-1);
push(p1);
arg();
push(p2);
multiply();
push(symbol(PI));
divide();
power();
multiply();
#else // use exponential form
push(p1);
mag();
push(p2);
power();
push(symbol(E));
push(p1);
arg();
push(p2);
multiply();
push(imaginaryunit);
multiply();
power();
multiply();
#endif
return;
}
}
if (simplify_polar())
return;
push_symbol(POWER);
push(p1);
push(p2);
list(3);
}
object *definition_value(object *exp) {
return is_symbol(cadr(exp)) ? caddr(exp) : make_lambda(cdadr(exp), cddr(exp));
}
object *lambda_parameters(object *exp) {
return cadr(exp);
}