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