lac : 8a1192da2dcec3a97b199e992f0220233936cc5b
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: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
340:
341: /* Special Form */
342: LAC_API static lreg_t proc_quote(lreg_t args, lenv_t *argenv, lenv_t *env)
343: {
344: _EXPECT_ARGS(args, 1);
345: return car(args);
346: }
347:
348: static void _qquote(lreg_t sexp, lenv_t *env, lreg_t *first, lreg_t *last, int nested)
349: {
350: switch ( lreg_raw_type(sexp) )
351: {
352: case LREG_CONS:
353: if ( car(sexp) == sym_quasiquote )
354: {
355: lreg_t qqd;
356: _qquote(cdr(sexp), env, &qqd, NULL, nested+1);
357: *first = cons(sym_quasiquote, qqd);
358: }
359: else if ( (car(sexp) == sym_unquote) )
360: {
361: if ( nested == 0 )
362: *first = eval(car(cdr(sexp)), env);
363: else
364: {
365: lreg_t qqd;
366: _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
367: *first = cons(sym_unquote, qqd);
368: }
369: }
370: else if ( car(sexp) == sym_splice )
371: {
372: if ( nested == 0 )
373: {
374: lreg_t tosplice;
375:
376: if ( last == NULL )
377: raise_exception("SPLICE expected on car only.", NIL);
378:
379: tosplice = eval(car(cdr(sexp)), env);
380: switch( lreg_raw_type (tosplice) )
381: {
382: lreg_t tail = NIL;
383: case LREG_CONS:
384: *first = tail = tosplice;
385: for ( ; tosplice != NIL && is_cons(cdr(tosplice));
386: tosplice = cdr(tosplice) );
387: *last = tosplice;
388: break;
389:
390: default:
391: *first = tosplice;
392: *last = cons(NIL,NIL);
393: break;
394: }
395: }
396: else
397: {
398: lreg_t qqd;
399: _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
400: *first = cons(sym_splice, qqd);
401: }
402: }
403: else
404: {
405: lreg_t qqa, qqd, qqalast = NIL;
406:
407: _qquote(car(sexp), env, &qqa, &qqalast, nested);
408: _qquote(cdr(sexp), env, &qqd, NULL, nested);
409:
410: if ( qqalast != NIL )
411: {
412: if ( cdr(qqalast) == NIL )
413: rplacd(qqalast, qqd);
414: else if ( qqd != NIL )
415: raise_exception("Dotted pairs in spliced list can be"
416: " present only when splicing is at end of a list.", qqd);
417:
418: *first = qqa;
419: }
420: else
421: *first = cons(qqa, qqd);
422: }
423: break;
424: default:
425: *first = sexp;
426: }
427: }
428:
429: /* Special Form */
430: LAC_API static lreg_t proc_quasiquote(lreg_t args, lenv_t *argenv, lenv_t *env)
431: {
432: lreg_t ret;
433: _EXPECT_ARGS(args, 1);
434: _qquote(car(args), env, &ret, NULL, 0);
435: return ret;
436: }
437:
438: LAC_API static lreg_t proc_car(lreg_t args, lenv_t *argenv, lenv_t *env)
439: {
440: _EXPECT_ARGS(args, 1);
441: lreg_t arg1 = ARGEVAL(car(args), argenv);
442:
443: /* Lisp-specific! */
444: if (arg1 == NIL)
445: return NIL;
446:
447: if ( !is_cons(arg1) )
448: _ERROR_AND_RET("argument is not cons");
449:
450: return car(arg1);
451: }
452:
453: LAC_API static lreg_t proc_cdr(lreg_t args, lenv_t *argenv, lenv_t *env)
454: {
455: _EXPECT_ARGS(args, 1);
456: lreg_t arg1 = ARGEVAL(car(args), argenv);
457:
458: /* Lisp-specific!
459: If I really want to keep this spec I should change cdr() and
460: car() to return NIL on NIL and remove these checks. */
461: if (arg1 == NIL)
462: return NIL;
463:
464: if (!is_cons(arg1))
465: _ERROR_AND_RET("argument is not cons");
466:
467: return cdr(arg1);
468: }
469:
470: LAC_API static lreg_t proc_cons(lreg_t args, lenv_t *argenv, lenv_t *env)
471: {
472: _EXPECT_ARGS(args, 2);
473: lreg_t arg1 = ARGEVAL(car(args), argenv);
474: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
475:
476: return cons(arg1, arg2);
477: }
478:
479: LAC_API static lreg_t proc_rplaca(lreg_t args, lenv_t *argenv, lenv_t *env)
480: {
481: _EXPECT_ARGS(args, 2);
482: lreg_t arg1 = ARGEVAL(car(args), argenv);
483: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
484:
485: if ( !is_cons(arg1) )
486: _ERROR_AND_RET("argument is not cons");
487:
488: rplaca(arg1, arg2);
489: return arg1;
490: }
491:
492: LAC_API static lreg_t proc_rplacd(lreg_t args, lenv_t *argenv, lenv_t *env)
493: {
494: _EXPECT_ARGS(args, 2);
495: lreg_t arg1 = ARGEVAL(car(args), argenv);
496: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
497:
498: if ( !is_cons(arg1) )
499: _ERROR_AND_RET("argument is not cons");
500:
501: rplacd(arg1, arg2);
502: return arg1;
503: }
504:
505: LAC_API static lreg_t proc_eq(lreg_t args, lenv_t *argenv, lenv_t *env)
506: {
507: _EXPECT_ARGS(args, 2);
508: lreg_t arg1 = ARGEVAL(car(args), argenv);
509: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
510:
511: return (lreg_type(arg1) == lreg_type(arg2)
512: && lreg_ptr(arg1) == lreg_ptr(arg2)) ? sym_true : sym_false;
513: }
514:
515: LAC_API static lreg_t proc_atom_equal(lreg_t args, lenv_t *argenv, lenv_t *env)
516: {
517: _EXPECT_ARGS(args, 2);
518: lreg_t arg1 = ARGEVAL(car(args), argenv);
519: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
520: int rc = 0;
521:
522: if (lreg_type(arg1) != lreg_type(arg2))
523: raise_exception("types mismatch", cons(arg1, arg2));
524:
525: switch(lreg_raw_type(arg1)) {
526: case LREG_NIL:
527: rc = 1;
528: break;
529: case LREG_LLPROC:
530: case LREG_LAMBDA:
531: case LREG_MACRO:
532: case LREG_SYMBOL:
533: rc = lreg_raw_ptr(arg1) == lreg_raw_ptr(arg2);
534: break;
535: case LREG_STRING:
536: rc = !strcmp(lreg_raw_ptr(arg1), lreg_raw_ptr(arg2));
537: break;
538: case LREG_EXTT:
539: rc = lacint_extty_equal(arg1, arg2);
540: break;
541: default:
542: raise_exception("not an atom", arg1);
543: }
544:
545: return rc ? sym_true : sym_false;
546: }
547:
548: /* Special Form */
549: LAC_API static lreg_t proc_labels(lreg_t args, lenv_t *argenv, lenv_t *env)
550: {
551: /* At least 3 arguments required. */
552: _EXPECT_MIN_ARGS(args, 3);
553: lreg_t ret;
554: lreg_t lbl = car(args);
555: lreg_t binds = car(cdr(args));
556: lenv_t *penv = GC_malloc(sizeof(lenv_t));
557:
558: if ( !is_cons(binds) && binds != NIL )
559: _ERROR_AND_RET("Syntax error in labels");
560:
561: env_pushnew(env, penv);
562: ret = lreg_raw(lreg_raw_ptr(cons(cdr(args), lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
563: env_define(penv, lbl, ret);
564: return ret;
565: }
566:
567: /* Special Form */
568: LAC_API static lreg_t proc_lambda(lreg_t args, lenv_t *argenv, lenv_t *env)
569: {
570: /* At least 2 arguments required. */
571: _EXPECT_MIN_ARGS(args, 2);
572: lreg_t binds = car(args);
573: lenv_t *penv = GC_malloc(sizeof(lenv_t));
574:
575: if ( !is_cons(binds) && binds != NIL )
576: _ERROR_AND_RET("Syntax error in lambda");
577:
578: env_pushnew(env, penv);
579: return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
580: }
581:
582: /* Special Form */
583: LAC_API static lreg_t proc_macro(lreg_t args, lenv_t *argenv, lenv_t *env)
584: {
585: /* At least 2 arguments required. */
586: _EXPECT_MIN_ARGS(args, 2);
587: lreg_t binds = car(args);
588: lenv_t *penv = GC_malloc(sizeof(lenv_t));
589:
590: if ( !is_cons(binds) && binds != NIL )
591: _ERROR_AND_RET("Syntax error in macro");
592:
593: env_pushnew(env, penv);
594: return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_MACRO);
595: }
596:
597: /* Special Form */
598: LAC_API static lreg_t proc_define(lreg_t args, lenv_t *argenv, lenv_t *env)
599: {
600: lreg_t defd;
601: _EXPECT_ARGS(args, 2);
602:
603: if ( !is_symbol(car(args)) )
604: _ERROR_AND_RET("Syntax error in define");
605:
606: defd = eval(car(cdr(args)), env);
607: env_define(env, car(args), defd);
608: return defd;
609: }
610:
611: LAC_API static lreg_t proc_set(lreg_t args, lenv_t *argenv, lenv_t *env)
612: {
613: int r;
614: _EXPECT_ARGS(args, 2);
615: lreg_t arg1 = ARGEVAL(car(args), argenv);
616: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
617:
618: if ( !is_symbol(arg1) )
619: _ERROR_AND_RET("Syntax error in set");
620:
621: r = env_set(env, arg1, arg2);
622: if ( r < 0 )
623: raise_exception("Error while setting env.", NIL);
624:
625: if ( r == 0 )
626: return arg2;
627:
628: /* Not defined */
629: return NIL;
630: }
631:
632: LAC_DEFINE_TYPE_PFUNC(cons, LREG_CONS);
633: LAC_DEFINE_TYPE_PFUNC(symbol, LREG_SYMBOL);
634:
635: LAC_API static lreg_t proc_gensym(lreg_t args, lenv_t *argenv, lenv_t *env)
636: {
637: #define GENSYM "#GSYM"
638: static int id = 0;
639: int len;
640: lreg_t ret;
641: char *s, *s1;
642: _EXPECT_ARGS(args, 0);
643: asprintf(&s1, "%s-%08x", GENSYM, id);
644: len = strlen(s1);
645: s = GC_malloc(len);
646: memcpy(s, s1, len);
647: free(s1);
648: ret = intern_symbol(s);
649: id++;
650: return ret;
651: }
652:
653: LAC_API static lreg_t proc_load(lreg_t args, lenv_t *argenv, lenv_t *env)
654: {
655: int r;
656: FILE *f;
657: char *file;
658: void *scan;
659: lreg_t res, arg1;
660: _EXPECT_ARGS(args, 1);
661:
662: arg1 = ARGEVAL(car(args), argenv);
663: if ( lreg_type(arg1) != LREG_STRING )
664: _ERROR_AND_RET("Syntax error in load");
665:
666: file = (char *)lreg_raw_ptr(arg1);
667: f = fopen((char *)file, "r");
668: if ( f == NULL )
669: _ERROR_AND_RET("Could not open file");
670:
671: sexpr_read_start(f, &scan);
672: lac_on_error({
673: sexpr_read_stop(scan);
674: _throw(); /* rethrow */
675: });
676: do {
677: r = sexpr_read(&res, scan);
678: eval(res, env);
679: } while(r);
680:
681: lac_off_error();
682: sexpr_read_stop(scan);
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:
734: void map_init(lenv_t *env);
735: void int_init(lenv_t *env);
736: void string_init(lenv_t *env);
737: static void
738: modules_init(lenv_t *env)
739: {
740: int_init(env);
741: string_init(env);
742: map_init(env);
743: }
744:
745: static void
746: library_init(lenv_t *env)
747: {
748: int r;
749: FILE *f;
750: lreg_t res;
751: void *scan;
752:
753: f = fopen("sys.lac", "r");
754: if ( f == NULL )
755: f = fopen(LAC_SYSDIR"/sys.lac", "r");
756: if ( f == NULL )
757: raise_exception("SYSTEM LIBRARY NOT FOUND", NIL);
758:
759: sexpr_read_start(f, &scan);
760: do {
761: r = sexpr_read(&res, scan);
762: eval(res, env);
763: } while(r);
764: sexpr_read_stop(scan);
765:
766: fclose(f);
767: }
768:
769: lenv_t *
770: lac_init(void)
771: {
772: sigset_t emptyset;
773: lenv_t *env;
774: GC_init();
775:
776: sigemptyset(&emptyset);
777: sigprocmask(SIG_BLOCK, &emptyset, &mainsigset);
778:
779: stackoverflow_install_handler(stackovf_handler, extra_stack, 16384);
780: env = lac_envalloc();
781: machine_init(env);
782: modules_init(env);
783: library_init(env);
784:
785: return env;
786: }
787:
788: lenv_t *
789: lac_envalloc(void)
790: {
791: return GC_malloc(sizeof(lenv_t));
792: }
793:
794:
Generated by git2html.