PageRenderTime 6ms CodeModel.GetById 2ms app.highlight 44ms RepoModel.GetById 1ms app.codeStats 0ms

/a++/appc/arsc.c

https://github.com/pib/500pl
C | 1010 lines | 794 code | 135 blank | 81 comment | 138 complexity | 5793197592e74bc3cba4f053f50ee359 MD5 | raw file
   1/***********************************************************************
   2                          arsc.c  -  description
   3                          ----------------------
   4    begin                : Wed Apr 17 2001
   5    update               : Sa  Aug 06 2004
   6    copyright            : (C) 2001 by Georg P. Loczewski
   7    email                : gpl@lambda-bound.com
   8 **********************************************************************/
   9
  10/***********************************************************************
  11*                                                                      *
  12* This program is free software; you can redistribute it and/or modify *
  13* it under the terms of the GNU General Public License as published by *
  14* the Free Software Foundation; either version 2 of the License, or    *
  15* (at your option) any later version.                                  *
  16*                                                                      *
  17***********************************************************************/
  18
  19#include <stdio.h>
  20#include <stdlib.h>
  21#include <setjmp.h>
  22#include <malloc.h>
  23#include "gc.h"
  24#include <string.h>
  25#include "arsc.h"
  26
  27extern jmp_buf _EXH;
  28
  29EXP *currentExp;
  30ENV *globalEnv;
  31EXP *trueSym;
  32
  33char *nameTable[MAX_NAMES];
  34NAME numNames;
  35NAME setName;
  36NAME eof;
  37NAME lambda;
  38VALUE *setVal;
  39VALUE *falseValue, *trueValue;
  40
  41int false;
  42int true;
  43
  44
  45/*****************************************************************
  46 *                  ADT CONSTRUCTORS                             *
  47 *****************************************************************/
  48
  49/* newVXP - make a value expression */
  50EXP *
  51newVXP (VALUE * val)
  52{
  53  EXP *e;
  54
  55  e = (EXP *) GC_malloc (sizeof (EXP));
  56  e->etype = VXP;
  57  e->exp.val = val;
  58  return e;
  59}
  60
  61
  62/* newRXP - make a variable expression (reference)  */
  63EXP *
  64newRXP (NAME nm)
  65{
  66  EXP *e;
  67
  68  e = (EXP *) GC_malloc (sizeof (EXP));
  69  e->etype = RXP;
  70  e->exp.ref = nm;
  71  return e;
  72}
  73
  74
  75/* newSXP - make an application expression (synthesis)  */
  76EXP *
  77newSXP (EXP * op, ELIST * el)
  78{
  79  EXP *e;
  80
  81  e = (EXP *) GC_malloc (sizeof (EXP));
  82  e->etype = SXP;
  83  e->exp.syn.op = op;
  84  e->exp.syn.args = el;
  85  return e;
  86}
  87
  88
  89/* newAXP - make a lambda expression (abstraction)  */
  90EXP *
  91newAXP (NLIST * formals, ELIST * body)
  92{
  93  EXP *e;
  94
  95  e = (EXP *) GC_malloc (sizeof (EXP));
  96  e->etype = AXP;
  97  e->exp.abs.vars = formals;
  98  e->exp.abs.body = body;
  99  return e;
 100}
 101
 102
 103/* newVAL - make a value (evaluated expression)  */
 104VALUE *
 105newVAL (VTYPE t)
 106{
 107  VALUE *val;
 108
 109  val = (VALUE *) GC_malloc (sizeof (VALUE));
 110  val->type = t;
 111  return val;
 112}
 113
 114
 115/* newLISTV - represent a value list as a value   */
 116VALUE *
 117newLISTV (VLIST *vl)
 118{
 119  VALUE *val;
 120
 121  if (vl) {
 122     val = (VALUE *) GC_malloc (sizeof (VALUE));
 123     val->type = LISTV;
 124     val->val.lv.car = vl->head;
 125     val->val.lv.cdr = newLISTV(vl->tail);
 126     return val;
 127  }
 128  else {
 129     return NULL;
 130  }
 131}
 132
 133
 134/* newPRIMV - make a primitive value */
 135VALUE *
 136newPRIMV (PRIM prim)
 137{
 138  VALUE *result;
 139
 140  result = (VALUE *) GC_malloc (sizeof (VALUE));
 141  result->type = PRIMV;
 142  result->val.prim = prim;
 143  return result;
 144}
 145
 146
 147/* newSTRV- make a string value */
 148VALUE *
 149newSTRV(NAME nm)
 150{
 151  VALUE *result;
 152
 153  result = (VALUE *) GC_malloc (sizeof (VALUE));
 154  result->type = STRV;
 155  result->val.str = nm;
 156  return result;
 157}
 158
 159/* newSYMV- make a symbol value */
 160VALUE *
 161newSYMV(NAME nm)
 162{
 163  VALUE *result;
 164
 165  result = (VALUE *) GC_malloc (sizeof (VALUE));
 166  result->type = SYMV;
 167  result->val.sym = nm;
 168  return result;
 169}
 170
 171/* newINTV- make an integer value */
 172VALUE *
 173newINTV (int i)
 174{
 175  VALUE *result;
 176
 177  result = (VALUE *) GC_malloc (sizeof (VALUE));
 178  result->type = INTV;
 179  result->val.ival = i;
 180  return result;
 181}
 182
 183
 184/* newACLV- make an ars-closure */
 185VALUE *
 186newACLV (EXP * fun, ENV * env)
 187{
 188  VALUE *result;
 189
 190  result = (VALUE *) GC_malloc (sizeof (VALUE));
 191  result->type = ACLV;
 192  result->val.acl.fun = fun;
 193  result->val.acl.env = env;
 194  return result;
 195}
 196
 197/* newCLAMV- make a c-lambda abstraction  */
 198VALUE *
 199newCLAMV (NLIST * vars, LFUN lfun, ENV *env)
 200{
 201  VALUE *cl;
 202
 203  cl = (VALUE *) GC_malloc (sizeof (VALUE));
 204  cl->type = CLAMV;
 205  cl->val.clam.vars = vars;
 206  cl->val.clam.lfun = lfun;
 207  cl->val.clam.env = env;
 208  return cl;
 209}
 210
 211/* newTHUNKV - make a frozen expression (delayed evaluation) */
 212VALUE *
 213newTHUNKV (EXP * e, ENV * env)
 214{
 215  VALUE *result;
 216
 217  result = (VALUE *) GC_malloc (sizeof (VALUE));
 218  result->type = THUNKV;
 219  result->val.thunk.body = e;
 220  result->val.thunk.env = env;
 221  return result;
 222}
 223
 224
 225/* econs - make a list of expressions */
 226ELIST *
 227econs (EXP * e, ELIST * el)
 228{
 229  ELIST *newel;
 230
 231  newel = (ELIST *) GC_malloc (sizeof (ELIST));
 232  newel->head = e;
 233  newel->tail = el;
 234  return newel;
 235}
 236
 237
 238/* ncons - make a list of names */
 239NLIST *
 240ncons (NAME nm, NLIST * nl)
 241{
 242  NLIST *newnl;
 243
 244  newnl = (NLIST *) GC_malloc (sizeof (NLIST));
 245  newnl->head = nm;
 246  newnl->tail = nl;
 247  return newnl;
 248}
 249
 250
 251/* vcons - make a list of values */
 252VLIST *
 253vcons (VALUE * val, VLIST * vl)
 254{
 255  VLIST *newvl;
 256
 257  newvl = (VLIST *) GC_malloc (sizeof (VLIST));
 258  newvl->head = val;
 259  newvl->tail = vl;
 260  return newvl;
 261}
 262
 263/* cons - make a list of values */
 264VALUE *
 265cons (VALUE * hd, VALUE * tl)
 266{
 267  VALUE *newvl;
 268
 269  newvl = (VALUE *) GC_malloc (sizeof (VALUE));
 270  newvl->type = LISTV;
 271  newvl->val.lv.car = hd;
 272  newvl->val.lv.cdr = tl;
 273  return newvl;
 274}
 275
 276
 277/* newENV - make an environment */
 278ENV *
 279newENV (NLIST * nl, VLIST * vl, ENV * env)
 280{
 281  ENV *newenv;
 282
 283  newenv = (ENV *) GC_malloc (sizeof (ENV));
 284  newenv->vars = nl;
 285  newenv->values = vl;
 286  newenv->next = env;
 287  return newenv;
 288}
 289
 290
 291/*****************************************************************
 292 *                     NAMES OF VARIABLES                        *
 293 *****************************************************************/
 294
 295/* initNames - place all pre-defined names into nameTable  */
 296void
 297initNames ()
 298{
 299  long i = 1;
 300
 301  nameTable[i - 1] = "define";
 302  i++;
 303  nameTable[i - 1] = "incr";
 304  i++;
 305  nameTable[i - 1] = "+";
 306  i++;
 307  nameTable[i - 1] = "-";
 308  i++;
 309  nameTable[i - 1] = "*";
 310  i++;
 311  nameTable[i - 1] = "/";
 312  i++;
 313  nameTable[i - 1] = "print";
 314  i++;
 315  nameTable[i - 1] = "load";
 316  i++;
 317  nameTable[i - 1] = "equal";
 318  i++;
 319  nameTable[i - 1] = ">=";
 320  i++;
 321  nameTable[i - 1] = "<";
 322  i++;
 323  nameTable[i - 1] = "quit";
 324  i++;
 325  nameTable[i - 1] = "false";
 326  i++;
 327  nameTable[i - 1] = "true";
 328  numNames = i;
 329}
 330
 331
 332
 333/* defName - insert new name into nameTable                     */
 334NAME
 335defName (char *nm)
 336{
 337  long i = 1;
 338  int found = false;
 339
 340  while (i <= numNames && !found) {
 341    if (!strcmp (nm, nameTable[i - 1]))
 342      found = true;
 343    else
 344      i++;
 345  }
 346  if (found)
 347    return i;
 348  if (i > MAX_NAMES) {
 349    printf ("No more room for names\n");
 350    longjmp (_EXH, 1);
 351  }
 352  numNames = i;
 353  nameTable[i - 1] = nm;
 354  return i;
 355}
 356
 357
 358/* prName - print name nm  */
 359void
 360prName (NAME nm)
 361{
 362  printf ("%s", nameTable[nm - 1]);
 363}
 364
 365
 366/* prString - print string nm (strings are handled like symbols ) */
 367void
 368prString (NAME nm)
 369{
 370  printf ("%s", nameTable[nm - 1]);
 371}
 372
 373/* lengthNL - return length of NLIST nl      */
 374long
 375lengthNL (NLIST * nl)
 376{
 377  long i = 0;
 378
 379  while (nl != NULL) {
 380    i++;
 381    nl = nl->tail;
 382  }
 383  return i;
 384}
 385
 386/* prNL - print list of names */
 387void
 388prNL (NLIST * nl)
 389{
 390  long i = 0;
 391
 392  putchar ('(');
 393  while (nl != NULL) {
 394    i++;
 395    prName (nl->head);
 396    nl = nl->tail;
 397    if (nl != NULL) {
 398       putchar (' ');
 399    }
 400  }
 401  printf (")\n");
 402}
 403
 404
 405/*****************************************************************
 406 *                     VARIABLES AND ENVIRONMENTS                *
 407 *****************************************************************/
 408
 409/* emptyEnv - return an environment with no bindings             */
 410ENV *
 411emptyEnv ()
 412{
 413  return (newENV (NULL, NULL, NULL));
 414}
 415
 416
 417/* defVar - bind variable nm to value val in environment env      */
 418void
 419defVar (NAME nm, VALUE * val, ENV * env)
 420{
 421  env->vars = ncons (nm, env->vars);
 422  env->values = vcons (val, env->values);
 423}
 424
 425/* setVar - set variable nm to value val in env                 */
 426void
 427setVar (NAME nm, VALUE * val, ENV * env)
 428{
 429  VLIST *vl;
 430
 431  vl = bindingInEnv (nm, env);
 432  if (vl) {
 433     vl->head = val;
 434  }
 435  else {
 436     printf("variable not defined: ");
 437     prName(nm);
 438     printf("\n");
 439  }
 440}
 441
 442/* getVar - return VAL bound to nm in env                        */
 443VALUE *
 444getVar (NAME nm, ENV * env)
 445{
 446  VLIST *vl;
 447
 448  vl = bindingInEnv (nm, env);
 449  if (vl)
 450     return (vl->head);
 451  else
 452     return falseValue;
 453}
 454
 455/*  extendEnv - extend environment env by binding vars to vals   */
 456ENV *
 457extendEnv (ENV * env, NLIST * vars, VLIST * vals)
 458{
 459  return (newENV (vars, vals, env));
 460}
 461
 462
 463/* bindingInFrame - look up nm in one frame                      */
 464VLIST *
 465bindingInFrame (NLIST * nl, VLIST * vl, NAME nm)
 466{
 467  int found = false;
 468
 469  while (nl != NULL && !found) {
 470    if (nl->head == nm)
 471      found = true;
 472    else {
 473      nl = nl->tail;
 474      vl = vl->tail;
 475    }
 476  }
 477  return vl;
 478}
 479
 480
 481/* bindingInEnv - look up nm in env                                   */
 482VLIST *
 483bindingInEnv (NAME nm, ENV * env)
 484{
 485  VLIST *vl;
 486
 487  do {
 488    vl = bindingInFrame (env->vars, env->values, nm);
 489    env = env->next;
 490  } while (vl == NULL && env != NULL);
 491  return vl;
 492}
 493
 494
 495/* isBound - check if nm is bound in env                         */
 496int
 497isBound (NAME nm, ENV * env)
 498{
 499  return (bindingInEnv (nm, env) != NULL);
 500}
 501
 502/* initGlobalEnv - initialize global environment */
 503void
 504initGlobalEnv ()
 505{
 506  PRIM op;
 507
 508  false = 0;
 509  true = 1;
 510  falseValue = newVAL (SYMV);
 511  trueValue = newVAL (SYMV);
 512  falseValue->val.sym = defName("false");
 513  trueValue->val.sym = defName("true");
 514  trueSym = newRXP (trueValue->val.sym);
 515  globalEnv = emptyEnv ();
 516  for (op = PRIMDEF;
 517       (long) op <= (long) PRIMQUIT; op = (PRIM) ((long) op + 1)) {
 518    defVar ((int) op + 1, newPRIMV (op), globalEnv);
 519  }
 520  setName = defName (strdup ("vmzero"));
 521  setVal = newVAL(INTV);
 522  setVal->val.ival = 0;
 523  defVar (setName, setVal, globalEnv);
 524  setName = defName (strdup ("vmtrue"));
 525  setVal = trueValue;
 526  defVar (setName, setVal, globalEnv);
 527
 528  setName = defName (strdup ("vmfalse"));
 529  setVal = falseValue;
 530  defVar (setName, setVal, globalEnv);
 531
 532  eof = defName (strdup ("*eof*"));
 533  lambda = defName (strdup ("lambda"));
 534}
 535
 536/*****************************************************************
 537 *                     EVALUATION  AND VALUES                    *
 538 *****************************************************************/
 539
 540/* eval - evaluate  expression e in local environment env  */
 541VALUE *
 542eval (EXP * e, ENV * env, EXP * lazy)
 543{
 544  VALUE *result, *op;
 545  PRIM primname;
 546
 547  switch (e->etype) {
 548
 549  case VXP:
 550    result = e->exp.val;
 551    break;
 552
 553  case RXP:
 554    if (isBound (e->exp.ref, env))
 555      result = getVar(e->exp.ref, env);
 556    else {
 557      printf ("Undefined variable: ");
 558      prName (e->exp.ref);
 559      putchar ('\n');
 560      longjmp (_EXH, 1);
 561    }
 562    result = evalThunk (result);
 563    break;
 564
 565  case SXP:
 566    op = evalThunk (eval (e->exp.syn.op, env, lazy));
 567    if (op->type == PRIMV) {
 568      primname = op->val.prim;
 569      if (primname == PRIMDEF)
 570	result = applySpecialForm (PRIMDEF, e->exp.syn.args, env);
 571      else
 572	result = applyPrimitive (primname,
 573				 evalList (e->exp.syn.args, env, lazy));
 574    }
 575    else
 576      result = applyARSClosure (op, 
 577		                evalList (e->exp.syn.args, env, lazy), 
 578			        lazy);
 579    break;
 580
 581  case AXP:
 582    result = newACLV(e, env);
 583    break;
 584  }
 585  return result;
 586}
 587
 588
 589/* evalThunk - enforce evaluation of frozen expression                */
 590/* memoizing version would be faster than standard version but not as */
 591/* flexible and is not used here to provide maximum flexibility for   */
 592/* ARS ( to allow implementing special forms as normal functions      */
 593
 594VALUE *
 595evalThunk (VALUE * val)
 596{
 597  if (val->type == THUNKV)
 598    return (evalThunk (eval (val->val.acl.fun,
 599			     val->val.acl.env, trueSym)));
 600  else
 601    return val;
 602}
 603
 604/* applyPrimitive - apply PRIM op to arguments in VLIST vl  */
 605VALUE *
 606applyPrimitive (PRIM op, VLIST * vl)
 607{
 608  VALUE *result, *v1, *v2;
 609  int nargs;
 610
 611  nargs = lengthVL (vl);
 612  switch (nargs) {
 613  case 0:
 614    if (op == PRIMQUIT) {
 615      longjmp (_EXH, 2);
 616    }
 617    else {
 618      printf ("Illegal operation: ");
 619      prName ((int) op + 1);
 620      putchar ('\n');
 621      longjmp (_EXH, 1);
 622    }
 623    break;
 624  case 1:
 625    v1 = evalThunk (vl->head);	/* 1st actual */
 626    switch (op) {
 627    case PRIMINCR:
 628      if (v1->type == INTV) {
 629	result = newVAL (INTV);
 630	result->val.ival = v1->val.ival + 1;
 631	return result;
 632      }
 633      else {
 634	printf ("Non-arithmetic arguments to ");
 635	prName ((int) op + 1);
 636	putchar ('\n');
 637	prValue (v1);
 638	longjmp (_EXH, 1);
 639      }
 640      break;
 641    case PRIMPRINT:
 642      printf("-->");
 643      prValue (v1);
 644      putchar ('\n');
 645      result = newVAL (SYMV);;
 646      result->val.sym = defName("void\n");
 647      break;
 648    case PRIMLOAD:
 649      prValue (v1);
 650      putchar ('\n');
 651      result = load (v1);
 652      break;
 653    default:
 654      printf ("undefined primitive operation\n ");
 655      prName ((int) op + 1);
 656      putchar ('\n');
 657      longjmp (_EXH, 2);
 658    }
 659    break;
 660  case 2:
 661    v1 = evalThunk (vl->head);	/* 1st actual */
 662    v2 = evalThunk (vl->tail->head);	/* 2nd actual */
 663    switch (op) {
 664      case PRIMADD:
 665        if ((v1->type == INTV) && (v2->type == INTV)) {
 666	   result = newVAL (INTV);
 667	   result->val.ival = v1->val.ival + v2->val.ival;
 668        }
 669        else {
 670           printf ("PRIMADD:\n ");
 671           printf ("Integer argument expected!\n ");
 672           longjmp (_EXH, 2);
 673        }
 674        break;
 675      case PRIMSUB:
 676        if ((v1->type == INTV) && (v2->type == INTV)) {
 677	   result = newINTV (v1->val.ival - v2->val.ival);
 678        }
 679        else {
 680           printf ("PRIMSUB:\n ");
 681           printf ("Integer argument expected!\n ");
 682           longjmp (_EXH, 2);
 683        }
 684        break;
 685      case PRIMMLT:
 686        if ((v1->type == INTV) && (v2->type == INTV)) {
 687	   result = newINTV (v1->val.ival * v2->val.ival);
 688        }
 689        else {
 690           printf ("PRIMMLT:\n ");
 691           printf ("Integer argument expected!\n ");
 692           longjmp (_EXH, 2);
 693        }
 694        break;
 695      case PRIMDIV:
 696        if ((v1->type == INTV) && (v2->type == INTV)) {
 697	   result = newINTV (v1->val.ival / v2->val.ival);
 698        }
 699        else {
 700           printf ("Integer argument expected!\n ");
 701           longjmp (_EXH, 2);
 702        }
 703        break;
 704      case PRIMGE:
 705        if (v1->type != v2->type) {
 706           result = getVar(defName("false"), globalEnv);
 707        }
 708        else if ((v1->type == INTV) &&
 709                 (v1->val.ival >= v2->val.ival)) {
 710                result = getVar(defName("true"), globalEnv);
 711        }
 712        else {
 713           result = getVar(defName("false"), globalEnv);
 714        }
 715        break;
 716      case PRIMLT:
 717        if (v1->type != v2->type) {
 718           result = getVar(defName("false"), globalEnv);
 719        }
 720        else if ((v1->type == INTV) &&
 721                 (v1->val.ival < v2->val.ival)) {
 722                result = getVar(defName("true"), globalEnv);
 723        }
 724        else {
 725           result = getVar(defName("false"), globalEnv);
 726        }
 727        break;
 728      case PRIMEQUAL:
 729        if (v1 == v2) {
 730          result = getVar(defName("true"), globalEnv);
 731        }
 732        else if (v1->type != v2->type) {
 733           result = getVar(defName("false"), globalEnv);
 734        }
 735        else if ((v1->type == INTV) &&
 736                 (v1->val.ival == v2->val.ival)) {
 737                result = getVar(defName("true"), globalEnv);
 738        }
 739        else if (v1->type == SYMV) {
 740                if (v1->val.sym == v2->val.sym) {
 741                   result = getVar(defName("true"), globalEnv);
 742                }
 743                else {
 744                   result = getVar(defName("false"), globalEnv);
 745                }
 746        }
 747        else if (v1->type == STRV) {
 748                if (v1->val.str == v2->val.str) {
 749                   result = getVar(defName("true"), globalEnv);
 750                }
 751                else {
 752                   result = getVar(defName("false"), globalEnv);
 753                }
 754        }
 755        else {
 756           result = getVar(defName("false"), globalEnv);
 757        }
 758        break;
 759      default:
 760        printf ("undefined primitive operation\n ");
 761        prName ((int) op + 1);
 762        putchar ('\n');
 763        longjmp (_EXH, 2);
 764      }
 765      break;
 766    default:
 767      printf ("Wrong number of arguments to ");
 768      prName ((int) op + 1);
 769      putchar ('\n');
 770      longjmp (_EXH, 1);
 771  }
 772  return result;
 773}
 774
 775/* lazyp - checks if lazy evaluation is to be applied */
 776int
 777lazyp (EXP * e1, EXP * e2)
 778{
 779  if (e1->etype == RXP && e2->etype == RXP) {
 780    if (e1->exp.ref == e2->exp.ref)
 781      return false;
 782    else
 783      return true;
 784  }
 785  else
 786    return true;
 787}
 788
 789
 790/* evalList - evaluate each expression in el                     */
 791VLIST *
 792evalList (ELIST * el, ENV * env, EXP * lazy)
 793{
 794  VALUE *h;
 795  VLIST *t;
 796
 797  if (el == NULL)
 798    return NULL;
 799  else {
 800    if (lazyp (el->head, lazy))
 801      h = newTHUNKV (el->head, env);
 802    else
 803      h = evalThunk (eval (el->head, env, lazy));
 804
 805    t = evalList (el->tail, env, lazy);
 806    return (vcons (h, t));
 807  }
 808}
 809
 810/* evalSequence - evaluate a sequence of expressions */
 811VALUE *
 812evalSequence (ELIST * el, ENV * newenv, EXP * lazy)
 813{
 814  while (el->tail != NULL) {
 815    evalThunk (eval (el->head, newenv, lazy));
 816    el = el->tail;
 817  }
 818  return (evalThunk (eval (el->head, newenv, lazy)));
 819}
 820
 821/* applyARSClosure - apply closure to arguments */
 822VALUE *
 823applyARSClosure (VALUE * op, VLIST * args, EXP * lazy)
 824{
 825  EXP *fun;
 826  ELIST *body;
 827  NLIST *names;
 828  ENV *savedenv, *newenv;
 829
 830  fun = op->val.acl.fun;
 831  savedenv = op->val.acl.env;
 832  names = fun->exp.abs.vars;
 833  body = fun->exp.abs.body;
 834  if (lengthNL (names) != lengthVL (args)) {
 835    printf ("Wrong number of arguments to closure\n");
 836    printf ("names\n");
 837    prNL (names);
 838    printf ("arguments\n");
 839    prVL (args);
 840    longjmp (_EXH, 1);
 841  }
 842  newenv = extendEnv (savedenv, names, args);
 843  return (evalSequence (body, newenv, lazy));
 844}
 845
 846/* applySpecialForm - evaluate special form */
 847VALUE *
 848applySpecialForm (PRIM op, ELIST * args, ENV * env)
 849{
 850  VALUE *result;
 851
 852  if (op == PRIMDEF) {
 853    result = evalThunk (eval (args->tail->head, env, args->head));
 854    if (isBound (args->head->exp.ref, env)) {
 855      setVar (args->head->exp.ref, result, env);
 856    }
 857    else {
 858      defVar (args->head->exp.ref, result, env);
 859    }
 860  }
 861  else {
 862    printf ("undefined control operation!\n");
 863    longjmp (_EXH, 2);
 864  }
 865  return result;
 866}
 867
 868/* apply - apply c-closure to arguments */
 869VALUE *
 870apply (VALUE * cl, VLIST * args)
 871{
 872  LFUN lfun;
 873  NLIST *names;
 874  ENV *savedenv, *newenv;
 875
 876  savedenv = cl->val.clam.env;
 877  names = cl->val.clam.vars;
 878  lfun = cl->val.clam.lfun;
 879  if (lengthNL (names) != lengthVL (args)) {
 880    printf ("Wrong number of arguments to closure\n");
 881    printf ("names\n");
 882    prNL (names);
 883    printf ("arguments\n");
 884    prVL (args);
 885    longjmp (_EXH, 1);
 886  }
 887  newenv = extendEnv (savedenv, names, args);
 888  return (lfun(newenv));
 889}
 890
 891/* prValue - print value  val                                */
 892void
 893prValue (VALUE * val)
 894{
 895  int i;
 896  
 897  if (val != NULL) {
 898     switch (val->type) {
 899
 900     case INTV:
 901       printf ("%ld", val->val.ival);
 902       break;
 903
 904     case SYMV:
 905       prString (val->val.sym);
 906       break;
 907
 908     case STRV:
 909       prString (val->val.str);
 910       break;
 911
 912     case LISTV:
 913        i = 0;
 914        putchar ('(');
 915        while (val != NULL) {
 916          i++;
 917          prValue (evalThunk (val->val.lv.car));
 918          putchar (' ');
 919          val = val->val.lv.cdr;
 920        }
 921        printf (")\n");
 922       break;
 923
 924     case PRIMV:
 925       printf ("<primitive: ");
 926       prName ((int) val->val.prim + 1);
 927       putchar ('>');
 928       break;
 929
 930     case ACLV:
 931       printf ("lambda");
 932       prNL(val->val.acl.fun->exp.abs.vars);
 933       break;
 934
 935     case CLAMV:
 936       printf ("<c-lambda-abstraction>");
 937       break;
 938
 939     case THUNKV:
 940       printf ("...");
 941       break;
 942     }
 943  }
 944}
 945
 946/* lengthVL - return length of VLIST vl      */
 947long
 948lengthVL (VLIST * vl)
 949{
 950  long i = 0;
 951
 952  while (vl != NULL) {
 953    i++;
 954    vl = vl->tail;
 955  }
 956  return i;
 957}
 958
 959/* prVL - print list of values */
 960void
 961prVL (VLIST * vl)
 962{
 963  long i = 0;
 964
 965  putchar ('(');
 966  while (vl != NULL) {
 967    i++;
 968    prValue (evalThunk (vl->head));
 969    putchar (' ');
 970    vl = vl->tail;
 971  }
 972  printf (")\n");
 973}
 974/*****************************************************************
 975 *                        LOAD ABSTRACTION FROM FILE             *
 976 *****************************************************************/
 977
 978/* primitive function load (load abstractions from file) */
 979VALUE *
 980load (VALUE * val)
 981{
 982  char *file;
 983  FILE *fis;
 984  EXP *currp;
 985  VALUE *result;
 986  int ret;
 987
 988  if (val->type == STRV) {
 989    file = nameTable[val->val.str - 1];
 990  }
 991  else {
 992    printf ("load: error in argument type\n");
 993    longjmp (_EXH, 1);
 994  }
 995  fis = fopen (file, "r");
 996  parserinit (fis);
 997
 998  while (1) {
 999    currp = readWithoutPrompt ();
1000    result = evalThunk (eval (currp, globalEnv, trueSym));
1001    if ((result->type == STRV) && (result->val.str == eof)) {
1002      fclose (fis);
1003      break;
1004    }
1005    prValue (result);
1006    //printf (".");
1007  }
1008  parserinit (stdin);
1009  return result;
1010}