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