lac : ab9fddca006964a741e20645824d373bb454ccf7
1: /*
2: lac -- a lisp interpreter library
3: Copyright (C) 2010 Gianluca Guida
4:
5: This program is free software; you can redistribute it and/or modify
6: it under the terms of the GNU General Public License as published by
7: the Free Software Foundation; either version 2 of the License, or
8: (at your option) any later version.
9:
10: This program is distributed in the hope that it will be useful,
11: but WITHOUT ANY WARRANTY; without even the implied warranty of
12: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13: GNU General Public License for more details.
14:
15: You should have received a copy of the GNU General Public License along
16: with this program; if not, write to the Free Software Foundation, Inc.,
17: 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18: */
19:
20: #define _GNU_SOURCE
21: #include <stdio.h>
22: #include <stdlib.h>
23: #include <search.h>
24: #include <string.h>
25: #include <gc/gc.h>
26: #include <signal.h>
27: #include <sigsegv.h>
28: #include "private.h"
29: #include "lac.h"
30:
31:
32: /*
33: * System symbols
34: */
35: lreg_t sym_true;
36: lreg_t sym_false;
37: lreg_t sym_cond;
38: lreg_t sym_apply;
39: lreg_t sym_quote;
40: lreg_t sym_quasiquote;
41: lreg_t sym_unquote;
42: lreg_t sym_splice;
43: lreg_t sym_rest;
44:
45:
46: /*
47: * Interface
48: */
49:
50: lreg_t register_symbol(const char *s)
51: {
52: unsigned len = strlen(s) + 1;
53: char *gcs = GC_malloc(len);
54: strncpy(gcs, s, len);
55: return intern_symbol(gcs);
56: }
57:
58: void
59: lac_extproc_register(lenv_t *env, const char *sym, lac_function_t f)
60: {
61:
62: env_define(env, register_symbol(sym), llproc_to_lreg(f));
63: }
64:
65:
66: /*
67: * Exception handling.
68: */
69:
70: __thread
71: struct _lac_xcpt *_lac_xcpt;
72: __thread
73: char *_lac_xcpt_msg;
74: __thread
75: lreg_t _lac_xcpt_reg;
76:
77: inline void raise_exception(char *arg, lreg_t errlr)
78: {
79:
80: _lac_xcpt_msg = arg;
81: _lac_xcpt_reg = errlr;
82: _throw();
83: }
84:
85: /*
86: * Stack Overflow handling.
87: */
88:
89: static sigset_t mainsigset;
90: static char extra_stack[16384];
91:
92: static void stackovf_continuation(void *arg1, void *arg2, void *arg3)
93: {
94: raise_exception(arg1, NIL);
95: }
96:
97: static void stackovf_handler()
98: {
99: sigprocmask(SIG_SETMASK, &mainsigset, NULL);
100: sigsegv_leave_handler(stackovf_continuation, "STACK OVERFLOW", NULL, NULL);
101: }
102:
103:
104: /*
105: * Basic procedures.
106: */
107:
108: /* Get symbol from string and intern it if new. */
109: lreg_t intern_symbol(char *s)
110: {
111: ENTRY e = { .key = s }, *r;
112:
113: /* Assert that the char pointer is actually aligned. If not it means
114: that we're interning a symbol from a string not allocated by the
115: GC, and this is against the code rules of this thing. */
116: assert(((uintptr_t)s & LREG_TYPE_MASK) == 0);
117:
118: r = hsearch(e, ENTER);
119: return lreg_raw(lreg_raw_ptr((lreg_t)r->key),LREG_SYMBOL);
120: }
121:
122: lreg_t cons(lreg_t a, lreg_t d)
123: {
124: struct cons *c = GC_malloc(sizeof(struct cons));
125: c->a = a;
126: c->d = d;
127: return lreg_raw(c, LREG_CONS);
128: }
129:
130:
131: /*
132: * Eval/Apply
133: */
134:
135:
136: lreg_t evargs(lreg_t list, lenv_t *env)
137: {
138: lreg_t tmp, head=NIL, tail=NIL;
139:
140: while (is_cons(list)) {
141: tmp = cons(eval(car(list), env), NIL);
142: if (head != NIL) {
143: rplacd(tail, tmp);
144: tail = cdr(tail);
145: } else {
146: head = tmp;
147: tail = head;
148: }
149: list = cdr(list);
150: }
151:
152: if (list != NIL)
153: {
154: raise_exception("evargs: invalid arguments", list);
155: head = NIL;
156: }
157: return head;
158: }
159:
160: static void
161: evbind(lreg_t binds, lreg_t args, lenv_t *argenv, lenv_t *env)
162: {
163: lreg_t arg;
164:
165: while (is_cons(binds) && is_cons(args)) {
166: if (car(binds) == sym_rest)
167: break;
168: arg = car(args);
169: if (argenv)
170: arg = eval(arg, argenv);
171: env_define(env, car(binds), arg);
172: binds = cdr(binds);
173: args = cdr(args);
174: }
175:
176: if (car(binds) == sym_rest) {
177: binds = cdr(binds);
178: arg = args;
179: if (argenv)
180: arg = evargs(arg, argenv);
181: env_define(env, car(binds), arg);
182: binds = cdr(binds);
183: args = NIL;
184: }
185:
186: if (is_cons(binds))
187: raise_exception("Undefined bindings", binds);
188:
189: if (is_cons(args))
190: raise_exception("Too many arguments", args);
191: }
192:
193: lreg_t
194: apply(lreg_t proc, lreg_t args, lenv_t *env)
195: {
196: return eval(cons(sym_apply, cons(proc, cons(args, NIL))), env);
197: }
198:
199: static __thread int in_tco = 0;
200:
201: lreg_t eval(lreg_t sexp, lenv_t *env)
202: {
203: lreg_t ans;
204: unsigned type;
205: lenv_t *cloenv;
206: lenv_t *tenvs[2] = { NULL, NULL };
207:
208: tco:
209: switch (lreg_raw_type(sexp))
210: {
211: case LREG_SYMBOL:
212: ans = env_lookup(env, sexp);
213: break;
214: case LREG_CONS: {
215: lreg_t proc = car(sexp), args = cdr(sexp);
216: lenv_t *penv, *argenv;
217:
218: ans = NIL;
219: /* COND: embedded procedure */
220: if (proc == sym_cond) {
221: lreg_t cond = NIL;
222: lreg_t next, test, body;
223:
224: body = NIL; /* Default return */
225: while ( args != NIL ) {
226: test = car(args);
227: if ( !is_cons(test) )
228: _ERROR_AND_RET("Syntax error in cond");
229: cond = eval(car(test), env);
230: /* Lisp-specific! Scheme (as for R5RS) checks for #t,
231: * though guile doesn't. */
232: if ( cond == NIL ) {
233: args = cdr(args);
234: continue;
235: }
236: body = cdr(test);
237: break;
238: }
239: if (body == NIL)
240: return cond;
241: next = cdr(body);
242: while(next != NIL) {
243: eval(car(body), env);
244: body = next;
245: next = cdr(next);
246: }
247: if (in_tco) {
248: sexp = car(body);
249: /* env unchanged */
250: goto tco;
251: }
252: in_tco = 1;
253: ans = eval(car(body), env);
254: in_tco = 0;
255: break;
256: } else if (proc == sym_apply) {
257: proc = car(args);
258: args = eval(car(cdr(args)), env);;
259: argenv = NULL;
260: goto _apply;
261: } else {
262: lreg_t lproc, binds, body, next;
263:
264: argenv = env;
265: _apply:
266: proc = eval(proc, env);
267: type = lreg_raw_type(proc);
268: if (type == LREG_LLPROC)
269: return lreg_to_llproc(proc)(args, argenv, env);
270: if (type != LREG_MACRO && type != LREG_LAMBDA) {
271: raise_exception("not a procedure", proc);
272: return NIL;
273: }
274: lproc = get_closure_proc(proc);
275: binds = get_proc_binds(lproc);
276: body = get_proc_body(lproc);
277:
278: if (tenvs[0] == NULL) {
279: tenvs[0] = alloca(sizeof(lenv_t));
280: cloenv = tenvs[0];
281: }
282: if (type == LREG_MACRO) {
283: penv = NULL;
284: } else
285: penv = argenv;
286:
287: env_pushnew(get_closure_env(proc), cloenv);
288: evbind(binds, args, penv, cloenv);
289: next = cdr(body);
290: while (body != NIL) {
291: if (next == NIL && type == LREG_LAMBDA && in_tco) {
292: lenv_t *t;
293:
294: if (tenvs[1] == NULL) {
295: tenvs[1] = alloca(sizeof(lenv_t));
296: env = tenvs[1];
297: }
298: /* Swap ENV */
299: t = env;
300: env = cloenv;
301: cloenv = t;
302: sexp = car(body);
303: goto tco;
304: }
305: in_tco = 1;
306: ans = eval(car(body), cloenv);
307: in_tco = 0;
308:
309: body = next;
310: next = cdr(next);
311: }
312: if (type == LREG_LAMBDA)
313: break;
314: if (in_tco) {
315: /* Macro expand hook? */
316: sexp = ans;
317: /* env unchanged */
318: goto tco;
319: }
320: in_tco = 1;
321: ans = eval(ans, env);
322: in_tco = 0;
323: break;
324: }
325: break;
326: }
327: default:
328: ans = sexp;
329: break;
330: }
331: return ans;
332: }
333:
334:
335: /*
336: * Embedded Procedures
337: */
338:
339: /* Special Form */
340: LAC_API static lreg_t proc_quote(lreg_t args, lenv_t *argenv, lenv_t *env)
341: {
342: _EXPECT_ARGS(args, 1);
343: return car(args);
344: }
345:
346: static void _qquote(lreg_t sexp, lenv_t *env, lreg_t *first, lreg_t *last, int nested)
347: {
348: switch ( lreg_raw_type(sexp) )
349: {
350: case LREG_CONS:
351: if ( car(sexp) == sym_quasiquote )
352: {
353: lreg_t qqd;
354: _qquote(cdr(sexp), env, &qqd, NULL, nested+1);
355: *first = cons(sym_quasiquote, qqd);
356: }
357: else if ( (car(sexp) == sym_unquote) )
358: {
359: if ( nested == 0 )
360: *first = eval(car(cdr(sexp)), env);
361: else
362: {
363: lreg_t qqd;
364: _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
365: *first = cons(sym_unquote, qqd);
366: }
367: }
368: else if ( car(sexp) == sym_splice )
369: {
370: if ( nested == 0 )
371: {
372: lreg_t tosplice;
373:
374: if ( last == NULL )
375: raise_exception("SPLICE expected on car only.", NIL);
376:
377: tosplice = eval(car(cdr(sexp)), env);
378: switch( lreg_raw_type (tosplice) )
379: {
380: lreg_t tail = NIL;
381: case LREG_CONS:
382: *first = tail = tosplice;
383: for ( ; tosplice != NIL && is_cons(cdr(tosplice));
384: tosplice = cdr(tosplice) );
385: *last = tosplice;
386: break;
387:
388: default:
389: *first = tosplice;
390: *last = cons(NIL,NIL);
391: break;
392: }
393: }
394: else
395: {
396: lreg_t qqd;
397: _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
398: *first = cons(sym_splice, qqd);
399: }
400: }
401: else
402: {
403: lreg_t qqa, qqd, qqalast = NIL;
404:
405: _qquote(car(sexp), env, &qqa, &qqalast, nested);
406: _qquote(cdr(sexp), env, &qqd, NULL, nested);
407:
408: if ( qqalast != NIL )
409: {
410: if ( cdr(qqalast) == NIL )
411: rplacd(qqalast, qqd);
412: else if ( qqd != NIL )
413: raise_exception("Dotted pairs in spliced list can be"
414: " present only when splicing is at end of a list.", qqd);
415:
416: *first = qqa;
417: }
418: else
419: *first = cons(qqa, qqd);
420: }
421: break;
422: default:
423: *first = sexp;
424: }
425: }
426:
427: /* Special Form */
428: LAC_API static lreg_t proc_quasiquote(lreg_t args, lenv_t *argenv, lenv_t *env)
429: {
430: lreg_t ret;
431: _EXPECT_ARGS(args, 1);
432: _qquote(car(args), env, &ret, NULL, 0);
433: return ret;
434: }
435:
436: LAC_API static lreg_t proc_car(lreg_t args, lenv_t *argenv, lenv_t *env)
437: {
438: _EXPECT_ARGS(args, 1);
439: lreg_t arg1 = ARGEVAL(car(args), argenv);
440:
441: /* Lisp-specific! */
442: if (arg1 == NIL)
443: return NIL;
444:
445: if ( !is_cons(arg1) )
446: _ERROR_AND_RET("argument is not cons");
447:
448: return car(arg1);
449: }
450:
451: LAC_API static lreg_t proc_cdr(lreg_t args, lenv_t *argenv, lenv_t *env)
452: {
453: _EXPECT_ARGS(args, 1);
454: lreg_t arg1 = ARGEVAL(car(args), argenv);
455:
456: /* Lisp-specific!
457: If I really want to keep this spec I should change cdr() and
458: car() to return NIL on NIL and remove these checks. */
459: if (arg1 == NIL)
460: return NIL;
461:
462: if (!is_cons(arg1))
463: _ERROR_AND_RET("argument is not cons");
464:
465: return cdr(arg1);
466: }
467:
468: LAC_API static lreg_t proc_cons(lreg_t args, lenv_t *argenv, lenv_t *env)
469: {
470: _EXPECT_ARGS(args, 2);
471: lreg_t arg1 = ARGEVAL(car(args), argenv);
472: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
473:
474: return cons(arg1, arg2);
475: }
476:
477: LAC_API static lreg_t proc_rplaca(lreg_t args, lenv_t *argenv, lenv_t *env)
478: {
479: _EXPECT_ARGS(args, 2);
480: lreg_t arg1 = ARGEVAL(car(args), argenv);
481: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
482:
483: if ( !is_cons(arg1) )
484: _ERROR_AND_RET("argument is not cons");
485:
486: rplaca(arg1, arg2);
487: return arg1;
488: }
489:
490: LAC_API static lreg_t proc_rplacd(lreg_t args, lenv_t *argenv, lenv_t *env)
491: {
492: _EXPECT_ARGS(args, 2);
493: lreg_t arg1 = ARGEVAL(car(args), argenv);
494: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
495:
496: if ( !is_cons(arg1) )
497: _ERROR_AND_RET("argument is not cons");
498:
499: rplacd(arg1, arg2);
500: return arg1;
501: }
502:
503: LAC_API static lreg_t proc_eq(lreg_t args, lenv_t *argenv, lenv_t *env)
504: {
505: _EXPECT_ARGS(args, 2);
506: lreg_t arg1 = ARGEVAL(car(args), argenv);
507: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
508:
509: return (lreg_type(arg1) == lreg_type(arg2)
510: && lreg_ptr(arg1) == lreg_ptr(arg2)) ? sym_true : sym_false;
511: }
512:
513: LAC_API static lreg_t proc_atom_equal(lreg_t args, lenv_t *argenv, lenv_t *env)
514: {
515: _EXPECT_ARGS(args, 2);
516: lreg_t arg1 = ARGEVAL(car(args), argenv);
517: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
518: int rc = 0;
519:
520: if (lreg_type(arg1) != lreg_type(arg2))
521: raise_exception("types mismatch", cons(arg1, arg2));
522:
523: switch(lreg_raw_type(arg1)) {
524: case LREG_NIL:
525: rc = 1;
526: break;
527: case LREG_LLPROC:
528: case LREG_LAMBDA:
529: case LREG_MACRO:
530: case LREG_SYMBOL:
531: rc = lreg_raw_ptr(arg1) == lreg_raw_ptr(arg2);
532: break;
533: case LREG_STRING:
534: rc = !strcmp(lreg_raw_ptr(arg1), lreg_raw_ptr(arg2));
535: break;
536: case LREG_EXTT:
537: rc = lacint_extty_equal(arg1, arg2);
538: break;
539: default:
540: raise_exception("not an atom", arg1);
541: }
542:
543: return rc ? sym_true : sym_false;
544: }
545:
546: /* Special Form */
547: LAC_API static lreg_t proc_labels(lreg_t args, lenv_t *argenv, lenv_t *env)
548: {
549: /* At least 3 arguments required. */
550: _EXPECT_MIN_ARGS(args, 3);
551: lreg_t ret;
552: lreg_t lbl = car(args);
553: lreg_t binds = car(cdr(args));
554: lenv_t *penv = GC_malloc(sizeof(lenv_t));
555:
556: if ( !is_cons(binds) && binds != NIL )
557: _ERROR_AND_RET("Syntax error in labels");
558:
559: env_pushnew(env, penv);
560: ret = lreg_raw(lreg_raw_ptr(cons(cdr(args), lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
561: env_define(penv, lbl, ret);
562: return ret;
563: }
564:
565: /* Special Form */
566: LAC_API static lreg_t proc_lambda(lreg_t args, lenv_t *argenv, lenv_t *env)
567: {
568: /* At least 2 arguments required. */
569: _EXPECT_MIN_ARGS(args, 2);
570: lreg_t binds = car(args);
571: lenv_t *penv = GC_malloc(sizeof(lenv_t));
572:
573: if ( !is_cons(binds) && binds != NIL )
574: _ERROR_AND_RET("Syntax error in lambda");
575:
576: env_pushnew(env, penv);
577: return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
578: }
579:
580: /* Special Form */
581: LAC_API static lreg_t proc_macro(lreg_t args, lenv_t *argenv, lenv_t *env)
582: {
583: /* At least 2 arguments required. */
584: _EXPECT_MIN_ARGS(args, 2);
585: lreg_t binds = car(args);
586: lenv_t *penv = GC_malloc(sizeof(lenv_t));
587:
588: if ( !is_cons(binds) && binds != NIL )
589: _ERROR_AND_RET("Syntax error in macro");
590:
591: env_pushnew(env, penv);
592: return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_MACRO);
593: }
594:
595: /* Special Form */
596: LAC_API static lreg_t proc_define(lreg_t args, lenv_t *argenv, lenv_t *env)
597: {
598: lreg_t defd;
599: _EXPECT_ARGS(args, 2);
600:
601: if ( !is_symbol(car(args)) )
602: _ERROR_AND_RET("Syntax error in define");
603:
604: defd = eval(car(cdr(args)), env);
605: env_define(env, car(args), defd);
606: return defd;
607: }
608:
609: LAC_API static lreg_t proc_set(lreg_t args, lenv_t *argenv, lenv_t *env)
610: {
611: int r;
612: _EXPECT_ARGS(args, 2);
613: lreg_t arg1 = ARGEVAL(car(args), argenv);
614: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
615:
616: if ( !is_symbol(arg1) )
617: _ERROR_AND_RET("Syntax error in set");
618:
619: r = env_set(env, arg1, arg2);
620: if ( r < 0 )
621: raise_exception("Error while setting env.", NIL);
622:
623: if ( r == 0 )
624: return arg2;
625:
626: /* Not defined */
627: return NIL;
628: }
629:
630: LAC_DEFINE_TYPE_PFUNC(cons, LREG_CONS);
631: LAC_DEFINE_TYPE_PFUNC(symbol, LREG_SYMBOL);
632:
633: LAC_API static lreg_t proc_gensym(lreg_t args, lenv_t *argenv, lenv_t *env)
634: {
635: #define GENSYM "#GSYM"
636: static int id = 0;
637: int len;
638: lreg_t ret;
639: char *s, *s1;
640: _EXPECT_ARGS(args, 0);
641: asprintf(&s1, "%s-%08x", GENSYM, id);
642: len = strlen(s1);
643: s = GC_malloc(len);
644: memcpy(s, s1, len);
645: free(s1);
646: ret = intern_symbol(s);
647: id++;
648: return ret;
649: }
650:
651: LAC_API static lreg_t proc_load(lreg_t args, lenv_t *argenv, lenv_t *env)
652: {
653: FILE *f;
654: char *file;
655: lreg_t arg1;
656: _EXPECT_ARGS(args, 1);
657:
658: arg1 = ARGEVAL(car(args), argenv);
659: if ( lreg_type(arg1) != LREG_STRING )
660: _ERROR_AND_RET("Syntax error in load");
661:
662: file = (char *)lreg_raw_ptr(arg1);
663: f = fopen((char *)file, "r");
664: if ( f == NULL )
665: _ERROR_AND_RET("Could not open file");
666:
667: lac_on_error({
668: _throw(); /* rethrow */
669: });
670:
671: sexpr_parse_file(f, (lreg_t (*)(lreg_t, void *))eval, (void *)env);
672:
673: lac_off_error();
674: return sym_true;
675: }
676:
677:
678: LAC_API static lreg_t proc_collect(lreg_t args, lenv_t *argenv, lenv_t *env)
679: {
680: _EXPECT_ARGS(args, 0);
681:
682: GC_gcollect();
683: return sym_true;
684: }
685:
686:
687: /*
688: * Initialization Functions
689: */
690:
691: static void machine_init(lenv_t *env)
692: {
693: /* Init symtab. */
694: hcreate(500);
695:
696: /* Init Null Env */
697: memset(env, 0, sizeof(struct env));
698:
699: /* Lisp-style booleans.
700: Can be changed into Scheme-scheme. */
701: sym_false = NIL;
702: sym_true = register_symbol("T");
703: env_define(env, sym_true, sym_true); /* Tautology. */
704: sym_quote = register_symbol("QUOTE");
705: env_define(env, sym_quote, llproc_to_lreg(proc_quote));
706: sym_cond = register_symbol("COND");
707: sym_apply = register_symbol("APPLY");
708:
709: lac_extproc_register(env, "LAMBDA", proc_lambda);
710: lac_extproc_register(env, "DEFINE", proc_define);
711: lac_extproc_register(env, "MACRO", proc_macro);
712: lac_extproc_register(env, "LABELS", proc_labels);
713:
714: lac_extproc_register(env,"CONS", proc_cons);
715: lac_extproc_register(env,"CAR", proc_car);
716: lac_extproc_register(env,"CDR", proc_cdr);
717: lac_extproc_register(env,"RPLACA", proc_rplaca);
718: lac_extproc_register(env,"RPLACD", proc_rplacd);
719: lac_extproc_register(env,"EQ", proc_eq);
720: lac_extproc_register(env,"ATOM-EQUAL", proc_atom_equal);
721: lac_extproc_register(env,"LOAD", proc_load);
722: lac_extproc_register(env,"SET", proc_set);
723: lac_extproc_register(env,"GENSYM", proc_gensym);
724: lac_extproc_register(env,"CONSP", LAC_TYPE_PFUNC(cons));
725: lac_extproc_register(env,"SYMBOLP", LAC_TYPE_PFUNC(symbol));
726:
727: sym_quasiquote = register_symbol("QUASIQUOTE");
728: env_define(env, sym_quasiquote, llproc_to_lreg(proc_quasiquote));
729: sym_unquote = register_symbol("UNQUOTE");
730: sym_splice = register_symbol("SPLICE");
731: sym_rest = register_symbol("&REST");
732:
733: lac_extproc_register(env, "GC-COLLECT", proc_collect);
734: }
735:
736: void map_init(lenv_t *env);
737: void int_init(lenv_t *env);
738: void string_init(lenv_t *env);
739: static void
740: modules_init(lenv_t *env)
741: {
742: int_init(env);
743: string_init(env);
744: map_init(env);
745: }
746:
747: static void
748: library_init(lenv_t *env)
749: {
750: FILE *f;
751:
752: f = fopen("sys.lac", "r");
753: if ( f == NULL )
754: f = fopen(LAC_SYSDIR"/sys.lac", "r");
755: if ( f == NULL )
756: raise_exception("SYSTEM LIBRARY NOT FOUND", NIL);
757:
758: sexpr_parse_file(f, (lreg_t (*)(lreg_t, void *))eval, (void *)env);
759: fclose(f);
760: }
761:
762: lenv_t *
763: lac_init(void)
764: {
765: sigset_t emptyset;
766: lenv_t *env;
767: GC_init();
768:
769: sigemptyset(&emptyset);
770: sigprocmask(SIG_BLOCK, &emptyset, &mainsigset);
771:
772: stackoverflow_install_handler(stackovf_handler, extra_stack, 16384);
773: env = lac_envalloc();
774: machine_init(env);
775: modules_init(env);
776: library_init(env);
777:
778: return env;
779: }
780:
781: lenv_t *
782: lac_envalloc(void)
783: {
784: return GC_malloc(sizeof(lenv_t));
785: }
786:
787:
Generated by git2html.