root/lang/c/misc/mlisp/core/sexp.cpp @ 11750

Revision 11750, 6.3 kB (checked in by mokehehe, 6 years ago)

マクロ組込み

Line 
1//=============================================================================
2///     S ������/**
3        mallloc �Ŋm�ۂ����A�h���X�͂S�̔{���Ɖ���*/
4//=============================================================================
5
6#include "sexp.h"
7#include "s_hash.h"
8#include "inner.h"
9#include <stdio.h>
10#include <string.h>
11#include <stdarg.h>
12
13/// �G���[
14static const char* errmsg[] = {
15        "illegal char: %c",
16        "string not terminate",
17        "no close paren",
18        "dot first",
19        "empty after dot",
20        "illegal dot list",
21
22        "type required: %s",
23        "undefined symbol",
24        "unexpected",
25};
26
27/// �^���������tatic const char* TypeStrTbl[] = {
28        "integer",
29        "cons",
30        "symbol",
31        "string",
32        "procedure",
33};
34
35
36/// �A���P�[�^
37typedef void* (*SGCAllocFunc)(size_t, int);
38class SAllocator {
39        SGCAllocFunc allocator;
40public:
41        void set(SGCAllocFunc f) { allocator = f; }
42        void* alloc(size_t size, bool b_atomic) { return allocator(size, b_atomic); }
43};
44
45
46template <int N>
47struct SizedSymbol : public Symbol {
48        char buf[N];            // Symbol �ŁAchar [1] ���̗̈悪���Ă����ŁA'\0'�̕��͊܂߂�����������������ł悢�B
49};
50
51SizedSymbol<3> symNil;
52SizedSymbol<1> symT;
53
54const SExp nil = {
55        (sint)&symNil,
56};
57
58const SExp t = {
59        (sint)&symT,
60};
61
62static void init_const(void) {
63        symNil.type = tSymb;
64        strcpy(symNil.str, "nil");
65        symT.type = tSymb;
66        strcpy(symT.str, "t");
67}
68
69SType type_of(SExp s) {
70        switch (s.i & 3) {
71        case 1: case 3:                 // �ʼn��ʃr�b�g���P�F����
72                return tInt;
73        case 2:                                 // �Q�F�萔
74                break;
75        case 0:                                 // �S�̔{���F�|�C���^
76//              return s.ptr->type;
77                return s.ptr->base.type;
78        }
79        return tUnknown;
80}
81
82const char* s2str(SExp s) {
83        type_check(s, tStr);
84        String* str = (String*)s.ptr;
85        return str->str;
86}
87
88
89//=============================================================================
90
91/// �V���{���e�[�u��
92class SymbolTable {
93        struct StrCmp {
94                bool operator()(const char* a, const char* b) const { return strcmp(a, b) < 0; }
95        };
96        typedef SHash<const char*, SExp, StrCmp> Container;
97        Container buf;
98
99public:
100        /// �T��
101        const SExp* find(const char* str) {
102                Container::iterator it = buf.find(str);
103                if (it != buf.end()) {
104                        return &(it->second);
105                } else {
106                        return NULL;
107                }
108        }
109
110        /// �lj�
111        void add(SExp symbol) {
112                assert(type_of(symbol) == tSymb);
113                Symbol* p = (Symbol*)symbol.ptr;
114                buf[p->str] = symbol;
115        }
116
117        /// �N���A
118        void clear() {
119                buf.clear();
120        }
121};
122
123
124//=============================================================================
125
126static const SVTable* vtbl;
127static SAllocator s_allocator;
128static SymbolTable symbol_table;
129
130
131void* salloc(size_t size, int b_atomic) {
132        return s_allocator.alloc(size, b_atomic != FALSE);
133}
134
135
136static void close(void) {
137        symbol_table.clear();
138}
139
140static void init(const SVTable* vtbl_) {
141        close();
142
143        vtbl = vtbl_;
144        s_allocator.set(vtbl_->gcmalloc);
145
146        init_const();
147
148        symbol_table.add(nil);
149        symbol_table.add(t);
150}
151
152void error(int errid, ...) {
153        va_list ap;
154        va_start(ap, errid);
155        char buf[256];
156        vsprintf(buf, errmsg[errid-1], ap);
157        va_end(ap);
158
159        if (vtbl->error != NULL) {
160                (*vtbl->error)(buf);
161        } else {
162                exit(errid);
163        }
164}
165
166void reset_error(void) {
167}
168
169int type_check(SExp s, SType type) {
170        if (type_of(s) != type) {
171                error(ERR_TYPE_REQUIRED, TypeStrTbl[type]);
172                return FALSE;
173        } else {
174                return TRUE;
175        }
176}
177
178
179SExp cons(SExp a, SExp d) {
180        Cell* p = (Cell*)salloc(sizeof(Cell), FALSE);
181        p->type = tCell;
182        p->car = a;
183        p->cdr = d;
184
185        SExp s;
186        s.ptr = (SExpExtU*)p;
187        return s;
188}
189
190SExp car(SExp s) {
191        if (!type_check(s, tCell))      return s;
192
193        Cell* cell = (Cell*)s.ptr;
194        return cell->car;
195}
196
197SExp cdr(SExp s) {
198        if (!type_check(s, tCell))      return s;
199
200        Cell* cell = (Cell*)s.ptr;
201        return cell->cdr;
202}
203
204void rplaca(SExp s, SExp a) {
205        if (!type_check(s, tCell))      return;
206
207        Cell* cell = (Cell*)s.ptr;
208        cell->car = a;
209}
210
211void rplacd(SExp s, SExp d) {
212        if (!type_check(s, tCell))      return;
213
214        Cell* cell = (Cell*)s.ptr;
215        cell->cdr = d;
216}
217
218SExp intern(const char* str) {
219        const SExp* ps = symbol_table.find(str);
220        if (ps != NULL) {
221                return *ps;
222        } else {
223                int l = strlen(str);
224                Symbol* p = (Symbol*)salloc(sizeof(Symbol) + l, TRUE);
225                p->type = tSymb;
226                memcpy(p->str, str, l);
227                p->str[l] = '\0';
228
229                SExp s;
230                s.ptr = (SExpExtU*)p;
231                symbol_table.add(s);
232                return s;
233        }
234}
235
236SExp gen_str(const char* str) {
237        String* p = (String*)salloc(sizeof(String), FALSE);
238        p->type = tStr;
239        int l = strlen(str);
240        p->str = (char*)salloc(l + 1, TRUE);
241        memcpy(p->str, str, l);
242        p->str[l] = '\0';
243
244        SExp s;
245        s.ptr = (SExpExtU*)p;
246        return s;
247}
248
249
250SExp gen_cfunc(SCFunc cfunc, int minnarg, int maxnarg) {
251        const bool b_macro = false;
252        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
253        p->type = tProc;
254        p->flag = Procedure::Builtin | (b_macro ? Procedure::Macro : Procedure::Lambda);
255        p->u.cfunc = cfunc;
256        p->minnarg = minnarg;
257        p->maxnarg = maxnarg;
258
259        SExp s;
260        s.ptr = (SExpExtU*)p;
261
262        return s;
263}
264
265SExp gen_cmacro(SCFuncM mfunc, int minnarg, int maxnarg) {
266        const bool b_macro = true;
267        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
268        p->type = tProc;
269        p->flag = Procedure::Builtin | (b_macro ? Procedure::Macro : Procedure::Lambda);
270        p->u.mfunc = mfunc;
271        p->minnarg = minnarg;
272        p->maxnarg = maxnarg;
273
274        SExp s;
275        s.ptr = (SExpExtU*)p;
276
277        return s;
278}
279
280
281SExp gen_closure(SExp body, SExp env, int minnarg, int maxnarg) {
282        const bool b_macro = false;
283        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
284        p->type = tProc;
285        p->flag = Procedure::Cell | (b_macro ? Procedure::Macro : Procedure::Lambda);
286        p->u.cell.s = body;
287        p->u.cell.e = env;
288        p->minnarg = minnarg;
289        p->maxnarg = maxnarg;
290
291        SExp s;
292        s.ptr = (SExpExtU*)p;
293
294        return s;
295}
296
297
298SExp gen_macro(SExp body, int minnarg, int maxnarg) {
299        const bool b_macro = true;
300        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
301        p->type = tProc;
302        p->flag = Procedure::Cell | (b_macro ? Procedure::Macro : Procedure::Lambda);
303        p->u.cell.s = body;
304        p->u.cell.e = nil;
305        p->minnarg = minnarg;
306        p->maxnarg = maxnarg;
307
308        SExp s;
309        s.ptr = (SExpExtU*)p;
310
311        return s;
312}
313
314//=============================================================================
315
316void sexp_new(const SVTable* vtbl) {
317        init(vtbl);
318}
319
320void sexp_delete(void) {
321        close();
322}
Note: See TracBrowser for help on using the browser.