/a++/appc/arsc.c
C | 1010 lines | 794 code | 135 blank | 81 comment | 138 complexity | 5793197592e74bc3cba4f053f50ee359 MD5 | raw file
- /***********************************************************************
- arsc.c - description
- ----------------------
- begin : Wed Apr 17 2001
- update : Sa Aug 06 2004
- copyright : (C) 2001 by Georg P. Loczewski
- email : gpl@lambda-bound.com
- **********************************************************************/
- /***********************************************************************
- * *
- * This program is free software; you can redistribute it and/or modify *
- * it under the terms of the GNU General Public License as published by *
- * the Free Software Foundation; either version 2 of the License, or *
- * (at your option) any later version. *
- * *
- ***********************************************************************/
- #include <stdio.h>
- #include <stdlib.h>
- #include <setjmp.h>
- #include <malloc.h>
- #include "gc.h"
- #include <string.h>
- #include "arsc.h"
- extern jmp_buf _EXH;
- EXP *currentExp;
- ENV *globalEnv;
- EXP *trueSym;
- char *nameTable[MAX_NAMES];
- NAME numNames;
- NAME setName;
- NAME eof;
- NAME lambda;
- VALUE *setVal;
- VALUE *falseValue, *trueValue;
- int false;
- int true;
- /*****************************************************************
- * ADT CONSTRUCTORS *
- *****************************************************************/
- /* newVXP - make a value expression */
- EXP *
- newVXP (VALUE * val)
- {
- EXP *e;
- e = (EXP *) GC_malloc (sizeof (EXP));
- e->etype = VXP;
- e->exp.val = val;
- return e;
- }
- /* newRXP - make a variable expression (reference) */
- EXP *
- newRXP (NAME nm)
- {
- EXP *e;
- e = (EXP *) GC_malloc (sizeof (EXP));
- e->etype = RXP;
- e->exp.ref = nm;
- return e;
- }
- /* newSXP - make an application expression (synthesis) */
- EXP *
- newSXP (EXP * op, ELIST * el)
- {
- EXP *e;
- e = (EXP *) GC_malloc (sizeof (EXP));
- e->etype = SXP;
- e->exp.syn.op = op;
- e->exp.syn.args = el;
- return e;
- }
- /* newAXP - make a lambda expression (abstraction) */
- EXP *
- newAXP (NLIST * formals, ELIST * body)
- {
- EXP *e;
- e = (EXP *) GC_malloc (sizeof (EXP));
- e->etype = AXP;
- e->exp.abs.vars = formals;
- e->exp.abs.body = body;
- return e;
- }
- /* newVAL - make a value (evaluated expression) */
- VALUE *
- newVAL (VTYPE t)
- {
- VALUE *val;
- val = (VALUE *) GC_malloc (sizeof (VALUE));
- val->type = t;
- return val;
- }
- /* newLISTV - represent a value list as a value */
- VALUE *
- newLISTV (VLIST *vl)
- {
- VALUE *val;
- if (vl) {
- val = (VALUE *) GC_malloc (sizeof (VALUE));
- val->type = LISTV;
- val->val.lv.car = vl->head;
- val->val.lv.cdr = newLISTV(vl->tail);
- return val;
- }
- else {
- return NULL;
- }
- }
- /* newPRIMV - make a primitive value */
- VALUE *
- newPRIMV (PRIM prim)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = PRIMV;
- result->val.prim = prim;
- return result;
- }
- /* newSTRV- make a string value */
- VALUE *
- newSTRV(NAME nm)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = STRV;
- result->val.str = nm;
- return result;
- }
- /* newSYMV- make a symbol value */
- VALUE *
- newSYMV(NAME nm)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = SYMV;
- result->val.sym = nm;
- return result;
- }
- /* newINTV- make an integer value */
- VALUE *
- newINTV (int i)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = INTV;
- result->val.ival = i;
- return result;
- }
- /* newACLV- make an ars-closure */
- VALUE *
- newACLV (EXP * fun, ENV * env)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = ACLV;
- result->val.acl.fun = fun;
- result->val.acl.env = env;
- return result;
- }
- /* newCLAMV- make a c-lambda abstraction */
- VALUE *
- newCLAMV (NLIST * vars, LFUN lfun, ENV *env)
- {
- VALUE *cl;
- cl = (VALUE *) GC_malloc (sizeof (VALUE));
- cl->type = CLAMV;
- cl->val.clam.vars = vars;
- cl->val.clam.lfun = lfun;
- cl->val.clam.env = env;
- return cl;
- }
- /* newTHUNKV - make a frozen expression (delayed evaluation) */
- VALUE *
- newTHUNKV (EXP * e, ENV * env)
- {
- VALUE *result;
- result = (VALUE *) GC_malloc (sizeof (VALUE));
- result->type = THUNKV;
- result->val.thunk.body = e;
- result->val.thunk.env = env;
- return result;
- }
- /* econs - make a list of expressions */
- ELIST *
- econs (EXP * e, ELIST * el)
- {
- ELIST *newel;
- newel = (ELIST *) GC_malloc (sizeof (ELIST));
- newel->head = e;
- newel->tail = el;
- return newel;
- }
- /* ncons - make a list of names */
- NLIST *
- ncons (NAME nm, NLIST * nl)
- {
- NLIST *newnl;
- newnl = (NLIST *) GC_malloc (sizeof (NLIST));
- newnl->head = nm;
- newnl->tail = nl;
- return newnl;
- }
- /* vcons - make a list of values */
- VLIST *
- vcons (VALUE * val, VLIST * vl)
- {
- VLIST *newvl;
- newvl = (VLIST *) GC_malloc (sizeof (VLIST));
- newvl->head = val;
- newvl->tail = vl;
- return newvl;
- }
- /* cons - make a list of values */
- VALUE *
- cons (VALUE * hd, VALUE * tl)
- {
- VALUE *newvl;
- newvl = (VALUE *) GC_malloc (sizeof (VALUE));
- newvl->type = LISTV;
- newvl->val.lv.car = hd;
- newvl->val.lv.cdr = tl;
- return newvl;
- }
- /* newENV - make an environment */
- ENV *
- newENV (NLIST * nl, VLIST * vl, ENV * env)
- {
- ENV *newenv;
- newenv = (ENV *) GC_malloc (sizeof (ENV));
- newenv->vars = nl;
- newenv->values = vl;
- newenv->next = env;
- return newenv;
- }
- /*****************************************************************
- * NAMES OF VARIABLES *
- *****************************************************************/
- /* initNames - place all pre-defined names into nameTable */
- void
- initNames ()
- {
- long i = 1;
- nameTable[i - 1] = "define";
- i++;
- nameTable[i - 1] = "incr";
- i++;
- nameTable[i - 1] = "+";
- i++;
- nameTable[i - 1] = "-";
- i++;
- nameTable[i - 1] = "*";
- i++;
- nameTable[i - 1] = "/";
- i++;
- nameTable[i - 1] = "print";
- i++;
- nameTable[i - 1] = "load";
- i++;
- nameTable[i - 1] = "equal";
- i++;
- nameTable[i - 1] = ">=";
- i++;
- nameTable[i - 1] = "<";
- i++;
- nameTable[i - 1] = "quit";
- i++;
- nameTable[i - 1] = "false";
- i++;
- nameTable[i - 1] = "true";
- numNames = i;
- }
- /* defName - insert new name into nameTable */
- NAME
- defName (char *nm)
- {
- long i = 1;
- int found = false;
- while (i <= numNames && !found) {
- if (!strcmp (nm, nameTable[i - 1]))
- found = true;
- else
- i++;
- }
- if (found)
- return i;
- if (i > MAX_NAMES) {
- printf ("No more room for names\n");
- longjmp (_EXH, 1);
- }
- numNames = i;
- nameTable[i - 1] = nm;
- return i;
- }
- /* prName - print name nm */
- void
- prName (NAME nm)
- {
- printf ("%s", nameTable[nm - 1]);
- }
- /* prString - print string nm (strings are handled like symbols ) */
- void
- prString (NAME nm)
- {
- printf ("%s", nameTable[nm - 1]);
- }
- /* lengthNL - return length of NLIST nl */
- long
- lengthNL (NLIST * nl)
- {
- long i = 0;
- while (nl != NULL) {
- i++;
- nl = nl->tail;
- }
- return i;
- }
- /* prNL - print list of names */
- void
- prNL (NLIST * nl)
- {
- long i = 0;
- putchar ('(');
- while (nl != NULL) {
- i++;
- prName (nl->head);
- nl = nl->tail;
- if (nl != NULL) {
- putchar (' ');
- }
- }
- printf (")\n");
- }
- /*****************************************************************
- * VARIABLES AND ENVIRONMENTS *
- *****************************************************************/
- /* emptyEnv - return an environment with no bindings */
- ENV *
- emptyEnv ()
- {
- return (newENV (NULL, NULL, NULL));
- }
- /* defVar - bind variable nm to value val in environment env */
- void
- defVar (NAME nm, VALUE * val, ENV * env)
- {
- env->vars = ncons (nm, env->vars);
- env->values = vcons (val, env->values);
- }
- /* setVar - set variable nm to value val in env */
- void
- setVar (NAME nm, VALUE * val, ENV * env)
- {
- VLIST *vl;
- vl = bindingInEnv (nm, env);
- if (vl) {
- vl->head = val;
- }
- else {
- printf("variable not defined: ");
- prName(nm);
- printf("\n");
- }
- }
- /* getVar - return VAL bound to nm in env */
- VALUE *
- getVar (NAME nm, ENV * env)
- {
- VLIST *vl;
- vl = bindingInEnv (nm, env);
- if (vl)
- return (vl->head);
- else
- return falseValue;
- }
- /* extendEnv - extend environment env by binding vars to vals */
- ENV *
- extendEnv (ENV * env, NLIST * vars, VLIST * vals)
- {
- return (newENV (vars, vals, env));
- }
- /* bindingInFrame - look up nm in one frame */
- VLIST *
- bindingInFrame (NLIST * nl, VLIST * vl, NAME nm)
- {
- int found = false;
- while (nl != NULL && !found) {
- if (nl->head == nm)
- found = true;
- else {
- nl = nl->tail;
- vl = vl->tail;
- }
- }
- return vl;
- }
- /* bindingInEnv - look up nm in env */
- VLIST *
- bindingInEnv (NAME nm, ENV * env)
- {
- VLIST *vl;
- do {
- vl = bindingInFrame (env->vars, env->values, nm);
- env = env->next;
- } while (vl == NULL && env != NULL);
- return vl;
- }
- /* isBound - check if nm is bound in env */
- int
- isBound (NAME nm, ENV * env)
- {
- return (bindingInEnv (nm, env) != NULL);
- }
- /* initGlobalEnv - initialize global environment */
- void
- initGlobalEnv ()
- {
- PRIM op;
- false = 0;
- true = 1;
- falseValue = newVAL (SYMV);
- trueValue = newVAL (SYMV);
- falseValue->val.sym = defName("false");
- trueValue->val.sym = defName("true");
- trueSym = newRXP (trueValue->val.sym);
- globalEnv = emptyEnv ();
- for (op = PRIMDEF;
- (long) op <= (long) PRIMQUIT; op = (PRIM) ((long) op + 1)) {
- defVar ((int) op + 1, newPRIMV (op), globalEnv);
- }
- setName = defName (strdup ("vmzero"));
- setVal = newVAL(INTV);
- setVal->val.ival = 0;
- defVar (setName, setVal, globalEnv);
- setName = defName (strdup ("vmtrue"));
- setVal = trueValue;
- defVar (setName, setVal, globalEnv);
- setName = defName (strdup ("vmfalse"));
- setVal = falseValue;
- defVar (setName, setVal, globalEnv);
- eof = defName (strdup ("*eof*"));
- lambda = defName (strdup ("lambda"));
- }
- /*****************************************************************
- * EVALUATION AND VALUES *
- *****************************************************************/
- /* eval - evaluate expression e in local environment env */
- VALUE *
- eval (EXP * e, ENV * env, EXP * lazy)
- {
- VALUE *result, *op;
- PRIM primname;
- switch (e->etype) {
- case VXP:
- result = e->exp.val;
- break;
- case RXP:
- if (isBound (e->exp.ref, env))
- result = getVar(e->exp.ref, env);
- else {
- printf ("Undefined variable: ");
- prName (e->exp.ref);
- putchar ('\n');
- longjmp (_EXH, 1);
- }
- result = evalThunk (result);
- break;
- case SXP:
- op = evalThunk (eval (e->exp.syn.op, env, lazy));
- if (op->type == PRIMV) {
- primname = op->val.prim;
- if (primname == PRIMDEF)
- result = applySpecialForm (PRIMDEF, e->exp.syn.args, env);
- else
- result = applyPrimitive (primname,
- evalList (e->exp.syn.args, env, lazy));
- }
- else
- result = applyARSClosure (op,
- evalList (e->exp.syn.args, env, lazy),
- lazy);
- break;
- case AXP:
- result = newACLV(e, env);
- break;
- }
- return result;
- }
- /* evalThunk - enforce evaluation of frozen expression */
- /* memoizing version would be faster than standard version but not as */
- /* flexible and is not used here to provide maximum flexibility for */
- /* ARS ( to allow implementing special forms as normal functions */
- VALUE *
- evalThunk (VALUE * val)
- {
- if (val->type == THUNKV)
- return (evalThunk (eval (val->val.acl.fun,
- val->val.acl.env, trueSym)));
- else
- return val;
- }
- /* applyPrimitive - apply PRIM op to arguments in VLIST vl */
- VALUE *
- applyPrimitive (PRIM op, VLIST * vl)
- {
- VALUE *result, *v1, *v2;
- int nargs;
- nargs = lengthVL (vl);
- switch (nargs) {
- case 0:
- if (op == PRIMQUIT) {
- longjmp (_EXH, 2);
- }
- else {
- printf ("Illegal operation: ");
- prName ((int) op + 1);
- putchar ('\n');
- longjmp (_EXH, 1);
- }
- break;
- case 1:
- v1 = evalThunk (vl->head); /* 1st actual */
- switch (op) {
- case PRIMINCR:
- if (v1->type == INTV) {
- result = newVAL (INTV);
- result->val.ival = v1->val.ival + 1;
- return result;
- }
- else {
- printf ("Non-arithmetic arguments to ");
- prName ((int) op + 1);
- putchar ('\n');
- prValue (v1);
- longjmp (_EXH, 1);
- }
- break;
- case PRIMPRINT:
- printf("-->");
- prValue (v1);
- putchar ('\n');
- result = newVAL (SYMV);;
- result->val.sym = defName("void\n");
- break;
- case PRIMLOAD:
- prValue (v1);
- putchar ('\n');
- result = load (v1);
- break;
- default:
- printf ("undefined primitive operation\n ");
- prName ((int) op + 1);
- putchar ('\n');
- longjmp (_EXH, 2);
- }
- break;
- case 2:
- v1 = evalThunk (vl->head); /* 1st actual */
- v2 = evalThunk (vl->tail->head); /* 2nd actual */
- switch (op) {
- case PRIMADD:
- if ((v1->type == INTV) && (v2->type == INTV)) {
- result = newVAL (INTV);
- result->val.ival = v1->val.ival + v2->val.ival;
- }
- else {
- printf ("PRIMADD:\n ");
- printf ("Integer argument expected!\n ");
- longjmp (_EXH, 2);
- }
- break;
- case PRIMSUB:
- if ((v1->type == INTV) && (v2->type == INTV)) {
- result = newINTV (v1->val.ival - v2->val.ival);
- }
- else {
- printf ("PRIMSUB:\n ");
- printf ("Integer argument expected!\n ");
- longjmp (_EXH, 2);
- }
- break;
- case PRIMMLT:
- if ((v1->type == INTV) && (v2->type == INTV)) {
- result = newINTV (v1->val.ival * v2->val.ival);
- }
- else {
- printf ("PRIMMLT:\n ");
- printf ("Integer argument expected!\n ");
- longjmp (_EXH, 2);
- }
- break;
- case PRIMDIV:
- if ((v1->type == INTV) && (v2->type == INTV)) {
- result = newINTV (v1->val.ival / v2->val.ival);
- }
- else {
- printf ("Integer argument expected!\n ");
- longjmp (_EXH, 2);
- }
- break;
- case PRIMGE:
- if (v1->type != v2->type) {
- result = getVar(defName("false"), globalEnv);
- }
- else if ((v1->type == INTV) &&
- (v1->val.ival >= v2->val.ival)) {
- result = getVar(defName("true"), globalEnv);
- }
- else {
- result = getVar(defName("false"), globalEnv);
- }
- break;
- case PRIMLT:
- if (v1->type != v2->type) {
- result = getVar(defName("false"), globalEnv);
- }
- else if ((v1->type == INTV) &&
- (v1->val.ival < v2->val.ival)) {
- result = getVar(defName("true"), globalEnv);
- }
- else {
- result = getVar(defName("false"), globalEnv);
- }
- break;
- case PRIMEQUAL:
- if (v1 == v2) {
- result = getVar(defName("true"), globalEnv);
- }
- else if (v1->type != v2->type) {
- result = getVar(defName("false"), globalEnv);
- }
- else if ((v1->type == INTV) &&
- (v1->val.ival == v2->val.ival)) {
- result = getVar(defName("true"), globalEnv);
- }
- else if (v1->type == SYMV) {
- if (v1->val.sym == v2->val.sym) {
- result = getVar(defName("true"), globalEnv);
- }
- else {
- result = getVar(defName("false"), globalEnv);
- }
- }
- else if (v1->type == STRV) {
- if (v1->val.str == v2->val.str) {
- result = getVar(defName("true"), globalEnv);
- }
- else {
- result = getVar(defName("false"), globalEnv);
- }
- }
- else {
- result = getVar(defName("false"), globalEnv);
- }
- break;
- default:
- printf ("undefined primitive operation\n ");
- prName ((int) op + 1);
- putchar ('\n');
- longjmp (_EXH, 2);
- }
- break;
- default:
- printf ("Wrong number of arguments to ");
- prName ((int) op + 1);
- putchar ('\n');
- longjmp (_EXH, 1);
- }
- return result;
- }
- /* lazyp - checks if lazy evaluation is to be applied */
- int
- lazyp (EXP * e1, EXP * e2)
- {
- if (e1->etype == RXP && e2->etype == RXP) {
- if (e1->exp.ref == e2->exp.ref)
- return false;
- else
- return true;
- }
- else
- return true;
- }
- /* evalList - evaluate each expression in el */
- VLIST *
- evalList (ELIST * el, ENV * env, EXP * lazy)
- {
- VALUE *h;
- VLIST *t;
- if (el == NULL)
- return NULL;
- else {
- if (lazyp (el->head, lazy))
- h = newTHUNKV (el->head, env);
- else
- h = evalThunk (eval (el->head, env, lazy));
- t = evalList (el->tail, env, lazy);
- return (vcons (h, t));
- }
- }
- /* evalSequence - evaluate a sequence of expressions */
- VALUE *
- evalSequence (ELIST * el, ENV * newenv, EXP * lazy)
- {
- while (el->tail != NULL) {
- evalThunk (eval (el->head, newenv, lazy));
- el = el->tail;
- }
- return (evalThunk (eval (el->head, newenv, lazy)));
- }
- /* applyARSClosure - apply closure to arguments */
- VALUE *
- applyARSClosure (VALUE * op, VLIST * args, EXP * lazy)
- {
- EXP *fun;
- ELIST *body;
- NLIST *names;
- ENV *savedenv, *newenv;
- fun = op->val.acl.fun;
- savedenv = op->val.acl.env;
- names = fun->exp.abs.vars;
- body = fun->exp.abs.body;
- if (lengthNL (names) != lengthVL (args)) {
- printf ("Wrong number of arguments to closure\n");
- printf ("names\n");
- prNL (names);
- printf ("arguments\n");
- prVL (args);
- longjmp (_EXH, 1);
- }
- newenv = extendEnv (savedenv, names, args);
- return (evalSequence (body, newenv, lazy));
- }
- /* applySpecialForm - evaluate special form */
- VALUE *
- applySpecialForm (PRIM op, ELIST * args, ENV * env)
- {
- VALUE *result;
- if (op == PRIMDEF) {
- result = evalThunk (eval (args->tail->head, env, args->head));
- if (isBound (args->head->exp.ref, env)) {
- setVar (args->head->exp.ref, result, env);
- }
- else {
- defVar (args->head->exp.ref, result, env);
- }
- }
- else {
- printf ("undefined control operation!\n");
- longjmp (_EXH, 2);
- }
- return result;
- }
- /* apply - apply c-closure to arguments */
- VALUE *
- apply (VALUE * cl, VLIST * args)
- {
- LFUN lfun;
- NLIST *names;
- ENV *savedenv, *newenv;
- savedenv = cl->val.clam.env;
- names = cl->val.clam.vars;
- lfun = cl->val.clam.lfun;
- if (lengthNL (names) != lengthVL (args)) {
- printf ("Wrong number of arguments to closure\n");
- printf ("names\n");
- prNL (names);
- printf ("arguments\n");
- prVL (args);
- longjmp (_EXH, 1);
- }
- newenv = extendEnv (savedenv, names, args);
- return (lfun(newenv));
- }
- /* prValue - print value val */
- void
- prValue (VALUE * val)
- {
- int i;
-
- if (val != NULL) {
- switch (val->type) {
- case INTV:
- printf ("%ld", val->val.ival);
- break;
- case SYMV:
- prString (val->val.sym);
- break;
- case STRV:
- prString (val->val.str);
- break;
- case LISTV:
- i = 0;
- putchar ('(');
- while (val != NULL) {
- i++;
- prValue (evalThunk (val->val.lv.car));
- putchar (' ');
- val = val->val.lv.cdr;
- }
- printf (")\n");
- break;
- case PRIMV:
- printf ("<primitive: ");
- prName ((int) val->val.prim + 1);
- putchar ('>');
- break;
- case ACLV:
- printf ("lambda");
- prNL(val->val.acl.fun->exp.abs.vars);
- break;
- case CLAMV:
- printf ("<c-lambda-abstraction>");
- break;
- case THUNKV:
- printf ("...");
- break;
- }
- }
- }
- /* lengthVL - return length of VLIST vl */
- long
- lengthVL (VLIST * vl)
- {
- long i = 0;
- while (vl != NULL) {
- i++;
- vl = vl->tail;
- }
- return i;
- }
- /* prVL - print list of values */
- void
- prVL (VLIST * vl)
- {
- long i = 0;
- putchar ('(');
- while (vl != NULL) {
- i++;
- prValue (evalThunk (vl->head));
- putchar (' ');
- vl = vl->tail;
- }
- printf (")\n");
- }
- /*****************************************************************
- * LOAD ABSTRACTION FROM FILE *
- *****************************************************************/
- /* primitive function load (load abstractions from file) */
- VALUE *
- load (VALUE * val)
- {
- char *file;
- FILE *fis;
- EXP *currp;
- VALUE *result;
- int ret;
- if (val->type == STRV) {
- file = nameTable[val->val.str - 1];
- }
- else {
- printf ("load: error in argument type\n");
- longjmp (_EXH, 1);
- }
- fis = fopen (file, "r");
- parserinit (fis);
- while (1) {
- currp = readWithoutPrompt ();
- result = evalThunk (eval (currp, globalEnv, trueSym));
- if ((result->type == STRV) && (result->val.str == eof)) {
- fclose (fis);
- break;
- }
- prValue (result);
- //printf (".");
- }
- parserinit (stdin);
- return result;
- }