luke
/
magic
mirror of https://github.com/RTimothyEdwards/magic.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
magic/lisp/lispEval.c

651 lines
15 KiB
C
Raw Blame History

/*************************************************************************
*
* lispEval.c --
*
* This module contains the core of the mini-scheme interpreter.
*
* (c) 1996 California Institute of Technology
* Department of Computer Science
* Pasadena, CA 91125.
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for any purpose and without fee is hereby
* granted, provided that the above copyright notice appear in all
* copies. The California Institute of Technology makes no representations
* about the suitability of this software for any purpose. It is
* provided "as is" without express or implied warranty. Export of this
* software outside of the United States of America may require an
* export license.
*
* $Header$
*
*************************************************************************/
#include <stdio.h>
#include "lisp/lisp.h"
#include "lispInt.h"
#include "textio/textio.h"
#include "utils/malloc.h"
#include "lispA-Z.h"
#include "lispargs.h"
#include "utils/signals.h"
struct LispBuiltinFn {
char *name;
int id;
int lazy; /* != 0 if lazy */
LispObj *(*f) (); /* built-in */
};
static struct LispBuiltinFn FnTable[] = {
/*------------------------------------------------------------------------
* E a g e r F u n c t i o n s
*------------------------------------------------------------------------
*/
/* inspect arguments */
{ "boolean?", -1, 0, LispIsBool },
{ "symbol?", -1, 0, LispIsSym },
{ "list?", -1, 0, LispIsList },
{ "pair?", -1, 0, LispIsPair },
{ "number?", -1, 0, LispIsNumber },
{ "string?", -1, 0, LispIsString },
{ "procedure?", -1, 0, LispIsProc },
/* standard list manipulation */
{ "car", -1, 0, LispCar },
{ "cdr", -1, 0, LispCdr },
{ "cons", -1, 0, LispCons },
{ "set-car!", -1, 0, LispSetCarBang },
{ "set-cdr!", -1, 0, LispSetCdrBang },
{ "null?", -1, 0, LispNull },
{ "list", -1, 0, LispList },
{ "length", -1, 0, LispLength },
{ "eval", -1, 0, Lispeval },
{ "apply", -1, 0, Lispapply },
{ "eqv?", -1, 0, LispEqv },
/* math */
{ "+", -1, 0, LispAdd },
{ "*", -1, 0, LispMult },
{ "-", -1, 0, LispSub },
{ "/", -1, 0, LispDiv },
{ "truncate", -1, 0, LispTruncate },
/* comparison */
{ "zero?", -1, 0, LispZeroQ },
{ "positive?", -1, 0, LispPositiveQ },
{ "negative?", -1, 0, LispNegativeQ },
/* string manipulation */
{ "string-append", -1, 0, LispStrCat },
{ "symbol->string", -1, 0, LispSymbolToString },
{ "string->symbol", -1, 0, LispStringToSymbol },
{ "number->string", -1, 0, LispNumberToString },
{ "string->number", -1, 0, LispStringToNumber },
{ "string-length", -1, 0, LispStringLength },
{ "string-compare", -1, 0, LispStringCompare },
{ "string-ref", -1, 0, LispStringRef },
{ "string-set!", -1, 0, LispStringSet },
{ "substring", -1, 0, LispSubString },
/* file I/O and spawn/wait */
{ "load-scm", -1, 0, LispLoad },
{ "save-scm", -1, 0, LispWrite },
{ "spawn", -1, 0, LispSpawn },
{ "wait", -1, 0, LispWait },
/* utilities */
{ "collect-garbage", -1, 0, LispCollectGarbage },
/* debugging help */
{ "error", -1, 0, LispError },
{ "showframe", -1, 0, LispShowFrame },
{ "display-object", -1, 0, LispDisplayObj },
{ "print-object", -1, 0, LispPrintObj },
/* magic */
{ "getpoint", -1, 0, LispGetPoint },
{ "getbox", -1, 0, LispGetbox },
{ "getpaint", -1, 0, LispGetPaint },
{ "getselpaint", -1, 0, LispGetSelPaint },
{ "getlabel", -1, 0, LispGetLabel },
{ "getsellabel", -1, 0, LispGetSelLabel },
{ "getcellnames", -1, 0, LispGetCellNames },
{ "magic", -1, 1, LispEvalMagic }, /* lazy */
/*------------------------------------------------------------------------
* N o t - s o - e a g e r F u n c t i o n s
*------------------------------------------------------------------------
*/
/* lazy functions, don't evaluate any arguments */
{ "quote", -1, 1, LispQuote },
{ "lambda", -1, 1, LispLambda },
{ "let", -1, 1, LispLet },
{ "let*", -1, 1, LispLetStar },
{ "letrec", -1, 1, LispLetRec },
{ "cond", -1, 1, LispCond },
{ "begin", -1, 1, LispBegin },
/* define: evaluate only second argument */
{ "define", -1, 2, LispDefine },
{ "set!", -1, 2, LispSetBang },
/* if: evaluate only first argument */
{ "if", -1, 3, LispIf },
{ NULL, 0, 0, NULL }
};
static LispObj *evalList ();
/*------------------------------------------------------------------------
*
* LispFnInit --
*
* Initialize function table.
*
* Results:
* Returns result of evaluation.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
void
LispFnInit ()
{
int i;
for (i=0; FnTable[i].name; i++) {
(void) LispNewString (FnTable[i].name);
FnTable[i].id = LispStringId (FnTable[i].name);
}
}
/*-----------------------------------------------------------------------------
*
* ispair --
*
* Checks if its argument is a dotted-pair.
*
* Results:
* 1 if dotted-pair, zero otherwise.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
int
ispair (s)
Sexp *s;
{
while (s && LTYPE(CDR(s)) == S_LIST)
s = LLIST(CDR(s));
if (s)
return 1;
else
return 0;
}
/*------------------------------------------------------------------------
*
* lookup --
*
* Lookup a name in a frame.
*
* Results:
* Returns result of lookup.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
LispObj *
lookup (s,f)
char *s;
Sexp *f;
{
LispObj *l;
Sexp *f1;
int i, k;
/* keywords have precedence */
k = LispStringId (s);
for (i=0; FnTable[i].name; i++)
if (FnTable[i].id == k) {
l = LispNewObj ();
LTYPE(l) = S_LAMBDA_BUILTIN;
LBUILTIN(l) = i;
return l;
}
/* look in frame */
l = LispFrameLookup (s,f);
if (l) return l;
/* assume that it is a magic command */
l = LispNewObj ();
LTYPE(l) = S_MAGIC_BUILTIN;
LSYM(l) = s;
return l;
}
/*------------------------------------------------------------------------
*
* LispMagicSend --
*
* Send magic command to magic window.
*
* Results:
* Returns #t if magic command exists, #f otherwise.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
LispObj *
LispMagicSend (name,s,f)
char *name;
Sexp *s;
Sexp *f;
{
int trace;
LispObj *l;
int argc;
char *argv[TX_MAXARGS];
char argstring[TX_MAX_CMDLEN];
int k = 0;
int i, j;
argc = 1;
argv[0] = name;
while (s) {
l = CAR(s);
if (LTYPE(CDR(s)) != S_LIST) {
TxPrintf ("%s: invalid argument!\n",name);
RETURN;
}
s = LLIST(CDR(s));
switch (LTYPE(l)) {
case S_INT:
argv[argc] = argstring+k;
sprintf (argstring+k, "%d", LINTEGER(l));
k = k + strlen(argstring+k)+1;
break;
case S_FLOAT:
argv[argc] = argstring+k;
sprintf (argstring+k, "%lf", LFLOAT(l));
k = k + strlen(argstring+k)+1;
break;
case S_STRING:
/* undo one level of literal parsing . . . */
argv[argc] = LSTR(l);
i = 0; j = 0;
while (argv[argc][i]) {
if (argv[argc][i] == '\\')
i++;
argv[argc][j] = argv[argc][i];
i++; j++;
}
argv[argc][j] = '\0';
break;
case S_BOOL:
argv[argc] = argstring+k;
sprintf (argstring+k, "#%c", LINTEGER(l) ? 't' : 'f');
k = k + strlen(argstring+k)+1;
break;
case S_SYM:
argv[argc] = LSYM(l);
break;
case S_LAMBDA:
TxPrintf ("%s: Type #proc in magic command argument.\n",name);
RETURN;
break;
case S_LAMBDA_BUILTIN:
argv[argc] = FnTable[LBUILTIN(l)].name;
break;
case S_MAGIC_BUILTIN:
argv[argc] = LSYM(l);
break;
case S_LIST:
TxPrintf ("%s: Type #list in magic command argument.\n",name);
RETURN;
break;
default:
argc--;
break;
}
argc++;
}
l = LispFrameLookup (LispNewString ("scm-trace-magic"), f);
if (!l)
trace = 0;
else if (LTYPE(l) != S_BOOL) {
TxPrintf ("magic-dispatch: scm-trace-magic is not a boolean\n");
RETURN;
}
else
trace = LBOOL(l);
if (!TxLispDispatch (argc, argv, trace, lispInFile))
RETURN;
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 1;
return l;
}
/*-----------------------------------------------------------------------------
*
* LispApply --
*
* Evaluate a lambda.
* s = definition of the lambda
* l = list of arguments
* f = frame
*
* Results:
* None.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispApply (s,l,f)
Sexp *s;
Sexp *l;
Sexp *f;
{
int len;
int dp;
Sexp *t, *tp;
int number, anum;
Sexp *arglist;
Sexp *frame;
LispObj *eval;
number = LINTEGER(ARG1(s));
arglist = LLIST(ARG2(s));
dp = ispair (arglist);
frame = LLIST(ARG3(s));
eval = ARG4(s);
len=0;
tp = NULL;
t = l;
while (t && LTYPE(CDR(t)) == S_LIST) {
tp = t;
t = LLIST(CDR(t));
len++;
}
anum = (number < 0) ? -number : number;
if (len < anum) {
TxPrintf ("apply: mismatch in # of arguments. Expected %d, got %d\n",
anum, len);
RETURN;
}
t = arglist;
f = LispFramePush (frame);
while (t && LTYPE(CDR(t)) == S_LIST) {
LispAddBinding (CAR(t),LispCopyObj(CAR(l)),f);
t = LLIST(CDR(t));
l = LLIST(CDR(l));
}
if (t) {
LispAddBinding (CAR(t),LispCopyObj(CAR(l)),f);
LispAddBinding (CDR(t),LispCopyObj(CDR(l)),f);
}
eval = LispEval (eval, f);
return eval;
}
/*-----------------------------------------------------------------------------
*
* LispBuiltinApply --
*
* Apply a builtin function to a list
*
* Results:
* The results of the builtin function
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispBuiltinApply (num,s,f)
int num;
Sexp *s;
Sexp *f;
{
return FnTable[num].f(FnTable[num].name, s, f);
}
/*------------------------------------------------------------------------
*
* evalList --
*
* Evaluate list
*
* Results:
* Returns result of evaluation.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static
LispObj *
evalList (s,f)
Sexp *s;
Sexp *f;
{
LispObj *l;
Sexp *t;
if (!s) {
l = LispNewObj ();
LTYPE(l) = S_LIST;
LLIST(l) = NULL;
return l;
}
/* evaluate car field */
s = LispCopySexp (s);
LispGCAddSexp (s);
CAR(s) = LispEval (CAR(s),f);
LispGCRemoveSexp (s);
if (!CAR(s))
return NULL;
if (LTYPE(CAR(s)) != S_MAGIC_BUILTIN &&
LTYPE(CAR(s)) != S_LAMBDA_BUILTIN &&
LTYPE(CAR(s)) != S_LAMBDA) {
TxPrintf ("eval: First argument of list is not a procedure.\n");
TxPrintf ("\t");
if (CAR(s)) LispPrint (stdout, CAR(s));
else TxPrintf ("()");
TxPrintf ("\n");
RETURN;
}
/* evaluate rest of list, if the car field corresponds to a non-lazy
function.
*/
if (LTYPE(CAR(s)) == S_LAMBDA_BUILTIN) {
LispGCAddSexp (s);
if (FnTable[LBUILTIN(CAR(s))].lazy == 2) {
LispStackPush (FnTable[LBUILTIN(CAR(s))].name);
/* define: evaluate second argument only */
CDR(s) = LispCopyObj (CDR(s));
if (LTYPE(CDR(s)) != S_LIST || LLIST(CDR(s)) == NULL) {
TxPrintf ("define: argument error\n");
LispGCRemoveSexp (s);
RETURNPOP;
}
LLIST(CDR(s)) = LispCopySexp (LLIST(CDR(s)));
t = LLIST(CDR(s));
if (LTYPE(CDR(t)) != S_LIST || LLIST(CDR(t)) == NULL) {
TxPrintf ("define: argument error\n");
LispGCRemoveSexp (s);
RETURNPOP;
}
CDR(t) = LispCopyObj (CDR(t));
LLIST(CDR(t)) = LispCopySexp (LLIST(CDR(t)));
t = LLIST(CDR(t));
CAR(t) = LispEval (CAR(t),f);
LispStackPop ();
if (!CAR(t)) {
LispGCRemoveSexp (s);
return NULL;
}
}
else if (FnTable[LBUILTIN(CAR(s))].lazy == 3) {
/* if: evaluate first argument only */
LispStackPush (FnTable[LBUILTIN(CAR(s))].name);
CDR(s) = LispCopyObj (CDR(s));
if (LTYPE(CDR(s)) != S_LIST || LLIST(CDR(s)) == NULL) {
TxPrintf ("if: argument error\n");
LispGCRemoveSexp (s);
RETURNPOP;
}
LLIST(CDR(s)) = LispCopySexp (LLIST(CDR(s)));
t = LLIST(CDR(s));
CAR(t) = LispEval (CAR(t),f);
LispStackPop ();
if (!CAR(t)) {
LispGCRemoveSexp (s);
return NULL;
}
}
LispGCRemoveSexp (s);
}
if (!(LTYPE(CAR(s)) == S_LAMBDA_BUILTIN && FnTable[LBUILTIN(CAR(s))].lazy)) {
LispGCAddSexp (s);
if (LTYPE(CAR(s)) == S_LAMBDA_BUILTIN)
LispStackPush (FnTable[LBUILTIN(CAR(s))].name);
else if (LTYPE(CAR(s)) == S_MAGIC_BUILTIN)
LispStackPush (LSYM(CAR(s)));
else {
char *str;
str = LispFrameRevLookup (CAR(s),f);
LispStackPush (str ? str : "#proc-userdef");
}
t = s;
while (LTYPE(CDR(t)) == S_LIST && LLIST(CDR(t))) {
CDR(t) = LispCopyObj (CDR(t));
LLIST(CDR(t)) = LispCopySexp (LLIST(CDR(t)));
t = LLIST(CDR(t));
CAR(t) = LispEval (CAR(t),f);
if (CAR(t) == NULL) {
LispStackPop ();
LispGCRemoveSexp (s);
return NULL;
}
}
if (LTYPE(CDR(t)) != S_LIST) {
CDR(t) = LispEval (CDR(t),f);
if (CDR(t) == NULL) {
LispStackPop ();
LispGCRemoveSexp (s);
return NULL;
}
}
LispStackPop ();
LispGCRemoveSexp (s);
}
if (LTYPE(CDR(s)) != S_LIST) {
/* a dotted pair . . . */
l = LispNewObj ();
LTYPE(l) = S_LIST;
LLIST(l) = s;
return l;
}
/* dispatch function */
if (LTYPE(CAR(s)) == S_LAMBDA_BUILTIN) {
LispStackPush (FnTable[LBUILTIN(CAR(s))].name);
l = LispBuiltinApply (LBUILTIN(CAR(s)), LLIST(CDR(s)), f);
LispStackPop ();
}
else if (LTYPE(CAR(s)) == S_LAMBDA) {
char *str;
str = LispFrameRevLookup (CAR(s),f);
LispStackPush (str ? str : "#proc-userdef");
l = LispApply (LUSERDEF(CAR(s)), LLIST(CDR(s)),f);
LispStackPop ();
}
else {
LispStackPush (LSYM(CAR(s)));
l = LispMagicSend (LSYM(CAR(s)),LLIST(CDR(s)), f);
LispStackPop ();
}
return l;
}
/*------------------------------------------------------------------------
*
* LispEval --
*
* Evaluate object in a frame.
*
* Results:
* Returns result of evaluation.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
LispObj *
LispEval (l,f)
LispObj *l;
Sexp *f;
{
LispObj *ret;
if (SigInterruptPending) return NULL;
if (LTYPE(l) == S_LIST) {
LispGCAddSexp (f);
ret = evalList (LLIST(l),f);
LispGCRemoveSexp (f);
return ret;
}
else if (LTYPE(l) == S_SYM)
return lookup (LSYM(l),f);
else
return l;
}
Reference in New Issue View Git Blame Copy Permalink