lac : 87168c0fd8f9ddf9c62a1a75c45c4ba09dea2574
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: #ifndef __LACONIC_H
21: #define __LACONIC_H
22:
23: #include <stdio.h>
24: #include <stdint.h>
25: #include <inttypes.h>
26:
27: #include <gc/gc.h>
28:
29: #ifdef __GNUC__
30: #define _noreturn __attribute__((noreturn))
31: #else
32: #define _noreturn
33: #endif
34:
35:
36: /*
37: * Basic Types.
38: */
39:
40: struct env;
41: typedef struct env lenv_t;
42: typedef uintptr_t lreg_t;
43:
44:
45: /*
46: * LREG/Type model.
47: *
48: * We require GC-allocated memory to be 8-byte aligned, so that we can
49: * use the least significant three bits for storing type information
50: * (up to seven types). Extended types (types whose id cannot be
51: * decoded in three bits) are encoded via the EXTT-type LREG, whose
52: * PTR points to a TREG, capable of storing a full object and a
53: * bigger tag.
54: */
55:
56: enum lreg_type
57: {
58: LREG_CONS = 0, /* Cons cells. */
59: LREG_SYMBOL, /* Symbols. */
60: LREG_STRING, /* String. */
61: LREG_LLPROC, /* C procedures. */
62: LREG_LAMBDA, /* Lambda procedures. */
63: LREG_MACRO, /* Macro procedures. */
64: LREG_NIL, /* NIL. */
65: LREG_EXTT, /* External Type. */
66: /* EXTTYs */
67: LREG_INTEGER, /* Integers, Fixed External type. */
68: LREG_AVAIL,
69: LREG_TYPES=256
70: };
71: #define LREG_TYPE_MASK 0x7
72:
73:
74: /*
75: * EXTTY handling.
76: */
77:
78: struct treg_hdr {
79: unsigned type;
80: size_t size;
81: void *ptr;
82: };
83:
84: typedef struct {
85: char *name;
86: void (*print)(FILE *fd, lreg_t lr);
87: int (*equal)(lreg_t arg1, lreg_t arg2);
88: } lac_exttype_t;
89:
90: static inline lreg_t lreg_raw(void *ptr, unsigned type)
91: {
92: return (lreg_t)((uintptr_t)ptr) | type;
93: }
94:
95: static inline void *lreg_raw_ptr(lreg_t lr)
96: {
97: return (void *)((uintptr_t)lr & ~LREG_TYPE_MASK);
98: }
99:
100: static inline uintptr_t lreg_raw_type(lreg_t lr)
101: {
102: return (uintptr_t)lr & LREG_TYPE_MASK;
103: }
104:
105: static inline unsigned lreg_type(lreg_t lr)
106: {
107: unsigned raw_type = lr & LREG_TYPE_MASK;
108:
109: switch(raw_type) {
110: case LREG_EXTT:
111: return ((struct treg_hdr *)lreg_raw_ptr(lr))->type;
112: default:
113: return raw_type;
114: }
115: }
116:
117: static inline void *lreg_ptr(lreg_t lr)
118: {
119: unsigned raw_type = lr & LREG_TYPE_MASK;
120: void *lreg_ptr = lreg_raw_ptr(lr);
121:
122: switch(raw_type) {
123: case LREG_EXTT:
124: return ((struct treg_hdr *)lreg_ptr)->ptr;
125: default:
126: return lreg_ptr;
127: }
128: }
129:
130: void raise_exception(char *, lreg_t) _noreturn;
131:
132: lenv_t *lac_envalloc(void);
133: lenv_t * lac_init(void);
134: extern void *GC_malloc(size_t);
135:
136: static inline void *lac_alloc(size_t size)
137: {
138: return GC_MALLOC(size);
139: }
140:
141: static inline void *lac_alloc_fini(size_t size,
142: void (*fn)(void*,void*), void *opq)
143: {
144: void *obj = GC_MALLOC(size);
145: GC_REGISTER_FINALIZER_IGNORE_SELF(obj, fn, opq, 0, 0);
146: return obj;
147: }
148:
149: void lac_error_print (FILE * f);
150: lreg_t lac_eval (lreg_t lr, lenv_t *env);
151:
152:
153: struct cons
154: {
155: lreg_t a;
156: lreg_t d;
157: };
158:
159: static inline struct cons *
160: get_cons(lreg_t lr)
161: {
162: if (lreg_raw_type(lr) == LREG_CONS)
163: return (struct cons *)lreg_raw_ptr(lr);
164: raise_exception("not a cons", lr);
165: }
166:
167: static inline lreg_t lac_string_box(char *s)
168: {
169: return lreg_raw(GC_strdup(s), LREG_STRING);
170: }
171:
172:
173: /*
174: * Embedded procedures
175: */
176:
177: #define LAC_API __attribute__((aligned(16)))
178: typedef lreg_t (*lac_function_t)(lreg_t args, lenv_t *argenv, lenv_t *env);
179:
180:
181: /*
182: * Extension
183: */
184:
185: void lac_extproc_register(lenv_t *env, const char *sym, lac_function_t f);
186:
187: int lac_extty_register(unsigned typeno, lac_exttype_t *extty);
188: lreg_t lac_extty_box(unsigned typeno, void *ptr, size_t size);
189: size_t lac_extty_unbox(lreg_t lr, void **ptr);
190: unsigned lac_extty_get_type(lreg_t lr);
191: size_t lac_extty_get_size(lreg_t lr);
192: int lac_extty_print(FILE * fd, lreg_t lr);
193:
194:
195: /*
196: * Lisp Machine
197: */
198:
199: #define NIL lreg_raw(0,LREG_NIL)
200: extern lreg_t sym_true;
201: extern lreg_t sym_false;
202: extern lreg_t sym_quote;
203: extern lreg_t sym_quasiquote;
204: extern lreg_t sym_unquote;
205: extern lreg_t sym_splice;
206: extern lreg_t sym_rest;
207:
208: #define car(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->a)
209: #define cdr(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->d)
210: #define rplaca(_lr, _a) do { get_cons(_lr)->a = (_a); } while(0)
211: #define rplacd(_lr, _d) do { get_cons(_lr)->d = (_d); } while(0)
212: lreg_t evargs(lreg_t list, lenv_t *env);
213: lreg_t eval(lreg_t list, lenv_t *env);
214: lreg_t apply(lreg_t proc, lreg_t args, lenv_t *env);
215: lreg_t cons(lreg_t a, lreg_t b);
216: lreg_t intern_symbol(char *s);
217:
218: #define _ERROR_AND_RET(err) \
219: do { \
220: raise_exception(err, NIL); \
221: } while ( 0 )
222:
223: #define __EXPECT_MIN_ARGS__(args, num) \
224: do { \
225: int i; \
226: for ( i = 0; i < num; tmp = cdr(tmp), i++ ) \
227: if ( tmp == NIL ) \
228: _ERROR_AND_RET("Not enough arguments"); \
229: } while ( 0 )
230:
231: #define _EXPECT_MIN_ARGS(args, num) \
232: do { \
233: lreg_t tmp = args; \
234: __EXPECT_MIN_ARGS__(args, num); \
235: } while ( 0 )
236:
237: #define _EXPECT_ARGS(args, num) \
238: do { \
239: lreg_t tmp = args; \
240: __EXPECT_MIN_ARGS__(args, num); \
241: if ( tmp != NIL ) \
242: _ERROR_AND_RET("Too Many arguments"); \
243: } while ( 0 )
244:
245: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
246:
247: #define LAC_DEFINE_TYPE_PFUNC(typename, typeno) \
248: LAC_API static lreg_t proc_##typename##p (lreg_t args, lenv_t *argenv, lenv_t *env) \
249: { \
250: _EXPECT_ARGS(args, 1); \
251: lreg_t arg1 = ARGEVAL(car(args), argenv); \
252: if ( lreg_type(arg1) == typeno ) \
253: return sym_true; \
254: else \
255: return sym_false; \
256: }
257: #define LAC_TYPE_PFUNC(typename) proc_##typename##p
258:
259: /*
260: * Exception handling.
261: * Simple SJLJ for now(?).
262: */
263:
264: #include <setjmp.h>
265: #include <stdlib.h>
266:
267: struct _lac_xcpt {
268: sigjmp_buf buf;
269: struct _lac_xcpt *next;
270: };
271:
272: /* Per thread. Correct but ugh. */
273: extern __thread struct _lac_xcpt *_lac_xcpt;
274: extern __thread char *_lac_xcpt_msg;
275: extern __thread lreg_t _lac_xcpt_reg;
276:
277: #define lac_errlreg() _lac_xcpt_reg
278: #define lac_errmsg() _lac_xcpt_msg
279:
280: #define lac_on_error(_b) do { \
281: struct _lac_xcpt *p = malloc(sizeof(struct _lac_xcpt)); \
282: p->next = _lac_xcpt; \
283: _lac_xcpt = p; \
284: if ( sigsetjmp(p->buf, 1) != 0 ) { \
285: { _b }; \
286: } \
287: } while(0)
288:
289: #define lac_off_error() do { \
290: struct _lac_xcpt *p = _lac_xcpt; \
291: _lac_xcpt = p->next; \
292: free(p); \
293: } while(0)
294:
295:
296: /*
297: * Representations
298: */
299:
300: lreg_t sexpr_eval_string(char *s, lenv_t *env);
301: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq);
302: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq);
303: void sexpr_fprint(FILE *f, lreg_t lr);
304:
305: #endif /* LACONIC_H */
Generated by git2html.