// 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 /* * Copyright (c) 2020, Masatake YAMATO * Copyright (c) 2020, Red Hat, Inc. * * This source code is released for free distribution under the terms of the * GNU General Public License version 2 or (at your option) any later version. */ #include "general.h" #include "debug.h" #include "es.h" #include "htable.h" #include "optscript.h" #include "ptrarray.h" #include "routines.h" #include "vstring.h" #include #include struct sOptVM { ptrArray *ostack; ptrArray *dstack; ptrArray *estack; int dstack_protection; MIO *in; MIO *out; MIO *err; EsObject *error; int print_depth; int read_depth; char *prompt; void *app_data; }; typedef struct sOperatorFat { EsObject *name; int arity; const char *help_str; } OperatorFat; typedef struct sOperatorExtra { const char *name; int arity; const char *help_str; } OperatorExtra; typedef OptOperatorFn Operator; typedef enum eAttr { ATTR_READABLE = 1 << 0, ATTR_WRITABLE = 1 << 1, ATTR_EXECUTABLE = 1 << 2, } Attr; typedef struct sDictFat { unsigned int attr; } DictFat; typedef struct sArrayFat { unsigned int attr; } ArrayFat; typedef struct sStringFat { unsigned int attr; } StringFat; typedef struct sNameFat { unsigned int attr; } NameFat; static EsObject* opt_system_dict; int OPT_TYPE_ARRAY; int OPT_TYPE_DICT; int OPT_TYPE_OPERATOR; int OPT_TYPE_STRING; int OPT_TYPE_NAME; int OPT_TYPE_MARK; static EsObject *OPT_ERR_UNDEFINED; static EsObject *OPT_ERR_SYNTAX; EsObject *OPT_ERR_UNDERFLOW; EsObject *OPT_ERR_TYPECHECK; EsObject *OPT_ERR_RANGECHECK; static EsObject *OPT_ERR_DICTSTACKUNDERFLOW; static EsObject *OPT_ERR_UNMATCHEDMARK; static EsObject *OPT_ERR_INTERNALERROR; static EsObject *OPT_ERR_END_PROC; static EsObject *OPT_ERR_INVALIDEXIT; static EsObject *OPT_ERR_STOPPED; EsObject *OPT_ERR_QUIT; static EsObject *OPT_ERR_INVALIDACCESS; static EsObject *OPT_ERR_INTOVERFLOW; static EsObject* OPT_MARK_ARRAY; static EsObject* OPT_MARK_DICT; static EsObject* OPT_MARK_MARK; static EsObject* OPT_KEY_newerror; static EsObject* OPT_KEY_errorname; static EsObject* OPT_KEY_command; static EsObject* OPT_KEY_ostack; static EsObject* OPT_KEY_estack; static EsObject* OPT_KEY_dstack; /* Naming conversions * * Opt|OPT * ===================================================================== * exported as part of the library API * * optscript and ctags may refer these names. * * * _... * ===================================================================== * functions released to PS datatypes * PS datatypes are array, dict, operator, ... * * _es_... * --------------------------------------------------------------------- * functions for representing the PS datatype object as EsObject object * * _op_... * --------------------------------------------------------------------- * functions for accessing the datatype object from vm internal purpose * * * op_... * ===================================================================== * functions implementing operators * * * vm_... * ===================================================================== * the rest VM related functions * */ static EsObject* array_new (unsigned int attr); static EsObject* array_es_init_fat (void *fat, void *ptr, void *extra); static void array_es_free (void *ptr, void *fat); static int array_es_equal (const void *a, const void *afat, const void *b, const void *bfat); static void array_es_print (const void *ptr, const void *fat, MIO *out); static void array_op_add (EsObject* array, EsObject* elt); static unsigned int array_op_length (const EsObject* array); static EsObject* array_op_get (const EsObject* array, unsigned int n); static void array_op_put (EsObject* array, unsigned int n, EsObject *obj); static EsObject* dict_new (unsigned int size, unsigned int attr); static EsObject* dict_es_init_fat (void *fat, void *ptr, void *extra); static void dict_es_free (void *ptr, void *fat); static int dict_es_equal (const void *a, const void *afat, const void *b, const void *bfat); static void dict_es_print (const void *ptr, const void *fat, MIO *out); static void dict_op_def (EsObject* dict, EsObject *key, EsObject *val); static bool dict_op_undef (EsObject* dict, EsObject *key); static bool dict_op_known_and_get (EsObject* dict, EsObject *key, EsObject **val); static void dict_op_clear (EsObject* dict); static EsObject* operator_new (Operator op, const char *name, int arity, const char *help_str); static EsObject* operator_es_init_fat (void *fat, void *ptr, void *extra); static void operator_es_print (const void *ptr, const void *fat, MIO *out); static void operator_es_free (void *ptr, void *fat); static EsObject* string_new (vString *vstr); static EsObject* string_es_init_fat (void *fat, void *ptr, void *extra); static void string_es_free (void *ptr, void *fat); static int string_es_equal (const void *a, const void *afat, const void *b, const void *bfat); static void string_es_print (const void *ptr, const void *fat, MIO *out); static EsObject* name_new (EsObject* symbol, unsigned int attr); static EsObject* name_newS (const char*s, unsigned int attr); static EsObject* name_newS_cb (const char*s, void *attr); static EsObject* name_es_init_fat (void *fat, void *ptr, void *extra); static void name_es_print (const void *ptr, const void *fat, MIO *out); static void name_es_free (void *ptr, void *fat); static int name_es_equal (const void *a, const void *afat, const void *b, const void *bfat); static EsObject* mark_new (const char* mark); static void mark_es_print (const void *ptr, MIO *out); static void mark_es_free (void *ptr); static int mark_es_equal (const void *a, const void *b); static EsObject* vm_read (OptVM *vm); static EsObject* vm_call_operator (OptVM *vm, EsObject *op); static EsObject* vm_call_proc (OptVM *vm, EsObject *proc); static void vm_print (OptVM *vm, EsObject *o); static void vm_print_full (OptVM *vm, EsObject *o, bool string_as_is, int dict_recursion); static void vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data); static void vm_record_stop (OptVM *vm, EsObject *cmd); static void vm_record_error (OptVM *vm, EsObject *e, EsObject *cmd); static void vm_report_error (OptVM *vm, EsObject *e); static void vm_bind_proc (OptVM *vm, ptrArray *proc); static void vm_ostack_push (OptVM *vm, EsObject *o); static EsObject* vm_ostack_pop (OptVM *vm); static unsigned int vm_ostack_count (OptVM *vm); static EsObject* vm_ostack_top (OptVM *vm); static EsObject* vm_ostack_peek (OptVM *vm, int index_from_top); static int vm_ostack_counttomark (OptVM *vm); static void vm_dict_def (OptVM *vm, EsObject *key, EsObject *val); /* Returns the dictionary where the value for the key is found. * val can be NULL. */ static EsObject* vm_dstack_known_and_get (OptVM *vm, EsObject *key, EsObject **val); static void vm_dstack_push (OptVM *vm, EsObject *o); /* FIXME: return type */ static int vm_dstack_count (OptVM *vm); static EsObject* vm_dstack_pop (OptVM *vm); static void vm_dstack_clear (OptVM *vm); static EsObject* vm_estack_push (OptVM *vm, EsObject *p); static EsObject* vm_estack_pop (OptVM *vm); #define declop(OP) \ static EsObject* op_##OP(OptVM *vm, EsObject *name) #define defOP(DICT, FN, NAME, ARITY, HELP) \ dict_op_def (DICT, \ es_object_autounref(es_symbol_intern (NAME)), \ es_object_autounref(operator_new (FN, NAME, ARITY, HELP))) #define defop(DICT, NAME, ARITY, HELP) \ defOP (DICT, op_##NAME, #NAME, ARITY, HELP) static EsObject* op__print_objdict_rec (OptVM *vm, EsObject *name); static EsObject* op__print_objdict (OptVM *vm, EsObject *name); static EsObject* op__print_object (OptVM *vm, EsObject *name); static EsObject* op__print (OptVM *vm, EsObject *name); static EsObject* op__make_array (OptVM *vm, EsObject *name); static EsObject* op__make_dict (OptVM *vm, EsObject *name); /* non-standard operator */ declop(_help); /* tested in pstack.ps */ declop(pstack); /* error related non-standard operators */ declop(_newerror); declop(_errorname); /* Operators for operand stack manipulation * tested in stack.ps */ declop(pop); declop(exch); declop(dup); declop(index); declop(roll); declop(clear); declop(count); declop(mark); declop(cleartomark); declop(counttomark); /* Arithmetic Operators tested in arithmetic.ps */ declop(add); declop(idiv); declop(mod); declop(mul); declop(sub); declop(abs); declop(neg); /* Operators for array manipulation tested in array.ps */ declop(array); declop(astore); declop(aload); /* Operators for dictionary manipulation * tested in dict.ps */ declop(dict); declop(begin); declop(end); declop(def); declop(load); declop(undef); declop(known); declop(where); declop(currentdict); declop(countdictstack); declop(store); declop(dictstack); declop(cleardictstack); /* Operators for string manipulation tested in string.ps */ /* -anchorsearch, -search, -token */ declop(string); declop(_strstr); declop(_strrstr); declop(_strchr); declop(_strrchr); declop(_strpbrk); /* Relation, logical, and bit operators tested in relalogbit.ps */ declop(eq); declop(ne); declop(true); declop(false); declop(and); declop(or); declop(xor); declop(not); declop(bitshift); declop(ge); declop(gt); declop(le); declop(lt); /* Operators for control flow * tested in control.ps */ declop(exec); declop(if); declop(ifelse); declop(repeat); declop(loop); declop(exit); declop(stop); declop(stopped); declop(for); declop(quit); declop(countexecstack); declop(execstack); /* ?start */ /* Operators for type, attribute and their conversion * tested in typeattrconv.ps */ declop(type); declop(cvn); declop(cvs); /* cvlit, cvx, xcheck, executeonly, noacess, readonly, rcheck, wcheck, cvi, cvr, cvrs, cvs,... */ /* Operators for Virtual Memory Operators */ /* ?save, ?restore */ /* Misc operators * tested in misc.ps */ declop(null); declop(bind); /* Methods for compound objects tested in compound.ps */ declop(length); declop(copy); declop(get); declop(put); declop(forall); declop(putinterval); declop(_copyinterval); /* -getinterval .... */ /* * Public functions */ int opt_init (void) { OPT_TYPE_ARRAY = es_type_define_fatptr ("arraytype", sizeof (ArrayFat), array_es_init_fat, array_es_free, array_es_equal, array_es_print); OPT_TYPE_DICT = es_type_define_fatptr ("dicttype", sizeof (DictFat), dict_es_init_fat, dict_es_free, dict_es_equal, dict_es_print); OPT_TYPE_OPERATOR = es_type_define_fatptr ("operatortype", sizeof (OperatorFat), operator_es_init_fat, operator_es_free, NULL, operator_es_print); OPT_TYPE_STRING = es_type_define_fatptr ("stringtype", sizeof (StringFat), string_es_init_fat, string_es_free, string_es_equal, string_es_print); OPT_TYPE_NAME = es_type_define_fatptr ("nametype", sizeof (NameFat), name_es_init_fat, name_es_free, name_es_equal, name_es_print); OPT_TYPE_MARK = es_type_define_pointer ("marktype", mark_es_free, mark_es_equal, mark_es_print); OPT_ERR_UNDEFINED = es_error_intern ("undefined"); OPT_ERR_SYNTAX = es_error_intern ("syntaxerror"); OPT_ERR_UNDERFLOW = es_error_intern ("stackunderflow"); OPT_ERR_TYPECHECK = es_error_intern ("typecheck"); OPT_ERR_RANGECHECK = es_error_intern ("rangecheck"); OPT_ERR_DICTSTACKUNDERFLOW = es_error_intern ("dictstackunderflow"); OPT_ERR_UNMATCHEDMARK = es_error_intern ("unmatchedmark"); OPT_ERR_INTERNALERROR = es_error_intern ("internalerror"); OPT_ERR_END_PROC = es_error_intern ("}"); OPT_ERR_INVALIDEXIT = es_error_intern ("invalidexit"); OPT_ERR_STOPPED = es_error_intern ("stopped"); OPT_ERR_QUIT = es_error_intern ("quit"); OPT_ERR_INVALIDACCESS = es_error_intern ("invalidaccess"); OPT_ERR_INTOVERFLOW = es_error_intern ("intoverflow"); es_symbol_intern ("true"); es_symbol_intern ("false"); es_symbol_intern ("null"); OPT_MARK_ARRAY = mark_new ("["); OPT_MARK_DICT = mark_new ("<<"); OPT_MARK_MARK = mark_new ("mark"); opt_system_dict = dict_new (101, ATTR_READABLE); es_autounref_pool_push (); defOP (opt_system_dict, op__print_objdict_rec,"====", 1, "any === -"); defOP (opt_system_dict, op__print_objdict, "===", 1, "any === -"); defOP (opt_system_dict, op__print_object, "==", 1, "any == -"); defOP (opt_system_dict, op__print, "=", 1, "any == -"); defOP (opt_system_dict, op_mark, "<<", 0, "- << mark"); defOP (opt_system_dict, op_mark, "[", 0, "- [ mark"); defOP (opt_system_dict, op__make_array, "]", 1, "[ any1 ... anyn ] array"); defOP (opt_system_dict, op__make_dict , ">>", 1, "<< key1 value1 ... keyn valuen >> dict"); defop (opt_system_dict, _help, 0, "- _HELP -"); defop (opt_system_dict, pstack, 0, "|- any1 ... anyn PSTACK |- any1 ... anyn"); defop (opt_system_dict, _newerror, 0, "- _NEWERROR bool"); defop (opt_system_dict, _errorname, 0, "- _ERRORNAME error:name|null"); defop (opt_system_dict, pop, 1, "any POP -"); defop (opt_system_dict, exch, 2, "any1 any2 EXCH any2 any1"); defop (opt_system_dict, dup, 1, "any DUP any any"); defop (opt_system_dict, index, 1, "anyn ... any0 n INDEX anyn ... any0 anyn"); 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"); defop (opt_system_dict, clear, 0, "|- any1 ... anyn CLEAR |-"); defop (opt_system_dict, count, 0, "|- any1 ... anyn COUNT any1 ... anyn n"); defop (opt_system_dict, mark, 0, "- MARK mark"); defop (opt_system_dict, cleartomark, 1, "mark any1 ... anyn CLEARTOMARK -"); defop (opt_system_dict, counttomark, 1, "mark any1 ... anyn COUNTTOMARK mark any1 ... anyn n"); defop (opt_system_dict, add, 2, "int1 int2 ADD int"); defop (opt_system_dict, idiv, 2, "int1 int2 IDIV int"); defop (opt_system_dict, mod, 2, "int1 int1 MOD int"); defop (opt_system_dict, mul, 2, "int1 int2 MUL int"); defop (opt_system_dict, sub, 2, "int1 int2 SUB int"); defop (opt_system_dict, abs, 1, "int1 ABS int2"); defop (opt_system_dict, neg, 1, "int1 NEG int2"); defop (opt_system_dict, array, 1, "int ARRAY array"); defop (opt_system_dict, astore, 1, "any0 ... any_n_1 array ASTORE array"); defop (opt_system_dict, aload, 1, "array ALOAD any0 ... any_n-1 array"); defop (opt_system_dict, eq, 2, "any1 any2 EQ bool"); defop (opt_system_dict, ne, 2, "any1 any2 NE bool"); defop (opt_system_dict, true, 0, "- TRUE true"); defop (opt_system_dict, false, 0, "- FALSE false"); defop (opt_system_dict, ge, 2, "int1 int2 GE bool%" "string1 string2 GE bool"); defop (opt_system_dict, gt, 2, "int1 int2 GT bool%" "string1 string2 GT bool"); defop (opt_system_dict, le, 2, "int1 int2 LE bool%" "string1 string2 LE bool"); defop (opt_system_dict, lt, 2, "int1 int2 LT bool%" "string1 string2 LT bool"); defop (opt_system_dict, and, 2, "bool1 bool2 AND bool3%" "int1 int2 AND int3"); defop (opt_system_dict, or, 2, "bool1 bool2 OR bool3%" "int1 int2 OR int3"); defop (opt_system_dict, xor, 2, "bool1 bool2 XOR bool3%" "int1 int2 XOR int3"); defop (opt_system_dict, not, 1, "bool1|int1 NOT bool2|int2"); defop (opt_system_dict, bitshift, 2, "int1 shift BITSHIFT int2"); defop (opt_system_dict, dict, 1, "int DICT dict"); defop (opt_system_dict, begin, 1, "dict BEGIN -"); defop (opt_system_dict, end, 0, "- END -"); defop (opt_system_dict, def, 2, "key value DEF -"); defop (opt_system_dict, load, 1, "key LOAD value"); defop (opt_system_dict, undef, 2, "dict key UNDEF -"); defop (opt_system_dict, known, 2, "dict key KNOWN bool"); defop (opt_system_dict, where, 1, "key WHERE dict true%key WHERE false"); defop (opt_system_dict, store, 2, "key value STORE -"); defop (opt_system_dict, currentdict, 0, "- CURRENTDICT dict"); defop (opt_system_dict, countdictstack, 0, "- COUNTDICTSTACK int"); defop (opt_system_dict, dictstack, 1, "array DICTSTACK array"); defop (opt_system_dict, cleardictstack, 0, "- CLEARDICTSTACK -"); defop (opt_system_dict, string, 1, "int STRING -"); defop (opt_system_dict, _strstr, 2, "string seek _STRSTR string offset true%" "string seek _STRSTR string false"); defop (opt_system_dict, _strrstr, 2, "string seek _STRRSTR string offset true%" "string seek _STRRSTR string false"); defop (opt_system_dict, _strchr, 2, "string chr _STRCHR string offset true%" "string chr _STRCHR string false"); defop (opt_system_dict, _strrchr, 2, "string chr _STRRCHR string offset true%" "string chr _STRRCHR string false"); defop (opt_system_dict, _strpbrk, 2, "string accept _STRPBRK string offset true%" "string accept _STRPBRK string false"); defop (opt_system_dict, exec, 1, "any EXEC -"); defop (opt_system_dict, if, 2, "bool proc IF -"); defop (opt_system_dict, ifelse, 3, "bool proc_t proc_f IFELSE -"); defop (opt_system_dict, repeat, 2, "int proc REPEAT -"); defop (opt_system_dict, loop, 1, "proc LOOP -"); defop (opt_system_dict, exit, 0, "- EXIT -"); defop (opt_system_dict, stop, 0, "- STOP -"); defop (opt_system_dict, stopped, 1, "any STOPPED bool"); defop (opt_system_dict, for, 4, "initial increment limit proc FOR -"); defop (opt_system_dict, quit, 0, "- quit -"); defop (opt_system_dict, countexecstack, 0, "- countexecstack int"); defop (opt_system_dict, execstack, 1, "array EXECSTACK array"); defop (opt_system_dict, type, 1, "any TYPE name"); defop (opt_system_dict, cvn, 1, "string CVN name"); defop (opt_system_dict, cvs, 2, "any string CVS string"); defop (opt_system_dict, null, 0, "- NULL null"); defop (opt_system_dict, bind, 1, "proc BIND proc"); defop (opt_system_dict, copy, 1, "any1 ... anyn n COPY any1 ... anyn any1 ... anyn%" "array1 array2 COPY array2%" "dict1 dict2 COPY dict2%" "string1 string2 COPY string2"); defop (opt_system_dict, length, 1, "array LENGTH int%" "dict LENGTH int%" "string LENGTH int"); defop (opt_system_dict, get, 2, "array index GET any%" "dict key GET any%" "string int GET int"); defop (opt_system_dict, put, 3, "array index any PUT -%" "dict key any PUT -%" "string index int PUT -"); defop (opt_system_dict, forall, 2, "array proc FORALL -%" "dict proc FORALL -%" "string proc FORALL -"); defop (opt_system_dict, putinterval, 3, "array1 index array2 PUTINTERVAL -%" "string1 index string2 PUTINTERVAL -"); defop (opt_system_dict, _copyinterval, 4, "array1 index count array2 _COPYINTERVAL array2%" "string1 index count string2 _COPYINTERVAL string2"); #define defKey(S) OPT_KEY_##S = es_symbol_intern(#S) defKey(newerror); defKey(errorname); defKey(command); defKey(ostack); defKey(estack); defKey(dstack); es_autounref_pool_pop (); return 0; } OptVM * opt_vm_new (MIO *in, MIO *out, MIO *err) { OptVM *vm = xCalloc (1, OptVM); vm->in = mio_ref (in); vm->out = mio_ref (out); vm->err = mio_ref (err); EsObject *tmp; tmp = array_new (0); vm->ostack = (ptrArray *)es_pointer_take (tmp); es_object_unref (tmp); tmp = array_new (0); vm->dstack = (ptrArray *)es_pointer_take (tmp); es_object_unref (tmp); tmp = array_new (0); vm->estack = (ptrArray *)es_pointer_take (tmp); es_object_unref (tmp); vm->dstack_protection = 0; vm_dstack_push (vm, opt_system_dict); vm->dstack_protection++; vm->error = dict_new (6, ATTR_READABLE|ATTR_WRITABLE); vm->print_depth = 0; vm->read_depth = 0; vm->prompt = NULL; return vm; } void opt_vm_clear (OptVM *vm) { ptrArrayClear (vm->estack); ptrArrayClear (vm->ostack); vm_dstack_clear (vm); vm->app_data = NULL; dict_op_clear (vm->error); } void opt_vm_delete (OptVM *vm) { ptrArrayDelete (vm->estack); ptrArrayDelete (vm->dstack); ptrArrayDelete (vm->ostack); es_object_unref (vm->error); mio_unref (vm->err); mio_unref (vm->out); mio_unref (vm->in); eFree (vm); } EsObject * opt_dict_new (unsigned int size) { return dict_new (size, ATTR_READABLE|ATTR_WRITABLE); } bool opt_dict_known_and_get_cstr (EsObject *dict, const char* name, EsObject **val) { if (es_object_get_type (dict) != OPT_TYPE_DICT) return false; EsObject *sym = es_symbol_intern (name); return dict_op_known_and_get (dict, sym, val); } bool opt_dict_foreach (EsObject *dict, bool (* fn) (EsObject *, EsObject *, void*), void *data) { if (es_object_get_type (dict) != OPT_TYPE_DICT) return false; hashTable *htable = es_pointer_get (dict); return hashTableForeachItem (htable, (hashTableForeachFunc) fn, data); } void opt_dict_def (EsObject *dict, EsObject *sym, EsObject *val) { Assert (!es_null(sym)); dict_op_def (dict, sym, val); } bool opt_dict_undef (EsObject *dict, EsObject *sym) { Assert (!es_null(sym)); return dict_op_undef (dict, sym); } void opt_dict_clear (EsObject *dict) { Assert (es_object_get_type (dict) == OPT_TYPE_DICT); dict_op_clear (dict); } EsObject * opt_array_new (void) { return array_new (ATTR_READABLE | ATTR_WRITABLE); } EsObject * opt_array_get (const EsObject *array, unsigned int index) { return array_op_get (array, index); } void opt_array_put (EsObject *array, unsigned int index, EsObject *obj) { array_op_put (array, index, obj); } void opt_array_add (EsObject *array, EsObject* elt) { array_op_add (array, elt); } unsigned int opt_array_length(const EsObject *array) { return array_op_length (array); } void opt_vm_dstack_push (OptVM *vm, EsObject *dict) { vm_dstack_push (vm, dict); vm->dstack_protection++; } void opt_vm_dstack_pop (OptVM *vm) { vm->dstack_protection--; vm_dstack_pop (vm); } EsObject* opt_vm_ostack_top (OptVM *vm) { return vm_ostack_top (vm); } EsObject* opt_vm_ostack_peek (OptVM *vm, int index_from_top) { return vm_ostack_peek (vm, index_from_top); } EsObject* opt_vm_ostack_pop (OptVM *vm) { return vm_ostack_pop (vm); } void opt_vm_ostack_push (OptVM *vm, EsObject *obj) { vm_ostack_push (vm, obj); } unsigned int opt_vm_ostack_count (OptVM *vm) { return vm_ostack_count (vm); } static EsObject* vm_eval (OptVM *vm, EsObject * o) { EsObject *r = es_false; if (es_error_p (o)) { r = o; goto out; } else if (es_object_get_type (o) == OPT_TYPE_NAME) { unsigned int attr = ((NameFat *)es_fatptr_get (o))->attr; if (attr & ATTR_EXECUTABLE) { EsObject *sym = es_pointer_get (o); EsObject *val = es_nil; EsObject *dict = vm_dstack_known_and_get (vm, sym, &val); if (es_object_get_type (dict) == OPT_TYPE_DICT) { int t = es_object_get_type (val); if (t == OPT_TYPE_OPERATOR) r = vm_call_operator (vm, val); else if (t == OPT_TYPE_ARRAY && (((ArrayFat *)es_fatptr_get (val))->attr & ATTR_EXECUTABLE)) r = vm_call_proc (vm, val); else { vm_ostack_push (vm, val); r = es_false; } if (es_error_p (r)) goto out; } else { r = es_error_set_object (OPT_ERR_UNDEFINED, o); vm_record_error (vm, r, o); /* TODO */ goto out; } } else vm_ostack_push (vm, o); } else if (es_object_get_type (o) == OPT_TYPE_OPERATOR) { r = vm_call_operator (vm, o); goto out; } else vm_ostack_push (vm, o); out: return r; } EsObject* opt_vm_read (OptVM *vm, MIO *in) { EsObject *e; MIO *tmp; if (in) { tmp = vm->in; vm->in = in; } e = vm_read (vm); if (in) vm->in = tmp; return e; } EsObject * opt_vm_eval (OptVM *vm, EsObject *obj) { return vm_eval (vm, obj); } void opt_vm_report_error (OptVM *vm, EsObject *eobj, MIO *err) { MIO *tmp; if (err) { tmp = vm->err; vm->err = err; } vm_report_error (vm, eobj); if (err) vm->err = tmp; } char* opt_vm_set_prompt (OptVM *vm, char *prompt) { char *tmp = vm->prompt; vm->prompt = prompt; return tmp; } void opt_vm_print_prompt (OptVM *vm) { if (vm->prompt && vm->read_depth == 0) { mio_puts (vm->err, vm->prompt); unsigned int c = ptrArrayCount (vm->ostack); if (c > 0) mio_printf (vm->err, "<%u> ", c); else mio_printf (vm->err, "> "); } } void* opt_vm_get_app_data (OptVM *vm) { return vm->app_data; } void* opt_vm_set_app_data (OptVM *vm, void *app_data) { void *tmp = vm->app_data; vm->app_data = app_data; return tmp; } int opt_vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data) { vm_help (vm, out? out: vm->out, extop, data); return 0; } EsObject * opt_operator_new (OptOperatorFn op, const char *name, int arity, const char *help_str) { return operator_new (op, name, arity, help_str); } EsObject *opt_string_new_from_cstr (const char *cstr) { vString *vstr = vStringNewInit (cstr? cstr: ""); return string_new (vstr); } const char* opt_string_get_cstr (const EsObject *str) { vString *vstr = es_pointer_get (str); return vStringValue (vstr); } EsObject *opt_name_new_from_cstr (const char *cstr) { return name_newS (cstr, ATTR_READABLE); } const char* opt_name_get_cstr (const EsObject *name) { if (es_object_get_type (name) == OPT_TYPE_NAME) name = es_pointer_get (name); if (!es_symbol_p (name)) return NULL; return es_symbol_get (name); } /* * VM */ static void vm_read_skip_comment(OptVM *vm) { while (true) { int c = mio_getc (vm->in); if (c == EOF || c == '\n' || c == '\r') { if (c != EOF) opt_vm_print_prompt (vm); return; } } } #define is_meta_char(c) ((c) == '%' \ || (c) == '/' \ || (c) == '(' \ || (c) == '{' \ || (c) == '}' \ || (c) == '[' \ || (c) == ']' \ || (c) == '<' \ || (c) == '>') static EsObject* vm_read_char (OptVM *vm) { int c = mio_getc (vm->in); int i; if (c == EOF) return OPT_ERR_SYNTAX; else if (c == '\\') { c = mio_getc (vm->in); int i; switch (c) { case 't': i = '\t'; break; case 'n': i = '\n'; break; case 'f': i = '\f'; break; case 'r': i = '\r'; break; case 'v': i = '\v'; break; case ' ': case '_': i = ' '; break; case '\\': i = '\\'; break; default: return OPT_ERR_SYNTAX; } c = mio_getc (vm->in); if (!(c == EOF || isspace (c) || is_meta_char (c))) return OPT_ERR_SYNTAX; mio_ungetc (vm->in, c); return es_integer_new (i); } else if (isgraph(c)) { i = c; c = mio_getc (vm->in); if (!(c == EOF || isspace (c) || is_meta_char (c))) return OPT_ERR_SYNTAX; mio_ungetc (vm->in, c); return es_integer_new (i); } else return OPT_ERR_SYNTAX; } static EsObject* vm_read_string (OptVM *vm) { int depth = 0; vString *s = vStringNew (); while (true) { int c = mio_getc (vm->in); if (c == ')') { if (depth == 0) return string_new (s); vStringPut (s, c); depth--; } else if (c == '(') { vStringPut (s, c); depth++; } else if (c == '\\') { c = mio_getc (vm->in); switch (c) { case EOF: vStringDelete (s); return OPT_ERR_SYNTAX; case 'n': vStringPut (s, '\n'); break; case 't': vStringPut (s, '\t'); break; case 'r': vStringPut (s, '\r'); break; case 'f': vStringPut (s, '\f'); break; case 'v': vStringPut (s, '\v'); break; case '\\': case '(': case ')': vStringPut (s, c); break; default: vStringPut (s, c); break; ; } } else if (c == EOF) { vStringDelete (s); return OPT_ERR_SYNTAX; } else vStringPut (s, c); } } static EsObject* vm_read_generic(OptVM *vm, int c, EsObject * (* make_object) (const char *, void *), void *data) { vString *name = vStringNew (); vStringPut (name, c); while (1) { c = mio_getc (vm->in); if (c == EOF) break; else if (isspace (c) || is_meta_char (c)) { mio_ungetc (vm->in, c); break; } else vStringPut (name, c); } EsObject *n = make_object (vStringValue (name), data); vStringDelete (name); return n; } static EsObject* vm_read_name (OptVM *vm, int c, unsigned int attr) { return vm_read_generic (vm, c, name_newS_cb, &attr); } struct name_or_number_data { unsigned int attr; bool negative; }; static EsObject* name_or_number_new (const char* s, void *data) { struct name_or_number_data *d = data; bool number = true; const char *t = s; while (*t) { if (!isdigit ((int)*t)) { number = false; break; } t++; } if (number) { int n; if (strToInt (s, 10, &n)) return es_integer_new (n * ((d->negative)? -1: 1)); else return OPT_ERR_INTOVERFLOW; } else return name_newS_cb (s, &d->attr); } static EsObject* vm_read_name_or_number (OptVM *vm, int c, unsigned int attr, bool negative) { struct name_or_number_data data = { .attr = attr, .negative = negative, }; return vm_read_generic (vm, c, name_or_number_new, &data); } static EsObject* vm_read_quoted (OptVM *vm) { bool immediate = false; int c = mio_getc (vm->in); switch (c) { case '/': immediate = true; c = mio_getc (vm->in); break; default: break; } EsObject *s = vm_read_name (vm, c, ATTR_READABLE); if (immediate) { EsObject *q; EsObject *val = es_nil; EsObject *dict = vm_dstack_known_and_get (vm, s, &val); if (es_object_get_type (dict) == OPT_TYPE_DICT) q = es_object_ref (val); else { q = es_error_set_object (OPT_ERR_UNDEFINED, s); vm_record_error (vm, q, s); /* TODO */ } es_object_unref (s); return q; } else return s; } static EsObject* vm_read_proc (OptVM *vm) { EsObject *proc = array_new (ATTR_EXECUTABLE|ATTR_READABLE); vm->read_depth++; while (true) { EsObject *o = vm_read (vm); if (es_object_equal (o, OPT_ERR_END_PROC)) { break; } else if (es_error_p (o)) { es_object_unref (proc); proc = o; break; } else { array_op_add (proc, o); es_object_unref (o); } } vm->read_depth--; return proc; } static EsObject* vm_read (OptVM *vm) { while (true) { int c = mio_getc (vm->in); if (c == EOF) return es_object_ref (ES_READER_EOF); else if (c == '\n' || c == '\r') { opt_vm_print_prompt (vm); continue; } else if (isspace (c)) continue; else if (c == '%') { vm_read_skip_comment (vm); continue; } else if (isdigit (c)) { return vm_read_name_or_number (vm, c, ATTR_EXECUTABLE|ATTR_READABLE, false); } else if (c == '-' || c == '+') { bool negative = (c == '-'); c = mio_getc (vm->in); if (isdigit (c)) return vm_read_name_or_number (vm, c, ATTR_EXECUTABLE|ATTR_READABLE, negative); else { mio_ungetc (vm->in, c); return vm_read_name_or_number (vm, '-', ATTR_EXECUTABLE|ATTR_READABLE, false); } } else if (c == '/') return vm_read_quoted (vm); else if (c == '(') return vm_read_string (vm); else if (c == '{') return vm_read_proc (vm); else if (c == '}') { if (vm->read_depth) return OPT_ERR_END_PROC; else return OPT_ERR_SYNTAX; } else if (c == '[' || c == ']') { const char name[2] = { [0] = c, [1] = '\0' }; EsObject *s = es_symbol_intern (name); EsObject *n = name_new (s, ATTR_EXECUTABLE|ATTR_READABLE); return n; } else if (c == '<' || c == '>') { int c0 = mio_getc (vm->in); if (c != c0) return OPT_ERR_SYNTAX; const char name [3] = { [0] = c, [1] = c, [2] = '\0' }; EsObject *s = es_symbol_intern (name); EsObject *n = name_new (s, ATTR_EXECUTABLE|ATTR_READABLE); return n; } else if (c == '?') return vm_read_char (vm); else return vm_read_name (vm, c, ATTR_EXECUTABLE|ATTR_READABLE); } } static void vm_ostack_push (OptVM *vm, EsObject *o) { ptrArrayAdd (vm->ostack, es_object_ref (o)); } static EsObject* vm_ostack_pop (OptVM *vm) { unsigned int c = vm_ostack_count (vm); if (c > 0) { ptrArrayDeleteLast (vm->ostack); return es_false; } return OPT_ERR_UNDERFLOW; } static unsigned int vm_ostack_count (OptVM *vm) { return ptrArrayCount (vm->ostack); } static int vm_ostack_counttomark (OptVM *vm) { unsigned int c = ptrArrayCount (vm->ostack); unsigned int i; if (c == 0) return -1; for (i = c; i > 0; i--) { EsObject *elt = ptrArrayItem (vm->ostack, i - 1); if (es_object_get_type (elt) == OPT_TYPE_MARK) break; } if (i == 0) return -1; int r = (c - i); if (r < 0) /* FIXME */ r = -1; return r; } static EsObject* vm_ostack_top (OptVM *vm) { if (ptrArrayCount (vm->ostack) > 0) return ptrArrayLast (vm->ostack); return OPT_ERR_UNDERFLOW; } static EsObject* vm_ostack_peek (OptVM *vm, int index_from_top) { unsigned int c = ptrArrayCount (vm->ostack); if (c > (unsigned int)index_from_top) { unsigned int i = (c - ((unsigned int)index_from_top)) - 1; Assert (i < c); return ptrArrayItem (vm->ostack, i); } return OPT_ERR_UNDERFLOW; } static EsObject* vm_dstack_known_and_get (OptVM *vm, EsObject *key, EsObject **val) { if (es_object_get_type (key) == OPT_TYPE_NAME) key = es_pointer_get (key); int c = ptrArrayCount (vm->dstack); for (int i = c - 1; i >= 0; i--) { EsObject *d = ptrArrayItem (vm->dstack, i); if (dict_op_known_and_get (d, key, val)) return d; } return es_false; } static void vm_dict_def (OptVM *vm, EsObject *key, EsObject *val) { Assert (!es_null(key)); dict_op_def (ptrArrayLast(vm->dstack), key, val); } static void vm_dstack_push (OptVM *vm, EsObject *o) { ptrArrayAdd (vm->dstack, es_object_ref (o)); } static int vm_dstack_count (OptVM *vm) { return ptrArrayCount (vm->dstack); } static EsObject* vm_dstack_pop (OptVM *vm) { if (vm_dstack_count (vm) <= vm->dstack_protection) return OPT_ERR_DICTSTACKUNDERFLOW; ptrArrayDeleteLast (vm->dstack); return es_false; } static void vm_dstack_clear (OptVM *vm) { while (ptrArrayCount (vm->dstack) > 1) ptrArrayDeleteLast (vm->dstack); vm->dstack_protection = 1; } static EsObject* vm_call_operator (OptVM *vm, EsObject *op) { EsObject *r; Operator operator = es_pointer_get (op); OperatorFat *ofat = es_fatptr_get (op); vm_estack_push (vm, op); if (ofat->arity > 0) { unsigned int c = ptrArrayCount (vm->ostack); if (c < (unsigned int)ofat->arity) { vm_estack_pop (vm); vm_record_error (vm, OPT_ERR_UNDERFLOW, op); return OPT_ERR_UNDERFLOW; } } r = (* operator) (vm, ofat->name); if (es_error_p (r)) { vm_estack_pop (vm); if (es_object_equal (OPT_ERR_STOPPED, r)) vm_record_stop (vm, op); else vm_record_error (vm, r, op); return r; } vm_estack_pop (vm); return es_false; } static EsObject* vm_call_proc (OptVM *vm, EsObject *proc) { ptrArray *a = es_pointer_get (proc); unsigned int c = ptrArrayCount (a); vm_estack_push (vm, proc); for (unsigned int i = 0; i < c; i++) { EsObject *o = ptrArrayItem (a, i); EsObject* e = vm_eval (vm, o); if (es_error_p (e)) { vm_estack_pop (vm); /* ??? */ return e; } } vm_estack_pop (vm); return es_false; } static EsObject* vm_estack_push (OptVM *vm, EsObject *p) { ptrArrayAdd (vm->estack, es_object_ref (p)); return es_false; } static EsObject* vm_estack_pop (OptVM *vm) { if (ptrArrayCount (vm->estack) < 1) return OPT_ERR_INTERNALERROR; ptrArrayDeleteLast (vm->estack); return es_false; } static void insert_spaces (MIO *mio, int n) { while (n-- > 0) mio_putc(mio, ' '); } struct htable_print_data { OptVM *vm; int dict_recursion; }; static bool htable_print_entry (const void *key, void *val, void *user_data) { struct htable_print_data *data = user_data; vm_print_full (data->vm, (EsObject *)key, false, data->dict_recursion); mio_putc (data->vm->out, ' '); vm_print_full (data->vm, (EsObject *)val, false, data->dict_recursion); return true; } static bool htable_print_entries (const void *key, void *val, void *user_data) { struct htable_print_data *data = user_data; insert_spaces (data->vm->out, data->vm->print_depth * 2); htable_print_entry (key, val, user_data); mio_putc (data->vm->out, '\n'); return true; } static void vm_print (OptVM *vm, EsObject *elt) { vm_print_full (vm, elt, false, 0); } static void vm_print_full(OptVM *vm, EsObject *elt, bool string_as_is, int dict_recursion) { if (es_object_equal (elt, es_true)) mio_puts (vm->out, "true"); else if (es_object_equal (elt, es_false)) mio_puts (vm->out, "false"); else if (es_object_equal (elt, es_nil)) mio_puts (vm->out, "null"); else if (es_error_p (elt)) { mio_putc (vm->out, '/'); mio_puts (vm->out, es_error_name (elt)); } else if (es_object_get_type (elt) == OPT_TYPE_DICT) { hashTable *d = es_pointer_get (elt); struct htable_print_data data = { .vm = vm, .dict_recursion = dict_recursion - 1, }; if (dict_recursion) { switch (hashTableCountItem (d)) { case 0: mio_puts(vm->out, "<<>> "); break; case 1: mio_puts(vm->out, "<<"); hashTableForeachItem (d, htable_print_entry, &data); mio_puts(vm->out, ">> "); break; default: mio_puts(vm->out, "<<\n"); vm->print_depth++; hashTableForeachItem (d, htable_print_entries, &data); vm->print_depth--; insert_spaces (vm->out, vm->print_depth*2); mio_puts(vm->out, ">> "); break; } } else { mio_printf (vm->out, "-dict:%u-", hashTableCountItem (d)); } } else if (es_object_get_type (elt) == OPT_TYPE_ARRAY) { ArrayFat *afat = (ArrayFat *)es_fatptr_get (elt); ptrArray *a = (ptrArray *)es_pointer_get (elt); unsigned int c = ptrArrayCount (a); int is_proc = (afat->attr & ATTR_EXECUTABLE)? 1: 0; mio_putc (vm->out, is_proc? '{': '['); vm->print_depth += is_proc; for (unsigned int i = 0; i < c; i++) { vm_print_full (vm, (EsObject *)ptrArrayItem (a, i), false, dict_recursion); if (i != c - 1) mio_putc (vm->out, ' '); } vm->print_depth -= is_proc; mio_putc (vm->out, is_proc? '}': ']'); } else if (es_object_get_type (elt) == OPT_TYPE_STRING && string_as_is) { const char *cstr = opt_string_get_cstr (elt); mio_puts (vm->out, cstr); } else if ((es_object_get_type (elt) == OPT_TYPE_NAME || es_symbol_p (elt)) && string_as_is) { const char *cstr = opt_name_get_cstr (elt); mio_puts (vm->out, cstr); } else if (es_symbol_p (elt) && (! string_as_is)) { mio_putc (vm->out, '/'); es_print (elt, vm->out); } else es_print (elt, vm->out); } static bool collect_operators (const void *key, void *value, void *user_data) { ptrArray *a = user_data; EsObject *op = value; if (es_object_get_type (op) == OPT_TYPE_OPERATOR) { OperatorFat *ofat = es_fatptr_get (op); if (ofat->help_str) ptrArrayAdd (a, op); } return true; } static const char* callable_get_name (const EsObject *callable) { if (es_object_get_type (callable) == OPT_TYPE_OPERATOR) { const OperatorFat *ofat_callable = es_fatptr_get (callable); return es_symbol_get (ofat_callable->name); } else return opt_name_get_cstr(callable); } static int compare_callable_by_name (const void *a, const void *b) { const char *str_a = callable_get_name (a); const char *str_b = callable_get_name (b); return strcmp (str_a, str_b); } static void vm_help (OptVM *vm, MIO *out, struct OptHelpExtender *extop, void *data) { unsigned int c = ptrArrayCount (vm->dstack); ptrArray *a = ptrArrayNew (NULL); for (unsigned int i = 0; i < c; i++) { hashTable *t = es_pointer_get (ptrArrayItem (vm->dstack, i)); hashTableForeachItem (t, collect_operators, a); } if (extop) extop->add (a, data); ptrArraySort (a, compare_callable_by_name); unsigned int ca = ptrArrayCount (a); size_t maxlen = 0; for (unsigned int i = 0; i < ca; i++) { EsObject* obj = ptrArrayItem (a, i); const char *name = callable_get_name (obj); size_t l = strlen (name); if (l > maxlen) maxlen = l; } for (unsigned int i = 0; i < ca; i++) { EsObject* obj = ptrArrayItem (a, i); const char *name = NULL; const char *help_str_head = NULL; const char *help_str_original = NULL; if (es_object_get_type (obj) == OPT_TYPE_OPERATOR) { OperatorFat *ofat = es_fatptr_get (obj); name = es_symbol_get (ofat->name); help_str_head = ofat->help_str; } else if (extop) { name = opt_name_get_cstr (obj); help_str_head = extop->get_help_str (obj, data); } help_str_original = help_str_head; if (name == NULL || help_str_head == NULL) continue; while (help_str_head) { const char *next = strpbrk (help_str_head, "%\n"); const char *label = (help_str_head == help_str_original)? name: NULL; if (next) { char *tmp = eStrndup (help_str_head, next - help_str_head); bool desc = (tmp[0] == ':'); mio_printf (out, "%*s%s%s\n", (int)maxlen, label? label: "", ((desc || (label == NULL))? " ": " -> "), (desc? tmp + 1: tmp)); eFree ((char *)tmp); help_str_head = next + 1; while (*help_str_head && isspace ((unsigned char)*help_str_head)) help_str_head++; } else { if (*help_str_head != '\0') { bool desc = (help_str_head[0] == ':'); mio_printf (out, "%*s%s%s\n", (int)maxlen, label? label: "", ((desc || (label == NULL))? " ": " -> "), (desc? help_str_head + 1: help_str_head)); } help_str_head = NULL; } } } ptrArrayDelete (a); } static EsObject * array_new_from_stack (ptrArray *src) { EsObject *dst = array_new (0); ptrArray *a = (ptrArray *)es_pointer_get (dst); for (unsigned int i = 0; i < ptrArrayCount(src); i++) ptrArrayAdd (a, es_object_ref (ptrArrayItem (src, i))); return dst; } static void vm_record_stop (OptVM *vm, EsObject *cmd) { dict_op_def (vm->error, OPT_KEY_command, cmd); dict_op_def (vm->error, OPT_KEY_errorname, es_nil); dict_op_def (vm->error, OPT_KEY_newerror, es_false); /* OPT_KEY_{o,e,o}stack are kept as is. */ } static void vm_record_error (OptVM *vm, EsObject *e, EsObject *cmd) { EsObject *newerror = es_nil; if (dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror) && es_object_equal (newerror, es_true)) return; dict_op_def (vm->error, OPT_KEY_newerror, es_true); dict_op_def (vm->error, OPT_KEY_errorname, e); dict_op_def (vm->error, OPT_KEY_command, cmd); EsObject *a; a = array_new_from_stack (vm->ostack); dict_op_def (vm->error, OPT_KEY_ostack, a); es_object_unref (a); a = array_new_from_stack (vm->estack); dict_op_def (vm->error, OPT_KEY_estack, a); es_object_unref (a); a = array_new_from_stack (vm->dstack); dict_op_def (vm->error, OPT_KEY_dstack, a); es_object_unref (a); } static void vm_report_error (OptVM *vm, EsObject *e) { MIO *out = vm->out; vm->out = vm->err; mio_puts (vm->err, "Error: "); EsObject *newerror = es_nil; if (!dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror)) { vm_print (vm, e); mio_putc (vm->err, '\n'); goto out; } if (es_object_equal (newerror, es_false)) { vm_print (vm, e); mio_putc (vm->err, '\n'); goto out; } if (!dict_op_known_and_get (vm->error, OPT_KEY_errorname, &e)) { vm_print (vm, OPT_ERR_INTERNALERROR); mio_putc (vm->err, '\n'); goto out; } vm_print (vm, e); EsObject *command = es_nil; dict_op_known_and_get (vm->error, OPT_KEY_command, &command); EsObject *attached_object = es_error_get_object (e); if (!es_null (attached_object)) { mio_puts (vm->err, " in "); vm_print (vm, attached_object); } else if (!es_null (command)) { mio_puts (vm->err, " in "); vm_print (vm, command); command = es_nil; } mio_putc (vm->err, '\n'); EsObject *ostack = es_nil; if (dict_op_known_and_get (vm->error, OPT_KEY_ostack, &ostack)) { mio_puts (vm->err, "Operand stack:\n"); mio_puts (vm->err, "top|"); ptrArray *a = es_pointer_get (ostack); for (unsigned int i = ptrArrayCount (a); i > 0; i--) { EsObject *o = ptrArrayItem (a, i - 1); mio_puts (vm->err, " "); vm_print (vm, o); } } mio_puts (vm->err, " |bottom\n"); EsObject *estack = es_nil; if (dict_op_known_and_get (vm->error, OPT_KEY_estack, &estack)) { mio_puts (vm->err, "Execution stack:\n"); mio_puts (vm->err, "top|"); if (!es_null (command)) { mio_puts (vm->err, " "); vm_print (vm, command); } ptrArray *a = es_pointer_get (estack); for (unsigned int i = ptrArrayCount (a); i > 0; i--) { EsObject *o = ptrArrayItem (a, i - 1); mio_puts (vm->err, " "); vm_print (vm, o); } } mio_puts (vm->err, " |bottom\n"); EsObject *dstack = es_nil; if (dict_op_known_and_get (vm->error, OPT_KEY_dstack, &dstack)) { mio_puts (vm->err, "Dictionary stack:\n"); mio_puts (vm->err, "top|"); ptrArray *a = es_pointer_get (dstack); for (unsigned int i = ptrArrayCount (a); i > 0; i--) { EsObject *o = ptrArrayItem (a, i - 1); mio_puts (vm->err, " "); vm_print (vm, o); } } mio_puts (vm->err, " |bottom\n"); out: dict_op_def (vm->error, OPT_KEY_newerror, es_false); vm->out = out; } static void vm_bind_proc (OptVM *vm, ptrArray *proc) { unsigned int c = ptrArrayCount (proc); for (unsigned int i = 0; i < c; i++) { EsObject *x = ptrArrayItem (proc, i); if (es_object_get_type (x) == OPT_TYPE_ARRAY) vm_bind_proc (vm, es_pointer_get (x)); else if (es_object_get_type (x) == OPT_TYPE_NAME) { if (!(((NameFat *)es_fatptr_get (x))->attr & ATTR_EXECUTABLE)) continue; EsObject* val = NULL; EsObject *r = vm_dstack_known_and_get (vm, x, &val); if (es_object_get_type (r) == OPT_TYPE_DICT) { if (es_object_get_type (val) == OPT_TYPE_OPERATOR) ptrArrayUpdate (proc, i, es_object_ref (val), es_nil); } } } } /* * Array */ static EsObject* array_new (unsigned int attr) { ptrArray *a = ptrArrayNew ((ptrArrayDeleteFunc)es_object_unref); return es_fatptr_new (OPT_TYPE_ARRAY, a, &attr); } static EsObject* array_es_init_fat (void *fat, void *ptr, void *extra) { ArrayFat *a = fat; a->attr = *((unsigned int *)extra); return es_false; } static void array_es_free (void *ptr, void *fat) { if (ptr) ptrArrayDelete ((ptrArray *)ptr); } static int array_es_equal (const void *a, const void *afat, const void *b, const void *bfat) { if (((ArrayFat *)afat)->attr != ((ArrayFat *)bfat)->attr) return 0; if (ptrArrayIsEmpty ((ptrArray *)a) && ptrArrayIsEmpty ((ptrArray*)b)) return 1; else if (a == b) return 1; else return 0; } static void array_es_print (const void *ptr, const void *fat, MIO *out) { unsigned int c = ptrArrayCount ((ptrArray *)ptr); ArrayFat *a = (ArrayFat *)fat; mio_printf (out, "%c%c%c count: %u", (a->attr & ATTR_READABLE) ? 'r': '-', (a->attr & ATTR_WRITABLE) ? 'w': '-', (a->attr & ATTR_EXECUTABLE)? 'x': '-', c); } static void array_op_add (EsObject* array, EsObject* elt) { ptrArray *a = es_pointer_get (array); ptrArrayAdd (a, es_object_ref (elt)); } static unsigned int array_op_length (const EsObject* array) { ptrArray *a = es_pointer_get (array); return ptrArrayCount (a); } static EsObject* array_op_get (const EsObject* array, unsigned int n) { ptrArray *a = es_pointer_get (array); unsigned int len = ptrArrayCount (a); if (n >= len) return OPT_ERR_RANGECHECK; return ptrArrayItem (a, n); } static void array_op_put (EsObject* array, unsigned int n, EsObject *obj) { ptrArray *a = es_pointer_get (array); ptrArrayUpdate (a, n, es_object_ref (obj), es_nil); } /* * Dictionary */ static unsigned int opt_es_hash (const void * const key) { const EsObject *k = key; if (es_integer_p (key)) return hashInthash (key); else if (es_boolean_p (key)) return es_object_equal (key, es_true)? 1: 0; return hashPtrhash (k); } static bool opt_es_eq (const void* a, const void* b) { return es_object_equal (a, b); } static EsObject* dict_new (unsigned int size, unsigned int attr) { hashTable *t = hashTableNew (size, opt_es_hash, opt_es_eq, (hashTableDeleteFunc)es_object_unref, (hashTableDeleteFunc)es_object_unref); hashTableSetValueForUnknownKey (t, t, NULL); return es_fatptr_new (OPT_TYPE_DICT, t, &attr); } static EsObject* dict_es_init_fat (void *fat, void *ptr, void *extra) { DictFat *a = fat; a->attr = *((unsigned int *)extra); return es_false; } static void dict_es_free (void *ptr, void *fat) { if (ptr) hashTableDelete ((hashTable *)ptr); } static int dict_es_equal (const void *a, const void *afat, const void *b, const void *bfat) { if (a == b) return 1; return 0; } static void dict_es_print (const void *ptr, const void *fat, MIO *out) { unsigned int c = hashTableCountItem ((hashTable *)ptr); DictFat *a = (DictFat *)fat; mio_printf (out, "%c%c%c count: %u", (a->attr & ATTR_READABLE) ? 'r': '-', (a->attr & ATTR_WRITABLE) ? 'w': '-', (a->attr & ATTR_EXECUTABLE)? 'x': '-', c); } static void dict_op_def (EsObject* dict, EsObject *key, EsObject *val) { hashTable *t = es_pointer_get (dict); Assert (t); Assert (!es_null (key)); if (es_object_get_type (key) == OPT_TYPE_NAME) key = es_pointer_get (key); key = es_object_ref (key); val = es_object_ref (val); hashTableUpdateItem (t, key, val); } static bool dict_op_undef (EsObject *dict, EsObject *key) { hashTable *t = es_pointer_get (dict); Assert (t); if (es_object_get_type (key) == OPT_TYPE_NAME) key = es_pointer_get (key); /* TODO: handle the case key == NULL */ return hashTableDeleteItem (t, key); } static bool dict_op_known_and_get(EsObject* dict, EsObject *key, EsObject **val) { hashTable *t = es_pointer_get (dict); Assert (t); if (es_object_get_type (key) == OPT_TYPE_STRING) { const char * cstr = opt_string_get_cstr (key); key = es_symbol_intern (cstr); } if (es_object_get_type (key) == OPT_TYPE_NAME) key = es_pointer_get (key); void *tmp = hashTableGetItem (t, key); if (tmp == t) return false; if (val) *val = tmp; return true; } static void dict_op_clear (EsObject* dict) { hashTable *h = es_pointer_get (dict); Assert (h); hashTableClear (h); } /* * Operator */ static EsObject* operator_new (Operator op, const char *name, int arity, const char *help_str) { OperatorExtra extra = { .name = name, .arity = arity, .help_str = help_str }; return es_fatptr_new (OPT_TYPE_OPERATOR, op, &extra); } static EsObject* operator_es_init_fat (void *fat, void *ptr, void *extra) { OperatorFat *ofat = fat; if (!extra) { ofat->name = NULL; return es_true; } OperatorExtra *oextra = extra; const char *name = oextra->name; EsObject *o = es_symbol_intern (name); if (es_error_p (o)) return o; ofat->name = o; ofat->arity = oextra->arity; ofat->help_str = oextra->help_str? eStrdup (oextra->help_str): NULL; return es_true; } static void operator_es_free (void *ptr, void *fat) { OperatorFat *ofat = fat; if (ofat->help_str) eFree ((char *)ofat->help_str); } static void operator_es_print (const void *ptr, const void *fat, MIO *out) { OperatorFat *ofat = (OperatorFat *)fat; mio_printf (out, "--%s--", es_symbol_get (ofat->name)); } /* * String */ static EsObject* string_new (vString *vstr) { unsigned int attr = ATTR_READABLE|ATTR_WRITABLE; if (vstr == NULL) vstr = vStringNew (); return es_fatptr_new (OPT_TYPE_STRING, vstr, &attr); } static EsObject* string_es_init_fat (void *fat, void *ptr, void *extra) { StringFat *s = fat; s->attr = *((unsigned int *)extra); return es_false; } static void string_es_free (void *ptr, void *fat) { if (ptr) vStringDelete (ptr); } static int string_es_equal (const void *a, const void *afat, const void *b, const void *bfat) { if (!strcmp (vStringValue ((vString *)a), vStringValue ((vString *)b))) return 1; return 0; } static void string_es_print (const void *ptr, const void *fat, MIO *out) { char *v = vStringValue ((vString *)ptr); mio_putc (out, '('); while (*v != '\0') { switch (*v) { case '(': case ')': case '\\': mio_putc (out, '\\'); mio_putc (out, *v); break; case '\n': mio_putc (out, '\\'); mio_putc (out, 'n'); break; case '\r': mio_putc (out, '\\'); mio_putc (out, 'r'); break; case '\t': mio_putc (out, '\\'); mio_putc (out, 't'); break; case '\f': mio_putc (out, '\\'); mio_putc (out, 'f'); break; case '\v': mio_putc (out, '\\'); mio_putc (out, 'v'); break; default: mio_putc (out, *v); } v++; } mio_putc (out, ')'); } /* * Name */ static EsObject* name_new (EsObject* symbol, unsigned int attr) { return es_fatptr_new (OPT_TYPE_NAME, es_object_ref (symbol), &attr); } static EsObject* name_newS (const char*s, unsigned int attr) { EsObject *sym = es_symbol_intern (s); return name_new (sym, attr); } static EsObject* name_newS_cb (const char*s, void *attr) { return name_newS (s, *((unsigned int *)attr)); } static EsObject* name_es_init_fat (void *fat, void *ptr, void *extra) { ArrayFat *a = fat; a->attr = *((unsigned int *)extra); return es_false; } static void name_es_print (const void *ptr, const void *fat, MIO *out) { const EsObject *symbol = ptr; const NameFat *qfat = fat; if (!(qfat->attr & ATTR_EXECUTABLE)) mio_putc (out, '/'); const char *name = es_symbol_get (symbol); mio_puts (out, name); } static void name_es_free (void *ptr, void *fat) { if (ptr) es_object_unref (ptr); } static int name_es_equal (const void *a, const void *afat, const void *b, const void *bfat) { const EsObject * asym = a; const EsObject * bsym = b; return es_object_equal (asym, bsym); } /* * Mark */ static EsObject* mark_new (const char* mark) { return es_pointer_new (OPT_TYPE_MARK, eStrdup (mark)); } static void mark_es_print (const void *ptr, MIO *out) { if (ptr == NULL || (strcmp (ptr, "mark") == 0)) mio_printf (out, "-mark-"); else mio_printf (out, "-mark:%s-", (char *)ptr); } static void mark_es_free (void *ptr) { if (ptr) eFree (ptr); } static int mark_es_equal (const void *a, const void *b) { return 1; } /* * Operator implementations */ #define GEN_PRINTER(NAME, BODY) \ static EsObject* \ NAME(OptVM *vm, EsObject *name) \ { \ EsObject * elt = ptrArrayRemoveLast (vm->ostack); \ BODY; \ mio_putc (vm->out, '\n'); \ es_object_unref (elt); \ return es_false; \ } GEN_PRINTER(op__print_objdict_rec, vm_print_full (vm, elt, false, 10)) GEN_PRINTER(op__print_objdict, vm_print_full (vm, elt, false, 1)) GEN_PRINTER(op__print_object, vm_print_full (vm, elt, false, 0)) GEN_PRINTER(op__print, vm_print_full (vm, elt, true, 0)) static EsObject* op__make_array (OptVM *vm, EsObject *name) { int n = vm_ostack_counttomark (vm); if (n < 0) return OPT_ERR_UNMATCHEDMARK; unsigned int count = vm_ostack_count (vm); EsObject *a = array_new (ATTR_READABLE | ATTR_WRITABLE); for (int i = (int)(count - n); i < count; i++) { EsObject *elt = ptrArrayItem (vm->ostack, i); array_op_add (a, elt); } ptrArrayDeleteLastInBatch (vm->ostack, n + 1); vm_ostack_push (vm, a); es_object_unref (a); return es_false; } static EsObject* op__make_dict (OptVM *vm, EsObject *name) { int n = vm_ostack_counttomark (vm); if (n < 0) return OPT_ERR_UNMATCHEDMARK; if (n % 2) return OPT_ERR_RANGECHECK; for (int i = 0; i < (n / 2); i++) { EsObject *key = ptrArrayItemFromLast (vm->ostack, 2 * i + 1); if (es_object_get_type (key) != OPT_TYPE_NAME && es_object_get_type (key) != OPT_TYPE_STRING && !es_integer_p (key) && !es_boolean_p (key)) return OPT_ERR_TYPECHECK; } EsObject *d = dict_new (n % 2 + 1, ATTR_READABLE|ATTR_WRITABLE); /* FIXME: + 1 */ for (int i = 0; i < (n / 2); i++) { EsObject *val = ptrArrayLast (vm->ostack); EsObject *key = ptrArrayItemFromLast (vm->ostack, 1); bool converted = false; if (es_object_get_type (key) == OPT_TYPE_STRING) { const char *cstr = opt_string_get_cstr (key); key = opt_name_new_from_cstr (cstr); converted = true; } dict_op_def (d, key, val); if (converted) es_object_unref (key); ptrArrayDeleteLastInBatch (vm->ostack, 2); } ptrArrayDeleteLast (vm->ostack); /* Remove the mark */ vm_ostack_push (vm, d); es_object_unref (d); return es_false; } static EsObject* op__help (OptVM *vm, EsObject *name) { vm_help (vm, vm->out, NULL, NULL); return es_false; } static EsObject* op_pstack (OptVM *vm, EsObject *name) { unsigned int c = vm_ostack_count (vm); for (unsigned int i = c; i > 0; i--) { EsObject * elt = ptrArrayItem (vm->ostack, i - 1); vm_print (vm, elt); mio_putc (vm->out, '\n'); } return es_false; } static EsObject* op__newerror (OptVM *vm, EsObject *name) { EsObject *newerror; if (dict_op_known_and_get (vm->error, OPT_KEY_newerror, &newerror)) vm_ostack_push (vm, newerror); else vm_ostack_push (vm, es_false); return es_false; } static EsObject* op__errorname (OptVM *vm, EsObject *name) { EsObject *errorname; if (dict_op_known_and_get (vm->error, OPT_KEY_errorname, &errorname)) { EsObject *sym = es_nil; if (!es_null (errorname)) { const char *cstr = es_error_name(errorname); sym = opt_name_new_from_cstr (cstr); } vm_ostack_push (vm, sym); if (!es_null (errorname)) es_object_unref (sym); } else vm_ostack_push (vm, es_nil); return es_false; } static EsObject* op_quit (OptVM *vm, EsObject *name) { int c = mio_getc (vm->in); if (!(c == '\n' || c == '\r' || c == EOF)) mio_ungetc (vm->in, c); return OPT_ERR_QUIT; } static EsObject* op_countexecstack (OptVM *vm, EsObject *name) { unsigned int c = ptrArrayCount (vm->estack); int n = c; if (n < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ EsObject *nobj = es_integer_new (n); vm_ostack_push (vm, nobj); es_object_unref (nobj); return es_false; } static EsObject* op__stack_common (OptVM *vm, EsObject *name, ptrArray *stack, EsObject *dstarrayobj, bool ignoreLast) { unsigned int c = ptrArrayCount (stack); ptrArray *a = es_pointer_get (dstarrayobj); if (ignoreLast && c == 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ ptrArrayClear (a); for (unsigned int i = 0; i < c - (ignoreLast? 1: 0); i++) { EsObject *d = ptrArrayItem (stack, i); ptrArrayAdd (a, es_object_ref (d)); } return es_false; } static EsObject* op_execstack (OptVM *vm, EsObject *name) { EsObject *obj = ptrArrayLast (vm->ostack); if (es_object_get_type (obj) != OPT_TYPE_ARRAY) return OPT_ERR_TYPECHECK; return op__stack_common (vm, name, vm->estack, obj, true); } /* * Operators for operand stack manipulation */ static EsObject* op_pop (OptVM *vm, EsObject *name) { ptrArrayDeleteLast (vm->ostack); return es_false; } static EsObject* op_exch (OptVM *vm, EsObject *name) { EsObject * top = ptrArrayRemoveLast (vm->ostack); EsObject * next = ptrArrayRemoveLast (vm->ostack); ptrArrayAdd (vm->ostack, top); ptrArrayAdd (vm->ostack, next); return es_false; } static EsObject* op_dup (OptVM *vm, EsObject *name) { EsObject * top = vm_ostack_top (vm); if (es_error_p (top)) return top; vm_ostack_push (vm, top); return es_false; } static bool dict_copy_cb (const void *key, void *value, void *user_data) { hashTable *dst = user_data; hashTablePutItem (dst, es_object_ref ((void *)key), es_object_ref (value)); return true; } static EsObject* op__copy_compound (OptVM *vm, EsObject *name, unsigned int c, EsObject *obj2) { int t = es_object_get_type (obj2); if (!(t == OPT_TYPE_ARRAY || t == OPT_TYPE_DICT || t == OPT_TYPE_STRING)) return OPT_ERR_TYPECHECK; if (c < 2) return OPT_ERR_UNDERFLOW; EsObject *obj1 = ptrArrayItemFromLast (vm->ostack, 1); if (es_object_get_type (obj1) != t) return OPT_ERR_TYPECHECK; if (t == OPT_TYPE_ARRAY) { ptrArray *a1 = es_pointer_get (obj1); ptrArray *a2 = es_pointer_get (obj2); ptrArrayClear (a2); unsigned int len = ptrArrayCount (a1); for (unsigned int i = 0; i < len; i++) { EsObject *o = ptrArrayItem (a1, i); ptrArrayAdd (a2, es_object_ref (o)); } } else if (t == OPT_TYPE_DICT) { hashTable *ht1 = es_pointer_get (obj1); hashTable *ht2 = es_pointer_get (obj2); hashTableClear (ht2); hashTableForeachItem (ht1, dict_copy_cb, ht2); } else { vString *str1 = es_pointer_get (obj1); vString *str2 = es_pointer_get (obj2); vStringCopy (str2, str1); } ptrArrayRemoveLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); ptrArrayAdd (vm->ostack, obj2); return es_false; } static EsObject* op_copy (OptVM *vm, EsObject *name) { unsigned int c = vm_ostack_count (vm); if (c > 0) { EsObject * nobj = ptrArrayLast(vm->ostack); if (!es_integer_p (nobj)) return op__copy_compound (vm, name, c, nobj); int n = es_integer_get (nobj); if (n < 0) return OPT_ERR_RANGECHECK; c--; if (((int)c) - n < 0) return OPT_ERR_UNDERFLOW; ptrArrayDeleteLast(vm->ostack); for (int i = c - n; i < c; i++) { EsObject * elt = ptrArrayItem (vm->ostack, i); vm_ostack_push (vm, elt); } return es_false; } return OPT_ERR_UNDERFLOW; } static EsObject* op_index (OptVM *vm, EsObject *name) { unsigned int c = vm_ostack_count (vm); EsObject * nobj = ptrArrayLast(vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if (n < 0) return OPT_ERR_RANGECHECK; if (c < (unsigned int)(n + 2)) return OPT_ERR_UNDERFLOW; ptrArrayDeleteLast (vm->ostack); EsObject * elt = ptrArrayItem (vm->ostack, c - n - 2); vm_ostack_push (vm, elt); return es_false; return OPT_ERR_UNDERFLOW; } static EsObject* op_roll (OptVM *vm, EsObject *name) { unsigned int c = vm_ostack_count (vm); EsObject *jobj = ptrArrayLast (vm->ostack); if (!es_integer_p (jobj)) return OPT_ERR_TYPECHECK; int j = es_integer_get (jobj); EsObject *nobj = ptrArrayItemFromLast (vm->ostack, 1); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if ((((int)c) - 2) < n) return OPT_ERR_UNDERFLOW; ptrArrayDeleteLastInBatch (vm->ostack, 2); if (j == 0) return es_false; unsigned int indx = c - 2 - n; EsObject *p; if (j > 0) { while (j-- != 0) { p = ptrArrayRemoveLast (vm->ostack); ptrArrayInsertItem (vm->ostack, indx, p); } } else { while (j++ != 0) { p = ptrArrayRemoveItem(vm->ostack, indx); ptrArrayAdd (vm->ostack, p); } } return es_false; } static EsObject* op_clear (OptVM *vm, EsObject *name) { ptrArrayClear (vm->ostack); return es_false; } static EsObject* op_count (OptVM *vm, EsObject *name) { unsigned int c = ptrArrayCount (vm->ostack); EsObject *n = es_integer_new ((int)c); ptrArrayAdd (vm->ostack, n); return es_false; } static EsObject* op_mark (OptVM *vm, EsObject *name) { EsObject *mark; if (es_object_equal (name, es_symbol_intern ("["))) mark = OPT_MARK_ARRAY; else if (es_object_equal (name, es_symbol_intern ("<<"))) mark = OPT_MARK_DICT; else mark = OPT_MARK_MARK; vm_ostack_push (vm, mark); return es_false; } static EsObject* op_cleartomark (OptVM *vm, EsObject *name) { int r = vm_ostack_counttomark (vm); if (r < 0) return OPT_ERR_UNMATCHEDMARK; if (r < 0) return OPT_ERR_UNMATCHEDMARK; for (int i = 0; i <= r; i++) ptrArrayDeleteLast (vm->ostack); return es_false; } static EsObject* op_counttomark (OptVM *vm, EsObject *name) { int r = vm_ostack_counttomark (vm); if (r < 0) return OPT_ERR_UNMATCHEDMARK; ptrArrayAdd (vm->ostack, es_integer_new (r)); return es_false; } /* * Arithmetic Operators */ #define INTEGER_BINOP(OP) \ EsObject *n0obj = ptrArrayLast (vm->ostack); \ if (!es_integer_p (n0obj)) \ return OPT_ERR_TYPECHECK; \ int n0 = es_integer_get (n0obj); \ \ EsObject *n1obj = ptrArrayItemFromLast (vm->ostack, 1); \ if (!es_integer_p (n1obj)) \ return OPT_ERR_TYPECHECK; \ int n1 = es_integer_get (n1obj); \ \ EsObject *r = es_integer_new (n1 OP n0); \ if (es_error_p (r)) \ return r; \ \ ptrArrayDeleteLastInBatch (vm->ostack, 2); \ ptrArrayAdd (vm->ostack, r); \ return es_false static EsObject* op_add (OptVM *vm, EsObject *name) { INTEGER_BINOP(+); } static EsObject* op_idiv (OptVM *vm, EsObject *name) { INTEGER_BINOP(/); } static EsObject* op_mod (OptVM *vm, EsObject *name) { INTEGER_BINOP(%); } static EsObject* op_mul (OptVM *vm, EsObject *name) { INTEGER_BINOP(*); } static EsObject* op_sub (OptVM *vm, EsObject *name) { INTEGER_BINOP(-); } static EsObject* op_abs (OptVM *vm, EsObject *name) { EsObject *nobj = ptrArrayLast (vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get(nobj); if (n >= 0) return es_false; EsObject *r = es_integer_new (-n); if (es_error_p (r)) return r; ptrArrayDeleteLast (vm->ostack); ptrArrayAdd (vm->ostack, r); return es_false; } static EsObject* op_neg (OptVM *vm, EsObject *name) { EsObject *nobj = ptrArrayLast (vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get(nobj); EsObject *r = es_integer_new (-n); if (es_error_p (r)) return r; ptrArrayDeleteLast (vm->ostack); ptrArrayAdd (vm->ostack, r); return es_false; } /* * Operators for array manipulation */ static EsObject* op_array (OptVM *vm, EsObject *name) { EsObject *nobj = ptrArrayLast (vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if (n < 0) return OPT_ERR_RANGECHECK; ptrArrayDeleteLast (vm->ostack); EsObject *array = array_new (ATTR_WRITABLE|ATTR_READABLE); ptrArray *a = es_pointer_get (array); for (int i = 0; i < n; i++) ptrArrayAdd (a, es_nil); vm_ostack_push (vm, array); es_object_unref (array); return es_false; } static EsObject* op_astore (OptVM *vm, EsObject *name) { EsObject *array = ptrArrayLast (vm->ostack); if (es_object_get_type (array) != OPT_TYPE_ARRAY) return OPT_ERR_TYPECHECK; unsigned int c = ptrArrayCount (vm->ostack); ptrArray *a = es_pointer_get (array); unsigned int l = ptrArrayCount (a); if (l == 0) return es_false; /* +1 is for the array itself. */ if (c < (l + 1)) return OPT_ERR_UNDERFLOW; ptrArrayClear (a); ptrArrayRemoveLast (vm->ostack); int i = l - 1; if (i < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ for (; i >= 0; i--) { EsObject * o = ptrArrayItemFromLast (vm->ostack, i); ptrArrayAdd (a, es_object_ref (o)); } ptrArrayDeleteLastInBatch (vm->ostack, l); vm_ostack_push (vm, array); es_object_unref (array); return es_false; } static EsObject* op_aload (OptVM *vm, EsObject *name) { EsObject *array = ptrArrayLast (vm->ostack); if (es_object_get_type (array) != OPT_TYPE_ARRAY) return OPT_ERR_TYPECHECK; ptrArray *a = es_pointer_get (array); ptrArrayRemoveLast (vm->ostack); unsigned int c = ptrArrayCount (a); for (unsigned int i = 0; i < c; i++) { EsObject *o = ptrArrayItem (a, i); vm_ostack_push (vm, o); } vm_ostack_push (vm, array); es_object_unref (array); return es_false; } /* * Operators for dictionary manipulation */ static EsObject* op_dict (OptVM *vm, EsObject *name) { EsObject *nobj = ptrArrayLast (vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if (n < 1) return OPT_ERR_RANGECHECK; ptrArrayDeleteLast (vm->ostack); EsObject *dict = dict_new (n, ATTR_READABLE|ATTR_WRITABLE); vm_ostack_push (vm, dict); es_object_unref (dict); return es_false; } static EsObject* op_def (OptVM *vm, EsObject *name) { EsObject *val = ptrArrayLast (vm->ostack); EsObject *key = ptrArrayItemFromLast (vm->ostack, 1); /* TODO */ if (es_object_get_type (key) != OPT_TYPE_NAME) return OPT_ERR_TYPECHECK; vm_dict_def (vm, key, val); ptrArrayDeleteLastInBatch(vm->ostack, 2); return es_false; } static EsObject* op_undef (OptVM *vm, EsObject *name) { EsObject *key = ptrArrayLast (vm->ostack); EsObject *dict = ptrArrayItemFromLast (vm->ostack, 1); if (es_object_get_type (key) != OPT_TYPE_NAME) return OPT_ERR_TYPECHECK; if (es_object_get_type (dict) != OPT_TYPE_DICT) return OPT_ERR_TYPECHECK; unsigned int attr = ((DictFat *)es_fatptr_get (dict))->attr; if (!(attr & ATTR_WRITABLE)) return OPT_ERR_INVALIDACCESS; if (!dict_op_undef (dict, key)) return es_error_set_object (OPT_ERR_UNDEFINED, key); ptrArrayDeleteLastInBatch (vm->ostack, 2); return es_false; } static EsObject* op_begin (OptVM *vm, EsObject *name) { EsObject *d = ptrArrayLast (vm->ostack); if (es_object_get_type (d) != OPT_TYPE_DICT) return OPT_ERR_TYPECHECK; vm_dstack_push (vm, d); ptrArrayDeleteLast (vm->ostack); return es_false; } static EsObject* op_end (OptVM *vm, EsObject *name) { return vm_dstack_pop (vm); } static EsObject* op_currentdict (OptVM *vm, EsObject *name) { EsObject *dict = ptrArrayLast (vm->dstack); vm_ostack_push (vm, dict); return es_false; } static EsObject* op_countdictstack (OptVM *vm, EsObject *name) { unsigned int c = ptrArrayCount (vm->dstack); int n = c; if (n < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ EsObject *nobj = es_integer_new (n); vm_ostack_push (vm, nobj); es_object_unref (nobj); return es_false; } static EsObject* op_dictstack (OptVM *vm, EsObject *name) { EsObject *obj = ptrArrayLast (vm->ostack); if (es_object_get_type (obj) != OPT_TYPE_ARRAY) return OPT_ERR_TYPECHECK; return op__stack_common (vm, name, vm->dstack, obj, false); } static EsObject* op_cleardictstack (OptVM *vm, EsObject *name) { unsigned int d = ptrArrayCount (vm->dstack) - vm->dstack_protection; ptrArrayDeleteLastInBatch (vm->dstack, d); return es_false; } static EsObject* op_where (OptVM *vm, EsObject *name) { EsObject *key = ptrArrayLast (vm->ostack); if (es_object_get_type (key) != OPT_TYPE_NAME) return OPT_ERR_TYPECHECK; EsObject *dict = vm_dstack_known_and_get (vm, key, NULL); ptrArrayDeleteLast (vm->ostack); if (es_object_get_type (dict) != OPT_TYPE_DICT) { vm_ostack_push (vm, es_false); return es_false; } else { vm_ostack_push (vm, dict); vm_ostack_push (vm, es_true); return es_false; } } static EsObject* op_known (OptVM *vm, EsObject *name) { EsObject *key = ptrArrayLast (vm->ostack); EsObject *dict = ptrArrayItemFromLast (vm->ostack, 1); if (es_object_get_type (dict) != OPT_TYPE_DICT) return OPT_ERR_TYPECHECK; EsObject *b = dict_op_known_and_get (dict, key, NULL) ? es_true : es_false; ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, b); return false; } static EsObject* op_store (OptVM *vm, EsObject *name) { EsObject *val = ptrArrayLast (vm->ostack); EsObject *key = ptrArrayItemFromLast (vm->ostack, 1); if (es_null (key)) return OPT_ERR_TYPECHECK; if (es_object_get_type (key) != OPT_TYPE_NAME) return OPT_ERR_TYPECHECK; EsObject *dict = vm_dstack_known_and_get (vm, key, NULL); if (es_object_get_type (dict) != OPT_TYPE_DICT) vm_dict_def (vm, key, val); else if (!(((DictFat *)es_fatptr_get (dict))->attr & ATTR_WRITABLE)) return OPT_ERR_INVALIDACCESS; else dict_op_def (dict, key, val); ptrArrayDeleteLastInBatch(vm->ostack, 2); return es_false; } static EsObject* op_load (OptVM *vm, EsObject *name) { EsObject *key = ptrArrayLast (vm->ostack); EsObject *val = NULL; EsObject *dict = vm_dstack_known_and_get (vm, key, &val); if (es_object_get_type (dict) != OPT_TYPE_DICT) return es_error_set_object (OPT_ERR_UNDEFINED, key); else { ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, val); return es_false; } } /* * Operators for string manipulation */ static EsObject* op_string (OptVM *vm, EsObject *name) { EsObject *nobj = ptrArrayLast (vm->ostack); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if (n < 0) return OPT_ERR_RANGECHECK; vString *s = vStringNew (); while (n-- > 0) vStringPut (s, ' '); EsObject *sobj = string_new (s); ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, sobj); es_object_unref (sobj); return es_false; } static EsObject* op__strstr_common (OptVM *vm, EsObject *name, bool fromTail) { EsObject *seekobj = ptrArrayLast (vm->ostack); EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1); if (es_object_get_type (strobj) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; if (es_object_get_type (seekobj) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; vString *stringv = es_pointer_get (strobj); vString *seekv = es_pointer_get (seekobj); if (vStringLength (stringv) < vStringLength (seekv)) { ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, es_false); return es_false; } const char *stringc = vStringValue (stringv); const char *seekc = vStringValue (seekv); char *tmp = (fromTail? strrstr: strstr) (stringc, seekc); if (tmp == NULL) { ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, es_false); return es_false; } unsigned int ud = tmp - stringc; int d = (int)ud; if (d < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ ptrArrayDeleteLast (vm->ostack); EsObject* dobj = es_integer_new (d); vm_ostack_push (vm, dobj); es_object_unref (dobj); vm_ostack_push (vm, es_true); return es_false; } static EsObject* op__strstr (OptVM *vm, EsObject *name) { return op__strstr_common (vm, name, false); } static EsObject* op__strrstr (OptVM *vm, EsObject *name) { return op__strstr_common (vm, name, true); } static EsObject* op__strchr_common (OptVM *vm, EsObject *name, bool fromTail) { EsObject *chrobj = ptrArrayLast (vm->ostack); EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1); if (! es_integer_p (chrobj)) return OPT_ERR_TYPECHECK; unsigned int chr = (unsigned int)es_integer_get (chrobj); /* 0 is unacceptable. */ if (! (0 < chr && chr < 256)) return OPT_ERR_RANGECHECK; if (es_object_get_type (strobj) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; vString *strv = es_pointer_get (strobj); const char *str = vStringValue (strv); char * p = (fromTail? strrchr: strchr) (str, (int)chr); if (p) { int d = p - str; if (d < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ ptrArrayDeleteLast (vm->ostack); EsObject *dobj = es_integer_new (d); vm_ostack_push (vm, dobj); es_object_unref (dobj); vm_ostack_push (vm, es_true); return es_false; } else { ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, es_false); return es_false; } } static EsObject* op__strchr (OptVM *vm, EsObject *name) { return op__strchr_common (vm, name, false); } static EsObject* op__strrchr (OptVM *vm, EsObject *name) { return op__strchr_common (vm, name, true); } static EsObject* op__strpbrk (OptVM *vm, EsObject *name) { EsObject *acceptobj = ptrArrayLast (vm->ostack); EsObject *strobj = ptrArrayItemFromLast (vm->ostack, 1); if (es_object_get_type (strobj) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; if (es_object_get_type (acceptobj) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; vString *strv = es_pointer_get (strobj); vString *acceptv = es_pointer_get (acceptobj); const char *str = vStringValue (strv); char *p = strpbrk (str, vStringValue (acceptv)); if (p) { int d = p - str; if (d < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ ptrArrayDeleteLast (vm->ostack); EsObject *dobj = es_integer_new (d); vm_ostack_push (vm, dobj); es_object_unref (dobj); vm_ostack_push (vm, es_true); return es_false; } else { ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, es_false); return es_false; } } /* * Relation, logical, and bit operators */ static EsObject* op__eq_full (OptVM *vm, EsObject *name, bool inversion) { EsObject *a = ptrArrayItemFromLast (vm->ostack, 0); EsObject *b = ptrArrayItemFromLast (vm->ostack, 1); bool eq = opt_es_eq (a, b); EsObject *r = (inversion? (!eq): eq)? es_true: es_false; ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, r); return es_false; } /* * Relation, logical, and bit operators */ static EsObject* op_eq (OptVM *vm, EsObject *name) { op__eq_full (vm, name, false); return es_false; } static EsObject* op_ne (OptVM *vm, EsObject *name) { op__eq_full (vm, name, true); return es_false; } static EsObject* op_true (OptVM *vm, EsObject *name) { vm_ostack_push (vm, es_true); return es_false; } static EsObject* op_false (OptVM *vm, EsObject *name) { vm_ostack_push (vm, es_false); return es_false; } #define CMP_OP(OP) \ EsObject *o0 = ptrArrayLast (vm->ostack); \ EsObject *o1 = ptrArrayItemFromLast (vm->ostack, 1); \ EsObject *r; \ \ if (es_integer_p (o0)) \ { \ if (!es_integer_p (o1)) \ return OPT_ERR_TYPECHECK; \ \ int i0 = es_integer_get (o0); \ int i1 = es_integer_get (o1); \ r = es_boolean_new (i1 OP i0); \ } \ else if (es_object_get_type (o0) == OPT_TYPE_STRING) \ { \ if (es_object_get_type (o1) != OPT_TYPE_STRING) \ return OPT_ERR_TYPECHECK; \ vString *vs0 = es_pointer_get (o0); \ vString *vs1 = es_pointer_get (o1); \ const char *s0 = vStringValue (vs0); \ const char *s1 = vStringValue (vs1); \ int d = strcmp (s1, s0); \ r = es_boolean_new (d OP 0); \ } \ else \ return OPT_ERR_TYPECHECK; \ ptrArrayDeleteLastInBatch (vm->ostack, 2); \ vm_ostack_push (vm, r); \ es_object_unref (r); \ return es_false static EsObject* op_ge (OptVM *vm, EsObject *name) { CMP_OP (>=); } static EsObject* op_gt (OptVM *vm, EsObject *name) { CMP_OP (>); } static EsObject* op_le (OptVM *vm, EsObject *name) { CMP_OP (<=); } static EsObject* op_lt (OptVM *vm, EsObject *name) { CMP_OP (<); } #define LOGBIT_OP(LOGOP, BITOP) \ EsObject *o0 = ptrArrayLast (vm->ostack); \ EsObject *o1 = ptrArrayItemFromLast (vm->ostack, 1); \ EsObject *r; \ \ if (es_boolean_p (o0)) \ { \ if (!es_boolean_p (o1)) \ return OPT_ERR_TYPECHECK; \ bool b0 = es_boolean_get (o0); \ bool b1 = es_boolean_get (o1); \ bool b = b0 LOGOP b1; \ r = es_boolean_new (b); \ } \ else if (es_integer_p (o0)) \ { \ if (!es_integer_p (o1)) \ return OPT_ERR_TYPECHECK; \ int i0 = es_integer_get (o0); \ int i1 = es_integer_get (o1); \ int i = i0 BITOP i1; \ r = es_integer_new (i); \ } \ else \ return OPT_ERR_TYPECHECK; \ \ ptrArrayDeleteLastInBatch (vm->ostack, 2); \ vm_ostack_push (vm, r); \ es_object_unref (r); \ return es_false; static EsObject* op_and (OptVM *vm, EsObject *name) { LOGBIT_OP (&&, &); } static EsObject* op_or (OptVM *vm, EsObject *name) { LOGBIT_OP (||, |); } static EsObject* op_xor (OptVM *vm, EsObject *name) { LOGBIT_OP (!=, ^); } static EsObject* op_not (OptVM *vm, EsObject *name) { EsObject *o = ptrArrayLast (vm->ostack); EsObject *r; if (es_boolean_p (o)) r = es_boolean_new (!es_boolean_get (o)); else if (es_integer_p (o)) r = es_integer_new (~ es_integer_get (o)); else return OPT_ERR_TYPECHECK; ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, r); es_object_unref (r); return es_false; } static EsObject* op_bitshift (OptVM *vm, EsObject *name) { EsObject *shiftobj = ptrArrayLast (vm->ostack); if (!es_integer_p (shiftobj)) return OPT_ERR_TYPECHECK; EsObject *iobj = ptrArrayItemFromLast (vm->ostack, 1); if (!es_integer_p (iobj)) return OPT_ERR_TYPECHECK; int shift = es_integer_get (shiftobj); int i = es_integer_get (iobj); EsObject *r; if (i == 0 || shift == 0) r = es_object_ref (iobj); else if (shift > 0) r = es_integer_new (i << shift); else r = es_integer_new (i >> -shift); ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, r); es_object_unref (r); return es_false; } /* * Operators for control flow */ static EsObject* op_exec (OptVM *vm, EsObject *name) { EsObject *x = ptrArrayRemoveLast (vm->ostack); EsObject *e; if (es_object_get_type (x) == OPT_TYPE_ARRAY && (((ArrayFat *)es_fatptr_get (x))->attr & ATTR_EXECUTABLE)) e = vm_call_proc (vm, x); else e = vm_eval (vm, x); es_object_unref (x); return e; } static EsObject* op_if (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *b = ptrArrayItemFromLast (vm->ostack, 1); if (!es_boolean_p (b)) return OPT_ERR_TYPECHECK; if (es_object_equal (b, es_false)) { ptrArrayDeleteLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); return es_false; } es_object_ref (proc); ptrArrayDeleteLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); EsObject *e = vm_call_proc (vm, proc); es_object_unref (proc); return e; } static EsObject* op_ifelse (OptVM *vm, EsObject *name) { EsObject *procf = ptrArrayLast (vm->ostack); if (!((es_object_get_type (procf) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (procf))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *proct = ptrArrayItemFromLast (vm->ostack, 1); if (!((es_object_get_type (proct) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proct))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *b = ptrArrayItemFromLast (vm->ostack, 2); if (!es_boolean_p (b)) return OPT_ERR_TYPECHECK; EsObject *p = (es_object_equal (b, es_false))? procf: proct; es_object_ref (p); ptrArrayDeleteLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); EsObject *e = vm_call_proc (vm, p); es_object_unref (p); return e; } static EsObject* op_loop (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; es_object_ref (proc); ptrArrayDeleteLast (vm->ostack); EsObject *e; while (true) { e = vm_call_proc (vm, proc); if (es_object_equal (e, OPT_ERR_INVALIDEXIT)) { dict_op_def (vm->error, OPT_KEY_newerror, es_false); e = es_false; break; } else if (es_error_p (e)) break; } es_object_unref (proc); return e; } static EsObject* op_exit (OptVM *vm, EsObject *name) { return OPT_ERR_INVALIDEXIT; } static EsObject* op_repeat (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *nobj = ptrArrayItemFromLast (vm->ostack, 1); if (!es_integer_p (nobj)) return OPT_ERR_TYPECHECK; int n = es_integer_get (nobj); if (n < 0) return OPT_ERR_RANGECHECK; es_object_ref (proc); ptrArrayDeleteLast (vm->ostack); ptrArrayDeleteLast (vm->ostack); EsObject *e = es_false;; for (int i = 0; i < n; i++) { e = vm_call_proc (vm, proc); if (es_object_equal (e, OPT_ERR_INVALIDEXIT)) { dict_op_def (vm->error, OPT_KEY_newerror, es_false); e = es_false; break; } else if (es_error_p (e)) break; } es_object_unref (proc); return e; } static EsObject* op_stop (OptVM *vm, EsObject *name) { return OPT_ERR_STOPPED; } static EsObject* op_stopped (OptVM *vm, EsObject *name) { EsObject *e = op_exec (vm, name); vm_ostack_push (vm, es_error_p (e)? es_true: es_false); return es_false; } static EsObject* op_for (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *limitobj = ptrArrayItemFromLast (vm->ostack, 1); if (! es_integer_p (limitobj)) return OPT_ERR_TYPECHECK; int limit = es_integer_get (limitobj); EsObject *incrementobj = ptrArrayItemFromLast (vm->ostack, 2); if (! es_integer_p (incrementobj)) return OPT_ERR_TYPECHECK; int increment = es_integer_get (incrementobj); EsObject *initialobj = ptrArrayItemFromLast (vm->ostack, 3); if (! es_integer_p (initialobj)) return OPT_ERR_TYPECHECK; int initial = es_integer_get (initialobj); ptrArrayRemoveLast (vm->ostack); ptrArrayDeleteLastInBatch (vm->ostack, 3); EsObject *r = es_false; for (int i = initial; (increment >= 0) ? (i <= limit) : (i >= limit); i += increment) { EsObject *iobj = es_integer_new (i); vm_ostack_push (vm, iobj); r = vm_call_proc (vm, proc); es_object_unref (iobj); if (es_object_equal (r, OPT_ERR_INVALIDEXIT)) { dict_op_def (vm->error, OPT_KEY_newerror, es_false); r = es_false; break; } if (es_error_p (r)) break; } es_object_unref (proc); return r; } /* * Operators for type, attribute and their conversion */ static const char* get_type_name (EsObject *o) { const char *n; if (o == es_nil) n = "nulltype"; else if (es_boolean_p (o)) n = "booleantype"; else if (es_integer_p (o)) n = "integertype"; else { int t = es_object_get_type (o); n = es_type_get_name (t); } return n; } static EsObject* op_type (OptVM *vm, EsObject *name) { EsObject *o = ptrArrayRemoveLast (vm->ostack); const char *n; n = get_type_name (o); EsObject *p = name_newS (n, ATTR_EXECUTABLE|ATTR_READABLE); vm_ostack_push (vm, p); es_object_unref (p); es_object_unref (o); return es_false; } static EsObject* op_cvn (OptVM *vm, EsObject *name) { EsObject *o = ptrArrayLast (vm->ostack); if (es_object_get_type (o) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; vString *vstr = es_pointer_get (o); const char *cstr = vStringValue (vstr); StringFat *sfat = es_fatptr_get (o); EsObject *n = name_newS (cstr, sfat->attr); ptrArrayDeleteLast (vm->ostack); vm_ostack_push (vm, n); es_object_unref (n); return es_false; } static EsObject * op_cvs (OptVM *vm, EsObject *name) { EsObject *o = ptrArrayLast (vm->ostack); if (es_object_get_type (o) != OPT_TYPE_STRING) return OPT_ERR_TYPECHECK; EsObject *any = ptrArrayItemFromLast (vm->ostack, 1); vString *vstr = es_pointer_get (o); int t = es_object_get_type (any); if (t == OPT_TYPE_STRING) { vString *vany = es_pointer_get (any); vStringCopy (vstr, vany); } else if (t == OPT_TYPE_NAME || t == ES_TYPE_SYMBOL) { if (t == OPT_TYPE_NAME) any = es_pointer_get (any); const char *cany = es_symbol_get (any); vStringCopyS (vstr, cany); } else if (t == ES_TYPE_INTEGER) { int iany = es_integer_get (any); #define buf_len 13 char buf[buf_len]; if (!(snprintf (buf, buf_len, "%d", iany) > 0)) buf [0] = '\0'; vStringCopyS (vstr, buf); } else if (t == ES_TYPE_BOOLEAN) vStringCopyS (vstr, any == es_true? "true": "false"); else { const char *type_name = get_type_name (any); vStringCopyS (vstr, "--"); vStringCatS (vstr, type_name); vStringCatS (vstr, "--"); } es_object_ref (o); ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, o); es_object_unref (o); return es_false; } /* * Misc operators */ static EsObject* op_null (OptVM *vm, EsObject *name) { vm_ostack_push (vm, es_nil); return es_false; } static EsObject* op_bind (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!((es_object_get_type (proc) == OPT_TYPE_ARRAY) && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; vm_bind_proc (vm, es_pointer_get (proc)); return es_false; } /* * Methods for compound objects */ static EsObject* op_length (OptVM *vm, EsObject *name) { EsObject *o = ptrArrayLast (vm->ostack); unsigned int c; int t = es_object_get_type (o); if (t == OPT_TYPE_ARRAY) { ptrArray *a = es_pointer_get (o); c = ptrArrayCount (a); } else if (t == OPT_TYPE_DICT) { hashTable *h = es_pointer_get (o); c = hashTableCountItem (h); } else if (t == OPT_TYPE_STRING) { vString *s = es_pointer_get (o); c = (unsigned int)vStringLength (s); } else if (t == OPT_TYPE_NAME) { EsObject *sym = es_pointer_get (o); const char* cstr = es_symbol_get (sym); c = (unsigned int) strlen (cstr); } else return OPT_ERR_TYPECHECK; int n = c; if (n < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ ptrArrayDeleteLast (vm->ostack); EsObject *nobj = es_integer_new (n); vm_ostack_push (vm, nobj); es_object_unref (nobj); return es_false; } static EsObject* op__get_array (OptVM *vm, EsObject *name, EsObject *k, EsObject *obj) { if (!es_integer_p (k)) return OPT_ERR_TYPECHECK; int n = es_integer_get (k); if (n < 0) return OPT_ERR_RANGECHECK; EsObject *r = array_op_get (obj, (unsigned int)n); if (es_error_p (r)) return r; es_object_ref (r); ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, r); es_object_unref (r); return es_false; } static EsObject* op__get_dict (OptVM *vm, EsObject *name, EsObject *k, EsObject *obj) { EsObject *v = NULL; if (!dict_op_known_and_get (obj, k, &v)) return es_error_set_object (OPT_ERR_UNDEFINED, k); es_object_ref (v); ptrArrayDeleteLastInBatch (vm->ostack, 2); vm_ostack_push (vm, v); es_object_unref (v); return es_false; } static EsObject* op__get_str (OptVM *vm, EsObject *name, EsObject *k, EsObject *obj) { if (!es_integer_p (k)) return OPT_ERR_TYPECHECK; int n = es_integer_get (k); if (n < 0) return OPT_ERR_RANGECHECK; vString *s = es_pointer_get (obj); unsigned int len = vStringLength (s); if ((unsigned int)n >= len) return OPT_ERR_RANGECHECK; unsigned char chr = vStringChar (s, n); ptrArrayDeleteLastInBatch (vm->ostack, 2); EsObject *chrobj = es_integer_new (chr); vm_ostack_push (vm, chrobj); es_object_unref (chrobj); return es_false; } static EsObject* op_get (OptVM *vm, EsObject *name) { EsObject *k = ptrArrayLast (vm->ostack); EsObject *obj = ptrArrayItemFromLast (vm->ostack, 1); int t = es_object_get_type (obj); if (t == OPT_TYPE_ARRAY) return op__get_array (vm, name, k, obj); else if (t == OPT_TYPE_DICT) return op__get_dict (vm, name, k, obj); else if (t == OPT_TYPE_STRING) return op__get_str (vm, name, k, obj); return OPT_ERR_TYPECHECK; } static EsObject* op__put_array (OptVM *vm, EsObject *name, EsObject *v, EsObject *k, EsObject *array) { if (!es_integer_p (k)) return OPT_ERR_TYPECHECK; int index = es_integer_get (k); if (index < 0) return OPT_ERR_RANGECHECK; array_op_put (array, (unsigned int)index, v); ptrArrayDeleteLastInBatch (vm->ostack, 3); return es_false; } static EsObject* op__put_dict (OptVM *vm, EsObject *name, EsObject *v, EsObject *k, EsObject *dict) { EsObject *key = k; if (es_null (key)) return OPT_ERR_TYPECHECK; if (es_object_get_type (key) == OPT_TYPE_STRING) { const char *cstr = opt_string_get_cstr (key); key = opt_name_new_from_cstr (cstr); } if (es_object_get_type (key) != OPT_TYPE_NAME && !es_integer_p (key) && !es_boolean_p (key)) return OPT_ERR_TYPECHECK; dict_op_def (dict, key, v); if (key != k) es_object_unref (key); ptrArrayDeleteLastInBatch (vm->ostack, 3); return es_false; } static EsObject* op__put_str (OptVM *vm, EsObject *name, EsObject *v, EsObject *k, EsObject *str) { if (!es_integer_p (v)) return OPT_ERR_TYPECHECK; int c = es_integer_get (v); if (!(c >= 0 && c < 256)) return OPT_ERR_RANGECHECK; if (!es_integer_p (k)) return OPT_ERR_TYPECHECK; int index = es_integer_get (k); if (index < 0) return OPT_ERR_RANGECHECK; vString *vstr = es_pointer_get (str); size_t len = vStringLength (vstr); if (len > (size_t)index) { if (c == 0) vStringTruncate (vstr, (size_t)index); else vStringChar(vstr, index) = (char)c; } else { size_t d = index - len; for (size_t i = 0; i < d; i++) vStringPut (vstr, ' '); if (c != 0) vStringPut (vstr, (char)c); } ptrArrayDeleteLastInBatch (vm->ostack, 3); return es_false; } static EsObject* op_put (OptVM *vm, EsObject *name) { EsObject *v = ptrArrayLast (vm->ostack); EsObject *k = ptrArrayItemFromLast (vm->ostack, 1); EsObject *obj = ptrArrayItemFromLast (vm->ostack, 2); int t = es_object_get_type (obj); if (t == OPT_TYPE_ARRAY) return op__put_array (vm, name, v, k, obj); else if (t == OPT_TYPE_DICT) return op__put_dict (vm, name, v, k, obj); else if (t == OPT_TYPE_STRING) return op__put_str (vm, name, v, k, obj); return OPT_ERR_TYPECHECK; } static EsObject* op__forall_array (OptVM *vm, EsObject *name, EsObject *proc, EsObject *obj) { ptrArray *a = es_pointer_get (obj); unsigned int c = ptrArrayCount (a); if (((int)c) < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ EsObject *e = es_false; for (int i = 0; i < c; i++) { EsObject *o = ptrArrayItem (a, i); es_object_ref (o); vm_ostack_push (vm, o); e = vm_call_proc (vm, proc); es_object_unref (o); if (es_error_p (e)) break; } return e; } struct dictForallData { OptVM *vm; EsObject *proc; EsObject *err; }; static bool dict_forall_cb (const void *key, void *value, void *user_data) { bool r = true; EsObject *k = (EsObject *)key; EsObject *v = value; struct dictForallData *d = user_data; /* TODO */ if (es_symbol_p (k)) k = name_new (k, ATTR_READABLE); else es_object_ref ((EsObject *)k); es_object_ref (v); vm_ostack_push (d->vm, (EsObject *)k); vm_ostack_push (d->vm, v); EsObject *e = vm_call_proc (d->vm, d->proc); if (es_error_p (e)) { d->err = e; r = false; } es_object_unref ((EsObject *)k); es_object_unref (v); return r; } static EsObject* op__forall_dict (OptVM *vm, EsObject *name, EsObject *proc, EsObject *obj) { EsObject *r = es_false;; hashTable *ht = es_pointer_get (obj); struct dictForallData data = { .vm = vm, .proc = proc }; if (!hashTableForeachItem (ht, dict_forall_cb, &data)) r = data.err; return r; } static EsObject* op__forall_string (OptVM *vm, EsObject *name, EsObject *proc, EsObject *obj) { vString *s = es_pointer_get (obj); unsigned int c = vStringLength (s); if (((int)c) < 0) return OPT_ERR_INTERNALERROR; /* TODO: integer overflow */ EsObject *e = es_false; for (int i = 0; i < c; i++) { unsigned char chr = vStringChar (s, i); EsObject *o = es_integer_new (chr); vm_ostack_push (vm, o); es_object_unref (o); e = vm_call_proc (vm, proc); if (es_error_p (e)) break; } return e; } static EsObject* op_forall (OptVM *vm, EsObject *name) { EsObject *proc = ptrArrayLast (vm->ostack); if (!(es_object_get_type (proc) == OPT_TYPE_ARRAY && (((ArrayFat *)es_fatptr_get (proc))->attr & ATTR_EXECUTABLE))) return OPT_ERR_TYPECHECK; EsObject *obj = ptrArrayItemFromLast (vm->ostack, 1); int t = es_object_get_type (obj); EsObject * (* proc_driver) (OptVM *, EsObject *, EsObject *, EsObject *) = NULL; if (t == OPT_TYPE_ARRAY) proc_driver = op__forall_array; else if (t == OPT_TYPE_DICT) proc_driver = op__forall_dict; else if (t == OPT_TYPE_STRING) proc_driver = op__forall_string; else return OPT_ERR_TYPECHECK; ptrArrayRemoveLast (vm->ostack); ptrArrayRemoveLast (vm->ostack); EsObject *e = (*proc_driver) (vm, name, proc, obj); es_object_unref (proc); es_object_unref (obj); if (es_object_equal (e, OPT_ERR_INVALIDEXIT)) { dict_op_def (vm->error, OPT_KEY_newerror, es_false); e = es_false; } return e; } static EsObject* op__putinterval_array (OptVM *vm, EsObject *name, ptrArray *srca, int index, ptrArray *dsta) { unsigned int dlen = ptrArrayCount (dsta); unsigned int slen = ptrArrayCount (srca); if (dlen > index) { if ((dlen - index) <= slen) { ptrArrayDeleteLastInBatch (dsta, dlen - index); for (unsigned int i = 0; i < slen; i++) ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i))); return es_false; } else { for (size_t i = 0; i < slen; i++) ptrArrayUpdate (dsta, ((size_t)index) + i, es_object_ref (ptrArrayItem (srca, i)), es_nil); return es_false; } } else if (dlen == index) { for (unsigned int i = 0; i < slen; i++) ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i))); return es_false; } else return OPT_ERR_RANGECHECK; } static EsObject* op__putinterval_string (OptVM *vm, EsObject *name, vString *srcv, int index, vString *dstv) { size_t dlen = vStringLength (dstv); if (dlen > index) { size_t slen = vStringLength (srcv); if ((dlen - index) <= slen) { vStringTruncate (dstv, (size_t)index); vStringCat (dstv, srcv); return es_false; } else { for (size_t i = 0; i < slen; i++) vStringChar (dstv, index + i) = vStringChar (srcv, i); return es_false; } } else if (dlen == index) { vStringCat (dstv, srcv); return es_false; } else return OPT_ERR_RANGECHECK; } static EsObject* op_putinterval (OptVM *vm, EsObject *name) { EsObject *src = ptrArrayLast (vm->ostack); EsObject *indexobj = ptrArrayItemFromLast (vm->ostack, 1); EsObject *dst = ptrArrayItemFromLast (vm->ostack, 2); int t = es_object_get_type (src); if (t == OPT_TYPE_ARRAY || t == OPT_TYPE_STRING) { if (!es_integer_p (indexobj)) return OPT_ERR_TYPECHECK; if (es_object_get_type (dst) != t) return OPT_ERR_TYPECHECK; } else return OPT_ERR_TYPECHECK; int index = es_integer_get (indexobj); if (index < 0) return OPT_ERR_RANGECHECK; EsObject *r; if (t == OPT_TYPE_ARRAY) r = op__putinterval_array (vm, name, es_pointer_get (src), index, es_pointer_get (dst)); else r = op__putinterval_string (vm, name, es_pointer_get (src), index, es_pointer_get (dst)); if (!es_error_p (r)) ptrArrayDeleteLastInBatch (vm->ostack, 3); return r; } static EsObject* op__copyinterval_array (OptVM *vm, EsObject *name, ptrArray *dsta, int count, int index, ptrArray *srca) { unsigned long srcl = ptrArrayCount (srca); if ((unsigned long)index > srcl) return OPT_ERR_RANGECHECK; if ((unsigned long)(index + count) > srcl) return OPT_ERR_RANGECHECK; for (unsigned int i = (unsigned int)index; i < index + count; i++) ptrArrayAdd (dsta, es_object_ref (ptrArrayItem (srca, i))); return es_false; } static EsObject* op__copyinterval_string (OptVM *vm, EsObject *name, vString *dsts, int count, int index, vString *srcs) { size_t srcl = vStringLength (srcs); if ((size_t)index > srcl) return OPT_ERR_RANGECHECK; if ((size_t)(index + count) > srcl) return OPT_ERR_RANGECHECK; vStringNCatSUnsafe (dsts, vStringValue (srcs) + index, (size_t)count); return es_false; } static EsObject* op__copyinterval (OptVM *vm, EsObject *name) { EsObject *dstobj = ptrArrayLast (vm->ostack); EsObject *countobj = ptrArrayItemFromLast (vm->ostack, 1); EsObject *indexobj = ptrArrayItemFromLast (vm->ostack, 2); EsObject *srcobj = ptrArrayItemFromLast (vm->ostack, 3); int t = es_object_get_type (dstobj); if (! (t == OPT_TYPE_ARRAY || t == OPT_TYPE_STRING)) return OPT_ERR_TYPECHECK; if (t != es_object_get_type (srcobj)) return OPT_ERR_TYPECHECK; if (!es_integer_p (countobj)) return OPT_ERR_TYPECHECK; if (!es_integer_p (indexobj)) return OPT_ERR_TYPECHECK; int count = es_integer_get (countobj); if (count < 0) return OPT_ERR_RANGECHECK; int index = es_integer_get (indexobj); if (index < 0) return OPT_ERR_RANGECHECK; EsObject* r; if (t == OPT_TYPE_ARRAY) r = op__copyinterval_array (vm, name, es_pointer_get (dstobj), count, index, es_pointer_get (srcobj)); else r = op__copyinterval_string (vm, name, es_pointer_get (dstobj), count, index, es_pointer_get (srcobj)); if (es_error_p (r)) return r; es_object_ref (dstobj); ptrArrayDeleteLastInBatch (vm->ostack, 4); vm_ostack_push (vm, dstobj); es_object_unref (dstobj); return r; }