1 // for x in $(grep ^declop ~/var/ctags/dsl/optscript.c | sed -e 's/declop(\([^)]*\));/\1/'); do grep -q $x Tmain/optscript.d/*.ps || echo $x; done
2 /*
3 * Copyright (c) 2020, Masatake YAMATO
4 * Copyright (c) 2020, Red Hat, Inc.
5 *
6 * This source code is released for free distribution under the terms of the
7 * GNU General Public License version 2 or (at your option) any later version.
8 */
9
10
11 #include "general.h"
12
13 #include "debug.h"
14 #include "es.h"
15 #include "htable.h"
16 #include "optscript.h"
17 #include "ptrarray.h"
18 #include "routines.h"
19 #include "vstring.h"
20
21 #include <ctype.h>
22 #include <string.h>
23
24
25 struct sOptVM
26 {
27 ptrArray *ostack;
28 ptrArray *dstack;
29 ptrArray *estack;
30
31 int dstack_protection;
32 MIO *in;
33 MIO *out;
34 MIO *err;
35
36 EsObject *error;
37
38 int print_depth;
39 int read_depth;
40 char *prompt;
41 void *app_data;
42 };
43
44 typedef struct sOperatorFat
45 {
46 EsObject *name;
47 int arity;
48 const char *help_str;
49 } OperatorFat;
50
51 typedef struct sOperatorExtra
52 {
53 const char *name;
54 int arity;
55 const char *help_str;
56 } OperatorExtra;
57
58 typedef OptOperatorFn Operator;
59
60 typedef enum eAttr {
61 ATTR_READABLE = 1 << 0,
62 ATTR_WRITABLE = 1 << 1,
63 ATTR_EXECUTABLE = 1 << 2,
64 } Attr;
65
66 typedef struct sDictFat
67 {
68 unsigned int attr;
69 } DictFat;
70
71 typedef struct sArrayFat
72 {
73 unsigned int attr;
74 } ArrayFat;
75
76 typedef struct sStringFat
77 {
78 unsigned int attr;
79 } StringFat;
80
81 typedef struct sNameFat
82 {
83 unsigned int attr;
84 } NameFat;
85
86 static EsObject* opt_system_dict;
87
88 int OPT_TYPE_ARRAY;
89 int OPT_TYPE_DICT;
90 int OPT_TYPE_OPERATOR;
91 int OPT_TYPE_STRING;
92 int OPT_TYPE_NAME;
93 int OPT_TYPE_MARK;
94
95 static EsObject *OPT_ERR_UNDEFINED;
96 static EsObject *OPT_ERR_SYNTAX;
97 EsObject *OPT_ERR_UNDERFLOW;
98 EsObject *OPT_ERR_TYPECHECK;
99 EsObject *OPT_ERR_RANGECHECK;
100 static EsObject *OPT_ERR_DICTSTACKUNDERFLOW;
101 static EsObject *OPT_ERR_UNMATCHEDMARK;
102 static EsObject *OPT_ERR_INTERNALERROR;
103 static EsObject *OPT_ERR_END_PROC;
104 static EsObject *OPT_ERR_INVALIDEXIT;
105 static EsObject *OPT_ERR_STOPPED;
106 EsObject *OPT_ERR_QUIT;
107 static EsObject *OPT_ERR_INVALIDACCESS;
108 static EsObject *OPT_ERR_INTOVERFLOW;
109
110 static EsObject* OPT_MARK_ARRAY;
111 static EsObject* OPT_MARK_DICT;
112 static EsObject* OPT_MARK_MARK;
113
114 static EsObject* OPT_KEY_newerror;
115 static EsObject* OPT_KEY_errorname;
116 static EsObject* OPT_KEY_command;
117 static EsObject* OPT_KEY_ostack;
118 static EsObject* OPT_KEY_estack;
119 static EsObject* OPT_KEY_dstack;
120
121 /* Naming conversions
122 *
123 * Opt|OPT
124 * =====================================================================
125 * exported as part of the library API
126 *
127 * optscript and ctags may refer these names.
128 *
129 *
130 * <datatype>_...
131 * =====================================================================
132 * functions released to PS datatypes
133 * PS datatypes are array, dict, operator, ...
134 *
135 * <datatype>_es_...
136 * ---------------------------------------------------------------------
137 * functions for representing the PS datatype object as EsObject object
138 *
139 * <datatype>_op_...
140 * ---------------------------------------------------------------------
141 * functions for accessing the datatype object from vm internal purpose
142 *
143 *
144 * op_...<operator>
145 * =====================================================================
146 * functions implementing operators
147 *
148 *
149 * vm_...
150 * =====================================================================
151 * the rest VM related functions
152 *
153 */
154
155 static EsObject* array_new (unsigned int attr);
156
157 static EsObject* array_es_init_fat (void *fat, void *ptr, void *extra);
158 static void array_es_free (void *ptr, void *fat);
159 static int array_es_equal (const void *a,
160 const void *afat,
161 const void *b,
162 const void *bfat);
163 static void array_es_print (const void *ptr, const void *fat, MIO *out);
164
165 static void array_op_add (EsObject* array, EsObject* elt);
166 static unsigned int array_op_length (const EsObject* array);
167 static EsObject* array_op_get (const EsObject* array, unsigned int n);
168 static void array_op_put (EsObject* array, unsigned int n, EsObject *obj);
169
170
171 static EsObject* dict_new (unsigned int size, unsigned int attr);
172
173 static EsObject* dict_es_init_fat (void *fat, void *ptr, void *extra);
174 static void dict_es_free (void *ptr, void *fat);
175 static int dict_es_equal (const void *a,
176 const void *afat,
177 const void *b,
178 const void *bfat);
179 static void dict_es_print (const void *ptr, const void *fat, MIO *out);
180
181
182 static void dict_op_def (EsObject* dict, EsObject *key, EsObject *val);
183 static bool dict_op_undef (EsObject* dict, EsObject *key);
184 static bool dict_op_known_and_get (EsObject* dict, EsObject *key, EsObject **val);
185 static void dict_op_clear (EsObject* dict);
186
187
188 static EsObject* operator_new (Operator op, const char *name, int arity, const char *help_str);
189
190 static EsObject* operator_es_init_fat (void *fat, void *ptr, void *extra);
191 static void operator_es_print (const void *ptr, const void *fat, MIO *out);
192 static void operator_es_free (void *ptr, void *fat);
193
194
195 static EsObject* string_new (vString *vstr);
196
197 static EsObject* string_es_init_fat (void *fat, void *ptr, void *extra);
198 static void string_es_free (void *ptr, void *fat);
199 static int string_es_equal (const void *a,
200 const void *afat,
201 const void *b,
202 const void *bfat);
203 static void string_es_print (const void *ptr, const void *fat, MIO *out);
204
205
206 static EsObject* name_new (EsObject* symbol, unsigned int attr);
207 static EsObject* name_newS (const char*s, unsigned int attr);
208 static EsObject* name_newS_cb (const char*s, void *attr);
209
210 static EsObject* name_es_init_fat (void *fat, void *ptr, void *extra);
211 static void name_es_print (const void *ptr, const void *fat, MIO *out);
212 static void name_es_free (void *ptr, void *fat);
213 static int name_es_equal (const void *a,
214 const void *afat,
215 const void *b,
216 const void *bfat);
217
218
219 static EsObject* mark_new (const char* mark);
220
221 static void mark_es_print (const void *ptr, MIO *out);
222 static void mark_es_free (void *ptr);
223 static int mark_es_equal (const void *a, const void *b);
224
225 static EsObject* vm_read (OptVM *vm);
226 static EsObject* vm_call_operator (OptVM *vm, EsObject *op);
227 static EsObject* vm_call_proc (OptVM *vm, EsObject *proc);
228 static void vm_print (OptVM *vm, EsObject *o);
229 static void vm_print_full (OptVM *vm, EsObject *o, bool string_as_is, int dict_recursion);
230 static void vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data);
231 static void vm_record_stop (OptVM *vm, EsObject *cmd);
232 static void vm_record_error (OptVM *vm, EsObject *e, EsObject *cmd);
233 static void vm_report_error (OptVM *vm, EsObject *e);
234 static void vm_bind_proc (OptVM *vm, ptrArray *proc);
235
236 static void vm_ostack_push (OptVM *vm, EsObject *o);
237 static EsObject* vm_ostack_pop (OptVM *vm);
238 static unsigned int vm_ostack_count (OptVM *vm);
239 static EsObject* vm_ostack_top (OptVM *vm);
240 static EsObject* vm_ostack_peek (OptVM *vm, int index_from_top);
241 static int vm_ostack_counttomark (OptVM *vm);
242
243 static void vm_dict_def (OptVM *vm, EsObject *key, EsObject *val);
244
245 /* Returns the dictionary where the value for the key is found.
246 * val can be NULL. */
247 static EsObject* vm_dstack_known_and_get (OptVM *vm, EsObject *key, EsObject **val);
248 static void vm_dstack_push (OptVM *vm, EsObject *o);
249 /* FIXME: return type */
250 static int vm_dstack_count (OptVM *vm);
251 static EsObject* vm_dstack_pop (OptVM *vm);
252 static void vm_dstack_clear (OptVM *vm);
253
254 static EsObject* vm_estack_push (OptVM *vm, EsObject *p);
255 static EsObject* vm_estack_pop (OptVM *vm);
256
257 #define declop(OP) \
258 static EsObject* op_##OP(OptVM *vm, EsObject *name)
259
260
261 #define defOP(DICT, FN, NAME, ARITY, HELP) \
262 dict_op_def (DICT, \
263 es_object_autounref(es_symbol_intern (NAME)), \
264 es_object_autounref(operator_new (FN, NAME, ARITY, HELP)))
265
266 #define defop(DICT, NAME, ARITY, HELP) \
267 defOP (DICT, op_##NAME, #NAME, ARITY, HELP)
268
269 static EsObject* op__print_objdict_rec (OptVM *vm, EsObject *name);
270 static EsObject* op__print_objdict (OptVM *vm, EsObject *name);
271 static EsObject* op__print_object (OptVM *vm, EsObject *name);
272 static EsObject* op__print (OptVM *vm, EsObject *name);
273 static EsObject* op__make_array (OptVM *vm, EsObject *name);
274 static EsObject* op__make_dict (OptVM *vm, EsObject *name);
275
276 /* non-standard operator */
277 declop(_help);
278
279 /* tested in pstack.ps */
280 declop(pstack);
281
282 /* error related non-standard operators */
283 declop(_newerror);
284 declop(_errorname);
285
286 /* Operators for operand stack manipulation
287 * tested in stack.ps */
288 declop(pop);
289 declop(exch);
290 declop(dup);
291 declop(index);
292 declop(roll);
293 declop(clear);
294 declop(count);
295 declop(mark);
296 declop(cleartomark);
297 declop(counttomark);
298
299 /* Arithmetic Operators
300 tested in arithmetic.ps */
301 declop(add);
302 declop(idiv);
303 declop(mod);
304 declop(mul);
305 declop(sub);
306 declop(abs);
307 declop(neg);
308
309 /* Operators for array manipulation
310 tested in array.ps */
311 declop(array);
312 declop(astore);
313 declop(aload);
314
315 /* Operators for dictionary manipulation
316 * tested in dict.ps */
317 declop(dict);
318 declop(begin);
319 declop(end);
320 declop(def);
321 declop(load);
322 declop(undef);
323 declop(known);
324 declop(where);
325 declop(currentdict);
326 declop(countdictstack);
327 declop(store);
328 declop(dictstack);
329 declop(cleardictstack);
330
331 /* Operators for string manipulation
332 tested in string.ps */
333 /* -anchorsearch, -search, -token */
334 declop(string);
335 declop(_strstr);
336 declop(_strrstr);
337 declop(_strchr);
338 declop(_strrchr);
339 declop(_strpbrk);
340
341 /* Relation, logical, and bit operators
342 tested in relalogbit.ps */
343 declop(eq);
344 declop(ne);
345 declop(true);
346 declop(false);
347 declop(and);
348 declop(or);
349 declop(xor);
350 declop(not);
351 declop(bitshift);
352 declop(ge);
353 declop(gt);
354 declop(le);
355 declop(lt);
356
357 /* Operators for control flow
358 * tested in control.ps */
359 declop(exec);
360 declop(if);
361 declop(ifelse);
362 declop(repeat);
363 declop(loop);
364 declop(exit);
365 declop(stop);
366 declop(stopped);
367 declop(for);
368 declop(quit);
369 declop(countexecstack);
370 declop(execstack);
371 /* ?start */
372
373 /* Operators for type, attribute and their conversion
374 * tested in typeattrconv.ps */
375 declop(type);
376 declop(cvn);
377 /* cvlit, cvx, xcheck, executeonly, noacess, readonly,
378 rcheck, wcheck, cvi, cvr, cvrs, cvs,... */
379
380 /* Operators for Virtual Memory Operators */
381 /* ?save, ?restore */
382
383 /* Misc operators
384 * tested in misc.ps */
385 declop(null);
386 declop(bind);
387
388 /* Methods for compound objects
389 tested in compound.ps */
390 declop(length);
391 declop(copy);
392 declop(get);
393 declop(put);
394 declop(forall);
395 declop(putinterval);
396 declop(_copyinterval);
397 /* -getinterval .... */
398
399
400 /*
401 * Public functions
402 */
403
404 int
opt_init(void)405 opt_init (void)
406 {
407 OPT_TYPE_ARRAY = es_type_define_fatptr ("arraytype",
408 sizeof (ArrayFat),
409 array_es_init_fat,
410 array_es_free,
411 array_es_equal,
412 array_es_print);
413 OPT_TYPE_DICT = es_type_define_fatptr ("dicttype",
414 sizeof (DictFat),
415 dict_es_init_fat,
416 dict_es_free,
417 dict_es_equal,
418 dict_es_print);
419 OPT_TYPE_OPERATOR = es_type_define_fatptr ("operatortype",
420 sizeof (OperatorFat),
421 operator_es_init_fat,
422 operator_es_free,
423 NULL,
424 operator_es_print);
425 OPT_TYPE_STRING = es_type_define_fatptr ("stringtype",
426 sizeof (StringFat),
427 string_es_init_fat,
428 string_es_free,
429 string_es_equal,
430 string_es_print);
431 OPT_TYPE_NAME = es_type_define_fatptr ("nametype",
432 sizeof (NameFat),
433 name_es_init_fat,
434 name_es_free,
435 name_es_equal,
436 name_es_print);
437 OPT_TYPE_MARK = es_type_define_pointer ("marktype",
438 mark_es_free,
439 mark_es_equal,
440 mark_es_print);
441
442 OPT_ERR_UNDEFINED = es_error_intern ("undefined");
443 OPT_ERR_SYNTAX = es_error_intern ("syntaxerror");
444 OPT_ERR_UNDERFLOW = es_error_intern ("stackunderflow");
445 OPT_ERR_TYPECHECK = es_error_intern ("typecheck");
446 OPT_ERR_RANGECHECK = es_error_intern ("rangecheck");
447 OPT_ERR_DICTSTACKUNDERFLOW = es_error_intern ("dictstackunderflow");
448 OPT_ERR_UNMATCHEDMARK = es_error_intern ("unmatchedmark");
449 OPT_ERR_INTERNALERROR = es_error_intern ("internalerror");
450 OPT_ERR_END_PROC = es_error_intern ("}");
451 OPT_ERR_INVALIDEXIT = es_error_intern ("invalidexit");
452 OPT_ERR_STOPPED = es_error_intern ("stopped");
453 OPT_ERR_QUIT = es_error_intern ("quit");
454 OPT_ERR_INVALIDACCESS = es_error_intern ("invalidaccess");
455 OPT_ERR_INTOVERFLOW = es_error_intern ("intoverflow");
456
457 es_symbol_intern ("true");
458 es_symbol_intern ("false");
459 es_symbol_intern ("null");
460
461 OPT_MARK_ARRAY = mark_new ("[");
462 OPT_MARK_DICT = mark_new ("<<");
463 OPT_MARK_MARK = mark_new ("mark");
464
465 opt_system_dict = dict_new (101, ATTR_READABLE);
466
467 es_autounref_pool_push ();
468
469 defOP (opt_system_dict, op__print_objdict_rec,"====", 1, "any === -");
470 defOP (opt_system_dict, op__print_objdict, "===", 1, "any === -");
471 defOP (opt_system_dict, op__print_object, "==", 1, "any == -");
472 defOP (opt_system_dict, op__print, "=", 1, "any == -");
473
474 defOP (opt_system_dict, op_mark, "<<", 0, "- << mark");
475 defOP (opt_system_dict, op_mark, "[", 0, "- [ mark");
476 defOP (opt_system_dict, op__make_array, "]", 1, "[ any1 ... anyn ] array");
477 defOP (opt_system_dict, op__make_dict , ">>", 1, "<< key1 value1 ... keyn valuen >> dict");
478
479 defop (opt_system_dict, _help, 0, "- _HELP -");
480 defop (opt_system_dict, pstack, 0, "|- any1 ... anyn PSTACK |- any1 ... anyn");
481
482 defop (opt_system_dict, _newerror, 0, "- _NEWERROR bool");
483 defop (opt_system_dict, _errorname, 0, "- _ERRORNAME error:name|null");
484
485 defop (opt_system_dict, pop, 1, "any POP -");
486 defop (opt_system_dict, exch, 2, "any1 any2 EXCH any2 any1");
487 defop (opt_system_dict, dup, 1, "any DUP any any");
488 defop (opt_system_dict, index, 1, "anyn ... any0 n INDEX anyn ... any0 anyn");
489 defop (opt_system_dict, roll, 2, "any_n-1 ... any0 n j ROLL any_(j-1)_mod_n ... any_n-1 ... any_j_mod_n");
490 defop (opt_system_dict, clear, 0, "|- any1 ... anyn CLEAR |-");
491 defop (opt_system_dict, count, 0, "|- any1 ... anyn COUNT any1 ... anyn n");
492 defop (opt_system_dict, mark, 0, "- MARK mark");
493 defop (opt_system_dict, cleartomark, 1, "mark any1 ... anyn CLEARTOMARK -");
494 defop (opt_system_dict, counttomark, 1, "mark any1 ... anyn COUNTTOMARK mark any1 ... anyn n");
495
496 defop (opt_system_dict, add, 2, "int1 int2 ADD int");
497 defop (opt_system_dict, idiv, 2, "int1 int2 IDIV int");
498 defop (opt_system_dict, mod, 2, "int1 int1 MOD int");
499 defop (opt_system_dict, mul, 2, "int1 int2 MUL int");
500 defop (opt_system_dict, sub, 2, "int1 int2 SUB int");
501 defop (opt_system_dict, abs, 1, "int1 ABS int2");
502 defop (opt_system_dict, neg, 1, "int1 NEG int2");
503
504 defop (opt_system_dict, array, 1, "int ARRAY array");
505 defop (opt_system_dict, astore, 1, "any0 ... any_n_1 array ASTORE array");
506 defop (opt_system_dict, aload, 1, "array ALOAD any0 ... any_n-1 array");
507
508 defop (opt_system_dict, eq, 2, "any1 any2 EQ bool");
509 defop (opt_system_dict, ne, 2, "any1 any2 NE bool");
510 defop (opt_system_dict, true, 0, "- TRUE true");
511 defop (opt_system_dict, false, 0, "- FALSE false");
512 defop (opt_system_dict, ge, 2, "int1 int2 GE bool%"
513 "string1 string2 GE bool");
514 defop (opt_system_dict, gt, 2, "int1 int2 GT bool%"
515 "string1 string2 GT bool");
516 defop (opt_system_dict, le, 2, "int1 int2 LE bool%"
517 "string1 string2 LE bool");
518 defop (opt_system_dict, lt, 2, "int1 int2 LT bool%"
519 "string1 string2 LT bool");
520 defop (opt_system_dict, and, 2, "bool1 bool2 AND bool3%"
521 "int1 int2 AND int3");
522 defop (opt_system_dict, or, 2, "bool1 bool2 OR bool3%"
523 "int1 int2 OR int3");
524 defop (opt_system_dict, xor, 2, "bool1 bool2 XOR bool3%"
525 "int1 int2 XOR int3");
526 defop (opt_system_dict, not, 1, "bool1|int1 NOT bool2|int2");
527 defop (opt_system_dict, bitshift, 2, "int1 shift BITSHIFT int2");
528
529 defop (opt_system_dict, dict, 1, "int DICT dict");
530 defop (opt_system_dict, begin, 1, "dict BEGIN -");
531 defop (opt_system_dict, end, 0, "- END -");
532 defop (opt_system_dict, def, 2, "key value DEF -");
533 defop (opt_system_dict, load, 1, "key LOAD value");
534 defop (opt_system_dict, undef, 2, "dict key UNDEF -");
535 defop (opt_system_dict, known, 2, "dict key KNOWN bool");
536 defop (opt_system_dict, where, 1, "key WHERE dict true%key WHERE false");
537 defop (opt_system_dict, store, 2, "key value STORE -");
538 defop (opt_system_dict, currentdict, 0, "- CURRENTDICT dict");
539 defop (opt_system_dict, countdictstack, 0, "- COUNTDICTSTACK int");
540 defop (opt_system_dict, dictstack, 1, "array DICTSTACK array");
541 defop (opt_system_dict, cleardictstack, 0, "- CLEARDICTSTACK -");
542
543 defop (opt_system_dict, string, 1, "int STRING -");
544 defop (opt_system_dict, _strstr, 2, "string seek _STRSTR string offset true%"
545 "string seek _STRSTR string false");
546 defop (opt_system_dict, _strrstr, 2, "string seek _STRRSTR string offset true%"
547 "string seek _STRRSTR string false");
548 defop (opt_system_dict, _strchr, 2, "string chr _STRCHR string offset true%"
549 "string chr _STRCHR string false");
550 defop (opt_system_dict, _strrchr, 2, "string chr _STRRCHR string offset true%"
551 "string chr _STRRCHR string false");
552 defop (opt_system_dict, _strpbrk, 2, "string accept _STRPBRK string offset true%"
553 "string accept _STRPBRK string false");
554
555 defop (opt_system_dict, exec, 1, "any EXEC -");
556 defop (opt_system_dict, if, 2, "bool proc IF -");
557 defop (opt_system_dict, ifelse, 3, "bool proc_t proc_f IFELSE -");
558 defop (opt_system_dict, repeat, 2, "int proc REPEAT -");
559 defop (opt_system_dict, loop, 1, "proc LOOP -");
560 defop (opt_system_dict, exit, 0, "- EXIT -");
561 defop (opt_system_dict, stop, 0, "- STOP -");
562 defop (opt_system_dict, stopped, 1, "any STOPPED bool");
563 defop (opt_system_dict, for, 4, "initial increment limit proc FOR -");
564 defop (opt_system_dict, quit, 0, "- quit -");
565 defop (opt_system_dict, countexecstack, 0, "- countexecstack int");
566 defop (opt_system_dict, execstack, 1, "array EXECSTACK array");
567
568 defop (opt_system_dict, type, 1, "any TYPE name");
569 defop (opt_system_dict, cvn, 1, "string CVN name");
570
571 defop (opt_system_dict, null, 0, "- NULL null");
572 defop (opt_system_dict, bind, 1, "proc BIND proc");
573
574 defop (opt_system_dict, copy, 1, "any1 ... anyn n COPY any1 ... anyn any1 ... anyn%"
575 "array1 array2 COPY array2%"
576 "dict1 dict2 COPY dict2%"
577 "string1 string2 COPY string2");
578 defop (opt_system_dict, length, 1, "array LENGTH int%"
579 "dict LENGTH int%"
580 "string LENGTH int");
581 defop (opt_system_dict, get, 2, "array index GET any%"
582 "dict key GET any%"
583 "string int GET int");
584 defop (opt_system_dict, put, 3, "array index any PUT -%"
585 "dict key any PUT -%"
586 "string index int PUT -");
587 defop (opt_system_dict, forall, 2, "array proc FORALL -%"
588 "dict proc FORALL -%"
589 "string proc FORALL -");
590 defop (opt_system_dict, putinterval, 3, "array1 index array2 PUTINTERVAL -%"
591 "string1 index string2 PUTINTERVAL -");
592 defop (opt_system_dict, _copyinterval, 4, "array1 index count array2 _COPYINTERVAL array2%"
593 "string1 index count string2 _COPYINTERVAL string2");
594
595 #define defKey(S) OPT_KEY_##S = es_symbol_intern(#S)
596 defKey(newerror);
597 defKey(errorname);
598 defKey(command);
599 defKey(ostack);
600 defKey(estack);
601 defKey(dstack);
602
603 es_autounref_pool_pop ();
604
605 return 0;
606 }
607
608 OptVM *
opt_vm_new(MIO * in,MIO * out,MIO * err)609 opt_vm_new (MIO *in, MIO *out, MIO *err)
610 {
611 OptVM *vm = xCalloc (1, OptVM);
612
613 vm->in = mio_ref (in);
614 vm->out = mio_ref (out);
615 vm->err = mio_ref (err);
616
617 EsObject *tmp;
618
619 tmp = array_new (0);
620 vm->ostack = (ptrArray *)es_pointer_take (tmp);
621 es_object_unref (tmp);
622
623 tmp = array_new (0);
624 vm->dstack = (ptrArray *)es_pointer_take (tmp);
625 es_object_unref (tmp);
626
627 tmp = array_new (0);
628 vm->estack = (ptrArray *)es_pointer_take (tmp);
629 es_object_unref (tmp);
630
631 vm->dstack_protection = 0;
632 vm_dstack_push (vm, opt_system_dict);
633 vm->dstack_protection++;
634
635 vm->error = dict_new (6, ATTR_READABLE|ATTR_WRITABLE);
636
637 vm->print_depth = 0;
638 vm->read_depth = 0;
639 vm->prompt = NULL;
640
641 return vm;
642 }
643
644 void
opt_vm_clear(OptVM * vm)645 opt_vm_clear (OptVM *vm)
646 {
647 ptrArrayClear (vm->estack);
648 ptrArrayClear (vm->ostack);
649 vm_dstack_clear (vm);
650 vm->app_data = NULL;
651 dict_op_clear (vm->error);
652 }
653
654 void
opt_vm_delete(OptVM * vm)655 opt_vm_delete (OptVM *vm)
656 {
657 ptrArrayDelete (vm->estack);
658 ptrArrayDelete (vm->dstack);
659 ptrArrayDelete (vm->ostack);
660 es_object_unref (vm->error);
661
662 mio_unref (vm->err);
663 mio_unref (vm->out);
664 mio_unref (vm->in);
665 eFree (vm);
666 }
667
668 EsObject *
opt_dict_new(unsigned int size)669 opt_dict_new (unsigned int size)
670 {
671 return dict_new (size, ATTR_READABLE|ATTR_WRITABLE);
672 }
673
674 bool
opt_dict_known_and_get_cstr(EsObject * dict,const char * name,EsObject ** val)675 opt_dict_known_and_get_cstr (EsObject *dict, const char* name, EsObject **val)
676 {
677 if (es_object_get_type (dict) != OPT_TYPE_DICT)
678 return false;
679
680 EsObject *sym = es_symbol_intern (name);
681 return dict_op_known_and_get (dict, sym, val);
682 }
683
684 bool
opt_dict_foreach(EsObject * dict,bool (* fn)(EsObject *,EsObject *,void *),void * data)685 opt_dict_foreach (EsObject *dict, bool (* fn) (EsObject *, EsObject *, void*), void *data)
686 {
687 if (es_object_get_type (dict) != OPT_TYPE_DICT)
688 return false;
689
690 hashTable *htable = es_pointer_get (dict);
691 return hashTableForeachItem (htable, (hashTableForeachFunc) fn, data);
692 }
693
694 void
opt_dict_def(EsObject * dict,EsObject * sym,EsObject * val)695 opt_dict_def (EsObject *dict, EsObject *sym, EsObject *val)
696 {
697 Assert (!es_null(sym));
698 dict_op_def (dict, sym, val);
699 }
700
701 bool
opt_dict_undef(EsObject * dict,EsObject * sym)702 opt_dict_undef (EsObject *dict, EsObject *sym)
703 {
704 Assert (!es_null(sym));
705 return dict_op_undef (dict, sym);
706 }
707
708 void
opt_dict_clear(EsObject * dict)709 opt_dict_clear (EsObject *dict)
710 {
711 Assert (es_object_get_type (dict) == OPT_TYPE_DICT);
712 dict_op_clear (dict);
713 }
714
715 EsObject *
opt_array_new(void)716 opt_array_new (void)
717 {
718 return array_new (ATTR_READABLE | ATTR_WRITABLE);
719 }
720
721 EsObject *
opt_array_get(const EsObject * array,unsigned int index)722 opt_array_get (const EsObject *array, unsigned int index)
723 {
724 return array_op_get (array, index);
725 }
726
727 void
opt_array_put(EsObject * array,unsigned int index,EsObject * obj)728 opt_array_put (EsObject *array, unsigned int index, EsObject *obj)
729 {
730 array_op_put (array, index, obj);
731 }
732
733 void
opt_array_add(EsObject * array,EsObject * elt)734 opt_array_add (EsObject *array, EsObject* elt)
735 {
736 array_op_add (array, elt);
737 }
738
739 unsigned int
opt_array_length(const EsObject * array)740 opt_array_length(const EsObject *array)
741 {
742 return array_op_length (array);
743 }
744
745 void
opt_vm_dstack_push(OptVM * vm,EsObject * dict)746 opt_vm_dstack_push (OptVM *vm, EsObject *dict)
747 {
748 vm_dstack_push (vm, dict);
749 vm->dstack_protection++;
750 }
751
752 void
opt_vm_dstack_pop(OptVM * vm)753 opt_vm_dstack_pop (OptVM *vm)
754 {
755 vm->dstack_protection--;
756 vm_dstack_pop (vm);
757 }
758
759 EsObject*
opt_vm_ostack_top(OptVM * vm)760 opt_vm_ostack_top (OptVM *vm)
761 {
762 return vm_ostack_top (vm);
763 }
764
765 EsObject*
opt_vm_ostack_peek(OptVM * vm,int index_from_top)766 opt_vm_ostack_peek (OptVM *vm, int index_from_top)
767 {
768 return vm_ostack_peek (vm, index_from_top);
769 }
770
771 EsObject*
opt_vm_ostack_pop(OptVM * vm)772 opt_vm_ostack_pop (OptVM *vm)
773 {
774 return vm_ostack_pop (vm);
775 }
776
777 void
opt_vm_ostack_push(OptVM * vm,EsObject * obj)778 opt_vm_ostack_push (OptVM *vm, EsObject *obj)
779 {
780 vm_ostack_push (vm, obj);
781 }
782
783 unsigned int
opt_vm_ostack_count(OptVM * vm)784 opt_vm_ostack_count (OptVM *vm)
785 {
786 return vm_ostack_count (vm);
787 }
788
789 static EsObject*
vm_eval(OptVM * vm,EsObject * o)790 vm_eval (OptVM *vm, EsObject * o)
791 {
792 EsObject *r = es_false;
793
794 if (es_error_p (o))
795 {
796 r = o;
797 goto out;
798 }
799 else if (es_object_get_type (o) == OPT_TYPE_NAME)
800 {
801 unsigned int attr = ((NameFat *)es_fatptr_get (o))->attr;
802 if (attr & ATTR_EXECUTABLE)
803 {
804 EsObject *sym = es_pointer_get (o);
805 EsObject *val = es_nil;
806 EsObject *dict = vm_dstack_known_and_get (vm, sym, &val);
807
808 if (es_object_get_type (dict) == OPT_TYPE_DICT)
809 {
810 int t = es_object_get_type (val);
811 if (t == OPT_TYPE_OPERATOR)
812 r = vm_call_operator (vm, val);
813 else if (t == OPT_TYPE_ARRAY
814 && (((ArrayFat *)es_fatptr_get (val))->attr & ATTR_EXECUTABLE))
815 r = vm_call_proc (vm, val);
816 else
817 {
818 vm_ostack_push (vm, val);
819 r = es_false;
820 }
821
822 if (es_error_p (r))
823 goto out;
824 }
825 else
826 {
827 r = es_error_set_object (OPT_ERR_UNDEFINED, o);
828 vm_record_error (vm, r, o); /* TODO */
829 goto out;
830 }
831 }
832 else
833 vm_ostack_push (vm, o);
834 }
835 else if (es_object_get_type (o) == OPT_TYPE_OPERATOR)
836 {
837 r = vm_call_operator (vm, o);
838 goto out;
839 }
840 else
841 vm_ostack_push (vm, o);
842 out:
843 return r;
844 }
845
846 EsObject*
opt_vm_read(OptVM * vm,MIO * in)847 opt_vm_read (OptVM *vm, MIO *in)
848 {
849 EsObject *e;
850 MIO *tmp;
851 if (in)
852 {
853 tmp = vm->in;
854 vm->in = in;
855 }
856 e = vm_read (vm);
857 if (in)
858 vm->in = tmp;
859 return e;
860 }
861
862 EsObject *
opt_vm_eval(OptVM * vm,EsObject * obj)863 opt_vm_eval (OptVM *vm, EsObject *obj)
864 {
865 return vm_eval (vm, obj);
866 }
867
868 void
opt_vm_report_error(OptVM * vm,EsObject * eobj,MIO * err)869 opt_vm_report_error (OptVM *vm, EsObject *eobj, MIO *err)
870 {
871 MIO *tmp;
872
873 if (err)
874 {
875 tmp = vm->err;
876 vm->err = err;
877 }
878 vm_report_error (vm, eobj);
879 if (err)
880 vm->err = tmp;
881 }
882
883 char*
opt_vm_set_prompt(OptVM * vm,char * prompt)884 opt_vm_set_prompt (OptVM *vm, char *prompt)
885 {
886 char *tmp = vm->prompt;
887 vm->prompt = prompt;
888 return tmp;
889 }
890
891 void
opt_vm_print_prompt(OptVM * vm)892 opt_vm_print_prompt (OptVM *vm)
893 {
894 if (vm->prompt && vm->read_depth == 0)
895 {
896 mio_puts (vm->err, vm->prompt);
897 unsigned int c = ptrArrayCount (vm->ostack);
898
899 if (c > 0)
900 mio_printf (vm->err, "<%u> ", c);
901 else
902 mio_printf (vm->err, "> ");
903 }
904 }
905
906 void*
opt_vm_get_app_data(OptVM * vm)907 opt_vm_get_app_data (OptVM *vm)
908 {
909 return vm->app_data;
910 }
911
912 void*
opt_vm_set_app_data(OptVM * vm,void * app_data)913 opt_vm_set_app_data (OptVM *vm, void *app_data)
914 {
915 void *tmp = vm->app_data;
916 vm->app_data = app_data;
917 return tmp;
918 }
919
920 int
opt_vm_help(OptVM * vm,MIO * out,struct OptHelpExtender * extop,void * data)921 opt_vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data)
922 {
923 vm_help (vm, out? out: vm->out, extop, data);
924 return 0;
925 }
926
927 EsObject *
opt_operator_new(OptOperatorFn op,const char * name,int arity,const char * help_str)928 opt_operator_new (OptOperatorFn op, const char *name, int arity, const char *help_str)
929 {
930 return operator_new (op, name, arity, help_str);
931 }
932
opt_string_new_from_cstr(const char * cstr)933 EsObject *opt_string_new_from_cstr (const char *cstr)
934 {
935 vString *vstr = vStringNewInit (cstr? cstr: "");
936 return string_new (vstr);
937 }
938
opt_string_get_cstr(const EsObject * str)939 const char* opt_string_get_cstr (const EsObject *str)
940 {
941 vString *vstr = es_pointer_get (str);
942 return vStringValue (vstr);
943 }
944
opt_name_new_from_cstr(const char * cstr)945 EsObject *opt_name_new_from_cstr (const char *cstr)
946 {
947 return name_newS (cstr, ATTR_READABLE);
948 }
949
opt_name_get_cstr(const EsObject * name)950 const char* opt_name_get_cstr (const EsObject *name)
951 {
952 if (es_object_get_type (name) == OPT_TYPE_NAME)
953 name = es_pointer_get (name);
954 if (!es_symbol_p (name))
955 return NULL;
956 return es_symbol_get (name);
957 }
958
959
960 /*
961 * VM
962 */
963 static void
vm_read_skip_comment(OptVM * vm)964 vm_read_skip_comment(OptVM *vm)
965 {
966 while (true)
967 {
968 int c = mio_getc (vm->in);
969 if (c == EOF || c == '\n' || c == '\r')
970 {
971 if (c != EOF)
972 opt_vm_print_prompt (vm);
973 return;
974 }
975 }
976 }
977
978 #define is_meta_char(c) ((c) == '%' \
979 || (c) == '/' \
980 || (c) == '(' \
981 || (c) == '{' \
982 || (c) == '}' \
983 || (c) == '[' \
984 || (c) == ']' \
985 || (c) == '<' \
986 || (c) == '>')
987
988 static EsObject*
vm_read_char(OptVM * vm)989 vm_read_char (OptVM *vm)
990 {
991 int c = mio_getc (vm->in);
992 int i;
993
994 if (c == EOF)
995 return OPT_ERR_SYNTAX;
996 else if (c == '\\')
997 {
998 c = mio_getc (vm->in);
999 int i;
1000 switch (c)
1001 {
1002 case 't':
1003 i = '\t';
1004 break;
1005 case 'n':
1006 i = '\n';
1007 break;
1008 case 'f':
1009 i = '\f';
1010 break;
1011 case 'r':
1012 i = '\r';
1013 break;
1014 case 'v':
1015 i = '\v';
1016 break;
1017 case ' ':
1018 case '_':
1019 i = ' ';
1020 break;
1021 case '\\':
1022 i = '\\';
1023 break;
1024 default:
1025 return OPT_ERR_SYNTAX;
1026 }
1027 c = mio_getc (vm->in);
1028 if (!(c == EOF || isspace (c) || is_meta_char (c)))
1029 return OPT_ERR_SYNTAX;
1030 mio_ungetc (vm->in, c);
1031 return es_integer_new (i);
1032 }
1033 else if (isgraph(c))
1034 {
1035 i = c;
1036
1037 c = mio_getc (vm->in);
1038 if (!(c == EOF || isspace (c) || is_meta_char (c)))
1039 return OPT_ERR_SYNTAX;
1040 mio_ungetc (vm->in, c);
1041
1042 return es_integer_new (i);
1043 }
1044 else
1045 return OPT_ERR_SYNTAX;
1046 }
1047
1048 static EsObject*
vm_read_string(OptVM * vm)1049 vm_read_string (OptVM *vm)
1050 {
1051 int depth = 0;
1052 vString *s = vStringNew ();
1053 while (true)
1054 {
1055 int c = mio_getc (vm->in);
1056 if (c == ')')
1057 {
1058 if (depth == 0)
1059 return string_new (s);
1060 vStringPut (s, c);
1061 depth--;
1062 }
1063 else if (c == '(')
1064 {
1065 vStringPut (s, c);
1066 depth++;
1067 }
1068 else if (c == '\\')
1069 {
1070 c = mio_getc (vm->in);
1071 switch (c)
1072 {
1073 case EOF:
1074 vStringDelete (s);
1075 return OPT_ERR_SYNTAX;
1076 case 'n':
1077 vStringPut (s, '\n');
1078 break;
1079 case 't':
1080 vStringPut (s, '\t');
1081 break;
1082 case 'r':
1083 vStringPut (s, '\r');
1084 break;
1085 case 'f':
1086 vStringPut (s, '\f');
1087 break;
1088 case 'v':
1089 vStringPut (s, '\v');
1090 break;
1091 case '\\':
1092 case '(':
1093 case ')':
1094 vStringPut (s, c);
1095 break;
1096 default:
1097 vStringPut (s, c);
1098 break;
1099 ;
1100 }
1101 }
1102 else if (c == EOF)
1103 {
1104 vStringDelete (s);
1105 return OPT_ERR_SYNTAX;
1106 }
1107 else
1108 vStringPut (s, c);
1109 }
1110 }
1111
1112 static EsObject*
vm_read_generic(OptVM * vm,int c,EsObject * (* make_object)(const char *,void *),void * data)1113 vm_read_generic(OptVM *vm, int c,
1114 EsObject * (* make_object) (const char *, void *),
1115 void *data)
1116 {
1117 vString *name = vStringNew ();
1118 vStringPut (name, c);
1119
1120 while (1)
1121 {
1122 c = mio_getc (vm->in);
1123 if (c == EOF)
1124 break;
1125 else if (isspace (c) || is_meta_char (c))
1126 {
1127 mio_ungetc (vm->in, c);
1128 break;
1129 }
1130 else
1131 vStringPut (name, c);
1132 }
1133 EsObject *n = make_object (vStringValue (name), data);
1134 vStringDelete (name);
1135 return n;
1136 }
1137
1138 static EsObject*
vm_read_name(OptVM * vm,int c,unsigned int attr)1139 vm_read_name (OptVM *vm, int c, unsigned int attr)
1140 {
1141 return vm_read_generic (vm, c, name_newS_cb, &attr);
1142 }
1143
1144 struct name_or_number_data {
1145 unsigned int attr;
1146 bool negative;
1147 };
1148
1149 static EsObject*
name_or_number_new(const char * s,void * data)1150 name_or_number_new (const char* s, void *data)
1151 {
1152 struct name_or_number_data *d = data;
1153
1154 bool number = true;
1155 const char *t = s;
1156 while (*t)
1157 {
1158 if (!isdigit ((int)*t))
1159 {
1160 number = false;
1161 break;
1162 }
1163 t++;
1164 }
1165 if (number)
1166 {
1167 int n;
1168 if (strToInt (s, 10, &n))
1169 return es_integer_new (n * ((d->negative)? -1: 1));
1170 else
1171 return OPT_ERR_INTOVERFLOW;
1172 }
1173 else
1174 return name_newS_cb (s, &d->attr);
1175 }
1176
1177 static EsObject*
vm_read_name_or_number(OptVM * vm,int c,unsigned int attr,bool negative)1178 vm_read_name_or_number (OptVM *vm, int c, unsigned int attr, bool negative)
1179 {
1180 struct name_or_number_data data = {
1181 .attr = attr,
1182 .negative = negative,
1183 };
1184
1185 return vm_read_generic (vm, c, name_or_number_new, &data);
1186 }
1187
1188 static EsObject*
vm_read_quoted(OptVM * vm)1189 vm_read_quoted (OptVM *vm)
1190 {
1191 bool immediate = false;
1192
1193 int c = mio_getc (vm->in);
1194 switch (c)
1195 {
1196 case '/':
1197 immediate = true;
1198 c = mio_getc (vm->in);
1199 break;
1200 default:
1201 break;
1202 }
1203
1204 EsObject *s = vm_read_name (vm, c, ATTR_READABLE);
1205 if (immediate)
1206 {
1207 EsObject *q;
1208
1209 EsObject *val = es_nil;
1210 EsObject *dict = vm_dstack_known_and_get (vm, s, &val);
1211 if (es_object_get_type (dict) == OPT_TYPE_DICT)
1212 q = es_object_ref (val);
1213 else
1214 {
1215 q = es_error_set_object (OPT_ERR_UNDEFINED, s);
1216 vm_record_error (vm, q, s); /* TODO */
1217 }
1218 es_object_unref (s);
1219 return q;
1220 }
1221 else
1222 return s;
1223 }
1224
1225 static EsObject*
vm_read_proc(OptVM * vm)1226 vm_read_proc (OptVM *vm)
1227 {
1228 EsObject *proc = array_new (ATTR_EXECUTABLE|ATTR_READABLE);
1229
1230 vm->read_depth++;
1231 while (true)
1232 {
1233 EsObject *o = vm_read (vm);
1234 if (es_object_equal (o, OPT_ERR_END_PROC))
1235 {
1236 break;
1237 }
1238 else if (es_error_p (o))
1239 {
1240 es_object_unref (proc);
1241 proc = o;
1242 break;
1243 }
1244 else
1245 {
1246 array_op_add (proc, o);
1247 es_object_unref (o);
1248 }
1249 }
1250 vm->read_depth--;
1251 return proc;
1252 }
1253
1254 static EsObject*
vm_read(OptVM * vm)1255 vm_read (OptVM *vm)
1256 {
1257 while (true)
1258 {
1259 int c = mio_getc (vm->in);
1260 if (c == EOF)
1261 return es_object_ref (ES_READER_EOF);
1262 else if (c == '\n' || c == '\r')
1263 {
1264 opt_vm_print_prompt (vm);
1265 continue;
1266 }
1267 else if (isspace (c))
1268 continue;
1269 else if (c == '%')
1270 {
1271 vm_read_skip_comment (vm);
1272 continue;
1273 }
1274 else if (isdigit (c))
1275 {
1276 return vm_read_name_or_number (vm, c, ATTR_EXECUTABLE|ATTR_READABLE,
1277 false);
1278 }
1279 else if (c == '-' || c == '+')
1280 {
1281 bool negative = (c == '-');
1282 c = mio_getc (vm->in);
1283 if (isdigit (c))
1284 return vm_read_name_or_number (vm, c, ATTR_EXECUTABLE|ATTR_READABLE,
1285 negative);
1286 else
1287 {
1288 mio_ungetc (vm->in, c);
1289 return vm_read_name_or_number (vm, '-', ATTR_EXECUTABLE|ATTR_READABLE,
1290 false);
1291 }
1292 }
1293 else if (c == '/')
1294 return vm_read_quoted (vm);
1295 else if (c == '(')
1296 return vm_read_string (vm);
1297 else if (c == '{')
1298 return vm_read_proc (vm);
1299 else if (c == '}')
1300 {
1301 if (vm->read_depth)
1302 return OPT_ERR_END_PROC;
1303 else
1304 return OPT_ERR_SYNTAX;
1305 }
1306 else if (c == '[' || c == ']')
1307 {
1308 const char name[2] = { [0] = c, [1] = '\0' };
1309 EsObject *s = es_symbol_intern (name);
1310 EsObject *n = name_new (s, ATTR_EXECUTABLE|ATTR_READABLE);
1311 return n;
1312 }
1313 else if (c == '<' || c == '>')
1314 {
1315 int c0 = mio_getc (vm->in);
1316 if (c != c0)
1317 return OPT_ERR_SYNTAX;
1318
1319 const char name [3] = { [0] = c, [1] = c, [2] = '\0' };
1320 EsObject *s = es_symbol_intern (name);
1321 EsObject *n = name_new (s, ATTR_EXECUTABLE|ATTR_READABLE);
1322 return n;
1323 }
1324 else if (c == '?')
1325 return vm_read_char (vm);
1326 else
1327 return vm_read_name (vm, c, ATTR_EXECUTABLE|ATTR_READABLE);
1328 }
1329 }
1330
1331 static void
vm_ostack_push(OptVM * vm,EsObject * o)1332 vm_ostack_push (OptVM *vm, EsObject *o)
1333 {
1334 ptrArrayAdd (vm->ostack, es_object_ref (o));
1335 }
1336
1337 static EsObject*
vm_ostack_pop(OptVM * vm)1338 vm_ostack_pop (OptVM *vm)
1339 {
1340 unsigned int c = vm_ostack_count (vm);
1341
1342 if (c > 0)
1343 {
1344 ptrArrayDeleteLast (vm->ostack);
1345 return es_false;
1346 }
1347
1348 return OPT_ERR_UNDERFLOW;
1349 }
1350
1351 static unsigned int
vm_ostack_count(OptVM * vm)1352 vm_ostack_count (OptVM *vm)
1353 {
1354 return ptrArrayCount (vm->ostack);
1355 }
1356
1357 static int
vm_ostack_counttomark(OptVM * vm)1358 vm_ostack_counttomark (OptVM *vm)
1359 {
1360 unsigned int c = ptrArrayCount (vm->ostack);
1361 unsigned int i;
1362
1363 if (c == 0)
1364 return -1;
1365
1366 for (i = c; i > 0; i--)
1367 {
1368 EsObject *elt = ptrArrayItem (vm->ostack, i - 1);
1369 if (es_object_get_type (elt) == OPT_TYPE_MARK)
1370 break;
1371 }
1372
1373 if (i == 0)
1374 return -1;
1375
1376 int r = (c - i);
1377 if (r < 0) /* FIXME */
1378 r = -1;
1379 return r;
1380 }
1381
1382 static EsObject*
vm_ostack_top(OptVM * vm)1383 vm_ostack_top (OptVM *vm)
1384 {
1385 if (ptrArrayCount (vm->ostack) > 0)
1386 return ptrArrayLast (vm->ostack);
1387 return OPT_ERR_UNDERFLOW;
1388 }
1389
1390 static EsObject*
vm_ostack_peek(OptVM * vm,int index_from_top)1391 vm_ostack_peek (OptVM *vm, int index_from_top)
1392 {
1393 unsigned int c = ptrArrayCount (vm->ostack);
1394 if (c > (unsigned int)index_from_top)
1395 {
1396 unsigned int i = (c - ((unsigned int)index_from_top)) - 1;
1397 Assert (i < c);
1398 return ptrArrayItem (vm->ostack, i);
1399 }
1400 return OPT_ERR_UNDERFLOW;
1401 }
1402
1403 static EsObject*
vm_dstack_known_and_get(OptVM * vm,EsObject * key,EsObject ** val)1404 vm_dstack_known_and_get (OptVM *vm, EsObject *key, EsObject **val)
1405 {
1406 if (es_object_get_type (key) == OPT_TYPE_NAME)
1407 key = es_pointer_get (key);
1408
1409 int c = ptrArrayCount (vm->dstack);
1410
1411 for (int i = c - 1; i >= 0; i--)
1412 {
1413 EsObject *d = ptrArrayItem (vm->dstack, i);
1414 if (dict_op_known_and_get (d, key, val))
1415 return d;
1416 }
1417 return es_false;
1418 }
1419
1420 static void
vm_dict_def(OptVM * vm,EsObject * key,EsObject * val)1421 vm_dict_def (OptVM *vm, EsObject *key, EsObject *val)
1422 {
1423 Assert (!es_null(key));
1424 dict_op_def (ptrArrayLast(vm->dstack), key, val);
1425 }
1426
1427 static void
vm_dstack_push(OptVM * vm,EsObject * o)1428 vm_dstack_push (OptVM *vm, EsObject *o)
1429 {
1430 ptrArrayAdd (vm->dstack, es_object_ref (o));
1431 }
1432
1433 static int
vm_dstack_count(OptVM * vm)1434 vm_dstack_count (OptVM *vm)
1435 {
1436 return ptrArrayCount (vm->dstack);
1437 }
1438
1439 static EsObject*
vm_dstack_pop(OptVM * vm)1440 vm_dstack_pop (OptVM *vm)
1441 {
1442 if (vm_dstack_count (vm) <= vm->dstack_protection)
1443 return OPT_ERR_DICTSTACKUNDERFLOW;
1444 ptrArrayDeleteLast (vm->dstack);
1445 return es_false;
1446 }
1447
1448 static void
vm_dstack_clear(OptVM * vm)1449 vm_dstack_clear (OptVM *vm)
1450 {
1451 while (ptrArrayCount (vm->dstack) > 1)
1452 ptrArrayDeleteLast (vm->dstack);
1453
1454 vm->dstack_protection = 1;
1455 }
1456
1457 static EsObject*
vm_call_operator(OptVM * vm,EsObject * op)1458 vm_call_operator (OptVM *vm, EsObject *op)
1459 {
1460 EsObject *r;
1461
1462 Operator operator = es_pointer_get (op);
1463 OperatorFat *ofat = es_fatptr_get (op);
1464
1465 vm_estack_push (vm, op);
1466
1467 if (ofat->arity > 0)
1468 {
1469 unsigned int c = ptrArrayCount (vm->ostack);
1470 if (c < (unsigned int)ofat->arity)
1471 {
1472 vm_estack_pop (vm);
1473 vm_record_error (vm, OPT_ERR_UNDERFLOW, op);
1474 return OPT_ERR_UNDERFLOW;
1475 }
1476 }
1477
1478 r = (* operator) (vm, ofat->name);
1479 if (es_error_p (r))
1480 {
1481 vm_estack_pop (vm);
1482 if (es_object_equal (OPT_ERR_STOPPED, r))
1483 vm_record_stop (vm, op);
1484 else
1485 vm_record_error (vm, r, op);
1486 return r;
1487 }
1488
1489 vm_estack_pop (vm);
1490 return es_false;
1491 }
1492
1493 static EsObject*
vm_call_proc(OptVM * vm,EsObject * proc)1494 vm_call_proc (OptVM *vm, EsObject *proc)
1495 {
1496 ptrArray *a = es_pointer_get (proc);
1497 unsigned int c = ptrArrayCount (a);
1498
1499 vm_estack_push (vm, proc);
1500 for (unsigned int i = 0; i < c; i++)
1501 {
1502 EsObject *o = ptrArrayItem (a, i);
1503 EsObject* e = vm_eval (vm, o);
1504 if (es_error_p (e))
1505 {
1506 vm_estack_pop (vm); /* ??? */
1507 return e;
1508 }
1509 }
1510 vm_estack_pop (vm);
1511
1512 return es_false;
1513 }
1514
1515 static EsObject*
vm_estack_push(OptVM * vm,EsObject * p)1516 vm_estack_push (OptVM *vm, EsObject *p)
1517 {
1518 ptrArrayAdd (vm->estack, es_object_ref (p));
1519 return es_false;
1520 }
1521
1522 static EsObject*
vm_estack_pop(OptVM * vm)1523 vm_estack_pop (OptVM *vm)
1524 {
1525 if (ptrArrayCount (vm->estack) < 1)
1526 return OPT_ERR_INTERNALERROR;
1527 ptrArrayDeleteLast (vm->estack);
1528 return es_false;
1529 }
1530
1531 static void
insert_spaces(MIO * mio,int n)1532 insert_spaces (MIO *mio, int n)
1533 {
1534 while (n-- > 0)
1535 mio_putc(mio, ' ');
1536 }
1537
1538 struct htable_print_data {
1539 OptVM *vm;
1540 int dict_recursion;
1541 };
1542
1543 static bool
htable_print_entry(const void * key,void * val,void * user_data)1544 htable_print_entry (const void *key, void *val, void *user_data)
1545 {
1546 struct htable_print_data *data = user_data;
1547
1548 vm_print_full (data->vm, (EsObject *)key, false, data->dict_recursion);
1549 mio_putc (data->vm->out, ' ');
1550 vm_print_full (data->vm, (EsObject *)val, false, data->dict_recursion);
1551
1552 return true;
1553 }
1554
1555 static bool
htable_print_entries(const void * key,void * val,void * user_data)1556 htable_print_entries (const void *key, void *val, void *user_data)
1557 {
1558 struct htable_print_data *data = user_data;
1559
1560 insert_spaces (data->vm->out, data->vm->print_depth * 2);
1561 htable_print_entry (key, val, user_data);
1562 mio_putc (data->vm->out, '\n');
1563
1564 return true;
1565 }
1566
1567 static void
vm_print(OptVM * vm,EsObject * elt)1568 vm_print (OptVM *vm, EsObject *elt)
1569 {
1570 vm_print_full (vm, elt, false, 0);
1571 }
1572
1573 static void
vm_print_full(OptVM * vm,EsObject * elt,bool string_as_is,int dict_recursion)1574 vm_print_full(OptVM *vm, EsObject *elt, bool string_as_is, int dict_recursion)
1575 {
1576 if (es_object_equal (elt, es_true))
1577 mio_puts (vm->out, "true");
1578 else if (es_object_equal (elt, es_false))
1579 mio_puts (vm->out, "false");
1580 else if (es_object_equal (elt, es_nil))
1581 mio_puts (vm->out, "null");
1582 else if (es_error_p (elt))
1583 {
1584 mio_putc (vm->out, '/');
1585 mio_puts (vm->out, es_error_name (elt));
1586 }
1587 else if (es_object_get_type (elt) == OPT_TYPE_DICT)
1588 {
1589 hashTable *d = es_pointer_get (elt);
1590
1591 struct htable_print_data data = {
1592 .vm = vm,
1593 .dict_recursion = dict_recursion - 1,
1594 };
1595
1596 if (dict_recursion)
1597 {
1598 switch (hashTableCountItem (d))
1599 {
1600 case 0:
1601 mio_puts(vm->out, "<<>> ");
1602 break;
1603 case 1:
1604 mio_puts(vm->out, "<<");
1605 hashTableForeachItem (d, htable_print_entry, &data);
1606 mio_puts(vm->out, ">> ");
1607 break;
1608 default:
1609 mio_puts(vm->out, "<<\n");
1610 vm->print_depth++;
1611 hashTableForeachItem (d, htable_print_entries, &data);
1612 vm->print_depth--;
1613 insert_spaces (vm->out, vm->print_depth*2);
1614 mio_puts(vm->out, ">> ");
1615 break;
1616 }
1617 }
1618 else
1619 {
1620 mio_printf (vm->out, "-dict:%u-",
1621 hashTableCountItem (d));
1622 }
1623 }
1624 else if (es_object_get_type (elt) == OPT_TYPE_ARRAY)
1625 {
1626 ArrayFat *afat = (ArrayFat *)es_fatptr_get (elt);
1627 ptrArray *a = (ptrArray *)es_pointer_get (elt);
1628 unsigned int c = ptrArrayCount (a);
1629 int is_proc = (afat->attr & ATTR_EXECUTABLE)? 1: 0;
1630
1631 mio_putc (vm->out, is_proc? '{': '[');
1632 vm->print_depth += is_proc;
1633 for (unsigned int i = 0; i < c; i++)
1634 {
1635 vm_print_full (vm, (EsObject *)ptrArrayItem (a, i), false, dict_recursion);
1636 if (i != c - 1)
1637 mio_putc (vm->out, ' ');
1638 }
1639 vm->print_depth -= is_proc;
1640 mio_putc (vm->out, is_proc? '}': ']');
1641 }
1642 else if (es_object_get_type (elt) == OPT_TYPE_STRING && string_as_is)
1643 {
1644 const char *cstr = opt_string_get_cstr (elt);
1645 mio_puts (vm->out, cstr);
1646 }
1647 else if ((es_object_get_type (elt) == OPT_TYPE_NAME || es_symbol_p (elt))
1648 && string_as_is)
1649 {
1650 const char *cstr = opt_name_get_cstr (elt);
1651 mio_puts (vm->out, cstr);
1652 }
1653 else if (es_symbol_p (elt) && (! string_as_is))
1654 {
1655 mio_putc (vm->out, '/');
1656 es_print (elt, vm->out);
1657 }
1658 else
1659 es_print (elt, vm->out);
1660 }
1661
1662 static bool
collect_operators(const void * key,void * value,void * user_data)1663 collect_operators (const void *key, void *value, void *user_data)
1664 {
1665 ptrArray *a = user_data;
1666 EsObject *op = value;
1667
1668 if (es_object_get_type (op) == OPT_TYPE_OPERATOR)
1669 {
1670 OperatorFat *ofat = es_fatptr_get (op);
1671 if (ofat->help_str)
1672 ptrArrayAdd (a, op);
1673 }
1674 return true;
1675 }
1676
1677 static const char*
callable_get_name(const EsObject * callable)1678 callable_get_name (const EsObject *callable)
1679 {
1680 if (es_object_get_type (callable) == OPT_TYPE_OPERATOR)
1681 {
1682 const OperatorFat *ofat_callable = es_fatptr_get (callable);
1683 return es_symbol_get (ofat_callable->name);
1684 }
1685 else
1686 return opt_name_get_cstr(callable);
1687 }
1688
1689 static int
compare_callable_by_name(const void * a,const void * b)1690 compare_callable_by_name (const void *a, const void *b)
1691 {
1692 const char *str_a = callable_get_name (a);
1693 const char *str_b = callable_get_name (b);
1694
1695 return strcmp (str_a, str_b);
1696 }
1697
1698 static void
vm_help(OptVM * vm,MIO * out,struct OptHelpExtender * extop,void * data)1699 vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data)
1700 {
1701 unsigned int c = ptrArrayCount (vm->dstack);
1702
1703 ptrArray *a = ptrArrayNew (NULL);
1704 for (unsigned int i = 0; i < c; i++)
1705 {
1706 hashTable *t = es_pointer_get (ptrArrayItem (vm->dstack, i));
1707 hashTableForeachItem (t, collect_operators, a);
1708 }
1709 if (extop)
1710 extop->add (a, data);
1711
1712 ptrArraySort (a, compare_callable_by_name);
1713
1714 unsigned int ca = ptrArrayCount (a);
1715 size_t maxlen = 0;
1716 for (unsigned int i = 0; i < ca; i++)
1717 {
1718 EsObject* obj = ptrArrayItem (a, i);
1719 const char *name = callable_get_name (obj);
1720
1721 size_t l = strlen (name);
1722 if (l > maxlen)
1723 maxlen = l;
1724 }
1725
1726 for (unsigned int i = 0; i < ca; i++)
1727 {
1728 EsObject* obj = ptrArrayItem (a, i);
1729 const char *name = NULL;
1730 const char *help_str_head = NULL;
1731 const char *help_str_original = NULL;
1732
1733 if (es_object_get_type (obj) == OPT_TYPE_OPERATOR)
1734 {
1735 OperatorFat *ofat = es_fatptr_get (obj);
1736 name = es_symbol_get (ofat->name);
1737 help_str_head = ofat->help_str;
1738 }
1739 else if (extop)
1740 {
1741 name = opt_name_get_cstr (obj);
1742 help_str_head = extop->get_help_str (obj, data);
1743 }
1744 help_str_original = help_str_head;
1745
1746 if (name == NULL || help_str_head == NULL)
1747 continue;
1748
1749 while (help_str_head)
1750 {
1751 const char *next = strpbrk (help_str_head, "%\n");
1752 const char *label = (help_str_head == help_str_original)? name: NULL;
1753 if (next)
1754 {
1755 char *tmp = eStrndup (help_str_head, next - help_str_head);
1756 bool desc = (tmp[0] == ':');
1757 mio_printf (out, "%*s%s%s\n",
1758 (int)maxlen, label? label: "",
1759 ((desc || (label == NULL))? " ": " -> "),
1760 (desc? tmp + 1: tmp));
1761 eFree ((char *)tmp);
1762 help_str_head = next + 1;
1763 while (*help_str_head && isspace ((unsigned char)*help_str_head))
1764 help_str_head++;
1765 }
1766 else
1767 {
1768 if (*help_str_head != '\0')
1769 {
1770 bool desc = (help_str_head[0] == ':');
1771 mio_printf (out, "%*s%s%s\n",
1772 (int)maxlen, label? label: "",
1773 ((desc || (label == NULL))? " ": " -> "),
1774 (desc? help_str_head + 1: help_str_head));
1775 }
1776 help_str_head = NULL;
1777 }
1778 }
1779 }
1780
1781 ptrArrayDelete (a);
1782 }
1783
1784 static EsObject *
array_new_from_stack(ptrArray * src)1785 array_new_from_stack (ptrArray *src)
1786 {
1787 EsObject *dst = array_new (0);
1788 ptrArray *a = (ptrArray *)es_pointer_get (dst);
1789 for (unsigned int i = 0; i < ptrArrayCount(src); i++)
1790 ptrArrayAdd (a, es_object_ref (ptrArrayItem (src, i)));
1791 return dst;
1792 }
1793
1794 static void
vm_record_stop(OptVM * vm,EsObject * cmd)1795 vm_record_stop (OptVM *vm, EsObject *cmd)
1796 {
1797 dict_op_def (vm->error, OPT_KEY_command, cmd);
1798 dict_op_def (vm->error, OPT_KEY_errorname, es_nil);
1799 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
1800 /* OPT_KEY_{o,e,o}stack are kept as is. */
1801 }
1802
1803 static void
vm_record_error(OptVM * vm,EsObject * e,EsObject * cmd)1804 vm_record_error (OptVM *vm, EsObject *e, EsObject *cmd)
1805 {
1806 EsObject *newerror = es_nil;
1807 if (dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror)
1808 && es_object_equal (newerror, es_true))
1809 return;
1810
1811 dict_op_def (vm->error, OPT_KEY_newerror, es_true);
1812 dict_op_def (vm->error, OPT_KEY_errorname, e);
1813 dict_op_def (vm->error, OPT_KEY_command, cmd);
1814
1815 EsObject *a;
1816
1817 a = array_new_from_stack (vm->ostack);
1818 dict_op_def (vm->error, OPT_KEY_ostack, a);
1819 es_object_unref (a);
1820
1821 a = array_new_from_stack (vm->estack);
1822 dict_op_def (vm->error, OPT_KEY_estack, a);
1823 es_object_unref (a);
1824
1825 a = array_new_from_stack (vm->dstack);
1826 dict_op_def (vm->error, OPT_KEY_dstack, a);
1827 es_object_unref (a);
1828 }
1829
1830 static void
vm_report_error(OptVM * vm,EsObject * e)1831 vm_report_error (OptVM *vm, EsObject *e)
1832 {
1833 MIO *out = vm->out;
1834 vm->out = vm->err;
1835 mio_puts (vm->err, "Error: ");
1836
1837 EsObject *newerror = es_nil;
1838 if (!dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror))
1839 {
1840 vm_print (vm, e);
1841 mio_putc (vm->err, '\n');
1842 goto out;
1843 }
1844
1845 if (es_object_equal (newerror, es_false))
1846 {
1847 vm_print (vm, e);
1848 mio_putc (vm->err, '\n');
1849 goto out;
1850 }
1851
1852 if (!dict_op_known_and_get (vm->error, OPT_KEY_errorname, &e))
1853 {
1854 vm_print (vm, OPT_ERR_INTERNALERROR);
1855 mio_putc (vm->err, '\n');
1856 goto out;
1857 }
1858
1859 vm_print (vm, e);
1860
1861 EsObject *command = es_nil;
1862 dict_op_known_and_get (vm->error, OPT_KEY_command, &command);
1863 EsObject *attached_object = es_error_get_object (e);
1864
1865 if (!es_null (attached_object))
1866 {
1867 mio_puts (vm->err, " in ");
1868 vm_print (vm, attached_object);
1869 }
1870 else if (!es_null (command))
1871 {
1872 mio_puts (vm->err, " in ");
1873 vm_print (vm, command);
1874 command = es_nil;
1875 }
1876 mio_putc (vm->err, '\n');
1877
1878 EsObject *ostack = es_nil;
1879 if (dict_op_known_and_get (vm->error, OPT_KEY_ostack, &ostack))
1880 {
1881 mio_puts (vm->err, "Operand stack:\n");
1882 mio_puts (vm->err, "top|");
1883 ptrArray *a = es_pointer_get (ostack);
1884 for (unsigned int i = ptrArrayCount (a); i > 0; i--)
1885 {
1886 EsObject *o = ptrArrayItem (a, i - 1);
1887 mio_puts (vm->err, " ");
1888 vm_print (vm, o);
1889 }
1890 }
1891 mio_puts (vm->err, " |bottom\n");
1892
1893 EsObject *estack = es_nil;
1894 if (dict_op_known_and_get (vm->error, OPT_KEY_estack, &estack))
1895 {
1896 mio_puts (vm->err, "Execution stack:\n");
1897 mio_puts (vm->err, "top|");
1898
1899 if (!es_null (command))
1900 {
1901 mio_puts (vm->err, " ");
1902 vm_print (vm, command);
1903 }
1904
1905 ptrArray *a = es_pointer_get (estack);
1906 for (unsigned int i = ptrArrayCount (a); i > 0; i--)
1907 {
1908 EsObject *o = ptrArrayItem (a, i - 1);
1909 mio_puts (vm->err, " ");
1910 vm_print (vm, o);
1911 }
1912 }
1913 mio_puts (vm->err, " |bottom\n");
1914
1915 EsObject *dstack = es_nil;
1916 if (dict_op_known_and_get (vm->error, OPT_KEY_dstack, &dstack))
1917 {
1918 mio_puts (vm->err, "Dictionary stack:\n");
1919 mio_puts (vm->err, "top|");
1920 ptrArray *a = es_pointer_get (dstack);
1921 for (unsigned int i = ptrArrayCount (a); i > 0; i--)
1922 {
1923 EsObject *o = ptrArrayItem (a, i - 1);
1924 mio_puts (vm->err, " ");
1925 vm_print (vm, o);
1926 }
1927 }
1928 mio_puts (vm->err, " |bottom\n");
1929
1930 out:
1931 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
1932 vm->out = out;
1933 }
1934
1935 static void
vm_bind_proc(OptVM * vm,ptrArray * proc)1936 vm_bind_proc (OptVM *vm, ptrArray *proc)
1937 {
1938 unsigned int c = ptrArrayCount (proc);
1939 for (unsigned int i = 0; i < c; i++)
1940 {
1941 EsObject *x = ptrArrayItem (proc, i);
1942
1943 if (es_object_get_type (x) == OPT_TYPE_ARRAY)
1944 vm_bind_proc (vm, es_pointer_get (x));
1945 else if (es_object_get_type (x) == OPT_TYPE_NAME)
1946 {
1947 if (!(((NameFat *)es_fatptr_get (x))->attr
1948 & ATTR_EXECUTABLE))
1949 continue;
1950
1951 EsObject* val = NULL;
1952 EsObject *r = vm_dstack_known_and_get (vm, x, &val);
1953 if (es_object_get_type (r) == OPT_TYPE_DICT)
1954 {
1955 if (es_object_get_type (val) == OPT_TYPE_OPERATOR)
1956 ptrArrayUpdate (proc, i, es_object_ref (val), es_nil);
1957 }
1958 }
1959 }
1960 }
1961
1962
1963 /*
1964 * Array
1965 */
1966 static EsObject*
array_new(unsigned int attr)1967 array_new (unsigned int attr)
1968 {
1969 ptrArray *a = ptrArrayNew ((ptrArrayDeleteFunc)es_object_unref);
1970 return es_fatptr_new (OPT_TYPE_ARRAY, a, &attr);
1971 }
1972
1973 static EsObject*
array_es_init_fat(void * fat,void * ptr,void * extra)1974 array_es_init_fat (void *fat, void *ptr, void *extra)
1975 {
1976 ArrayFat *a = fat;
1977 a->attr = *((unsigned int *)extra);
1978 return es_false;
1979 }
1980
1981 static void
array_es_free(void * ptr,void * fat)1982 array_es_free (void *ptr, void *fat)
1983 {
1984 if (ptr)
1985 ptrArrayDelete ((ptrArray *)ptr);
1986 }
1987
1988 static int
array_es_equal(const void * a,const void * afat,const void * b,const void * bfat)1989 array_es_equal (const void *a, const void *afat, const void *b, const void *bfat)
1990 {
1991 if (((ArrayFat *)afat)->attr != ((ArrayFat *)bfat)->attr)
1992 return 0;
1993
1994 if (ptrArrayIsEmpty ((ptrArray *)a) && ptrArrayIsEmpty ((ptrArray*)b))
1995 return 1;
1996 else if (a == b)
1997 return 1;
1998 else
1999 return 0;
2000 }
2001
2002 static void
array_es_print(const void * ptr,const void * fat,MIO * out)2003 array_es_print (const void *ptr, const void *fat, MIO *out)
2004 {
2005 unsigned int c = ptrArrayCount ((ptrArray *)ptr);
2006 ArrayFat *a = (ArrayFat *)fat;
2007 mio_printf (out, "%c%c%c count: %u",
2008 (a->attr & ATTR_READABLE) ? 'r': '-',
2009 (a->attr & ATTR_WRITABLE) ? 'w': '-',
2010 (a->attr & ATTR_EXECUTABLE)? 'x': '-',
2011 c);
2012 }
2013
2014 static void
array_op_add(EsObject * array,EsObject * elt)2015 array_op_add (EsObject* array, EsObject* elt)
2016 {
2017 ptrArray *a = es_pointer_get (array);
2018 ptrArrayAdd (a, es_object_ref (elt));
2019 }
2020
2021 static unsigned int
array_op_length(const EsObject * array)2022 array_op_length (const EsObject* array)
2023 {
2024 ptrArray *a = es_pointer_get (array);
2025 return ptrArrayCount (a);
2026 }
2027
2028 static EsObject*
array_op_get(const EsObject * array,unsigned int n)2029 array_op_get (const EsObject* array, unsigned int n)
2030 {
2031 ptrArray *a = es_pointer_get (array);
2032 unsigned int len = ptrArrayCount (a);
2033 if (n >= len)
2034 return OPT_ERR_RANGECHECK;
2035 return ptrArrayItem (a, n);
2036 }
2037
2038 static void
array_op_put(EsObject * array,unsigned int n,EsObject * obj)2039 array_op_put (EsObject* array, unsigned int n, EsObject *obj)
2040 {
2041 ptrArray *a = es_pointer_get (array);
2042 ptrArrayUpdate (a, n,
2043 es_object_ref (obj), es_nil);
2044 }
2045
2046
2047 /*
2048 * Dictionary
2049 */
2050 static unsigned int
opt_es_hash(const void * const key)2051 opt_es_hash (const void * const key)
2052 {
2053 const EsObject *k = key;
2054
2055 if (es_integer_p (key))
2056 return hashInthash (key);
2057 else if (es_boolean_p (key))
2058 return es_object_equal (key, es_true)? 1: 0;
2059
2060 return hashPtrhash (k);
2061 }
2062
2063 static bool
opt_es_eq(const void * a,const void * b)2064 opt_es_eq (const void* a, const void* b)
2065 {
2066 return es_object_equal (a, b);
2067 }
2068
2069 static EsObject*
dict_new(unsigned int size,unsigned int attr)2070 dict_new (unsigned int size, unsigned int attr)
2071 {
2072 hashTable *t = hashTableNew (size,
2073 opt_es_hash,
2074 opt_es_eq,
2075 (hashTableDeleteFunc)es_object_unref,
2076 (hashTableDeleteFunc)es_object_unref);
2077 hashTableSetValueForUnknownKey (t, t, NULL);
2078 return es_fatptr_new (OPT_TYPE_DICT, t, &attr);
2079 }
2080
2081 static EsObject*
dict_es_init_fat(void * fat,void * ptr,void * extra)2082 dict_es_init_fat (void *fat, void *ptr, void *extra)
2083 {
2084 DictFat *a = fat;
2085 a->attr = *((unsigned int *)extra);
2086 return es_false;
2087 }
2088
2089 static void
dict_es_free(void * ptr,void * fat)2090 dict_es_free (void *ptr, void *fat)
2091 {
2092 if (ptr)
2093 hashTableDelete ((hashTable *)ptr);
2094 }
2095
2096 static int
dict_es_equal(const void * a,const void * afat,const void * b,const void * bfat)2097 dict_es_equal (const void *a, const void *afat, const void *b, const void *bfat)
2098 {
2099 if (a == b)
2100 return 1;
2101 return 0;
2102 }
2103
2104 static void
dict_es_print(const void * ptr,const void * fat,MIO * out)2105 dict_es_print (const void *ptr, const void *fat, MIO *out)
2106 {
2107 unsigned int c = hashTableCountItem ((hashTable *)ptr);
2108 DictFat *a = (DictFat *)fat;
2109 mio_printf (out, "%c%c%c count: %u",
2110 (a->attr & ATTR_READABLE) ? 'r': '-',
2111 (a->attr & ATTR_WRITABLE) ? 'w': '-',
2112 (a->attr & ATTR_EXECUTABLE)? 'x': '-',
2113 c);
2114 }
2115
2116 static void
dict_op_def(EsObject * dict,EsObject * key,EsObject * val)2117 dict_op_def (EsObject* dict, EsObject *key, EsObject *val)
2118 {
2119 hashTable *t = es_pointer_get (dict);
2120 Assert (t);
2121 Assert (!es_null (key));
2122
2123 if (es_object_get_type (key) == OPT_TYPE_NAME)
2124 key = es_pointer_get (key);
2125
2126 key = es_object_ref (key);
2127 val = es_object_ref (val);
2128
2129 hashTableUpdateItem (t, key, val);
2130 }
2131
2132 static bool
dict_op_undef(EsObject * dict,EsObject * key)2133 dict_op_undef (EsObject *dict, EsObject *key)
2134 {
2135 hashTable *t = es_pointer_get (dict);
2136 Assert (t);
2137
2138 if (es_object_get_type (key) == OPT_TYPE_NAME)
2139 key = es_pointer_get (key);
2140
2141 /* TODO: handle the case key == NULL */
2142 return hashTableDeleteItem (t, key);
2143 }
2144
2145 static bool
dict_op_known_and_get(EsObject * dict,EsObject * key,EsObject ** val)2146 dict_op_known_and_get(EsObject* dict, EsObject *key, EsObject **val)
2147 {
2148 hashTable *t = es_pointer_get (dict);
2149 Assert (t);
2150
2151 if (es_object_get_type (key) == OPT_TYPE_STRING)
2152 {
2153 const char * cstr = opt_string_get_cstr (key);
2154 key = es_symbol_intern (cstr);
2155 }
2156
2157 if (es_object_get_type (key) == OPT_TYPE_NAME)
2158 key = es_pointer_get (key);
2159
2160 void *tmp = hashTableGetItem (t, key);
2161 if (tmp == t)
2162 return false;
2163
2164 if (val)
2165 *val = tmp;
2166 return true;
2167 }
2168
2169 static void
dict_op_clear(EsObject * dict)2170 dict_op_clear (EsObject* dict)
2171 {
2172 hashTable *h = es_pointer_get (dict);
2173 Assert (h);
2174
2175 hashTableClear (h);
2176 }
2177
2178
2179 /*
2180 * Operator
2181 */
2182 static EsObject*
operator_new(Operator op,const char * name,int arity,const char * help_str)2183 operator_new (Operator op, const char *name, int arity, const char *help_str)
2184 {
2185 OperatorExtra extra = { .name = name, .arity = arity, .help_str = help_str };
2186 return es_fatptr_new (OPT_TYPE_OPERATOR, op, &extra);
2187 }
2188
2189 static EsObject*
operator_es_init_fat(void * fat,void * ptr,void * extra)2190 operator_es_init_fat (void *fat, void *ptr, void *extra)
2191 {
2192 OperatorFat *ofat = fat;
2193
2194 if (!extra)
2195 {
2196 ofat->name = NULL;
2197 return es_true;
2198 }
2199
2200 OperatorExtra *oextra = extra;
2201 const char *name = oextra->name;
2202 EsObject *o = es_symbol_intern (name);
2203
2204 if (es_error_p (o))
2205 return o;
2206 ofat->name = o;
2207 ofat->arity = oextra->arity;
2208 ofat->help_str = oextra->help_str? eStrdup (oextra->help_str): NULL;
2209 return es_true;
2210 }
2211
2212 static void
operator_es_free(void * ptr,void * fat)2213 operator_es_free (void *ptr, void *fat)
2214 {
2215 OperatorFat *ofat = fat;
2216 if (ofat->help_str)
2217 eFree ((char *)ofat->help_str);
2218 }
2219
2220 static void
operator_es_print(const void * ptr,const void * fat,MIO * out)2221 operator_es_print (const void *ptr, const void *fat, MIO *out)
2222 {
2223 OperatorFat *ofat = (OperatorFat *)fat;
2224 mio_printf (out, "--%s--", es_symbol_get (ofat->name));
2225 }
2226
2227 /*
2228 * String
2229 */
2230 static EsObject*
string_new(vString * vstr)2231 string_new (vString *vstr)
2232 {
2233 unsigned int attr = ATTR_READABLE|ATTR_WRITABLE;
2234
2235 if (vstr == NULL)
2236 vstr = vStringNew ();
2237
2238 return es_fatptr_new (OPT_TYPE_STRING, vstr, &attr);
2239 }
2240
2241 static EsObject*
string_es_init_fat(void * fat,void * ptr,void * extra)2242 string_es_init_fat (void *fat, void *ptr, void *extra)
2243 {
2244 StringFat *s = fat;
2245 s->attr = *((unsigned int *)extra);
2246 return es_false;
2247 }
2248
2249 static void
string_es_free(void * ptr,void * fat)2250 string_es_free (void *ptr, void *fat)
2251 {
2252 if (ptr)
2253 vStringDelete (ptr);
2254 }
2255
2256 static int
string_es_equal(const void * a,const void * afat,const void * b,const void * bfat)2257 string_es_equal (const void *a,
2258 const void *afat,
2259 const void *b,
2260 const void *bfat)
2261 {
2262 if (!strcmp (vStringValue ((vString *)a),
2263 vStringValue ((vString *)b)))
2264 return 1;
2265 return 0;
2266 }
2267
2268
2269 static void
string_es_print(const void * ptr,const void * fat,MIO * out)2270 string_es_print (const void *ptr, const void *fat, MIO *out)
2271 {
2272 char *v = vStringValue ((vString *)ptr);
2273
2274 mio_putc (out, '(');
2275 while (*v != '\0')
2276 {
2277 switch (*v)
2278 {
2279 case '(':
2280 case ')':
2281 case '\\':
2282 mio_putc (out, '\\');
2283 mio_putc (out, *v);
2284 break;
2285 case '\n':
2286 mio_putc (out, '\\');
2287 mio_putc (out, 'n');
2288 break;
2289 case '\r':
2290 mio_putc (out, '\\');
2291 mio_putc (out, 'r');
2292 break;
2293 case '\t':
2294 mio_putc (out, '\\');
2295 mio_putc (out, 't');
2296 break;
2297 case '\f':
2298 mio_putc (out, '\\');
2299 mio_putc (out, 'f');
2300 break;
2301 case '\v':
2302 mio_putc (out, '\\');
2303 mio_putc (out, 'v');
2304 break;
2305 default:
2306 mio_putc (out, *v);
2307 }
2308 v++;
2309 }
2310 mio_putc (out, ')');
2311 }
2312
2313
2314 /*
2315 * Name
2316 */
2317 static EsObject*
name_new(EsObject * symbol,unsigned int attr)2318 name_new (EsObject* symbol, unsigned int attr)
2319 {
2320 return es_fatptr_new (OPT_TYPE_NAME,
2321 es_object_ref (symbol), &attr);
2322 }
2323
2324 static EsObject*
name_newS(const char * s,unsigned int attr)2325 name_newS (const char*s, unsigned int attr)
2326 {
2327 EsObject *sym = es_symbol_intern (s);
2328 return name_new (sym, attr);
2329 }
2330
name_newS_cb(const char * s,void * attr)2331 static EsObject* name_newS_cb (const char*s, void *attr)
2332 {
2333 return name_newS (s, *((unsigned int *)attr));
2334 }
2335
2336 static EsObject*
name_es_init_fat(void * fat,void * ptr,void * extra)2337 name_es_init_fat (void *fat, void *ptr, void *extra)
2338 {
2339 ArrayFat *a = fat;
2340 a->attr = *((unsigned int *)extra);
2341 return es_false;
2342 }
2343
2344 static void
name_es_print(const void * ptr,const void * fat,MIO * out)2345 name_es_print (const void *ptr, const void *fat, MIO *out)
2346 {
2347 const EsObject *symbol = ptr;
2348 const NameFat *qfat = fat;
2349 if (!(qfat->attr & ATTR_EXECUTABLE))
2350 mio_putc (out, '/');
2351 const char *name = es_symbol_get (symbol);
2352 mio_puts (out, name);
2353 }
2354
2355 static void
name_es_free(void * ptr,void * fat)2356 name_es_free (void *ptr, void *fat)
2357 {
2358 if (ptr)
2359 es_object_unref (ptr);
2360 }
2361
2362 static int
name_es_equal(const void * a,const void * afat,const void * b,const void * bfat)2363 name_es_equal (const void *a, const void *afat,
2364 const void *b, const void *bfat)
2365 {
2366 const EsObject * asym = a;
2367 const EsObject * bsym = b;
2368 return es_object_equal (asym, bsym);
2369 }
2370
2371 /*
2372 * Mark
2373 */
2374 static EsObject*
mark_new(const char * mark)2375 mark_new (const char* mark)
2376 {
2377 return es_pointer_new (OPT_TYPE_MARK,
2378 eStrdup (mark));
2379 }
2380
2381 static void
mark_es_print(const void * ptr,MIO * out)2382 mark_es_print (const void *ptr, MIO *out)
2383 {
2384 if (ptr == NULL || (strcmp (ptr, "mark") == 0))
2385 mio_printf (out, "-mark-");
2386 else
2387 mio_printf (out, "-mark:%s-", (char *)ptr);
2388 }
2389
2390 static void
mark_es_free(void * ptr)2391 mark_es_free (void *ptr)
2392 {
2393 if (ptr)
2394 eFree (ptr);
2395 }
2396
2397 static int
mark_es_equal(const void * a,const void * b)2398 mark_es_equal (const void *a, const void *b)
2399 {
2400 return 1;
2401 }
2402
2403
2404 /*
2405 * Operator implementations
2406 */
2407 #define GEN_PRINTER(NAME, BODY) \
2408 static EsObject* \
2409 NAME(OptVM *vm, EsObject *name) \
2410 { \
2411 EsObject * elt = ptrArrayRemoveLast (vm->ostack); \
2412 BODY; \
2413 mio_putc (vm->out, '\n'); \
2414 es_object_unref (elt); \
2415 return es_false; \
2416 }
2417
2418 GEN_PRINTER(op__print_objdict_rec, vm_print_full (vm, elt, false, 10))
2419 GEN_PRINTER(op__print_objdict, vm_print_full (vm, elt, false, 1))
2420 GEN_PRINTER(op__print_object, vm_print_full (vm, elt, false, 0))
2421 GEN_PRINTER(op__print, vm_print_full (vm, elt, true, 0))
2422
2423 static EsObject*
op__make_array(OptVM * vm,EsObject * name)2424 op__make_array (OptVM *vm, EsObject *name)
2425 {
2426 int n = vm_ostack_counttomark (vm);
2427 if (n < 0)
2428 return OPT_ERR_UNMATCHEDMARK;
2429
2430 unsigned int count = vm_ostack_count (vm);
2431 EsObject *a = array_new (ATTR_READABLE | ATTR_WRITABLE);
2432 for (int i = (int)(count - n); i < count; i++)
2433 {
2434 EsObject *elt = ptrArrayItem (vm->ostack, i);
2435 array_op_add (a, elt);
2436 }
2437
2438 ptrArrayDeleteLastInBatch (vm->ostack, n + 1);
2439 vm_ostack_push (vm, a);
2440 es_object_unref (a);
2441 return es_false;
2442 }
2443
2444 static EsObject*
op__make_dict(OptVM * vm,EsObject * name)2445 op__make_dict (OptVM *vm, EsObject *name)
2446 {
2447 int n = vm_ostack_counttomark (vm);
2448 if (n < 0)
2449 return OPT_ERR_UNMATCHEDMARK;
2450
2451 if (n % 2)
2452 return OPT_ERR_RANGECHECK;
2453
2454 for (int i = 0; i < (n / 2); i++)
2455 {
2456 EsObject *key = ptrArrayItemFromLast (vm->ostack, 2 * i + 1);
2457
2458 if (es_object_get_type (key) != OPT_TYPE_NAME
2459 && es_object_get_type (key) != OPT_TYPE_STRING
2460 && !es_integer_p (key) && !es_boolean_p (key))
2461 return OPT_ERR_TYPECHECK;
2462 }
2463
2464 EsObject *d = dict_new (n % 2 + 1, ATTR_READABLE|ATTR_WRITABLE); /* FIXME: + 1 */
2465 for (int i = 0; i < (n / 2); i++)
2466 {
2467 EsObject *val = ptrArrayLast (vm->ostack);
2468 EsObject *key = ptrArrayItemFromLast (vm->ostack, 1);
2469 bool converted = false;
2470
2471 if (es_object_get_type (key) == OPT_TYPE_STRING)
2472 {
2473 const char *cstr = opt_string_get_cstr (key);
2474 key = opt_name_new_from_cstr (cstr);
2475 converted = true;
2476 }
2477 dict_op_def (d, key, val);
2478 if (converted)
2479 es_object_unref (key);
2480
2481 ptrArrayDeleteLastInBatch (vm->ostack, 2);
2482 }
2483 ptrArrayDeleteLast (vm->ostack); /* Remove the mark */
2484 vm_ostack_push (vm, d);
2485 es_object_unref (d);
2486 return es_false;
2487 }
2488
2489 static EsObject*
op__help(OptVM * vm,EsObject * name)2490 op__help (OptVM *vm, EsObject *name)
2491 {
2492 vm_help (vm, vm->out, NULL, NULL);
2493 return es_false;
2494 }
2495
2496 static EsObject*
op_pstack(OptVM * vm,EsObject * name)2497 op_pstack (OptVM *vm, EsObject *name)
2498 {
2499 unsigned int c = vm_ostack_count (vm);
2500
2501 for (unsigned int i = c; i > 0; i--)
2502 {
2503 EsObject * elt = ptrArrayItem (vm->ostack, i - 1);
2504 vm_print (vm, elt);
2505 mio_putc (vm->out, '\n');
2506 }
2507 return es_false;
2508 }
2509
2510 static EsObject*
op__newerror(OptVM * vm,EsObject * name)2511 op__newerror (OptVM *vm, EsObject *name)
2512 {
2513 EsObject *newerror;
2514 if (dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror))
2515 vm_ostack_push (vm, newerror);
2516 else
2517 vm_ostack_push (vm, es_false);
2518 return es_false;
2519 }
2520
2521 static EsObject*
op__errorname(OptVM * vm,EsObject * name)2522 op__errorname (OptVM *vm, EsObject *name)
2523 {
2524 EsObject *errorname;
2525 if (dict_op_known_and_get (vm->error, OPT_KEY_errorname, &errorname))
2526 {
2527 EsObject *sym = es_nil;
2528 if (!es_null (errorname))
2529 {
2530 const char *cstr = es_error_name(errorname);
2531 sym = opt_name_new_from_cstr (cstr);
2532 }
2533 vm_ostack_push (vm, sym);
2534 if (!es_null (errorname))
2535 es_object_unref (sym);
2536 }
2537 else
2538 vm_ostack_push (vm, es_nil);
2539 return es_false;
2540 }
2541
2542 static EsObject*
op_quit(OptVM * vm,EsObject * name)2543 op_quit (OptVM *vm, EsObject *name)
2544 {
2545 int c = mio_getc (vm->in);
2546 if (!(c == '\n' || c == '\r' || c == EOF))
2547 mio_ungetc (vm->in, c);
2548 return OPT_ERR_QUIT;
2549 }
2550
2551 static EsObject*
op_countexecstack(OptVM * vm,EsObject * name)2552 op_countexecstack (OptVM *vm, EsObject *name)
2553 {
2554 unsigned int c = ptrArrayCount (vm->estack);
2555 int n = c;
2556
2557 if (n < 0)
2558 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
2559
2560 EsObject *nobj = es_integer_new (n);
2561 vm_ostack_push (vm, nobj);
2562 es_object_unref (nobj);
2563
2564 return es_false;
2565 }
2566
2567 static EsObject*
op__stack_common(OptVM * vm,EsObject * name,ptrArray * stack,EsObject * dstarrayobj,bool ignoreLast)2568 op__stack_common (OptVM *vm, EsObject *name, ptrArray *stack, EsObject *dstarrayobj,
2569 bool ignoreLast)
2570 {
2571 unsigned int c = ptrArrayCount (stack);
2572 ptrArray *a = es_pointer_get (dstarrayobj);
2573
2574 if (ignoreLast && c == 0)
2575 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
2576
2577 ptrArrayClear (a);
2578 for (unsigned int i = 0; i < c - (ignoreLast? 1: 0); i++)
2579 {
2580 EsObject *d = ptrArrayItem (stack, i);
2581 ptrArrayAdd (a, es_object_ref (d));
2582 }
2583
2584 return es_false;
2585 }
2586
2587 static EsObject*
op_execstack(OptVM * vm,EsObject * name)2588 op_execstack (OptVM *vm, EsObject *name)
2589 {
2590 EsObject *obj = ptrArrayLast (vm->ostack);
2591 if (es_object_get_type (obj) != OPT_TYPE_ARRAY)
2592 return OPT_ERR_TYPECHECK;
2593
2594 return op__stack_common (vm, name, vm->estack, obj, true);
2595 }
2596
2597
2598 /*
2599 * Operators for operand stack manipulation
2600 */
2601 static EsObject*
op_pop(OptVM * vm,EsObject * name)2602 op_pop (OptVM *vm, EsObject *name)
2603 {
2604 ptrArrayDeleteLast (vm->ostack);
2605 return es_false;
2606 }
2607
2608 static EsObject*
op_exch(OptVM * vm,EsObject * name)2609 op_exch (OptVM *vm, EsObject *name)
2610 {
2611 EsObject * top = ptrArrayRemoveLast (vm->ostack);
2612 EsObject * next = ptrArrayRemoveLast (vm->ostack);
2613 ptrArrayAdd (vm->ostack, top);
2614 ptrArrayAdd (vm->ostack, next);
2615 return es_false;
2616 }
2617
2618 static EsObject*
op_dup(OptVM * vm,EsObject * name)2619 op_dup (OptVM *vm, EsObject *name)
2620 {
2621 EsObject * top = vm_ostack_top (vm);
2622 if (es_error_p (top))
2623 return top;
2624 vm_ostack_push (vm, top);
2625 return es_false;
2626 }
2627
2628 static bool
dict_copy_cb(const void * key,void * value,void * user_data)2629 dict_copy_cb (const void *key, void *value, void *user_data)
2630 {
2631 hashTable *dst = user_data;
2632 hashTablePutItem (dst, es_object_ref ((void *)key), es_object_ref (value));
2633 return true;
2634 }
2635
2636 static EsObject*
op__copy_compound(OptVM * vm,EsObject * name,unsigned int c,EsObject * obj2)2637 op__copy_compound (OptVM *vm, EsObject *name, unsigned int c, EsObject *obj2)
2638 {
2639 int t = es_object_get_type (obj2);
2640 if (!(t == OPT_TYPE_ARRAY || t == OPT_TYPE_DICT || t == OPT_TYPE_STRING))
2641 return OPT_ERR_TYPECHECK;
2642
2643 if (c < 2)
2644 return OPT_ERR_UNDERFLOW;
2645
2646 EsObject *obj1 = ptrArrayItemFromLast (vm->ostack, 1);
2647 if (es_object_get_type (obj1) != t)
2648 return OPT_ERR_TYPECHECK;
2649
2650 if (t == OPT_TYPE_ARRAY)
2651 {
2652 ptrArray *a1 = es_pointer_get (obj1);
2653 ptrArray *a2 = es_pointer_get (obj2);
2654 ptrArrayClear (a2);
2655 unsigned int len = ptrArrayCount (a1);
2656 for (unsigned int i = 0; i < len; i++)
2657 {
2658 EsObject *o = ptrArrayItem (a1, i);
2659 ptrArrayAdd (a2, es_object_ref (o));
2660 }
2661 }
2662 else if (t == OPT_TYPE_DICT)
2663 {
2664 hashTable *ht1 = es_pointer_get (obj1);
2665 hashTable *ht2 = es_pointer_get (obj2);
2666 hashTableClear (ht2);
2667 hashTableForeachItem (ht1, dict_copy_cb, ht2);
2668 }
2669 else
2670 {
2671 vString *str1 = es_pointer_get (obj1);
2672 vString *str2 = es_pointer_get (obj2);
2673 vStringCopy (str2, str1);
2674 }
2675
2676 ptrArrayRemoveLast (vm->ostack);
2677 ptrArrayDeleteLast (vm->ostack);
2678 ptrArrayAdd (vm->ostack, obj2);
2679 return es_false;
2680 }
2681
2682 static EsObject*
op_copy(OptVM * vm,EsObject * name)2683 op_copy (OptVM *vm, EsObject *name)
2684 {
2685 unsigned int c = vm_ostack_count (vm);
2686
2687 if (c > 0)
2688 {
2689 EsObject * nobj = ptrArrayLast(vm->ostack);
2690
2691
2692 if (!es_integer_p (nobj))
2693 return op__copy_compound (vm, name, c, nobj);
2694
2695 int n = es_integer_get (nobj);
2696 if (n < 0)
2697 return OPT_ERR_RANGECHECK;
2698
2699 c--;
2700
2701 if (((int)c) - n < 0)
2702 return OPT_ERR_UNDERFLOW;
2703
2704 ptrArrayDeleteLast(vm->ostack);
2705
2706 for (int i = c - n; i < c; i++)
2707 {
2708 EsObject * elt = ptrArrayItem (vm->ostack, i);
2709 vm_ostack_push (vm, elt);
2710 }
2711 return es_false;
2712 }
2713 return OPT_ERR_UNDERFLOW;
2714 }
2715
2716 static EsObject*
op_index(OptVM * vm,EsObject * name)2717 op_index (OptVM *vm, EsObject *name)
2718 {
2719 unsigned int c = vm_ostack_count (vm);
2720
2721 EsObject * nobj = ptrArrayLast(vm->ostack);
2722 if (!es_integer_p (nobj))
2723 return OPT_ERR_TYPECHECK;
2724
2725 int n = es_integer_get (nobj);
2726 if (n < 0)
2727 return OPT_ERR_RANGECHECK;
2728 if (c < (unsigned int)(n + 2))
2729 return OPT_ERR_UNDERFLOW;
2730
2731 ptrArrayDeleteLast (vm->ostack);
2732
2733 EsObject * elt = ptrArrayItem (vm->ostack, c - n - 2);
2734 vm_ostack_push (vm, elt);
2735 return es_false;
2736
2737 return OPT_ERR_UNDERFLOW;
2738 }
2739
2740 static EsObject*
op_roll(OptVM * vm,EsObject * name)2741 op_roll (OptVM *vm, EsObject *name)
2742 {
2743 unsigned int c = vm_ostack_count (vm);
2744
2745 EsObject *jobj = ptrArrayLast (vm->ostack);
2746 if (!es_integer_p (jobj))
2747 return OPT_ERR_TYPECHECK;
2748 int j = es_integer_get (jobj);
2749
2750 EsObject *nobj = ptrArrayItemFromLast (vm->ostack, 1);
2751 if (!es_integer_p (nobj))
2752 return OPT_ERR_TYPECHECK;
2753 int n = es_integer_get (nobj);
2754
2755 if ((((int)c) - 2) < n)
2756 return OPT_ERR_UNDERFLOW;
2757
2758 ptrArrayDeleteLastInBatch (vm->ostack, 2);
2759 if (j == 0)
2760 return es_false;
2761
2762 unsigned int indx = c - 2 - n;
2763 EsObject *p;
2764 if (j > 0)
2765 {
2766 while (j-- != 0)
2767 {
2768 p = ptrArrayRemoveLast (vm->ostack);
2769 ptrArrayInsertItem (vm->ostack, indx, p);
2770 }
2771 }
2772 else
2773 {
2774 while (j++ != 0)
2775 {
2776 p = ptrArrayRemoveItem(vm->ostack, indx);
2777 ptrArrayAdd (vm->ostack, p);
2778 }
2779
2780 }
2781
2782 return es_false;
2783 }
2784
2785 static EsObject*
op_clear(OptVM * vm,EsObject * name)2786 op_clear (OptVM *vm, EsObject *name)
2787 {
2788 ptrArrayClear (vm->ostack);
2789
2790 return es_false;
2791 }
2792
2793 static EsObject*
op_count(OptVM * vm,EsObject * name)2794 op_count (OptVM *vm, EsObject *name)
2795 {
2796 unsigned int c = ptrArrayCount (vm->ostack);
2797
2798 EsObject *n = es_integer_new ((int)c);
2799 ptrArrayAdd (vm->ostack, n);
2800
2801 return es_false;
2802 }
2803
2804 static EsObject*
op_mark(OptVM * vm,EsObject * name)2805 op_mark (OptVM *vm, EsObject *name)
2806 {
2807 EsObject *mark;
2808 if (es_object_equal (name, es_symbol_intern ("[")))
2809 mark = OPT_MARK_ARRAY;
2810 else if (es_object_equal (name, es_symbol_intern ("<<")))
2811 mark = OPT_MARK_DICT;
2812 else
2813 mark = OPT_MARK_MARK;
2814 vm_ostack_push (vm, mark);
2815
2816 return es_false;
2817 }
2818
2819 static EsObject*
op_cleartomark(OptVM * vm,EsObject * name)2820 op_cleartomark (OptVM *vm, EsObject *name)
2821 {
2822 int r = vm_ostack_counttomark (vm);
2823
2824 if (r < 0)
2825 return OPT_ERR_UNMATCHEDMARK;
2826
2827 if (r < 0)
2828 return OPT_ERR_UNMATCHEDMARK;
2829
2830 for (int i = 0; i <= r; i++)
2831 ptrArrayDeleteLast (vm->ostack);
2832 return es_false;
2833 }
2834
2835 static EsObject*
op_counttomark(OptVM * vm,EsObject * name)2836 op_counttomark (OptVM *vm, EsObject *name)
2837 {
2838 int r = vm_ostack_counttomark (vm);
2839
2840 if (r < 0)
2841 return OPT_ERR_UNMATCHEDMARK;
2842
2843 ptrArrayAdd (vm->ostack, es_integer_new (r));
2844 return es_false;
2845 }
2846
2847
2848 /*
2849 * Arithmetic Operators
2850 */
2851 #define INTEGER_BINOP(OP) \
2852 EsObject *n0obj = ptrArrayLast (vm->ostack); \
2853 if (!es_integer_p (n0obj)) \
2854 return OPT_ERR_TYPECHECK; \
2855 int n0 = es_integer_get (n0obj); \
2856 \
2857 EsObject *n1obj = ptrArrayItemFromLast (vm->ostack, 1); \
2858 if (!es_integer_p (n1obj)) \
2859 return OPT_ERR_TYPECHECK; \
2860 int n1 = es_integer_get (n1obj); \
2861 \
2862 EsObject *r = es_integer_new (n1 OP n0); \
2863 if (es_error_p (r)) \
2864 return r; \
2865 \
2866 ptrArrayDeleteLastInBatch (vm->ostack, 2); \
2867 ptrArrayAdd (vm->ostack, r); \
2868 return es_false
2869
2870 static EsObject*
op_add(OptVM * vm,EsObject * name)2871 op_add (OptVM *vm, EsObject *name)
2872 {
2873 INTEGER_BINOP(+);
2874 }
2875
2876 static EsObject*
op_idiv(OptVM * vm,EsObject * name)2877 op_idiv (OptVM *vm, EsObject *name)
2878 {
2879 INTEGER_BINOP(/);
2880 }
2881
2882 static EsObject*
op_mod(OptVM * vm,EsObject * name)2883 op_mod (OptVM *vm, EsObject *name)
2884 {
2885 INTEGER_BINOP(%);
2886 }
2887
2888 static EsObject*
op_mul(OptVM * vm,EsObject * name)2889 op_mul (OptVM *vm, EsObject *name)
2890 {
2891 INTEGER_BINOP(*);
2892 }
2893
2894 static EsObject*
op_sub(OptVM * vm,EsObject * name)2895 op_sub (OptVM *vm, EsObject *name)
2896 {
2897 INTEGER_BINOP(-);
2898 }
2899
2900 static EsObject*
op_abs(OptVM * vm,EsObject * name)2901 op_abs (OptVM *vm, EsObject *name)
2902 {
2903 EsObject *nobj = ptrArrayLast (vm->ostack);
2904 if (!es_integer_p (nobj))
2905 return OPT_ERR_TYPECHECK;
2906
2907 int n = es_integer_get(nobj);
2908 if (n >= 0)
2909 return es_false;
2910
2911 EsObject *r = es_integer_new (-n);
2912 if (es_error_p (r))
2913 return r;
2914 ptrArrayDeleteLast (vm->ostack);
2915 ptrArrayAdd (vm->ostack, r);
2916 return es_false;
2917 }
2918
2919 static EsObject*
op_neg(OptVM * vm,EsObject * name)2920 op_neg (OptVM *vm, EsObject *name)
2921 {
2922 EsObject *nobj = ptrArrayLast (vm->ostack);
2923 if (!es_integer_p (nobj))
2924 return OPT_ERR_TYPECHECK;
2925 int n = es_integer_get(nobj);
2926 EsObject *r = es_integer_new (-n);
2927 if (es_error_p (r))
2928 return r;
2929 ptrArrayDeleteLast (vm->ostack);
2930 ptrArrayAdd (vm->ostack, r);
2931 return es_false;
2932 }
2933
2934
2935 /*
2936 * Operators for array manipulation
2937 */
2938 static EsObject*
op_array(OptVM * vm,EsObject * name)2939 op_array (OptVM *vm, EsObject *name)
2940 {
2941 EsObject *nobj = ptrArrayLast (vm->ostack);
2942 if (!es_integer_p (nobj))
2943 return OPT_ERR_TYPECHECK;
2944
2945 int n = es_integer_get (nobj);
2946 if (n < 0)
2947 return OPT_ERR_RANGECHECK;
2948
2949 ptrArrayDeleteLast (vm->ostack);
2950
2951 EsObject *array = array_new (ATTR_WRITABLE|ATTR_READABLE);
2952 ptrArray *a = es_pointer_get (array);
2953 for (int i = 0; i < n; i++)
2954 ptrArrayAdd (a, es_nil);
2955 vm_ostack_push (vm, array);
2956 es_object_unref (array);
2957
2958 return es_false;
2959 }
2960
2961 static EsObject*
op_astore(OptVM * vm,EsObject * name)2962 op_astore (OptVM *vm, EsObject *name)
2963 {
2964 EsObject *array = ptrArrayLast (vm->ostack);
2965 if (es_object_get_type (array) != OPT_TYPE_ARRAY)
2966 return OPT_ERR_TYPECHECK;
2967
2968 unsigned int c = ptrArrayCount (vm->ostack);
2969 ptrArray *a = es_pointer_get (array);
2970 unsigned int l = ptrArrayCount (a);
2971
2972 if (l == 0)
2973 return es_false;
2974
2975 /* +1 is for the array itself. */
2976 if (c < (l + 1))
2977 return OPT_ERR_UNDERFLOW;
2978
2979 ptrArrayClear (a);
2980 ptrArrayRemoveLast (vm->ostack);
2981
2982 int i = l - 1;
2983 if (i < 0)
2984 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
2985 for (; i >= 0; i--)
2986 {
2987 EsObject * o = ptrArrayItemFromLast (vm->ostack, i);
2988 ptrArrayAdd (a, es_object_ref (o));
2989 }
2990
2991 ptrArrayDeleteLastInBatch (vm->ostack, l);
2992 vm_ostack_push (vm, array);
2993 es_object_unref (array);
2994 return es_false;
2995 }
2996
2997 static EsObject*
op_aload(OptVM * vm,EsObject * name)2998 op_aload (OptVM *vm, EsObject *name)
2999 {
3000 EsObject *array = ptrArrayLast (vm->ostack);
3001 if (es_object_get_type (array) != OPT_TYPE_ARRAY)
3002 return OPT_ERR_TYPECHECK;
3003 ptrArray *a = es_pointer_get (array);
3004
3005 ptrArrayRemoveLast (vm->ostack);
3006 unsigned int c = ptrArrayCount (a);
3007 for (unsigned int i = 0; i < c; i++)
3008 {
3009 EsObject *o = ptrArrayItem (a, i);
3010 vm_ostack_push (vm, o);
3011 }
3012 vm_ostack_push (vm, array);
3013 es_object_unref (array);
3014 return es_false;
3015 }
3016
3017
3018 /*
3019 * Operators for dictionary manipulation
3020 */
3021 static EsObject*
op_dict(OptVM * vm,EsObject * name)3022 op_dict (OptVM *vm, EsObject *name)
3023 {
3024 EsObject *nobj = ptrArrayLast (vm->ostack);
3025 if (!es_integer_p (nobj))
3026 return OPT_ERR_TYPECHECK;
3027
3028 int n = es_integer_get (nobj);
3029 if (n < 1)
3030 return OPT_ERR_RANGECHECK;
3031
3032 ptrArrayDeleteLast (vm->ostack);
3033
3034 EsObject *dict = dict_new (n, ATTR_READABLE|ATTR_WRITABLE);
3035 vm_ostack_push (vm, dict);
3036 es_object_unref (dict);
3037
3038 return es_false;
3039 }
3040
3041 static EsObject*
op_def(OptVM * vm,EsObject * name)3042 op_def (OptVM *vm, EsObject *name)
3043 {
3044 EsObject *val = ptrArrayLast (vm->ostack);
3045 EsObject *key = ptrArrayItemFromLast (vm->ostack, 1);
3046 /* TODO */
3047 if (es_object_get_type (key) != OPT_TYPE_NAME)
3048 return OPT_ERR_TYPECHECK;
3049
3050 vm_dict_def (vm, key, val);
3051
3052 ptrArrayDeleteLastInBatch(vm->ostack, 2);
3053
3054 return es_false;
3055 }
3056
3057 static EsObject*
op_undef(OptVM * vm,EsObject * name)3058 op_undef (OptVM *vm, EsObject *name)
3059 {
3060 EsObject *key = ptrArrayLast (vm->ostack);
3061 EsObject *dict = ptrArrayItemFromLast (vm->ostack, 1);
3062
3063 if (es_object_get_type (key) != OPT_TYPE_NAME)
3064 return OPT_ERR_TYPECHECK;
3065
3066 if (es_object_get_type (dict) != OPT_TYPE_DICT)
3067 return OPT_ERR_TYPECHECK;
3068
3069 unsigned int attr = ((DictFat *)es_fatptr_get (dict))->attr;
3070 if (!(attr & ATTR_WRITABLE))
3071 return OPT_ERR_INVALIDACCESS;
3072
3073 if (!dict_op_undef (dict, key))
3074 return es_error_set_object (OPT_ERR_UNDEFINED, key);
3075
3076 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3077 return es_false;
3078 }
3079
3080 static EsObject*
op_begin(OptVM * vm,EsObject * name)3081 op_begin (OptVM *vm, EsObject *name)
3082 {
3083 EsObject *d = ptrArrayLast (vm->ostack);
3084 if (es_object_get_type (d) != OPT_TYPE_DICT)
3085 return OPT_ERR_TYPECHECK;
3086
3087 vm_dstack_push (vm, d);
3088 ptrArrayDeleteLast (vm->ostack);
3089
3090 return es_false;
3091 }
3092
3093 static EsObject*
op_end(OptVM * vm,EsObject * name)3094 op_end (OptVM *vm, EsObject *name)
3095 {
3096 return vm_dstack_pop (vm);
3097 }
3098
3099 static EsObject*
op_currentdict(OptVM * vm,EsObject * name)3100 op_currentdict (OptVM *vm, EsObject *name)
3101 {
3102 EsObject *dict = ptrArrayLast (vm->dstack);
3103
3104 vm_ostack_push (vm, dict);
3105
3106 return es_false;
3107 }
3108
3109 static EsObject*
op_countdictstack(OptVM * vm,EsObject * name)3110 op_countdictstack (OptVM *vm, EsObject *name)
3111 {
3112 unsigned int c = ptrArrayCount (vm->dstack);
3113 int n = c;
3114
3115 if (n < 0)
3116 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
3117
3118 EsObject *nobj = es_integer_new (n);
3119 vm_ostack_push (vm, nobj);
3120 es_object_unref (nobj);
3121
3122 return es_false;
3123 }
3124
3125 static EsObject*
op_dictstack(OptVM * vm,EsObject * name)3126 op_dictstack (OptVM *vm, EsObject *name)
3127 {
3128 EsObject *obj = ptrArrayLast (vm->ostack);
3129 if (es_object_get_type (obj) != OPT_TYPE_ARRAY)
3130 return OPT_ERR_TYPECHECK;
3131
3132 return op__stack_common (vm, name, vm->dstack, obj, false);
3133 }
3134
3135 static EsObject*
op_cleardictstack(OptVM * vm,EsObject * name)3136 op_cleardictstack (OptVM *vm, EsObject *name)
3137 {
3138 unsigned int d = ptrArrayCount (vm->dstack) - vm->dstack_protection;
3139 ptrArrayDeleteLastInBatch (vm->dstack, d);
3140 return es_false;
3141 }
3142
3143 static EsObject*
op_where(OptVM * vm,EsObject * name)3144 op_where (OptVM *vm, EsObject *name)
3145 {
3146 EsObject *key = ptrArrayLast (vm->ostack);
3147 if (es_object_get_type (key) != OPT_TYPE_NAME)
3148 return OPT_ERR_TYPECHECK;
3149
3150 EsObject *dict = vm_dstack_known_and_get (vm, key, NULL);
3151 ptrArrayDeleteLast (vm->ostack);
3152
3153 if (es_object_get_type (dict) != OPT_TYPE_DICT)
3154 {
3155 vm_ostack_push (vm, es_false);
3156 return es_false;
3157 }
3158 else
3159 {
3160 vm_ostack_push (vm, dict);
3161 vm_ostack_push (vm, es_true);
3162 return es_false;
3163 }
3164 }
3165
3166 static EsObject*
op_known(OptVM * vm,EsObject * name)3167 op_known (OptVM *vm, EsObject *name)
3168 {
3169 EsObject *key = ptrArrayLast (vm->ostack);
3170 EsObject *dict = ptrArrayItemFromLast (vm->ostack, 1);
3171
3172 if (es_object_get_type (dict) != OPT_TYPE_DICT)
3173 return OPT_ERR_TYPECHECK;
3174
3175 EsObject *b = dict_op_known_and_get (dict, key, NULL)
3176 ? es_true
3177 : es_false;
3178 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3179 vm_ostack_push (vm, b);
3180
3181 return false;
3182 }
3183
3184 static EsObject*
op_store(OptVM * vm,EsObject * name)3185 op_store (OptVM *vm, EsObject *name)
3186 {
3187 EsObject *val = ptrArrayLast (vm->ostack);
3188 EsObject *key = ptrArrayItemFromLast (vm->ostack, 1);
3189
3190 if (es_null (key))
3191 return OPT_ERR_TYPECHECK;
3192 if (es_object_get_type (key) != OPT_TYPE_NAME)
3193 return OPT_ERR_TYPECHECK;
3194
3195 EsObject *dict = vm_dstack_known_and_get (vm, key, NULL);
3196 if (es_object_get_type (dict) != OPT_TYPE_DICT)
3197 vm_dict_def (vm, key, val);
3198 else if (!(((DictFat *)es_fatptr_get (dict))->attr & ATTR_WRITABLE))
3199 return OPT_ERR_INVALIDACCESS;
3200 else
3201 dict_op_def (dict, key, val);
3202
3203 ptrArrayDeleteLastInBatch(vm->ostack, 2);
3204 return es_false;
3205 }
3206
3207 static EsObject*
op_load(OptVM * vm,EsObject * name)3208 op_load (OptVM *vm, EsObject *name)
3209 {
3210 EsObject *key = ptrArrayLast (vm->ostack);
3211 EsObject *val = NULL;
3212 EsObject *dict = vm_dstack_known_and_get (vm, key, &val);
3213
3214 if (es_object_get_type (dict) != OPT_TYPE_DICT)
3215 return es_error_set_object (OPT_ERR_UNDEFINED, key);
3216 else
3217 {
3218 ptrArrayDeleteLast (vm->ostack);
3219 vm_ostack_push (vm, val);
3220 return es_false;
3221 }
3222 }
3223
3224
3225 /*
3226 * Operators for string manipulation
3227 */
3228 static EsObject*
op_string(OptVM * vm,EsObject * name)3229 op_string (OptVM *vm, EsObject *name)
3230 {
3231 EsObject *nobj = ptrArrayLast (vm->ostack);
3232 if (!es_integer_p (nobj))
3233 return OPT_ERR_TYPECHECK;
3234 int n = es_integer_get (nobj);
3235 if (n < 0)
3236 return OPT_ERR_RANGECHECK;
3237
3238 vString *s = vStringNew ();
3239
3240 while (n-- > 0)
3241 vStringPut (s, ' ');
3242
3243 EsObject *sobj = string_new (s);
3244 ptrArrayDeleteLast (vm->ostack);
3245 vm_ostack_push (vm, sobj);
3246 es_object_unref (sobj);
3247 return es_false;
3248 }
3249
3250 static EsObject*
op__strstr_common(OptVM * vm,EsObject * name,bool fromTail)3251 op__strstr_common (OptVM *vm, EsObject *name, bool fromTail)
3252 {
3253 EsObject *seekobj = ptrArrayLast (vm->ostack);
3254 EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1);
3255
3256 if (es_object_get_type (strobj) != OPT_TYPE_STRING)
3257 return OPT_ERR_TYPECHECK;
3258 if (es_object_get_type (seekobj) != OPT_TYPE_STRING)
3259 return OPT_ERR_TYPECHECK;
3260
3261 vString *stringv = es_pointer_get (strobj);
3262 vString *seekv = es_pointer_get (seekobj);
3263
3264 if (vStringLength (stringv) < vStringLength (seekv))
3265 {
3266 ptrArrayDeleteLast (vm->ostack);
3267 vm_ostack_push (vm, es_false);
3268 return es_false;
3269 }
3270
3271 const char *stringc = vStringValue (stringv);
3272 const char *seekc = vStringValue (seekv);
3273 char *tmp = (fromTail? strrstr: strstr) (stringc, seekc);
3274
3275 if (tmp == NULL)
3276 {
3277 ptrArrayDeleteLast (vm->ostack);
3278 vm_ostack_push (vm, es_false);
3279 return es_false;
3280 }
3281
3282 unsigned int ud = tmp - stringc;
3283 int d = (int)ud;
3284 if (d < 0)
3285 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
3286
3287 ptrArrayDeleteLast (vm->ostack);
3288 EsObject* dobj = es_integer_new (d);
3289 vm_ostack_push (vm, dobj);
3290 es_object_unref (dobj);
3291 vm_ostack_push (vm, es_true);
3292 return es_false;
3293 }
3294
3295 static EsObject*
op__strstr(OptVM * vm,EsObject * name)3296 op__strstr (OptVM *vm, EsObject *name)
3297 {
3298 return op__strstr_common (vm, name, false);
3299 }
3300
3301 static EsObject*
op__strrstr(OptVM * vm,EsObject * name)3302 op__strrstr (OptVM *vm, EsObject *name)
3303 {
3304 return op__strstr_common (vm, name, true);
3305 }
3306
3307 static EsObject*
op__strchr_common(OptVM * vm,EsObject * name,bool fromTail)3308 op__strchr_common (OptVM *vm, EsObject *name, bool fromTail)
3309 {
3310 EsObject *chrobj = ptrArrayLast (vm->ostack);
3311 EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1);
3312
3313 if (! es_integer_p (chrobj))
3314 return OPT_ERR_TYPECHECK;
3315
3316 unsigned int chr = (unsigned int)es_integer_get (chrobj);
3317 /* 0 is unacceptable. */
3318 if (! (0 < chr && chr < 256))
3319 return OPT_ERR_RANGECHECK;
3320
3321 if (es_object_get_type (strobj) != OPT_TYPE_STRING)
3322 return OPT_ERR_TYPECHECK;
3323
3324 vString *strv = es_pointer_get (strobj);
3325 const char *str = vStringValue (strv);
3326
3327 char * p = (fromTail? strrchr: strchr) (str, (int)chr);
3328 if (p)
3329 {
3330 int d = p - str;
3331 if (d < 0)
3332 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
3333 ptrArrayDeleteLast (vm->ostack);
3334 EsObject *dobj = es_integer_new (d);
3335 vm_ostack_push (vm, dobj);
3336 es_object_unref (dobj);
3337 vm_ostack_push (vm, es_true);
3338 return es_false;
3339 }
3340 else
3341 {
3342 ptrArrayDeleteLast (vm->ostack);
3343 vm_ostack_push (vm, es_false);
3344 return es_false;
3345 }
3346 }
3347
3348 static EsObject*
op__strchr(OptVM * vm,EsObject * name)3349 op__strchr (OptVM *vm, EsObject *name)
3350 {
3351 return op__strchr_common (vm, name, false);
3352 }
3353
3354 static EsObject*
op__strrchr(OptVM * vm,EsObject * name)3355 op__strrchr (OptVM *vm, EsObject *name)
3356 {
3357 return op__strchr_common (vm, name, true);
3358 }
3359
3360 static EsObject*
op__strpbrk(OptVM * vm,EsObject * name)3361 op__strpbrk (OptVM *vm, EsObject *name)
3362 {
3363 EsObject *acceptobj = ptrArrayLast (vm->ostack);
3364 EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1);
3365
3366 if (es_object_get_type (strobj) != OPT_TYPE_STRING)
3367 return OPT_ERR_TYPECHECK;
3368 if (es_object_get_type (acceptobj) != OPT_TYPE_STRING)
3369 return OPT_ERR_TYPECHECK;
3370
3371 vString *strv = es_pointer_get (strobj);
3372 vString *acceptv = es_pointer_get (acceptobj);
3373
3374 const char *str = vStringValue (strv);
3375 char *p = strpbrk (str, vStringValue (acceptv));
3376 if (p)
3377 {
3378 int d = p - str;
3379 if (d < 0)
3380 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
3381 ptrArrayDeleteLast (vm->ostack);
3382 EsObject *dobj = es_integer_new (d);
3383 vm_ostack_push (vm, dobj);
3384 es_object_unref (dobj);
3385 vm_ostack_push (vm, es_true);
3386 return es_false;
3387 }
3388 else
3389 {
3390 ptrArrayDeleteLast (vm->ostack);
3391 vm_ostack_push (vm, es_false);
3392 return es_false;
3393 }
3394 }
3395
3396
3397 /*
3398 * Relation, logical, and bit operators
3399 */
3400 static EsObject*
op__eq_full(OptVM * vm,EsObject * name,bool inversion)3401 op__eq_full (OptVM *vm, EsObject *name, bool inversion)
3402 {
3403 EsObject *a = ptrArrayItemFromLast (vm->ostack, 0);
3404 EsObject *b = ptrArrayItemFromLast (vm->ostack, 1);
3405
3406 bool eq = opt_es_eq (a, b);
3407 EsObject *r = (inversion? (!eq): eq)? es_true: es_false;
3408 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3409 vm_ostack_push (vm, r);
3410 return es_false;
3411 }
3412
3413
3414 /*
3415 * Relation, logical, and bit operators
3416 */
3417 static EsObject*
op_eq(OptVM * vm,EsObject * name)3418 op_eq (OptVM *vm, EsObject *name)
3419 {
3420 op__eq_full (vm, name, false);
3421 return es_false;
3422
3423 }
3424
3425 static EsObject*
op_ne(OptVM * vm,EsObject * name)3426 op_ne (OptVM *vm, EsObject *name)
3427 {
3428 op__eq_full (vm, name, true);
3429 return es_false;
3430
3431 }
3432
3433 static EsObject*
op_true(OptVM * vm,EsObject * name)3434 op_true (OptVM *vm, EsObject *name)
3435 {
3436 vm_ostack_push (vm, es_true);
3437 return es_false;
3438
3439 }
3440
3441 static EsObject*
op_false(OptVM * vm,EsObject * name)3442 op_false (OptVM *vm, EsObject *name)
3443 {
3444 vm_ostack_push (vm, es_false);
3445 return es_false;
3446 }
3447
3448 #define CMP_OP(OP) \
3449 EsObject *o0 = ptrArrayLast (vm->ostack); \
3450 EsObject *o1 = ptrArrayItemFromLast (vm->ostack, 1); \
3451 EsObject *r; \
3452 \
3453 if (es_integer_p (o0)) \
3454 { \
3455 if (!es_integer_p (o1)) \
3456 return OPT_ERR_TYPECHECK; \
3457 \
3458 int i0 = es_integer_get (o0); \
3459 int i1 = es_integer_get (o1); \
3460 r = es_boolean_new (i1 OP i0); \
3461 } \
3462 else if (es_object_get_type (o0) == OPT_TYPE_STRING) \
3463 { \
3464 if (es_object_get_type (o1) != OPT_TYPE_STRING) \
3465 return OPT_ERR_TYPECHECK; \
3466 vString *vs0 = es_pointer_get (o0); \
3467 vString *vs1 = es_pointer_get (o1); \
3468 const char *s0 = vStringValue (vs0); \
3469 const char *s1 = vStringValue (vs1); \
3470 int d = strcmp (s1, s0); \
3471 r = es_boolean_new (d OP 0); \
3472 } \
3473 else \
3474 return OPT_ERR_TYPECHECK; \
3475 ptrArrayDeleteLastInBatch (vm->ostack, 2); \
3476 vm_ostack_push (vm, r); \
3477 es_object_unref (r); \
3478 return es_false
3479
3480 static EsObject*
op_ge(OptVM * vm,EsObject * name)3481 op_ge (OptVM *vm, EsObject *name)
3482 {
3483 CMP_OP (>=);
3484 }
3485
3486 static EsObject*
op_gt(OptVM * vm,EsObject * name)3487 op_gt (OptVM *vm, EsObject *name)
3488 {
3489 CMP_OP (>);
3490 }
3491
3492 static EsObject*
op_le(OptVM * vm,EsObject * name)3493 op_le (OptVM *vm, EsObject *name)
3494 {
3495 CMP_OP (<=);
3496 }
3497
3498 static EsObject*
op_lt(OptVM * vm,EsObject * name)3499 op_lt (OptVM *vm, EsObject *name)
3500 {
3501 CMP_OP (<);
3502 }
3503
3504 #define LOGBIT_OP(LOGOP, BITOP) \
3505 EsObject *o0 = ptrArrayLast (vm->ostack); \
3506 EsObject *o1 = ptrArrayItemFromLast (vm->ostack, 1); \
3507 EsObject *r; \
3508 \
3509 if (es_boolean_p (o0)) \
3510 { \
3511 if (!es_boolean_p (o1)) \
3512 return OPT_ERR_TYPECHECK; \
3513 bool b0 = es_boolean_get (o0); \
3514 bool b1 = es_boolean_get (o1); \
3515 bool b = b0 LOGOP b1; \
3516 r = es_boolean_new (b); \
3517 } \
3518 else if (es_integer_p (o0)) \
3519 { \
3520 if (!es_integer_p (o1)) \
3521 return OPT_ERR_TYPECHECK; \
3522 int i0 = es_integer_get (o0); \
3523 int i1 = es_integer_get (o1); \
3524 int i = i0 BITOP i1; \
3525 r = es_integer_new (i); \
3526 } \
3527 else \
3528 return OPT_ERR_TYPECHECK; \
3529 \
3530 ptrArrayDeleteLastInBatch (vm->ostack, 2); \
3531 vm_ostack_push (vm, r); \
3532 es_object_unref (r); \
3533 return es_false;
3534
3535 static EsObject*
op_and(OptVM * vm,EsObject * name)3536 op_and (OptVM *vm, EsObject *name)
3537 {
3538 LOGBIT_OP (&&, &);
3539 }
3540
3541 static EsObject*
op_or(OptVM * vm,EsObject * name)3542 op_or (OptVM *vm, EsObject *name)
3543 {
3544 LOGBIT_OP (||, |);
3545 }
3546
3547 static EsObject*
op_xor(OptVM * vm,EsObject * name)3548 op_xor (OptVM *vm, EsObject *name)
3549 {
3550 LOGBIT_OP (!=, ^);
3551 }
3552
3553 static EsObject*
op_not(OptVM * vm,EsObject * name)3554 op_not (OptVM *vm, EsObject *name)
3555 {
3556 EsObject *o = ptrArrayLast (vm->ostack);
3557 EsObject *r;
3558
3559 if (es_boolean_p (o))
3560 r = es_boolean_new (!es_boolean_get (o));
3561 else if (es_integer_p (o))
3562 r = es_integer_new (~ es_integer_get (o));
3563 else
3564 return OPT_ERR_TYPECHECK;
3565
3566 ptrArrayDeleteLast (vm->ostack);
3567 vm_ostack_push (vm, r);
3568 es_object_unref (r);
3569 return es_false;
3570 }
3571
3572 static EsObject*
op_bitshift(OptVM * vm,EsObject * name)3573 op_bitshift (OptVM *vm, EsObject *name)
3574 {
3575 EsObject *shiftobj = ptrArrayLast (vm->ostack);
3576 if (!es_integer_p (shiftobj))
3577 return OPT_ERR_TYPECHECK;
3578
3579 EsObject *iobj = ptrArrayItemFromLast (vm->ostack, 1);
3580 if (!es_integer_p (iobj))
3581 return OPT_ERR_TYPECHECK;
3582
3583 int shift = es_integer_get (shiftobj);
3584 int i = es_integer_get (iobj);
3585
3586 EsObject *r;
3587 if (i == 0 || shift == 0)
3588 r = es_object_ref (iobj);
3589 else if (shift > 0)
3590 r = es_integer_new (i << shift);
3591 else
3592 r = es_integer_new (i >> -shift);
3593 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3594 vm_ostack_push (vm, r);
3595 es_object_unref (r);
3596
3597 return es_false;
3598 }
3599
3600
3601 /*
3602 * Operators for control flow
3603 */
3604 static EsObject*
op_exec(OptVM * vm,EsObject * name)3605 op_exec (OptVM *vm, EsObject *name)
3606 {
3607 EsObject *x = ptrArrayRemoveLast (vm->ostack);
3608
3609 EsObject *e;
3610 if (es_object_get_type (x) == OPT_TYPE_ARRAY
3611 && (((ArrayFat *)es_fatptr_get (x))->attr & ATTR_EXECUTABLE))
3612 e = vm_call_proc (vm, x);
3613 else
3614 e = vm_eval (vm, x);
3615
3616 es_object_unref (x);
3617 return e;
3618 }
3619
3620 static EsObject*
op_if(OptVM * vm,EsObject * name)3621 op_if (OptVM *vm, EsObject *name)
3622 {
3623 EsObject *proc = ptrArrayLast (vm->ostack);
3624 if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY)
3625 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
3626 return OPT_ERR_TYPECHECK;
3627
3628 EsObject *b = ptrArrayItemFromLast (vm->ostack, 1);
3629 if (!es_boolean_p (b))
3630 return OPT_ERR_TYPECHECK;
3631
3632 if (es_object_equal (b, es_false))
3633 {
3634 ptrArrayDeleteLast (vm->ostack);
3635 ptrArrayDeleteLast (vm->ostack);
3636 return es_false;
3637 }
3638
3639 es_object_ref (proc);
3640 ptrArrayDeleteLast (vm->ostack);
3641 ptrArrayDeleteLast (vm->ostack);
3642 EsObject *e = vm_call_proc (vm, proc);
3643 es_object_unref (proc);
3644
3645 return e;
3646 }
3647
3648 static EsObject*
op_ifelse(OptVM * vm,EsObject * name)3649 op_ifelse (OptVM *vm, EsObject *name)
3650 {
3651 EsObject *procf = ptrArrayLast (vm->ostack);
3652 if (!((es_object_get_type (procf) == OPT_TYPE_ARRAY)
3653 && (((ArrayFat *)es_fatptr_get (procf))->attr & ATTR_EXECUTABLE)))
3654 return OPT_ERR_TYPECHECK;
3655
3656 EsObject *proct = ptrArrayItemFromLast (vm->ostack, 1);
3657 if (!((es_object_get_type (proct) == OPT_TYPE_ARRAY)
3658 && (((ArrayFat *)es_fatptr_get (proct))->attr & ATTR_EXECUTABLE)))
3659 return OPT_ERR_TYPECHECK;
3660
3661 EsObject *b = ptrArrayItemFromLast (vm->ostack, 2);
3662 if (!es_boolean_p (b))
3663 return OPT_ERR_TYPECHECK;
3664
3665 EsObject *p = (es_object_equal (b, es_false))? procf: proct;
3666
3667 es_object_ref (p);
3668 ptrArrayDeleteLast (vm->ostack);
3669 ptrArrayDeleteLast (vm->ostack);
3670 ptrArrayDeleteLast (vm->ostack);
3671 EsObject *e = vm_call_proc (vm, p);
3672 es_object_unref (p);
3673
3674 return e;
3675 }
3676
3677 static EsObject*
op_loop(OptVM * vm,EsObject * name)3678 op_loop (OptVM *vm, EsObject *name)
3679 {
3680 EsObject *proc = ptrArrayLast (vm->ostack);
3681 if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY)
3682 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
3683 return OPT_ERR_TYPECHECK;
3684
3685 es_object_ref (proc);
3686 ptrArrayDeleteLast (vm->ostack);
3687
3688 EsObject *e;
3689 while (true)
3690 {
3691 e = vm_call_proc (vm, proc);
3692 if (es_object_equal (e, OPT_ERR_INVALIDEXIT))
3693 {
3694 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
3695 e = es_false;
3696 break;
3697 }
3698 else if (es_error_p (e))
3699 break;
3700 }
3701 es_object_unref (proc);
3702 return e;
3703 }
3704
3705 static EsObject*
op_exit(OptVM * vm,EsObject * name)3706 op_exit (OptVM *vm, EsObject *name)
3707 {
3708 return OPT_ERR_INVALIDEXIT;
3709 }
3710
3711 static EsObject*
op_repeat(OptVM * vm,EsObject * name)3712 op_repeat (OptVM *vm, EsObject *name)
3713 {
3714 EsObject *proc = ptrArrayLast (vm->ostack);
3715 if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY)
3716 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
3717 return OPT_ERR_TYPECHECK;
3718
3719 EsObject *nobj = ptrArrayItemFromLast (vm->ostack, 1);
3720 if (!es_integer_p (nobj))
3721 return OPT_ERR_TYPECHECK;
3722
3723 int n = es_integer_get (nobj);
3724 if (n < 0)
3725 return OPT_ERR_RANGECHECK;
3726
3727 es_object_ref (proc);
3728 ptrArrayDeleteLast (vm->ostack);
3729 ptrArrayDeleteLast (vm->ostack);
3730
3731 EsObject *e = es_false;;
3732 for (int i = 0; i < n; i++)
3733 {
3734 e = vm_call_proc (vm, proc);
3735 if (es_object_equal (e, OPT_ERR_INVALIDEXIT))
3736 {
3737 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
3738 e = es_false;
3739 break;
3740 }
3741 else if (es_error_p (e))
3742 break;
3743 }
3744 es_object_unref (proc);
3745 return e;
3746 }
3747
3748 static EsObject*
op_stop(OptVM * vm,EsObject * name)3749 op_stop (OptVM *vm, EsObject *name)
3750 {
3751 return OPT_ERR_STOPPED;
3752 }
3753
3754 static EsObject*
op_stopped(OptVM * vm,EsObject * name)3755 op_stopped (OptVM *vm, EsObject *name)
3756 {
3757 EsObject *e = op_exec (vm, name);
3758 vm_ostack_push (vm, es_error_p (e)? es_true: es_false);
3759 return es_false;
3760 }
3761
3762 static EsObject*
op_for(OptVM * vm,EsObject * name)3763 op_for (OptVM *vm, EsObject *name)
3764 {
3765 EsObject *proc = ptrArrayLast (vm->ostack);
3766 if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY)
3767 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
3768 return OPT_ERR_TYPECHECK;
3769
3770 EsObject *limitobj = ptrArrayItemFromLast (vm->ostack, 1);
3771 if (! es_integer_p (limitobj))
3772 return OPT_ERR_TYPECHECK;
3773 int limit = es_integer_get (limitobj);
3774
3775 EsObject *incrementobj = ptrArrayItemFromLast (vm->ostack, 2);
3776 if (! es_integer_p (incrementobj))
3777 return OPT_ERR_TYPECHECK;
3778 int increment = es_integer_get (incrementobj);
3779
3780 EsObject *initialobj = ptrArrayItemFromLast (vm->ostack, 3);
3781 if (! es_integer_p (initialobj))
3782 return OPT_ERR_TYPECHECK;
3783 int initial = es_integer_get (initialobj);
3784
3785 ptrArrayRemoveLast (vm->ostack);
3786 ptrArrayDeleteLastInBatch (vm->ostack, 3);
3787
3788 EsObject *r = es_false;
3789 for (int i = initial;
3790 (increment >= 0) ? (i <= limit) : (i >= limit);
3791 i += increment)
3792 {
3793 EsObject *iobj = es_integer_new (i);
3794 vm_ostack_push (vm, iobj);
3795 r = vm_call_proc (vm, proc);
3796 es_object_unref (iobj);
3797
3798 if (es_object_equal (r, OPT_ERR_INVALIDEXIT))
3799 {
3800 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
3801 r = es_false;
3802 break;
3803 }
3804 if (es_error_p (r))
3805 break;
3806 }
3807 es_object_unref (proc);
3808 return r;
3809 }
3810
3811
3812 /*
3813 * Operators for type, attribute and their conversion
3814 */
3815 static EsObject*
op_type(OptVM * vm,EsObject * name)3816 op_type (OptVM *vm, EsObject *name)
3817 {
3818 EsObject *o = ptrArrayRemoveLast (vm->ostack);
3819 const char *n;
3820
3821 if (o == es_nil)
3822 n = "nulltype";
3823 else if (es_boolean_p (o))
3824 n = "booleantype";
3825 else if (es_integer_p (o))
3826 n = "integertype";
3827 else
3828 {
3829 int t = es_object_get_type (o);
3830 n = es_type_get_name (t);
3831 }
3832
3833 EsObject *p = name_newS (n, ATTR_EXECUTABLE|ATTR_READABLE);
3834 vm_ostack_push (vm, p);
3835 es_object_unref (p);
3836 es_object_unref (o);
3837 return es_false;
3838 }
3839
3840 static EsObject*
op_cvn(OptVM * vm,EsObject * name)3841 op_cvn (OptVM *vm, EsObject *name)
3842 {
3843 EsObject *o = ptrArrayLast (vm->ostack);
3844 if (es_object_get_type (o) != OPT_TYPE_STRING)
3845 return OPT_ERR_TYPECHECK;
3846
3847 vString *vstr = es_pointer_get (o);
3848 const char *cstr = vStringValue (vstr);
3849 StringFat *sfat = es_fatptr_get (o);
3850 EsObject *n = name_newS (cstr, sfat->attr);
3851 ptrArrayDeleteLast (vm->ostack);
3852 vm_ostack_push (vm, n);
3853 es_object_unref (n);
3854 return es_false;
3855 }
3856
3857
3858 /*
3859 * Misc operators
3860 */
3861 static EsObject*
op_null(OptVM * vm,EsObject * name)3862 op_null (OptVM *vm, EsObject *name)
3863 {
3864 vm_ostack_push (vm, es_nil);
3865 return es_false;
3866 }
3867
3868 static EsObject*
op_bind(OptVM * vm,EsObject * name)3869 op_bind (OptVM *vm, EsObject *name)
3870 {
3871 EsObject *proc = ptrArrayLast (vm->ostack);
3872 if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY)
3873 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
3874 return OPT_ERR_TYPECHECK;
3875
3876 vm_bind_proc (vm, es_pointer_get (proc));
3877 return es_false;
3878 }
3879
3880
3881 /*
3882 * Methods for compound objects
3883 */
3884 static EsObject*
op_length(OptVM * vm,EsObject * name)3885 op_length (OptVM *vm, EsObject *name)
3886 {
3887 EsObject *o = ptrArrayLast (vm->ostack);
3888 unsigned int c;
3889
3890 int t = es_object_get_type (o);
3891 if (t == OPT_TYPE_ARRAY)
3892 {
3893 ptrArray *a = es_pointer_get (o);
3894 c = ptrArrayCount (a);
3895 }
3896 else if (t == OPT_TYPE_DICT)
3897 {
3898 hashTable *h = es_pointer_get (o);
3899 c = hashTableCountItem (h);
3900 }
3901 else if (t == OPT_TYPE_STRING)
3902 {
3903 vString *s = es_pointer_get (o);
3904 c = (unsigned int)vStringLength (s);
3905 }
3906 else if (t == OPT_TYPE_NAME)
3907 {
3908 EsObject *sym = es_pointer_get (o);
3909 const char* cstr = es_symbol_get (sym);
3910 c = (unsigned int) strlen (cstr);
3911 }
3912 else
3913 return OPT_ERR_TYPECHECK;
3914
3915 int n = c;
3916 if (n < 0)
3917 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
3918
3919 ptrArrayDeleteLast (vm->ostack);
3920 EsObject *nobj = es_integer_new (n);
3921 vm_ostack_push (vm, nobj);
3922 es_object_unref (nobj);
3923
3924 return es_false;
3925 }
3926
3927 static EsObject*
op__get_array(OptVM * vm,EsObject * name,EsObject * k,EsObject * obj)3928 op__get_array (OptVM *vm, EsObject *name,
3929 EsObject *k, EsObject *obj)
3930 {
3931 if (!es_integer_p (k))
3932 return OPT_ERR_TYPECHECK;
3933 int n = es_integer_get (k);
3934 if (n < 0)
3935 return OPT_ERR_RANGECHECK;
3936 EsObject *r = array_op_get (obj, (unsigned int)n);
3937 if (es_error_p (r))
3938 return r;
3939 es_object_ref (r);
3940 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3941 vm_ostack_push (vm, r);
3942 es_object_unref (r);
3943 return es_false;
3944 }
3945
3946 static EsObject*
op__get_dict(OptVM * vm,EsObject * name,EsObject * k,EsObject * obj)3947 op__get_dict (OptVM *vm, EsObject *name,
3948 EsObject *k, EsObject *obj)
3949 {
3950 EsObject *v = NULL;
3951 if (!dict_op_known_and_get (obj, k, &v))
3952 return es_error_set_object (OPT_ERR_UNDEFINED, k);
3953 es_object_ref (v);
3954 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3955 vm_ostack_push (vm, v);
3956 es_object_unref (v);
3957 return es_false;
3958 }
3959
3960 static EsObject*
op__get_str(OptVM * vm,EsObject * name,EsObject * k,EsObject * obj)3961 op__get_str (OptVM *vm, EsObject *name,
3962 EsObject *k, EsObject *obj)
3963 {
3964 if (!es_integer_p (k))
3965 return OPT_ERR_TYPECHECK;
3966 int n = es_integer_get (k);
3967 if (n < 0)
3968 return OPT_ERR_RANGECHECK;
3969 vString *s = es_pointer_get (obj);
3970 unsigned int len = vStringLength (s);
3971 if ((unsigned int)n >= len)
3972 return OPT_ERR_RANGECHECK;
3973 unsigned char chr = vStringChar (s, n);
3974 ptrArrayDeleteLastInBatch (vm->ostack, 2);
3975 EsObject *chrobj = es_integer_new (chr);
3976 vm_ostack_push (vm, chrobj);
3977 es_object_unref (chrobj);
3978 return es_false;
3979 }
3980
3981 static EsObject*
op_get(OptVM * vm,EsObject * name)3982 op_get (OptVM *vm, EsObject *name)
3983 {
3984 EsObject *k = ptrArrayLast (vm->ostack);
3985 EsObject *obj = ptrArrayItemFromLast (vm->ostack, 1);
3986
3987 int t = es_object_get_type (obj);
3988 if (t == OPT_TYPE_ARRAY)
3989 return op__get_array (vm, name, k, obj);
3990 else if (t == OPT_TYPE_DICT)
3991 return op__get_dict (vm, name, k, obj);
3992 else if (t == OPT_TYPE_STRING)
3993 return op__get_str (vm, name, k, obj);
3994
3995 return OPT_ERR_TYPECHECK;
3996 }
3997
3998 static EsObject*
op__put_array(OptVM * vm,EsObject * name,EsObject * v,EsObject * k,EsObject * array)3999 op__put_array (OptVM *vm, EsObject *name,
4000 EsObject *v, EsObject *k, EsObject *array)
4001 {
4002 if (!es_integer_p (k))
4003 return OPT_ERR_TYPECHECK;
4004 int index = es_integer_get (k);
4005 if (index < 0)
4006 return OPT_ERR_RANGECHECK;
4007
4008 array_op_put (array, (unsigned int)index, v);
4009 ptrArrayDeleteLastInBatch (vm->ostack, 3);
4010 return es_false;
4011 }
4012
4013 static EsObject*
op__put_dict(OptVM * vm,EsObject * name,EsObject * v,EsObject * k,EsObject * dict)4014 op__put_dict (OptVM *vm, EsObject *name,
4015 EsObject *v, EsObject *k, EsObject *dict)
4016 {
4017 EsObject *key = k;
4018
4019 if (es_null (key))
4020 return OPT_ERR_TYPECHECK;
4021
4022 if (es_object_get_type (key) == OPT_TYPE_STRING)
4023 {
4024 const char *cstr = opt_string_get_cstr (key);
4025 key = opt_name_new_from_cstr (cstr);
4026 }
4027
4028 if (es_object_get_type (key) != OPT_TYPE_NAME
4029 && !es_integer_p (key) && !es_boolean_p (key))
4030 return OPT_ERR_TYPECHECK;
4031
4032 dict_op_def (dict, key, v);
4033 if (key != k)
4034 es_object_unref (key);
4035 ptrArrayDeleteLastInBatch (vm->ostack, 3);
4036 return es_false;
4037 }
4038
4039 static EsObject*
op__put_str(OptVM * vm,EsObject * name,EsObject * v,EsObject * k,EsObject * str)4040 op__put_str (OptVM *vm, EsObject *name,
4041 EsObject *v, EsObject *k, EsObject *str)
4042 {
4043 if (!es_integer_p (v))
4044 return OPT_ERR_TYPECHECK;
4045 int c = es_integer_get (v);
4046 if (!(c >= 0 && c < 256))
4047 return OPT_ERR_RANGECHECK;
4048 if (!es_integer_p (k))
4049 return OPT_ERR_TYPECHECK;
4050 int index = es_integer_get (k);
4051 if (index < 0)
4052 return OPT_ERR_RANGECHECK;
4053
4054 vString *vstr = es_pointer_get (str);
4055 size_t len = vStringLength (vstr);
4056 if (len > (size_t)index)
4057 {
4058 if (c == 0)
4059 vStringTruncate (vstr, (size_t)index);
4060 else
4061 vStringChar(vstr, index) = (char)c;
4062 }
4063 else
4064 {
4065 size_t d = index - len;
4066 for (size_t i = 0; i < d; i++)
4067 vStringPut (vstr, ' ');
4068 if (c != 0)
4069 vStringPut (vstr, (char)c);
4070 }
4071
4072 ptrArrayDeleteLastInBatch (vm->ostack, 3);
4073 return es_false;
4074 }
4075
4076 static EsObject*
op_put(OptVM * vm,EsObject * name)4077 op_put (OptVM *vm, EsObject *name)
4078 {
4079 EsObject *v = ptrArrayLast (vm->ostack);
4080 EsObject *k = ptrArrayItemFromLast (vm->ostack, 1);
4081 EsObject *obj = ptrArrayItemFromLast (vm->ostack, 2);
4082
4083 int t = es_object_get_type (obj);
4084 if (t == OPT_TYPE_ARRAY)
4085 return op__put_array (vm, name, v, k, obj);
4086 else if (t == OPT_TYPE_DICT)
4087 return op__put_dict (vm, name, v, k, obj);
4088 else if (t == OPT_TYPE_STRING)
4089 return op__put_str (vm, name, v, k, obj);
4090
4091 return OPT_ERR_TYPECHECK;
4092 }
4093
4094 static EsObject*
op__forall_array(OptVM * vm,EsObject * name,EsObject * proc,EsObject * obj)4095 op__forall_array (OptVM *vm, EsObject *name,
4096 EsObject *proc, EsObject *obj)
4097 {
4098 ptrArray *a = es_pointer_get (obj);
4099 unsigned int c = ptrArrayCount (a);
4100 if (((int)c) < 0)
4101 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
4102
4103 EsObject *e = es_false;
4104 for (int i = 0; i < c; i++)
4105 {
4106 EsObject *o = ptrArrayItem (a, i);
4107 es_object_ref (o);
4108 vm_ostack_push (vm, o);
4109 e = vm_call_proc (vm, proc);
4110 es_object_unref (o);
4111 if (es_error_p (e))
4112 break;
4113 }
4114
4115 return e;
4116 }
4117
4118 struct dictForallData {
4119 OptVM *vm;
4120 EsObject *proc;
4121 EsObject *err;
4122 };
4123
4124 static bool
dict_forall_cb(const void * key,void * value,void * user_data)4125 dict_forall_cb (const void *key, void *value, void *user_data)
4126 {
4127 bool r = true;
4128 EsObject *k = (EsObject *)key;
4129 EsObject *v = value;
4130 struct dictForallData *d = user_data;
4131
4132 /* TODO */
4133 if (es_symbol_p (k))
4134 k = name_new (k, ATTR_READABLE);
4135 else
4136 es_object_ref ((EsObject *)k);
4137 es_object_ref (v);
4138
4139 vm_ostack_push (d->vm, (EsObject *)k);
4140 vm_ostack_push (d->vm, v);
4141 EsObject *e = vm_call_proc (d->vm, d->proc);
4142 if (es_error_p (e))
4143 {
4144 d->err = e;
4145 r = false;
4146 }
4147 es_object_unref ((EsObject *)k);
4148 es_object_unref (v);
4149
4150 return r;
4151 }
4152
4153 static EsObject*
op__forall_dict(OptVM * vm,EsObject * name,EsObject * proc,EsObject * obj)4154 op__forall_dict (OptVM *vm, EsObject *name,
4155 EsObject *proc, EsObject *obj)
4156 {
4157 EsObject *r = es_false;;
4158 hashTable *ht = es_pointer_get (obj);
4159 struct dictForallData data = {
4160 .vm = vm,
4161 .proc = proc
4162 };
4163
4164 if (!hashTableForeachItem (ht, dict_forall_cb, &data))
4165 r = data.err;
4166
4167 return r;
4168 }
4169
4170 static EsObject*
op__forall_string(OptVM * vm,EsObject * name,EsObject * proc,EsObject * obj)4171 op__forall_string (OptVM *vm, EsObject *name,
4172 EsObject *proc, EsObject *obj)
4173 {
4174 vString *s = es_pointer_get (obj);
4175 unsigned int c = vStringLength (s);
4176 if (((int)c) < 0)
4177 return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */
4178
4179 EsObject *e = es_false;
4180 for (int i = 0; i < c; i++)
4181 {
4182 unsigned char chr = vStringChar (s, i);
4183 EsObject *o = es_integer_new (chr);
4184 vm_ostack_push (vm, o);
4185 es_object_unref (o);
4186 e = vm_call_proc (vm, proc);
4187 if (es_error_p (e))
4188 break;
4189 }
4190
4191 return e;
4192 }
4193
4194 static EsObject*
op_forall(OptVM * vm,EsObject * name)4195 op_forall (OptVM *vm, EsObject *name)
4196 {
4197 EsObject *proc = ptrArrayLast (vm->ostack);
4198 if (!(es_object_get_type (proc) == OPT_TYPE_ARRAY
4199 && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE)))
4200 return OPT_ERR_TYPECHECK;
4201
4202 EsObject *obj = ptrArrayItemFromLast (vm->ostack, 1);
4203
4204 int t = es_object_get_type (obj);
4205 EsObject * (* proc_driver) (OptVM *, EsObject *,
4206 EsObject *, EsObject *) = NULL;
4207 if (t == OPT_TYPE_ARRAY)
4208 proc_driver = op__forall_array;
4209 else if (t == OPT_TYPE_DICT)
4210 proc_driver = op__forall_dict;
4211 else if (t == OPT_TYPE_STRING)
4212 proc_driver = op__forall_string;
4213 else
4214 return OPT_ERR_TYPECHECK;
4215
4216 ptrArrayRemoveLast (vm->ostack);
4217 ptrArrayRemoveLast (vm->ostack);
4218 EsObject *e = (*proc_driver) (vm, name, proc, obj);
4219 es_object_unref (proc);
4220 es_object_unref (obj);
4221
4222 if (es_object_equal (e, OPT_ERR_INVALIDEXIT))
4223 {
4224 dict_op_def (vm->error, OPT_KEY_newerror, es_false);
4225 e = es_false;
4226 }
4227 return e;
4228 }
4229
4230 static EsObject*
op__putinterval_array(OptVM * vm,EsObject * name,ptrArray * srca,int index,ptrArray * dsta)4231 op__putinterval_array (OptVM *vm, EsObject *name,
4232 ptrArray *srca, int index, ptrArray *dsta)
4233 {
4234 unsigned int dlen = ptrArrayCount (dsta);
4235 unsigned int slen = ptrArrayCount (srca);
4236 if (dlen > index)
4237 {
4238 if ((dlen - index) <= slen)
4239 {
4240 ptrArrayDeleteLastInBatch (dsta, dlen - index);
4241 for (unsigned int i = 0; i < slen; i++)
4242 ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i)));
4243 return es_false;
4244 }
4245 else
4246 {
4247 for (size_t i = 0; i < slen; i++)
4248 ptrArrayUpdate (dsta, ((size_t)index) + i,
4249 es_object_ref (ptrArrayItem (srca, i)),
4250 es_nil);
4251 return es_false;
4252 }
4253 }
4254 else if (dlen == index)
4255 {
4256 for (unsigned int i = 0; i < slen; i++)
4257 ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i)));
4258 return es_false;
4259 }
4260 else
4261 return OPT_ERR_RANGECHECK;
4262 }
4263
4264 static EsObject*
op__putinterval_string(OptVM * vm,EsObject * name,vString * srcv,int index,vString * dstv)4265 op__putinterval_string (OptVM *vm, EsObject *name,
4266 vString *srcv, int index, vString *dstv)
4267 {
4268 size_t dlen = vStringLength (dstv);
4269 if (dlen > index)
4270 {
4271 size_t slen = vStringLength (srcv);
4272 if ((dlen - index) <= slen)
4273 {
4274 vStringTruncate (dstv, (size_t)index);
4275 vStringCat (dstv, srcv);
4276 return es_false;
4277 }
4278 else
4279 {
4280 for (size_t i = 0; i < slen; i++)
4281 vStringChar (dstv, index + i) = vStringChar (srcv, i);
4282 return es_false;
4283 }
4284 }
4285 else if (dlen == index)
4286 {
4287 vStringCat (dstv, srcv);
4288 return es_false;
4289 }
4290 else
4291 return OPT_ERR_RANGECHECK;
4292 }
4293
4294 static EsObject*
op_putinterval(OptVM * vm,EsObject * name)4295 op_putinterval (OptVM *vm, EsObject *name)
4296 {
4297 EsObject *src = ptrArrayLast (vm->ostack);
4298 EsObject *indexobj = ptrArrayItemFromLast (vm->ostack, 1);
4299 EsObject *dst = ptrArrayItemFromLast (vm->ostack, 2);
4300
4301 int t = es_object_get_type (src);
4302 if (t == OPT_TYPE_ARRAY || t == OPT_TYPE_STRING)
4303 {
4304 if (!es_integer_p (indexobj))
4305 return OPT_ERR_TYPECHECK;
4306 if (es_object_get_type (dst) != t)
4307 return OPT_ERR_TYPECHECK;
4308 }
4309 else
4310 return OPT_ERR_TYPECHECK;
4311
4312 int index = es_integer_get (indexobj);
4313 if (index < 0)
4314 return OPT_ERR_RANGECHECK;
4315
4316 EsObject *r;
4317 if (t == OPT_TYPE_ARRAY)
4318 r = op__putinterval_array (vm, name,
4319 es_pointer_get (src),
4320 index,
4321 es_pointer_get (dst));
4322 else
4323 r = op__putinterval_string (vm, name,
4324 es_pointer_get (src),
4325 index,
4326 es_pointer_get (dst));
4327
4328 if (!es_error_p (r))
4329 ptrArrayDeleteLastInBatch (vm->ostack, 3);
4330
4331 return r;
4332 }
4333
4334 static EsObject*
op__copyinterval_array(OptVM * vm,EsObject * name,ptrArray * dsta,int count,int index,ptrArray * srca)4335 op__copyinterval_array (OptVM *vm, EsObject *name,
4336 ptrArray *dsta,
4337 int count,
4338 int index,
4339 ptrArray *srca)
4340 {
4341 unsigned long srcl = ptrArrayCount (srca);
4342
4343 if ((unsigned long)index > srcl)
4344 return OPT_ERR_RANGECHECK;
4345
4346 if ((unsigned long)(index + count) > srcl)
4347 return OPT_ERR_RANGECHECK;
4348
4349 for (unsigned int i = (unsigned int)index; i < index + count; i++)
4350 ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i)));
4351 return es_false;
4352 }
4353
4354 static EsObject*
op__copyinterval_string(OptVM * vm,EsObject * name,vString * dsts,int count,int index,vString * srcs)4355 op__copyinterval_string (OptVM *vm, EsObject *name,
4356 vString *dsts,
4357 int count,
4358 int index,
4359 vString *srcs)
4360 {
4361 size_t srcl = vStringLength (srcs);
4362
4363 if ((size_t)index > srcl)
4364 return OPT_ERR_RANGECHECK;
4365
4366 if ((size_t)(index + count) > srcl)
4367 return OPT_ERR_RANGECHECK;
4368
4369 vStringNCatSUnsafe (dsts, vStringValue (srcs) + index, (size_t)count);
4370 return es_false;
4371 }
4372
4373 static EsObject*
op__copyinterval(OptVM * vm,EsObject * name)4374 op__copyinterval (OptVM *vm, EsObject *name)
4375 {
4376 EsObject *dstobj = ptrArrayLast (vm->ostack);
4377 EsObject *countobj = ptrArrayItemFromLast (vm->ostack, 1);
4378 EsObject *indexobj = ptrArrayItemFromLast (vm->ostack, 2);
4379 EsObject *srcobj = ptrArrayItemFromLast (vm->ostack, 3);
4380
4381 int t = es_object_get_type (dstobj);
4382 if (! (t == OPT_TYPE_ARRAY || t == OPT_TYPE_STRING))
4383 return OPT_ERR_TYPECHECK;
4384 if (t != es_object_get_type (srcobj))
4385 return OPT_ERR_TYPECHECK;
4386
4387 if (!es_integer_p (countobj))
4388 return OPT_ERR_TYPECHECK;
4389 if (!es_integer_p (indexobj))
4390 return OPT_ERR_TYPECHECK;
4391
4392 int count = es_integer_get (countobj);
4393 if (count < 0)
4394 return OPT_ERR_RANGECHECK;
4395
4396 int index = es_integer_get (indexobj);
4397 if (index < 0)
4398 return OPT_ERR_RANGECHECK;
4399
4400 EsObject* r;
4401 if (t == OPT_TYPE_ARRAY)
4402 r = op__copyinterval_array (vm, name,
4403 es_pointer_get (dstobj),
4404 count,
4405 index,
4406 es_pointer_get (srcobj));
4407 else
4408 r = op__copyinterval_string (vm, name,
4409 es_pointer_get (dstobj),
4410 count,
4411 index,
4412 es_pointer_get (srcobj));
4413
4414 if (es_error_p (r))
4415 return r;
4416
4417 es_object_ref (dstobj);
4418 ptrArrayDeleteLastInBatch (vm->ostack, 4);
4419 vm_ostack_push (vm, dstobj);
4420 es_object_unref (dstobj);
4421 return r;
4422 }
4423