1 /*
2 * Copyright (c) 2020, Masatake YAMATO
3 * Copyright (c) 2020, Red Hat, Inc.
4 *
5 * This source code is released for free distribution under the terms of the
6 * GNU General Public License version 2 or (at your option) any later version.
7 */
8
9 /*
10 * INCLUDES
11 */
12 #include "dsl.h"
13 #include <assert.h>
14 #include <stdlib.h>
15 #include <string.h>
16 #include <ctype.h>
17
18 /*
19 * TYPES
20 */
21 struct sDSLCode
22 {
23 EsObject *expr;
24 };
25
26 struct sDSLEngine
27 {
28 DSLProcBind *pbinds;
29 int pbinds_count;
30 };
31 typedef struct sDSLEngine DSLEngine;
32
33 /*
34 * MACROS
35 */
36
37 #define DECLARE_VALUE_FN(N) \
38 static EsObject* value_##N (EsObject *args, DSLEnv *env)
39
40 #define DEFINE_VALUE_FN(N) \
41 static EsObject* value_##N (EsObject *args, DSLEnv *env) \
42 { \
43 return dsl_entry_##N (env->entry); \
44 }
45
46 /*
47 * FUNCTION DECLARATIONS
48 */
49
50 static EsObject *dsl_eval0 (EsObject *object, DSLEnv *env);
51 static EsObject *dsl_define (DSLEngineType engine, DSLProcBind *pbind);
52
53 static EsObject* builtin_null (EsObject *args, DSLEnv *env);
54 static EsObject* sform_begin (EsObject *args, DSLEnv *env);
55 static EsObject* sform_begin0 (EsObject *args, DSLEnv *env);
56 static EsObject* sfrom_and (EsObject *args, DSLEnv *env);
57 static EsObject* sform_or (EsObject *args, DSLEnv *env);
58 static EsObject* sform_if (EsObject *args, DSLEnv *env);
59 static EsObject* sform_cond (EsObject *args, DSLEnv *env);
60 static EsObject* builtin_not (EsObject *args, DSLEnv *env);
61 static EsObject* builtin_eq (EsObject *args, DSLEnv *env);
62 static EsObject* builtin_lt (EsObject *args, DSLEnv *env);
63 static EsObject* builtin_gt (EsObject *args, DSLEnv *env);
64 static EsObject* builtin_le (EsObject *args, DSLEnv *env);
65 static EsObject* builtin_ge (EsObject *args, DSLEnv *env);
66 static EsObject* builtin_prefix (EsObject *args, DSLEnv *env);
67 static EsObject* builtin_suffix (EsObject *args, DSLEnv *env);
68 static EsObject* builtin_substr (EsObject *args, DSLEnv *env);
69 static EsObject* builtin_member (EsObject *args, DSLEnv *env);
70 static EsObject* builtin_downcase (EsObject *args, DSLEnv *env);
71 static EsObject* builtin_upcase (EsObject *args, DSLEnv *env);
72 static EsObject* builtin_length (EsObject *args, DSLEnv *env);
73 static EsObject* bulitin_debug_print (EsObject *args, DSLEnv *env);
74 static EsObject* builtin_entry_ref (EsObject *args, DSLEnv *env);
75
76 static EsObject* builtin_string_append (EsObject *args, DSLEnv *env);
77 static EsObject* builtin_string2regexp (EsObject *args, DSLEnv *env);
78 static EsObject* builtin_regexp_quote (EsObject *args, DSLEnv *env);
79 static EsObject* builtin_add (EsObject *args, DSLEnv *env);
80 static EsObject* builtin_sub (EsObject *args, DSLEnv *env);
81
82 static EsObject* value_true (EsObject *args, DSLEnv *env);
83 static EsObject* value_false (EsObject *args, DSLEnv *env);
84 static EsObject* value_nil (EsObject *args, DSLEnv *env);
85
86 DECLARE_VALUE_FN(name);
87 DECLARE_VALUE_FN(input);
88 DECLARE_VALUE_FN(pattern);
89 DECLARE_VALUE_FN(line);
90
91 DECLARE_VALUE_FN(access);
92 DECLARE_VALUE_FN(end);
93 DECLARE_VALUE_FN(extras);
94 DECLARE_VALUE_FN(file);
95 DECLARE_VALUE_FN(inherits);
96 DECLARE_VALUE_FN(implementation);
97 DECLARE_VALUE_FN(kind);
98 DECLARE_VALUE_FN(language);
99 DECLARE_VALUE_FN(scope);
100 DECLARE_VALUE_FN(scope_kind);
101 DECLARE_VALUE_FN(scope_name);
102 DECLARE_VALUE_FN(signature);
103 DECLARE_VALUE_FN(typeref);
104 DECLARE_VALUE_FN(typeref_kind);
105 DECLARE_VALUE_FN(typeref_name);
106 DECLARE_VALUE_FN(roles);
107 DECLARE_VALUE_FN(xpath);
108
109 static EsObject* macro_string_append (EsObject *args);
110 static EsObject* macro_string2regexp (EsObject *args);
111 static EsObject* macro_regexp_quote (EsObject *args);
112 static EsObject* macro_debug_printX (EsObject *args);
113
114 /*
115 * DATA DEFINITIONS
116 */
117 static DSLEngine engines [DSL_ENGINE_COUNT];
118
119 static DSLProcBind pbinds_interanl_pseudo [] = {
120 { "#/PATTERN/", NULL, NULL, 0, 0,
121 .helpstr = "(#/patter/ <string>) -> <boolean>; regular expression matching" },
122 { "#/PATTERN/i", NULL, NULL, 0, 0,
123 .helpstr = "(#/patter/i <string>) -> <boolean>; in case insensitive way" },
124 };
125
126 static DSLProcBind pbinds [] = {
127 { "null?", builtin_null, NULL, DSL_PATTR_CHECK_ARITY, 1,
128 .helpstr = "(null? <any>) -> <boolean>" },
129 { "begin", sform_begin, NULL, DSL_PATTR_SELF_EVAL, 0UL,
130 .helpstr = "(begin <any:0> ... <any:n>) -> <any:n>" },
131 { "begin0", sform_begin0, NULL, DSL_PATTR_SELF_EVAL, 0UL,
132 .helpstr = "(begin0 <any:0> ... <any:n>) -> <any:0>" },
133 { "and", sfrom_and, NULL, DSL_PATTR_SELF_EVAL,
134 .helpstr = "(and <any> ...) -> <boolean>" },
135 { "or", sform_or, NULL, DSL_PATTR_SELF_EVAL,
136 .helpstr = "(or <any> ...) -> <boolean>" },
137 { "if", sform_if, NULL, DSL_PATTR_SELF_EVAL|DSL_PATTR_CHECK_ARITY, 3,
138 .helpstr = "(if <any:cond> <any:true> <any:false>) -> <any:true>|<any:false>" },
139 { "cond", sform_cond, NULL, DSL_PATTR_SELF_EVAL, 0,
140 .helpstr = "(cond (<any:cond0> ... <any:expr0>) ... (<any:condN> ... <any:exprN>)) -> <any:exprI>|false" } ,
141 { "not", builtin_not, NULL, DSL_PATTR_CHECK_ARITY, 1,
142 .helpstr = "(not <any>) -> <boolean>" },
143 { "eq?", builtin_eq, NULL, DSL_PATTR_CHECK_ARITY, 2,
144 .helpstr = "(eq? <any> <any>) -> <boolean>" },
145 { "<", builtin_lt, NULL, DSL_PATTR_CHECK_ARITY, 2,
146 .helpstr = "(< <integer> <integer>) -> <boolean>" },
147 { ">", builtin_gt, NULL, DSL_PATTR_CHECK_ARITY, 2,
148 .helpstr = "(> <integer> <integer>) -> <boolean>" },
149 { "<=", builtin_le, NULL, DSL_PATTR_CHECK_ARITY, 2,
150 .helpstr = "(<= <integer> <integer>) -> <boolean>" },
151 { ">=", builtin_ge, NULL, DSL_PATTR_CHECK_ARITY, 2,
152 .helpstr = "(>= <integer> <integer>) -> <boolean>" },
153 { "prefix?", builtin_prefix, NULL, DSL_PATTR_CHECK_ARITY, 2,
154 .helpstr = "(prefix? <string:target> <string:prefix>) -> <boolean>" },
155 { "suffix?", builtin_suffix, NULL, DSL_PATTR_CHECK_ARITY, 2,
156 .helpstr = "(suffix? <string:target> <string:suffix>) -> <boolean>" },
157 { "substr?", builtin_substr, NULL, DSL_PATTR_CHECK_ARITY, 2,
158 .helpstr = "(substr? <string:target> string:substr>) -> <boolean>" },
159 { "member", builtin_member, NULL, DSL_PATTR_CHECK_ARITY, 2,
160 .helpstr = "(member <any> <list>) -> #f|<list>" },
161 { "downcase", builtin_downcase, NULL, DSL_PATTR_CHECK_ARITY, 1,
162 .helpstr = "(downcase <string>|<list>) -> <string>|<list>" },
163 { "upcase", builtin_upcase, NULL, DSL_PATTR_CHECK_ARITY, 1,
164 .helpstr = "(upcase <string>|<list>) -> <string>|<list>" },
165 { "length", builtin_length, NULL, DSL_PATTR_CHECK_ARITY, 1,
166 .helpstr = "(length <string>) -> <integer>" },
167 { "+", builtin_add, NULL, DSL_PATTR_CHECK_ARITY, 2,
168 .helpstr = "(+ <integer> <integer>) -> <integer>", },
169 { "-", builtin_sub, NULL, DSL_PATTR_CHECK_ARITY, 2,
170 .helpstr = "(- <integer> <integer>) -> <integer>", },
171 { "concat", builtin_string_append,NULL, 0, 0,
172 .helpstr = "(concat <string> ...) -> <string>; an alias for string-append",
173 .macro = macro_string_append },
174 { "string-append", builtin_string_append,NULL, 0, 0,
175 .helpstr = "(string-append <string> ...) -> <string>",
176 .macro = macro_string_append },
177 { "string->regexp", builtin_string2regexp,NULL, 0, 0,
178 .helpstr = "((string->regexp <string:pattern>) <string:target>) -> <boolean>",
179 .macro = macro_string2regexp },
180 { "regexp-quote", builtin_regexp_quote, NULL, DSL_PATTR_CHECK_ARITY, 1,
181 .helpstr = "(regexp-quote <string>) -> <string>",
182 .macro = macro_regexp_quote },
183 { "print", bulitin_debug_print, NULL, DSL_PATTR_CHECK_ARITY, 1,
184 .helpstr = "(print OBJ) -> OBJ" },
185 { "printX", NULL, 0, 0,
186 .helpstr = "(printX EXPR) -> EXPR; do the same as `print' but this works before evaluating",
187 .macro = macro_debug_printX },
188 { "true", value_true, NULL, 0, 0UL,
189 .helpstr = "-> #t" },
190 { "false", value_false, NULL, 0, 0UL,
191 .helpstr = "-> #f" },
192 { "nil", value_nil, NULL, 0, 0UL,
193 .helpstr = "-> ()" },
194 { "$", builtin_entry_ref, NULL, DSL_PATTR_CHECK_ARITY, 1,
195 .helpstr = "($ <string:field>) -> #f|<string>" },
196 { "$name", value_name, NULL, DSL_PATTR_MEMORABLE, 0UL,
197 .helpstr = "-> <string>"},
198 { "$input", value_input, NULL, DSL_PATTR_MEMORABLE, 0UL,
199 .helpstr = "-> <string>; input file name" },
200 { "$pattern", value_pattern, NULL, DSL_PATTR_MEMORABLE, 0UL,
201 .helpstr = "-> #f|<string>"},
202 { "$line", value_line, NULL, DSL_PATTR_MEMORABLE, 0UL,
203 .helpstr = "-> #f|<integer>" },
204 { "$access", value_access, NULL, DSL_PATTR_MEMORABLE, 0UL,
205 .helpstr = "-> #f|<string>" },
206 { "$end", value_end, NULL, DSL_PATTR_MEMORABLE, 0UL,
207 .helpstr = "-> #f|<integer>"},
208 { "$extras", value_extras, NULL, DSL_PATTR_MEMORABLE, 0UL,
209 .helpstr = "-> #f|<string>"},
210 { "$file", value_file, NULL, DSL_PATTR_MEMORABLE, 0UL,
211 .helpstr = "-> <boolean>; whether the scope is limited in the file or not." },
212 { "$inherits", value_inherits, NULL, DSL_PATTR_MEMORABLE, 0UL,
213 .helpstr = "-> <list>" },
214 { "$implementation", value_implementation, NULL, DSL_PATTR_MEMORABLE, 0UL,
215 .helpstr = "-> #f|<string>" },
216 { "$kind", value_kind, NULL, DSL_PATTR_MEMORABLE, 0UL,
217 .helpstr = "-> #f|<string>"},
218 { "$language", value_language, NULL, DSL_PATTR_MEMORABLE, 0UL,
219 .helpstr = "-> #f|<string>" },
220 { "$scope", value_scope, NULL, DSL_PATTR_MEMORABLE, 0UL,
221 .helpstr = "-> #f|<string>; $scope-kind:$scope-name"},
222 { "$scope-kind", value_scope_kind, NULL, DSL_PATTR_MEMORABLE, 0UL,
223 .helpstr = "-> #f|<string>"},
224 { "$scope-name", value_scope_name, NULL, DSL_PATTR_MEMORABLE, 0UL,
225 .helpstr = "-> #f|<string>"},
226 { "$signature", value_signature, NULL, DSL_PATTR_MEMORABLE, 0UL,
227 .helpstr = "-> #f|<string>" },
228 { "$typeref", value_typeref, NULL, DSL_PATTR_MEMORABLE, 0UL,
229 .helpstr = "-> #f|<string>"},
230 { "$typeref-kind", value_typeref_kind, NULL, DSL_PATTR_MEMORABLE, 0UL,
231 .helpstr = "-> #f|<string>"},
232 { "$typeref-name", value_typeref_name, NULL, DSL_PATTR_MEMORABLE, 0UL,
233 .helpstr = "-> #f|<string>"},
234 { "$roles", value_roles, NULL, DSL_PATTR_MEMORABLE, 0UL,
235 .helpstr = "-> <list>" },
236 { "$xpath", value_xpath, NULL, DSL_PATTR_MEMORABLE, 0UL,
237 .helpstr = "-> #f|<string>"},
238 };
239
240
241 /*
242 * FUNCTION DEFINITIONS
243 */
dsl_define(DSLEngineType engine,DSLProcBind * pbind)244 static EsObject * dsl_define (DSLEngineType engine, DSLProcBind *pbind)
245 {
246 EsObject *name = es_symbol_intern (pbind->name);
247 if (name == es_nil)
248 return es_nil;
249
250 DSLProcBind **pbs = es_symbol_get_data (name);
251 if (!pbs)
252 {
253 pbs = calloc (DSL_ENGINE_COUNT, sizeof (pbinds[0]));
254 if (!pbs)
255 return es_nil;
256 es_symbol_set_data (name, pbs);
257 }
258
259 pbs [engine] = pbind;
260
261 return name;
262 }
263
dsl_init(DSLEngineType engine,DSLProcBind * engine_pbinds,int count)264 int dsl_init (DSLEngineType engine, DSLProcBind *engine_pbinds, int count)
265 {
266 static int initialized = 0;
267
268 if (!initialized)
269 {
270 engines [DSL_INTERNAL_PSEUDO].pbinds = pbinds_interanl_pseudo;
271 engines [DSL_INTERNAL_PSEUDO].pbinds_count
272 = sizeof(pbinds_interanl_pseudo)/sizeof(pbinds_interanl_pseudo [0]);
273
274 for (int i = 0; i < sizeof(pbinds)/sizeof(pbinds [0]); i++)
275 {
276 if (dsl_define (DSL_COMMON, pbinds + i) == NULL)
277 return 0;
278 }
279 engines [DSL_COMMON].pbinds = pbinds;
280 engines [DSL_COMMON].pbinds_count = sizeof(pbinds)/sizeof(pbinds [0]);
281
282 initialized = 1;
283 }
284
285 for (int i = 0; i < count; i++)
286 {
287 if (dsl_define (engine, engine_pbinds + i) == NULL)
288 return 0;
289 }
290
291 engines [engine].pbinds = engine_pbinds;
292 engines [engine].pbinds_count = count;
293
294 return 1;
295 }
296
dsl_lookup(DSLEngineType engine,EsObject * name)297 DSLProcBind *dsl_lookup (DSLEngineType engine, EsObject *name)
298 {
299 DSLProcBind **pbs = es_symbol_get_data (name);
300 if (!pbs)
301 return NULL;
302 return pbs [engine]? pbs [engine]: pbs [DSL_COMMON];
303 }
304
dsl_help0(DSLEngineType engine,FILE * fp)305 static void dsl_help0 (DSLEngineType engine, FILE *fp)
306 {
307 DSLEngine *e = engines + engine;
308
309 for (int i = 0; i < e->pbinds_count; i++)
310 {
311 const char* hs = e->pbinds [i].helpstr;
312 fprintf(fp, "%15s: %s\n", e->pbinds [i].name, hs? hs: "");
313 }
314 }
315
dsl_help(DSLEngineType engine,FILE * fp)316 void dsl_help (DSLEngineType engine, FILE *fp)
317 {
318 dsl_help0 (DSL_INTERNAL_PSEUDO, fp);
319 dsl_help0 (DSL_COMMON, fp);
320 dsl_help0 (engine, fp);
321 }
322
dsl_cache_reset0(DSLProcBind * pb)323 static void dsl_cache_reset0 (DSLProcBind *pb)
324 {
325 if (pb->flags & DSL_PATTR_MEMORABLE)
326 pb->cache = NULL;
327 }
328
dsl_cache_reset(DSLEngineType engine)329 void dsl_cache_reset (DSLEngineType engine)
330 {
331 for (int i = 0; i < sizeof(pbinds)/sizeof(pbinds [0]); i++)
332 dsl_cache_reset0 (pbinds + i);
333
334 DSLEngine *e = engines + engine;
335 for (int i = 0; i < e->pbinds_count; i++)
336 dsl_cache_reset0( e->pbinds + i);
337 }
338
length(EsObject * object)339 static int length (EsObject *object)
340 {
341 int i;
342 for (i = 0; !es_null (object); i++)
343 object = es_cdr (object);
344 return i;
345 }
346
error_included(EsObject * object)347 static EsObject *error_included (EsObject *object)
348 {
349 while (!es_null (object))
350 {
351 if (es_error_p (es_car (object)))
352 return es_car (object);
353 object = es_cdr (object);
354 }
355 return es_false;
356 }
357
eval0(EsObject * object,DSLEnv * env)358 static EsObject *eval0 (EsObject *object, DSLEnv *env)
359 {
360 if (es_null (object))
361 return es_nil;
362 else
363 return es_object_autounref (
364 es_cons(dsl_eval0 (es_car (object), env),
365 eval0 (es_cdr (object), env))
366 );
367 }
368
dsl_eval0(EsObject * object,DSLEnv * env)369 static EsObject *dsl_eval0 (EsObject *object, DSLEnv *env)
370 {
371 EsObject *r;
372 DSLProcBind *pb;
373 EsObject *car;
374
375 if (es_null (object))
376 return es_nil;
377 else if (es_symbol_p (object))
378 {
379 pb = dsl_lookup (env->engine, object);
380
381 if (pb)
382 {
383 if (pb->cache)
384 return pb->cache;
385
386 r = pb->proc (es_nil, env);
387 if (pb->flags & DSL_PATTR_MEMORABLE)
388 pb->cache = r;
389 return r;
390 }
391 else
392 dsl_throw (UNBOUND_VARIABLE, object);
393 }
394 else if (es_atom (object))
395 return object;
396
397 car = es_car (object);
398 if (es_regex_p(car))
399 {
400 EsObject *cdr = es_cdr (object);
401 int l = length (cdr);
402
403 if (l < 1)
404 dsl_throw (TOO_FEW_ARGUMENTS, car);
405 else if (l > 1)
406 dsl_throw (TOO_MANY_ARGUMENTS, car);
407
408 cdr = eval0(cdr, env);
409 EsObject *err;
410
411 err = error_included (cdr);
412 if (!es_object_equal (err, es_false))
413 return err;
414
415 EsObject *cadr = es_car (cdr);
416 if (!es_string_p (cadr))
417 dsl_throw (WRONG_TYPE_ARGUMENT, object);
418
419 r = es_regex_exec (car, cadr);
420 return r;
421 }
422 else if (es_error_p(car))
423 return car;
424 else if (es_cons_p (car))
425 {
426 car = dsl_eval0 (car, env);
427 if (es_error_p(car))
428 return car;
429
430 object = es_object_autounref (es_cons (car, es_cdr (object)));
431 return dsl_eval0 (object, env);
432 }
433 else if (es_symbol_p(car))
434 {
435 EsObject *cdr = es_cdr (object);
436 int l;
437
438 pb = dsl_lookup (env->engine, car);
439
440 if (!pb)
441 dsl_throw (UNBOUND_VARIABLE, car);
442
443 if (pb->cache)
444 return pb->cache;
445
446 if (pb->flags & DSL_PATTR_CHECK_ARITY)
447 {
448 l = length (cdr);
449 if (l < pb->arity)
450 dsl_throw (TOO_FEW_ARGUMENTS, car);
451 else if (l > pb->arity &&
452 !(pb->flags & DSL_PATTR_CHECK_ARITY_OPT))
453 dsl_throw (TOO_MANY_ARGUMENTS, car);
454 }
455
456 if (! (pb->flags & DSL_PATTR_SELF_EVAL))
457 {
458 EsObject *err;
459
460 cdr = eval0(cdr, env);
461
462 err = error_included (cdr);
463 if (!es_object_equal (err, es_false))
464 return err;
465 }
466
467 r = pb->proc (cdr, env);
468 if (pb->flags & DSL_PATTR_MEMORABLE)
469 pb->cache = r;
470 return r;
471 }
472 else
473 dsl_throw (CALLABLE_REQUIRED, car);
474 }
475
dsl_eval(DSLCode * code,DSLEnv * env)476 EsObject *dsl_eval (DSLCode *code, DSLEnv *env)
477 {
478 return dsl_eval0 (code->expr, env);
479 }
480
dsl_compile_and_eval(EsObject * expr,DSLEnv * env)481 EsObject *dsl_compile_and_eval (EsObject *expr, DSLEnv *env)
482 {
483 return dsl_eval0 (expr, env);
484 }
485
compile(EsObject * expr,void * engine)486 static EsObject *compile (EsObject *expr, void *engine)
487 {
488 if (!es_cons_p (expr))
489 return es_object_ref (expr);
490
491 EsObject *head = es_car (expr);
492 if (es_symbol_p (head))
493 {
494 DSLProcBind *pb = dsl_lookup (*((DSLEngineType *)engine),
495 head);
496 if (!pb)
497 dsl_throw (UNBOUND_VARIABLE, head);
498 if (pb->macro)
499 {
500 EsObject *tail = compile (es_cdr (expr), engine);
501 if (es_error_p (tail))
502 return tail;
503 expr = es_cons (head, tail);
504 EsObject *r = pb->macro (expr);
505 es_object_unref (expr);
506 es_object_unref (tail);
507 return r;
508 }
509 }
510 return es_map (compile, expr, engine);
511 }
512
dsl_compile(DSLEngineType engine,EsObject * expr)513 DSLCode *dsl_compile (DSLEngineType engine, EsObject *expr)
514 {
515 DSLCode *code = malloc (sizeof (DSLCode));
516 if (code == NULL)
517 return NULL;
518
519 code->expr = compile (expr, &engine);
520 if (es_null (code->expr))
521 {
522 free (code);
523 return NULL;
524 }
525 else if (es_error_p (code->expr))
526 {
527 dsl_report_error ("COMPILE ERROR", code->expr);
528 free (code);
529 return NULL;
530 }
531 return code;
532 }
533
dsl_release(DSLEngineType engine,DSLCode * code)534 void dsl_release (DSLEngineType engine, DSLCode *code)
535 {
536 es_object_unref (code->expr);
537 free (code);
538 }
539
540 /*
541 * Built-ins
542 */
builtin_null(EsObject * args,DSLEnv * env)543 static EsObject* builtin_null (EsObject *args, DSLEnv *env)
544 {
545 return es_null(es_car (args))? es_true: es_false;
546 }
547
sform_begin_common(const char * fn,EsObject * args,DSLEnv * env)548 static EsObject* sform_begin_common (const char *fn, EsObject *args, DSLEnv *env)
549 {
550 if (es_null (args))
551 dsl_throw (TOO_FEW_ARGUMENTS,
552 es_symbol_intern (fn));
553
554 EsObject *o = es_false;
555 while (! es_null (args))
556 {
557 o = es_car (args);
558 o = dsl_eval0 (o, env);
559 if (es_error_p (o))
560 return o;
561 args = es_cdr (args);
562 }
563 return o;
564 }
565
sform_begin(EsObject * args,DSLEnv * env)566 static EsObject* sform_begin (EsObject *args, DSLEnv *env)
567 {
568 return sform_begin_common ("begin", args, env);
569 }
570
sform_begin0(EsObject * args,DSLEnv * env)571 static EsObject* sform_begin0 (EsObject *args, DSLEnv *env)
572 {
573 if (es_null (args))
574 dsl_throw (TOO_FEW_ARGUMENTS, es_symbol_intern ("begin0"));
575
576 int count = 0;
577 EsObject *o, *o0 = es_false;
578 while (! es_null (args))
579 {
580 o = es_car (args);
581 o = dsl_eval0 (o, env);
582 if (!count++)
583 o0 = o;
584
585 if (es_error_p (o))
586 return o;
587 args = es_cdr (args);
588 }
589 return o0;
590 }
591
sfrom_and(EsObject * args,DSLEnv * env)592 static EsObject* sfrom_and (EsObject *args, DSLEnv *env)
593 {
594 EsObject *o = es_true;
595
596 while (! es_null (args))
597 {
598 o = es_car (args);
599 o = dsl_eval0 (o, env);
600 if (es_object_equal (o, es_false))
601 return es_false;
602 else if (es_error_p (o))
603 return o;
604 args = es_cdr (args);
605 }
606
607 return o;
608 }
609
sform_or(EsObject * args,DSLEnv * env)610 static EsObject* sform_or (EsObject *args, DSLEnv *env)
611 {
612 EsObject *o;
613
614 while (! es_null (args))
615 {
616 o = es_car (args);
617 o = dsl_eval0 (o, env);
618 if (! es_object_equal (o, es_false))
619 return o;
620 else if (es_error_p (o))
621 return o;
622 args = es_cdr (args);
623 }
624
625 return es_false;
626 }
627
sform_if(EsObject * args,DSLEnv * env)628 static EsObject* sform_if (EsObject *args, DSLEnv *env)
629 {
630 EsObject *o;
631
632 o = es_car (args);
633 o = dsl_eval0 (o, env);
634 if (!es_object_equal (o, es_false))
635 return dsl_eval0 (es_car (es_cdr (args)), env);
636 else if (es_error_p (o))
637 return o;
638 else
639 return dsl_eval0 (es_car (es_cdr (es_cdr (args))), env);
640
641 return es_false;
642 }
643
sform_cond(EsObject * args,DSLEnv * env)644 static EsObject* sform_cond (EsObject *args, DSLEnv *env)
645 {
646
647 while (!es_null(args))
648 {
649 EsObject *o = es_car (args);
650 args = es_cdr (args);
651
652 if (!es_cons_p (o))
653 dsl_throw (WRONG_TYPE_ARGUMENT, o);
654
655 EsObject *condition = es_car(o);
656 EsObject *actions = es_cdr(o);
657
658 EsObject *result = dsl_eval0 (condition, env);
659 if (es_error_p (result))
660 return result;
661
662 if (!es_object_equal (result, es_false))
663 {
664 if (es_null (actions))
665 return result;
666 return sform_begin_common("cond", actions, env);
667 }
668 }
669
670 return es_false;
671 }
672
builtin_not(EsObject * args,DSLEnv * env)673 static EsObject* builtin_not (EsObject *args, DSLEnv *env)
674 {
675 if (es_object_equal (es_car(args), es_false))
676 return es_true;
677 else if (es_error_p (es_car(args)))
678 return es_car(args);
679 else
680 return es_false;
681 }
682
683 #define DEFINE_OP_WITH_CHECK(N, X, C, E, O) \
684 static EsObject* builtin_##N (EsObject *args, DSLEnv *env) \
685 { \
686 EsObject *a, *b; \
687 \
688 a = es_car (args); \
689 b = es_car (es_cdr (args)); \
690 if (!C (a)) dsl_throw(E, O); \
691 if (!C (b)) dsl_throw(E, O); \
692 if (X) \
693 return es_true; \
694 else \
695 return es_false; \
696 }
697
builtin_eq(EsObject * args,DSLEnv * env)698 static EsObject* builtin_eq (EsObject *args, DSLEnv *env)
699 {
700 EsObject *a, *b;
701 a = es_car (args);
702 b = es_car (es_cdr (args));
703
704 if (es_object_equal(a, b))
705 return es_true;
706 else
707 return es_false;
708 }
709
710 DEFINE_OP_WITH_CHECK(lt, es_number_get (a) < es_number_get (b), es_number_p, NUMBER_REQUIRED, es_symbol_intern ("<"));
711 DEFINE_OP_WITH_CHECK(gt, es_number_get (a) > es_number_get (b), es_number_p, NUMBER_REQUIRED, es_symbol_intern (">"));
712 DEFINE_OP_WITH_CHECK(le, es_number_get (a) <= es_number_get (b), es_number_p, NUMBER_REQUIRED, es_symbol_intern ("<="));
713 DEFINE_OP_WITH_CHECK(ge, es_number_get (a) >= es_number_get (b), es_number_p, NUMBER_REQUIRED, es_symbol_intern (">="));
714
builtin_prefix(EsObject * args,DSLEnv * env)715 static EsObject* builtin_prefix (EsObject* args, DSLEnv *env)
716 {
717 EsObject *target = es_car (args);
718 EsObject *prefix = es_car (es_cdr (args));
719 const char *ts;
720 const char *ps;
721 size_t tl;
722 size_t pl;
723
724 if ((! es_string_p (target))
725 || (! es_string_p (prefix)))
726 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern ("prefix?"));
727
728 ts = es_string_get (target);
729 ps = es_string_get (prefix);
730 tl = strlen (ts);
731 pl = strlen (ps);
732 if (tl < pl)
733 return es_false;
734 return (strncmp (ts, ps, pl) == 0)? es_true: es_false;
735 }
736
builtin_suffix(EsObject * args,DSLEnv * env)737 static EsObject* builtin_suffix (EsObject* args, DSLEnv *env)
738 {
739 EsObject *target = es_car (args);
740 EsObject *suffix = es_car (es_cdr (args));
741 const char *ts;
742 const char *ss;
743 size_t tl;
744 size_t sl;
745 unsigned int d;
746
747 if ((! es_string_p (target))
748 || (! es_string_p (suffix)))
749 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern ("suffix?"));
750
751 ts = es_string_get (target);
752 ss = es_string_get (suffix);
753 tl = strlen (ts);
754 sl = strlen (ss);
755 if (tl < sl)
756 return es_false;
757 d = tl - sl;
758 return (strcmp (ts + d, ss) == 0)? es_true: es_false;
759 }
760
builtin_substr(EsObject * args,DSLEnv * env)761 static EsObject* builtin_substr (EsObject* args, DSLEnv *env)
762 {
763 EsObject *target = es_car (args);
764 EsObject *substr = es_car (es_cdr (args));
765 const char *ts;
766 const char *ss;
767
768 if ((! es_string_p (target))
769 || (! es_string_p (substr)))
770 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern("substr?"));
771 ts = es_string_get (target);
772 ss = es_string_get (substr);
773
774 return strstr(ts, ss) == NULL? es_false: es_true;
775 }
776
builtin_member(EsObject * args,DSLEnv * env)777 static EsObject* builtin_member (EsObject *args, DSLEnv *env)
778 {
779 EsObject *elt = es_car (args);
780 EsObject *lst = es_car (es_cdr (args));
781
782 if (! es_list_p (lst))
783 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern ("member"));
784
785 while (!es_null (lst))
786 {
787 if (es_object_equal (elt, es_car (lst)))
788 return lst;
789 lst = es_cdr (lst);
790 }
791
792 return es_false;
793 }
794
caseop(EsObject * o,int (* op)(int))795 static EsObject* caseop (EsObject *o, int (*op)(int))
796 {
797 if (es_string_p (o))
798 {
799 const char *s = es_string_get (o);
800 char *r = strdup (s);
801
802 for (char *tmp = r; *tmp != '\0'; tmp++)
803 *tmp = op (*tmp);
804
805 EsObject *q = es_object_autounref (es_string_new (r));
806 free (r);
807 return q;
808 }
809 else
810 return o;
811 }
812
downcase(EsObject * o)813 static EsObject* downcase (EsObject *o)
814 {
815 return caseop (o, tolower);
816 }
817
upcase(EsObject * o)818 static EsObject* upcase (EsObject *o)
819 {
820 return caseop (o, toupper);
821 }
822
builtin_caseop0(EsObject * o,EsObject * (* op)(EsObject *))823 static EsObject* builtin_caseop0 (EsObject *o,
824 EsObject *(* op) (EsObject*))
825 {
826 if (es_null (o)
827 || es_error_p (o))
828 return o;
829 else if (es_list_p (o))
830 {
831 EsObject *oa = es_car (o);
832 EsObject *od = es_cdr (o);
833 EsObject *da, *dd;
834
835 da = op (oa);
836 if (es_error_p (da))
837 return da;
838 dd = builtin_caseop0 (od, op);
839 if (es_error_p (dd))
840 return dd;
841
842 return es_object_autounref (es_cons (da, dd));
843 }
844 else
845 return op (o);
846 }
847
builtin_downcase(EsObject * args,DSLEnv * env)848 static EsObject* builtin_downcase (EsObject *args, DSLEnv *env)
849 {
850 EsObject *o = es_car(args);
851 return builtin_caseop0 (o, downcase);
852 }
853
builtin_upcase(EsObject * args,DSLEnv * env)854 static EsObject* builtin_upcase (EsObject *args, DSLEnv *env)
855 {
856 EsObject *o = es_car(args);
857 return builtin_caseop0 (o, upcase);
858 }
859
builtin_length(EsObject * args,DSLEnv * env)860 static EsObject* builtin_length (EsObject *args, DSLEnv *env)
861 {
862 EsObject *o = es_car(args);
863 if (es_error_p (o))
864 return o;
865 if (!es_string_p (o))
866 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern ("length"));
867
868 const char *cstr = es_string_get (o);
869 size_t len = strlen (cstr);
870 return es_object_autounref (es_integer_new ((int)len));
871 }
872
873 static MIO *miodebug;
bulitin_debug_print(EsObject * args,DSLEnv * env)874 static EsObject* bulitin_debug_print (EsObject *args, DSLEnv *env)
875 {
876 if (miodebug == NULL)
877 miodebug = mio_new_fp (stderr, NULL);
878
879 EsObject *o = es_car(args);
880 es_print(o, miodebug);
881 putc('\n', stderr);
882
883 return o;
884 }
885
886 /*
887 * Accessesors for tagEntry
888 */
889
890 /*
891 * Value functions
892 */
893 DEFINE_VALUE_FN(name)
DEFINE_VALUE_FN(input)894 DEFINE_VALUE_FN(input)
895 DEFINE_VALUE_FN(pattern)
896 DEFINE_VALUE_FN(line)
897
898 DEFINE_VALUE_FN(access)
899 DEFINE_VALUE_FN(end)
900 DEFINE_VALUE_FN(extras)
901 DEFINE_VALUE_FN(file)
902 DEFINE_VALUE_FN(inherits)
903 DEFINE_VALUE_FN(implementation)
904 DEFINE_VALUE_FN(kind)
905 DEFINE_VALUE_FN(language)
906 DEFINE_VALUE_FN(scope)
907 DEFINE_VALUE_FN(scope_kind)
908 DEFINE_VALUE_FN(scope_name)
909 DEFINE_VALUE_FN(signature)
910 DEFINE_VALUE_FN(typeref)
911 DEFINE_VALUE_FN(typeref_kind)
912 DEFINE_VALUE_FN(typeref_name)
913 DEFINE_VALUE_FN(roles)
914 DEFINE_VALUE_FN(xpath)
915
916 static const char*entry_xget (const tagEntry *entry, const char* name)
917 {
918 unsigned int i;
919 unsigned short count = entry->fields.count;
920 tagExtensionField *list = entry->fields.list;
921
922 for (i = 0; i < count; ++i)
923 {
924 if (strcmp (list [i].key, name) == 0)
925 return list [i].value;
926 }
927 return NULL;
928
929 }
930
dsl_entry_xget_string(const tagEntry * entry,const char * name)931 EsObject* dsl_entry_xget_string (const tagEntry *entry, const char* name)
932 {
933 const char* value = entry_xget (entry, name);
934 if (value)
935 return es_object_autounref (es_string_new (value));
936 else
937 return es_false;
938 }
939
940 /*
941 * Accessesors for tagEntry
942 */
943
builtin_entry_ref(EsObject * args,DSLEnv * env)944 static EsObject* builtin_entry_ref (EsObject *args, DSLEnv *env)
945 {
946 EsObject *key = es_car(args);
947
948 if (es_error_p (key))
949 return key;
950 else if (! es_string_p (key))
951 dsl_throw (WRONG_TYPE_ARGUMENT, es_symbol_intern ("$"));
952 else
953 return dsl_entry_xget_string (env->entry, es_string_get (key));
954 }
955
dsl_entry_name(const tagEntry * entry)956 EsObject* dsl_entry_name (const tagEntry *entry)
957 {
958 return es_object_autounref (es_string_new (entry->name));
959 }
960
dsl_entry_input(const tagEntry * entry)961 EsObject* dsl_entry_input (const tagEntry *entry)
962 {
963 return es_object_autounref (es_string_new (entry->file));
964 }
965
dsl_entry_access(const tagEntry * entry)966 EsObject* dsl_entry_access (const tagEntry *entry)
967 {
968 return dsl_entry_xget_string (entry, "access");
969 }
970
dsl_entry_file(const tagEntry * entry)971 EsObject* dsl_entry_file (const tagEntry *entry)
972 {
973 return entry->fileScope? es_true: es_false;
974 }
975
dsl_entry_language(const tagEntry * entry)976 EsObject* dsl_entry_language (const tagEntry *entry)
977 {
978 return dsl_entry_xget_string (entry, "language");
979 }
980
dsl_entry_implementation(const tagEntry * entry)981 EsObject* dsl_entry_implementation (const tagEntry *entry)
982 {
983 return dsl_entry_xget_string (entry, "implementation");
984 }
985
dsl_entry_signature(const tagEntry * entry)986 EsObject* dsl_entry_signature (const tagEntry *entry)
987 {
988 return dsl_entry_xget_string (entry, "signature");
989 }
990
dsl_entry_line(const tagEntry * entry)991 EsObject* dsl_entry_line (const tagEntry *entry)
992 {
993 unsigned long ln = entry->address.lineNumber;
994
995 if (ln == 0)
996 return es_false;
997 else
998 return es_object_autounref (es_integer_new (ln));
999 }
1000
dsl_entry_extras(const tagEntry * entry)1001 EsObject* dsl_entry_extras (const tagEntry *entry)
1002 {
1003 return dsl_entry_xget_string (entry, "extras");
1004 }
1005
dsl_entry_end(const tagEntry * entry)1006 EsObject* dsl_entry_end (const tagEntry *entry)
1007 {
1008 const char *end_str = entry_xget(entry, "end");
1009 EsObject *o;
1010
1011 if (end_str)
1012 {
1013 o = es_read_from_string (end_str, NULL);
1014 if (es_integer_p (o))
1015 return es_object_autounref (o);
1016 else
1017 return es_false;
1018 }
1019 else
1020 return es_false;
1021 }
1022
dsl_entry_kind(const tagEntry * entry)1023 EsObject* dsl_entry_kind (const tagEntry *entry)
1024 {
1025 const char* kind;
1026 kind = entry->kind;
1027
1028 if (kind)
1029 return es_object_autounref (es_string_new (entry->kind));
1030 else
1031 return es_false;
1032 }
1033
dsl_entry_roles(const tagEntry * entry)1034 EsObject* dsl_entry_roles (const tagEntry *entry)
1035 {
1036 return dsl_entry_xget_string(entry, "roles");
1037 }
1038
dsl_entry_pattern(const tagEntry * entry)1039 EsObject* dsl_entry_pattern (const tagEntry *entry)
1040 {
1041 const char *pattern = entry->address.pattern;
1042
1043 if (pattern == NULL)
1044 return es_false;
1045 else
1046 return es_object_autounref (es_string_new (pattern));
1047 }
1048
dsl_entry_inherits(const tagEntry * entry)1049 EsObject* dsl_entry_inherits (const tagEntry *entry)
1050 {
1051 return dsl_entry_xget_string (entry, "inherits");
1052 }
1053
dsl_entry_scope(const tagEntry * entry)1054 EsObject* dsl_entry_scope (const tagEntry *entry)
1055 {
1056 return dsl_entry_xget_string (entry, "scope");
1057 }
1058
dsl_entry_typeref(const tagEntry * entry)1059 EsObject* dsl_entry_typeref (const tagEntry *entry)
1060 {
1061 return dsl_entry_xget_string (entry, "typeref");
1062 }
1063
dsl_entry_xpath(const tagEntry * entry)1064 EsObject* dsl_entry_xpath (const tagEntry *entry)
1065 {
1066 return dsl_entry_xget_string (entry, "xpath");
1067 }
1068
dsl_entry_scope_kind(const tagEntry * entry)1069 EsObject* dsl_entry_scope_kind (const tagEntry *entry)
1070 {
1071 const char* scope = entry_xget (entry, "scope");
1072 const char* kind;
1073 EsObject *r;
1074
1075 if (scope == NULL)
1076 return es_false;
1077
1078 kind = strchr (scope, ':');
1079 if (kind == NULL)
1080 return es_false;
1081
1082 r = es_object_autounref (es_string_newL (scope,
1083 kind - scope));
1084 return r;
1085 }
1086
dsl_entry_scope_name(const tagEntry * entry)1087 EsObject* dsl_entry_scope_name (const tagEntry *entry)
1088 {
1089 const char* scope = entry_xget (entry, "scope");
1090 const char* kind;
1091 EsObject *r;
1092
1093 if (scope == NULL)
1094 return es_false;
1095
1096 kind = strchr (scope, ':');
1097 if (kind == NULL)
1098 return es_false;
1099
1100 if (*(kind + 1) == '\0')
1101 return es_false;
1102
1103 r = es_object_autounref (es_string_new (kind + 1));
1104
1105 return r;
1106 }
1107
dsl_entry_typeref_kind(const tagEntry * entry)1108 EsObject* dsl_entry_typeref_kind (const tagEntry *entry)
1109 {
1110 const char* typeref = entry_xget (entry, "typeref");
1111 const char* kind;
1112 EsObject *r;
1113
1114 if (typeref == NULL)
1115 return es_false;
1116
1117 kind = strchr (typeref, ':');
1118 if (kind == NULL)
1119 return es_false;
1120
1121 r = es_object_autounref (es_string_newL (typeref,
1122 kind - typeref));
1123 return r;
1124 }
1125
dsl_entry_typeref_name(const tagEntry * entry)1126 EsObject* dsl_entry_typeref_name (const tagEntry *entry)
1127 {
1128 const char* typeref = entry_xget (entry, "typeref");
1129 const char* kind;
1130 EsObject *r;
1131
1132 if (typeref == NULL)
1133 return es_false;
1134
1135 kind = strchr (typeref, ':');
1136 if (kind == NULL)
1137 return es_false;
1138
1139 if (*(kind + 1) == '\0')
1140 return es_false;
1141
1142 r = es_object_autounref (es_string_new (kind + 1));
1143
1144 return r;
1145 }
1146
accumulate_length(EsObject * elt,void * data)1147 static EsObject* accumulate_length (EsObject *elt, void *data)
1148 {
1149 size_t *len = data;
1150 if (!es_string_p (elt))
1151 dsl_throw (STRING_REQUIRED, elt);
1152
1153 const char *s = es_string_get (elt);
1154 *len += strlen (s);
1155
1156 return es_false;
1157 }
1158
string_accumulate(EsObject * elt,void * data)1159 static EsObject* string_accumulate (EsObject *elt, void *data)
1160 {
1161 char **cursor = data;
1162 const char *s;
1163 char *t;
1164
1165 for (s = es_string_get(elt), t = *cursor;
1166 *s != '\0';
1167 s++, t++)
1168 *t = *s;
1169 *cursor = t;
1170 return es_false;
1171 }
1172
builtin_string_append(EsObject * args,DSLEnv * env)1173 static EsObject* builtin_string_append (EsObject *args, DSLEnv *env)
1174 {
1175 size_t len = 0;
1176
1177 EsObject *r = es_foreach (accumulate_length, args, &len);
1178 if (!es_object_equal (r, es_false))
1179 return r;
1180
1181 char *buf = malloc (len + 1);
1182 if (buf == NULL)
1183 return ES_ERROR_MEMORY;
1184
1185 char *cursor = buf;
1186 r = es_foreach (string_accumulate, args, &cursor);
1187 if (!es_object_equal (r, es_false))
1188 goto out;
1189 *cursor = '\0';
1190
1191 r = es_string_new (buf);
1192
1193 out:
1194 free (buf);
1195 return es_object_autounref (r);
1196 }
1197
optimize_strings(EsObject * kar,EsObject * kdr,void * user_data)1198 static EsObject* optimize_strings (EsObject *kar, EsObject *kdr, void *user_data)
1199 {
1200 EsObject *r;
1201 if (!es_string_p (kar))
1202 {
1203 r = es_cons (kar, kdr);
1204 return r;
1205 }
1206
1207 EsObject *kadr = es_car (kdr);
1208 if (!es_string_p (kadr))
1209 {
1210 r = es_cons (kar, kdr);
1211 return r;
1212 }
1213
1214 const char *kar_str = es_string_get (kar);
1215 const char *kadr_str = es_string_get (kadr);
1216 size_t kar_len = strlen (kar_str);
1217 size_t kadr_len = strlen (kadr_str);
1218 char *buf = malloc (kar_len + kadr_len + 1);
1219 if (buf == NULL)
1220 return ES_ERROR_MEMORY;
1221
1222 memcpy (buf, kadr_str, kadr_len);
1223 memcpy (buf + kadr_len, kar_str, kar_len);
1224 buf [kadr_len + kar_len] = '\0';
1225
1226 EsObject *elt = es_object_autounref (es_string_new (buf));
1227 free (buf);
1228
1229 if (es_error_p (elt))
1230 return ES_ERROR_MEMORY;
1231
1232 r = es_cons (elt, es_cdr (kdr));
1233
1234 return r;
1235 }
1236
macro_string_append(EsObject * expr)1237 static EsObject* macro_string_append (EsObject *expr)
1238 {
1239 EsObject *new_expr;
1240 EsObject *list = es_cdr (expr);
1241 EsObject *r = es_fold (optimize_strings,
1242 es_nil, list, NULL);
1243
1244 if (es_error_p (r))
1245 return es_error_set_object (r, expr);
1246
1247 EsObject *str = es_car (r);
1248 if (es_string_p (str) && es_null (es_cdr (r)))
1249 new_expr = es_object_ref (str);
1250 else
1251 {
1252 EsObject *kar = es_car (expr);
1253 EsObject* rr = es_reverse (r);
1254 new_expr = es_cons (kar, rr);
1255 es_object_unref (rr);
1256 }
1257 es_object_unref (r);
1258 return new_expr;
1259 }
1260
builtin_add(EsObject * args,DSLEnv * env)1261 static EsObject* builtin_add (EsObject *args, DSLEnv *env)
1262 {
1263 EsObject *a = es_car (args);
1264 if (!es_integer_p (a))
1265 dsl_throw (INTEGER_REQUIRED,
1266 es_symbol_intern ("+"));
1267
1268 EsObject *b = es_car (es_cdr (args));
1269 if (!es_integer_p (b))
1270 dsl_throw (INTEGER_REQUIRED,
1271 es_symbol_intern ("+"));
1272
1273 int ai = es_integer_get (a);
1274 int bi = es_integer_get (b);
1275
1276 return es_object_autounref (es_integer_new (ai + bi));
1277 }
1278
builtin_sub(EsObject * args,DSLEnv * env)1279 static EsObject* builtin_sub (EsObject *args, DSLEnv *env)
1280 {
1281 EsObject *a = es_car (args);
1282 if (!es_integer_p (a))
1283 dsl_throw (INTEGER_REQUIRED,
1284 es_symbol_intern ("-"));
1285
1286 EsObject *b = es_car (es_cdr (args));
1287 if (!es_integer_p (b))
1288 dsl_throw (INTEGER_REQUIRED,
1289 es_symbol_intern ("-"));
1290
1291 int ai = es_integer_get (a);
1292 int bi = es_integer_get (b);
1293
1294 return es_object_autounref (es_integer_new (ai - bi));
1295 }
1296
value_true(EsObject * args,DSLEnv * env)1297 static EsObject* value_true (EsObject *args, DSLEnv *env)
1298 {
1299 return es_true;
1300 }
1301
value_false(EsObject * args,DSLEnv * env)1302 static EsObject* value_false (EsObject *args, DSLEnv *env)
1303 {
1304 return es_false;
1305 }
1306
value_nil(EsObject * args,DSLEnv * env)1307 static EsObject* value_nil (EsObject *args, DSLEnv *env)
1308 {
1309 return es_nil;
1310 }
1311
common_string2regexp(EsObject * args,DSLEnv * env,EsObject * original_expr)1312 static EsObject* common_string2regexp (EsObject *args, DSLEnv *env,
1313 EsObject *original_expr)
1314 {
1315 static EsObject *self = es_nil;
1316 if (self == es_nil)
1317 self = es_symbol_intern ("string->regexp");
1318
1319 if (!es_cons_p (args))
1320 dsl_throw(TOO_FEW_ARGUMENTS,
1321 (original_expr == es_nil)
1322 ? self
1323 : es_car (original_expr));
1324 else if (!es_string_p (es_car (args)))
1325 {
1326 if (original_expr == es_nil)
1327 dsl_throw(STRING_REQUIRED, self);
1328 else
1329 return es_object_ref (original_expr);
1330 }
1331 else
1332 {
1333 static EsObject *case_fold_key = es_nil;
1334 if (case_fold_key == es_nil)
1335 case_fold_key = es_symbol_intern (":case-fold");
1336 static EsObject *false_val = es_nil;
1337 if (false_val == es_nil)
1338 false_val = es_symbol_intern ("false");
1339
1340 EsObject *case_fold = es_car (es_cdr (args));
1341 EsObject *pattern = es_car (args);
1342 int icase = 0;
1343
1344 if (!es_null (case_fold))
1345 {
1346 if (!es_object_equal (case_fold, case_fold_key))
1347 dsl_throw (WRONG_TYPE_ARGUMENT,
1348 (original_expr == es_nil)? self: original_expr);
1349
1350 case_fold = es_car (es_cdr (es_cdr (args)));
1351 if (es_null (case_fold))
1352 dsl_throw (TOO_FEW_ARGUMENTS,
1353 (original_expr == es_nil)? self: original_expr);
1354
1355 icase = ! (es_object_equal(case_fold, es_false)
1356 /* TODO: remove the next condition. */
1357 || es_object_equal(case_fold, false_val));
1358 }
1359
1360 EsObject *r = es_regex_compile (es_string_get (pattern), icase);
1361 return (original_expr == es_nil)? es_object_autounref (r): r;
1362 }
1363 }
1364
builtin_string2regexp(EsObject * args,DSLEnv * env)1365 static EsObject* builtin_string2regexp (EsObject *args, DSLEnv *env)
1366 {
1367 return common_string2regexp (args, env, es_nil);
1368 }
1369
macro_string2regexp(EsObject * expr)1370 static EsObject* macro_string2regexp (EsObject *expr)
1371 {
1372 return common_string2regexp (es_cdr (expr), NULL, expr);
1373 }
1374
common_regexp_quote(EsObject * args,DSLEnv * env,EsObject * original_expr)1375 static EsObject* common_regexp_quote (EsObject *args, DSLEnv *env,
1376 EsObject *original_expr)
1377 {
1378 static EsObject *self = es_nil;
1379 if (self == es_nil)
1380 self = es_symbol_intern ("regexp-quote");
1381
1382 if (original_expr != es_nil && !es_cons_p (args))
1383 dsl_throw(TOO_FEW_ARGUMENTS,
1384 es_car (original_expr));
1385
1386 EsObject *unquoted_str = es_car (args);
1387 if (!es_string_p (unquoted_str))
1388 {
1389 if (original_expr == es_nil)
1390 dsl_throw(STRING_REQUIRED, self);
1391 else
1392 return es_object_ref (original_expr);
1393 }
1394
1395 const char *src = es_string_get (unquoted_str);
1396 if (src[0] == '\0')
1397 return (original_expr == es_nil)
1398 ? unquoted_str
1399 : es_object_ref (unquoted_str);
1400
1401 size_t len = strlen (src);
1402 char *buf = malloc (len * 2 + 1);
1403 if (!buf)
1404 return ES_ERROR_MEMORY;
1405
1406 char *dst = buf;
1407 for (size_t i = 0; i < len; i++)
1408 {
1409 if (strchr ("[{.*+]}^$()|?\\", src [i]))
1410 *dst++ = '\\';
1411 *dst++ = src[i];
1412 }
1413 *dst = '\0';
1414 EsObject *r = es_string_new (buf);
1415 free (buf);
1416 return (original_expr == es_nil)? es_object_autounref (r): r;
1417 }
1418
builtin_regexp_quote(EsObject * args,DSLEnv * env)1419 static EsObject* builtin_regexp_quote (EsObject *args, DSLEnv *env)
1420 {
1421 return common_regexp_quote (args, env, es_nil);
1422 }
1423
macro_regexp_quote(EsObject * expr)1424 static EsObject* macro_regexp_quote (EsObject *expr)
1425 {
1426 return common_regexp_quote (es_cdr (expr), NULL, expr);
1427 }
1428
macro_debug_printX(EsObject * expr)1429 static EsObject* macro_debug_printX (EsObject *expr)
1430 {
1431 EsObject *code = es_cdr (expr);
1432 bulitin_debug_print (code, NULL);
1433 return es_object_ref(es_car (code));
1434 }
1435
dsl_report_error(const char * msg,EsObject * obj)1436 void dsl_report_error (const char *msg, EsObject *obj)
1437 {
1438 MIO *mioerr = mio_new_fp (stderr, NULL);
1439
1440 if (es_error_p (obj))
1441 {
1442 fprintf(stderr, "%s: %s: ", msg, es_error_name (obj));
1443 es_print(es_error_get_object(obj), mioerr);
1444 }
1445 else
1446 {
1447 fprintf(stderr, "%s: ", msg);
1448 es_print(obj, mioerr);
1449 }
1450 putc('\n', stderr);
1451 mio_unref(mioerr);
1452 }
1453