lac : 8647c1ba18e47685616546fd7b7b5fbc065be7ec
1: /*
2: lac -- a lisp interpreter
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: %{
21: #define YYSTYPE lreg_t
22:
23: #include <ctype.h>
24: #include <strings.h>
25:
26: #include <lac.h>
27: #include "sexpr.h"
28: #include "private.h"
29: %}
30:
31: %option noyywrap
32: %option reentrant
33: %option bison-bridge
34:
35: WHITESPACE [\ \t\n]
36: DIGIT [0-9]
37: HEXDIGIT [0-9a-fA-F]
38: ALPHA [A-Za-z]
39: SP_INIT [#\*/:<=>?^_~!$%&+-]
40: SPECIAL [\*/:<=>?^_~!$%&+-.]
41: SIGN [+|-]
42:
43: %%
44:
45: ;(.)*
46: {WHITESPACE}
47:
48: {SIGN}?{DIGIT}+ {
49: intptr_t n;
50:
51: errno = 0;
52: n = strtol(yytext, (char **)NULL, 10);
53: *yylval = lac_extty_box(LREG_INTEGER, (void *)n, 0);
54: return INTEGER;
55: }
56:
57: (#x|0x){HEXDIGIT}+ {
58: intptr_t n;
59:
60: errno = 0;
61: n = strtol(yytext+2, (char **)NULL, 16);
62: if ( errno == ERANGE )
63: raise_exception("Integer overflow in input", NIL);
64: *yylval = lac_extty_box(LREG_INTEGER, (void *)n, 0);
65: return INTEGER;
66: }
67:
68: (NIL|nil) {
69: *yylval = NIL;
70: return NIHIL;
71: }
72:
73: \"[^\"]*\" {
74: size_t len = strlen(yytext);
75: char *s = lac_alloc(len - 1);
76: memcpy(s, yytext+1, len - 2);
77: *yylval = lreg_raw(s, LREG_STRING);
78: return STRING;
79: }
80:
81: (({DIGIT}+({SPECIAL}|{ALPHA}))|{ALPHA}|{SP_INIT})({SPECIAL}|{ALPHA}|{DIGIT})* {
82: int i;
83: size_t len = strlen(yytext);
84: char *s = lac_alloc(len + 1);
85: for (i = 0; i < len; i++)
86: *(s+i) = toupper((int)*(yytext+i));
87: *yylval = intern_symbol(s);
88: return SYMBOL;
89: }
90:
91: ,@ { return COMMA_AT; }
92:
93: \' { return QUOTE; }
94:
95: ` { return QUASI; }
96:
97: , { return COMMA; }
98:
99: \( { return OPAREN; }
100:
101: \) { return CPAREN; }
102:
103: \. { return DOT; }
104:
105: <<EOF>> { return -1; }
106:
107: . { return -1; }
108:
109:
110: %%
111:
112: static void _sexpr_parse(yyscan_t yyscan, struct parse_cb *cb)
113: {
114: int v;
115: lreg_t lr;
116: void *parser;
117:
118: parser = ParseAlloc(malloc);
119:
120: lac_on_error({
121: ParseFree(parser, free);
122: yylex_destroy(yyscan);
123: _throw();
124: });
125:
126: while((v = yylex(&lr, yyscan)) != -1) {
127: Parse(parser, v, lr, cb);
128: }
129: Parse(parser, ENDPARSE, lr, cb);
130:
131: lac_off_error();
132:
133: ParseFree(parser, free);
134: yylex_destroy(yyscan);
135: }
136:
137: lreg_t sexpr_eval_string(char *s, lenv_t *env)
138: {
139: yyscan_t yyscan;
140: struct parse_cb cb;
141:
142: cb.fn = (lreg_t (*)(lreg_t,void*))eval;
143: cb.opq = (void *)env;
144: cb.res = NIL;
145:
146: yylex_init(&yyscan);
147: yy_scan_string(s, yyscan);
148:
149: lac_on_error ({
150: lac_error_print (stderr);
151: return NIL;
152: });
153:
154: _sexpr_parse(yyscan, &cb);
155:
156: lac_off_error();
157: return cb.res;
158: }
159:
160: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq)
161: {
162: yyscan_t yyscan;
163: struct parse_cb cb;
164:
165: cb.fn = fn;
166: cb.opq = opq;
167: cb.res = NIL;
168:
169: yylex_init(&yyscan);
170: yy_scan_string(s, yyscan);
171:
172: _sexpr_parse(yyscan, &cb);
173:
174: return cb.res;
175: }
176:
177: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq)
178: {
179: yyscan_t yyscan;
180: struct parse_cb cb;
181:
182: cb.fn = fn;
183: cb.opq = opq;
184: cb.res = NIL;
185:
186: yylex_init(&yyscan);
187: yyset_in(f, yyscan);
188:
189: _sexpr_parse(yyscan, &cb);
190: return cb.res;
191: }
192:
193:
194: /*
195: * Print
196: */
197:
198: static void sexpr_print_cons(FILE *f, lreg_t lr, const char *h)
199: {
200: lreg_t a = car(lr);
201: lreg_t d = cdr(lr);
202:
203: printf(h);
204: sexpr_fprint(f, a);
205:
206: if (d == NIL) {
207: fprintf(f, ")");
208: return;
209: }
210:
211: if (lreg_raw_type(d) == LREG_CONS)
212: sexpr_print_cons(f, d, " ");
213: else
214: {
215: fprintf(f, " . ");
216: sexpr_fprint(f, cdr(lr));
217: fprintf(f, ")");
218: }
219: }
220:
221: void sexpr_fprint(FILE *f, lreg_t lr)
222: {
223: switch ( lreg_type(lr) )
224: {
225: case LREG_NIL:
226: fprintf(f, "()");
227: break;
228: case LREG_SYMBOL:
229: fprintf(f, "%s", (char *)lreg_raw_ptr(lr));
230: break;
231: case LREG_STRING:
232: fprintf(f, "\"%s\"", (char *)lreg_raw_ptr(lr));
233: break;
234: case LREG_CONS:
235: sexpr_print_cons(f, lr, "(");
236: break;
237: case LREG_MACRO:
238: fprintf(f, "<#MACRO>");
239: break;
240: case LREG_LAMBDA:
241: fprintf(f, "<#LAMBDA>");
242: break;
243: case LREG_LLPROC:
244: fprintf(f, "<#LLPROC>");
245: break;
246: default:
247: if ( !lac_extty_print(f, lr) )
248: fprintf(f, "<??? %d>",(int)lreg_type(lr));
249: }
250: return;
251: }
Generated by git2html.