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