added some builtins, fixed string-constant generation (it led to seg-fault on string...
[bugg-scheme-compiler.git] / src / c / scheme.c
blobe5f57c55e99fe51cb93fb32b332e1b6deb680a66
1 /* scheme.c
2 * The run-time support needed for the Scheme->C compiler.
3 * Programmer: Mayer Goldberg, 2000
4 */
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"
12 #define STRING_ALLOC(s, n) do { \
13 s = (char *)autoMalloc((n)*sizeof(char)); \
14 } while (0)
16 SchemeObject *makeSchemeObject()
18 SchemeObject *sob;
20 sob = (SchemeObject *)autoMalloc(sizeof(SchemeObject));
21 SOB_DATA(sob) = NULL;
23 return sob;
26 SchemeObject *makeSchemeVoid()
28 SchemeObject *sob;
30 sob = makeSchemeObject();
31 SOB_TYPE(sob) = SCHEME_VOID;
32 SOB_DATA(sob) = NULL;
34 return sob;
37 SchemeObject *makeSchemeInt(int n)
39 SchemeObject *sob;
41 sob = makeSchemeObject();
42 SOB_TYPE(sob) = SCHEME_INT;
43 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeIntData)));
44 SOB_INT_VALUE(sob) = n;
46 return sob;
49 SchemeObject *makeSchemeChar(char c)
51 SchemeObject *sob;
53 sob = makeSchemeObject();
54 SOB_TYPE(sob) = SCHEME_CHAR;
55 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeCharData)));
56 SOB_CHAR_VALUE(sob) = c;
58 return sob;
61 SchemeObject *makeSchemeBool(int b)
63 SchemeObject *sob;
65 sob = makeSchemeObject();
66 SOB_TYPE(sob) = SCHEME_BOOL;
67 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeBoolData)));
69 SOB_BOOL_VALUE(sob) = b;
71 return sob;
74 SchemeObject *makeSchemeString(int n, char c)
76 SchemeObject *sob;
77 int i;
79 ASSERT_ALWAYS(n >= 0,"");
81 sob = makeSchemeObject();
82 SOB_TYPE(sob) = SCHEME_STRING;
83 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeStringData)));
85 SOB_STRING_LENGTH(sob) = n;
86 SOB_STRING_VALUE(sob) = (char *)autoMalloc(n + 1);
88 for (i = 0; i < n; ++i) {
89 SOB_STRING_SET(sob, i, c);
92 SOB_STRING_SET(sob, n, '\0');
94 return sob;
97 SchemeObject *makeSchemeStringFromCString(char *s)
99 SchemeObject *sob;
101 sob = makeSchemeObject();
102 SOB_TYPE(sob) = SCHEME_STRING;
103 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeStringData)));
105 SOB_STRING_LENGTH(sob) = strlen(s);
106 SOB_STRING_VALUE(sob) = (char *)autoMalloc(1 + SOB_STRING_LENGTH(sob));
108 strcpy(SOB_STRING_VALUE(sob), s);
110 return sob;
113 SchemeObject *makeSchemeNil()
115 SchemeObject *sob;
117 sob = makeSchemeObject();
118 SOB_TYPE(sob) = SCHEME_NIL;
120 return sob;
123 SchemeObject *makeSchemePair(SchemeObject *car, SchemeObject *cdr)
125 SchemeObject *sob;
127 sob = makeSchemeObject();
128 SOB_TYPE(sob) = SCHEME_PAIR;
129 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemePairData)));
131 SOB_PAIR_CAR(sob) = car;
132 SOB_PAIR_CDR(sob) = cdr;
134 return sob;
137 SchemeObject *makeSchemeVectorInit(int n, SchemeObject *initSob)
139 SchemeObject *sob;
140 int i;
142 ASSERT_ALWAYS(n >= 0,"");
144 sob = makeSchemeObject();
145 SOB_TYPE(sob) = SCHEME_VECTOR;
146 SOB_DATA(sob) = (SchemeObjectData *)autoMalloc(sizeof(SchemeVectorData));
148 SOB_VECTOR_LENGTH(sob) = n;
150 SOB_VECTOR_VALUE(sob) =
151 (SchemeObject **)autoMalloc(n * sizeof(SchemeObject *));
153 for (i = 0; i < n; ++i) {
154 SOB_VECTOR_SET(sob, i, initSob);
157 return sob;
160 extern SymbolNode *topLevel;
162 SchemeObject *makeSchemeSymbol(char *s)
164 int len;
165 SchemeObject *sob;
167 len = strlen(s);
168 ASSERT_ALWAYS(len > 0,"");
170 sob = makeSchemeObject();
171 SOB_TYPE(sob) = SCHEME_SYMBOL;
172 SOB_DATA(sob) = SOD(autoMalloc(sizeof(SchemeSymbolData)));
174 SOB_SYMBOL_ENTRY(sob) = getSymbol(s, topLevel);
176 return sob;
179 SchemeObject *makeSchemeClosure(void* env,void* code)
181 SchemeObject *sob;
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,"" );
189 SOB_CLOSURE_ENV(sob) = env;
190 SOB_CLOSURE_CODE(sob) = code;
192 return sob;
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);
206 char *sobToString(SchemeObject *sob)
208 SchemeType sobType;
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),"");
226 fprintf(stderr,
227 "Non exhaustive switch in file \"%s\", line %d\n",
228 __FILE__, __LINE__);
229 exit(-1);
233 #define VOID_PRINT_STRING "#<void object>"
235 char *sobVoidToString(SchemeObject *sob)
237 char *res;
239 STRING_ALLOC(res, 1 + sizeof(VOID_PRINT_STRING));
240 sprintf(res, "%s", VOID_PRINT_STRING);
242 return res;
245 #define MAX_INTEGER_LENGTH 32
247 char *sobIntToString(SchemeObject *sob)
249 char buf[MAX_INTEGER_LENGTH], *res;
251 sprintf(buf, "%d", SOB_INT_VALUE(sob));
253 STRING_ALLOC(res, 1 + strlen(buf));
254 strcpy(res, buf);
256 return res;
259 #define MAX_CHAR_LENGTH 32
261 char *sobCharToString(SchemeObject *sob)
263 unsigned char c;
264 char buf[MAX_CHAR_LENGTH], *res;
266 c = SOB_CHAR_VALUE(sob);
268 if (c == ' ') {
269 sprintf(buf, "#\\space");
271 else if (c == '\n') {
272 sprintf(buf, "#\\newline");
274 else if (c == '\r') {
275 sprintf(buf, "#\\return");
277 else if (c == '\f') {
278 sprintf(buf, "#\\page");
280 else if (c == '\0') {
281 sprintf(buf, "#\\nul");
283 else if (c < ' ') {
284 unsigned int o1, o2, o3;
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);
291 else {
292 sprintf(buf, "#\\%c", c);
295 STRING_ALLOC(res, 1 + strlen(buf));
296 strcpy(res, buf);
298 return res;
301 #define MAX_BOOLEAN_LENGTH 32
303 char *sobBoolToString(SchemeObject *sob)
305 char buf[MAX_BOOLEAN_LENGTH], *res;
306 int b;
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),"");
316 STRING_ALLOC(res, 1 + strlen(buf));
317 strcpy(res, buf);
319 return res;
322 char *sobStringToString(SchemeObject *sob)
324 char *src, *dst, *res;
325 int srcLen, i, j;
327 srcLen = SOB_STRING_LENGTH(sob);
328 src = SOB_STRING_VALUE(sob);
329 dst = (char *)autoMalloc(1 + (srcLen << 1)); /* max possible dst length */
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];
342 dst[j] = '\0';
344 STRING_ALLOC(res, 3 + strlen(dst));
345 strcpy(res, "\"");
346 strcat(res, dst);
347 strcat(res, "\"");
349 return res;
352 #define MAX_NIL_LENGTH 32
354 char *sobNilToString(SchemeObject *sob)
356 char buf[MAX_NIL_LENGTH], *res;
358 sprintf(buf, "()");
360 STRING_ALLOC(res, 1 + strlen(buf));
361 strcpy(res, buf);
363 return res;
366 char *sobPairToString(SchemeObject *sob)
368 char *tmp1, *tmp2, *res;
369 SchemeObject *cdr;
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);
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);
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);
389 return res;
392 #define MAX_VECTOR_TEMP_LENGTH 32
394 char *sobVectorToString(SchemeObject *sob)
396 char *res, tmp[MAX_VECTOR_TEMP_LENGTH];
397 int len, i;
399 len = SOB_VECTOR_LENGTH(sob);
400 if (len == 0) {
401 STRING_ALLOC(res, 5);
402 strcpy(res, "#0()");
404 return res;
406 else {
407 char **eltStr;
408 int resSize;
410 eltStr = (char **)autoMalloc(len * sizeof(char *));
412 for (i = 0, resSize = 2 + len; i < len; ++i) {
413 eltStr[i] = sobToString(SOB_VECTOR_REF(sob, i));
414 resSize += strlen(eltStr[i]);
417 sprintf(tmp, "#%d(", len);
418 resSize += strlen(tmp);
420 STRING_ALLOC(res, resSize);
421 strcpy(res, tmp);
422 strcat(res, eltStr[0]); autoFree(eltStr[0]);
424 for (i = 1; i < len; ++i) {
425 strcat(res, " ");
426 strcat(res, eltStr[i]); autoFree(eltStr[i]);
429 autoFree(eltStr);
431 strcat(res, ")");
433 return res;
437 #define SYMBOL_CHARS "abcdefghijklmnopqrstuvwxyz01234567890!@$%^&*_-+=/?:<>,."
439 char *sobSymbolToString(SchemeObject *sob)
441 char *res, *tmp; /*, *buf; */
442 int len, i, isSpecial;
445 tmp = SOB_SYMBOL_NAME(sob);
446 len = strlen(tmp);
448 for (i = 0, isSpecial = 0; i < len; ++i) {
449 if (strchr(SYMBOL_CHARS, tmp[i]) == NULL) {
450 isSpecial = 1;
451 break;
455 if (isSpecial) {
456 STRING_ALLOC(res, 3 + len);
457 sprintf(res, "|%s|", tmp);
459 else {
460 STRING_ALLOC(res, 1 + len);
461 sprintf(res, "%s", tmp);
464 return res;
467 #define CLOSURE_STRING "#<compiled closure>"
469 char *sobClosureToString(SchemeObject *sob)
471 char *res;
473 STRING_ALLOC(res, 1 + sizeof(CLOSURE_STRING));
474 strcpy(res, CLOSURE_STRING);
476 return res;
479 /* support for the top level; this is not a hash table -- see header
480 * file for details.
483 SymbolEntry *probeSymbolDefined(char *name, SymbolNode *t)
485 int compare;
487 if (t == NULL) { return NULL; }
489 compare = strcmp(name, SYM_NAME(t));
490 if (compare == 0) {
491 return SYM_ENTRY(t);
493 else if (compare < 0) {
494 return probeSymbolDefined(name, SYM_LEFT(t));
496 else {
497 return probeSymbolDefined(name, SYM_RIGHT(t));
501 SymbolNode *newSymbolNode(char *name);
503 SymbolEntry *getSymbol(char *name, SymbolNode *t)
505 int compare;
506 SymbolNode *child;
508 if (t == NULL) {
509 if (t == topLevel) {
510 topLevel = newSymbolNode(name);
512 return SYM_ENTRY(topLevel);
514 else {
515 ASSERT_ALWAYS(t != NULL,"");
519 compare = strcmp(name, SYM_NAME(t));
521 if (compare == 0) {
522 return SYM_ENTRY(t);
524 else if (compare < 0) {
525 child = SYM_LEFT(t);
526 if (child == NULL) {
527 child = newSymbolNode(name);
528 SYM_LEFT(t) = child;
530 return SYM_ENTRY(child);
532 else {
533 return getSymbol(name, child);
536 else {
537 child = SYM_RIGHT(t);
538 if (child == NULL) {
539 child = newSymbolNode(name);
540 SYM_RIGHT(t) = child;
542 return SYM_ENTRY(child);
544 else {
545 return getSymbol(name, child);
550 SymbolNode *newSymbolNode(char *name)
552 SymbolNode *child;
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;
562 return child;
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. :)
570 void *autoMalloc(int n)
572 void *tmp;
574 if (n == 0) {
575 return NULL;
577 else {
578 tmp = (void *)malloc(n);
579 ASSERT_ALWAYS(tmp != NULL,"");
581 return tmp;
585 void autoFree(void *p)
587 if (p != NULL) {
588 free(p);