src/c/scheme.c

   1 /* scheme.c
   2  * The run-time support needed for the Scheme->C compiler.
   3  * Programmer: Mayer Goldberg, 2000
   4  */
   5
   6 #include <stdio.h>
   7 #include <stdlib.h>
   8 #include <string.h>
   9 #include "assertions.h" /* check this out: great for debugging */
  10 #include "scheme.h"
  11
  12 #define STRING_ALLOC(s, n) do { \
  13           s = (char *)autoMalloc((n)*sizeof(char)); \
  14         } while (0)
  15
  16 SchemeObject *makeSchemeObject()
  17 {
  18   SchemeObject *sob;
  19
  20   sob = (SchemeObject *)autoMalloc(sizeof(SchemeObject));
  21   SOB_DATA(sob) = NULL;
  22
  23   return sob;
  24 }
  25
  26 SchemeObject *makeSchemeVoid()
  27 {
  28   SchemeObject *sob;
  29
  30   sob = makeSchemeObject();
  31   SOB_TYPE(sob) = SCHEME_VOID;
  32   SOB_DATA(sob) = NULL;
  33
  34   return sob;
  35 }
  36
  37 SchemeObject *makeSchemeInt(int n)
  38 {
  39   SchemeObject *sob;
  40
  41   sob = makeSchemeObject();
  42   SOB_TYPE(sob) = SCHEME_INT;
  43   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeIntData)));
  44   SOB_INT_VALUE(sob) = n;
  45
  46   return sob;
  47 }
  48
  49 SchemeObject *makeSchemeChar(char c)
  50 {
  51   SchemeObject *sob;
  52
  53   sob = makeSchemeObject();
  54   SOB_TYPE(sob) = SCHEME_CHAR;
  55   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeCharData)));
  56   SOB_CHAR_VALUE(sob) = c;
  57
  58   return sob;
  59 }
  60
  61 SchemeObject *makeSchemeBool(int b)
  62 {
  63   SchemeObject *sob;
  64
  65   sob = makeSchemeObject();
  66   SOB_TYPE(sob) = SCHEME_BOOL;
  67   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeBoolData)));
  68
  69   SOB_BOOL_VALUE(sob) = b;
  70
  71   return sob;
  72 }
  73
  74 SchemeObject *makeSchemeString(int n, char c)
  75 {
  76   SchemeObject *sob;
  77   int i;
  78
  79   ASSERT_ALWAYS(n >= 0,"");
  80
  81   sob = makeSchemeObject();
  82   SOB_TYPE(sob) = SCHEME_STRING;
  83   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeStringData)));
  84
  85   SOB_STRING_LENGTH(sob) = n;
  86   SOB_STRING_VALUE(sob) = (char *)autoMalloc(n + 1);
  87
  88   for (i = 0; i < n; ++i) {
  89     SOB_STRING_SET(sob, i, c);
  90   }
  91
  92   SOB_STRING_SET(sob, n, '\0');
  93
  94   return sob;
  95 }
  96
  97 SchemeObject *makeSchemeStringFromCString(char *s)
  98 {
  99   SchemeObject *sob;
 100
 101   sob = makeSchemeObject();
 102   SOB_TYPE(sob) = SCHEME_STRING;
 103   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeStringData)));
 104
 105   SOB_STRING_LENGTH(sob) = strlen(s);
 106   SOB_STRING_VALUE(sob) = (char *)autoMalloc(1 + SOB_STRING_LENGTH(sob));
 107
 108   strcpy(SOB_STRING_VALUE(sob), s);
 109
 110   return sob;
 111 }
 112
 113 SchemeObject *makeSchemeNil()
 114 {
 115   SchemeObject *sob;
 116
 117   sob = makeSchemeObject();
 118   SOB_TYPE(sob) = SCHEME_NIL;
 119
 120   return sob;
 121 }
 122
 123 SchemeObject *makeSchemePair(SchemeObject *car, SchemeObject *cdr)
 124 {
 125   SchemeObject *sob;
 126
 127   sob = makeSchemeObject();
 128   SOB_TYPE(sob) = SCHEME_PAIR;
 129   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemePairData)));
 130
 131   SOB_PAIR_CAR(sob) = car;
 132   SOB_PAIR_CDR(sob) = cdr;
 133
 134   return sob;
 135 }
 136
 137 SchemeObject *makeSchemeVectorInit(int n, SchemeObject *initSob)
 138 {
 139   SchemeObject *sob;
 140   int i;
 141
 142   ASSERT_ALWAYS(n >= 0,"");
 143
 144   sob = makeSchemeObject();
 145   SOB_TYPE(sob) = SCHEME_VECTOR;
 146   SOB_DATA(sob) = (SchemeObjectData *)autoMalloc(sizeof(SchemeVectorData));
 147
 148   SOB_VECTOR_LENGTH(sob) = n;
 149
 150   SOB_VECTOR_VALUE(sob) =
 151     (SchemeObject **)autoMalloc(n * sizeof(SchemeObject *));
 152
 153   for (i = 0; i < n; ++i) {
 154     SOB_VECTOR_SET(sob, i, initSob);
 155   }
 156
 157   return sob;
 158 }
 159
 160 extern SymbolNode *topLevel;
 161
 162 SchemeObject *makeSchemeSymbol(char *s)
 163 {
 164   int len;
 165   SchemeObject *sob;
 166
 167   len = strlen(s);
 168   ASSERT_ALWAYS(len > 0,"");
 169
 170   sob = makeSchemeObject();
 171   SOB_TYPE(sob) = SCHEME_SYMBOL;
 172   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeSymbolData)));
 173
 174   SOB_SYMBOL_ENTRY(sob) = getSymbol(s, topLevel);
 175
 176   return sob;
 177 }
 178
 179 SchemeObject *makeSchemeClosure(void* env,void* code)
 180 {
 181   SchemeObject *sob;
 182
 183   sob = makeSchemeObject();
 184   ASSERT_ALWAYS( sob!=0,"" );
 185   SOB_TYPE(sob) = SCHEME_CLOSURE;
 186   SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeClosureData)));
 187   ASSERT_ALWAYS( SOB_DATA(sob)!=0,"" );
 188
 189   SOB_CLOSURE_ENV(sob) = env;
 190   SOB_CLOSURE_CODE(sob) = code;
 191
 192   return sob;
 193 }
 194
 195 char *sobVoidToString(SchemeObject *sob);
 196 char *sobIntToString(SchemeObject *sob);
 197 char *sobCharToString(SchemeObject *sob);
 198 char *sobBoolToString(SchemeObject *sob);
 199 char *sobStringToString(SchemeObject *sob);
 200 char *sobNilToString(SchemeObject *sob);
 201 char *sobPairToString(SchemeObject *sob);
 202 char *sobVectorToString(SchemeObject *sob);
 203 char *sobSymbolToString(SchemeObject *sob);
 204 char *sobClosureToString(SchemeObject *sob);
 205
 206 char *sobToString(SchemeObject *sob)
 207 {
 208   SchemeType sobType;
 209
 210   sobType = SOB_TYPE(sob);
 211   switch (sobType) {
 212   case SCHEME_VOID:           return sobVoidToString(sob);
 213   case SCHEME_INT:            return sobIntToString(sob);
 214   case SCHEME_CHAR:           return sobCharToString(sob);
 215   case SCHEME_BOOL:           return sobBoolToString(sob);
 216   case SCHEME_STRING:         return sobStringToString(sob);
 217   case SCHEME_NIL:            return sobNilToString(sob);
 218   case SCHEME_PAIR:           return sobPairToString(sob);
 219   case SCHEME_VECTOR:         return sobVectorToString(sob);
 220   case SCHEME_SYMBOL:         return sobSymbolToString(sob);
 221   case SCHEME_CLOSURE:        return sobClosureToString(sob);
 222   default:
 223     ASSERT_ALWAYS((sobType >= SCHEME_TYPE_FIRST) &&
 224                   (sobType < SCHEME_TYPE_END),"");
 225
 226     fprintf(stderr,
 227             "Non exhaustive switch in file \"%s\", line %d\n",
 228                     __FILE__, __LINE__);
 229             exit(-1);
 230   }
 231 }
 232
 233 #define VOID_PRINT_STRING "#<void object>"
 234
 235 char *sobVoidToString(SchemeObject *sob)
 236 {
 237   char *res;
 238
 239   STRING_ALLOC(res, 1 + sizeof(VOID_PRINT_STRING));
 240   sprintf(res, "%s", VOID_PRINT_STRING);
 241
 242   return res;
 243 }
 244
 245 #define MAX_INTEGER_LENGTH 32
 246
 247 char *sobIntToString(SchemeObject *sob)
 248 {
 249   char buf[MAX_INTEGER_LENGTH], *res;
 250
 251   sprintf(buf, "%d", SOB_INT_VALUE(sob));
 252
 253   STRING_ALLOC(res, 1 + strlen(buf));
 254   strcpy(res, buf);
 255
 256   return res;
 257 }
 258
 259 #define MAX_CHAR_LENGTH 32
 260
 261 char *sobCharToString(SchemeObject *sob)
 262 {
 263   unsigned char c;
 264   char buf[MAX_CHAR_LENGTH], *res;
 265
 266   c = SOB_CHAR_VALUE(sob);
 267
 268   if (c == ' ') {
 269     sprintf(buf, "#\\space");
 270   }
 271   else if (c == '\n') {
 272     sprintf(buf, "#\\newline");
 273   }
 274   else if (c == '\r') {
 275     sprintf(buf, "#\\return");
 276   }
 277   else if (c == '\f') {
 278     sprintf(buf, "#\\page");
 279   }
 280   else if (c == '\0') {
 281     sprintf(buf, "#\\nul");
 282   }
 283   else if (c < ' ') {
 284     unsigned int o1, o2, o3;
 285
 286     o3 = c % 8; c = c >> 3;
 287     o2 = c % 8; c = c >> 3;
 288     o1 = c % 8; /* not needed; just for good luck :) */
 289     sprintf(buf, "#\\%u%u%u", o1, o2, o3);
 290   }
 291   else {
 292     sprintf(buf, "#\\%c", c);
 293   }
 294
 295   STRING_ALLOC(res, 1 + strlen(buf));
 296   strcpy(res, buf);
 297
 298   return res;
 299 }
 300
 301 #define MAX_BOOLEAN_LENGTH 32
 302
 303 char *sobBoolToString(SchemeObject *sob)
 304 {
 305   char buf[MAX_BOOLEAN_LENGTH], *res;
 306   int b;
 307
 308   b = SOB_BOOL_VALUE(sob);
 309   switch (b) {
 310   case 0: sprintf(buf, "#f"); break;
 311   case 1: sprintf(buf, "#t"); break;
 312   default:
 313       ASSERT_ALWAYS((b != 0) && (b != 1),"");
 314   }
 315
 316   STRING_ALLOC(res, 1 + strlen(buf));
 317   strcpy(res, buf);
 318
 319   return res;
 320 }
 321
 322 char *sobStringToString(SchemeObject *sob)
 323 {
 324   char *src, *dst, *res;
 325   int srcLen, i, j;
 326
 327   srcLen = SOB_STRING_LENGTH(sob);
 328   src = SOB_STRING_VALUE(sob);
 329   dst = (char *)autoMalloc(1 + (srcLen << 1)); /* max possible dst length */
 330
 331   for (i = 0, j = 0; i < srcLen; ++i) {
 332     switch (src[i]) {
 333     case '\\':
 334       dst[j++] = '\\'; dst[j++] = '\\'; break;
 335     case '"':
 336       dst[j++] = '\\'; dst[j++] = '"'; break;
 337     default:
 338       dst[j++] = src[i];
 339     }
 340   }
 341
 342   dst[j] = '\0';
 343
 344   STRING_ALLOC(res, 3 + strlen(dst));
 345   strcpy(res, "\"");
 346   strcat(res, dst);
 347   strcat(res, "\"");
 348
 349   return res;
 350 }
 351
 352 #define MAX_NIL_LENGTH 32
 353
 354 char *sobNilToString(SchemeObject *sob)
 355 {
 356   char buf[MAX_NIL_LENGTH], *res;
 357
 358   sprintf(buf, "()");
 359
 360   STRING_ALLOC(res, 1 + strlen(buf));
 361   strcpy(res, buf);
 362
 363   return res;
 364 }
 365
 366 char *sobPairToString(SchemeObject *sob)
 367 {
 368   char *tmp1, *tmp2, *res;
 369   SchemeObject *cdr;
 370
 371   tmp1 = sobToString(SOB_PAIR_CAR(sob));
 372   cdr = SOB_PAIR_CDR(sob);
 373   if (IS_SOB_NIL(cdr)) {
 374     STRING_ALLOC(res, 3 + strlen(tmp1));
 375     sprintf(res, "(%s)", tmp1); autoFree(tmp1);
 376   }
 377   else if (IS_SOB_PAIR(cdr)) {
 378     tmp2 = sobToString(cdr);
 379     STRING_ALLOC(res, 3 + strlen(tmp1) + strlen(tmp2));
 380     sprintf(res, "(%s %s", tmp1, tmp2 + 1);
 381   }
 382   else {
 383     tmp2 = sobToString(cdr);
 384     STRING_ALLOC(res, 6 + strlen(tmp1) + strlen(tmp2));
 385     sprintf(res, "(%s . %s)", tmp1, tmp2);
 386     autoFree(tmp1); autoFree(tmp2);
 387   }
 388
 389   return res;
 390 }
 391
 392 #define MAX_VECTOR_TEMP_LENGTH 32
 393
 394 char *sobVectorToString(SchemeObject *sob)
 395 {
 396   char *res, tmp[MAX_VECTOR_TEMP_LENGTH];
 397   int len, i;
 398
 399   len = SOB_VECTOR_LENGTH(sob);
 400   if (len == 0) {
 401     STRING_ALLOC(res, 5);
 402     strcpy(res, "#0()");
 403
 404     return res;
 405   }
 406   else {
 407     char **eltStr;
 408     int resSize;
 409
 410     eltStr = (char **)autoMalloc(len * sizeof(char *));
 411
 412     for (i = 0, resSize = 2 + len; i < len; ++i) {
 413       eltStr[i] = sobToString(SOB_VECTOR_REF(sob, i));
 414       resSize += strlen(eltStr[i]);
 415     }
 416
 417     sprintf(tmp, "#%d(", len);
 418     resSize += strlen(tmp);
 419
 420     STRING_ALLOC(res, resSize);
 421     strcpy(res, tmp);
 422     strcat(res, eltStr[0]); autoFree(eltStr[0]);
 423
 424     for (i = 1; i < len; ++i) {
 425       strcat(res, " ");
 426       strcat(res, eltStr[i]); autoFree(eltStr[i]);
 427     }
 428
 429     autoFree(eltStr);
 430
 431     strcat(res, ")");
 432
 433     return res;
 434   }
 435 }
 436
 437 #define SYMBOL_CHARS "abcdefghijklmnopqrstuvwxyz01234567890!@$%^&*_-+=/?:<>,."
 438
 439 char *sobSymbolToString(SchemeObject *sob)
 440 {
 441   char *res, *tmp; /*, *buf; */
 442   int len, i, isSpecial;
 443
 444
 445   tmp = SOB_SYMBOL_NAME(sob);
 446   len = strlen(tmp);
 447
 448   for (i = 0, isSpecial = 0; i < len; ++i) {
 449     if (strchr(SYMBOL_CHARS, tmp[i]) == NULL) {
 450       isSpecial = 1;
 451       break;
 452     }
 453   }
 454
 455   if (isSpecial) {
 456     STRING_ALLOC(res, 3 + len);
 457     sprintf(res, "|%s|", tmp);
 458   }
 459   else {
 460     STRING_ALLOC(res, 1 + len);
 461     sprintf(res, "%s", tmp);
 462   }
 463
 464   return res;
 465 }
 466
 467 #define CLOSURE_STRING "#<compiled closure>"
 468
 469 char *sobClosureToString(SchemeObject *sob)
 470 {
 471   char *res;
 472
 473   STRING_ALLOC(res, 1 + sizeof(CLOSURE_STRING));
 474   strcpy(res, CLOSURE_STRING);
 475
 476   return res;
 477 }
 478
 479 /* support for the top level; this is not a hash table -- see header
 480  * file for details.
 481  */
 482
 483 SymbolEntry *probeSymbolDefined(char *name, SymbolNode *t)
 484 {
 485   int compare;
 486
 487   if (t == NULL) { return NULL; }
 488
 489   compare = strcmp(name, SYM_NAME(t));
 490   if (compare == 0) {
 491     return SYM_ENTRY(t);
 492   }
 493   else if (compare < 0) {
 494     return probeSymbolDefined(name, SYM_LEFT(t));
 495   }
 496   else {
 497     return probeSymbolDefined(name, SYM_RIGHT(t));
 498   }
 499 }
 500
 501 SymbolNode *newSymbolNode(char *name);
 502
 503 SymbolEntry *getSymbol(char *name, SymbolNode *t)
 504 {
 505   int compare;
 506   SymbolNode *child;
 507
 508   if (t == NULL) {
 509     if (t == topLevel) {
 510       topLevel = newSymbolNode(name);
 511
 512       return SYM_ENTRY(topLevel);
 513     }
 514     else {
 515         ASSERT_ALWAYS(t != NULL,"");
 516     }
 517   }
 518
 519   compare = strcmp(name, SYM_NAME(t));
 520
 521   if (compare == 0) {
 522     return SYM_ENTRY(t);
 523   }
 524   else if (compare < 0) {
 525     child = SYM_LEFT(t);
 526     if (child == NULL) {
 527       child = newSymbolNode(name);
 528       SYM_LEFT(t) = child;
 529
 530       return SYM_ENTRY(child);
 531     }
 532     else {
 533       return getSymbol(name, child);
 534     }
 535   }
 536   else {
 537     child = SYM_RIGHT(t);
 538     if (child == NULL) {
 539       child = newSymbolNode(name);
 540       SYM_RIGHT(t) = child;
 541
 542       return SYM_ENTRY(child);
 543     }
 544     else {
 545       return getSymbol(name, child);
 546     }
 547   }
 548 }
 549
 550 SymbolNode *newSymbolNode(char *name)
 551 {
 552   SymbolNode *child;
 553
 554   child = (SymbolNode *)autoMalloc(sizeof(SymbolNode));
 555   SYM_ENTRY(child) = (SymbolEntry *)autoMalloc(sizeof(SymbolEntry));
 556   SYM_NAME(child) = (char *)autoMalloc(1 + strlen(name));
 557   strcpy(SYM_NAME(child), name);
 558   SYM_HAS_VALUE(child) = 0;
 559   SYM_VALUE(child) = NULL;
 560   SYM_LEFT(child) = SYM_RIGHT(child) = NULL;
 561
 562   return child;
 563 }
 564
 565 /* The procedures autoMalloc and autoFree are interface procedures:
 566  * They are meant to be used instead of malloc and free, and are to be
 567  * re-defined when the garbage collector is added to the system. Hint:
 568  * autoFree will be defined to do nothing. :)
 569  */
 570 void *autoMalloc(int n)
 571 {
 572   void *tmp;
 573
 574   if (n == 0) {
 575     return NULL;
 576   }
 577   else {
 578     tmp = (void *)malloc(n);
 579     ASSERT_ALWAYS(tmp != NULL,"");
 580
 581     return tmp;
 582   }
 583 }
 584
 585 void autoFree(void *p)
 586 {
 587   if (p != NULL) {
 588     free(p);
 589   }
 590 }
 591
 592