2 * The run-time support needed for the Scheme->C compiler.
3 * Programmer: Mayer Goldberg, 2000
9 #include "assertions.h" /* check this out: great for debugging */
12 #define STRING_ALLOC(s, n) do { \
13 s = (char *)autoMalloc((n)*sizeof(char)); \
16 SchemeObject
*makeSchemeObject()
20 sob
= (SchemeObject
*)autoMalloc(sizeof(SchemeObject
));
26 SchemeObject
*makeSchemeVoid()
30 sob
= makeSchemeObject();
31 SOB_TYPE(sob
) = SCHEME_VOID
;
37 SchemeObject
*makeSchemeInt(int n
)
41 sob
= makeSchemeObject();
42 SOB_TYPE(sob
) = SCHEME_INT
;
43 SOB_DATA(sob
) = SOD(autoMalloc(sizeof(SchemeIntData
)));
44 SOB_INT_VALUE(sob
) = n
;
49 SchemeObject
*makeSchemeChar(char c
)
53 sob
= makeSchemeObject();
54 SOB_TYPE(sob
) = SCHEME_CHAR
;
55 SOB_DATA(sob
) = SOD(autoMalloc(sizeof(SchemeCharData
)));
56 SOB_CHAR_VALUE(sob
) = c
;
61 SchemeObject
*makeSchemeBool(int b
)
65 sob
= makeSchemeObject();
66 SOB_TYPE(sob
) = SCHEME_BOOL
;
67 SOB_DATA(sob
) = SOD(autoMalloc(sizeof(SchemeBoolData
)));
69 SOB_BOOL_VALUE(sob
) = b
;
74 SchemeObject
*makeSchemeString(int n
, char c
)
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');
97 SchemeObject
*makeSchemeStringFromCString(char *s
)
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
);
113 SchemeObject
*makeSchemeNil()
117 sob
= makeSchemeObject();
118 SOB_TYPE(sob
) = SCHEME_NIL
;
123 SchemeObject
*makeSchemePair(SchemeObject
*car
, SchemeObject
*cdr
)
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
;
137 SchemeObject
*makeSchemeVectorInit(int n
, SchemeObject
*initSob
)
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
);
160 extern SymbolNode
*topLevel
;
162 SchemeObject
*makeSchemeSymbol(char *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
);
179 SchemeObject
*makeSchemeClosure(void* env
,void* code
)
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
;
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
)
210 sobType
= SOB_TYPE(sob
);
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
);
223 ASSERT_ALWAYS((sobType
>= SCHEME_TYPE_FIRST
) &&
224 (sobType
< SCHEME_TYPE_END
),"");
227 "Non exhaustive switch in file \"%s\", line %d\n",
233 #define VOID_PRINT_STRING "#<void object>"
235 char *sobVoidToString(SchemeObject
*sob
)
239 STRING_ALLOC(res
, 1 + sizeof(VOID_PRINT_STRING
));
240 sprintf(res
, "%s", VOID_PRINT_STRING
);
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
));
259 #define MAX_CHAR_LENGTH 32
261 char *sobCharToString(SchemeObject
*sob
)
264 char buf
[MAX_CHAR_LENGTH
], *res
;
266 c
= SOB_CHAR_VALUE(sob
);
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");
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
);
292 sprintf(buf
, "#\\%c", c
);
295 STRING_ALLOC(res
, 1 + strlen(buf
));
301 #define MAX_BOOLEAN_LENGTH 32
303 char *sobBoolToString(SchemeObject
*sob
)
305 char buf
[MAX_BOOLEAN_LENGTH
], *res
;
308 b
= SOB_BOOL_VALUE(sob
);
310 case 0: sprintf(buf
, "#f"); break;
311 case 1: sprintf(buf
, "#t"); break;
313 ASSERT_ALWAYS((b
!= 0) && (b
!= 1),"");
316 STRING_ALLOC(res
, 1 + strlen(buf
));
322 char *sobStringToString(SchemeObject
*sob
)
324 char *src
, *dst
, *res
;
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
) {
334 dst
[j
++] = '\\'; dst
[j
++] = '\\'; break;
336 dst
[j
++] = '\\'; dst
[j
++] = '"'; break;
344 STRING_ALLOC(res
, 3 + strlen(dst
));
352 #define MAX_NIL_LENGTH 32
354 char *sobNilToString(SchemeObject
*sob
)
356 char buf
[MAX_NIL_LENGTH
], *res
;
360 STRING_ALLOC(res
, 1 + strlen(buf
));
366 char *sobPairToString(SchemeObject
*sob
)
368 char *tmp1
, *tmp2
, *res
;
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);
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
);
392 #define MAX_VECTOR_TEMP_LENGTH 32
394 char *sobVectorToString(SchemeObject
*sob
)
396 char *res
, tmp
[MAX_VECTOR_TEMP_LENGTH
];
399 len
= SOB_VECTOR_LENGTH(sob
);
401 STRING_ALLOC(res
, 5);
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
);
422 strcat(res
, eltStr
[0]); autoFree(eltStr
[0]);
424 for (i
= 1; i
< len
; ++i
) {
426 strcat(res
, eltStr
[i
]); autoFree(eltStr
[i
]);
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
);
448 for (i
= 0, isSpecial
= 0; i
< len
; ++i
) {
449 if (strchr(SYMBOL_CHARS
, tmp
[i
]) == NULL
) {
456 STRING_ALLOC(res
, 3 + len
);
457 sprintf(res
, "|%s|", tmp
);
460 STRING_ALLOC(res
, 1 + len
);
461 sprintf(res
, "%s", tmp
);
467 #define CLOSURE_STRING "#<compiled closure>"
469 char *sobClosureToString(SchemeObject
*sob
)
473 STRING_ALLOC(res
, 1 + sizeof(CLOSURE_STRING
));
474 strcpy(res
, CLOSURE_STRING
);
479 /* support for the top level; this is not a hash table -- see header
483 SymbolEntry
*probeSymbolDefined(char *name
, SymbolNode
*t
)
487 if (t
== NULL
) { return NULL
; }
489 compare
= strcmp(name
, SYM_NAME(t
));
493 else if (compare
< 0) {
494 return probeSymbolDefined(name
, SYM_LEFT(t
));
497 return probeSymbolDefined(name
, SYM_RIGHT(t
));
501 SymbolNode
*newSymbolNode(char *name
);
503 SymbolEntry
*getSymbol(char *name
, SymbolNode
*t
)
510 topLevel
= newSymbolNode(name
);
512 return SYM_ENTRY(topLevel
);
515 ASSERT_ALWAYS(t
!= NULL
,"");
519 compare
= strcmp(name
, SYM_NAME(t
));
524 else if (compare
< 0) {
527 child
= newSymbolNode(name
);
530 return SYM_ENTRY(child
);
533 return getSymbol(name
, child
);
537 child
= SYM_RIGHT(t
);
539 child
= newSymbolNode(name
);
540 SYM_RIGHT(t
) = child
;
542 return SYM_ENTRY(child
);
545 return getSymbol(name
, child
);
550 SymbolNode
*newSymbolNode(char *name
)
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
;
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
)
578 tmp
= (void *)malloc(n
);
579 ASSERT_ALWAYS(tmp
!= NULL
,"");
585 void autoFree(void *p
)