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