diff options
Diffstat (limited to 'generic/Lcompile.c')
| -rw-r--r-- | generic/Lcompile.c | 8167 |
1 files changed, 8167 insertions, 0 deletions
diff --git a/generic/Lcompile.c b/generic/Lcompile.c new file mode 100644 index 0000000..c1e5973 --- /dev/null +++ b/generic/Lcompile.c @@ -0,0 +1,8167 @@ +/* + * Copyright (c) 2006-2009 BitMover, Inc. + */ +#include <stdio.h> +#include <stdarg.h> +#include <setjmp.h> +#include "tclInt.h" +#include "tclIO.h" +#include "tclCompile.h" +#include "tclRegexp.h" +#include "Lcompile.h" +#include "Lgrammar.h" + +/* Used by compile_spawn_system(). */ +enum { + SYSTEM_ARGV = 0x00000001, + SYSTEM_IN_STRING = 0x00000002, + SYSTEM_IN_ARRAY = 0x00000004, + SYSTEM_IN_FILENAME = 0x00000008, + SYSTEM_IN_HANDLE = 0x00000010, + SYSTEM_OUT_STRING = 0x00000020, + SYSTEM_OUT_ARRAY = 0x00000040, + SYSTEM_OUT_FILENAME = 0x00000080, + SYSTEM_OUT_HANDLE = 0x00000100, + SYSTEM_ERR_STRING = 0x00000200, + SYSTEM_ERR_ARRAY = 0x00000400, + SYSTEM_ERR_FILENAME = 0x00000800, + SYSTEM_ERR_HANDLE = 0x00001000, + SYSTEM_BACKGROUND = 0x00002000, +}; + +/* + * As of March 2009, we use a bit in the Tcl_Obj structure to + * represent when an object has the L undefined value. This avoids + * the problems we had when Tcl would shimmer undef away into another + * type, making it look defined. But we also need an undef object, as + * the value of array, hash, and struct members when they dynamically + * are brought into life. This is also the value of the "undef" + * pre-defined constant. We create one object of this type and dup it + * whenever undef is requested. + */ + +private void +undef_freeInternalRep(Tcl_Obj *o) +{ +} + +/* + * Return an error if someone tries to convert something to undef + * type. + */ +private int +undef_setFromAny(Tcl_Interp *interp, Tcl_Obj *o) +{ + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot convert to undefined value", + -1)); + return (TCL_ERROR); +} + +/* + * Get a pointer to the "undefined" object pointer, allocating it the + * first time it is needed. Keep the refCount high because we want + * the one-and-only undef object to never be freed. + */ +Tcl_Obj ** +L_undefObjPtrPtr() +{ + static Tcl_Obj *undef_obj = NULL; + + unless (undef_obj) { + undef_obj = Tcl_NewObj(); + undef_obj->bytes = tclEmptyStringRep; + undef_obj->typePtr = &L_undefType; + undef_obj->undef = 1; + undef_obj->refCount = 1234; // arbitrary; to be recognizable + } + ASSERT(undef_obj->undef); + return (&undef_obj); +} + +int +L_isUndef(Tcl_Obj *o) +{ + return (o->undef); +} + +Tcl_ObjType L_undefType = { + "undef", + undef_freeInternalRep, + NULL, + NULL, + undef_setFromAny +}; + +/* Returned by re_kind. */ +typedef enum { + RE_NOT_AN_RE = 0x0001, + RE_CONST = 0x0002, + RE_GLOB = 0x0004, + RE_SIMPLE = 0x0008, + RE_COMPLEX = 0x0010, + RE_NEEDS_EVAL = 0x0020, +} ReKind; + +/* Used by tmp_* API. */ +typedef enum { + TMP_REUSE, + TMP_UNSET, +} TmpKind; + +/* + * Lists of allowable attributes in #pragma, _attribute, and cmd-line + * options. Each array must end with a NULL. + */ +char *L_attrs_attribute[] = { + "dis", + "fnhook", + "fntrace", + "trace_depth", + NULL +}; +char *L_attrs_cmdLine[] = { + "L", + "dis", + "fnhook", + "fntrace", + "line", + "lineadj", + "norun", + "nowarn", + "poly", + "trace_depth", + "trace_files", + "trace_funcs", + "trace_out", + "trace_script", + "warn_undefined_fns", + "version", + NULL +}; +char *L_attrs_pragma[] = { + "dis", + "fnhook", + "fntrace", + "line", + "lineadj", + "norun", + "nowarn", + "poly", + "trace_depth", + "warn_undefined_fns", + NULL +}; +char *L_attrs_Lhtml[] = { + "line", + "lineadj", +}; + +/* The next two functions are generated by flex. */ +extern void *L__scan_bytes (const char *bytes, int len); +extern void L__delete_buffer(void *buf); + +private int ast_compile(void *ast); +private void ast_free(Ast *ast_list); +private char *basenm(char *s); +private int compile_abs(Expr *expr); +private int compile_assert(Expr *expr); +private void compile_assign(Expr *expr); +private void compile_assignComposite(Expr *expr); +private void compile_assignFromStack(Expr *lhs, Type *rhs_type, Expr *expr, + int flags); +private int compile_binOp(Expr *expr, Expr_f flags); +private void compile_block(Block *block); +private void compile_break(Stmt *stmt); +private int compile_cast(Expr *expr, Expr_f flags); +private int compile_catch(Expr *expr); +private void compile_clsDecl(ClsDecl *class); +private int compile_clsDeref(Expr *expr, Expr_f flags); +private int compile_clsInstDeref(Expr *expr, Expr_f flags); +private void compile_condition(Expr *cond); +private void compile_continue(Stmt *stmt); +private void compile_defined(Expr *expr); +private int compile_die(Expr *expr); +private void compile_do(Loop *loop); +private void compile_eq_stack(Expr *expr, Type *type); +private void compile_for_while(Loop *loop); +private int compile_idxOp(Expr *expr, Expr_f flags); +private int compile_idxOp2(Expr *expr, Expr_f flags); +private int compile_expr(Expr *expr, Expr_f flags); +private int compile_exprs(Expr *expr, Expr_f flags); +private int compile_fnCall(Expr *expr); +private void compile_fnDecl(FnDecl *fun, Decl_f flags); +private void compile_fnDecls(FnDecl *fun, Decl_f flags); +private void compile_foreach(ForEach *loop); +private void compile_foreachAngle(ForEach *loop); +private void compile_foreachArray(ForEach *loop); +private void compile_foreachHash(ForEach *loop); +private void compile_foreachString(ForEach *loop); +private void compile_goto(Stmt *stmt); +private int compile_here(Expr *expr); +private void compile_ifUnless(Cond *cond); +private void compile_incdec(Expr *expr); +private int compile_insert_unshift(Expr *expr); +private int compile_join(Expr *expr); +private int compile_keys(Expr *expr); +private void compile_label(Stmt *stmt); +private int compile_length(Expr *expr); +private void compile_loop(Loop *loop); +private int compile_min_max(Expr *expr); +private int compile_fnParms(VarDecl *decl); +private int compile_popen(Expr *expr); +private int compile_pop_shift(Expr *expr); +private int compile_push(Expr *expr); +private void compile_reMatch(Expr *re); +private int compile_read(Expr *expr); +private int compile_rename(Expr *expr); +private void compile_return(Stmt *stmt); +private int compile_script(Tcl_Obj *scriptObj, Tcl_Obj *nameObj); +private void compile_shortCircuit(Expr *expr); +private int compile_sort(Expr *expr); +private int compile_spawn_system(Expr *expr); +private int compile_split(Expr *expr); +private void compile_stmt(Stmt *stmt); +private void compile_stmts(Stmt *stmt); +private void compile_switch(Switch *sw); +private void compile_switch_fast(Switch *sw); +private void compile_switch_slow(Switch *sw); +private int compile_trinOp(Expr *expr); +private int compile_trace_script(char *script); +private void compile_trycatch(Stmt *stmt); +private void compile_twiddle(Expr *expr); +private void compile_twiddleSubst(Expr *expr); +private int compile_typeof(Expr *expr); +private int compile_undef(Expr *expr); +private int compile_unOp(Expr *expr); +private int compile_var(Expr *expr, Expr_f flags); +private void compile_varDecl(VarDecl *decl); +private void compile_varDecls(VarDecl *decls); +private int compile_warn(Expr *expr); +private int compile_write(Expr *expr); +private void copyout_parms(Expr *actuals); +private Tcl_Obj *do_getline(Tcl_Interp *interp, Tcl_Channel chan); +private void emit_globalUpvar(Sym *sym); +private void emit_instrForLOp(Expr *expr, Type *type); +private void emit_jmp_back(TclJumpType jmp_type, int offset); +private Jmp *emit_jmp_fwd(int op, Jmp *next); +private void fixup_jmps(Jmp **jumps); +private int fnCallBegin(); +private void fnCallEnd(int lev); +private int fnInArgList(); +private Frame *frame_find(Frame_f flags); +private char *frame_name(void); +private void frame_pop(void); +private void frame_push(void *node, char *name, Frame_f flags); +private void frame_resumeBody(); +private void frame_resumePrologue(); +private char *get_text(Expr *expr); +private int has_END(Expr *expr); +private void init_predefined(); +private Type *iscallbyname(VarDecl *formal); +private int ispatternfn(char *name, Expr **foo, Expr **Foo_star, + Expr **opts, int *nopts); +private Label *label_lookup(Stmt *stmt, Label_f flags); +private Expr *mkId(char *name); +private int parse_options(int objc, Tcl_Obj **objv, char *allowed[]); +private int parse_script(char *str, Ast **L_ast, Tcl_Obj *nameObj); +private void proc_mkArg(Proc *proc, VarDecl *decl); +private int push_index(Expr *expr, int flags); +private int push_parms(Expr *actuals, VarDecl *formals); +private int push_regexpModifiers(Expr *regexp); +private ReKind re_kind(Expr *re, Tcl_DString *ds); +private int re_submatchCnt(Expr *re); +private VarDecl *struct_lookupMember(Type *t, Expr *idx, int *offset); +private Sym *sym_mk(char *name, Type *t, Decl_f flags); +private Sym *sym_lookup(Expr *id, Expr_f flags); +private Sym *sym_store(VarDecl *decl); +private Tmp *tmp_get(TmpKind kind); +private void tmp_free(Tmp *tmp); +private void tmp_freeAll(Tmp *tmp); +private void track_cmd(int codeOffset, void *node); +private void type_free(Type *type_list); +private int typeck_spawn(Expr *in, Expr *out, Expr *err); +private int typeck_system(Expr *in, Expr *out, Expr *err); + +Linterp *L; // per-interp L state +Type *L_int; // pre-defined types +Type *L_float; +Type *L_string; +Type *L_void; +Type *L_var; +Type *L_poly; +Type *L_widget; + +/* + * L built-in functions. + */ +static struct { + char *name; + int (*fn)(Expr *); +} builtins[] = { + { "abs", compile_abs }, + { "assert", compile_assert }, + { "catch", compile_catch }, + { "die", compile_die }, + { "here", compile_here }, + { "insert", compile_insert_unshift }, + { "join", compile_join }, + { "keys", compile_keys }, + { "length", compile_length }, + { "max", compile_min_max }, + { "min", compile_min_max }, + { "popen", compile_popen }, + { "pop", compile_pop_shift }, + { "push", compile_push }, + { "read", compile_read }, + { "rename", compile_rename }, + { "shift", compile_pop_shift }, + { "sort", compile_sort }, + { "split", compile_split }, + { "spawn", compile_spawn_system }, + { "system", compile_spawn_system }, + { "typeof", compile_typeof }, + { "undef", compile_undef }, + { "unshift", compile_insert_unshift }, + { "warn", compile_warn }, + { "write", compile_write }, +}; + +/* + * L compiler entry point. + */ +int +Tcl_LObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]) +{ + char *s; + int argc, ret; + Tcl_Obj **argvList; + + /* Extract the L state from the interp. */ + L = Tcl_GetAssocData(interp, "L", NULL); + + /* + * Verify that lib L was loaded. L fails badly if lib L isn't + * there, and this catches cases where the user overrides the + * Tcl library path. + */ + unless (Tcl_GetVar(L->interp, "::L_libl_initted", 0)) { + Tcl_SetResult(L->interp, "fatal -- libl.tcl not found", 0); + return (TCL_ERROR); + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?options? l-program"); + return (TCL_ERROR); + } + + /* Parse options from both the Tcl L command and the tclsh cmd line. */ + L->errs = NULL; + L->options = Tcl_NewDictObj(); + ret = parse_options(objc-1, (Tcl_Obj **)(objv+1), L_attrs_cmdLine); + unless (ret == TCL_OK) { + Tcl_SetObjResult(interp, L->errs); + return (ret); + } + if (L->global->tclsh_argv && + Tcl_ListObjGetElements(L->interp, L->global->tclsh_argv, &argc, + &argvList) == TCL_OK) { + ret = parse_options(argc-1, argvList+1, L_attrs_cmdLine); + unless (ret == TCL_OK) { + Tcl_SetObjResult(interp, L->errs); + return (ret); + } + } + + /* L_synerr() longjmps back here on a parser syntax error. */ + if (setjmp(L->jmp)) { + Tcl_SetObjResult(interp, L->errs); + return (TCL_ERROR); + } + + /* + * If a function-tracing script was specified in + * --trace_script or L_TRACE_SCRIPT (takes precedence), + * compile that (once) but only after libL has been compiled. + */ + unless (hash_get(L->options, "trace_script_compiled")) { + if ((s = getenv("L_TRACE_SCRIPT"))) { + hash_put(L->options, "trace_script", s); + } + if ((s = hash_get(L->options, "trace_script")) && + Tcl_GetVar(L->interp, "::L_libl_done", 0)) { + hash_put(L->options, "trace_script_compiled", "yes"); + s = ckstrdup(s); + ret = compile_trace_script(s); + if (ret != TCL_OK) return (ret); + } + } + + /* + * Propagate some cmd-line options to env variables for lib L. + * Pre-existing env variables take precedence. + */ + if ((s = hash_get(L->options, "trace_funcs"))) { + unless (getenv("L_TRACE_FUNCS")) { + s = cksprintf("L_TRACE_FUNCS=%s", s); + putenv(s); + } + } + if ((s = hash_get(L->options, "trace_files"))) { + unless (getenv("L_TRACE_FILES")) { + s = cksprintf("L_TRACE_FILES=%s", s); + putenv(s); + } + } + if ((s = hash_get(L->options, "trace_out"))) { + unless (getenv("L_TRACE_OUT")) { + s = cksprintf("L_TRACE_OUT=%s", s); + putenv(s); + } + } + if ((s = hash_get(L->options, "fnhook"))) { + unless (getenv("L_TRACE_HOOK")) { + s = cksprintf("L_TRACE_HOOK=%s", s); + putenv(s); + } + } + if ((s = hash_get(L->options, "fntrace"))) { + unless (getenv("L_TRACE_ALL")) { + s = cksprintf("L_TRACE_ALL=%s", s); + putenv(s); + } + } + if ((s = hash_get(L->options, "dis"))) { + unless (getenv("L_DISASSEMBLE")) { + s = cksprintf("L_DISASSEMBLE=%s", s); + putenv(s); + } + } + + /* This allows the old comparison-op syntax (eq ne lt le gt ge). */ + if (getenv("_L_ALLOW_EQ_OPS")) { + hash_put(L->options, "allow_eq_ops", "yes"); + } + + return (compile_script(objv[objc-1], ((Interp *)L->interp)->scriptFile)); +} + +private int +compile_trace_script(char *script) +{ + int len, ret; + Tcl_Channel chan; + Tcl_Obj *nameObj, *scriptObj; + + len = strlen(script); + if ((len > 3) && (script[len-2] == '.') && (script[len-1] == 'l')) { + nameObj = Tcl_NewStringObj(script, -1); + Tcl_IncrRefCount(nameObj); + chan = Tcl_FSOpenFileChannel(L->interp, nameObj, "r", 0644); + unless (chan) return (TCL_ERROR); + scriptObj = Tcl_NewObj(); + Tcl_IncrRefCount(scriptObj); + ret = Tcl_ReadChars(chan, scriptObj, -1, 0); + Tcl_Close(L->interp, chan); + if (ret < 0) { + Tcl_DecrRefCount(scriptObj); + return (TCL_ERROR); + } + } else { + nameObj = Tcl_NewStringObj("L_TRACE_SCRIPT", -1); + scriptObj = Tcl_ObjPrintf( + "void L_fn_hook(_argused int pre, _argused poly av[], " + "_argused poly ret) { %s ;}", + script); + hash_put(L->options, "fnhook", "L_fn_hook"); + Tcl_IncrRefCount(nameObj); + } + ret = compile_script(scriptObj, nameObj); + Tcl_DecrRefCount(nameObj); + return (ret); +} + +private int +compile_script(Tcl_Obj *scriptObj, Tcl_Obj *nameObj) +{ + int ret; + Ast *ast; +#ifdef TCL_COMPILE_DEBUG + char *s; +#endif + + L->script = Tcl_NewObj(); + Tcl_IncrRefCount(L->script); + L->script_len = 0; + + ret = parse_script(TclGetString(scriptObj), &ast, nameObj); + + if ((ret == TCL_OK) && ast) { + ret = ast_compile(ast); + } + +#ifdef TCL_COMPILE_DEBUG + if ((s = getenv("L_TRACE_BYTECODES"))) { + extern int tclTraceExec; + tclTraceExec = atoi(s); + } +#endif + return (ret); +} + +/* + * Parse key=val (where =val is optional and is replaced by "yes" if + * omitted) and add to the L->options hash. Strip any leading -'s from + * key so that -key and --key both work. Replace all other -'s with _'s + * so that --trace-files becomes trace_files. + */ +private int +parse_options(int objc, Tcl_Obj **objv, char *allowed[]) +{ + int i, ret = TCL_OK; + char *key, *newkey, *p, *val; + char **q; + + for (i = 0; i < objc; ++i) { + key = Tcl_GetString(objv[i]); + unless (key[0] == '-') break; + /* Look for key=val */ + val = strchr(key, '='); + if (val) { + *val = 0; + } + newkey = ckalloc(strlen(key)+1); + /* Skip past all leading -'s in the key */ + while (*key == '-') ++key; + /* Now copy except replace all other -'s with _ */ + for (p = newkey; *key; ++key, ++p) { + *p = *key; + if (*p == '-') *p = '_'; + } + *p = 0; + key = newkey; + for (q = allowed; *q; ++q) { + if (!strcmp(key, *q)) break; + } + unless (*q) { + L_errf(NULL, "illegal option '%s'", + Tcl_GetString(objv[i])); + ret = TCL_ERROR; + } + if (val) { + hash_put(L->options, key, val+1); + *val = '='; + } else { + hash_put(L->options, key, "yes"); + } + } + return (ret); +} + +/* + * Parse an L script into an AST. Parsing and compiling are broken into two + * stages in order to support an interactive mode that parses many times + * before finally compiling. + */ +private int +parse_script(char *str, Ast **ast_p, Tcl_Obj *nameObj) +{ + char *prepend, *s; + void *lex_buffer; + + L_typeck_init(); + + if (nameObj) { + L->file = ckstrdup(Tcl_GetString(nameObj)); + L->dir = L_dirname(L->file); + } else { + char *cwd = getcwd(NULL, 0); + L->file = ckstrdup("<stdin>"); + L->dir = ckstrdup(cwd); + free(cwd); + } + + /* + * Calculate the starting line # from the --line and --lineadj + * cmd-line options and inject a #line directive at the start + * of the source code. This communicates the file-relative + * line # to code elsewhere that prints run-time error + * messages. + */ + if ((s = getenv("_L_LINE"))) { + L->line = strtoul(s, NULL, 10); + } else { + if ((s = hash_get(L->options, "line"))) { + L->line = atoi(s); + } else { + L->line = 1; + } + if ((s = hash_get(L->options, "lineadj"))) { + L->line += atoi(s); + } + } + prepend = cksprintf("#line %d\n", L->line); + str = cksprintf("%s%s", prepend, str); + + L->token_off = 0; + L->prev_token_off = 0; + L->prev_token_len = 0; + L->errs = NULL; + L_lex_start(); + lex_buffer = (void *)L__scan_bytes(str, strlen(str)); + + L_parse(); + ASSERT(ast_p); + *ast_p = L->ast; + + L__delete_buffer(lex_buffer); + ckfree(str); + ckfree(prepend); + + if (L->errs) { + Tcl_SetObjResult(L->interp, L->errs); + return (TCL_ERROR); + } + return (TCL_OK); +} + +/* Compile an L AST into Tcl ByteCodes. The envPtr may be NULL. */ +private int +ast_compile(void *ast) +{ + int ret = TCL_OK; + TopLev *toplev; + static int ctr = 0; + + ASSERT(((Ast *)ast)->type == L_NODE_TOPLEVEL); + + L->toplev = cksprintf("%d%%l_toplevel", ctr++); + + init_predefined(); // set the L pre-defined identifiers + + /* + * Two frames get pushed, one for private globals that exist + * at file scope, and one for the top-level code. See the + * comment in sym_store(). + */ + frame_push(NULL, NULL, SCRIPT|SEARCH); + frame_push(NULL, L->toplev, FUNC|TOPLEV|SKIP); + + /* + * Before compiling, enter prototypes for all functions into + * the global symbol table. + */ + for (toplev = (TopLev *)ast; toplev; toplev = toplev->next) { + switch (toplev->kind) { + case L_TOPLEVEL_FUN: + compile_fnDecl(toplev->u.fun, FN_PROTO_ONLY); + break; + default: + break; + } + } + + for (toplev = (TopLev *)ast; toplev; toplev = toplev->next) { + switch (toplev->kind) { + case L_TOPLEVEL_CLASS: + compile_clsDecl(toplev->u.class); + break; + case L_TOPLEVEL_FUN: + compile_fnDecl(toplev->u.fun, FN_PROTO_AND_BODY); + break; + case L_TOPLEVEL_GLOBAL: + compile_varDecls(toplev->u.global); + break; + case L_TOPLEVEL_STMT: + compile_stmts(toplev->u.stmt); + break; + default: + L_bomb("Unexpected toplevel stmt type %d", toplev->kind); + } + } + + /* If main() was defined, emit a %%call_main_if_defined call. */ + if (sym_lookup(mkId("main"), L_NOWARN)) { + if (hash_get(L->options, "warn_undefined_fns")) { + push_lit("%%check_L_fns"); + emit_invoke(1); + } + push_lit("%%call_main_if_defined"); + emit_invoke(1); + } + + push_lit(""); + TclEmitOpcode(INST_DONE, L->frame->envPtr); + frame_pop(); + frame_pop(); + + if (L->errs) { + Tcl_SetObjResult(L->interp, L->errs); + return (TCL_ERROR); + } + + if (hash_get(L->options, "norun") || (L->err && !getenv("_L_TEST"))) { + /* Still check for undefined functions if requested. */ + if (hash_get(L->options, "warn_undefined_fns") && + sym_lookup(mkId("main"), L_NOWARN)) { + if (L->frame->envPtr) { + push_lit("%%check_L_fns"); + emit_invoke(1); + } else { + Tcl_Eval(L->interp, "%%check_L_fns"); + } + } + return (TCL_OK); + } + + /* Invoke the top-level code that was just compiled. */ + if (L->frame->envPtr) { + push_lit("LtraceInit"); + emit_invoke(1); + push_lit(L->toplev); + emit_invoke(1); + } else { + if (Tcl_GetVar(L->interp, "::L_libl_done", 0)) { + ret = Tcl_Eval(L->interp, "LtraceInit"); + } + if (ret == TCL_OK) ret = Tcl_Eval(L->interp, L->toplev); + } + return (ret); +} + +private void +init_predefined() +{ +#define SET_INT(name, val) \ + Tcl_SetVar2Ex(L->interp, (name), NULL, Tcl_NewIntObj(val), \ + TCL_GLOBAL_ONLY) + + /* + * These are flags used by compile_spawn_system() when + * compiling calls to libl.tcl's system_(). Pre-define them as L + * variables so that system_() in lib L can see their values. + */ + SET_INT("SYSTEM_ARGV__", SYSTEM_ARGV); + SET_INT("SYSTEM_IN_STRING__", SYSTEM_IN_STRING); + SET_INT("SYSTEM_IN_ARRAY__", SYSTEM_IN_ARRAY); + SET_INT("SYSTEM_IN_FILENAME__", SYSTEM_IN_FILENAME); + SET_INT("SYSTEM_IN_HANDLE__", SYSTEM_IN_HANDLE); + SET_INT("SYSTEM_OUT_STRING__", SYSTEM_OUT_STRING); + SET_INT("SYSTEM_OUT_ARRAY__", SYSTEM_OUT_ARRAY); + SET_INT("SYSTEM_OUT_FILENAME__", SYSTEM_OUT_FILENAME); + SET_INT("SYSTEM_OUT_HANDLE__", SYSTEM_OUT_HANDLE); + SET_INT("SYSTEM_ERR_STRING__", SYSTEM_ERR_STRING); + SET_INT("SYSTEM_ERR_ARRAY__", SYSTEM_ERR_ARRAY); + SET_INT("SYSTEM_ERR_FILENAME__", SYSTEM_ERR_FILENAME); + SET_INT("SYSTEM_ERR_HANDLE__", SYSTEM_ERR_HANDLE); + SET_INT("SYSTEM_BACKGROUND__", SYSTEM_BACKGROUND); + +#undef SET_INT +} + +private void +compile_clsDecl(ClsDecl *clsdecl) +{ + ASSERT(clsdecl->constructors); + ASSERT(clsdecl->destructors); + + /* + * A class creates two scopes, one for the class symbols and + * the other for its top-level code (class variable + * initializers). See the comments in sym_store(). The class + * symtab is persisted so it can be later retrieved from the + * class type to support obj->var or classname->var lookups. + */ + frame_push(NULL, NULL, CLS_OUTER|SEARCH|KEEPSYMS); + clsdecl->symtab = L->frame->symtab; + frame_push(NULL, NULL, CLS_TOPLEV|SKIP); + L->frame->clsdecl = clsdecl; + + frame_resumePrologue(); + push_lit("::namespace"); + push_lit("eval"); + push_litf("::L::_class_%s", clsdecl->decl->id->str); + push_lit("variable __num 0"); + emit_invoke(4); + emit_pop(); + frame_resumeBody(); + + compile_varDecls(clsdecl->clsvars); + /* Process function decls first, then compile the bodies. */ + compile_fnDecls(clsdecl->fns, FN_PROTO_ONLY); + compile_fnDecls(clsdecl->constructors, FN_PROTO_ONLY); + compile_fnDecls(clsdecl->destructors, FN_PROTO_ONLY); + compile_fnDecls(clsdecl->constructors, FN_PROTO_AND_BODY); + compile_fnDecls(clsdecl->destructors, FN_PROTO_AND_BODY); + compile_fnDecls(clsdecl->fns, FN_PROTO_AND_BODY); + + frame_pop(); + frame_pop(); +} + +/* + * Take an expr list consisting of + * + * id like the arg to "#pragma fntrace" + * id=constant like the arg to "#pragma fnhook=myhook" + * + * and add hash entries to the given hash. The id's here aren't taken + * as variables, but the name of the id itself is used, to avoid + * making the programmer put everything inside quotes. This is used + * for #pragmas and function attributes. + */ +void +L_compile_attributes(Tcl_Obj *hash, Expr *expr, char *allowed[]) +{ + Expr *arg; + char *key, *val; + char **p; + + ASSERT(hash); + for (arg = expr; arg; arg = arg->next) { + if (arg->kind == L_EXPR_ID) { + key = arg->str; + val = "yes"; + } else if ((arg->kind == L_EXPR_BINOP) && + (arg->op == L_OP_EQUALS)) { + key = arg->a->str; + val = arg->b->str; + unless (isconst(arg->b) || (arg->b->kind == L_EXPR_ID)) { + L_errf(arg, + "non-constant value for attribute %s", + key); + } + } else { + L_errf(arg, "illegal attribute; not id or id=constant"); + continue; + } + for (p = allowed; *p; ++p) { + if (!strcmp(key, *p)) break; + } + unless (*p) { + L_errf(expr, "illegal attribute '%s'", key); + } else { + hash_put(hash, key, val); + } + } +} + +private void +compile_fnDecls(FnDecl *fun, Decl_f flags) +{ + for (; fun; fun = fun->next) { + compile_fnDecl(fun, flags); + } +} + +private void +compile_fnDecl(FnDecl *fun, Decl_f flags) +{ + int i; + VarDecl *decl = fun->decl; + char *name = decl->id->str; + char *clsname = NULL; + ClsDecl *clsdecl = NULL; + Sym *self_sym = NULL; + Sym *sym; + + flags |= decl->flags; + + ASSERT(fun && decl); + ASSERT(!(flags & SCOPE_LOCAL)); + ASSERT(flags & (SCOPE_CLASS | SCOPE_GLOBAL | SCOPE_SCRIPT)); + ASSERT(flags & (DECL_FN | DECL_CLASS_FN)); + // DECL_CLASS_FN ==> DECL_PUBLIC | DECL_PRIVATE + ASSERT(!(flags & DECL_CLASS_FN) || + (flags & (DECL_PUBLIC | DECL_PRIVATE))); + ASSERT(flags & (FN_PROTO_ONLY | FN_PROTO_AND_BODY)); + + /* + * Sort out the possible error cases: + * + * - main() declared with wrong types for formals + * - name illegal + * - name already declared as a variable + * - proto already declared and doesn't match this decl + * - this decl declares function body but body already declared + */ + if (!strcmp(name, "main")) L_typeck_main(decl); + if (name[0] == '_') { + L_errf(decl->id, "function names cannot begin with _"); + } + if (!strcmp(name, "END")) { + L_errf(decl->id, "cannot use END for function name"); + } else if (!strcmp(name, "undef")) { + L_errf(decl->id, "cannot use undef for function name"); + } + for (i = 0; i < sizeof(builtins)/sizeof(builtins[0]); ++i) { + if (!strcmp(builtins[i].name, name)) { + L_errf(decl->id, + "function '%s' conflicts with built-in", + name); + return; + } + } + sym = sym_lookup(decl->id, L_NOWARN|L_NOTUSED); + if (sym) { + unless (sym->kind & L_SYM_FN) { + L_errf(fun, "%s already declared as a variable",name); + return; + } else if ((sym->kind & L_SYM_FNBODY) && fun->body) { + L_errf(fun, "function %s already declared", name); + return; + } else unless (L_typeck_same(decl->type, sym->type)) { + L_errf(fun, "does not match other declaration of %s", + name); + return; + } + } else { + sym = sym_store(decl); + unless (sym) return; + } + + /* Check arg and return types for legality. */ + L_typeck_declType(decl); + + if (!fun->body || (flags & FN_PROTO_ONLY)) return; + + /* + * Add this function's attributes to the hash of all declared + * functions in L->fn_decls which is put into the Tcl global + * variable L_fnsDeclared, for use by the function-tracing + * subsystem code in libl.tcl when tracing is enabled. + */ + L_compile_attributes(fun->attrs, decl->attrs, L_attrs_attribute); + if (flags & FN_PROTO_AND_BODY) { + Tcl_Obj *key; + Var *arrayPtr, *varPtr; + + /* + * L->fn_decls can get out of date when the L code in + * lib L writes to L_fnsDeclared, so grab the latest. + */ + varPtr = TclLookupVar(L->interp, + "L_fnsDeclared", + NULL, + TCL_GLOBAL_ONLY, + NULL, + 0, + 0, + &arrayPtr); + if (L->fn_decls != varPtr->value.objPtr) { + L->fn_decls = varPtr->value.objPtr; + } + + hash_put(fun->attrs, "name", name); + hash_put(fun->attrs, "file", basenm(fun->node.loc.file)); + if (Tcl_IsShared(L->fn_decls)) { + L->fn_decls = Tcl_DuplicateObj(L->fn_decls); + Tcl_SetVar2Ex(L->interp, "L_fnsDeclared", NULL, + L->fn_decls, TCL_GLOBAL_ONLY); + } + key = Tcl_NewStringObj(sym->tclname, -1); + Tcl_IncrRefCount(key); + Tcl_DictObjPut(L->interp, L->fn_decls, key, fun->attrs); + Tcl_DecrRefCount(key); + } + + frame_push(fun, sym->tclname, FUNC|SEARCH); + sym->kind |= L_SYM_FNBODY; + L->frame->block = (Ast *)fun; + + compile_fnParms(decl); + + /* Gather class decl and name, for class member functions. */ + clsdecl = fun->decl->clsdecl; + if (clsdecl) clsname = clsdecl->decl->id->str; + + /* + * For private class member fns and the constructor, declare + * the local variable "self". For public member fns, lookup + * "self" which is required to be the first parameter (and is + * added by compile_fnParms if not present). + */ + if (isClsConstructor(decl) || isClsFnPrivate(decl)) { + self_sym = sym_mk("self", + clsdecl->decl->type, + SCOPE_LOCAL | DECL_LOCAL_VAR); + ASSERT(self_sym && self_sym->idx >= 0); + self_sym->used_p = TRUE; + } else if (isClsFnPublic(decl)) { + self_sym = sym_lookup(mkId("self"), L_NOWARN); + ASSERT(self_sym && self_sym->idx >= 0); + } + + /* + * For a constructor, before compiling the user's + * constructor body, emit code to increment the class instance + * #, set "self" to the namespace name of the class instance, + * create the namespace, then compile the instance-variable + * initializers. Basically this: + * + * incrStkImm ::L::_class_<cls_name>::__num + * set self ::L::_instance_<cls_name>${__num} + * namespace eval $self {} + * ...instance variable initializers... + * ...user's constructor body... + */ + if (isClsConstructor(decl)) { + frame_resumePrologue(); + ASSERT(clsdecl && clsname && self_sym); + push_litf("::L::_class_%s::__num", clsname); + TclEmitInstInt1(INST_INCR_STK_IMM, 1, L->frame->envPtr); + emit_pop(); + push_lit("::namespace"); + push_lit("eval"); + push_litf("::L::_instance_%s", clsname); + push_litf("::L::_class_%s::__num", clsname); + TclEmitOpcode(INST_LOAD_STK, L->frame->envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + emit_store_scalar(self_sym->idx); + push_lit(""); + emit_invoke(4); + emit_pop(); + frame_resumeBody(); + compile_varDecls(clsdecl->instvars); + } + + /* + * For private member functions, upvar "self" to the "self" in + * the calling frame. This works because only other class member + * functions can call private member functions, and they have "self". + */ + if (isClsFnPrivate(decl)) { + frame_resumePrologue(); + push_lit("1"); + push_lit("self"); + TclEmitInstInt4(INST_UPVAR, self_sym->idx, L->frame->envPtr); + emit_pop(); + frame_resumeBody(); + } + + L->enclosing_func = fun; + L->enclosing_func_frame = L->frame; + compile_block(fun->body); + L->enclosing_func = NULL; + L->enclosing_func_frame = NULL; + + /* + * Emit a "fall off the end" implicit return for void + * functions. Class constructors return the value of "self". + * Non-void functions throw an exception if you fall + * off the end. + */ + if (isClsConstructor(decl)) { + emit_load_scalar(self_sym->idx); + } else if (isvoidtype(decl->type->base_type)) { + push_lit(""); + } else { + push_lit("::throw"); + push_lit("{FUNCTION NO-RETURN-VALUE " + "{no value returned from function}}"); + push_lit("no value returned from function"); + emit_invoke(3); + } + + /* + * Fix-up the return jmps so that all return stmts jump to here. + * The return value will already be on the run-time stack. + */ + fixup_jmps(&L->frame->ret_jmps); + + /* + * For class destructor, delete the instance namespace. + */ + if (isClsDestructor(decl)) { + ASSERT(self_sym); + push_lit("::namespace"); + push_lit("delete"); + emit_load_scalar(self_sym->idx); + emit_invoke(3); + emit_pop(); + } + + TclEmitOpcode(INST_DONE, L->frame->envPtr); + + frame_pop(); +} + +/* + * Push a semantic-stack frame. If flags & FUNC, start a new proc + * too. To support the delayed generation of proc prologue code, we + * allocate two CompileEnv's, one for the proc body and one for its + * prologue. You switch between the two with frame_resumePrologue() + * and frame_resumeBody(). A jump is emitted at the head of the proc + * that jumps to the end, and when the proc is done being compiled, + * the prologue code is emitted at the end along with a jump back. + * This provides a way to lazily output proc initialization code, such + * as the upvars for accessing globals and class variables. + */ +private void +frame_push(void *node, char *name, Frame_f flags) +{ + Frame *frame; + Proc *proc; + CompileEnv *bodyEnvPtr, *prologueEnvPtr; + + frame = (Frame *)ckalloc(sizeof(Frame)); + memset(frame, 0, sizeof(*frame)); + frame->flags = flags; + frame->symtab = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(frame->symtab, TCL_STRING_KEYS); + frame->labeltab = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(frame->labeltab, TCL_STRING_KEYS); + frame->prevFrame = L->frame; + L->frame = frame; + + unless (frame->flags & FUNC) { + frame->block = node; + if (frame->prevFrame) { + frame->envPtr = frame->prevFrame->envPtr; + frame->bodyEnvPtr = frame->prevFrame->bodyEnvPtr; + frame->prologueEnvPtr = frame->prevFrame->prologueEnvPtr; + } + return; + } + + bodyEnvPtr = (CompileEnv *)ckalloc(sizeof(CompileEnv)); + prologueEnvPtr = (CompileEnv *)ckalloc(sizeof(CompileEnv)); + frame->bodyEnvPtr = bodyEnvPtr; + frame->prologueEnvPtr = prologueEnvPtr; + frame->envPtr = bodyEnvPtr; + + proc = (Proc *)ckalloc(sizeof(Proc)); + proc->iPtr = (struct Interp *)L->interp; + proc->refCount = 1; + proc->numArgs = 0; + proc->numCompiledLocals = 0; + proc->firstLocalPtr = NULL; + proc->lastLocalPtr = NULL; + proc->bodyPtr = Tcl_NewObj(); + Tcl_IncrRefCount(proc->bodyPtr); + TclInitCompileEnv(L->interp, bodyEnvPtr, TclGetString(L->script), + L->script_len, NULL, 0); + bodyEnvPtr->procPtr = proc; + + TclInitCompileEnv(L->interp, prologueEnvPtr, NULL, 0, NULL, 0); + + frame->proc = proc; + frame->name = name; + + /* + * Emit a jump to what will eventually be the prologue code + * (output by frame_pop()). + */ + frame->end_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + frame->proc_top = currOffset(frame->envPtr); +} + +private void +frame_resumePrologue() +{ + L->frame->envPtr = L->frame->prologueEnvPtr; +} + +private void +frame_resumeBody() +{ + L->frame->envPtr = L->frame->bodyEnvPtr; +} + +private void +frame_pop() +{ + int off; + Frame *frame = L->frame; + Proc *proc = frame->proc; + Sym *sym; + Label *label; + ByteCode *codePtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + /* + * Emit proc prologue code and the jump back to the head of + * the proc. Splice in any code in the frame->prologueEnvPtr + * CompileEnv. This is dependent on CompileEnv details. + */ + if (frame->flags & FUNC) { + CompileEnv *body = frame->bodyEnvPtr; + CompileEnv *prologue = frame->prologueEnvPtr; + int len = prologue->codeNext - prologue->codeStart; + + ASSERT(frame->envPtr == frame->bodyEnvPtr); + + fixup_jmps(&frame->end_jmp); + while ((body->codeNext + len) >= body->codeEnd) { + TclExpandCodeArray(body); + } + memcpy(body->codeNext, prologue->codeStart, len); + body->codeNext += len; + if (prologue->maxStackDepth > body->maxStackDepth) { + body->maxStackDepth = prologue->maxStackDepth; + } + off = currOffset(frame->envPtr); + TclEmitInstInt4(INST_JUMP4, frame->proc_top-off, frame->envPtr); + } + + /* + * Check for unused local symbols, and free the frame's symbol table. + */ + for (hPtr = Tcl_FirstHashEntry(frame->symtab, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + sym = (Sym *)Tcl_GetHashValue(hPtr); + unless (sym->used_p || !(sym->kind & L_SYM_LVAR) || + (sym->decl->flags & DECL_ARGUSED)) { + L_warnf(sym->decl, "%s unused", sym->name); + } + unless (frame->flags & KEEPSYMS) { + ckfree(sym->name); + ckfree(sym->tclname); + ckfree((char *)sym); + } + } + unless (frame->flags & KEEPSYMS) { + Tcl_DeleteHashTable(frame->symtab); + ckfree((char *)frame->symtab); + } + + /* + * Check for unresolved labels, and free the frame's label table. + */ + for (hPtr = Tcl_FirstHashEntry(frame->labeltab, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + label = (Label *)Tcl_GetHashValue(hPtr); + unless (label->offset >= 0) { + L_err("label %s referenced but not defined", + label->name); + } + ckfree((char *)label); + } + Tcl_DeleteHashTable(frame->labeltab); + ckfree((char *)frame->labeltab); + + /* + * Create the Tcl command and free the old frame. + */ + if (frame->flags & FUNC) { + TclInitByteCodeObj(proc->bodyPtr, frame->envPtr); + proc->cmdPtr = (Command *)Tcl_CreateObjCommand(L->interp, + frame->name, + TclObjInterpProc, + (ClientData)proc, + TclProcDeleteProc); + // Don't recompile on compileEpoch changes. + codePtr = (ByteCode *)proc->bodyPtr->internalRep.twoPtrValue.ptr1; + codePtr->flags |= TCL_BYTECODE_PRECOMPILED; + TclFreeCompileEnv(frame->bodyEnvPtr); + TclFreeCompileEnv(frame->prologueEnvPtr); + ckfree((char *)frame->bodyEnvPtr); + ckfree((char *)frame->prologueEnvPtr); + } + + L->frame = frame->prevFrame; + tmp_freeAll(frame->tmps); + ckfree((char *)frame); +} + +private Frame * +frame_find(Frame_f flags) +{ + Frame *f = L->frame; + + ASSERT(f); + while (f && !(f->flags & flags)) f = f->prevFrame; + return (f); +} + +private char * +frame_name() +{ + if (L->enclosing_func) { + return(L->enclosing_func->decl->id->str); + } else { + return(L->toplev); + } +} + +private void +compile_varInitializer(VarDecl *decl) +{ + int start_off = currOffset(L->frame->envPtr); + + unless (decl->initializer) { + decl->initializer = ast_mkBinOp(L_OP_EQUALS, + decl->id, + mkId("undef"), + decl->node.loc, + decl->node.loc); + } + compile_expr(decl->initializer, L_DISCARD); + track_cmd(start_off, decl); +} + +private void +compile_varDecl(VarDecl *decl) +{ + char *name; + Sym *sym; + + /* + * Process any declaration only once, but generate code for + * its initializers each time through here. This is for class + * constructors where the class instance variables get + * compiled once for each constructor. + */ + if (decl->flags & DECL_DONE) { + compile_varInitializer(decl); + return; + } + decl->flags |= DECL_DONE; + + ASSERT(decl->id && decl->type); + + name = decl->id->str; + + unless (L_typeck_declType(decl)) return; + + if (decl->flags & DECL_LOCAL_VAR) { + if (name[0] == '_') { + L_errf(decl, + "local variable names cannot begin with _"); + } + if (decl->flags & (DECL_PRIVATE | DECL_PUBLIC)) { + L_errf(decl, + "public/private qualifiers illegal for locals"); + decl->flags &= ~(DECL_PRIVATE | DECL_PUBLIC); + } + } + if (!strcmp(name, "END")) { + L_errf(decl, "cannot use END for variable name"); + return; + } else if (!strcmp(name, "undef")) { + L_errf(decl, "cannot use undef for variable name"); + return; + } + if ((decl->type->kind == L_CLASS) && + !strcmp(name, decl->type->u.class.clsdecl->decl->id->str)) { + L_errf(decl, "cannot declare object with same name as class"); + } + + sym = sym_store(decl); + unless (sym) return; // bail if multiply declared + + if (decl->flags & DECL_EXTERN) { + if (decl->initializer) { + L_errf(decl, "extern initializers illegal"); + } + unless (L->frame->flags & TOPLEV) { + L_errf(decl, "externs legal only at global scope"); + } + sym->used_p = TRUE; // to suppress extraneous warning + return; + } + + compile_varInitializer(decl); + + /* Mark var as unused even though it was just initialized. */ + sym->used_p = FALSE; +} + +private void +compile_varDecls(VarDecl *decls) +{ + for (; decls; decls = decls->next) { + compile_varDecl(decls); + } +} + +private void +compile_stmt(Stmt *stmt) +{ + int start_off = currOffset(L->frame->envPtr); + + unless (stmt) return; + switch (stmt->kind) { + case L_STMT_BLOCK: + frame_push(stmt, NULL, SEARCH); + compile_block(stmt->u.block); + frame_pop(); + break; + case L_STMT_EXPR: + compile_exprs(stmt->u.expr, L_DISCARD); + break; + case L_STMT_COND: + compile_ifUnless(stmt->u.cond); + break; + case L_STMT_LOOP: + compile_loop(stmt->u.loop); + break; + case L_STMT_SWITCH: + compile_switch(stmt->u.swich); + break; + case L_STMT_FOREACH: + compile_foreach(stmt->u.foreach); + break; + case L_STMT_RETURN: + compile_return(stmt); + break; + case L_STMT_BREAK: + compile_break(stmt); + break; + case L_STMT_CONTINUE: + compile_continue(stmt); + break; + case L_STMT_LABEL: + compile_label(stmt); + break; + case L_STMT_GOTO: + compile_goto(stmt); + break; + case L_STMT_TRY: + compile_trycatch(stmt); + break; + default: + L_bomb("Malformed AST in compile_stmt"); + } + switch (stmt->kind) { + case L_STMT_BLOCK: + case L_STMT_COND: + case L_STMT_EXPR: + case L_STMT_TRY: + break; + default: + track_cmd(start_off, stmt); + break; + } +} + +private void +compile_stmts(Stmt *stmts) +{ + for (; stmts; stmts = stmts->next) { + compile_stmt(stmts); + } +} + +private void +compile_trycatch(Stmt *stmt) +{ + int range; + int msg_idx = -1; + Jmp *jmp; + Try *try = stmt->u.try; + Expr *msg = try->msg; + + if (msg) { + unless (msg->op == L_OP_ADDROF) { + L_errf(msg, "expected catch(&variable)"); + return; + } + compile_expr(msg, L_DISCARD); + if (msg->a->sym) { + msg_idx = msg->a->sym->idx; + } else { + L_errf(msg->a, "illegal operand to &"); + } + } + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, L->frame->envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, L->frame->envPtr); + + /* + * Emit separate INST_END_CATCH's for the non-error and error + * paths so that a return can be done inside of a catch() + * clause -- the "try" is done when the body finishes without + * error or by the time the catch() is entered. + */ + + /* body */ + ExceptionRangeStarts(L->frame->envPtr, range); + compile_stmts(try->try); + ExceptionRangeEnds(L->frame->envPtr, range); + TclEmitOpcode(INST_END_CATCH, L->frame->envPtr); + jmp = emit_jmp_fwd(INST_JUMP4, 0); + + /* error case */ + ExceptionRangeTarget(L->frame->envPtr, range, catchOffset); + if (msg_idx != -1) { + TclEmitOpcode(INST_PUSH_RESULT, L->frame->envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, msg_idx, L->frame->envPtr); + TclEmitOpcode(INST_POP, L->frame->envPtr); + } + TclEmitOpcode(INST_END_CATCH, L->frame->envPtr); + compile_stmts(try->catch); + + /* out */ + fixup_jmps(&jmp); +} + +private void +compile_block(Block *block) +{ + compile_varDecls(block->decls); + compile_stmts(block->body); +} + +private void +compile_return(Stmt *stmt) +{ + VarDecl *decl; + Type *ret_type; + + /* Handle return from the top level. */ + unless (L->enclosing_func) { + if (stmt->u.expr) { + compile_expr(stmt->u.expr, L_PUSH_VAL); + } else { + push_lit(""); + } + TclEmitOpcode(INST_DONE, L->frame->envPtr); + return; + } + + decl = L->enclosing_func->decl; + ret_type = decl->type->base_type; + + if (isvoidtype(ret_type) && (stmt->u.expr)) { + L_errf(stmt, "void function cannot return value"); + compile_expr(stmt->u.expr, L_DISCARD); + } else if (stmt->u.expr) { + compile_expr(stmt->u.expr, L_PUSH_VAL); // return value + unless (L_typeck_compat(ret_type, stmt->u.expr->type)) { + L_errf(stmt, "incompatible return type"); + } + } else unless (isvoidtype(ret_type)) { + L_errf(stmt, "must specify return value"); + } else { + push_lit(""); // no return value -- push a "" + } + + /* Jmp to the function end where any necessary clean-up code is. */ + ASSERT(L->enclosing_func_frame); + L->enclosing_func_frame->ret_jmps = + emit_jmp_fwd(INST_JUMP4, L->enclosing_func_frame->ret_jmps); +} + +private void +proc_mkArg(Proc *proc, VarDecl *decl) +{ + int argnum; + char *name = decl->id->str; + CompiledLocal *local; + + argnum = proc->numArgs++; + ++proc->numCompiledLocals; + local = (CompiledLocal *)ckalloc(sizeof(CompiledLocal) - + sizeof(local->name) + + strlen(name) + 1); + if (proc->firstLocalPtr == NULL) { + proc->firstLocalPtr = local; + proc->lastLocalPtr = local; + } else { + proc->lastLocalPtr->nextPtr = local; + proc->lastLocalPtr = local; + } + local->nextPtr = NULL; + local->resolveInfo = NULL; + local->defValuePtr = NULL; + local->frameIndex = argnum; + local->nameLength = strlen(name); + strcpy(local->name, name); + + local->flags = VAR_ARGUMENT; + if (decl->flags & DECL_REST_ARG) local->flags |= VAR_IS_ARGS; + if (decl->flags & DECL_OPTIONAL) { + if (isnameoftype(decl->type)) { + local->defValuePtr = + Tcl_NewStringObj("::L_undef_ref_parm_", -1); + local->defValuePtr->undef = 1; + } else { + local->defValuePtr = *L_undefObjPtrPtr(); + } + Tcl_IncrRefCount(local->defValuePtr); + } +} + +/* + * Determine whether the parameter-passing mode for a formal parameter + * declaration is call-by-reference. Return NULL or the base type of + * the parameter (without the name-of). You get call-by-reference if + * the parameter was declared with & and is not a function pointer. + */ +private Type * +iscallbyname(VarDecl *formal) +{ + unless (formal) return (NULL); + if (formal->flags & DECL_REF) { + if (isfntype(formal->type->base_type)) { + return (NULL); + } else { + return (formal->type->base_type); + } + } + return (NULL); +} + +private int +compile_fnParms(VarDecl *decl) +{ + int n; + int name_parms = 0; + char *name; + Proc *proc = L->frame->envPtr->procPtr; + Expr *varId; + VarDecl *p, *varDecl; + Sym *parmSym, *varSym; + Type *type; + VarDecl *param = decl->type->u.func.formals; + + proc->numArgs = 0; + proc->numCompiledLocals = 0; + + /* + * Public class member fns (except constructor) must have "self" + * as the first arg and it must be of the class type. + */ + if (isClsFnPublic(decl) && !isClsConstructor(decl)) { + Type *clstype = decl->clsdecl->decl->type; + Expr *self_id; + VarDecl *self_decl; + unless (param && param->id && isid(param->id, "self")) { + L_errf(decl->id, "class public member function lacks " + "'self' as first arg"); + /* Add it so we can keep compiling. */ + self_id = mkId("self"); + self_decl = ast_mkVarDecl(clstype, self_id, + decl->node.loc, + decl->node.loc); + self_decl->flags = SCOPE_LOCAL | DECL_LOCAL_VAR; + self_decl->next = param; + param = self_decl; + } else unless (L_typeck_same(param->type, clstype)) { + L_errf(param, "'self' parameter must be of class type"); + } + } + + /* + * To handle call-by-name formals, make two passes through the + * formals list. In the first pass, mangle any formal name to + * "&name". In the second pass, for formals only, create a + * local "name" as an upvar to the variable one frame up whose + * name is passed in the arg. Note that the formal will have + * type "name-of <t>" and the local gets type <t>. This is + * needed since Tcl requires the locals to follow the args. + */ + for (p = param, n = 0; p; p = p->next, n++) { + unless (p->id) { + L_errf(p, "formal parameter #%d lacks a name", n+1); + name = cksprintf("unnamed-arg-%d", n+1); + p->id = mkId(name); + ckfree(name); + } + if (isClsConstructor(decl) && isid(p->id, "self")) { + L_errf(p, + "'self' parameter illegal in class constructor"); + continue; + } + if (isClsFnPrivate(decl) && isid(p->id, "self")) { + L_errf(p, + "'self' parameter illegal in private function"); + continue; + } + if ((p->flags & DECL_REST_ARG) && (p->next)) { + L_errf(p, "Rest parameter must be last"); + } + if ((p->flags & DECL_OPTIONAL) && (p->next)) { + L_errf(p, "_optional parameter must be last"); + } + if (typeis(p->type, "FMT") && + (!p->next || !(p->next->flags & DECL_REST_ARG))) { + L_errf(p, "rest argument must follow FMT"); + } + if (iscallbyname(p)) { + name = cksprintf("&%s", p->id->str); + ckfree(p->id->str); + p->id->str = name; + ++name_parms; + } + proc_mkArg(proc, p); + parmSym = sym_store(p); + unless (parmSym) continue; // multiple declaration + parmSym->idx = n; + /* Suppress unused warning for obj arg to class member fns. */ + if ((p == param) && + isClsFnPublic(decl) && !isClsConstructor(decl)) { + parmSym->used_p = TRUE; + } + } + /* For call by name, push a 1 the first time (arg to INST_UPVAR). */ + if (name_parms) push_lit("1"); + /* + * For each call-by-reference formal, we have + * "&var" - a fn parm that gets the name of the caller's actual parm + * "var" - a local upvar'd to this name, becomes alias for the actual + * The first was created above. Create the second one now. + */ + for (p = param; p; p = p->next) { + unless (type = iscallbyname(p)) continue; + + /* Lookup "&var". */ + parmSym = sym_lookup(p->id, L_NOWARN); + ASSERT(parmSym && (p->id->str[0] == '&')); + + /* Create "var". */ + varId = ast_mkId(p->id->str + 1, // point past the & + p->id->node.loc, + p->id->node.loc); + varDecl = ast_mkVarDecl(type, varId, p->node.loc, p->node.loc); + varDecl->flags = SCOPE_LOCAL | DECL_LOCAL_VAR | p->flags; + varDecl->node.loc.line = p->node.loc.line; + unless (varSym = sym_store(varDecl)) continue; // multiple decl + varSym->decl->refsym = parmSym; + emit_load_scalar(parmSym->idx); + TclEmitInstInt4(INST_UPVAR, varSym->idx, L->frame->envPtr); + } + /* Pop the 1 pushed for INST_UPVAR. */ + if (name_parms) emit_pop(); + return (n); +} + +private int +compile_rename(Expr *expr) +{ + int n; + + push_lit("frename_"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n == 2) { + L_errf(expr, "incorrect # args for rename"); + } + emit_invoke(3); + expr->type = L_int; + return (1); // stack effect +} + +private int +compile_split(Expr *expr) +{ + int n; + Expr *str = NULL, *lim = NULL, *sep = NULL; + Expr_f flags = 0; + + expr->type = L_poly; // for err return path + n = compile_exprs(expr->b, L_PUSH_VAL); + ASSERT(n > 0); // grammar ensures this + if (n > 3) { + L_errf(expr, "too many args to split"); + return (0); + } + switch (n) { + case 1: // split(<str>) + str = expr->b; + break; + case 2: // split(/re/, <str>) + sep = expr->b; + str = sep->next; + break; + case 3: // split(/re/, <str>, <lim>) + sep = expr->b; + str = sep->next; + lim = str->next; + break; + } + unless (istype(str, L_STRING|L_WIDGET|L_POLY)) { + L_errf(str, "expression to split must be string"); + } + if (sep) { + unless (isregexp(sep)) { + L_errf(sep, "split delimiter must be a " + "regular expression"); + } + if (sep->flags & ~(L_EXPR_RE_T | L_EXPR_RE_I)) { + L_errf(sep, "illegal regular expression modifier"); + } + flags |= L_SPLIT_RE | sep->flags; + } + if (lim) { + flags |= L_SPLIT_LIM; + unless (isint(lim)) { + L_errf(expr, "third arg to split must be integer"); + return (0); + } + } + TclEmitInstInt4(INST_L_SPLIT, flags, L->frame->envPtr); + TclAdjustStackDepth(n-1, L->frame->envPtr); + expr->type = type_mkArray(0, L_string); + return (1); // stack effect +} + +private int +compile_push(Expr *expr) +{ + int flags = 0, i, idx; + Expr *arg, *array; + Type *base_type; + Tmp *tmp; + + expr->type = L_void; + unless (expr->b && expr->b->next) { + L_errf(expr, "too few arguments to push"); + return (0); + } + unless (isaddrof(expr->b)) { + L_errf(expr, "first arg to push not an array reference (&)"); + return (0); + } + ASSERT(expr->b->a); + array = expr->b->a; + arg = expr->b->next; + compile_expr(array, L_PUSH_PTR | L_LVALUE); + unless (isarray(array) || ispoly(array)) { + L_errf(expr, + "first arg to push not an array reference (&)"); + return (0); + } + unless (array->sym) { + L_errf(expr, "invalid l-value in push"); + return (0); + } + idx = array->sym->idx; // local slot # for array + if (isarray(array)) { + base_type = array->type->base_type; + } else { + base_type = L_poly; + } + if (arg->next) { + /* Build up a list of the args to push. */ + tmp = tmp_get(TMP_REUSE); + push_lit(""); + emit_store_scalar(tmp->idx); + emit_pop(); + for (i = 2; arg; arg = arg->next, ++i) { + compile_expr(arg, L_PUSH_VAL); + /* We allow base_type or an array of base_type. */ + if (L_typeck_compat(base_type, arg->type)) { + flags = L_INSERT_ELT; + } else if (L_typeck_compat(array->type, arg->type)) { + flags = L_INSERT_LIST; + } else { + L_errf(expr, "arg #%d to push has type " + "incompatible with array", i); + } + push_lit("-1"); // -1 means append + TclEmitInstInt4(INST_L_LIST_INSERT, tmp->idx, + L->frame->envPtr); + TclEmitInt4(flags, L->frame->envPtr); + } + emit_load_scalar(tmp->idx); + tmp_free(tmp); + flags = L_INSERT_LIST; + } else { + compile_expr(arg, L_PUSH_VAL); + /* We allow base_type or an array of base_type. */ + if (L_typeck_compat(base_type, arg->type)) { + flags = L_INSERT_ELT; + } else if (L_typeck_compat(array->type, arg->type)) { + flags = L_INSERT_LIST; + } else { + L_errf(expr, "arg #2 to push has type " + "incompatible with array"); + } + } + if (array->flags & L_EXPR_DEEP) { + // deep-ptr rval + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // rval deep-ptr + push_lit("-1"); // -1 means append + TclEmitInstInt4(INST_L_DEEP_WRITE, idx, + L->frame->envPtr); + TclEmitInt4(flags | L_DISCARD, L->frame->envPtr); + } else { + push_lit("-1"); // -1 means append + TclEmitInstInt4(INST_L_LIST_INSERT, idx, + L->frame->envPtr); + TclEmitInt4(flags, L->frame->envPtr); + } + return (0); // stack effect +} + +private int +compile_pop_shift(Expr *expr) +{ + int idx; + Expr *arg = NULL; + char *opNm = expr->a->str; + Expr *toDelete; + YYLTYPE loc; + + expr->type = L_poly; + unless (expr->b && !expr->b->next) { + L_errf(expr, "incorrect # arguments to %s", opNm); + return (0); + } + unless (isaddrof(expr->b)) { + L_errf(expr, "arg to %s not an array reference (&)", opNm); + return (0); + } + /* + * For pop, change arg from &arr to &arr[END] and then delete + * that element. For shift, use &arr[0]. + */ + ASSERT(expr->b->a); + loc = expr->b->a->node.loc; + if (!strcmp(opNm, "pop")) { + toDelete = mkId("END"); + } else { + toDelete = ast_mkConst(L_int, ckstrdup("0"), loc, loc); + } + arg = ast_mkBinOp(L_OP_ARRAY_INDEX, + expr->b->a, + toDelete, + loc, + loc); + expr->b->a = arg; + /* L_NEG_OK here permits indexing element -1 (array already empty). */ + compile_expr(arg, L_PUSH_PTR | L_DELETE | L_NEG_OK | L_LVALUE); + unless (isarray(arg->a) || ispoly(arg->a)) { + L_errf(expr, "arg to %s not an array reference (&)", opNm); + return (0); + } + unless (arg->sym) { + L_errf(expr, "invalid l-value in %s", opNm); + return (0); + } + idx = arg->sym->idx; // local slot # for array + TclEmitInstInt4(INST_L_DEEP_WRITE, idx, L->frame->envPtr); + TclEmitInt4(L_DELETE | L_PUSH_OLD, L->frame->envPtr); + TclAdjustStackDepth(1, L->frame->envPtr); + expr->type = arg->type; + return (1); // stack effect +} + +private int +compile_insert_unshift(Expr *expr) +{ + int flags, i, idx; + Expr *arg, *array, *index; + Type *base_type; + Tmp *argTmp = NULL, *idxTmp = NULL; + char *opNm = expr->a->str; + + /* + * Make unshift(arg1, arg2, ...) look like insert(arg1, "0", arg2, ...) + */ + if (!strcmp(opNm, "unshift")) { + if (expr->b) { + arg = ast_mkConst(L_int, ckstrdup("0"), expr->node.loc, + expr->node.loc); + arg->next = expr->b->next; + expr->b->next = arg; + } + i = 2; // where data args start + } else { + i = 3; // where data args start + } + + expr->type = L_void; + unless (expr->b && expr->b->next && expr->b->next->next) { + L_errf(expr, "too few arguments to %s", opNm); + return (0); + } + ASSERT(expr->b->a); + array = expr->b->a; + index = expr->b->next; + arg = expr->b->next->next; + unless (isaddrof(expr->b)) { + L_errf(expr, "first arg to %s not an array reference (&)", opNm); + return (0); + } + compile_expr(array, L_PUSH_PTR | L_LVALUE); + unless (isarray(array) || ispoly(array)) { + L_errf(expr, + "first arg to %s not an array reference (&)", opNm); + return (0); + } + unless (array->sym) { + L_errf(expr, "invalid l-value in %s", opNm); + return (0); + } + idx = array->sym->idx; // local slot # for array + if (isarray(array)) { + base_type = array->type->base_type; + } else { + base_type = L_poly; + } + + /* + * If >1 arg, concat them all into a temp and insert that. We + * can't just insert them one by one like we do in + * compile_push(), since that would insert them backwards. + * We could reverse the arg list, but building the temp is + * about as fast as re-indexing into the array for each element. + */ + if (arg->next) { + idxTmp = tmp_get(TMP_REUSE); + compile_expr(index, L_PUSH_VAL); + emit_store_scalar(idxTmp->idx); + emit_pop(); + unless (isint(index)) { + L_errf(expr, "second arg to %s not an int", opNm); + return (0); + } + argTmp = tmp_get(TMP_REUSE); + push_lit(""); + emit_store_scalar(argTmp->idx); + emit_pop(); + for (; arg; arg = arg->next, ++i) { + compile_expr(arg, L_PUSH_VAL); + /* For an arg, allow base_type or array of base_type. */ + unless (L_typeck_compat(base_type, arg->type) || + L_typeck_compat(array->type, arg->type)) { + L_errf(expr, "arg #%d to %s has type " + "incompatible with array", i, opNm); + } + if (isarray(arg) || islist(arg)) { + flags = L_INSERT_LIST; + } else { + flags = L_INSERT_ELT; + } + push_lit("-1"); // -1 means append + TclEmitInstInt4(INST_L_LIST_INSERT, argTmp->idx, + L->frame->envPtr); + TclEmitInt4(flags, L->frame->envPtr); + } + if (array->flags & L_EXPR_DEEP) { + emit_load_scalar(argTmp->idx); + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + emit_load_scalar(idxTmp->idx); + TclEmitInstInt4(INST_L_DEEP_WRITE, idx, + L->frame->envPtr); + TclEmitInt4(L_INSERT_LIST | L_DISCARD, + L->frame->envPtr); + } else { + emit_load_scalar(argTmp->idx); + emit_load_scalar(idxTmp->idx); + TclEmitInstInt4(INST_L_LIST_INSERT, idx, + L->frame->envPtr); + TclEmitInt4(L_INSERT_LIST, L->frame->envPtr); + } + } else { + compile_expr(arg, L_PUSH_VAL); + /* For the arg, we allow base_type or an array of base_type. */ + unless (L_typeck_compat(base_type, arg->type) || + L_typeck_compat(array->type, arg->type)) { + L_errf(expr, "arg #%d to %s has type incompatible " + "with array", i, opNm); + } + if (isarray(arg) || islist(arg)) { + flags = L_INSERT_LIST; + } else { + flags = L_INSERT_ELT; + } + if (array->flags & L_EXPR_DEEP) { + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + } + compile_expr(index, L_PUSH_VAL); + unless (isint(index)) { + L_errf(expr, "second arg to %s not an int", opNm); + return (0); + } + if (array->flags & L_EXPR_DEEP) { + TclEmitInstInt4(INST_L_DEEP_WRITE, idx, + L->frame->envPtr); + TclEmitInt4(flags | L_DISCARD, L->frame->envPtr); + } else { + TclEmitInstInt4(INST_L_LIST_INSERT, idx, + L->frame->envPtr); + TclEmitInt4(flags, L->frame->envPtr); + } + } + tmp_free(idxTmp); + tmp_free(argTmp); + return (0); // stack effect +} + +private void +compile_eq_stack(Expr *expr, Type *type) +{ + int i, top_off; + Tmp *itmp, *ltmp, *rtmp; + Jmp *out = NULL; + Jmp *out_false = NULL, *out_false2 = NULL, *out_true = NULL; + VarDecl *v; + + unless (type->kind & (L_ARRAY|L_STRUCT|L_HASH)) { + /* Scalar -- just need a single bytecode. */ + emit_instrForLOp(expr, type); + return; + } + + /* Put lhs and rhs into temps. */ + ltmp = tmp_get(TMP_REUSE); + rtmp = tmp_get(TMP_REUSE); + emit_store_scalar(rtmp->idx); + emit_pop(); + emit_store_scalar(ltmp->idx); + emit_pop(); + + switch (type->kind) { + case L_ARRAY: + itmp = tmp_get(TMP_UNSET); + /* + * if (length(lhs) != length(rhs)) goto out_false + * itmp = length(rhs) + * top_off: + * if (itmp == 0) goto out_true + * --itmp + * if (lhs[itmp] != rhs[itmp]) goto out_false + * goto top_off + * out_true: + * push 1 + * goto out + * out_false: + * push 0 + * out: + */ + emit_load_scalar(ltmp->idx); + TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr); + emit_load_scalar(rtmp->idx); + TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr); + emit_store_scalar(itmp->idx); + TclEmitOpcode(INST_EQ, L->frame->envPtr); + out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false); + top_off = currOffset(L->frame->envPtr); + emit_load_scalar(itmp->idx); + out_true = emit_jmp_fwd(INST_JUMP_FALSE4, out_true); + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, itmp->idx, + L->frame->envPtr); + TclEmitInt1(-1, L->frame->envPtr); + emit_pop(); + emit_load_scalar(ltmp->idx); + emit_load_scalar(itmp->idx); + TclEmitOpcode(INST_LIST_INDEX, L->frame->envPtr); + emit_load_scalar(rtmp->idx); + emit_load_scalar(itmp->idx); + TclEmitOpcode(INST_LIST_INDEX, L->frame->envPtr); + compile_eq_stack(expr, type->base_type); + out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false); + emit_jmp_back(TCL_UNCONDITIONAL_JUMP, top_off); + fixup_jmps(&out_true); + push_lit("1"); + out = emit_jmp_fwd(INST_JUMP1, out); + fixup_jmps(&out_false); + push_lit("0"); + fixup_jmps(&out); + tmp_free(itmp); + break; + case L_STRUCT: + /* + * The structs are of compatible types, so we know + * they have the same number of members. Compare + * them one by one. + */ + i = 0; + for (v = type->u.struc.members; v; v = v->next) { + emit_load_scalar(ltmp->idx); + TclEmitInstInt4(INST_LIST_INDEX_IMM, i, + L->frame->envPtr); + emit_load_scalar(rtmp->idx); + TclEmitInstInt4(INST_LIST_INDEX_IMM, i, + L->frame->envPtr); + ++i; + compile_eq_stack(expr, v->type); + out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false); + } + push_lit("1"); + out = emit_jmp_fwd(INST_JUMP1, out); + fixup_jmps(&out_false); + push_lit("0"); + fixup_jmps(&out); + break; + case L_HASH: + /* + * if (length(lhs) != length(rhs)) goto out_false2 + * if [dict first lhs] goto out_true + * top_off: + * // stack: val key (key is on top) + * unless [::dict exists rhs key] goto out_false + * unless [::dict get rhs key] == val goto out_false2 + * unless [dict next] goto top_off + * out_true: + * pop // pop key + * pop // pop val + * push 1 + * goto out + * out_false: + * pop // pop key + * pop // pop val + * out_false2: + * push 0 + * out: + */ + itmp = tmp_get(TMP_UNSET); + push_lit("::dict"); + push_lit("size"); + emit_load_scalar(ltmp->idx); + // ::dict size lhs + emit_invoke(3); + // <lhs-size> + push_lit("::dict"); + push_lit("size"); + emit_load_scalar(rtmp->idx); + // <lhs-size> ::dict size rhs + emit_invoke(3); + // <lhs-size> <rhs-size> + TclEmitOpcode(INST_EQ, L->frame->envPtr); + // <true/false> + out_false2 = emit_jmp_fwd(INST_JUMP_FALSE4, out_false2); + emit_load_scalar(ltmp->idx); + // lhs + TclEmitInstInt4(INST_DICT_FIRST, itmp->idx, L->frame->envPtr); + // <lhs-val> <lhs-key> <done-flag> + out_true = emit_jmp_fwd(INST_JUMP_TRUE4, out_true); + top_off = currOffset(L->frame->envPtr); + // <lhs-val> <lhs-key> + TclEmitOpcode(INST_DUP, L->frame->envPtr); + // <lhs-val> <lhs-key> <lhs-key> + push_lit("::dict"); + push_lit("exists"); + emit_load_scalar(rtmp->idx); + // <lhs-val> <lhs-key> <lhs-key> ::dict exists rhs + TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr); + // <lhs-val> <lhs-key> ::dict exists rhs <lhs-key> + emit_invoke(4); + // <lhs-val> <lhs-key> <rhs-exists-flag> + out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false); + // <lhs-val> <lhs-key> + push_lit("::dict"); + push_lit("get"); + emit_load_scalar(rtmp->idx); + // <lhs-val> <lhs-key> ::dict get rhs + TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr); + // <lhs-val> ::dict get rhs <lhs-key> + emit_invoke(4); + // <lhs-val> <rhs-val> + compile_eq_stack(expr, type->base_type); + // <equals-flag> + out_false2 = emit_jmp_fwd(INST_JUMP_FALSE4, out_false2); + TclEmitInstInt4(INST_DICT_NEXT, itmp->idx, L->frame->envPtr); + // <lhs-val> <lhs-key> <done-flag> + emit_jmp_back(TCL_FALSE_JUMP, top_off); + fixup_jmps(&out_true); + // <lhs-val> <lhs-key> + emit_pop(); + emit_pop(); + push_lit("1"); + out = emit_jmp_fwd(INST_JUMP1, out); + // <lhs-val> <lhs-key> + fixup_jmps(&out_false); + emit_pop(); + emit_pop(); + fixup_jmps(&out_false2); + push_lit("0"); + fixup_jmps(&out); + tmp_free(itmp); + break; + default: ASSERT(0); + } + tmp_free(ltmp); + tmp_free(rtmp); +} + +private int +compile_keys(Expr *expr) +{ + int n; + + push_lit("::dict"); + push_lit("keys"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n == 1) { + L_errf(expr, "incorrect # args to keys"); + expr->type = L_poly; + return (0); // stack effect + } + unless (ishash(expr->b) || ispoly(expr->b)) { + L_errf(expr, "arg to keys is not a hash"); + expr->type = L_poly; + return (0); // stack effect + } + emit_invoke(3); + if (ispoly(expr->b)) { + expr->type = L_poly; + } else { + expr->type = type_mkArray(0, expr->b->type->u.hash.idx_type); + } + return (1); // stack effect +} + +private int +compile_length(Expr *expr) +{ + int n; + Jmp *jmp1, *jmp2; + + expr->type = L_int; + + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n == 1) { + L_errf(expr, "incorrect # args to length"); + return (0); // stack effect + } + if (isstring(expr->b) || iswidget(expr->b)) { + TclEmitOpcode(INST_STR_LEN, L->frame->envPtr); + } else if (isarray(expr->b) || islist(expr->b) || ispoly(expr->b)) { + TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr); + } else if (ishash(expr->b)) { + /* + * <arg is on stack from above compile_exprs> + * dup + * l_defined + * jmpFalse 1 + * ::dict size (rot arg into place before the invoke) + * jmp 2 + * 1: pop + * push 0 + * 2: + */ + TclEmitOpcode(INST_DUP, L->frame->envPtr); + TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr); + jmp1 = emit_jmp_fwd(INST_JUMP_FALSE1, NULL); + push_lit("::dict"); + push_lit("size"); + TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr); + emit_invoke(3); + jmp2 = emit_jmp_fwd(INST_JUMP1, NULL); + fixup_jmps(&jmp1); + emit_pop(); + push_lit("0"); + fixup_jmps(&jmp2); + } else { + L_errf(expr, "arg to length has illegal type"); + } + return (1); // stack effect +} + +private int +compile_min_max(Expr *expr) +{ + push_litf("::tcl::mathfunc::%s", expr->a->str); + unless (compile_exprs(expr->b, L_PUSH_VAL) == 2) { + L_errf(expr, "incorrect # args to %s", expr->a->str); + expr->type = L_poly; + return (0); + } + L_typeck_expect(L_INT|L_FLOAT, expr->b, "in min/max"); + L_typeck_expect(L_INT|L_FLOAT, expr->b->next, "in min/max"); + emit_invoke(3); + if (isfloat(expr->b) || isfloat(expr->b->next)) { + expr->type = L_float; + } else { + expr->type = L_int; + } + return (1); // stack effect +} + +private int +compile_sort(Expr *expr) +{ + int custom_compar = 0, i, n; + Expr *e, *l; + Type *t; + + /* + * Do some gymnastics to get this on the run-time stack: + * ::lsort + * <all args except last one> + * -integer, -real, or -ascii depending on list type, unless + * the -compare option was given + * <last arg (the thing to be sorted)> + */ + + push_lit("::lsort"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n >= 1) { + L_errf(expr, "incorrect # args to sort"); + expr->type = L_poly; + return (0); // stack effect + } + /* See if there's a "-command" argument. */ + for (i = 0, l = expr->b; i < (n-1); ++i, l = l->next) { + unless (isconst(l) && l->str && !strcmp(l->str, "-command")) { + continue; + } + /* Type check the arg to -command. */ + e = l->next; + unless (e && (e->type->kind == L_NAMEOF) && + (e->type->base_type->kind == L_FUNCTION)) { + L_errf(e, "'command:' arg to sort must be &function"); + } + custom_compar = 1; + } + /* The last argument to sort must be an array, list, or poly. */ + if (isarray(l) || islist(l)) { + t = l->type->base_type; + } else if (ispoly(l)) { + t = L_poly; + } else { + L_errf(expr, "last arg to sort not an array or list"); + expr->type = L_poly; + return (0); // stack effect + } + unless (custom_compar) { + switch (t->kind) { + case L_INT: + push_lit("-integer"); + break; + case L_FLOAT: + push_lit("-real"); + break; + default: + push_lit("-ascii"); + break; + } + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + ++n; + } + if (n > 255) L_errf(expr, "sort cannot have >255 args"); + emit_invoke(n+1); + expr->type = type_mkArray(0, t); + return (1); // stack effect +} + +private int +compile_join(Expr *expr) +{ + Expr *array, *sep; + + expr->type = L_string; + push_lit("::join"); + unless ((sep=expr->b) && (array=sep->next) && !array->next) { + L_errf(expr, "incorrect # args to join"); + return (0); // stack effect + } + compile_expr(array, L_PUSH_VAL); + unless (isarray(array) || islist(array) || ispoly(array)) { + L_errf(expr, "second arg to join not an array or list"); + return (0); // stack effect + } + compile_expr(sep, L_PUSH_VAL); + unless (isstring(sep) || iswidget(sep) || ispoly(sep)) { + L_errf(expr, "first arg to join not a string"); + return (0); // stack effect + } + emit_invoke(3); + return (1); // stack effect +} + +private int +compile_abs(Expr *expr) +{ + int n; + + push_lit("::tcl::mathfunc::abs"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n == 1) { + L_errf(expr, "incorrect # args to abs"); + expr->type = L_poly; + return (0); + } + unless (isint(expr->b) || isfloat(expr->b) || ispoly(expr->b)) { + L_errf(expr, "must pass int or float to abs"); + } + emit_invoke(2); + expr->type = expr->b->type; + return (1); // stack effect +} + +private int +compile_assert(Expr *expr) +{ + Jmp *jmp; + char *cond_txt; + + expr->type = L_void; + unless (expr->b && !expr->b->next) { + L_errf(expr, "incorrect # args to assert"); + return (0); // stack effect + } + compile_condition(expr->b); + jmp = emit_jmp_fwd(INST_JUMP_TRUE4, NULL); + cond_txt = get_text(expr->b); + push_lit("die_"); + push_lit(frame_name()); + push_litf("%d", expr->node.loc.line); + push_litf("ASSERTION FAILED %s:%d: %s\n", expr->node.loc.file, + expr->node.loc.line, cond_txt); + emit_invoke(4); + emit_pop(); + ckfree(cond_txt); + fixup_jmps(&jmp); + return (0); // stack effect +} + +private int +compile_catch(Expr *expr) +{ + L_errf(expr, "catch() is reserved for try/catch; " + "use ::catch() for Tcl's catch"); + return (0); +} + +/* + * Change die(fmt, ...args) into die_(__FILE__, __LINE__, fmt, ...args) + */ +private int +compile_die(Expr *expr) +{ + Expr *arg; + + ckfree(expr->a->str); + expr->a->str = ckstrdup("die_"); + arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc); + arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc); + arg->next->next = expr->b; + expr->b = arg; + return (compile_expr(expr, L_PUSH_VAL)); +} + +/* + * Change warn(fmt, ...args) into warn_(__FILE__, __LINE__, fmt, ...args) + */ +private int +compile_warn(Expr *expr) +{ + Expr *arg; + + ckfree(expr->a->str); + expr->a->str = ckstrdup("warn_"); + arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc); + arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc); + arg->next->next = expr->b; + expr->b = arg; + return (compile_expr(expr, L_PUSH_VAL)); +} + +/* + * Change here() into here_(__FILE__, __LINE__, __FUNC__) + */ +private int +compile_here(Expr *expr) +{ + Expr *arg; + + if (expr->b) { + L_errf(expr, "here() takes no arguments"); + } + ckfree(expr->a->str); + expr->a->str = ckstrdup("here_"); + arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc); + arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc); + arg->next->next = ast_mkId("__FUNC__", expr->node.loc, expr->node.loc); + expr->b = arg; + return (compile_expr(expr, L_PUSH_VAL)); +} + +private int +compile_undef(Expr *expr) +{ + int n; + Expr *arg = expr->b; + + n = compile_exprs(arg, L_PUSH_PTR | L_DELETE | L_LVALUE); + unless (n == 1) { + L_errf(expr, "incorrect # args to undef"); + goto done; + } + unless (arg->sym) { + L_errf(expr, "illegal l-value in undef()"); + goto done; + } + if (((arg->op == L_OP_DOT) || (arg->op == L_OP_POINTS)) && + isstruct(arg->a)) { + L_errf(expr, "cannot undef() a struct field"); + goto done; + } + /* + * If arg is a deep dive, delete the hash or array element. + * If arg is a variable, treat undef(var) like var=undef. + */ + if (arg->flags & L_EXPR_DEEP) { + TclEmitInstInt4(INST_L_DEEP_WRITE, + arg->sym->idx, + L->frame->envPtr); + TclEmitInt4(L_DELETE | L_DISCARD, L->frame->envPtr); + } else { + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + emit_store_scalar(arg->sym->idx); + emit_pop(); + } + done: + expr->type = L_void; + return (0); // stack effect +} + +private int +compile_typeof(Expr *expr) +{ + Sym *sym; + + expr->type = L_string; + unless (expr->b->kind == L_EXPR_ID) { + L_errf(expr, "argument to typeof() not a variable"); + return (0); + } + sym = sym_lookup(expr->b, 0); + if (sym) { + if (sym->type->name) { + push_lit(sym->type->name); + } else { + push_lit(L_type_str(sym->type->kind)); + } + } + return (1); // stack effect +} + +private int +compile_read(Expr *expr) +{ + int n; + Expr *buf, *fd, *nbytes; + + expr->type = L_int; + push_lit("Lread_"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless ((n == 2) || (n == 3)) { + L_errf(expr, "incorrect # args to read()"); + return (0); + } + fd = expr->b; + unless (typeisf(fd, "FILE") || ispoly(fd)) { + L_errf(expr, "first arg to read() must have type FILE"); + return (0); + } + buf = fd->next; + unless (isaddrof(buf) && (isstring(buf->a) || ispoly(buf->a))) { + L_errf(expr, "second arg to read() must have type string&"); + return (0); + } + nbytes = buf->next; + if (nbytes) { + unless (isint(nbytes) || ispoly(nbytes)) { + L_errf(expr, "third arg to read() must have type int"); + return (0); + } + } + emit_invoke(n+1); + return (1); // stack effect +} + +private int +compile_write(Expr *expr) +{ + int n; + Expr *buf, *fd, *nbytes; + + expr->type = L_int; + push_lit("Lwrite_"); + n = compile_exprs(expr->b, L_PUSH_VAL); + unless (n == 3) { + L_errf(expr, "incorrect # args to write()"); + return (0); + } + fd = expr->b; + unless (typeisf(fd, "FILE") || ispoly(fd)) { + L_errf(expr, "first arg to write() must have type FILE"); + return (0); + } + buf = fd->next; + unless (isstring(buf) || iswidget(buf) || ispoly(buf)) { + L_errf(expr, "second arg to write() must have type string"); + return (0); + } + nbytes = buf->next; + unless (isint(nbytes) || ispoly(nbytes)) { + L_errf(expr, "third arg to write() must have type int"); + return (0); + } + emit_invoke(4); + return (1); // stack effect +} + +/* + * Allowable forms of system(): + * + * int system(string cmd) + * int system(string cmd, STATUS &s) + * int system(string argv[]) + * int system(string argv[], STATUS &s) + * int system(cmd | argv[], string in, string &out, string &err) + * int system(cmd | argv[], string in, string &out, string &err, STATUS &) + * int system(cmd | argv[], string[] in, string[] &out, string[] &err) + * int system(cmd | argv[], string[] in, string[] &out, string[] &err,STATUS &) + * int system(cmd | argv[], "input", "${outf}", "errors") + * int system(cmd | argv[], "input", "${outf}", "errors", STATUS &s) + * int system(cmd | argv[], FILE in, FILE out, FILE err); + * int system(cmd | argv[], FILE in, FILE out, FILE err, STATUS &s); + * + * and spawn(): + * + * int spawn(string cmd) + * int spawn(string cmd, STATUS &s) + * int spawn(string argv[]) + * int spawn(string argv[], STATUS &s) + * int spawn(cmd | argv[], string in, FILE out, FILE err) + * int spawn(cmd | argv[], string in, FILE out, FILE err, STATUS &s) + * int spawn(cmd | argv[], string[] in, FILE out, FILE err) + * int spawn(cmd | argv[], string[] in, FILE out, FILE err, STATUS &s) + * int spawn(cmd | argv[], "input", "${outf}", "errors") + * int spawn(cmd | argv[], "input", "${outf}", "errors", STATUS &s) + * int spawn(cmd | argv[], FILE in, FILE out, FILE err) + * int spawn(cmd | argv[], FILE in, FILE out, FILE err, STATUS &s) + * + * Convert these into a call to system_ or spawn_ that has exactly + * seven args, the last being flags indicating the number and type of + * what the user supplied. + */ + +private int +compile_spawn_system(Expr *expr) +{ + int flags = 0, n; + Expr *cmd; + Expr *err = NULL, *in = NULL, *out = NULL, *status = NULL; + enum { SYSTEM, SPAWN } kind; + + kind = isid(expr->a, "system") ? SYSTEM : SPAWN; + + push_lit("system_"); + n = compile_exprs(expr->b, L_PUSH_VAL); + + expr->type = L_poly; + cmd = expr->b; + switch (n) { + case 1: + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + break; + case 2: + status = cmd->next; + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr); + break; + case 4: + in = cmd->next; + out = in->next; + err = out->next; + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + break; + case 5: + in = cmd->next; + out = in->next; + err = out->next; + status = err->next; + break; + default: + L_errf(expr, "incorrect # args"); + return (0); + } + if (isstring(cmd) || ispoly(cmd)) { + } else if (isarrayof(cmd, L_STRING | L_POLY) || islist(cmd)) { + flags |= SYSTEM_ARGV; + } else { + L_errf(expr, "first arg must be string or string array"); + } + switch (kind) { + case SYSTEM: flags |= typeck_system(in, out, err); break; + case SPAWN: flags |= typeck_spawn(in, out, err); break; + } + if (status) { + Type *base_type = status->type->base_type; + unless (isid(status, "undef") || + (isnameoftype(status->type) && + (ispolytype(base_type) || typeis(base_type, "STATUS")))) { + L_errf(expr, "last arg must be of type STATUS &"); + return (0); + } + } + push_litf("0x%x", flags); + emit_invoke(7); + expr->type = L_int; + return (1); +} + +private int +typeck_spawn(Expr *in, Expr *out, Expr *err) +{ + int flags = 0; + + if (!in || isid(in, "undef")) { + } else if (typeisf(in, "FILE")) { + flags |= SYSTEM_IN_HANDLE; + } else if (isstring(in) && (isconst(in) || isinterp(in))) { + flags |= SYSTEM_IN_FILENAME; + } else if (isstring(in) || ispoly(in)) { + flags |= SYSTEM_IN_STRING; + } else if (isarrayof(in, L_STRING | L_POLY) || islist(in)) { + flags |= SYSTEM_IN_ARRAY; + } else { + L_errf(in, "second arg must be FILE, or " + "string constant/variable/array"); + } + if (!out || isid(out, "undef")) { + } else if (typeisf(out, "FILE")) { + flags |= SYSTEM_OUT_HANDLE; + } else if (isstring(out) && (isconst(out) || isinterp(out))) { + flags |= SYSTEM_OUT_FILENAME; + } else { + L_errf(out, "third arg must be FILE, or string constant"); + } + if (!err || isid(err, "undef")) { + } else if (typeisf(err, "FILE")) { + flags |= SYSTEM_ERR_HANDLE; + } else if (isstring(err) && (isconst(err) || isinterp(err))) { + flags |= SYSTEM_ERR_FILENAME; + } else { + L_errf(err, "fourth arg must be FILE, or string constant"); + } + + return (flags | SYSTEM_BACKGROUND); +} + +private int +typeck_system(Expr *in, Expr *out, Expr *err) +{ + int flags = 0; + + if (!in || isid(in, "undef")) { + } else if (typeisf(in, "FILE")) { + flags |= SYSTEM_IN_HANDLE; + } else if (isstring(in) && (isconst(in) || isinterp(in))) { + flags |= SYSTEM_IN_FILENAME; + } else if (isstring(in) || ispoly(in)) { + flags |= SYSTEM_IN_STRING; + } else if (isarrayof(in, L_STRING | L_POLY) || islist(in)) { + flags |= SYSTEM_IN_ARRAY; + } else { + L_errf(in, "second arg must be FILE, or " + "string constant/variable/array"); + } + if (!out || isid(out, "undef")) { + } else if (typeisf(out, "FILE")) { + flags |= SYSTEM_OUT_HANDLE; + } else if (isstring(out) && (isconst(out) || isinterp(out))) { + flags |= SYSTEM_OUT_FILENAME; + } else if (isaddrof(out) && (isstring(out->a) || ispoly(out->a))) { + flags |= SYSTEM_OUT_STRING; + } else if (isaddrof(out) && isarrayof(out->a, L_STRING | L_POLY)) { + flags |= SYSTEM_OUT_ARRAY; + } else { + L_errf(out, "third arg must be FILE, string " + "constant, or reference to string or string array"); + } + if (!err || isid(err, "undef")) { + } else if (typeisf(err, "FILE")) { + flags |= SYSTEM_ERR_HANDLE; + } else if (isstring(err) && (isconst(err) || isinterp(err))) { + flags |= SYSTEM_ERR_FILENAME; + } else if (isaddrof(err) && (isstring(err->a) || ispoly(err->a))) { + flags |= SYSTEM_ERR_STRING; + } else if (isaddrof(err) && isarrayof(err->a, L_STRING | L_POLY)) { + flags |= SYSTEM_ERR_ARRAY; + } else { + L_errf(err, "fourth arg must be FILE, string " + "constant, or reference to string or string array"); + } + + return (flags); +} + +private int +compile_popen(Expr *expr) +{ + int flags = 0, n; + Expr *cb, *cmd, *mode; + VarDecl *args; + Type *want; + YYLTYPE loc = { 0 }; + + push_lit("popen_"); + expr->type = L_poly; + + n = compile_exprs(expr->b, L_PUSH_VAL); + unless ((n == 2) || (n == 3)) { + L_errf(expr, "incorrect # args to popen"); + return (0); + } + cmd = expr->b; + mode = cmd->next; + cb = mode->next; + + if (isarrayof(cmd, L_STRING | L_POLY) || islist(cmd)) { + flags |= SYSTEM_ARGV; + } else unless (isstring(cmd) || ispoly(cmd)) { + L_errf(cmd, "first arg to popen must be string or string array"); + } + + L_typeck_expect(L_STRING, mode, "in second arg to popen"); + + // To typecheck the optional stderr-callback arg, build a + // type descriptor and let L_typeck_same() do the work. + if (cb) { + args = ast_mkVarDecl(L_string, NULL, loc, loc); + args->next = ast_mkVarDecl(L_string, NULL, loc, loc); + want = type_mkNameOf(type_mkFunc(L_void, args)); + unless (L_typeck_same(want, cb->type)) { + L_errf(cb, "illegal type for stderr callback"); + } + flags |= SYSTEM_OUT_HANDLE; + } else { + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + } + + push_litf("0x%x", flags); + emit_invoke(5); + expr->type = L_typedef_lookup("FILE"); + ASSERT(expr->type); + return (1); +} + +/* + * Return a copy of the source text for the given expression. Caller + * must free. + */ +private char * +get_text(Expr *expr) +{ + int beg = expr->node.loc.beg; + int end = expr->node.loc.end; + int len = end - beg; + char *s; + + s = ckalloc(len + 1); + strncpy(s, Tcl_GetString(L->script)+beg, len); + s[len] = 0; + return (s); +} + +/* + * Emit code to compute the value of the given expression. The flags + * say in what form the generated code should produce the value. The + * caller chooses these flags based on whether + * 1. expr will be read, written, or both; and whether + * 2. expr is a deep dive or something else (an object dereference, + * a variable, or an expression). + * The flags are bit-masks (see below) and can be combined. + * + * Passing in one of the pointer flags means that IF the expr is a + * deep dive, leave a deep-ptr to it and possibly also its value on + * the run-time stack. If the expr is not, evaluate it (so that + * expr->sym etc is valid) but don't push anything. You use this when + * expr is an l-value. + * + * Passing in L_PUSH_VAL and none of the pointer flags means that + * the expr's value is left on the stack. + * + * Passing in both L_PUSH_VAL and one of the pointer flags is done + * when the caller needs a deep-ptr if expr is a deep dive but + * just wants the value otherwise. You use this when expr is + * an l-value but you also need the r-value, such as when + * compiling ++/-- or =~. + * + * Passing in L_PUSH_NAME means the fully qualified name of the + * variable is left on the stack and is valid only for certain + * kinds of variables (globals, locals, class variables, or class + * instance variables). + * + * L_PUSH_VAL push value onto stack, unless deep dive and + * you also request a deep-ptr + * L_PUSH_PTR if deep dive, push deep-ptr onto stack + * L_PUSH_PTRVAL if deep dive, push deep-ptr then value onto stack + * L_PUSH_VALPTR if deep dive, push value then deep-ptr onto stack + * L_LVALUE if deep dive, create an un-shared copy for writing + * L_DISCARD evaluate expr then discard its value + * L_PUSH_NAME push fully qualified name of variable, not the value + */ +private int +compile_expr(Expr *expr, Expr_f flags) +{ + int n = 0; + int start_off = currOffset(L->frame->envPtr); + + ++L->expr_level; + + /* The compile_xxx returns indicate whether they pushed anything. */ + unless (expr) return (0); + switch (expr->kind) { + case L_EXPR_FUNCALL: + n = compile_fnCall(expr); + break; + case L_EXPR_CONST: + case L_EXPR_RE: + push_lit(expr->str); + n = 1; + break; + case L_EXPR_ID: + n = compile_var(expr, flags); + break; + case L_EXPR_UNOP: + n = compile_unOp(expr); + break; + case L_EXPR_BINOP: + n = compile_binOp(expr, flags); + break; + case L_EXPR_TRINOP: + n = compile_trinOp(expr); + break; + default: + L_bomb("Unknown expression type %d", expr->kind); + } + + /* + * Throw away the value if requested by the caller. This is done + * for expressions that are statements, in for-loop pre and + * post expressions, etc. + */ + if (flags & L_DISCARD) { + while (n--) emit_pop(); + } + + track_cmd(start_off, expr); + + --L->expr_level; + return (n); +} + +/* + * If a function-call name begins with a cap and has an _ inside, it + * looks like a pattern call. From a name like "Foo_barBazBlech" + * create Expr const nodes "foo", "Foo_*" and a linked list of Expr + * const nodes for "bar", "baz", and "blech". Note that the returned + * Expr's need not be freed explicitly since all AST nodes are + * deallocated by the compiler. + */ +private int +ispatternfn(char *name, Expr **foo, Expr **Foo_star, Expr **opts, int *nopts) +{ + int i; + char *buf, *p, *under; + Expr *e; + + unless ((name[0] >= 'A') && (name[0] <= 'Z') && + (p = strchr(name, '_')) && p[1]) { // _ cannot be last + return (FALSE); + } + + under = p; + *under = '\0'; + + /* Build foo from Foo_bar. */ + buf = cksprintf("%s", name); + buf[0] = tolower(buf[0]); + *foo = mkId(buf); + ckfree(buf); + + /* Build Foo_* from Foo_bar. */ + buf = cksprintf("%s_*", name); + *Foo_star = mkId(buf); + ckfree(buf); + + /* Build a list of bar,baz,blech nodes from barBazBlech. */ + ++p; + *opts = NULL; + *nopts = 0; + while (*p) { + YYLTYPE loc = { 0 }; + *p = tolower(*p); + buf = ckalloc(strlen(p) + 1); + for (i = 0; *p && !isupper(*p); ++p, ++i) { + buf[i] = *p; + } + buf[i] = 0; + e = ast_mkConst(L_string, buf, loc, loc); + APPEND_OR_SET(Expr, next, *opts, e); + ++(*nopts); + } + + *under = '_'; + + return (TRUE); +} + +/* + * Rules for compiling a function call like "foo(arg)": + * + * - If foo is a variable of type name-of function, assume it contains + * the name of the function to call. + * + * - Otherwise call foo. If foo isn't declared, that's OK, we just + * won't have a prototype to type-check against. + * + * For a function call like "Foo_bar(a,b,c)" or "Foo_barBazBlech(a,b,c)", + * where the name starts with [A-Z] and has an _ in it (except at the + * end), we have what's called a "pattern function". The "bar", "baz", + * and "blech" are the "options", and "a", "b", and "c" are the "arguments". + * + * - If Foo_bar happens to be a declared function, handle as above. + * + * - If the function Foo_* is defined, change the call to + * Foo_*(bar,baz,blech,a,b,c). + * + * - If "a" is not of widget type, change the call to + * foo(bar,baz,blech,a,b,c). + * + * - If "a" is a widget type, change the call to *a(bar,baz,blech,b,c) + * where *a means that the value of the argument "a" becomes the + * function name. + */ +private int +compile_fnCall(Expr *expr) +{ + int expand, i, level, nopts; + int num_parms = 0, typchk = FALSE; + char *name; + char *defchk = NULL; // name for definedness chk before main() runs + Expr *foo, *Foo_star, *opts, *p; + Sym *sym; + VarDecl *formals = NULL; + + ASSERT(expr->a->kind == L_EXPR_ID); + name = expr->a->str; + + /* Check for an (expand) in the arg list. */ + expand = 0; + for (p = expr->b; p; p = p->next) { + if (isexpand(p)) { + TclEmitOpcode(INST_EXPAND_START, L->frame->envPtr); + expand = 1; + break; + } + } + + /* + * Check for an L built-in function. XXX change the array to + * a hash if the number of built-ins grows much more. + */ + for (i = 0; i < sizeof(builtins)/sizeof(builtins[0]); ++i) { + if (!strcmp(builtins[i].name, name)) { + if (expand) { + L_errf(expr, "(expand) illegal with " + "this function"); + } + i = builtins[i].fn(expr); + /* Copy out hash/array elements passed by reference. */ + copyout_parms(expr->b); + return (i); + } + } + + level = fnCallBegin(); + sym = sym_lookup(expr->a, L_NOWARN); + + if (sym && isfntype(sym->type)) { + /* A regular call -- the name is the fn name. */ + push_lit(sym->tclname); + formals = sym->type->u.func.formals; + typchk = TRUE; + defchk = name; + expr->type = sym->type->base_type; + } else if (sym && (sym->type->kind == L_NAMEOF) && + (sym->type->base_type->kind == L_FUNCTION)) { + /* + * Name is a function "pointer". It holds the function + * name and its type is the function proto. + */ + emit_load_scalar(sym->idx); + formals = sym->type->base_type->u.func.formals; + typchk = TRUE; + expr->type = sym->type->base_type->base_type; + } else if (sym) { + /* Name is declared but isn't a function or fn pointer. */ + L_errf(expr, "'%s' is declared but not as a function", name); + expr->type = L_poly; + } else if (ispatternfn(name, &foo, &Foo_star, &opts, &nopts)) { + /* Pattern function. Figure out which kind. */ + if ((sym = sym_lookup(Foo_star, L_NOWARN))) { + /* Foo_* is defined -- compile Foo_*(opts,a,b,c). */ + push_lit(Foo_star->str); + APPEND(Expr, next, opts, expr->b); + expr->b = opts; + formals = sym->type->u.func.formals; + typchk = TRUE; + defchk = Foo_star->str; + expr->type = sym->type->base_type; + } else { + /* Push first arg, then check its type. */ + compile_expr(expr->b, L_PUSH_VAL); + if (!expr->b) { + /* No args, compile as foo(opts). */ + push_lit(foo->str); + num_parms = push_parms(opts, NULL); + defchk = foo->str; + } else if (iswidget(expr->b)) { + /* Compile as *a(opts,b,c). */ + APPEND(Expr, next, opts, expr->b->next); + expr->b = opts; + } else { + /* Compile as foo(opts,a,b,c). */ + // a + push_lit(foo->str); + num_parms = push_parms(opts, NULL); + ASSERT(num_parms == nopts); + // a foo <opts> + TclEmitInstInt1(isexpand(expr->b)? + INST_EXPAND_ROT : INST_ROT, + nopts + 1, + L->frame->envPtr); + // foo <opts> a + expr->b = expr->b->next; + ++num_parms; + defchk = foo->str; + } + expr->type = L_poly; + } + } else { + /* Call to an undeclared function. */ + push_lit(name); + expr->type = L_poly; + defchk = name; + } + num_parms += push_parms(expr->b, formals); + if (expand) { + emit_invoke_expanded(); + } else { + emit_invoke(num_parms+1); + } + + /* + * Handle the copy-out part of copy in/out parameters. + * These are any deep-dive expressions that are passed by reference. + */ + copyout_parms(expr->b); + + if (typchk) L_typeck_fncall(formals, expr); + fnCallEnd(level); + /* + * If the call is to a function name that is known now (e.g., + * not a function pointer), add it to the L->fn_calls list + * which is walked before main() is called to verify that the + * function exists. + */ + if (defchk) { + Tcl_Obj *nm = Tcl_NewStringObj(defchk, -1); + Tcl_Obj *val = Tcl_NewObj(); + Tcl_DictObjPut(L->interp, L->fn_calls, nm, val); + Tcl_SetVar2Ex(L->interp, "%%L_fnsCalled", NULL, L->fn_calls, + TCL_GLOBAL_ONLY); + } + return (1); // stack effect +} + +private void +copyout_parms(Expr *actuals) +{ + Expr *actual, *arg; + + /* + * Copy out any deep-dive expressions that were passed with &. + * For these, the actual's value was copied into a temp var + * and its name passed. Copy that temp back out. + */ + for (actual = actuals; actual; actual = actual->next) { + arg = actual->a; + unless (isaddrof(actual) && (arg->flags & L_SAVE_IDX)) { + continue; + } + emit_load_scalar(arg->u.deepdive.val->idx); + compile_assignFromStack(arg, arg->type, NULL, L_REUSE_IDX); + emit_pop(); + tmp_free(arg->u.deepdive.val); + arg->u.deepdive.val = NULL; + } +} + +private int +compile_var(Expr *expr, Expr_f flags) +{ + Sym *self, *sym; + + ASSERT(expr->kind == L_EXPR_ID); + + /* Check for pre-defined identifiers first. */ + if (isid(expr, "END")) { + TclEmitOpcode(INST_L_READ_SIZE, L->frame->envPtr); + unless ((L->idx_op == L_OP_ARRAY_INDEX) | + (L->idx_op == L_OP_ARRAY_SLICE)) { + L_errf(expr, + "END illegal outside of a string or array index"); + } + expr->type = L_int; + return (1); + } else if (isid(expr, "undef")) { + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + expr->type = L_poly; + return (1); + } else if (isid(expr, "__FILE__")) { + push_lit(expr->node.loc.file); + expr->type = L_string; + return (1); + } else if (isid(expr, "__LINE__")) { + push_litf("%d", expr->node.loc.line); + expr->type = L_int; + return (1); + } else if (isid(expr, "__FUNC__")) { + push_lit(frame_name()); + expr->type = L_string; + return (1); + } + + unless ((sym = sym_lookup(expr, flags))) { + // Undeclared variable. + expr->type = L_poly; + return (1); + } + expr->type = sym->type; + if (flags & L_PUSH_VAL) { + if (sym->kind & L_SYM_FN) { + L_errf(expr, "cannot use a function name as a value"); + } else { + emit_load_scalar(sym->idx); + } + return (1); + } else if (flags & L_PUSH_NAME) { + switch (canDeref(sym)) { + case DECL_GLOBAL_VAR: + if (sym->decl->flags & DECL_PRIVATE) { + push_litf("::_%s_%s", L->toplev, sym->name); + } else { + push_litf("::%s", sym->name); + } + break; + case DECL_LOCAL_VAR: + push_lit(sym->tclname); + break; + case DECL_FN: + push_lit(sym->tclname); + break; + case DECL_CLASS_VAR: + push_litf("::L::_class_%s::%s", + sym->decl->clsdecl->decl->id->str, + sym->name); + break; + case DECL_CLASS_INST_VAR: + self = sym_lookup(mkId("self"), L_NOWARN); + ASSERT(self); + emit_load_scalar(self->idx); + push_litf("::%s", sym->name); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + break; + default: + ASSERT(0); + } + return (1); + } else { + /* Push nothing. */ + return (0); + } + /* Not reached. */ + ASSERT(0); + return (1); +} + +private int +compile_exprs(Expr *expr, Expr_f flags) +{ + int num_exprs; + + for (num_exprs = 0; expr; expr = expr->next, ++num_exprs) { + compile_expr(expr, flags); + } + return (num_exprs); +} + +/* + * Emit code to push the parameters to a function call and return the + * # pushed. Rules: + * + * - For two consecutive parms like "-foovariable, &foo", push "-foovariable" + * and then the name of "foo". This is legal only for globals, class + * variables, and class instance variables. + * + * - If undef is passed as a reference parameter, pass the name of the + * special variable L_undef_ref_parm_. Code in lib L sets read and + * write traces on this variable as a way to cause a run-time error + * upon access to it. + * + * - For everything else, push the value or name as indicated by whether + * the parm has the & operator; compile_expr() handles that. The type + * checker sorts out any mis-matches with the declared formals. + */ +private int +push_parms(Expr *actuals, VarDecl *formals) +{ + int i; + int widget_flag = FALSE; + int strlen_of_variable = strlen("variable"); + char *s; + Expr *a, *v; + Sym *sym; + + for (i = 0, a = actuals; a; a = a->next, ++i) { + if (isaddrof(a) && (a->a->kind == L_EXPR_ID) && + (sym = sym_lookup(a->a, L_NOWARN)) && + (sym->decl->flags & DECL_REF)) { + push_lit(sym->tclname); + a->type = type_mkNameOf(a->a->type); + } else if (isid(a, "undef") && + formals && isnameoftype(formals->type) && + !isfntype(formals->type->base_type)) { + push_lit("::L_undef_ref_parm_"); + a->type = L_poly; + } else { + compile_expr(a, L_PUSH_VAL); + } + if (widget_flag && isaddrof(a)) { + a->type = L_poly; + v = a->a; + /* can't use local vars or functions from a widget */ + if (v->sym && + ((v->sym->decl->flags & (DECL_LOCAL_VAR|DECL_FN)) || + !canDeref(v->sym))) { + L_errf(a, "illegal operand to &"); + } + } + s = a->str; + widget_flag = ((a->kind == L_EXPR_CONST) && + isstring(a) && + /* has at least the minimum length */ + (strlen(s) > strlen_of_variable) && + /* starts with '-' */ + (s[0] == '-') && + /* ends with "variable" */ + !strcmp("variable", s + (strlen(s) - strlen_of_variable))); + if (formals) formals = formals->next; + } + return (i); +} + +private int +compile_unOp(Expr *expr) +{ + switch (expr->op) { + case L_OP_BANG: + case L_OP_BITNOT: + if (expr->op == L_OP_BANG) { + compile_condition(expr->a); + } else { + compile_expr(expr->a, L_PUSH_VAL); + } + L_typeck_expect(L_INT, expr->a, "in unary ! or ~"); + emit_instrForLOp(expr, expr->type); + expr->type = expr->a->type; + break; + case L_OP_UPLUS: + case L_OP_UMINUS: + compile_expr(expr->a, L_PUSH_VAL); + L_typeck_expect(L_INT|L_FLOAT, expr->a, "in unary +/-"); + emit_instrForLOp(expr, expr->type); + expr->type = expr->a->type; + break; + case L_OP_DEFINED: + compile_defined(expr->a); + expr->type = L_int; + break; + case L_OP_ADDROF: + /* + * Compile &<expr>. For function names, regular + * variables, and class variables (&x, + * &classname->var, &obj->var), this is just the name + * of the Tcl variable. For a deep-dive expr, + * it's the name of a temp var that holds the value. + */ + compile_expr(expr->a, L_PUSH_NAME); + expr->type = type_mkNameOf(expr->a->type); + unless (expr->a->sym) { + L_errf(expr->a, "illegal operand to &"); + expr->type = L_poly; + } + break; + case L_OP_PLUSPLUS_PRE: + case L_OP_PLUSPLUS_POST: + case L_OP_MINUSMINUS_PRE: + case L_OP_MINUSMINUS_POST: + compile_incdec(expr); + expr->type = expr->a->type; + break; + case L_OP_EXPAND: + unless (fnInArgList()) { + L_errf(expr, "(expand) illegal in this context"); + } + compile_expr(expr->a, L_PUSH_VAL); + TclEmitInstInt4(INST_EXPAND_STKTOP, + L->frame->envPtr->currStackDepth, + L->frame->envPtr); + expr->type = L_poly; + break; + case L_OP_CMDSUBST: + push_lit("::backtick_"); + if (expr->a) { + compile_expr(expr->a, L_PUSH_VAL); + push_lit(expr->str); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + } else { + push_lit(expr->str); + } + emit_invoke(2); + expr->type = L_string; + break; + case L_OP_FILE: + if (expr->a) { + push_lit("fgetline"); + compile_expr(expr->a, L_PUSH_VAL); + if (typeisf(expr->a, "FILE")) { + emit_invoke(2); + } else { + L_errf(expr->a, "expect FILE in <>"); + } + } else { + push_lit("angle_read_"); + emit_invoke(1); + } + expr->type = L_string; + break; + default: + L_bomb("Unknown unary operator %d", expr->op); + break; + } + return (1); // stack effect +} + +private int +compile_binOp(Expr *expr, Expr_f flags) +{ + int expand, level, n; + Type *type; + Expr *e; + + /* Return the net run-time stack effect (i.e., how much was pushed). */ + + switch (expr->op) { + case L_OP_EQUALS: + compile_assign(expr); + expr->type = expr->a->type; + return (1); + case L_OP_EQPLUS: + case L_OP_EQMINUS: + case L_OP_EQSTAR: + case L_OP_EQSLASH: + compile_assign(expr); + L_typeck_expect(L_INT|L_FLOAT, expr->a, + "in arithmetic assignment"); + expr->type = expr->a->type; + return (1); + case L_OP_EQPERC: + case L_OP_EQBITAND: + case L_OP_EQBITOR: + case L_OP_EQBITXOR: + case L_OP_EQLSHIFT: + case L_OP_EQRSHIFT: + compile_assign(expr); + L_typeck_expect(L_INT, expr->a, "in arithmetic assignment"); + expr->type = expr->a->type; + return (1); + case L_OP_EQDOT: + compile_assign(expr); + L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in .="); + expr->type = expr->a->type; + return (1); + case L_OP_ANDAND: + case L_OP_OROR: + compile_shortCircuit(expr); + expr->type = L_int; + return (1); + case L_OP_STR_EQ: + case L_OP_STR_NE: + case L_OP_STR_GT: + case L_OP_STR_GE: + case L_OP_STR_LT: + case L_OP_STR_LE: + unless (hash_get(L->options, "allow_eq_ops")) { + L_errf(expr, "illegal comparison operator"); + } + /* Warn on things like "s eq undef". */ + if (isid(e=expr->a, "undef") || isid(e=expr->b, "undef")) { + L_errf(e, "undef illegal in comparison"); + } + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + L_typeck_expect(L_STRING|L_WIDGET, expr->a, + "in string comparison"); + L_typeck_expect(L_STRING|L_WIDGET, expr->b, + "in string comparison"); + emit_instrForLOp(expr, expr->type); + expr->type = L_int; + return (1); + case L_OP_EQUALEQUAL: + case L_OP_NOTEQUAL: + case L_OP_GREATER: + case L_OP_GREATEREQ: + case L_OP_LESSTHAN: + case L_OP_LESSTHANEQ: + expr->type = L_int; + /* Warn on things like "i == undef". */ + if (isid(e=expr->a, "undef") || isid(e=expr->b, "undef")) { + L_errf(e, "undef illegal in comparison"); + } + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + L_typeck_deny(L_VOID, expr->a); + L_typeck_deny(L_VOID, expr->b); + unless (L_typeck_compat(expr->a->type, expr->b->type) || + L_typeck_compat(expr->b->type, expr->a->type)) { + L_errf(expr, "incompatible types in comparison"); + return (0); + } + if (!isscalar(expr->a) && (expr->op != L_OP_EQUALEQUAL)) { + L_errf(expr, "only eq() allowed on non-scalar types"); + return (0); + } + compile_eq_stack(expr, expr->a->type); + return (1); // stack effect + case L_OP_PLUS: + case L_OP_MINUS: + case L_OP_STAR: + case L_OP_SLASH: + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + L_typeck_expect(L_INT|L_FLOAT, expr->a, + "in arithmetic operator"); + L_typeck_expect(L_INT|L_FLOAT, expr->b, + "in arithmetic operator"); + emit_instrForLOp(expr, expr->type); + if (isfloat(expr->a) || isfloat(expr->b)) { + expr->type = L_float; + } else { + expr->type = L_int; + } + return (1); + case L_OP_PERC: + case L_OP_BITAND: + case L_OP_BITOR: + case L_OP_BITXOR: + case L_OP_LSHIFT: + case L_OP_RSHIFT: + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + L_typeck_expect(L_INT, expr->a, "in arithmetic operator"); + L_typeck_expect(L_INT, expr->b, "in arithmetic operator"); + emit_instrForLOp(expr, expr->type); + expr->type = L_int; + return (1); + case L_OP_ARRAY_INDEX: + case L_OP_HASH_INDEX: + case L_OP_DOT: + case L_OP_POINTS: + return (compile_idxOp(expr, flags)); + case L_OP_CLASS_INDEX: + return (compile_clsDeref(expr, flags)); + case L_OP_INTERP_STRING: + case L_OP_INTERP_RE: + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + expr->type = L_string; + return (1); + case L_OP_LIST: + level = fnCallBegin(); + for (e = expr, expand = 0; e; e = e->b) { + if (e->a && isexpand(e->a)) { + TclEmitOpcode(INST_EXPAND_START, + L->frame->envPtr); + expand = 1; + break; + } + } + push_lit("::list"); + n = compile_expr(expr->a, L_PUSH_VAL); + if (n == 0) { // empty list {} + ASSERT(!expr->a && !expr->b); + type = L_poly; + } else if (iskv(expr->a)) { + ASSERT((n == 2) && ishash(expr->a)); + type = expr->a->type; + } else { + type = type_mkList(expr->a->type); + } + for (e = expr->b; e; e = e->b) { + ASSERT(e->op == L_OP_LIST); + n += compile_expr(e->a, L_PUSH_VAL); + if (ishashtype(type) && iskv(e->a)) { + } else if (islisttype(type) && !iskv(e->a)) { + /* + * The list type is literally a list of all the + * individual element types linked together. + */ + Type *t = type_mkList(e->a->type); + APPEND(Type, next, type, t); + } else unless (ispolytype(type)) { + L_errf(expr, "cannot mix hash and " + "non-hash elements"); + type = L_poly; + } + } + if (expand) { + emit_invoke_expanded(); + } else { + emit_invoke(n+1); + } + expr->type = type; + fnCallEnd(level); + return (1); + case L_OP_KV: + n = compile_expr(expr->a, L_PUSH_VAL); + n += compile_expr(expr->b, L_PUSH_VAL); + ASSERT(n == 2); + unless (isscalar(expr->a)) { + L_errf(expr->a, "hash keys must be scalar"); + } + expr->type = type_mkHash(expr->a->type, expr->b->type); + return (n); + case L_OP_EQTWID: + case L_OP_BANGTWID: + compile_twiddle(expr); + expr->type = L_int; + return (1); + case L_OP_COMMA: + compile_expr(expr->a, L_DISCARD); + compile_expr(expr->b, L_PUSH_VAL); + expr->type = expr->b->type; + return (1); + case L_OP_CAST: + return (compile_cast(expr, flags)); + case L_OP_CONCAT: + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + L_typeck_expect(L_STRING|L_WIDGET, expr->a, + "in lhs of . operator"); + L_typeck_expect(L_STRING|L_WIDGET, expr->b, + "in rhs of . operator"); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + expr->type = L_string; + return (1); + default: + L_bomb("compile_binOp: malformed AST"); + return (1); + } +} + +private int +compile_cast(Expr *expr, Expr_f flags) +{ + int range; + Jmp *jmp; + Type *type = (Type *)expr->a; + + flags &= ~L_DISCARD; + if (flags & L_LVALUE) { + compile_expr(expr->b, flags); + } else if ((type->kind == L_INT) || (type->kind == L_FLOAT)) { + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, + L->frame->envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, L->frame->envPtr); + ExceptionRangeStarts(L->frame->envPtr, range); + if (type->kind == L_INT) { + push_lit("::tcl::mathfunc::int"); + compile_expr(expr->b, flags); + emit_invoke(2); + } else if (type->kind == L_FLOAT) { + push_lit("::tcl::mathfunc::double"); + compile_expr(expr->b, flags); + emit_invoke(2); + } + ExceptionRangeEnds(L->frame->envPtr, range); + jmp = emit_jmp_fwd(INST_JUMP4, 0); + /* error case */ + ExceptionRangeTarget(L->frame->envPtr, range, catchOffset); + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + /* out */ + fixup_jmps(&jmp); + TclEmitOpcode(INST_END_CATCH, L->frame->envPtr); + } else { + compile_expr(expr->b, flags); + } + L_typeck_deny(L_VOID|L_FUNCTION, expr->b); + expr->sym = expr->b->sym; + expr->flags = expr->b->flags; + expr->type = type; + return (1); +} + +private int +compile_trinOp(Expr *expr) +{ + int save, start_off; + int i = 0, n = 0; + Jmp *end_jmp, *false_jmp; + + switch (expr->op) { + case L_OP_EQTWID: + compile_twiddleSubst(expr); + expr->type = L_int; + n = 1; + break; + case L_OP_INTERP_STRING: + case L_OP_INTERP_RE: + compile_expr(expr->a, L_PUSH_VAL); + compile_expr(expr->b, L_PUSH_VAL); + compile_expr(expr->c, L_PUSH_VAL); + TclEmitInstInt1(INST_STR_CONCAT1, 3, L->frame->envPtr); + expr->type = L_string; + n = 1; + break; + case L_OP_ARRAY_SLICE: + compile_expr(expr->a, L_PUSH_VAL); + if (isstring(expr->a) || iswidget(expr->a)) { + push_lit("::string"); + push_lit("range"); + TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr); + expr->type = L_string; + i = 5; + } else if (isarray(expr->a) || islist(expr->a)) { + push_lit("::lrange"); + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + expr->type = expr->a->type; + i = 4; + } else { + L_errf(expr->a, "illegal type for slice"); + expr->type = L_poly; + } + if (has_END(expr->b) || has_END(expr->c)) { + if (isstring(expr->a) || iswidget(expr->a)) { + TclEmitOpcode(INST_L_PUSH_STR_SIZE, + L->frame->envPtr); + } else { + TclEmitOpcode(INST_L_PUSH_LIST_SIZE, + L->frame->envPtr); + } + } + save = L->idx_op; + L->idx_op = L_OP_ARRAY_SLICE; + compile_expr(expr->b, L_PUSH_VAL); + unless (isint(expr->b)) { + L_errf(expr->b, "first slice index not an int"); + } + compile_expr(expr->c, L_PUSH_VAL); + unless (isint(expr->c)) { + L_errf(expr->c, "second slice index not an int"); + } + L->idx_op = save; + if (has_END(expr->b) || has_END(expr->c)) { + TclEmitOpcode(INST_L_POP_SIZE, L->frame->envPtr); + } + emit_invoke(i); + n = 1; + break; + case L_OP_TERNARY_COND: + compile_condition(expr->a); + false_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + start_off = currOffset(L->frame->envPtr); + n = compile_expr(expr->b, L_PUSH_VAL); + end_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + track_cmd(start_off, expr->b); + fixup_jmps(&false_jmp); + start_off = currOffset(L->frame->envPtr); + compile_expr(expr->c, L_PUSH_VAL); + track_cmd(start_off, expr->c); + fixup_jmps(&end_jmp); + if (ispoly(expr->b) || ispoly(expr->c)) { + expr->type = L_poly; + } else if (L_typeck_same(expr->b->type, expr->c->type)) { + expr->type = expr->b->type; + } else if ((expr->b->type->kind & (L_INT|L_FLOAT)) && + (expr->c->type->kind & (L_INT|L_FLOAT))) { + expr->type = L_float; + } else { + L_errf(expr, "incompatible types in ? : expressions"); + expr->type = L_poly; + } + break; + default: + L_bomb("compile_trinOp: malformed AST"); + } + return (n); // stack effect +} + + +/* + * There are two kinds of defined(): + * defined(&var) - var is a call-by-reference formal + * defined(expr) - otherwise + */ +private void +compile_defined(Expr *expr) +{ + Sym *sym; + + if (isaddrof(expr)) { + unless (expr->a->kind == L_EXPR_ID) { + L_errf(expr, "arg to & not a call-by-reference parm"); + return; + } + sym = sym_lookup(expr->a, L_NOWARN); + unless (sym && (sym->decl->flags & DECL_REF)) { + L_errf(expr, "%s undeclared or not a " + "call-by-reference parm", expr->a->str); + return; + } + push_lit("::L_undef_ref_parm_"); + TclEmitInstInt4(INST_DIFFERENT_OBJ, sym->idx, L->frame->envPtr); + } else { + compile_expr(expr, L_PUSH_VAL); + L_typeck_deny(L_VOID, expr); + TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr); + } +} + +/* + * Estimate how many submatches are in the given regexp. These are + * the sub-expressions within parens. If the regexp includes an + * interpolated string, we can't get this exact, so just assume + * the maximum (9) in that case. + */ +private int +re_submatchCnt(Expr *re) +{ + int n = 9; + Tcl_Obj *const_regexp; + Tcl_RegExp compiled; + + if (re->kind == L_EXPR_RE) { + const_regexp = Tcl_NewStringObj(re->str, -1); + Tcl_IncrRefCount(const_regexp); + compiled = Tcl_GetRegExpFromObj(L->interp, const_regexp, + TCL_REG_ADVANCED); + Tcl_DecrRefCount(const_regexp); + if (compiled) n = ((TclRegexp *)compiled)->re.re_nsub; + } + return (n); +} + +/* + * Determine whether a regexp is a constant (which can be matched with + * a string comparison), a glob (use string-match bytecode), a simpler + * regexp (no submatches, use the regexp bytecode), or a more complex + * regexp which requires the ::regexp command. If the regexp is + * interpolated, we can't tell for sure, so assume the worst. Also + * return flags indicating whether the re expr needs to be compiled. + * + * If ds is non-NULL return the equivalent glob in *ds; this becomes + * an operand to INST_STR_EQ or INST_STR_MATCH. + */ +private ReKind +re_kind(Expr *re, Tcl_DString *ds) +{ + Tcl_DString myds; + int exact, ret = 0; + + unless ((re->kind == L_EXPR_RE) || (re->op == L_OP_INTERP_RE)) { + return (RE_NOT_AN_RE); + } + unless (ds) ds = &myds; // to accommodate passing in ds==NULL + + if (re->op == L_OP_INTERP_RE) { + ret |= RE_NEEDS_EVAL; + } + if (re->flags & L_EXPR_RE_L) { + ret |= RE_NEEDS_EVAL | RE_GLOB; + } else if (re_submatchCnt(re) || (re->flags & L_EXPR_RE_G)) { + ret |= RE_NEEDS_EVAL | RE_COMPLEX; + } else if (isstring(re) && + (TclReToGlob(NULL, re->str, strlen(re->str), + ds, &exact, NULL) == TCL_OK) && + exact) { + if (ds == &myds) Tcl_DStringFree(&myds); + ret |= RE_CONST; + } else { + ret |= RE_NEEDS_EVAL | RE_SIMPLE; + } + return (ret); +} + +private void +compile_twiddle(Expr *expr) +{ + compile_expr(expr->a, L_PUSH_VAL); + compile_reMatch(expr->b); + if (expr->op == L_OP_BANGTWID) { + TclEmitOpcode(INST_LNOT, L->frame->envPtr); + L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in !~"); + } else { + L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in =~"); + } +} + +/* + * Compile a regexp match. It is assumed that the value to compare + * the regexp against will already be on the run-time stack. Code to + * push the regexp is generated here. When run, these are replaced + * with the match Boolean. + */ +private void +compile_reMatch(Expr *re) +{ + int i, cflags, mod_cnt, submatch_cnt; + int nocase = (re->flags & L_EXPR_RE_I); + Sym *s; + Expr *id; + ReKind kind; + Tcl_DString ds; + + kind = re_kind(re, &ds); + /* First push the regexp. */ + if (kind & RE_NEEDS_EVAL) { + compile_expr(re, L_PUSH_VAL); + } else { + push_lit(Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + } + /* Now emit the appropriate match instruction. */ + switch (kind & (RE_CONST|RE_GLOB|RE_SIMPLE|RE_COMPLEX)) { + case RE_CONST: + TclEmitOpcode(INST_STR_EQ, L->frame->envPtr); + break; + case RE_GLOB: + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + TclEmitInstInt1(INST_STR_MATCH, nocase, L->frame->envPtr); + break; + case RE_SIMPLE: + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + cflags = TCL_REG_ADVANCED | TCL_REG_NLSTOP | + (nocase ? TCL_REG_NOCASE : 0); + TclEmitInstInt1(INST_REGEXP, cflags, L->frame->envPtr); + break; + case RE_COMPLEX: + // val re + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // re val + push_lit("::regexp"); + mod_cnt = push_regexpModifiers(re); + push_lit("--"); + // re val ::regexp <mods> -- + TclEmitInstInt1(INST_ROT, mod_cnt+3, L->frame->envPtr); + // val ::regexp <mods> -- re + TclEmitInstInt1(INST_ROT, mod_cnt+3, L->frame->envPtr); + // ::regexp <mods> -- re val + /* Submatch vars. This loop always iterates at least once. */ + submatch_cnt = re_submatchCnt(re); + for (i = 0; i <= submatch_cnt; i++) { + char buf[32]; + snprintf(buf, sizeof(buf), "$%d", i); + id = mkId(buf); + unless (sym_lookup(id, L_NOWARN)) { + s = sym_mk(buf, L_string, + SCOPE_LOCAL | DECL_LOCAL_VAR); + s->used_p = TRUE; // suppress unused var warning + } + push_lit(buf); + } + emit_invoke(5 + submatch_cnt + mod_cnt); + break; + default: ASSERT(0); + } +} + +private void +compile_twiddleSubst(Expr *expr) +{ + Expr *id, *lhs = expr->a; + int i, modCount, submatchCount; + Sym *s; + Tmp *tmp = NULL; + Tcl_Obj *varList; + + push_lit("::regsub"); + modCount = push_regexpModifiers(expr->b); + /* Submatch vars. This loop always iterates at least once. */ + push_lit("-submatches"); + submatchCount = re_submatchCnt(expr->b); + varList = Tcl_NewObj(); + Tcl_IncrRefCount(varList); + for (i = 0; i <= submatchCount; i++) { + char buf[32]; + snprintf(buf, sizeof(buf), "$%d", i); + id = mkId(buf); + unless (sym_lookup(id, L_NOWARN)) { + s = sym_mk(buf, L_string, + SCOPE_LOCAL | DECL_LOCAL_VAR); + s->used_p = TRUE; // suppress unused var warning + } + Tcl_AppendPrintfToObj(varList, "$%d ", i); + } + push_lit(Tcl_GetString(varList)); + Tcl_DecrRefCount(varList); + push_lit("-line"); + push_lit("--"); + compile_expr(expr->b, L_PUSH_VAL); + // ::regsub <mods> -submatches <varlist> -line -- <re> + compile_expr(expr->c, L_PUSH_VAL); + // ::regsub <mods> -submatches <varlist> -line -- <re> <subst> + compile_expr(lhs, L_PUSH_VALPTR | L_PUSH_VAL | L_LVALUE); + unless (lhs->sym) { + L_errf(expr, "invalid l-value in =~"); + return; + } + if (isdeepdive(lhs)) { + tmp = tmp_get(TMP_REUSE); + // ::regsub <mods> -submatches <varlist> + // -line -- <re> <subst> <lhs-val> <lhs-ptr> + TclEmitInstInt1(INST_ROT, -(8+modCount), L->frame->envPtr); + // <lhs-ptr> ::regsub <mods> -submatches <varlist> + // -line -- <re> <subst> <lhs-val> + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // <lhs-ptr> ::regsub <mods> -submatches <varlist> + // -line -- <re> <lhs-val> <subst> + push_lit(tmp->name); + // <lhs-ptr> ::regsub <mods> -submatches <varlits> + // -line -- <re> <lhs-val> <subst> <tmp-name> + } else { + // ::regsub <mods> -submatches <varlist> + // -line -- <re> <subst> <lhs-val> + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // ::regsub <mods> -submatches <varlist> + // -line -- <re> <lhs-val> <subst> + push_lit(lhs->sym->tclname); + // ::regsub <mods> -submatches <varlist> + // -line -- <re> <lhs-val> <subst> <lhs-name> + } + emit_invoke(modCount + 9); + if (isdeepdive(lhs)) { + // <lhs-ptr> <match> + emit_load_scalar(tmp->idx); + tmp_free(tmp); + // <lhs-ptr> <match> <new-val> + TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr); + // <match> <new-val> <lhs-ptr> + TclEmitInstInt4(INST_L_DEEP_WRITE, + lhs->sym->idx, + L->frame->envPtr); + TclEmitInt4(L_PUSH_NEW, L->frame->envPtr); + // <match> <new-val> + emit_pop(); + } + L_typeck_expect(L_STRING|L_WIDGET, lhs, "in =~"); + // <match> +} + +private void +compile_shortCircuit(Expr *expr) +{ + Jmp *jmp; + unsigned char op; + + /* + * In case the operator "a op b" short-circuits, we need one + * value of "a" on the stack for the test and one for the value of + * the expression. If the operator doesn't short-circuit, we + * pop one of these off and move on to evaluating "b". + */ + ASSERT((expr->op == L_OP_ANDAND) || (expr->op == L_OP_OROR)); + op = (expr->op == L_OP_ANDAND) ? INST_JUMP_FALSE4 : INST_JUMP_TRUE4; + compile_condition(expr->a); + // <a-val> + TclEmitOpcode(INST_DUP, L->frame->envPtr); + // <a-val> <a-val> + jmp = emit_jmp_fwd(op, NULL); + // <a-val> if short-circuit and we jumped out + // <a-val> if did not short-circuit and we're still going + emit_pop(); + compile_condition(expr->b); + fixup_jmps(&jmp); + // <a-val> if short-circuit + // <b-val> if did not short-circuit +} + +/* + * Compile an expression that is used as a conditional test. + * This is compiled like a normal expression except that if it's + * of string type the expression is tested for defined. + */ +private void +compile_condition(Expr *cond) +{ + unless (cond) { + push_lit("1"); + return; + } + if (isaddrof(cond)) { + compile_defined(cond); + } else { + compile_expr(cond, L_PUSH_VAL); + if (isvoid(cond)) { + L_errf(cond, "void type illegal in predicate"); + } + unless (isint(cond) || isfloat(cond) || ispoly(cond)) { + TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr); + } + } + cond->type = L_int; +} + +/* + * Compile if-unless as follows. + * + * No "else" leg: "Else" leg present: + * <eval cond> <eval cond> + * jmpFalse 1 jmpFalse 1 + * <if leg> <if leg> + * 1: jmp 2 + * 1: <else leg> + * 2: + */ +private void +compile_ifUnless(Cond *cond) +{ + Jmp *endjmp, *falsejmp; + + /* Test the condition and jmp if false. */ + compile_condition(cond->cond); + falsejmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + + /* Compile the "if" leg. */ + frame_push(cond, NULL, SEARCH); + compile_stmts(cond->if_body); + + if (cond->else_body) { + /* "Else" leg present. */ + frame_pop(); + frame_push(cond, NULL, SEARCH); + endjmp = emit_jmp_fwd(INST_JUMP4, NULL); + fixup_jmps(&falsejmp); + compile_stmts(cond->else_body); + fixup_jmps(&endjmp); + } else { + /* No "else" leg. */ + fixup_jmps(&falsejmp); + } + frame_pop(); +} + +private void +compile_loop(Loop *loop) +{ + switch (loop->kind) { + case L_LOOP_DO: + compile_do(loop); + break; + case L_LOOP_FOR: + case L_LOOP_WHILE: + compile_for_while(loop); + break; + default: + L_bomb("bad loop type"); + break; + } +} + +/* + * Do loop: + * + * 1: <body> + * <cond> + * jmpTrue 1 + */ +private void +compile_do(Loop *loop) +{ + int body_off; + Jmp *break_jmps, *continue_jmps; + + body_off = currOffset(L->frame->envPtr); + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jmps = L->frame->break_jumps; + continue_jmps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jmps); + + compile_condition(loop->cond); + emit_jmp_back(TCL_TRUE_JUMP, body_off); + fixup_jmps(&break_jmps); +} + +/* + * While loop: For loop: + * + * <pre> + * 1: <cond> 1: <cond> + * jmpFalse 2 jmpFalse 2 + * <body> <body> + * <post> + * jmp 1 jmp 1 + * 2: 2: + */ +private void +compile_for_while(Loop *loop) +{ + int cond_off; + Jmp *break_jmps, *continue_jmps, *out_jmp; + + if (loop->kind == L_LOOP_FOR) compile_exprs(loop->pre, L_DISCARD); + + cond_off = currOffset(L->frame->envPtr); + compile_condition(loop->cond); + out_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jmps = L->frame->break_jumps; + continue_jmps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jmps); + + if (loop->kind == L_LOOP_FOR) compile_exprs(loop->post, L_DISCARD); + + emit_jmp_back(TCL_UNCONDITIONAL_JUMP, cond_off); + fixup_jmps(&out_jmp); + fixup_jmps(&break_jmps); +} + +/* + * Emit a jump instruction to a backwards target. jmp_type is one of + * TCL_UNCONDITIONAL, TCL_TRUE_JUMP, or TCL_FALSE_JUMP. The jump + * opcope is appropriately selected for the jump distance. + */ +private void +emit_jmp_back(TclJumpType jmp_type, int offset) +{ + int op = 0; + int dist = currOffset(L->frame->envPtr) - offset; + + if (dist > 127) { + switch (jmp_type) { + case TCL_UNCONDITIONAL_JUMP: + op = INST_JUMP4; + break; + case TCL_TRUE_JUMP: + op = INST_JUMP_TRUE4; + break; + case TCL_FALSE_JUMP: + op = INST_JUMP_FALSE4; + break; + default: + L_bomb("bad jmp type"); + break; + } + TclEmitInstInt4(op, -dist, L->frame->envPtr); + } else { + switch (jmp_type) { + case TCL_UNCONDITIONAL_JUMP: + op = INST_JUMP1; + break; + case TCL_TRUE_JUMP: + op = INST_JUMP_TRUE1; + break; + case TCL_FALSE_JUMP: + op = INST_JUMP_FALSE1; + break; + default: + L_bomb("bad jmp type"); + break; + } + TclEmitInstInt1(op, -dist, L->frame->envPtr); + } +} + +/* + * Emit a jump instruction with an unknown target offset and return a + * structure that can be passed in to fixup_jmps() to later fix-up the + * target to any desired bytecode offset. Caller must free the + * returned structure. + */ +private Jmp * +emit_jmp_fwd(int op, Jmp *next) +{ + Jmp *ret = (Jmp *)ckalloc(sizeof(Jmp)); + + ret->op = op; + ret->offset = currOffset(L->frame->envPtr); + ret->next = next; + switch (op) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + ret->size = 1; + TclEmitInstInt1(op, 0, L->frame->envPtr); + break; + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + ret->size = 4; + TclEmitInstInt4(op, 0, L->frame->envPtr); + break; + default: + L_bomb("unexpected jump instruction"); + break; + } + return (ret); +} + +/* + * Fix up jump targets to point to the current PC, free the + * passed-in fix-ups list and then set it to NULL. + */ +private void +fixup_jmps(Jmp **p) +{ + int target; + Jmp *t; + Jmp *j = *p; + unsigned char *jmp_pc; + + while (j) { + target = currOffset(L->frame->envPtr) - j->offset; + jmp_pc = L->frame->envPtr->codeStart + j->offset; + switch (j->size) { + case 1: + ASSERT(*jmp_pc == j->op); + TclUpdateInstInt1AtPc(j->op, target, jmp_pc); + break; + case 4: + ASSERT(*jmp_pc == j->op); + TclUpdateInstInt4AtPc(j->op, target, jmp_pc); + break; + default: + L_bomb("unexpected jump fixup"); + break; + } + t = j->next; + ckfree((char *)j); + j = t; + } + *p = NULL; +} + +private void +compile_foreach(ForEach *loop) +{ + /* + * Handle foreach(s in <expr>). + */ + if (loop->expr->op == L_OP_FILE) { + compile_foreachAngle(loop); + return; + } + + compile_expr(loop->expr, L_PUSH_VAL); + + switch (loop->expr->type->kind) { + case L_ARRAY: + case L_LIST: + compile_foreachArray(loop); + break; + case L_HASH: + compile_foreachHash(loop); + break; + case L_STRING: + compile_foreachString(loop); + break; + default: + L_errf(loop->expr, "foreach expression must be" + " array, hash, or string"); + break; + } +} + +/* + * Most of the following function came from tclCompCmds.c + * TclCompileForEachCmd(), modified in various ways for L. + */ +private void +compile_foreachArray(ForEach *loop) +{ + int i, continue_off, num_vars; + Expr *var; + ForeachInfo *info; + ForeachVarList *varlist; + Jmp *break_jumps, *continue_jumps, *false_jump; + int jumpBackDist, jumpBackOffset, infoIndex; + Tmp *loopctrTmp, *valTmp; + + /* The foreach(k=>v in expr) form is illegal in array iteration. */ + if (loop->value) { + L_errf(loop, "=> illegal in foreach over arrays"); + } + + /* + * Type-check the value variables. In "foreach (v1,v2,v3 in + * a)", v* are the value variables or variable list, and a is + * the value list, in tcl terminology. + */ + for (var = loop->key, num_vars = 0; var; var = var->next, ++num_vars) { + unless (sym_lookup(var, 0)) return; // undeclared var + unless (L_typeck_arrElt(var->type, loop->expr->type)) { + L_errf(var, "loop index type incompatible with" + " array element type"); + } + } + + /* Temps for value list value and loop counter. */ + valTmp = tmp_get(TMP_UNSET); + loopctrTmp = tmp_get(TMP_UNSET); + + /* + * ForeachInfo and ForeachVarList are structures required by + * the bytecode interpreter for foreach bytecodes. In our + * case, we have only one value and one variable list + * consisting of num_vars variables. + */ + info = (ForeachInfo *)ckalloc(sizeof(ForeachInfo) + + sizeof(ForeachVarList *)); + info->numLists = 1; + info->firstValueTemp = valTmp->idx; + info->loopCtTemp = loopctrTmp->idx; + varlist = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) + + num_vars * sizeof(int)); + varlist->numVars = num_vars; + for (i = 0, var = loop->key; var; var = var->next, ++i) { + Sym *s = sym_lookup(var, 0); + varlist->varIndexes[i] = s->idx; + } + info->varLists[0] = varlist; + infoIndex = TclCreateAuxData(info, TclGetAuxDataType("ForeachInfo"), + L->frame->envPtr); + + /* The values to iterate through are already on the stack (the + * caller evaluated loop->expr). Assign to the value temp. */ + emit_store_scalar(valTmp->idx); + emit_pop(); + + /* Initialize the loop state. */ + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, L->frame->envPtr); + + /* Top of the loop. Step, and jump out if done. */ + continue_off = currOffset(L->frame->envPtr); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, L->frame->envPtr); + false_jump = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + + /* Loop body. */ + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jumps = L->frame->break_jumps; + continue_jumps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jumps); + + /* End of loop -- jump back to top. */ + jumpBackOffset = currOffset(L->frame->envPtr); + jumpBackDist = jumpBackOffset - continue_off; + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, L->frame->envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, L->frame->envPtr); + } + + fixup_jmps(&false_jump); + + /* Set the value variables to undef. */ + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + for (var = loop->key; var; var = var->next) { + Sym *s = sym_lookup(var, 0); + ASSERT(s); + emit_store_scalar(s->idx); + } + emit_pop(); + + fixup_jmps(&break_jumps); + tmp_free(valTmp); + tmp_free(loopctrTmp); +} + +private void +compile_foreachHash(ForEach *loop) +{ + Sym *key; + Sym *val = NULL; + int body_off, disp; + Jmp *break_jumps, *continue_jumps, *out_jmp; + Tmp *itTmp; + + /* Check types and ensure variables are declared etc. */ + unless ((key = sym_lookup(loop->key, 0))) return; + if (loop->value) { + unless ((val = sym_lookup(loop->value, 0))) return; + unless (L_typeck_compat(val->type, + loop->expr->type->base_type)) { + L_errf(loop->value, "loop index value type " + "incompatible with hash element type"); + } + } + unless (L_typeck_compat(key->type, loop->expr->type->u.hash.idx_type)) { + L_errf(loop->key, + "loop index key type incompatible with hash index type"); + } + if (loop->key->next) { + L_errf(loop, "multiple variables illegal in foreach over hash"); + } + + /* A temp to hold the iterator state.*/ + itTmp = tmp_get(TMP_UNSET); + + /* + * Both DICT_FIRST and DICT_NEXT leave value, key, and done-p + * on the stack. Check done-p and jump out of the loop if + * it's true. (We fixup the jump target once we know the size + * of the loop body.) + */ + TclEmitInstInt4(INST_DICT_FIRST, itTmp->idx, L->frame->envPtr); + out_jmp = emit_jmp_fwd(INST_JUMP_TRUE4, NULL); + + /* + * Update the key and value variables. We save the offset of + * this code so we can jump back to it after DICT_NEXT. + * Note: the caller already pushed loop->expr. + */ + body_off = currOffset(L->frame->envPtr); + emit_store_scalar(key->idx); + emit_pop(); + if (loop->value) emit_store_scalar(val->idx); + emit_pop(); + + /* + * Compile loop body. Note that we must grab the jump fix-ups + * out of the frame before popping it. + */ + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jumps = L->frame->break_jumps; + continue_jumps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jumps); + + /* If there's another entry in the hash, go around again. */ + TclEmitInstInt4(INST_DICT_NEXT, itTmp->idx, L->frame->envPtr); + disp = body_off - currOffset(L->frame->envPtr); + TclEmitInstInt4(INST_JUMP_FALSE4, disp, L->frame->envPtr); + + /* End of the loop. Point the jump after the DICT_FIRST to here. */ + fixup_jmps(&out_jmp); + + /* All done. Cleanup the values that DICT_FIRST/DICT_NEXT left. */ + emit_pop(); + emit_pop(); + + /* Set key and/or value counters to undef. */ + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + emit_store_scalar(key->idx); + if (val) emit_store_scalar(val->idx); + emit_pop(); + + fixup_jmps(&break_jumps); + /* XXX We need to ensure that DICT_DONE happens in the face of + exceptions, so that the refcount on the dict will be + decremented, and the iterator freed. See the + implementation of "dict for" in tclCompCmds.c. --timjr + 2006.11.3 */ + TclEmitInstInt4(INST_DICT_DONE, itTmp->idx, L->frame->envPtr); + tmp_free(itTmp); +} + +/* + * Foreach over a string uses three temp variables (str_idx, len_idx, + * and it_idx) and compiles to this: + * + * str_idx = string value already on stack + * len_idx = [::string length $str_idx] + * it_idx = 0 + * jmp 2 + * 1: loopvar1 = str_idx[it_idx++] + * loopvar2 = str_idx[it_idx++] + * ... + * loopvarn = str_idx[it_idx++] + * <loop body> + * 2: test it_idx < len_idx + * jmp if true to 1 + */ +private void +compile_foreachString(ForEach *loop) +{ + int body_off, jmp_dist; + Jmp *break_jmps, *continue_jmps; + Jmp *cond_jmp = 0; + Expr *id; + Tmp *itTmp, *lenTmp, *strTmp; + + /* The foreach(k=>v in expr) form is illegal in string iteration. */ + if (loop->value) { + L_errf(loop, "=> illegal in foreach over strings"); + } + + /* Temps for the loop index, string value, and string length. */ + itTmp = tmp_get(TMP_REUSE); + lenTmp = tmp_get(TMP_REUSE); + strTmp = tmp_get(TMP_REUSE); + + emit_store_scalar(strTmp->idx); + + push_lit("::string"); + push_lit("length"); + TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr); + emit_invoke(3); + emit_store_scalar(lenTmp->idx); + emit_pop(); + + push_lit("0"); + emit_store_scalar(itTmp->idx); + emit_pop(); + + cond_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + body_off = currOffset(L->frame->envPtr); + + for (id = loop->key; id; id = id->next) { + unless (sym_lookup(id, 0)) return; // undeclared var + unless (L_typeck_compat(id->type, L_string)) { + L_errf(id, "loop index not of string type"); + } + emit_load_scalar(strTmp->idx); + emit_load_scalar(itTmp->idx); + TclEmitInstInt4(INST_L_INDEX, L_IDX_STRING | L_PUSH_VAL, + L->frame->envPtr); + emit_store_scalar(id->sym->idx); + emit_pop(); + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, itTmp->idx, + L->frame->envPtr); + TclEmitInt1(1, L->frame->envPtr); + emit_pop(); + } + + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jmps = L->frame->break_jumps; + continue_jmps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jmps); + + fixup_jmps(&cond_jmp); + emit_load_scalar(itTmp->idx); + emit_load_scalar(lenTmp->idx); + TclEmitOpcode(INST_LT, L->frame->envPtr); + jmp_dist = currOffset(L->frame->envPtr) - body_off; + TclEmitInstInt4(INST_JUMP_TRUE4, -jmp_dist, L->frame->envPtr); + + /* Set the loop counters to undef. */ + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); + for (id = loop->key; id; id = id->next) { + emit_store_scalar(id->sym->idx); + } + emit_pop(); + + fixup_jmps(&break_jmps); + tmp_free(itTmp); + tmp_free(lenTmp); + tmp_free(strTmp); +} + +private void +compile_foreachAngle(ForEach *loop) +{ + Expr *expr = loop->expr->a; + Expr *id; + Tmp *tmp; + Jmp *break_jmps, *continue_jmps, *out_jmp; + int top_off; + + /* Outlaw foreach(s in <>). */ + unless (expr) { + L_errf(loop, "this form is disallowed; did you mean " + "while (buf = <>)?"); + return; + } + + /* The foreach(k=>v in expr) form is illegal in string iteration. */ + if (loop->value) { + L_errf(loop, "=> illegal in foreach over strings"); + } + + push_lit("LgetNextLineInit_"); + compile_expr(expr, L_PUSH_VAL); + + /* Outlaw foreach(s in <a_FILE>). */ + if (typeisf(expr, "FILE")) { + L_errf(loop->expr, + "this form is disallowed; did you mean " + "while (buf = <F>)?"); + return; + } + unless (isstring(expr)) { + L_errf(expr, "in foreach, arg to <> must be a string"); + return; + } + + for (id = loop->key; id; id = id->next) { + unless (sym_lookup(id, 0)) return; // undeclared var + unless (L_typeck_compat(id->type, L_string)) { + L_errf(id, "loop index %s not of string type", id->str); + } + } + + /* + * tmp = LgetNextLineInit_(expr) + * 1: s1 = LgetNextLine_(tmp) + * s2 = LgetNextLine_(tmp) + * ... + * s<n> = LgetNextLine_(tmp) + * if (s1 is undef) jmp 2 + * <loop body> + * jmp 1 + * 2: + */ + + tmp = tmp_get(TMP_REUSE); + emit_invoke(2); + emit_store_scalar(tmp->idx); + emit_pop(); + top_off = currOffset(L->frame->envPtr); + for (id = loop->key; id; id = id->next) { + push_lit("LgetNextLine_"); + emit_load_scalar(tmp->idx); + emit_invoke(2); + emit_store_scalar(id->sym->idx); + emit_pop(); + } + emit_load_scalar(loop->key->sym->idx); + TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr); + out_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + frame_push(loop, NULL, LOOP|SEARCH); + compile_stmts(loop->body); + break_jmps = L->frame->break_jumps; + continue_jmps = L->frame->continue_jumps; + frame_pop(); + fixup_jmps(&continue_jmps); + emit_jmp_back(TCL_UNCONDITIONAL_JUMP, top_off); + fixup_jmps(&break_jmps); + fixup_jmps(&out_jmp); +} + +private void +compile_switch(Switch *sw) +{ + Case *c; + + /* + * If all cases are constant, compile a jump table (fast), + * otherwise compile if-then-else code (slower). + */ + for (c = sw->cases; c; c = c->next) { + if (c->expr && !isconst(c->expr)) break; + } + if (c) { + compile_switch_slow(sw); + } else { + compile_switch_fast(sw); + } +} + +/* + * Generate if-then-else code like the following for a switch statement. + * + * local_tmp = <switch expression> + * # The following is generated for each case except the default case. + * # All jmps are forward jmps. + * next-test: + * load local_tmp + * <case expression> + * <appropriate compare opcode> + * jmp-false next-test + * next-body: + * <case body> + * jmp next-body + * # The following is generated for the default case. + * jmp next-test + * next-body: + * default: + * <case body> + * jmp next-body + * # Statement prologue. + * next-test: + * jmp default # backward jmp, only if default case present + * next-body: + * break-label: # where break stmts jmp to + * pop + */ +private void +compile_switch_slow(Switch *sw) +{ + Expr *e = sw->expr; + Case *c; + int def_off = -1; + int start_off; + Jmp *break_jmps; + Jmp *next_body_jmp = NULL, *next_test_jmp = NULL, *undef_jmp = NULL; + Tmp *tmp; + + compile_expr(e, L_PUSH_VAL); + tmp = tmp_get(TMP_REUSE); + emit_store_scalar(tmp->idx); + emit_pop(); + unless (istype(e, L_INT|L_STRING|L_WIDGET|L_POLY)) { + L_errf(e, "switch expression must be int or string"); + return; + } + + frame_push(sw, NULL, SWITCH|SEARCH); + /* + * If there's a case undef, check that first, because if the + * switch expr is undef, Tcl will still let us get its value + * and it would match a "" case and we don't want that. + */ + for (c = sw->cases; c; c = c->next) { + if (c->expr && isid(c->expr, "undef")) { + start_off = currOffset(L->frame->envPtr); + emit_load_scalar(tmp->idx); + TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr); + undef_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL); + track_cmd(start_off, c->expr); + break; + } + } + for (c = sw->cases; c; c = c->next) { + start_off = currOffset(L->frame->envPtr); + if (c->expr && isid(c->expr, "undef")) { + next_test_jmp = emit_jmp_fwd(INST_JUMP4, next_test_jmp); + fixup_jmps(&undef_jmp); + } else if (c->expr) { + fixup_jmps(&next_test_jmp); + emit_load_scalar(tmp->idx); + if (isregexp(c->expr)) { + compile_reMatch(c->expr); + } else if (isint(e)) { + compile_expr(c->expr, L_PUSH_VAL); + TclEmitOpcode(INST_EQ, L->frame->envPtr); + } else { + compile_expr(c->expr, L_PUSH_VAL); + TclEmitOpcode(INST_STR_EQ, L->frame->envPtr); + } + unless (L_typeck_compat(e->type, c->expr->type)) { + L_errf(c, "case type incompatible" + " with switch expression"); + } + next_test_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, + next_test_jmp); + track_cmd(start_off, c->expr); + } else { // default case (grammar ensures there's at most one) + next_test_jmp = emit_jmp_fwd(INST_JUMP4, next_test_jmp); + ASSERT(def_off == -1); + def_off = currOffset(L->frame->envPtr); + track_cmd(start_off, c); + } + fixup_jmps(&next_body_jmp); + compile_stmts(c->body); + next_body_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + } + fixup_jmps(&next_test_jmp); + if (def_off != -1) { + emit_jmp_back(TCL_UNCONDITIONAL_JUMP, def_off); + } + fixup_jmps(&next_body_jmp); + break_jmps = L->frame->break_jumps; + frame_pop(); + fixup_jmps(&break_jmps); + tmp_free(tmp); +} + +/* + * Generate jump-table code like the following for a switch statement. + * + * <switch expression> + * INST_JUMP_TABLE + * jmp default + * # The following is generated for each case except the default case. + * # All jmps are forward jmps. + * next-body: + * <case body> + * jmp next-body + * # The following is the default case. + * default: + * next-body: + * <case body> (only if default case present) + * jmp next-body (only if default case present) + * # Statement prologue. + * next-body: + * break-label: # where break stmts jmp to + */ +private void +compile_switch_fast(Switch *sw) +{ + Expr *e = sw->expr; + Case *c; + int jt_idx, new, start_off; + Jmp *break_jmps; + Jmp *default_jmp; + Jmp *next_body_jmp = NULL; + Tcl_HashEntry *hPtr; + JumptableInfo *jt; + + jt = (JumptableInfo *)ckalloc(sizeof(JumptableInfo)); + Tcl_InitHashTable(&jt->hashTable, TCL_STRING_KEYS); + jt_idx = TclCreateAuxData(jt, &tclJumptableInfoType, L->frame->envPtr); + + compile_expr(e, L_PUSH_VAL); + unless (istype(e, L_INT|L_STRING|L_WIDGET|L_POLY)) { + L_errf(e, "switch expression must be int or string"); + return; + } + if (isint(e)) { + /* + * Since the jump table keys are strings, add 0 to + * guarantee a canonicalized string rep of an int. + */ + push_lit("0"); + TclEmitOpcode(INST_ADD, L->frame->envPtr); + } + + frame_push(sw, NULL, SWITCH|SEARCH); + + start_off = currOffset(L->frame->envPtr); + TclEmitInstInt4(INST_JUMP_TABLE, jt_idx, L->frame->envPtr); + default_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + + for (c = sw->cases; c; c = c->next) { + if (c->expr) { + ASSERT(isconst(c->expr)); + hPtr = Tcl_CreateHashEntry(&jt->hashTable, + c->expr->str, + &new); + if (new) { + Tcl_SetHashValue(hPtr, + INT2PTR(currOffset(L->frame->envPtr) - + start_off)); + } else { + L_errf(c, "duplicate case value"); + } + unless (L_typeck_compat(e->type, c->expr->type)) { + L_errf(c, + "case type incompatible with switch expression"); + } + } else { // default case (grammar ensures there's at most one) + fixup_jmps(&default_jmp); + } + fixup_jmps(&next_body_jmp); + compile_stmts(c->body); + next_body_jmp = emit_jmp_fwd(INST_JUMP4, NULL); + } + fixup_jmps(&default_jmp); // no-op if default exists (already fixed up) + fixup_jmps(&next_body_jmp); + break_jmps = L->frame->break_jumps; + frame_pop(); + fixup_jmps(&break_jmps); +} + +private VarDecl * +struct_lookupMember(Type *t, Expr *idx, int *offset) +{ + VarDecl *m; + + ASSERT((idx->op == L_OP_DOT) || (idx->op == L_OP_POINTS)); + + unless (t->u.struc.members) { + L_errf(idx, "incomplete struct type %s", t->u.struc.tag); + return (NULL); + } + for (*offset = 0, m = t->u.struc.members; m; m = m->next, ++*offset) { + if (!strcmp(idx->str, m->id->str)) { + return (m); + } + } + return (NULL); +} + +/* + * Determine whether an array index expression contains a reference to + * the array's END index. + */ +private int +has_END(Expr *expr) +{ + Expr *p; + + unless (expr) return (0); + switch (expr->kind) { + case L_EXPR_FUNCALL: + for (p = expr->b; p; p = p->next) { + if (has_END(p)) return (1); + } + return (0); + case L_EXPR_CONST: + case L_EXPR_RE: + return (0); + case L_EXPR_ID: + return (isid(expr, "END")); + case L_EXPR_UNOP: + return (has_END(expr->a)); + case L_EXPR_BINOP: + switch (expr->op) { + case L_OP_ARRAY_INDEX: + /* END in a nested index refers to another array. */ + return (has_END(expr->a)); + case L_OP_CAST: + /* A cast is special: expr->a is a type not an expr. */ + return (has_END(expr->b)); + default: + return (has_END(expr->a) || has_END(expr->b)); + } + case L_EXPR_TRINOP: + if (expr->op == L_OP_ARRAY_SLICE) { + /* END in a nested index refers to another array. */ + return (has_END(expr->a)); + } else { + return (has_END(expr->a) || has_END(expr->b) || + has_END(expr->c)); + } + default: ASSERT(0); + } + /*NOTREACHED*/ + return (0); +} + +/* + * Generate code to push an array/hash/struct/string index onto the stack. + * Return flags suitable for the INST_L_INDEX instruction which indicate + * whether the operator is an array, hash, struct, or string index. + */ +private int +push_index(Expr *expr, int flags) +{ + int ret; + int reuse = flags & L_REUSE_IDX; + int save = flags & L_SAVE_IDX; + Type *type; + VarDecl *member; + Tmp *idxTmp; + int offset; + + /* Error-path return values. */ + ret = 0; + type = L_poly; + + ASSERT(type); + switch (expr->op) { + case L_OP_DOT: + case L_OP_POINTS: + unless (isstruct(expr->a)) { + L_errf(expr, "not a struct"); + goto out; + } + member = struct_lookupMember(expr->a->type, + expr, + &offset); + if (member) { + unless (reuse) push_litf("%i", offset); + type = member->type; + } else { + L_errf(expr, "struct field %s not found", expr->str); + } + ret = L_IDX_ARRAY; + break; + case L_OP_ARRAY_INDEX: + unless (reuse) { + compile_expr(expr->b, L_PUSH_VAL); + if (isid(expr->b, "undef")) { + L_errf(expr->b, "cannot use undef as an " + "array/string index"); + } + } + L_typeck_expect(L_INT, expr->b, "in array/string index"); + if (isarray(expr->a) || islist(expr->a)) { + type = expr->a->type->base_type; + ret = L_IDX_ARRAY; + } else if (isstring(expr->a) || iswidget(expr->a)) { + /* + * Disallow stringvar[0][0] = "x". It doesn't make much + * sense and INST_L_DEEP_WRITE can't handle it anyway. + */ + if ((expr->a->op == L_OP_ARRAY_INDEX) && + expr->a->sym && + isstring(expr->a->a) && + (expr->a->flags & L_LVALUE)) { + L_errf(expr, "cannot index a string index"); + } + type = L_string; + ret = L_IDX_STRING; + } else if (ispoly(expr->a)) { + type = L_poly; + ret = L_IDX_ARRAY; + } else { + L_errf(expr, "not an array or string"); + } + break; + case L_OP_HASH_INDEX: { + unless (reuse) { + compile_expr(expr->b, L_PUSH_VAL); + if (isid(expr->b, "undef")) { + L_errf(expr->b, "cannot use undef as a " + "hash index"); + } + } + if (ishash(expr->a)) { + L_typeck_expect(expr->a->type->u.hash.idx_type->kind, + expr->b, + "in hash index"); + type = expr->a->type->base_type; + } else if (ispoly(expr->a)) { + type = L_poly; + } else { + L_errf(expr, "not a hash"); + } + ret = L_IDX_HASH; + break; + } + default: + L_bomb("Invalid index op, %d", expr->op); + break; + } + out: + if (save) { + // save copy of index to a temp + idxTmp = tmp_get(TMP_REUSE); + expr->u.deepdive.idx = idxTmp; + emit_store_scalar(idxTmp->idx); + } else if (reuse) { + // get index value from temp + idxTmp = expr->u.deepdive.idx; + ASSERT(idxTmp); + emit_load_scalar(idxTmp->idx); + tmp_free(idxTmp); + expr->u.deepdive.idx = NULL; + } + expr->type = type; + return (ret); +} + +/* + * Compile a hash/array/struct/class or string index. These are the + * L_OP_HASH_INDEX, L_OP_ARRAY_INDEX, L_OP_DOT, and L_OP_POINTS nodes. + * + * The resulting stack depends on the flags which specify whether the + * indexed element's value, pointer, or both (and in what order) are + * wanted. We get one of + * + * <elem-obj> if flags & L_PUSH_VAL + * <deep-ptr> if flags & L_PUSH_PTR + * <elem-obj> <deep-ptr> if flags & L_PUSH_VAL_PTR + * <deep-ptr> <elem-obj> if flags & L_PUSH_PTR_VAL + * <tmp-name> if flags & L_PUSH_NAME + * + * For L_PUSH_NAME, we evaluate the indexed expression and store its + * value and all the indices in local temp variables, then use the + * value temp's name as the value of the expression. The expr nodes + * store information about the temps so they can be accessed later, + * such as for the copy-out part of copy in/out parameters. + */ +private int +compile_idxOp(Expr *expr, Expr_f flags) +{ + int ret; + Tmp *valTmp; + + if ((flags & L_PUSH_NAME) && !(flags & L_SAVE_IDX)) { + /* First time through for L_PUSH_NAME. */ + ret = compile_idxOp2(expr, flags | L_PUSH_VAL | L_SAVE_IDX); + /* + * Check whether this was really an object index (we + * don't know until now). + */ + if (isclass(expr->a)) return (ret); + valTmp = tmp_get(TMP_REUSE); + expr->u.deepdive.val = valTmp; + emit_store_scalar(valTmp->idx); + emit_pop(); + push_lit(valTmp->name); + } else { + ret = compile_idxOp2(expr, flags); + } + return (ret); +} + +private int +compile_idxOp2(Expr *expr, Expr_f flags) +{ + int save; + + /* + * Eval the thing being indexed. The flags magic here is + * because we always want its value if it's a variable, or a + * deep-pointer if it's the result of another deep-dive index, + * regardless of in what form we want expr. + */ + compile_expr(expr->a, L_PUSH_PTR | L_PUSH_VAL | + (flags & ~(L_PUSH_VALPTR | + L_PUSH_PTRVAL | + L_DISCARD | + L_PUSH_NAME))); + + /* + * Require "->" for all objects and call-by-reference structures. + * Require "." for all call-by-value and non-parameter structures. + */ + if (isclass(expr->a)) { + unless (expr->op == L_OP_POINTS) { + L_errf(expr, "must access object only with ->"); + } + } else if (expr->a->sym && + (expr->a->sym->decl->flags & DECL_REF) && + !(expr->a->flags & L_EXPR_DEEP)) { + if (expr->op == L_OP_DOT) { + L_errf(expr, ". illegal on call-by-reference " + "parms; use -> instead"); + } + } else { + if (expr->op == L_OP_POINTS) { + L_errf(expr, "-> illegal except on call-by-reference " + "parms; use . instead"); + } + } + + /* + * Handle obj->var. We check here because, in general, we + * don't know until now whether expr->a has type class. + */ + if (isclass(expr->a) && ((expr->op == L_OP_DOT) || + (expr->op == L_OP_POINTS))) { + return (compile_clsInstDeref(expr, flags)); + } + + if (has_END(expr->b)) { + if (flags & L_REUSE_IDX) { + } else if (isstring(expr->a) || iswidget(expr->a)) { + TclEmitOpcode(INST_L_PUSH_STR_SIZE, L->frame->envPtr); + } else { + TclEmitOpcode(INST_L_PUSH_LIST_SIZE, L->frame->envPtr); + } + } + + save = L->idx_op; + L->idx_op = expr->op; + flags |= push_index(expr, flags); + L->idx_op = save; + + if (has_END(expr->b)) { + TclEmitOpcode(INST_L_POP_SIZE, L->frame->envPtr); + } + + /* + * Perform an optimization and don't create a deep pointer if + * the caller won't be doing a deep dive into the expression + * being evaluated but instead just needs its value. This + * happens when the deep dive we're doing now results in + * something of type class and the caller requested a value. + * See the comments in compile_expr(). + * + * This wart is here because the caller can't know in general + * whether expr is a deep dive or a class deref. Their + * expressions look identical but are evaluated in drastically + * different ways. + */ + if (isclass(expr) && (flags & (L_PUSH_VAL | L_DISCARD))) { + flags &= ~(L_PUSH_PTR | L_PUSH_VALPTR | L_PUSH_PTRVAL | + L_LVALUE); + } else if (flags & (L_PUSH_PTR | L_PUSH_VALPTR | L_PUSH_PTRVAL)) { + flags &= ~L_PUSH_VAL; + } + + TclEmitInstInt4(INST_L_INDEX, flags, L->frame->envPtr); + + /* + * Adjust the stack depth that Tcl tracks (debug build) to + * reflect when two objs are left on the stack instead of one + * as indicated by the entry in the tclInstructionTable in + * tclCompile.c + */ + if (flags & (L_PUSH_PTRVAL | L_PUSH_VALPTR)) { + TclAdjustStackDepth(1, L->frame->envPtr); + } + + expr->sym = expr->a->sym; // propagate sym table ptr up the tree + expr->flags = flags | L_EXPR_DEEP; + return ((flags & L_DISCARD) ? 0 : 1); +} + +/* Compile classname->var. */ +private int +compile_clsDeref(Expr *expr, Expr_f flags) +{ + int in_class = 0; + char *clsnm, *varnm; + Sym *sym, *tmpsym; + Tmp *tmp; + Type *type = (Type *)expr->a; + ClsDecl *clsdecl = type->u.class.clsdecl; + Tcl_HashEntry *hPtr; + + expr->type = L_poly; + unless (isclasstype(type)) { + L_errf(expr, "can dereference only class types"); + return (0); + } + + ASSERT(type && clsdecl); + + clsnm = clsdecl->decl->id->str; + varnm = expr->str; + if (L->enclosing_func) { + in_class = L->enclosing_func->decl->flags & DECL_CLASS_FN; + } + + hPtr = Tcl_FindHashEntry(clsdecl->symtab, varnm); + unless (hPtr) { + L_errf(expr, "%s is not a member of class %s", varnm, clsnm); + return (0); + } + sym = (Sym *)Tcl_GetHashValue(hPtr); + unless (in_class || (sym->decl->flags & DECL_PUBLIC)) { + L_errf(expr, "%s is not a public variable of class %s", + varnm, clsnm); + } + unless (sym->decl->flags & DECL_CLASS_VAR) { + L_errf(expr, "%s is not a class variable of class %s", + varnm, clsnm); + } + + if (flags & L_PUSH_NAME) { + push_litf("::L::_class_%s::%s", clsnm, sym->name); + expr->sym = sym; + expr->type = sym->type; + return (1); // stack effect + } + + tmp = tmp_get(TMP_UNSET); + tmpsym = sym_mk(tmp->name, sym->type, SCOPE_LOCAL | DECL_LOCAL_VAR); + ASSERT(tmpsym); // cannot be multiply declared + tmpsym->used_p = TRUE; + + push_litf("::L::_class_%s", clsnm); + push_lit(sym->name); + TclEmitInstInt4(INST_NSUPVAR, tmp->idx, L->frame->envPtr); + emit_pop(); + + expr->sym = tmpsym; + expr->type = sym->type; + + if (flags & L_PUSH_VAL) { + emit_load_scalar(tmp->idx); + return (1); // stack effect + } else { + return (0); // stack effect + } +} + +/* + * Compile obj->var. Code to push the value of obj on the run-time + * stack already has been generated by compile_idxOp(). + */ +private int +compile_clsInstDeref(Expr *expr, Expr_f flags) +{ + int in_class = 0; + char *clsnm, *varnm; + Tmp *tmp; + Sym *sym, *tmpsym; + ClsDecl *clsdecl = expr->a->type->u.class.clsdecl; + Tcl_HashEntry *hPtr; + + ASSERT(isclass(expr->a) && clsdecl); + ASSERT(clsdecl->symtab); + + clsnm = clsdecl->decl->id->str; + varnm = expr->str; + if (L->enclosing_func) { + in_class = L->enclosing_func->decl->flags & DECL_CLASS_FN; + } + + hPtr = Tcl_FindHashEntry(clsdecl->symtab, varnm); + unless (hPtr) { + L_errf(expr, "%s is not a member of class %s", varnm, clsnm); + expr->type = L_poly; + return (0); // stack effect + } + sym = (Sym *)Tcl_GetHashValue(hPtr); + unless (in_class || (sym->decl->flags & DECL_PUBLIC)) { + L_errf(expr, "%s is not a public variable of class %s", + varnm, clsnm); + } + unless (sym->decl->flags & DECL_CLASS_INST_VAR) { + L_errf(expr, "%s is not an instance variable of class %s", + varnm, clsnm); + } + + if (flags & L_PUSH_NAME) { + // Caller already pushed obj value, so concat var name to it. + push_litf("::%s", sym->name); + TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr); + expr->sym = sym; + expr->type = sym->type; + return (1); // stack effect + } + + tmp = tmp_get(TMP_UNSET); + tmpsym = sym_mk(tmp->name, sym->type, SCOPE_LOCAL | DECL_LOCAL_VAR); + ASSERT(tmpsym); // cannot be multiply declared + tmpsym->used_p = TRUE; + + push_lit(sym->name); + TclEmitInstInt4(INST_NSUPVAR, tmp->idx, L->frame->envPtr); + emit_pop(); + + expr->sym = tmpsym; + expr->type = sym->type; + + if (flags & L_PUSH_VAL) { + emit_load_scalar(tmp->idx); + return (1); // stack effect + } else { + return (0); // stack effect + } +} + +private void +compile_assign(Expr *expr) +{ + Expr *lhs = expr->a; + Expr *rhs = expr->b; + + if (lhs->op == L_OP_LIST) { + /* Handle {a,b,c} = ... */ + compile_assignComposite(expr); + } else { + /* Handle regular assignment. */ + compile_expr(rhs, L_PUSH_VAL); + compile_assignFromStack(lhs, rhs->type, expr, 0); + } +} + +private void +compile_assignFromStack(Expr *lhs, Type *rhs_type, Expr *expr, int flags) +{ + /* Whether it's an arithmetic assignment (lhs op= rhs). */ + int arith = (expr && (expr->op != L_OP_EQUALS)); + + compile_expr(lhs, (arith?L_PUSH_VALPTR:L_PUSH_PTR) | L_LVALUE | flags); + unless (lhs->sym) { + L_errf(lhs, "invalid l-value in assignment"); + return; + } + L_typeck_assign(lhs, rhs_type); + + if (isdeepdive(lhs)) { + // <rval> <lhs-ptr> if !arith + // <rval> <lhs-val> <lhs-ptr> if arith + if (arith) { + // <rval> <lhs-val> <lhs-ptr> + TclEmitInstInt4(INST_REVERSE, 3, L->frame->envPtr); + // <lhs-ptr> <lhs-val> <rval> + emit_instrForLOp(expr, expr->type); + // <lhs-ptr> <new-val> + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + } + // <rval> <lhs-ptr> or <new-val> <lhs-ptr> + TclEmitInstInt4(INST_L_DEEP_WRITE, + lhs->sym->idx, + L->frame->envPtr); + TclEmitInt4(L_PUSH_NEW, L->frame->envPtr); + } else { + // <rval> + if (arith) { + emit_load_scalar(lhs->sym->idx); + // <rval> <old-val> + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // <old-val> <rval> + emit_instrForLOp(expr, expr->type); + // <new-val> + } + // <rval> or <new-val> + emit_store_scalar(lhs->sym->idx); + } + // <rval> +} + +private void +compile_assignComposite(Expr *expr) +{ + int i; + Expr *lhs = expr->a; + Expr *rhs = expr->b; + Type *list = NULL, *rhs_elt_type; + VarDecl *member = NULL; + + expr->type = L_poly; + unless (expr->op == L_OP_EQUALS) { + L_errf(expr, "arithmetic assignment illegal"); + lhs->type = L_poly; + rhs->type = L_poly; + return; + } + ASSERT(lhs->op == L_OP_LIST); + + compile_expr(rhs, L_PUSH_VAL); + + /* rhs_elt_type stores the current rhs type as we walk the elts. */ + switch (rhs->type->kind) { + case L_POLY: + rhs_elt_type = L_poly; + break; + case L_ARRAY: + rhs_elt_type = rhs->type->base_type; + break; + case L_STRUCT: + member = rhs->type->u.struc.members; + ASSERT(member); + rhs_elt_type = member->type; + break; + case L_LIST: + list = rhs->type; + rhs_elt_type = list->base_type; + break; + default: + L_errf(expr, + "right-hand side incompatible with composite assign"); + return; + } + /* Assign lhs <- rhs elements (left to right). */ + for (i = 0, lhs = expr->a; lhs; ++i, lhs = lhs->b) { + ASSERT(lhs->op == L_OP_LIST); + /* A lhs undef means skip the corresponding rhs element. */ + unless (isid(lhs->a, "undef")) { + TclEmitInstInt1(INST_L_LINDEX_STK, i, L->frame->envPtr); + compile_assignFromStack(lhs->a, rhs_elt_type, expr, 0); + emit_pop(); + } + /* Advance rhs_elt_type to type of next elt, if known. */ + if (member) { + member = member->next; + rhs_elt_type = member? member->type: NULL; + } else if (list) { + list = list->next; + rhs_elt_type = list? list->base_type: NULL; + } + } + /* Pop rhs. */ + emit_pop(); + /* The value of the assignment is undef. */ + TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr); +} + +private void +compile_incdec(Expr *expr) +{ + Expr *lhs = expr->a; + /* Whether expr is a postfix operator. */ + int post = ((expr->op == L_OP_PLUSPLUS_POST) || + (expr->op == L_OP_MINUSMINUS_POST)); + /* Whether expr is a ++ operator. */ + int inc = ((expr->op == L_OP_PLUSPLUS_PRE) || + (expr->op == L_OP_PLUSPLUS_POST)); + + compile_expr(lhs, L_PUSH_PTRVAL | (post?L_PUSH_VAL:0) | L_LVALUE); + unless (lhs->sym) { + L_errf(expr, "invalid l-value in inc/dec"); + return; + } + L_typeck_expect(L_INT|L_FLOAT, lhs, "in ++/--"); + + if (isdeepdive(lhs)) { + // <lhs-ptr> <lhs-val> + push_lit("1"); + // <hs-ptr> <lhs-val> 1 + TclEmitOpcode(inc?INST_ADD:INST_SUB, L->frame->envPtr); + // <lhs-ptr> <new-val> + TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr); + // <new-val> <lhs-ptr> + TclEmitInstInt4(INST_L_DEEP_WRITE, + lhs->sym->idx, + L->frame->envPtr); + TclEmitInt4(post?L_PUSH_OLD:L_PUSH_NEW, L->frame->envPtr); + } else { + // <old-val> if post + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, lhs->sym->idx, + L->frame->envPtr); + TclEmitInt1(inc? 1 : -1, L->frame->envPtr); + // <old-val> <new-val> if post + // <new-val> if !post + if (post) emit_pop(); + } + // <old-val> if post + // <new-val> if !post +} + +private int +push_regexpModifiers(Expr *regexp) +{ + int n = 0; + + push_lit("-linestop"); + n++; + if (regexp->flags & L_EXPR_RE_I) { + push_lit("-nocase"); + n++; + } + if (regexp->flags & L_EXPR_RE_G) { + push_lit("-all"); + n++; + } + return (n); +} + +private void +emit_instrForLOp(Expr *expr, Type *type) +{ + int arg = 0; + int op = 0; + + switch (expr->op) { + case L_OP_EQUALEQUAL: + case L_OP_NOTEQUAL: + case L_OP_GREATER: + case L_OP_GREATEREQ: + case L_OP_LESSTHAN: + case L_OP_LESSTHANEQ: + switch (type->kind) { + case L_INT: + case L_FLOAT: + case L_POLY: + switch (expr->op) { + case L_OP_EQUALEQUAL: + op = INST_EQ; + break; + case L_OP_NOTEQUAL: + op = INST_NEQ; + break; + case L_OP_GREATER: + op = INST_GT; + break; + case L_OP_GREATEREQ: + op = INST_GE; + break; + case L_OP_LESSTHAN: + op = INST_LT; + break; + case L_OP_LESSTHANEQ: + op = INST_LE; + break; + default: ASSERT(0); + } + break; + case L_STRING: + case L_WIDGET: + switch (expr->op) { + case L_OP_EQUALEQUAL: + op = INST_STR_EQ; + break; + case L_OP_NOTEQUAL: + op = INST_STR_NEQ; + break; + default: + TclEmitOpcode(INST_STR_CMP, L->frame->envPtr); + switch (expr->op) { + case L_OP_GREATER: + push_lit("1"); + op = INST_EQ; + break; + case L_OP_LESSTHAN: + push_lit("-1"); + op = INST_EQ; + break; + case L_OP_GREATEREQ: + push_lit("0"); + op = INST_GE; + break; + case L_OP_LESSTHANEQ: + push_lit("0"); + op = INST_LE; + break; + default: ASSERT(0); + } + break; + } + break; + default: + // We get here only for eq() of a composite type + // w/no numerics. + op = INST_STR_EQ; + break; + } + break; + case L_OP_STR_EQ: + op = INST_STR_EQ; + break; + case L_OP_STR_NE: + op = INST_STR_NEQ; + break; + case L_OP_STR_GT: + case L_OP_STR_GE: + case L_OP_STR_LT: + case L_OP_STR_LE: + TclEmitOpcode(INST_STR_CMP, L->frame->envPtr); + switch (expr->op) { + case L_OP_STR_GT: + push_lit("1"); + op = INST_EQ; + break; + case L_OP_STR_LT: + push_lit("-1"); + op = INST_EQ; + break; + case L_OP_STR_GE: + push_lit("0"); + op = INST_GE; + break; + case L_OP_STR_LE: + push_lit("0"); + op = INST_LE; + break; + default: ASSERT(0); + } + break; + case L_OP_PLUS: + case L_OP_EQPLUS: + op = INST_ADD; + break; + case L_OP_MINUS: + case L_OP_EQMINUS: + op = INST_SUB; + break; + case L_OP_STAR: + case L_OP_EQSTAR: + op = INST_MULT; + break; + case L_OP_SLASH: + case L_OP_EQSLASH: + op = INST_DIV; + break; + case L_OP_PERC: + case L_OP_EQPERC: + op = INST_MOD; + break; + case L_OP_BITAND: + case L_OP_EQBITAND: + op = INST_BITAND; + break; + case L_OP_BITOR: + case L_OP_EQBITOR: + op = INST_BITOR; + break; + case L_OP_BITXOR: + case L_OP_EQBITXOR: + op = INST_BITXOR; + break; + case L_OP_LSHIFT: + case L_OP_EQLSHIFT: + op = INST_LSHIFT; + break; + case L_OP_RSHIFT: + case L_OP_EQRSHIFT: + op = INST_RSHIFT; + break; + case L_OP_UMINUS: + op = INST_UMINUS; + break; + case L_OP_UPLUS: + op = INST_UPLUS; + break; + case L_OP_BANG: + op = INST_LNOT; + break; + case L_OP_BITNOT: + op = INST_BITNOT; + break; + default: + break; + } + if (op) { + TclEmitOpcode(op, L->frame->envPtr); + return; + } + switch (expr->op) { + case L_OP_EQDOT: + op = INST_STR_CONCAT1; + arg = 2; + break; + default: + L_bomb("Unable to map operator %d to an instruction", expr->op); + break; + } + if (op) { + TclEmitInstInt1(op, arg, L->frame->envPtr); + } +} + +private void +compile_continue(Stmt *stmt) +{ + Frame *loop_frame = frame_find(LOOP); + + unless (loop_frame) { + L_errf(stmt, "continue allowed only inside loops"); + return; + } + loop_frame->continue_jumps = emit_jmp_fwd(INST_JUMP4, + loop_frame->continue_jumps); +} + +private void +compile_break(Stmt *stmt) +{ + Frame *loop_frame = frame_find(LOOP|SWITCH); + + unless (loop_frame) { + L_errf(stmt, + "break allowed only inside switch and loop statements"); + return; + } + loop_frame->break_jumps = emit_jmp_fwd(INST_JUMP4, + loop_frame->break_jumps); +} + +private void +compile_label(Stmt *stmt) +{ + Label *label; + + if (!strcmp(stmt->u.label, "break")) { + L_errf(stmt, "break is not a legal label"); + } + label = label_lookup(stmt, LABEL_DEF); + fixup_jmps(&label->fixups); + label->fixups = NULL; + label->offset = currOffset(L->frame->envPtr); +} + +private void +compile_goto(Stmt *stmt) +{ + Label *label; + + label = label_lookup(stmt, LABEL_USE); + if (label->offset >= 0) { + emit_jmp_back(TCL_UNCONDITIONAL_JUMP, label->offset); + } else { + label->fixups = emit_jmp_fwd(INST_JUMP4, label->fixups); + } +} + +private Label * +label_lookup(Stmt *stmt, Label_f flags) +{ + int new; + char *name = stmt->u.label; + Label *label = NULL; + Frame *frame; + Tcl_HashEntry *hPtr = NULL; + + /* Labels are restricted to the enclosing proc's labeltab. */ + frame = frame_find(FUNC); + ASSERT(frame); + + hPtr = Tcl_FindHashEntry(frame->labeltab, name); + if (hPtr) { + label = (Label *)Tcl_GetHashValue(hPtr); + } else { + label = (Label *)ckalloc(sizeof(Label)); + memset(label, 0, sizeof(Label)); + label->name = name; + label->offset = -1; + hPtr = Tcl_CreateHashEntry(frame->labeltab, name, &new); + ASSERT(new); + Tcl_SetHashValue(hPtr, label); + } + if ((flags & LABEL_DEF) && (label->offset >= 0)) { + L_errf(stmt, "label %s already defined", name); + } + return (label); +} + +private void +emit_globalUpvar(Sym *sym) +{ + VarDecl *decl = sym->decl; + char *id = sym->name; + + /* + * Tim comment: We attempt to detect whether L global + * variables should be true globals, or should be shared with + * the calling proc, by checking if the current variable frame + * pointer in interp is the same as the global frame pointer. + * (Sharing variables with the calling proc is useful if you + * want to use L as an expr replacement). + */ + if (((Interp *)L->interp)->rootFramePtr != + ((Interp *)L->interp)->varFramePtr) { + ASSERT(!(decl->flags & (DECL_CLASS_VAR | DECL_CLASS_INST_VAR))); + frame_resumePrologue(); + push_lit("#0"); + push_lit(id); + TclEmitInstInt4(INST_UPVAR, sym->idx, L->frame->envPtr); + emit_pop(); + frame_resumeBody(); + return; + } + + /* + * The namespace of the var we're creating an upvar alias to is + * either ::, an L class namespace, or an L class instance namespace + * where the local "self" holds the namespace name. + */ + frame_resumePrologue(); + switch (decl->flags & + (DECL_GLOBAL_VAR | DECL_CLASS_VAR | DECL_CLASS_INST_VAR)) { + case DECL_GLOBAL_VAR: + push_lit("::"); + /* Private globals get mangled to avoid clashes. */ + if (decl->flags & DECL_PRIVATE) { + push_litf("_%s_%s", L->toplev, id); + } else { + push_lit(id); + } + break; + case DECL_CLASS_VAR: + push_litf("::L::_class_%s", decl->clsdecl->decl->id->str); + push_lit(id); + break; + case DECL_CLASS_INST_VAR: { + Sym *self = sym_lookup(mkId("self"), L_NOWARN); + ASSERT(self); + emit_load_scalar(self->idx); + push_lit(id); + break; + } + } + TclEmitInstInt4(INST_NSUPVAR, sym->idx, L->frame->envPtr); + emit_pop(); + frame_resumeBody(); +} + +/* + * Add a variable or function name to the symbol table. If it's a + * local variable, allocate a slot for it in the current proc. + * + * Print an error if the symbol is already defined. The rules are + * + * - Multiply defined globals are illegal, with the exception that + * main() can be re-defined. + * - A local cannot shadow any other local in the proc. + * - A local can shadow a global. + * - A local can shadow a global upvar shadow (which is a local + * with special status). + * + * Scopes are created as follows. The complexity stems from Tcl + * requiring local upvar shadows as the only way to access globals. + * So we have a scope in which the global symbol is stored and a + * nested scope for the proc in which the local upvar shadow is + * stored. + * + * There is one scope hierarchy per Tcl Interp in which L code + * appears, as illustrated next. OUTER,SCRIPT,TOPLEV,SKIP etc are frame + * flags (Frame_f); SKIP means that the scope is skipped when + * searching enclosing scopes. + * + * [ outer-most scope (OUTER): public globals go in this frame's symtab + * [ file scope (SCRIPT): private globals go in this frame's symtab + * [ * (%%n_toplevel proc) (TOPLEV|SKIP) + * global initializers get compiled in this scope, causing the + * local upvar shadows to go in this scope's symtab + * [ class outer-most (CLS_OUTER): class/instance vars & private + * member fns go in this frame's symtab + * [ * class top-level (CLS_TOPLEV|SKIP) + * class variable initializers get compiled in this scope + * (note that this is still in the %%n_toplevel proc) + * [ (constructor proc) + * instance var initializers get compiled here + * ] + * [ (destructor proc) + * ] + * [ (member fn proc): public fn names go in outer-most + * scope's, symtable, private fn names go in class + * outer-most scope, fn locals go in this frame's + * symtab + * [ block + * [ nested blocks... + * ] + * ] + * ] + * ] + * ] + * [ regular function (proc): public fn name goes in outer-most + * scope's symtab, private fn name goes in file scope's symtab, + * fn locals go in this frame's symtab + * [ block + * [ nested blocks... + * ] + * ] + * ] + * ] + * ] + * ] + */ +private Sym * +sym_store(VarDecl *decl) +{ + int new; + char *name = decl->id->str; + Sym *sym = NULL; + Sym *sym2; + Frame *frame = NULL; + Tcl_HashEntry *hPtr; + + /* Check for multiple declaration. */ + switch (decl->flags & + (SCOPE_LOCAL | SCOPE_GLOBAL | SCOPE_SCRIPT | SCOPE_CLASS)) { + case SCOPE_GLOBAL: + case SCOPE_SCRIPT: + /* Declaring a global -- search outer-most and file frames. */ + frame = frame_find(OUTER); + hPtr = Tcl_FindHashEntry(frame->symtab, name); + unless (hPtr) { + frame = frame_find(SCRIPT); + hPtr = Tcl_FindHashEntry(frame->symtab, name); + } + if (hPtr) { + sym2 = (Sym *)Tcl_GetHashValue(hPtr); + if (decl->flags & DECL_EXTERN) { + sym = (Sym *)Tcl_GetHashValue(hPtr); + if (L_typeck_same(decl->type, sym->type)) { + return (sym); + } + L_errf(decl, + "extern re-declaration type does not " + "match other declaration"); + return (NULL); + } else if (sym2->decl->flags & DECL_ERR) { + Tcl_DeleteHashEntry(hPtr); + } else { + L_errf(decl, + "multiple declaration of global %s", name); + return (NULL); + } + } + break; + case SCOPE_CLASS: + /* Declaring class var -- search up thru class outer scope. */ + for (frame = L->frame; frame; frame = frame->prevFrame) { + hPtr = Tcl_FindHashEntry(frame->symtab, name); + if (hPtr) { + sym2 = (Sym *)Tcl_GetHashValue(hPtr); + if (sym2->decl->flags & DECL_ERR) { + Tcl_DeleteHashEntry(hPtr); + } else { + L_errf(decl, "multiple declaration of %s", + name); + return (NULL); + } + } + if (frame->flags & CLS_OUTER) break; + } + break; + case SCOPE_LOCAL: + /* + * Declaring a local -- search current proc's local + * scopes, then the global scope so we can issue a warning + * if this is a local that shadows a class or global var. + */ + for (frame = L->frame; frame; frame = frame->prevFrame) { + unless (frame->envPtr == L->frame->envPtr) break; + hPtr = Tcl_FindHashEntry(frame->symtab, name); + if (hPtr) { + sym = (Sym *)Tcl_GetHashValue(hPtr); + ASSERT(sym->kind & L_SYM_LVAR); + unless (sym->kind & L_SYM_LSHADOW) { + L_errf(decl, "multiple declaration " + "of local %s", name); + return (NULL); + } + } + } + for (; frame; frame = frame->prevFrame) { + hPtr = Tcl_FindHashEntry(frame->symtab, name); + unless (hPtr && (frame->flags & SEARCH)) continue; + sym2 = (Sym *)Tcl_GetHashValue(hPtr); + if (sym2->decl->flags & DECL_GLOBAL_VAR) { + L_warnf(decl, "local variable %s shadows " + "a global declared at %s:%d", + name, sym2->decl->node.loc.file, + sym2->decl->node.loc.line); + } else if (sym2->decl->flags & DECL_CLASS_VAR) { + L_warnf(decl, "local variable %s shadows " + "a class variable declared at %s:%d", + name, sym2->decl->node.loc.file, + sym2->decl->node.loc.line); + } else if (sym2->decl->flags & DECL_CLASS_INST_VAR) { + L_warnf(decl, "local variable %s shadows a " + "class instance variable declared " + "at %s:%d", name, + sym2->decl->node.loc.file, + sym2->decl->node.loc.line); + } + } + break; + default: + ASSERT(0); + break; + } + + /* Select the frame to add the symbol to. */ + switch (decl->flags & + (SCOPE_LOCAL | SCOPE_GLOBAL | SCOPE_SCRIPT | SCOPE_CLASS)) { + case SCOPE_GLOBAL: + frame = frame_find(OUTER); + break; + case SCOPE_SCRIPT: + frame = frame_find(SCRIPT); + break; + case SCOPE_CLASS: + frame = frame_find(CLS_OUTER); + break; + case SCOPE_LOCAL: + frame = L->frame; + break; + default: + ASSERT(0); + break; + } + hPtr = Tcl_CreateHashEntry(frame->symtab, name, &new); + /* If it's not new, it must be shadowing a global. */ + ASSERT(new || (sym && (sym->kind & L_SYM_LSHADOW) && + (decl->flags & (DECL_LOCAL_VAR | DECL_CLASS_INST_VAR)))); + sym = (Sym *)ckalloc(sizeof(Sym)); + memset(sym, 0, sizeof(*sym)); + sym->name = ckstrdup(name); + sym->type = decl->type; + sym->decl = decl; + + /* + * Set the name of the tcl variable, mangling it to avoid + * clashes. + */ + if (isfntype(decl->type)) { + ASSERT(decl->flags & (DECL_FN | DECL_CLASS_FN)); + sym->kind = L_SYM_FN; + if (decl->tclprefix) { + sym->tclname = cksprintf("%s%s", decl->tclprefix, name); + } else { + sym->tclname = ckstrdup(name); + } + } else if (decl->flags & DECL_GLOBAL_VAR) { + sym->kind = L_SYM_GVAR; + sym->tclname = cksprintf("_%s", name); + } else if (decl->flags & (DECL_CLASS_VAR | DECL_CLASS_INST_VAR)) { + sym->kind = L_SYM_GVAR; + sym->tclname = cksprintf("_%s_%s", + decl->clsdecl->decl->id->str, + name); + } else { + ASSERT(decl->flags & DECL_LOCAL_VAR); + sym->kind = L_SYM_LVAR; + sym->tclname = ckstrdup(name); + } + + /* If a local, allocate a slot for it. */ + if (sym->kind & L_SYM_LVAR) { + sym->idx = TclFindCompiledLocal(name, strlen(name), + 1, L->frame->envPtr); + } else { + sym->idx = -1; + } + + decl->id->sym = sym; + decl->id->type = decl->type; + Tcl_SetHashValue(hPtr, sym); + + return (sym); +} + +/* + * Lookup id in the symbol table. + * + * flags & L_NOTUSED ==> don't mark the id as having been referenced + * (used for warning which variables are unused). + * + * flags & L_NOWARN ==> don't print error message if id not found. + * + * The first time a global is referenced within a scope, an upvar is + * created for it. + */ +private Sym * +sym_lookup(Expr *id, Expr_f flags) +{ + int new; + char *name; + Sym *shw; + Sym *sym = NULL; + Frame *frame; + Tcl_HashEntry *hPtr = NULL; + + unless (id->kind == L_EXPR_ID) return (NULL); + name = id->str; + + for (frame = L->frame; frame; frame = frame->prevFrame) { + if ((frame->envPtr == L->frame->envPtr) || + (frame->flags & SEARCH)) { + hPtr = Tcl_FindHashEntry(frame->symtab, name); + if (hPtr) break; + } + } + if (hPtr) sym = (Sym *)Tcl_GetHashValue(hPtr); + if (sym) { + /* + * If a global is being referenced for the first time + * in this scope, create a local upvar to shadow it + * in the symtab of the enclosing proc or top-level. + */ + if ((sym->kind & L_SYM_GVAR) && (sym->idx == -1)) { + Frame *proc_frame; + // assert global => in outer-most or file frame + ASSERT(!(sym->decl->flags & DECL_GLOBAL_VAR) || + (frame->flags & (OUTER|SCRIPT))); + // assert class var => in class outer-most frame + ASSERT(!(sym->decl->flags & DECL_CLASS_VAR) || + (frame->flags & CLS_OUTER)); + // assert class instance var => class outer-most frame + ASSERT(!(sym->decl->flags & DECL_CLASS_INST_VAR) || + (frame->flags & CLS_OUTER)); + proc_frame = frame_find(TOPLEV|CLS_TOPLEV|FUNC); + ASSERT(proc_frame); + hPtr = Tcl_CreateHashEntry(proc_frame->symtab, name, + &new); + ASSERT(new); + shw = (Sym *)ckalloc(sizeof(Sym)); + memset(shw, 0, sizeof(*shw)); + shw->kind = L_SYM_LVAR | L_SYM_LSHADOW; + shw->name = ckstrdup(name); + shw->tclname = ckstrdup(sym->tclname); + shw->type = sym->decl->type; + shw->decl = sym->decl; + shw->used_p = TRUE; + shw->idx = TclFindCompiledLocal(shw->tclname, + strlen(shw->tclname), + 1, + L->frame->envPtr); + emit_globalUpvar(shw); + Tcl_SetHashValue(hPtr, shw); + sym = shw; + } + unless (flags & L_NOTUSED) sym->used_p = TRUE; + id->sym = sym; + id->type = sym->type; + return (sym); + } else { + ASSERT(id->sym == NULL); + unless (flags & L_NOWARN) { + /* + * Add the undeclared variable to the symtab to avoid + * cascading errors. + */ + YYLTYPE loc = id->node.loc; + VarDecl *decl = ast_mkVarDecl(L_poly, id, loc, loc); + decl->flags = DECL_ERR | DECL_ARGUSED; + switch (L->frame->flags & (FUNC|CLS_TOPLEV|TOPLEV)) { + case TOPLEV | FUNC: + decl->flags |= SCOPE_GLOBAL | DECL_GLOBAL_VAR; + break; + case CLS_TOPLEV: + decl->flags |= SCOPE_CLASS | DECL_CLASS_VAR; + ASSERT(L->frame->clsdecl); + decl->clsdecl = L->frame->clsdecl; + break; + case FUNC: + case 0: // stmt block + decl->flags |= SCOPE_LOCAL | DECL_LOCAL_VAR; + break; + default: ASSERT(0); + } + L_errf(id, "undeclared variable: %s", name); + id->sym = sym_store(decl); + } + id->type = L_poly; + return (NULL); + } +} + +private Sym * +sym_mk(char *name, Type *t, Decl_f flags) +{ + YYLTYPE loc = { 0 }; + Expr *id = mkId(name); + VarDecl *decl = ast_mkVarDecl(t, id, loc, loc); + + decl->flags = flags; + return (sym_store(decl)); +} + +private Tmp * +tmp_get(TmpKind kind) +{ + Tmp *tmp; + + for (tmp = L->frame->tmps; tmp; tmp = tmp->next) { + if (tmp->free) break; + } + unless (tmp) { + tmp = (Tmp *)ckalloc(sizeof(*tmp)); + tmp->next = L->frame->tmps; + L->frame->tmps = tmp; + tmp->name = cksprintf("=temp%d", L->tmpnum++); + tmp->idx = TclFindCompiledLocal(tmp->name, strlen(tmp->name), + 1, L->frame->envPtr); + } + tmp->free = 0; + /* + * Sometimes we need a tmp var that is not set to anything. + * For example, to create an upvar or to use the INST_DICT_* + * bytecodes. + */ + if (kind == TMP_UNSET) { + TclEmitInstInt4(INST_UNSET_LOCAL, tmp->idx, L->frame->envPtr); + } + return (tmp); +} + +private void +tmp_free(Tmp *tmp) +{ + if (tmp) tmp->free = 1; +} + +private void +tmp_freeAll(Tmp *tmp) +{ + while (tmp) { + Tmp *next = tmp->next; + ckfree((char *)tmp); + tmp = next; + } +} + +void +L_bomb(const char *format, ...) +{ + va_list ap; + + va_start(ap, format); + fprintf(stderr, "L Internal Error: "); + vfprintf(stderr, format, ap); + va_end(ap); + fprintf(stderr, "\n"); + exit(1); +} + +/* + * L_synerr is Bison's yyerror and is called by the parser for syntax + * errors. Bail out by longjumping back to Tcl_LObjCmd, as a way + * to work-around a possible compiler bug in our Windows build where + * the Bison-generated parser's own internal longjmp causes a crash. + */ +void +L_synerr(const char *s) +{ + int i, off; + char *beg = Tcl_GetString(L->script); + char *end = beg + L->script_len; + char *line, *stop; + + unless (L->errs) { + L->errs = Tcl_NewObj(); + L->err = 1; + } + Tcl_AppendPrintfToObj(L->errs, "%s:%d: L Error: %s\n", + L->file, L->line, s); + + /* Search backwards to find the start of the offending line. */ + off = L_lloc.beg; + ASSERT(off >= 0); + ASSERT(beg); + for (line = beg+off; (line > beg) && (line[-1] != '\n'); --line) ; + off = beg+off - line; // is now offset from start of offending line + + /* Print the offending line with a ^ pointing to the current token. */ + stop = line + off; + for (i = 1; (*line != '\n') && (line < end); ++i) { + // adjust for tab printing >1 char + if ((*line == '\t') && (line <= stop)) { + off += 8 - i%8; + i += 7; + } + Tcl_AppendToObj(L->errs, line++, 1); + } + Tcl_AppendToObj(L->errs, "\n", 1); + ASSERT(off >= 0); + while (off--) Tcl_AppendToObj(L->errs, " ", 1); + Tcl_AppendToObj(L->errs, "^\n", 2); + + longjmp(L->jmp, 0); +} + +/* + * Like L_synerr() above but take the offset of the offending token + * instead of using the current token. + */ +void +L_synerr2(const char *s, int offset) +{ + L_lloc.beg = offset; + L_synerr(s); +} + +void +L_warnf(void *node, const char *format, ...) +{ + va_list ap; + int len = 64; + char *buf, *fmt; + + if (hash_get(L->options, "nowarn")) return; + + fmt = cksprintf("%s:%d: L Warning: %s\n", + ((Ast *)node)->loc.file, ((Ast *)node)->loc.line, + format); + va_start(ap, format); + while (!(buf = ckvsprintf(fmt, ap, len))) { + va_end(ap); + va_start(ap, format); + len *= 2; + } + va_end(ap); + unless (L->errs) { + L->errs = Tcl_NewObj(); + L->err = 1; + } + Tcl_AppendToObj(L->errs, buf, -1); + ckfree(fmt); + ckfree(buf); +} + +void +L_err(const char *format, ...) +{ + va_list ap; + int len = 64; + char *buf, *fmt; + + fmt = cksprintf("%s:%d: L Error: %s\n", L->file, L->line, format); + va_start(ap, format); + while (!(buf = ckvsprintf(fmt, ap, len))) { + va_end(ap); + va_start(ap, format); + len *= 2; + } + va_end(ap); + unless (L->errs) { + L->errs = Tcl_NewObj(); + L->err = 1; + } + Tcl_AppendToObj(L->errs, buf, -1); + ckfree(fmt); + ckfree(buf); +} + +void +L_errf(void *node, const char *format, ...) +{ + va_list ap; + int len = 64; + char *buf, *fmt; + + if (node) { + fmt = cksprintf("%s:%d: L Error: %s\n", + ((Ast *)node)->loc.file, + ((Ast *)node)->loc.line, + format); + } else { + fmt = cksprintf("L Error: %s\n", format); + } + va_start(ap, format); + while (!(buf = ckvsprintf(fmt, ap, len))) { + va_end(ap); + va_start(ap, format); + len *= 2; + } + va_end(ap); + unless (L->errs) { + L->errs = Tcl_NewObj(); + L->err = 1; + } + Tcl_AppendToObj(L->errs, buf, -1); + ckfree(fmt); +} + +private void +ast_free(Ast *ast_list) +{ + while (ast_list) { + Ast *node = ast_list; + ast_list = ast_list->next; + switch (node->type) { + case L_NODE_STMT: { + Stmt *s = (Stmt *)node; + if ((s->kind == L_STMT_LABEL) || + (s->kind == L_STMT_GOTO)) { + ckfree(s->u.label); + } + break; + } + case L_NODE_EXPR: + ckfree(((Expr *)node)->str); + break; + case L_NODE_VAR_DECL: + ckfree(((VarDecl *)node)->tclprefix); + break; + default: + break; + } + ckfree((char *)node); + } +} + +private void +type_free(Type *type_list) +{ + while (type_list) { + Type *type = type_list; + type_list = type_list->list; + if (type->kind == L_STRUCT) ckfree(type->u.struc.tag); + ckfree(type->name); + ckfree((char *)type); + } +} + +/* + * This is basically a whacked version of EnterCmdStartData and + * EnterCmdWordData from tclCompile.c. + */ +private void +track_cmd(int codeOffset, void *node) +{ + int cmdIndex = L->frame->envPtr->numCommands++; + Ast *ast = (Ast *)node; + int len = ast->loc.end - ast->loc.beg; + int srcOffset = ast->loc.beg; + ECL *ePtr; + CmdLocation *cmdLocPtr; + CompileEnv *envPtr = L->frame->envPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + Tcl_Panic("track_cmd: bad command index %d", cmdIndex); + } + if (cmdIndex >= envPtr->cmdMapEnd) { + /* + * Expand the command location array by allocating + * more storage from the heap. The currently allocated + * CmdLocation entries are stored from cmdMapPtr[0] up + * to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). + */ + size_t currElems = envPtr->cmdMapEnd; + size_t newElems = 2*currElems; + size_t currBytes = currElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); + CmdLocation *newPtr = (CmdLocation *)ckalloc((int)newBytes); + + /* + * Copy from old command location array to new, free + * old command location array if needed, and mark new + * array as malloced. + */ + memcpy(newPtr, envPtr->cmdMapPtr, currBytes); + if (envPtr->mallocedCmdMap) ckfree((char *)envPtr->cmdMapPtr); + envPtr->cmdMapPtr = (CmdLocation *)newPtr; + envPtr->cmdMapEnd = newElems; + envPtr->mallocedCmdMap = 1; + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->codeOffset = codeOffset; + cmdLocPtr->srcOffset = srcOffset; + cmdLocPtr->numSrcBytes = len; + cmdLocPtr->numCodeBytes = currOffset(envPtr) - codeOffset; + + /* + * The command locations have to be sorted in ascending order + * by codeOffset. (Or Tcl panics in GetCmdLocEncodingSize(), + * if nothing else). However, when L compiles nested function + * calls, the outer one will get tracked second, even though + * it begins first. So we walk the new CmdLocation entry back + * from the end until it lands where it belongs. + */ + while ((cmdIndex > 0) && (envPtr->cmdMapPtr[cmdIndex-1].codeOffset > + envPtr->cmdMapPtr[cmdIndex].codeOffset)) { + CmdLocation cmdLoc = envPtr->cmdMapPtr[cmdIndex]; + envPtr->cmdMapPtr[cmdIndex] = envPtr->cmdMapPtr[cmdIndex-1]; + envPtr->cmdMapPtr[cmdIndex-1] = cmdLoc; + cmdIndex--; + } + + if (eclPtr->nuloc >= eclPtr->nloc) { + /* + * Expand the ECL array by allocating more storage + * from the heap. The currently allocated ECL entries + * are stored from eclPtr->loc[0] up to + * eclPtr->loc[eclPtr->nuloc-1] (inclusive). + */ + size_t currElems = eclPtr->nloc; + size_t newElems = (currElems ? 2*currElems : 1); + size_t newBytes = newElems * sizeof(ECL); + eclPtr->loc = (ECL *) ckrealloc((char *) eclPtr->loc, newBytes); + eclPtr->nloc = newElems; + } + + /* We enter only one word for the L command. */ + ePtr = &eclPtr->loc[eclPtr->nuloc]; + ePtr->srcOffset = srcOffset; + ePtr->line = (int *) ckalloc(sizeof(int)); + ePtr->nline = 1; + eclPtr->nuloc ++; +} + +/* + * API for tracking when we are compiling a function argument. This is + * used to check whether an (expand) operator is being used as a + * function argument (OK) or as something else (error). + * + * fnCallBegin: call just before compiling a fn call + * fnCallEnd: call just after compiling a fn call + * fnInArgList: returns 1 if we are just starting to compile a + * fn call arg; returns 0 if we're either outside of a + * fn call or nested within an expression inside of + * an arg: + * foo(x) -- true + * foo(x+y) -- false + */ +private int +fnCallBegin() +{ + int old = L->call_level; + L->call_level = L->expr_level; + return (old); +} +private void +fnCallEnd(int lev) +{ + L->call_level = lev; +} +private int +fnInArgList() +{ + return (L->expr_level == (L->call_level + 1)); +} + +private Expr * +mkId(char *name) +{ + YYLTYPE loc = { 0 }; + + return (ast_mkId(name, loc, loc)); +} + +char * +ckstrdup(const char *str) +{ + if (str) { + return (ckstrndup(str, strlen(str))); + } else { + return (NULL); + } +} + +char * +ckstrndup(const char *str, int len) +{ + char *newStr = ckalloc(len+1); + + strncpy(newStr, str, len); + newStr[len] = '\0'; + return (newStr); +} + +char * +cksprintf(const char *fmt, ...) +{ + va_list ap; + int len = 64; + char *buf; + + va_start(ap, fmt); + while (!(buf = ckvsprintf(fmt, ap, len))) { + va_end(ap); + va_start(ap, fmt); + len *= 2; + } + va_end(ap); + return (buf); +} + +/* + * Allocate a buffer of len bytes and attempt a vsnprintf and fail + * (return NULL) if len isn't enough. The caller should double len + * and re-try. We require the caller to re-try instead of re-trying + * here because on some platforms "ap" is changed by the vsnprintf + * call and there is no portable way to save and restore it. + */ +char * +ckvsprintf(const char *fmt, va_list ap, int len) +{ + char *buf = ckalloc(len); + int ret = vsnprintf(buf, len, fmt, ap); + /* + * The meaning of the return value depends on the platform. + * Some return the needed length (minus 1), some return -1, + * some truncate the buffer. For the latter, ret will be + * len-1 and we won't know whether it barely fit or wasn't + * enough, so just fail on that case. + */ + if ((ret >= (len-1)) || (ret < 0)) { + ckfree(buf); + return (NULL); + } + return (buf); +} + +/* + * Since we have C-like variable declarations in L, when hashes and + * arrays are declared, the base type is parsed separately from the + * array sizes or hash-element types. The next two functions put them + * back together. E.g., in + * + * string h{int}; + * + * the main type passed in to these functions is a hash type + * (w/index type of "int") but the hash type doesn't yet have its + * base type set, which in this example is "string". + * + * For simple declarations (like "string s") where there is no + * explicit array or hash, decl->type won't be set by the parser, so + * the base type goes there. For arrays/hashes, decl->type points to + * the first level of array or hash, and the base type must go onto + * the last nested hash or array type. + */ + +void +L_set_baseType(Type *type, Type *base_type) +{ + while (type->base_type) { + ASSERT((type->kind == L_ARRAY) || + (type->kind == L_HASH) || + (type->kind == L_NAMEOF)); + type = type->base_type; + } + type->base_type = base_type; +} + +void +L_set_declBaseType(VarDecl *decl, Type *base_type) +{ + if (decl->type) { + L_set_baseType(decl->type, base_type); + } else { + decl->type = base_type; + } + if (isnameoftype(base_type)) decl->flags |= DECL_REF; +} + +/* + * These are called before each Tcl interp is created (see + * tclInterp.c) and after it is deleted. Set up a top-level scope and + * call frame in order to persist typedefs, struct types, and globals + * across all the L programs compiled inside the interp. + */ +void +TclLInitCompiler(Tcl_Interp *interp) +{ + static Lglobal global; // L global state + +// putenv("MallocStackLogging=1"); + + /* Associate the L interp state with this interp. */ + L = (Linterp *)ckalloc(sizeof(Linterp)); + memset(L, 0, sizeof(Linterp)); + Tcl_SetAssocData(interp, "L", TclLCleanupCompiler, L); + + L->global = &global; + L->interp = interp; + frame_push(NULL, NULL, OUTER|SEARCH); + L_scope_enter(); + L->fn_calls = Tcl_NewObj(); + Tcl_SetVar2Ex(L->interp, "%%L_fnsCalled", NULL, L->fn_calls, + TCL_GLOBAL_ONLY); + L->fn_decls = Tcl_NewObj(); + Tcl_SetVar2Ex(L->interp, "L_fnsDeclared", NULL, L->fn_decls, + TCL_GLOBAL_ONLY); +} + +void +TclLCleanupCompiler(ClientData clientData, Tcl_Interp *interp) +{ + char buf[32]; + + L = (Linterp *)clientData; + L_scope_leave(); + frame_pop(); + ast_free(L->ast_list); + type_free(L->type_list); + if (L->include_table) { + Tcl_DeleteHashTable(L->include_table); + ckfree((char *)L->include_table); + } + ckfree(L->file); + ckfree(L->toplev); + if (L->script) Tcl_DecrRefCount(L->script); + ckfree((char *)L); + L = NULL; + + snprintf(buf, sizeof(buf), "/usr/bin/leaks %u", getpid()); +// system(buf); +} + +void +L_scope_enter() +{ + Scope *new_scope = (Scope *)ckalloc(sizeof(*new_scope)); + + new_scope->structs = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(new_scope->structs, TCL_STRING_KEYS); + + new_scope->typedefs = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(new_scope->typedefs, TCL_STRING_KEYS); + + new_scope->prev = L->curr_scope; + L->curr_scope = new_scope; +} + +void +L_scope_leave() +{ + Scope *prev = L->curr_scope->prev; + + Tcl_DeleteHashTable(L->curr_scope->structs); + ckfree((char *)L->curr_scope->structs); + + Tcl_DeleteHashTable(L->curr_scope->typedefs); + ckfree((char *)L->curr_scope->typedefs); + + ckfree((char *)L->curr_scope); + + L->curr_scope = prev; +} + +/* + * Called by parser to look up a reference to "struct tag". If + * "local" is true, check only the current scope. If the struct + * hasn't yet been declared, add an incomplete type to the current + * scope's struct table whose members will get filled up later when + * the struct is fully declared. + */ +Type * +L_struct_lookup(char *tag, int local) +{ + int new; + Type *type; + Tcl_HashEntry *hPtr = NULL; + Scope *scope; + + for (scope = L->curr_scope; !hPtr && scope; scope = scope->prev) { + hPtr = Tcl_FindHashEntry(scope->structs, tag); + if (local) break; + } + if (hPtr) { + type = (Type *)Tcl_GetHashValue(hPtr); + } else { + hPtr = Tcl_CreateHashEntry(L->curr_scope->structs, tag, &new); + type = type_mkStruct(tag, NULL); + Tcl_SetHashValue(hPtr, type); + } + return (type); +} + +/* + * Called by parser to declare a new struct type. If the struct + * already has been declared but without any members, fill them in + * now and return the existing type pointer. If tag is NULL, just + * sanity check the members' types (checking for void etc). + */ +Type * +L_struct_store(char *tag, VarDecl *m) +{ + Type *type = NULL; + + ASSERT(m); + + if (tag) { + type = L_struct_lookup(tag, TRUE); + if (type->u.struc.members) { + L_errf(m, "multiple declaration of struct %s", tag); + } else { + type->u.struc.members = m; + } + } + + /* Check member types for legality. */ + for (; m; m = m->next) { + L_typeck_declType(m); + } + + return (type); +} + +/* + * Called by parser to look up an ID in the typedef table to see if + * it's been previously declared as a type name. + */ +Type * +L_typedef_lookup(char *name) +{ + Tcl_HashEntry *hPtr = NULL; + Scope *scope; + + for (scope = L->curr_scope; !hPtr && scope; scope = scope->prev) { + hPtr = Tcl_FindHashEntry(scope->typedefs, name); + } + if (hPtr) { + return ((Type *)Tcl_GetHashValue(hPtr)); + } else { + return (NULL); + } +} + +/* + * Called by parser to define a new type name. + */ +void +L_typedef_store(VarDecl *decl) +{ + int new; + Tcl_HashEntry *hPtr; + Type *new_type; + char *name = decl->id->str; + + hPtr = Tcl_CreateHashEntry(L->curr_scope->typedefs, name, &new); + if (new) { + new_type = type_dup(decl->type); + if (new_type->name) ckfree(new_type->name); + new_type->name = ckstrdup(name); + Tcl_SetHashValue(hPtr, new_type); + } else { + Type *t = Tcl_GetHashValue(hPtr); + unless (L_typeck_same(decl->type, t)) { + L_errf(decl, "Cannot redefine type %s", name); + } + } +} + +void +hash_put(Tcl_Obj *hash, char *key, char *val) +{ + Tcl_Obj *keyObj, *valObj; + + ASSERT(hash && key); + keyObj = Tcl_NewStringObj(key, -1); + Tcl_IncrRefCount(keyObj); + if (val) { + valObj = Tcl_NewStringObj(val, -1); + } else { + valObj = *L_undefObjPtrPtr(); + } + Tcl_DictObjPut(L->interp, hash, keyObj, valObj); + Tcl_DecrRefCount(keyObj); +} + +void +hash_rm(Tcl_Obj *hash, char *key) +{ + Tcl_Obj *keyObj; + + ASSERT(hash && key); + keyObj = Tcl_NewStringObj(key, -1); + Tcl_IncrRefCount(keyObj); + Tcl_DictObjRemove(L->interp, hash, keyObj); + Tcl_DecrRefCount(keyObj); +} + +char * +hash_get(Tcl_Obj *hash, char *key) +{ + int ret; + Tcl_Obj *keyObj = Tcl_NewStringObj(key, -1); + Tcl_Obj *valObj; + + ASSERT(hash); + Tcl_IncrRefCount(keyObj); + ret = Tcl_DictObjGet(L->interp, hash, keyObj, &valObj); + unless (ret == TCL_OK) return (NULL); + Tcl_DecrRefCount(keyObj); + if (valObj) { + return (Tcl_GetString(valObj)); + } else { + return (NULL); + } +} + +/* For debugging. */ +void +hash_dump(Tcl_Obj *hash) +{ + int done, ret; + Tcl_Obj *key, *val; + Tcl_DictSearch ctxt; + + ret = Tcl_DictObjFirst(L->interp, hash, &ctxt, &key, &val, &done); + if ((ret != TCL_OK) || done) return; + do { + printf("%s -> %s\n", Tcl_GetString(key), + val->undef ? "<undef>" : Tcl_GetString(val)); + Tcl_DictObjNext(&ctxt, &key, &val, &done); + } while (!done); +} + +private char * +basenm(char *s) +{ + char *t; + + for (t = s; *t; t++); + do { + t--; + } while (*t != '/' && t > s); + if (*t == '/') t++; + return (t); +} + +/* + * Return the dirname of a path. The caller must ckfree() it. + */ +char * +L_dirname(char *path) +{ + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_Obj *dirObj, *tmpObj; + char *ret = NULL; + + Tcl_IncrRefCount(pathObj); + tmpObj = Tcl_FSGetNormalizedPath(NULL, pathObj); + if (tmpObj == NULL) goto err; + dirObj = TclPathPart(L->interp, tmpObj, TCL_PATH_DIRNAME); + if (dirObj == NULL) goto err; + ret = ckstrdup(Tcl_GetString(dirObj)); + Tcl_DecrRefCount(dirObj); + err: Tcl_DecrRefCount(pathObj); + return (ret); +} + +/* + * This function executes the INST_L_SPLIT bytecode and is based on + * pieces from tclCmdMZ.c. + * + * For edge cases, some of Perl's "split" semantics are obeyed: + * + * - A limit <= 0 means no limit. + * + * - Trailing null fields in the result are always suppressed. + * + * - If there is no delim, split on white space and trim any leading + * null fields from the result. + * + * - If the delim is /regexp/t, trim any leading null fields. + * + * - If all result fields are null, they are considered to be trailing + * and are all suppressed. + */ +Tcl_Obj * +L_split(Tcl_Interp *interp, Tcl_Obj *strobj, Tcl_Obj *delimobj, + Tcl_Obj *limobj, Expr_f flags) +{ + int chlen, i, leading, len, lim, matches, nocase, off, ret; + int trim = (flags & L_EXPR_RE_T); + int start = 0, end = 0; + Tcl_RegExp regExpr = NULL; + Tcl_RegExpInfo info; + Tcl_Obj **elems, *resultPtr, *objPtr, *listPtr; + Tcl_UniChar ch; + char *str; + + if (limobj) { + Tcl_GetIntFromObj(interp, limobj, &lim); + if (lim <= 0) { + lim = INT_MAX; + } else { + /* The lim is the max # fields to return, + * which is one less than the max # matches to + * allow. */ + --lim; + } + } else { + lim = INT_MAX; + } + + /* + * Make sure to avoid problems where the objects are shared. This can + * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. + * [Bug #461322] + */ + if (strobj == delimobj) { + objPtr = Tcl_DuplicateObj(strobj); + } else { + objPtr = strobj; + } + if (objPtr->typePtr == &tclByteArrayType) { + str = (char *)Tcl_GetByteArrayFromObj(objPtr, &len); + } else { + str = Tcl_GetStringFromObj(objPtr, &len); + } + + listPtr = Tcl_NewObj(); + matches = 0; + leading = 1; + off = 0; + + /* + * Split on white space if no delim was specified. + */ + unless (delimobj) { + int skip = 0; + for (start = 0; (off < len) && (matches < lim); off += chlen) { + chlen = TclUtfToUniChar(str+off, &ch); + if (skip) { + unless (Tcl_UniCharIsSpace(ch)) { + start = off; + skip = 0; + ++matches; + } + } else { + if (Tcl_UniCharIsSpace(ch)) { + /* Suppress leading null field + * in result. */ + if (off || start) { + resultPtr = Tcl_NewStringObj( + str+start, + off-start); + Tcl_ListObjAppendElement( + NULL, listPtr, + resultPtr); + } + skip = 1; + } + } + } + unless (skip) { + resultPtr = Tcl_NewStringObj(str+start, len-start); + Tcl_ListObjAppendElement(NULL, listPtr, resultPtr); + } + goto done; + } + + /* + * Split on a regular expression. + */ + nocase = (flags & L_EXPR_RE_I) ? TCL_REG_NOCASE : 0; + regExpr = Tcl_GetRegExpFromObj(interp, delimobj, + TCL_REG_ADVANCED | TCL_REG_PCRE | nocase); + unless (regExpr) { // bad regexp + listPtr = NULL; + goto done; + } + while ((off < len) && (matches < lim)) { + int flags = TCL_REG_BYTEOFFSET; + + if ((off > 0) && (str[off-1] != '\n')) flags |= TCL_REG_NOTBOL; + ret = Tcl_RegExpExecObj(interp, regExpr, objPtr, off, 1, flags); + if (ret < 0) goto done; + if (ret == 0) break; + Tcl_RegExpGetInfo(regExpr, &info); + start = info.matches[0].start; + end = info.matches[0].end; + matches++; + + /* + * Copy to the result list the portion of the source + * string before the match. If we matched the empty + * string, split after the current char. Don't add + * leading null fields if specified. + */ + if (leading && trim && (start == 0)) { + if (start == end) ++off; + off += end; + continue; + } + if (start == end) { + ASSERT(start == 0); + resultPtr = Tcl_NewStringObj(str+off, 1); + ++off; + } else { + resultPtr = Tcl_NewStringObj(str+off, start); + } + leading = 0; + Tcl_ListObjAppendElement(NULL, listPtr, resultPtr); + off += end; + } + /* + * Copy to the result list the portion of the source string after + * the last match, unless we matched the last char. + */ + if (off < len) { + resultPtr = Tcl_NewStringObj(str+off, len-off); + Tcl_ListObjAppendElement(NULL, listPtr, resultPtr); + } + + done: + if (objPtr && (strobj == delimobj)) { + Tcl_DecrRefCount(objPtr); + } + unless (listPtr) return (NULL); + + /* + * Strip any trailing empty fields in the result. This is + * to be consistent with Perl's split semantics. + */ + TclListObjGetElements(NULL, listPtr, &len, &elems); + for (i = len-1; i >= 0; --i) { + if (Tcl_GetCharLength(elems[i])) break; + Tcl_ListObjReplace(interp, listPtr, i, 1, 0, NULL); + } + return (listPtr); +} + +/* + * This command splits the given arguments according to bash-style + * quoting, returning a string[] array. + * + * xyz -- all escapes are processed except \<newline> ignored + * 'xyz' -- no single quotes allowed inside, no escapes processed + * "xyz" -- only \\ and \" are processed, \<newline> ignored + */ +int +Tcl_ShSplitObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *cmd; + int i, j, len; + Tcl_Obj *arg = NULL, *argv; + enum { LOOKING, ARG, SINGLE, DOUBLE } state; + + unless (objc >= 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?string ...?"); + return (TCL_ERROR); + } + argv = Tcl_NewObj(); + for (i = 1; i < objc; ++i) { + cmd = TclGetStringFromObj(objv[i], &len); + state = LOOKING; + for (j = 0; j < len; ++j) { + char c = cmd[j]; + switch (state) { + case LOOKING: + if (isspace(c)) { + continue; + } else { + arg = Tcl_NewObj(); + state = ARG; + /*FALLTHRU*/ + } + case ARG: + if (isspace(c)) { + Tcl_ListObjAppendElement(interp, + argv, arg); + state = LOOKING; + } else if (c == '\\') { + char e = 0; + if ((j+1) < len) e = cmd[j+1]; + // escape anything but ignore \<newline> + if (!e) { + Tcl_AppendResult(interp, + "trailing \\", + NULL); + return (TCL_ERROR); + } else if (e == '\n') { + ++j; + } else { + Tcl_AppendToObj(arg, &e, 1); + ++j; + } + } else if (c == '\'') { + state = SINGLE; + } else if (c == '"') { + state = DOUBLE; + } else { + Tcl_AppendToObj(arg, &c, 1); + } + break; + case SINGLE: + if (c == '\'') { + state = ARG; + } else { + Tcl_AppendToObj(arg, &c, 1); + } + break; + case DOUBLE: + if (c == '\\') { + char e = 0; + if ((j+1) < len) e = cmd[j+1]; + // escape \ and " but ignore \<newline> + if ((e == '\\') || (e == '"')) { + Tcl_AppendToObj(arg, &e, 1); + ++j; + } else if (e == '\n') { + ++j; + } else { + Tcl_AppendToObj(arg, &c, 1); + } + } else if (c == '"') { + state = ARG; + } else { + Tcl_AppendToObj(arg, &c, 1); + } + break; + } + } + switch (state) { + case LOOKING: + break; + case ARG: + Tcl_ListObjAppendElement(interp, argv, arg); + break; + case SINGLE: + Tcl_AppendResult(interp, "unterminated \'", NULL); + return (TCL_ERROR); + case DOUBLE: + Tcl_AppendResult(interp, "unterminated \"", NULL); + return (TCL_ERROR); + } + } + Tcl_SetObjResult(interp, argv); + return (TCL_OK); +} + +int +Tcl_GetOptObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int ac, i, n, ret = TCL_OK; + char **av, *opts, *s; + longopt *lopts = NULL; + Tcl_Obj **objs; + + /* + * This is all about converting the L args to C args for the + * getopt() call and then mapping back for the return value. + */ + + unless (objc == 4) { + Tcl_WrongNumArgs(interp, 1, objv, "av opts lopts"); + return (TCL_ERROR); + } + + /* Set the C optind variable from its L counterpart. */ + s = (char *)Tcl_GetVar(interp, "optind", TCL_GLOBAL_ONLY); + if (s) optind = atoi(s); + + if (Tcl_ListObjGetElements(interp, objv[1], &ac, &objs) != TCL_OK) { + return (TCL_ERROR); + } + av = (char **)ckalloc(ac * sizeof(char *)); + for (i = 0; i < ac; ++i) { + av[i] = TclGetString(objs[i]); + } + opts = (objv[2]->undef ? "" : TclGetString(objv[2])); + /* + * For long opts, the C API wants an array of <char*,int>, and + * the L call sent in a string array, so map the long opt name to + * its L array index + 300 (values <= 256 are reserved for the + * short opts and GETOPT_ERR). + */ + if (Tcl_ListObjGetElements(interp, objv[3], &n, &objs) != TCL_OK) { + ret = TCL_ERROR; + goto done; + } + if (n) { + lopts = (longopt *)ckalloc((n+1) * sizeof(longopt)); + for (i = 0; i < n; ++i) { + lopts[i].name = TclGetString(objs[i]); + lopts[i].ret = 300 + i; + } + lopts[i].name = NULL; + } + i = getopt(ac, av, opts, lopts); + switch (i) { + case GETOPT_EOF: + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + break; + case GETOPT_ERR: + Tcl_SetObjResult(interp, Tcl_NewStringObj("", 0)); + break; + default: + if (i < 300) { + // short opt + char str[1]; + str[0] = i; + Tcl_SetObjResult(interp, Tcl_NewStringObj(str, 1)); + } else { + // long opt -- map back to the longopts array entry + // and strip any trailing :;| + s = TclGetStringFromObj(objs[i-300], &n); + if ((s[n-1] == ':') || (s[n-1] == ';') || + (s[n-1] == '|')) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(s,n-1)); + } else { + Tcl_SetObjResult(interp, objs[i-300]); + } + } + break; + } + /* Set the optind, optopt, and optarg globals from the C variables. */ + s = cksprintf("%d", optind); + Tcl_SetVar(interp, "optind", s, TCL_GLOBAL_ONLY); + ckfree(s); + s = cksprintf("%c", optopt); + Tcl_SetVar(interp, "optopt", s, TCL_GLOBAL_ONLY); + ckfree(s); + if (optarg) { + Tcl_SetVar(interp, "optarg", optarg, TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar2Ex(interp, "optarg", NULL, *L_undefObjPtrPtr(), + TCL_GLOBAL_ONLY); + } + done: + ckfree((char *)av); + ckfree((char *)lopts); + return (ret); +} + +int +Tcl_GetOptResetObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + unless (objc == 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + getoptReset(); + Tcl_SetVar(interp, "optind", "0", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "optopt", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "optarg", NULL, *L_undefObjPtrPtr(), + TCL_GLOBAL_ONLY); + return (TCL_OK); +} + +/* + * Parts of the next two functions are taken from Tcl_GetsObjCmd(). + * do_getline() is like Tcl_GetsObjCmd() except that it results in + * undef on error or EOF, and it returns the result object so you + * don't have to pull it out of the interp to see what happened. + */ + +private Tcl_Obj * +do_getline(Tcl_Interp *interp, Tcl_Channel chan) +{ + Tcl_Obj *ret; + + ret = Tcl_NewObj(); + if (Tcl_GetsObj(chan, ret) < 0) { + Tcl_DecrRefCount(ret); + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + /* + * TIP #219. Capture error messages put by the + * driver into the bypass area and put them + * into the regular interpreter result. Fall + * back to the regular message if nothing was + * found in the bypass. + */ + if (!TclChanCaughtErrorBypass(interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_PosixError(interp), + NULL); + } + Tcl_SetVar2Ex(interp, "::stdio_lasterr", NULL, + Tcl_GetObjResult(interp), + TCL_GLOBAL_ONLY); + return (NULL); + } + ret = *L_undefObjPtrPtr(); + } + Tcl_SetObjResult(interp, ret); + return (ret); +} + +int +Tcl_FGetlineObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int mode; + Tcl_Channel chan; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return (TCL_ERROR); + } + if (TclGetChannelFromObj(interp, objv[1], &chan, + &mode, 0) != TCL_OK) { + goto err; + } + unless (mode & TCL_READABLE) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), + "\" wasn't opened for reading", NULL); + goto err; + } + unless (do_getline(interp, chan)) { + goto err; + } + return (TCL_OK); + err: + Tcl_SetVar2Ex(interp, "::stdio_lasterr", NULL, + Tcl_GetObjResult(interp), + TCL_GLOBAL_ONLY); + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + return (TCL_OK); +} + +int +Tcl_LAngleReadObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *ret = NULL; + int argc, res; + Tcl_Obj **argv; + static int cur = 0; + static Tcl_Channel chan = NULL; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + unless (L->global->script_argc) { + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj("angle_read_", -1); + objv[1] = Tcl_NewStringObj("stdin", -1); + res = Tcl_FGetlineObjCmd(dummy, interp, 2, objv); + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + return (res); + } + Tcl_ListObjGetElements(L->interp, L->global->script_argv, &argc, &argv); + while (1) { + if (chan) { + ret = do_getline(interp, chan); + if (ret && !ret->undef) break; + Tcl_UnregisterChannel(interp, chan); + chan = NULL; + } + if (cur >= argc) { + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + break; + } + chan = Tcl_FSOpenFileChannel(interp, argv[cur++], "r", 0); + if (chan) { + Tcl_RegisterChannel(interp, chan); + } else { + fprintf(stderr, "%s\n", Tcl_GetStringResult(interp)); + Tcl_ResetResult(interp); + } + } + return (TCL_OK); +} + +extern int Tcl_WriteObjN(Tcl_Channel chan, Tcl_Obj *objPtr, int numBytes); + +int +Tcl_LWriteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int mode, nbytes; + char *errmsg = ""; + Tcl_Channel chan; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "channel buffer numBytes"); + return (TCL_ERROR); + } + if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { + return (TCL_ERROR); + } + if (!(mode & TCL_WRITABLE)) { + errmsg = "channel wasn't opened for writing"; + goto err; + } + if (Tcl_GetIntFromObj(interp, objv[3], &nbytes) != TCL_OK) { + return (TCL_ERROR); + } + nbytes = Tcl_WriteObjN(chan, objv[2], nbytes); + if (nbytes < 0) { + if (!TclChanCaughtErrorBypass(interp, chan)) { + errmsg = (char *)Tcl_PosixError(interp); + } + goto err; + } + out: + Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); + return (TCL_OK); + err: + Tcl_SetVar2(interp, "::stdio_lasterr", NULL, errmsg, TCL_GLOBAL_ONLY); + nbytes = -1; + goto out; +} + +int +Tcl_LReadCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int mode, nbytes = -1; + char *errmsg = ""; + Tcl_Channel chan; + Tcl_Obj *buf; + + if ((objc != 4) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channel varName ?numBytes"); + return (TCL_ERROR); + } + if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { + return (TCL_ERROR); + } + if (!(mode & TCL_READABLE)) { + errmsg = "channel wasn't opened for reading"; + goto err; + } + if (Tcl_Eof(chan)) { + errmsg = "end of file"; + goto err; + } + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &nbytes) != TCL_OK) { + return (TCL_ERROR); + } + } + buf = Tcl_NewObj(); + Tcl_IncrRefCount(buf); + nbytes = Tcl_ReadChars(chan, buf, nbytes, 0); + if (nbytes < 0) { + if (!TclChanCaughtErrorBypass(interp, chan)) { + errmsg = (char *)Tcl_PosixError(interp); + } + Tcl_DecrRefCount(buf); + goto err; + } + Tcl_ObjSetVar2(interp, objv[2], NULL, buf, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(buf); + Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); + return (TCL_OK); + err: + Tcl_SetVar(interp, "::stdio_lasterr", errmsg, TCL_GLOBAL_ONLY); + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + return (TCL_OK); +} + +int +Tcl_LRefCnt( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "object"); + return (TCL_ERROR); + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(objv[1]->refCount)); + return (TCL_OK); +} + +/* + * This defines a defined() proc even though it also is a compiler + * built-in. When L code uses defined(), it gets the built-in. + * Having the proc allows access to this functionality from Tcl code. + */ +int +Tcl_LDefined( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "object"); + return (TCL_ERROR); + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(objv[1]->undef ? 0 : 1)); + return (TCL_OK); +} + +/* + * This evaluates an Lhtml document. All input is passed through + * to Tcl's stdout channel with two kinds of interpolation: + * + * - Anything between <? and ?> is taken to be L statements + * and is replaced by whatever that L code outputs. + * + * - Anything between <?= and ?> is taken to be an L expression and is + * replaced by whatever it evaluates to (this is just like regular L + * string interpolation). + * + * This works by putting the scanner into an Lhtml mode where + * <?, <?=, and ?> are recognized. The parser contains rules for + * wrapping the html in puts() calls. + */ +int +Tcl_LHtmlObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int ret; + + L_lex_begLhtml(); + ret = Tcl_LObjCmd(NULL, interp, objc, objv); + L_lex_endLhtml(); + return (ret); +} + +/* + * A Tcl_Obj type to store a pointer into a string buffer that we can + * walk down over time. The twpPtrValue internalrep is used, with the + * first ptr pointing to a ckalloc'd Bufptr struct (defined below) and + * the second ptr pointing to a copy of the buffer. + */ +static Tcl_ObjType L_bufPtrType = { + "l-bufPtrType", + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; +typedef struct { + char *p; + char *end; +} Bufptr; + +int +Tcl_LGetNextLineInit( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int len; + char *beg, *s; + Tcl_Obj *tmp; + Bufptr *bufptr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "object"); + return (TCL_ERROR); + } + if (objv[1]->undef) { + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + return (TCL_OK); + } + + /* + * Make a copy of the string whose lines we will walk. Do + * this instead of copying the Tcl_Obj to avoid problems with + * possible shimmering (i.e., the Tcl_Obj's string-rep buffer is + * not guaranteed to remain). + */ + s = Tcl_GetStringFromObj(objv[1], &len); + beg = ckalloc(len + 1); + memcpy(beg, s, len); + beg[len] = '\0'; + + /* + * Stash the copied string and a Bufptr into it inside of a + * tmp Tcl_Obj that will live for the duration of the walk. + * Tcl_LGetNextLine() will process it. + */ + tmp = Tcl_NewObj(); + tmp->typePtr = &L_bufPtrType; + bufptr = (Bufptr *)ckalloc(sizeof(Bufptr)); + bufptr->p = beg; + bufptr->end = beg + len; + tmp->internalRep.twoPtrValue.ptr1 = bufptr; + tmp->internalRep.twoPtrValue.ptr2 = beg; + + Tcl_SetObjResult(interp, tmp); + return (TCL_OK); +} + +int +Tcl_LGetNextLine( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *ret, *tmp; + char *beg, *p; + Bufptr *bufptr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "tmp"); + return (TCL_ERROR); + } + tmp = objv[1]; + if (tmp->undef) goto nomore; + unless (tmp->typePtr == &L_bufPtrType) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid tmp object", -1)); + return (TCL_ERROR); + } + bufptr = (Bufptr *)tmp->internalRep.twoPtrValue.ptr1; + unless (bufptr) goto nomore; + + beg = bufptr->p; + if (beg >= bufptr->end) goto nomore; + + for (p = beg; p < bufptr->end; ++p) { + if (p[0] == '\n') { + bufptr->p = p + 1; + break; + } + if (((p+1) < bufptr->end) && (p[0] == '\r') && (p[1] == '\n')) { + bufptr->p = p + 2; + break; + } + } + ret = Tcl_NewStringObj(beg, p - beg); + if (p == bufptr->end) { + ckfree(tmp->internalRep.twoPtrValue.ptr2); + ckfree((char *)bufptr); + tmp->internalRep.twoPtrValue.ptr1 = NULL; + tmp->internalRep.twoPtrValue.ptr2 = NULL; + } + Tcl_SetObjResult(interp, ret); + return (TCL_OK); + nomore: + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + return (TCL_OK); +} + +#ifdef _WIN32 + +int +Tcl_LGetDirX( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int len, ret; + Tcl_Obj *argv[2], *dirObjs, *eltObjs[3], *fileObjs, *listObj; + char *buf, *dir, *type, *utfname; + Tcl_DString ds; + HANDLE hFind; + WIN32_FIND_DATA f; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "directory"); + return (TCL_ERROR); + } + + // Append \* to the given directory path. + dir = cksprintf("%s\\*", Tcl_GetString(objv[1])); + Tcl_WinUtfToTChar(dir, -1, &ds); + + hFind = FindFirstFile((TCHAR *)Tcl_DStringValue(&ds), &f); + if (hFind == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER | + FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + GetLastError(), + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (char *)&buf, + 0, NULL); + // Chomp the cr,lf that windows added to buf. + len = strlen(buf); + if (len > 2) buf[len-2] = 0; + Tcl_SetVar(interp, "::stdio_lasterr", + buf, + TCL_GLOBAL_ONLY); + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + LocalFree(buf); + return (TCL_OK); + } + ckfree(dir); + Tcl_DStringFree(&ds); + + fileObjs = Tcl_NewListObj(0, NULL); + dirObjs = Tcl_NewListObj(0, NULL); + do { + utfname = Tcl_WinTCharToUtf(f.cFileName, -1, &ds); + eltObjs[0] = Tcl_NewStringObj(utfname, -1); + if (f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) { + type = "directory"; + } else { + type = "file"; + } + eltObjs[1] = Tcl_NewStringObj(type, -1); + if ((f.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) || + (*utfname == '.')) { + eltObjs[2] = Tcl_NewIntObj(1); + } else { + eltObjs[2] = Tcl_NewIntObj(0); + } + listObj = Tcl_NewListObj(3, eltObjs); + if (f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) { + Tcl_ListObjAppendElement(interp, dirObjs, listObj); + } else { + Tcl_ListObjAppendElement(interp, fileObjs, listObj); + } + Tcl_DStringFree(&ds); + } while (FindNextFile(hFind, &f)); + FindClose(hFind); + + // Sort the lists. + argv[1] = dirObjs; + Tcl_IncrRefCount(dirObjs); + Tcl_ResetResult(interp); + ret = Tcl_LsortObjCmd(NULL, interp, 2, argv); + Tcl_DecrRefCount(dirObjs); + if (ret == TCL_OK) { + dirObjs = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + + argv[1] = fileObjs; + Tcl_IncrRefCount(fileObjs); + Tcl_ResetResult(interp); + ret = Tcl_LsortObjCmd(NULL, interp, 2, argv); + Tcl_DecrRefCount(fileObjs); + if (ret == TCL_OK) { + fileObjs = Tcl_GetObjResult(interp); + } + + // Return a list with the file names after all the dir names. + Tcl_ListObjAppendList(interp, dirObjs, fileObjs); + Tcl_SetObjResult(interp, dirObjs); + return (TCL_OK); +} + +#else // #ifdef WIN32 + +int +Tcl_LGetDirX( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int ret; + Tcl_Obj *argv[2], *dirObjs, *eltObjs[3], *fileObjs, *listObj; + DIR *d; + struct dirent *dent; + char *dir, *type; +#ifndef HAVE_STRUCT_DIRENT_D_TYPE + char *path; + struct stat st; +#endif + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "directory"); + return (TCL_ERROR); + } + + dir = Tcl_GetString(objv[1]); + d = opendir(dir); + unless (d) { + Tcl_SetVar(interp, "::stdio_lasterr", + strerror(errno), + TCL_GLOBAL_ONLY); + Tcl_SetObjResult(interp, *L_undefObjPtrPtr()); + return (TCL_OK); + } + + fileObjs = Tcl_NewListObj(0, NULL); + dirObjs = Tcl_NewListObj(0, NULL); + while (dent = readdir(d)) { + eltObjs[0] = Tcl_NewStringObj(dent->d_name, -1); +#ifdef HAVE_STRUCT_DIRENT_D_TYPE + switch (dent->d_type) { + case DT_REG: type = "file"; break; + case DT_DIR: type = "directory"; break; + default: type = "other"; break; + } +#else + path = cksprintf("%s/%s", dir, dent->d_name); + if (stat(path, &st)) { + type = "unknown"; + } else if (S_ISREG(st.st_mode)) { + type = "file"; + } else if (S_ISDIR(st.st_mode)) { + type = "directory"; + } else { + type = "other"; + } + ckfree(path); +#endif + eltObjs[1] = Tcl_NewStringObj(type, -1); + if (*dent->d_name == '.') { + eltObjs[2] = Tcl_NewIntObj(1); + } else { + eltObjs[2] = Tcl_NewIntObj(0); + } + listObj = Tcl_NewListObj(3, eltObjs); + if (*type == 'd') { + Tcl_ListObjAppendElement(interp, dirObjs, listObj); + } else { + Tcl_ListObjAppendElement(interp, fileObjs, listObj); + } + } + closedir(d); + + // Sort the lists. + argv[1] = dirObjs; + Tcl_IncrRefCount(dirObjs); + Tcl_ResetResult(interp); + ret = Tcl_LsortObjCmd(NULL, interp, 2, argv); + Tcl_DecrRefCount(dirObjs); + if (ret == TCL_OK) { + dirObjs = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + + argv[1] = fileObjs; + Tcl_IncrRefCount(fileObjs); + Tcl_ResetResult(interp); + ret = Tcl_LsortObjCmd(NULL, interp, 2, argv); + Tcl_DecrRefCount(fileObjs); + if (ret == TCL_OK) { + fileObjs = Tcl_GetObjResult(interp); + } + + // Return a list with the file names after all the dir names. + Tcl_ListObjAppendList(interp, dirObjs, fileObjs); + Tcl_SetObjResult(interp, dirObjs); + return (TCL_OK); +} + +#endif // #ifdef WIN32 |