187 lines
4.6 KiB
Mathematica
187 lines
4.6 KiB
Mathematica
|
|
||
|
/*
|
||
|
test scheme parser
|
||
|
by marko riedel, mriedel@neuearbeit.de
|
||
|
*/
|
||
|
|
||
|
#include <locale.h>
|
||
|
#include <stdio.h>
|
||
|
#include <stdlib.h>
|
||
|
|
||
|
#import "SchemeTypes.h"
|
||
|
#import "VScheme.h"
|
||
|
|
||
|
id yyresult;
|
||
|
|
||
|
|
||
|
static char *forms[] = {
|
||
|
"top",
|
||
|
"define1", "define2", "set",
|
||
|
"lambda1", "lambda2",
|
||
|
"quote", "binding",
|
||
|
"let", "let*", "letrec",
|
||
|
"if1", "if2",
|
||
|
"and", "or",
|
||
|
"begin", "apply",
|
||
|
"case", "scond1", "scond2", "scond3", "cond",
|
||
|
"callcc"
|
||
|
};
|
||
|
|
||
|
void print_tree(id item, int indent)
|
||
|
{
|
||
|
int pos;
|
||
|
|
||
|
for(pos=0; pos<indent; pos++){
|
||
|
putchar(' ');
|
||
|
}
|
||
|
|
||
|
|
||
|
if(item==[NSNull null]){
|
||
|
puts("'()");
|
||
|
}
|
||
|
else if([item isKindOfClass:[Boolean class]]){
|
||
|
printf("BOOL: %s\n", (![item boolVal] ? "NO" : "YES"));
|
||
|
}
|
||
|
else if([item isKindOfClass:[Char class]]){
|
||
|
char c = [item charVal];
|
||
|
if(c=='\n'){
|
||
|
printf("CHAR: <\\newline>\n");
|
||
|
}
|
||
|
else if(c=='\t'){
|
||
|
printf("CHAR: <\\tab>\n");
|
||
|
}
|
||
|
else if(c==' '){
|
||
|
printf("CHAR: <\\space>\n");
|
||
|
}
|
||
|
else{
|
||
|
printf("CHAR: <%c>\n", c);
|
||
|
}
|
||
|
}
|
||
|
else if([item isKindOfClass:[Int class]]){
|
||
|
printf("INT: %ld\n", [item intVal]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[Double class]]){
|
||
|
printf("DOUBLE: %le\n", [item doubleVal]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[Symbol class]]){
|
||
|
printf("SYMBOL: <%s>\n", [[item symVal] cString]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[String class]]){
|
||
|
printf("STRING: <%s>\n", [[item strVal] cString]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[Closure class]]){
|
||
|
printf("CLOSURE %s\n",
|
||
|
[[VScheme valToString:[item args]] cString]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[Primitive class]]){
|
||
|
printf("PRIMITIVE\n");
|
||
|
}
|
||
|
else if([item isKindOfClass:[Thunk class]]){
|
||
|
printf("THUNK %d %d %d\n", [item argp], [item envp], [item codep]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[Pair class]]){
|
||
|
printf("PAIR %s\n", [[VScheme valToString:item] cString]);
|
||
|
}
|
||
|
else if([item isKindOfClass:[NSMutableArray class]]){
|
||
|
printf("CODES: %u\n", [item count]);
|
||
|
}
|
||
|
else{
|
||
|
printf("FORM %s\n", forms[[item tag]]);
|
||
|
if([item arg1]!=nil){
|
||
|
print_tree([item arg1], indent+1);
|
||
|
}
|
||
|
if([item arg2]!=nil){
|
||
|
print_tree([item arg2], indent+1);
|
||
|
}
|
||
|
if([item arg3]!=nil){
|
||
|
print_tree([item arg3], indent+1);
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
void print_scheme_item(id item)
|
||
|
{
|
||
|
print_tree(item, 0);
|
||
|
}
|
||
|
|
||
|
|
||
|
|
||
|
yyerror(char *s) /* Called by yyparse on error */
|
||
|
{
|
||
|
printf ("%s\n", s);
|
||
|
}
|
||
|
|
||
|
int main(int argc, char **argv)
|
||
|
{
|
||
|
NSAutoreleasePool *pool = [NSAutoreleasePool new];
|
||
|
NSApplication *theApp;
|
||
|
VScheme *vm;
|
||
|
id forms, item;
|
||
|
|
||
|
GSDebugAllocationActive(YES);
|
||
|
|
||
|
vm = [[VScheme alloc] init];
|
||
|
|
||
|
theApp = [NSApplication sharedApplication];
|
||
|
// [theApp run];
|
||
|
|
||
|
setlocale(LC_NUMERIC, "C");
|
||
|
printf("locale %s\n", setlocale(LC_NUMERIC, NULL));
|
||
|
|
||
|
yyparse();
|
||
|
// print_scheme_item(yyresult);
|
||
|
[vm setSource:yyresult];
|
||
|
|
||
|
forms = yyresult;
|
||
|
while(forms!=[NSNull null]){
|
||
|
NSMutableArray *codes = [NSMutableArray arrayWithCapacity:1];
|
||
|
BOOL err = [vm compile:[forms arg1] output:codes];
|
||
|
print_scheme_item([forms arg1]);
|
||
|
if(err==NO){
|
||
|
[VScheme printCodes:codes];
|
||
|
[vm clearOutput];
|
||
|
if([vm run:codes]==YES){
|
||
|
id stack = [vm argStack], envs = [vm envStack],
|
||
|
code = [vm codeStack];
|
||
|
int count = 0;
|
||
|
while(count<[stack count]){
|
||
|
printf("stack %d: ", count);
|
||
|
print_scheme_item([stack objectAtIndex:count++]);
|
||
|
}
|
||
|
|
||
|
printf("code: %d (%d) pc: %d args: %d (%d) envs: %d (%d):",
|
||
|
[code count], [vm maxcode],
|
||
|
[vm maxpc],
|
||
|
[stack count], [vm maxarg],
|
||
|
[envs count], [vm maxenv]);
|
||
|
|
||
|
count=0;
|
||
|
while(count<[envs count]){
|
||
|
id env = [envs objectAtIndex:count++];
|
||
|
printf("(%d)", [env chainLength]);
|
||
|
}
|
||
|
putchar('\n');
|
||
|
|
||
|
printf("OUTPUT\n%s\n", [[vm output] cString]);
|
||
|
|
||
|
[vm resetStacks];
|
||
|
}
|
||
|
else{
|
||
|
printf("run time error: %s\n", [[vm errmsg] cString]);
|
||
|
}
|
||
|
}
|
||
|
else{
|
||
|
printf("compilation failed: %s\n", [[vm errmsg] cString]);
|
||
|
}
|
||
|
|
||
|
|
||
|
[codes removeAllObjects];
|
||
|
|
||
|
forms = [forms arg2];
|
||
|
}
|
||
|
|
||
|
// [pool release];
|
||
|
|
||
|
return 0;
|
||
|
}
|