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   char c, buf[MAX_CHAR_LENGTH], *res;
 264
 265   c = SOB_CHAR_VALUE(sob);
 266
 267   if (c == ' ') {
 268     sprintf(buf, "#\\space");
 269   }
 270   else if (c == '\n') {
 271     sprintf(buf, "#\\newline");
 272   }
 273   else if (c == '\r') {
 274     sprintf(buf, "#\\return");
 275   }
 276   else if (c == '\f') {
 277     sprintf(buf, "#\\page");
 278   }
 279   else if (c < ' ') {
 280     int o1, o2, o3;
 281
 282     o3 = c % 8; c = c >> 3;
 283     o2 = c % 8; c = c >> 3;
 284     o1 = c % 8; /* not needed; just for good luck :) */
 285     sprintf(buf, "#\\%d%d%d", o1, o2, o3);
 286   }
 287   else {
 288     sprintf(buf, "#\\%c", c);
 289   }
 290
 291   STRING_ALLOC(res, 1 + strlen(buf));
 292   strcpy(res, buf);
 293
 294   return res;
 295 }
 296
 297 #define MAX_BOOLEAN_LENGTH 32
 298
 299 char *sobBoolToString(SchemeObject *sob)
 300 {
 301   char buf[MAX_BOOLEAN_LENGTH], *res;
 302   int b;
 303
 304   b = SOB_BOOL_VALUE(sob);
 305   switch (b) {
 306   case 0: sprintf(buf, "#f"); break;
 307   case 1: sprintf(buf, "#t"); break;
 308   default:
 309     ASSERT_ALWAYS((b != 0) && (b != 1));
 310   }
 311
 312   STRING_ALLOC(res, 1 + strlen(buf));
 313   strcpy(res, buf);
 314
 315   return res;
 316 }
 317
 318 char *sobStringToString(SchemeObject *sob)
 319 {
 320   char *src, *dst, *res;
 321   int srcLen, i, j;
 322
 323   srcLen = SOB_STRING_LENGTH(sob);
 324   src = SOB_STRING_VALUE(sob);
 325   dst = (char *)autoMalloc(1 + (srcLen << 1)); /* max possible dst length */
 326
 327   for (i = 0, j = 0; i < srcLen; ++i) {
 328     switch (src[i]) {
 329     case '\\':
 330       dst[j++] = '\\'; dst[j++] = '\\'; break;
 331     case '"':
 332       dst[j++] = '\\'; dst[j++] = '"'; break;
 333     default:
 334       dst[j++] = src[i];
 335     }
 336   }
 337
 338   dst[j] = '\0';
 339
 340   STRING_ALLOC(res, 3 + strlen(dst));
 341   strcpy(res, "\"");
 342   strcat(res, dst);
 343   strcat(res, "\"");
 344
 345   return res;
 346 }
 347
 348 #define MAX_NIL_LENGTH 32
 349
 350 char *sobNilToString(SchemeObject *sob)
 351 {
 352   char buf[MAX_NIL_LENGTH], *res;
 353
 354   sprintf(buf, "()");
 355
 356   STRING_ALLOC(res, 1 + strlen(buf));
 357   strcpy(res, buf);
 358
 359   return res;
 360 }
 361
 362 char *sobPairToString(SchemeObject *sob)
 363 {
 364   char *tmp1, *tmp2, *res;
 365   SchemeObject *cdr;
 366
 367   tmp1 = sobToString(SOB_PAIR_CAR(sob));
 368   cdr = SOB_PAIR_CDR(sob);
 369   if (IS_SOB_NIL(cdr)) {
 370     STRING_ALLOC(res, 3 + strlen(tmp1));
 371     sprintf(res, "(%s)", tmp1); autoFree(tmp1);
 372   }
 373   else if (IS_SOB_PAIR(cdr)) {
 374     tmp2 = sobToString(cdr);
 375     STRING_ALLOC(res, 3 + strlen(tmp1) + strlen(tmp2));
 376     sprintf(res, "(%s %s", tmp1, tmp2 + 1);
 377   }
 378   else {
 379     tmp2 = sobToString(cdr);
 380     STRING_ALLOC(res, 6 + strlen(tmp1) + strlen(tmp2));
 381     sprintf(res, "(%s . %s)", tmp1, tmp2);
 382     autoFree(tmp1); autoFree(tmp2);
 383   }
 384
 385   return res;
 386 }
 387
 388 #define MAX_VECTOR_TEMP_LENGTH 32
 389
 390 char *sobVectorToString(SchemeObject *sob)
 391 {
 392   char *res, tmp[MAX_VECTOR_TEMP_LENGTH];
 393   int len, i;
 394
 395   len = SOB_VECTOR_LENGTH(sob);
 396   if (len == 0) {
 397     STRING_ALLOC(res, 5);
 398     strcpy(res, "#0()");
 399
 400     return res;
 401   }
 402   else {
 403     char **eltStr;
 404     int resSize;
 405
 406     eltStr = (char **)autoMalloc(len * sizeof(char *));
 407
 408     for (i = 0, resSize = 2 + len; i < len; ++i) {
 409       eltStr[i] = sobToString(SOB_VECTOR_REF(sob, i));
 410       resSize += strlen(eltStr[i]);
 411     }
 412
 413     sprintf(tmp, "#%d(", len);
 414     resSize += strlen(tmp);
 415
 416     STRING_ALLOC(res, resSize);
 417     strcpy(res, tmp);
 418     strcat(res, eltStr[0]); autoFree(eltStr[0]);
 419
 420     for (i = 1; i < len; ++i) {
 421       strcat(res, " ");
 422       strcat(res, eltStr[i]); autoFree(eltStr[i]);
 423     }
 424
 425     autoFree(eltStr);
 426
 427     strcat(res, ")");
 428
 429     return res;
 430   }
 431 }
 432
 433 #define SYMBOL_CHARS "abcdefghijklmnopqrstuvwxyz01234567890!@$%^&*_-+=/?:<>,."
 434
 435 char *sobSymbolToString(SchemeObject *sob)
 436 {
 437   char *res, *tmp; /*, *buf; */
 438   int len, i, isSpecial;
 439
 440
 441   tmp = SOB_SYMBOL_NAME(sob);
 442   len = strlen(tmp);
 443
 444   for (i = 0, isSpecial = 0; i < len; ++i) {
 445     if (strchr(SYMBOL_CHARS, tmp[i]) == NULL) {
 446       isSpecial = 1;
 447       break;
 448     }
 449   }
 450
 451   if (isSpecial) {
 452     STRING_ALLOC(res, 3 + len);
 453     sprintf(res, "|%s|", tmp);
 454   }
 455   else {
 456     STRING_ALLOC(res, 1 + len);
 457     sprintf(res, "%s", tmp);
 458   }
 459
 460   return res;
 461 }
 462
 463 #define CLOSURE_STRING "#<compiled closure>"
 464
 465 char *sobClosureToString(SchemeObject *sob)
 466 {
 467   char *res;
 468
 469   STRING_ALLOC(res, 1 + sizeof(CLOSURE_STRING));
 470   strcpy(res, CLOSURE_STRING);
 471
 472   return res;
 473 }
 474
 475 /* support for the top level; this is not a hash table -- see header
 476  * file for details.
 477  */
 478
 479 SymbolEntry *probeSymbolDefined(char *name, SymbolNode *t)
 480 {
 481   int compare;
 482
 483   if (t == NULL) { return NULL; }
 484
 485   compare = strcmp(name, SYM_NAME(t));
 486   if (compare == 0) {
 487     return SYM_ENTRY(t);
 488   }
 489   else if (compare < 0) {
 490     return probeSymbolDefined(name, SYM_LEFT(t));
 491   }
 492   else {
 493     return probeSymbolDefined(name, SYM_RIGHT(t));
 494   }
 495 }
 496
 497 SymbolNode *newSymbolNode(char *name);
 498
 499 SymbolEntry *getSymbol(char *name, SymbolNode *t)
 500 {
 501   int compare;
 502   SymbolNode *child;
 503
 504   if (t == NULL) {
 505     if (t == topLevel) {
 506       topLevel = newSymbolNode(name);
 507
 508       return SYM_ENTRY(topLevel);
 509     }
 510     else {
 511       ASSERT_ALWAYS(t != NULL);
 512     }
 513   }
 514
 515   compare = strcmp(name, SYM_NAME(t));
 516
 517   if (compare == 0) {
 518     return SYM_ENTRY(t);
 519   }
 520   else if (compare < 0) {
 521     child = SYM_LEFT(t);
 522     if (child == NULL) {
 523       child = newSymbolNode(name);
 524       SYM_LEFT(t) = child;
 525
 526       return SYM_ENTRY(child);
 527     }
 528     else {
 529       return getSymbol(name, child);
 530     }
 531   }
 532   else {
 533     child = SYM_RIGHT(t);
 534     if (child == NULL) {
 535       child = newSymbolNode(name);
 536       SYM_RIGHT(t) = child;
 537
 538       return SYM_ENTRY(child);
 539     }
 540     else {
 541       return getSymbol(name, child);
 542     }
 543   }
 544 }
 545
 546 SymbolNode *newSymbolNode(char *name)
 547 {
 548   SymbolNode *child;
 549
 550   child = (SymbolNode *)autoMalloc(sizeof(SymbolNode));
 551   SYM_ENTRY(child) = (SymbolEntry *)autoMalloc(sizeof(SymbolEntry));
 552   SYM_NAME(child) = (char *)autoMalloc(1 + strlen(name));
 553   strcpy(SYM_NAME(child), name);
 554   SYM_HAS_VALUE(child) = 0;
 555   SYM_VALUE(child) = NULL;
 556   SYM_LEFT(child) = SYM_RIGHT(child) = NULL;
 557
 558   return child;
 559 }
 560
 561 /* The procedures autoMalloc and autoFree are interface procedures:
 562  * They are meant to be used instead of malloc and free, and are to be
 563  * re-defined when the garbage collector is added to the system. Hint:
 564  * autoFree will be defined to do nothing. :)
 565  */
 566 void *autoMalloc(int n)
 567 {
 568   void *tmp;
 569
 570   if (n == 0) {
 571     return NULL;
 572   }
 573   else {
 574     tmp = (void *)malloc(n);
 575     ASSERT_ALWAYS(tmp != NULL);
 576
 577     return tmp;
 578   }
 579 }
 580
 581 void autoFree(void *p)
 582 {
 583   if (p != NULL) {
 584     free(p);
 585   }
 586 }
 587
 588