PageRenderTime 26ms CodeModel.GetById 2ms app.highlight 20ms RepoModel.GetById 1ms app.codeStats 0ms

/a++/appc/arsclib.c

https://github.com/pib/500pl
C | 553 lines | 399 code | 95 blank | 59 comment | 38 complexity | 37b03d55d1689b590116679b759fbc8c 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
 50/* newVAL - make a value (evaluated expression)  */
 51VALUE *
 52newVAL (VTYPE t)
 53{
 54  VALUE *val;
 55
 56  val = (VALUE *) GC_malloc (sizeof (VALUE));
 57  val->type = t;
 58  return val;
 59}
 60
 61
 62/* newLISTV - represent a value list as a value   */
 63VALUE *
 64newLISTV (VLIST *vl)
 65{
 66  VALUE *val;
 67
 68  if (vl) {
 69     val = (VALUE *) GC_malloc (sizeof (VALUE));
 70     val->type = LISTV;
 71     val->val.lv.car = vl->head;
 72     val->val.lv.cdr = newLISTV(vl->tail);
 73     return val;
 74  }
 75  else {
 76     return NULL;
 77  }
 78}
 79
 80
 81/* newPRIMV - make a primitive value */
 82VALUE *
 83newPRIMV (PRIM prim)
 84{
 85  VALUE *result;
 86
 87  result = (VALUE *) GC_malloc (sizeof (VALUE));
 88  result->type = PRIMV;
 89  result->val.prim = prim;
 90  return result;
 91}
 92
 93
 94/* newSTRV- make a string value */
 95VALUE *
 96newSTRV(NAME nm)
 97{
 98  VALUE *result;
 99
100  result = (VALUE *) GC_malloc (sizeof (VALUE));
101  result->type = STRV;
102  result->val.str = nm;
103  return result;
104}
105
106/* newSYMV- make a symbol value */
107VALUE *
108newSYMV(NAME nm)
109{
110  VALUE *result;
111
112  result = (VALUE *) GC_malloc (sizeof (VALUE));
113  result->type = SYMV;
114  result->val.sym = nm;
115  return result;
116}
117
118/* newINTV- make an integer value */
119VALUE *
120newINTV (int i)
121{
122  VALUE *result;
123
124  result = (VALUE *) GC_malloc (sizeof (VALUE));
125  result->type = INTV;
126  result->val.ival = i;
127  return result;
128}
129
130
131/* newACLV- make an ars-closure */
132VALUE *
133newACLV (EXP * fun, ENV * env)
134{
135  VALUE *result;
136
137  result = (VALUE *) GC_malloc (sizeof (VALUE));
138  result->type = ACLV;
139  result->val.acl.fun = fun;
140  result->val.acl.env = env;
141  return result;
142}
143
144/* newCLAMV- make a c-lambda abstraction  */
145VALUE *
146newCLAMV (NLIST * vars, LFUN lfun, ENV *env)
147{
148  VALUE *cl;
149
150  cl = (VALUE *) GC_malloc (sizeof (VALUE));
151  cl->type = CLAMV;
152  cl->val.clam.vars = vars;
153  cl->val.clam.lfun = lfun;
154  cl->val.clam.env = env;
155  return cl;
156}
157
158
159/* ncons - make a list of names */
160NLIST *
161ncons (NAME nm, NLIST * nl)
162{
163  NLIST *newnl;
164
165  newnl = (NLIST *) GC_malloc (sizeof (NLIST));
166  newnl->head = nm;
167  newnl->tail = nl;
168  return newnl;
169}
170
171
172/* vcons - make a list of values */
173VLIST *
174vcons (VALUE * val, VLIST * vl)
175{
176  VLIST *newvl;
177
178  newvl = (VLIST *) GC_malloc (sizeof (VLIST));
179  newvl->head = val;
180  newvl->tail = vl;
181  return newvl;
182}
183
184/* cons - make a list of values */
185VALUE *
186cons (VALUE * hd, VALUE * tl)
187{
188  VALUE *newvl;
189
190  newvl = (VALUE *) GC_malloc (sizeof (VALUE));
191  newvl->type = LISTV;
192  newvl->val.lv.car = hd;
193  newvl->val.lv.cdr = tl;
194  return newvl;
195}
196
197
198/* newENV - make an environment */
199ENV *
200newENV (NLIST * nl, VLIST * vl, ENV * env)
201{
202  ENV *newenv;
203
204  newenv = (ENV *) GC_malloc (sizeof (ENV));
205  newenv->vars = nl;
206  newenv->values = vl;
207  newenv->next = env;
208  return newenv;
209}
210
211
212/*****************************************************************
213 *                     NAMES OF VARIABLES                        *
214 *****************************************************************/
215
216/* initNames - place all pre-defined names into nameTable       */
217void
218initNames ()
219{
220  long i = 1;
221
222  nameTable[i - 1] = "define";
223  i++;
224  nameTable[i - 1] = "incr";
225  i++;
226  nameTable[i - 1] = "+";
227  i++;
228  nameTable[i - 1] = "-";
229  i++;
230  nameTable[i - 1] = "*";
231  i++;
232  nameTable[i - 1] = "/";
233  i++;
234  nameTable[i - 1] = "print";
235  i++;
236  nameTable[i - 1] = "load";
237  i++;
238  nameTable[i - 1] = "equal";
239  i++;
240  nameTable[i - 1] = ">=";
241  i++;
242  nameTable[i - 1] = "<";
243  i++;
244  nameTable[i - 1] = "quit";
245  i++;
246  nameTable[i - 1] = "false";
247  i++;
248  nameTable[i - 1] = "true";
249  numNames = i;
250}
251
252
253
254/* defName - insert new name into nameTable                     */
255NAME
256defName (char *nm)
257{
258  long i = 1;
259  int found = false;
260
261  while (i <= numNames && !found) {
262    if (!strcmp (nm, nameTable[i - 1]))
263      found = true;
264    else
265      i++;
266  }
267  if (found)
268    return i;
269  if (i > MAX_NAMES) {
270    printf ("No more room for names\n");
271    longjmp (_EXH, 1);
272  }
273  numNames = i;
274  nameTable[i - 1] = nm;
275  return i;
276}
277
278
279/* prName - print name nm  */
280void
281prName (NAME nm)
282{
283  printf ("%s", nameTable[nm - 1]);
284}
285
286
287/* prString - print string nm (strings are handled like symbols ) */
288void
289prString (NAME nm)
290{
291  printf ("%s", nameTable[nm - 1]);
292}
293
294/* lengthNL - return length of NLIST nl      */
295long
296lengthNL (NLIST * nl)
297{
298  long i = 0;
299
300  while (nl != NULL) {
301    i++;
302    nl = nl->tail;
303  }
304  return i;
305}
306
307/* prNL - print list of names */
308void
309prNL (NLIST * nl)
310{
311  long i = 0;
312
313  putchar ('(');
314  while (nl != NULL) {
315    i++;
316    prName (nl->head);
317    nl = nl->tail;
318    if (nl != NULL) {
319       putchar (' ');
320    }
321  }
322  printf (")\n");
323}
324
325
326/*****************************************************************
327 *                     VARIABLES AND ENVIRONMENTS                *
328 *****************************************************************/
329
330/* emptyEnv - return an environment with no bindings             */
331ENV *
332emptyEnv ()
333{
334  return (newENV (NULL, NULL, NULL));
335}
336
337
338/* defVar - bind variable nm to value val in environment env      */
339void
340defVar (NAME nm, VALUE * val, ENV * env)
341{
342  env->vars = ncons (nm, env->vars);
343  env->values = vcons (val, env->values);
344}
345
346/* setVar - set variable nm to value val in env                 */
347void
348setVar (NAME nm, VALUE * val, ENV * env)
349{
350  VLIST *vl;
351
352  vl = bindingInEnv (nm, env);
353  if (vl) {
354     vl->head = val;
355  }
356  else {
357     printf("variable not defined: ");
358     prName(nm);
359     printf("\n");
360  }
361}
362
363/* getVar - return VAL bound to nm in env                        */
364VALUE *
365getVar (NAME nm, ENV * env)
366{
367  VLIST *vl;
368
369  vl = bindingInEnv (nm, env);
370  if (vl)
371     return (vl->head);
372  else
373     return falseValue;
374}
375
376/*  extendEnv - extend environment env by binding vars to vals   */
377ENV *
378extendEnv (ENV * env, NLIST * vars, VLIST * vals)
379{
380  return (newENV (vars, vals, env));
381}
382
383
384/* bindingInFrame - look up nm in one frame                      */
385VLIST *
386bindingInFrame (NLIST * nl, VLIST * vl, NAME nm)
387{
388  int found = false;
389
390  while (nl != NULL && !found) {
391    if (nl->head == nm)
392      found = true;
393    else {
394      nl = nl->tail;
395      vl = vl->tail;
396    }
397  }
398  return vl;
399}
400
401
402/* bindingInEnv - look up nm in env                                   */
403VLIST *
404bindingInEnv (NAME nm, ENV * env)
405{
406  VLIST *vl;
407
408  do {
409    vl = bindingInFrame (env->vars, env->values, nm);
410    env = env->next;
411  } while (vl == NULL && env != NULL);
412  return vl;
413}
414
415
416/* isBound - check if nm is bound in env                         */
417int
418isBound (NAME nm, ENV * env)
419{
420  return (bindingInEnv (nm, env) != NULL);
421}
422
423/* initGlobalEnv - initialize global environment */
424void
425initGlobalEnv ()
426{
427  PRIM op;
428
429  false = 0;
430  true = 1;
431  falseValue = newVAL (SYMV);
432  trueValue = newVAL (SYMV);
433  falseValue->val.sym = defName("false");
434  trueValue->val.sym = defName("true");
435  globalEnv = emptyEnv ();
436  setVal->val.ival = 0;
437  defVar (setName, setVal, globalEnv);
438
439  eof = defName (strdup ("*eof*"));
440  lambda = defName (strdup ("lambda"));
441}
442
443/*****************************************************************
444 *                     EVALUATION  AND VALUES                    *
445 *****************************************************************/
446
447
448/* apply - apply c-closure to arguments */
449VALUE *
450apply (VALUE * cl, VLIST * args)
451{
452  LFUN lfun;
453  NLIST *names;
454  ENV *savedenv, *newenv;
455
456  savedenv = cl->val.clam.env;
457  names = cl->val.clam.vars;
458  lfun = cl->val.clam.lfun;
459  if (lengthNL (names) != lengthVL (args)) {
460    printf ("Wrong number of arguments to closure\n");
461    printf ("names\n");
462    prNL (names);
463    printf ("arguments\n");
464    prVL (args);
465    longjmp (_EXH, 1);
466  }
467  newenv = extendEnv (savedenv, names, args);
468  return (lfun(newenv));
469}
470
471/* prValue - print value  val                                */
472void
473prValue (VALUE * val)
474{
475  int i;
476  
477  if (val != NULL) {
478     switch (val->type) {
479
480     case INTV:
481       printf ("%ld", val->val.ival);
482       break;
483
484     case SYMV:
485       prString (val->val.sym);
486       break;
487
488     case STRV:
489       prString (val->val.str);
490       break;
491
492     case LISTV:
493        i = 0;
494        putchar ('(');
495        while (val != NULL) {
496          i++;
497          prValue (val->val.lv.car);
498          putchar (' ');
499          val = val->val.lv.cdr;
500        }
501        printf (")\n");
502       break;
503
504     case PRIMV:
505       printf ("<primitive: ");
506       prName ((int) val->val.prim + 1);
507       putchar ('>');
508       break;
509
510     case ACLV:
511       printf ("lambda");
512       prNL(val->val.acl.fun->exp.abs.vars);
513       break;
514
515     case CLAMV:
516       printf ("<c-lambda-abstraction>");
517       break;
518
519     case THUNKV:
520       printf ("...");
521       break;
522     }
523  }
524}
525
526/* lengthVL - return length of VLIST vl      */
527long
528lengthVL (VLIST * vl)
529{
530  long i = 0;
531
532  while (vl != NULL) {
533    i++;
534    vl = vl->tail;
535  }
536  return i;
537}
538
539/* prVL - print list of values */
540void
541prVL (VLIST * vl)
542{
543  long i = 0;
544
545  putchar ('(');
546  while (vl != NULL) {
547    i++;
548    prValue (vl->head);
549    putchar (' ');
550    vl = vl->tail;
551  }
552  printf (")\n");
553}