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