lac : 5973ac08a3cd481abe4ba8cc33e6136f9b3a03ea
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: struct cons
150: {
151: lreg_t a;
152: lreg_t d;
153: };
154:
155: static inline struct cons *
156: get_cons(lreg_t lr)
157: {
158: if (lreg_raw_type(lr) == LREG_CONS)
159: return (struct cons *)lreg_raw_ptr(lr);
160: raise_exception("not a cons", lr);
161: }
162:
163:
164: /*
165: * Embedded procedures
166: */
167:
168: #define LAC_API __attribute__((aligned(16)))
169: typedef lreg_t (*lac_function_t)(lreg_t args, lenv_t *argenv, lenv_t *env);
170:
171:
172: /*
173: * Extension
174: */
175:
176: void lac_extproc_register(lenv_t *env, const char *sym, lac_function_t f);
177:
178: int lac_extty_register(unsigned typeno, lac_exttype_t *extty);
179: lreg_t lac_extty_box(unsigned typeno, void *ptr, size_t size);
180: size_t lac_extty_unbox(lreg_t lr, void **ptr);
181: unsigned lac_extty_get_type(lreg_t lr);
182: size_t lac_extty_get_size(lreg_t lr);
183: int lac_extty_print(FILE * fd, lreg_t lr);
184:
185:
186: /*
187: * Lisp Machine
188: */
189:
190: #define NIL lreg_raw(0,LREG_NIL)
191: extern lreg_t sym_true;
192: extern lreg_t sym_false;
193: extern lreg_t sym_quote;
194: extern lreg_t sym_quasiquote;
195: extern lreg_t sym_unquote;
196: extern lreg_t sym_splice;
197: extern lreg_t sym_rest;
198:
199: #define car(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->a)
200: #define cdr(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->d)
201: #define rplaca(_lr, _a) do { get_cons(_lr)->a = (_a); } while(0)
202: #define rplacd(_lr, _d) do { get_cons(_lr)->d = (_d); } while(0)
203: lreg_t evargs(lreg_t list, lenv_t *env);
204: lreg_t eval(lreg_t list, lenv_t *env);
205: lreg_t apply(lreg_t proc, lreg_t args, lenv_t *env);
206: lreg_t cons(lreg_t a, lreg_t b);
207: lreg_t intern_symbol(char *s);
208:
209: #define _ERROR_AND_RET(err) \
210: do { \
211: raise_exception(err, NIL); \
212: } while ( 0 )
213:
214: #define __EXPECT_MIN_ARGS__(args, num) \
215: do { \
216: int i; \
217: for ( i = 0; i < num; tmp = cdr(tmp), i++ ) \
218: if ( tmp == NIL ) \
219: _ERROR_AND_RET("Not enough arguments"); \
220: } while ( 0 )
221:
222: #define _EXPECT_MIN_ARGS(args, num) \
223: do { \
224: lreg_t tmp = args; \
225: __EXPECT_MIN_ARGS__(args, num); \
226: } while ( 0 )
227:
228: #define _EXPECT_ARGS(args, num) \
229: do { \
230: lreg_t tmp = args; \
231: __EXPECT_MIN_ARGS__(args, num); \
232: if ( tmp != NIL ) \
233: _ERROR_AND_RET("Too Many arguments"); \
234: } while ( 0 )
235:
236: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
237:
238: #define LAC_DEFINE_TYPE_PFUNC(typename, typeno) \
239: LAC_API static lreg_t proc_##typename##p (lreg_t args, lenv_t *argenv, lenv_t *env) \
240: { \
241: _EXPECT_ARGS(args, 1); \
242: lreg_t arg1 = ARGEVAL(car(args), argenv); \
243: if ( lreg_type(arg1) == typeno ) \
244: return sym_true; \
245: else \
246: return sym_false; \
247: }
248: #define LAC_TYPE_PFUNC(typename) proc_##typename##p
249:
250: /*
251: * Exception handling.
252: * Simple SJLJ for now(?).
253: */
254:
255: #include <setjmp.h>
256: #include <stdlib.h>
257:
258: struct _lac_xcpt {
259: sigjmp_buf buf;
260: struct _lac_xcpt *next;
261: };
262:
263: /* Per thread. Correct but ugh. */
264: extern __thread struct _lac_xcpt *_lac_xcpt;
265: extern __thread char *_lac_xcpt_msg;
266: extern __thread lreg_t _lac_xcpt_reg;
267:
268: #define lac_errlreg() _lac_xcpt_reg
269: #define lac_errmsg() _lac_xcpt_msg
270:
271: #define lac_on_error(_b) do { \
272: struct _lac_xcpt *p = malloc(sizeof(struct _lac_xcpt)); \
273: p->next = _lac_xcpt; \
274: _lac_xcpt = p; \
275: if ( sigsetjmp(p->buf, 1) != 0 ) { \
276: { _b }; \
277: } \
278: } while(0)
279:
280: #define lac_off_error() do { \
281: struct _lac_xcpt *p = _lac_xcpt; \
282: _lac_xcpt = p->next; \
283: free(p); \
284: } while(0)
285:
286: void lac_error_print (FILE * f);
287:
288:
289: /*
290: * Representations
291: */
292:
293: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq);
294: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq);
295: void sexpr_fprint(FILE *f, lreg_t lr);
296:
297: #endif /* LACONIC_H */
Generated by git2html.