removed elist-like descriptions for definitions
[k8-xscheme:k8-xscheme.git] / src / core / xsinit.c
1 /* xscheme initialization routines */
2 /* Copyright (c) 1988, David Michael Betz
3  * Copyright (c) 2010, Ketmar // Vampire Avalon
4  * All rights reserved.
5  * see LICENSE for terms of using.
6  */
7 #include <string.h>
8
9 #include "xscheme.h"
10
11
12 /* global variables */
13 jmp_buf *xsTopLevelJP;
14 XSVal xsEOFSym;
15 XSVal xsVoid;
16 XSVal xsOptionalSym, xsRestSym, xsKeySym;
17 XSVal xsObjObArray, xsTrue, xsObjEOF, xsObjDefault, xsUnassignedSym;
18 XSVal xsCSMap1, xsCSForEach1, xsCSLoad1, xsCSForce1;
19 XSVal xsEvalSym, xsUnboundSym, xsStdInSym, xsStdOutSym, xsStdErrSym;
20 XSVal xsPrintCaseSym, xsDownCaseSym, xsUpCaseSym;
21 XSVal xsFixFmtSym, xsFloFmtSym;
22 XSVal xsElseSym, xsCondArrowSym;
23 XSVal xsLParSym, xsRParSym, xsDotSym, xsQuoteChSym, xsQuoteSym, xsQQuoteSym;
24 XSVal xsUQuoteSym, xsUQuoteSSym;
25 #ifdef XS_PREALLOC_CHARS
26 XSVal xs256Chars[256]; /* array of first 256 characters */
27 #endif
28
29
30 /* lookup/enter all symbols used by the runtime system */
31 static void xsSymInit (void) {
32   /* top-level procedure symbol */
33   xsEvalSym = xsEnter("EVAL");
34   /* enter the symbols used by the system */
35   xsVoid = xsEnter("#!VOID");
36   /*xsSetValue(xsVoidObj, xsVoidObj);*/
37   xsTrue = xsEnter("#T");
38   xsUnboundSym = xsEnter("*UNBOUND*");
39   xsUnassignedSym = xsEnter("#!UNASSIGNED");
40   /* enter the i/o symbols */
41   xsStdInSym = xsEnter("*STANDARD-INPUT*");
42   xsStdOutSym = xsEnter("*STANDARD-OUTPUT*");
43   xsStdErrSym = xsEnter("*ERROR-OUTPUT*");
44   /* enter the symbols used by the printer */
45   xsFixFmtSym = xsEnter("*FIXNUM-FORMAT*");
46   xsFloFmtSym = xsEnter("*FLONUM-FORMAT*");
47   /* enter the lambda list keywords */
48   xsOptionalSym = xsEnter("#!OPTIONAL");
49   xsRestSym = xsEnter("#!REST");
50   xsKeySym = xsEnter("#!KEY");
51   /* enter symbols needed by the reader */
52   xsLParSym = xsEnter("(");
53   xsRParSym = xsEnter(")");
54   xsDotSym = xsEnter(".");
55   xsQuoteChSym = xsEnter("'");
56   xsQuoteSym = xsEnter("QUOTE");
57   xsQQuoteSym = xsEnter("QUASIQUOTE");
58   xsUQuoteSym = xsEnter("UNQUOTE");
59   xsUQuoteSSym = xsEnter("UNQUOTE-SPLICING");
60   /* 'else' is a useful synonym for #t in cond clauses */
61   xsElseSym = xsEnter("ELSE");
62   xsSetValue(xsElseSym, xsTrue);
63   xsCondArrowSym = xsEnter("=>");
64   xsEOFSym = xsEnter("#!EOF");
65   /* setup stdin/stdout/stderr */
66   xsSetValue(xsStdInSym, xsNewFilePort("<STDIN>", stdin, XS_PF_INPUT));
67   xsSetValue(xsStdOutSym, xsNewFilePort("<STDOUT>", stdout, XS_PF_OUTPUT));
68   xsSetValue(xsStdErrSym, xsNewFilePort("<STDERR>", stderr, XS_PF_OUTPUT));
69   /* enter *print-case* and its keywords */
70   xsUpCaseSym = xsEnter("UPCASE");
71   xsDownCaseSym = xsEnter("DOWNCASE");
72   xsPrintCaseSym = xsEnter("*PRINT-CASE*");
73   /* get the built-in continuation subrs */
74   xsCSMap1 = xsGetValue(xsEnter("%MAP1"));
75   xsCSForEach1 = xsGetValue(xsEnter("%FOR-EACH1"));
76   xsCSLoad1 = xsGetValue(xsEnter("%LOAD1"));
77   xsCSForce1 = xsGetValue(xsEnter("%FORCE1"));
78   /* initialize xsobj.c */
79   xsObjSymInit();
80 }
81
82
83 static void compileString (const char *str) {
84   /* xsRFun used as GC-protected temp var hare */
85   xsRFun = xsNewDynPort(str, strlen(str), XS_PF_INPUT);
86   xsRVal = XS_NIL;
87   for (;;) {
88     /* name */
89     if (!xsRead(xsRFun, &xsREnv)) break;
90     xsCPush(xsREnv);
91     /* args */
92     if (!xsRead(xsRFun, &xsREnv)) { xsDrop(1); break; }
93     xsCPush(xsREnv);
94     /* body */
95     if (!xsRead(xsRFun, &xsREnv)) { xsDrop(2); break; }
96     xsCPush(xsREnv);
97     /* compile */
98     xsRVal = xsCompFunc(xsSP[2], xsSP[1], xsSP[0], XS_NIL);
99     xsRVal = xsNewClosure(xsRVal, XS_NIL);
100     xsSetValue(xsSP[2], xsRVal);
101     xsDrop(3);
102   }
103   xsRFun = xsREnv = xsRVal = XS_NIL;
104 }
105
106
107 /* create an initial workspace */
108 int xsScmInit (unsigned int ssize) {
109 #ifdef XS_PREALLOC_CHARS
110   int f;
111 #endif
112   jmp_buf initJP;
113   jmp_buf *oldTLJP = xsTopLevelJP;
114   xsTopLevelJP = &initJP;
115   if (setjmp(initJP)) {
116     xsMemDeinit();
117     return XS_FALSE;
118   }
119   /* allocate memory for the workspace */
120   xsMemInit(ssize);
121   /* initialize the obarray */
122   xsUnboundSym = XS_NIL; /* to make cvsymbol work */
123   xsObjObArray = xsNewSymbol("*OBARRAY*");
124   xsSetValue(xsObjObArray, xsAllocVector(XS_HSIZE));
125   /* add the symbol *OBARRAY* to the obarray */
126   xsSetElement(xsGetValue(xsObjObArray),
127     xsStrHash(xsGetString(xsGetPName(xsObjObArray)), -1)%XS_HSIZE,
128     xsNewPair(xsObjObArray, XS_NIL));
129 #ifdef XS_PREALLOC_CHARS
130   /* alloc 256 chars */
131   for (f = 0; f < 256; f++) xs256Chars[f] = xsNewChar(f);
132 #endif
133   /* enter the eof object */
134   xsObjEOF = xsNewPair(xsEnter("**EOF**"), XS_NIL);
135   /* enter the default object */
136   xsObjDefault = xsNewPair(xsEnter("**DEFAULT**"), XS_NIL);
137   /* initialize the error handlers */
138   xsSetValue(xsEnter("*ERROR-HANDLER*"), XS_NIL);
139   xsSetValue(xsEnter("*UNBOUND-HANDLER*"), XS_NIL);
140   xsSetValue(xsEnter("*LAST-RES*"), XS_NIL);
141   /* install the built-in functions */
142   xsRegisterBuiltins();
143   xsObjInit(); /* initialize xsobj.c */
144   /* setup some synonyms */
145   xsSetValue(xsEnter("NOT"), xsGetValue(xsEnter("NULL?")));
146   /* enter all of the symbols used by the runtime system */
147   xsSymInit();
148   /* set the initial values of the symbol #T */
149   xsSetValue(xsTrue, xsTrue);
150   /* default to lowercase output of symbols */
151   xsSetValue(xsPrintCaseSym, xsDownCaseSym);
152   /* setup the print formats for numbers */
153   xsSetValue(xsFixFmtSym, xsNewString(XS_IFMT));
154   xsSetValue(xsFloFmtSym, xsNewString(XS_FFMT));
155   /* build the '%EVAL-WHOLE-STRING' function */
156   compileString(
157     "%EVAL-WHOLE-STRING\n"
158     "(str) (\n"
159       "(define fi (open-string-port str \"r\"))\n"
160       "(if (not fi) (error \"can't open string port\"))\n"
161       "(define lastres #f)\n"
162       "(define expr (read fi))\n"
163       "(while (not (eof-object? expr))\n"
164         "(set! lastres (eval expr))\n"
165         "(set! expr (read fi)))\n"
166       "lastres)\n");
167   /* build the 'eval' function */
168   compileString(
169     "eval\n"
170     "(x #!optional env) (\n"
171       "((if (default-object? env)\n"
172          "(compile x)\n"
173          "(compile x env))))\n");
174   /* build the '*toplevel*' function */
175   compileString(
176     "*toplevel*\n"
177     "() (\n"
178 #ifdef _WIN32
179       "(display \"> \")\n"
180 #endif
181       "(define exp (read))\n"
182       "(cond\n"
183         "[(eof-object? exp)\n"
184          "*last-res*]\n"
185         "[else\n"
186          "(set! *last-res* (eval exp))\n"
187          "(write *last-res*)\n"
188          "(newline)\n"
189          "(*toplevel*)]))\n");
190   xsTopLevelJP = oldTLJP;
191   return XS_TRUE;
192 }
193
194
195 int xsRunPreInitializer (void) {
196   int wasError = 0;
197   xsPEvalString(xscDefaultInit, &wasError);
198   return wasError==0;
199 }
200
201
202 int xsLoadDefaultLibInfo (void) {
203   int wasError = 0;
204   xsPEvalString(xscDefaultLibInfo, &wasError);
205   return wasError==0;
206 }