diff options
| -rw-r--r-- | ChangeLog | 35 | ||||
| -rw-r--r-- | eval.c | 205 | ||||
| -rw-r--r-- | txr.1 | 75 |
3 files changed, 259 insertions, 56 deletions
@@ -1,5 +1,40 @@ 2014-02-21 Kaz Kylheku <kaz@kylheku.com> + Implementing special variables with local overriding. + All predefined globals become special. + + * eval.c (special, with_saved_vars_s): New global variables. + (mark_special, special_p): New functions. + (bindings_helper): Takes new argument, include_specials. + Now processes the special colon syntax for denoting special variables, + setting up their values, taking care to observe whether the + binding is parallel or sequential. + (op_let, op_for): Pass new argument to bindings_helper. + (op_each): Pass new argument to bindings_helper with a value of it, + and deal with the colon annotations that emerge in the bindings. + (op_defvar, regvar): Mark symbol as special. + (op_with_saved_vars): New static function. + (expand_vars): Takes new argument, returns a cons. Detects special + variables among the vars and produces the colon syntax. + (expand_catch_clause): Bugfix: this was using expand_vars on + a parameter list. Now properly uses expand_params. + (expand_save_specials): New static function. + (expand): For the operators that are binding constructs, handle + the new form of expand_vars which returns information about + special variables. If specials occur, then generate the + with-saved-vars form around the expansion which will save and restore + their values. The expansion of vars done by expand_vars, together + with the run-time actions of bindings_helper, do the rest. + Speaking of which, the new with-saved-vars operator form is now + expanded here too. + (eval_init): Protect new variables special and with_saved_vars_s. + Initialize special with new hash table. Store new interned + symbol in with_saved_vars_s. Register op_with_save_vars in op_table. + + * txr.1: Documented specials. + +2014-02-21 Kaz Kylheku <kaz@kylheku.com> + * eval.c (subst_vars): Change throwing of query_error_s to eval_error call. This is a leftover from when this was cloned from its counterpart in match.c. However, I can't think of a way @@ -71,7 +71,7 @@ struct c_var { val bind; }; -val top_vb, top_fb, top_mb; +val top_vb, top_fb, top_mb, special; val op_table; val eval_error_s; @@ -88,6 +88,7 @@ val delay_s, promise_s, op_s; val hash_lit_s, hash_construct_s; val vector_lit_s, vector_list_s; val macro_time_s; +val with_saved_vars_s; val whole_k, env_k; @@ -224,6 +225,16 @@ static val lookup_sym_lisp1(val env, val sym) } } +static void mark_special(val sym) +{ + sethash(special, sym, t); +} + +static val special_p(val sym) +{ + return gethash(special, sym); +} + static val bind_args(val env, val params, val args, val ctx_form) { val new_env = make_env(nil, nil, env); @@ -835,37 +846,55 @@ static val op_unquote_error(val form, val env) } -static val bindings_helper(val vars, val env, val sequential, val ctx_form) +static val bindings_helper(val vars, val env, val sequential, + val include_specials, val ctx_form) { val iter; list_collect_decl (new_bindings, ptail); val nenv = if3(sequential, make_env(nil, nil, env), env); + val spec_val[32], *spec_loc[32]; + int speci = 0; for (iter = vars; iter; iter = cdr(iter)) { val item = car(iter); - val var, val = nil; + val var, value = nil; if (consp(item)) { - if (!consp(cdr(item))) - eval_error(ctx_form, lit("~s: invalid syntax: ~s"), - car(ctx_form), item, nao); - var = first(item); - val = eval(second(item), nenv, ctx_form); + var = pop(&item); + value = eval(pop(&item), nenv, ctx_form); } else { var = item; } - if (symbolp(var)) { - if (!bindable(var)) + if (!bindable(var)) { + val special = car(item); + val *loc = lookup_var_l(nil, special); + if (var != colon_k) eval_error(ctx_form, lit("~s: ~s is not a bindable symbol"), car(ctx_form), var, nao); - } - - ptail = list_collect (ptail, cons(var, val)); + if (!loc) + eval_error(ctx_form, lit("~s: cannot rebind variable ~s: not found"), + car(ctx_form), special, nao); + if (sequential) { + *loc = value; + } else if (speci < 32) { + spec_val[speci] = value; + spec_loc[speci++] = loc; + } else { + eval_error(ctx_form, lit("~s: too many special variables rebound"), + car(ctx_form), nao); + } + if (include_specials) + ptail = list_collect (ptail, cons(colon_k, var)); + } else { + ptail = list_collect (ptail, cons(var, value)); - if (sequential) - env_replace_vbind(nenv, new_bindings); + if (sequential) + env_replace_vbind(nenv, new_bindings); + } } + while (speci-- > 0) + *spec_loc[speci] = spec_val[speci]; return new_bindings; } @@ -885,7 +914,7 @@ static val op_let(val form, val env) val args = rest(form); val vars = first(args); val body = rest(args); - val new_bindings = bindings_helper(vars, env, eq(let, let_star_s), form); + val new_bindings = bindings_helper(vars, env, eq(let, let_star_s), nil, form); return eval_progn(body, make_env(new_bindings, nil, env), form); } @@ -901,7 +930,7 @@ static val op_each(val form, val env) eq(each, append_each_star_s)); val collect = or2(eq(each, collect_each_s), eq(each, collect_each_star_s)); val append = or2(eq(each, append_each_s), eq(each, append_each_star_s)); - val new_bindings = bindings_helper(vars, env, star, form); + val new_bindings = bindings_helper(vars, env, star, t, form); val lists = mapcar(cdr_f, new_bindings); list_collect_decl (collection, ptail); @@ -915,9 +944,18 @@ static val op_each(val form, val env) { val binding = car(biter); val list = car(liter); + val sym = car(binding); if (!list) goto out; - rplacd(binding, car(list)); + if (sym == colon_k) { + val *loc = lookup_var_l(nil, cdr(binding)); + if (!loc) + eval_error(form, lit("~s: nonexistent special var ~a"), + car(form), sym); + *loc = car(list); + } else { + rplacd(binding, car(list)); + } rplaca(liter, cdr(list)); } @@ -1024,6 +1062,7 @@ static val op_defvar(val form, val env) val value = eval(second(args), env, form); sethash(top_vb, sym, cons(sym, value)); } + mark_special(sym); } return sym; @@ -1431,7 +1470,8 @@ static val op_for(val form, val env) val cond = third(form); val incs = fourth(form); val forms = rest(rest(rest(rest(form)))); - val new_bindings = bindings_helper(vars, env, eq(forsym, for_star_s), form); + val new_bindings = bindings_helper(vars, env, eq(forsym, for_star_s), + nil, form); val new_env = make_env(new_bindings, nil, env); uw_block_begin (nil, result); @@ -1652,6 +1692,39 @@ static val op_quasi_lit(val form, val env) return cat_str(subst_vars(rest(form), env), nil); } +static val op_with_saved_vars(val form, val env) +{ + val vars = (pop(&form), pop(&form)); + val prot_form = pop(&form); + val result = nil; + val var_save[32], *var_loc[32]; + int n; + + uw_simple_catch_begin; + + for (n = 0; n < 32 && vars; n++, vars = cdr(vars)) { + val sym = car(vars); + val *loc = lookup_var_l(nil, sym); + if (!loc) { + eval_error(form, lit("~s: cannot save value of " + "nonexistent var ~a"), car(form), sym, nao); + } + var_loc[n] = loc; + var_save[n] = *loc; + } + + result = eval(prot_form, env, prot_form); + + uw_unwind { + while (n-- > 0) + *var_loc[n] = var_save[n]; + } + + uw_catch_end; + + return result; +} + val expand_forms(val form) { if (atom(form)) { @@ -1791,26 +1864,42 @@ static val expand_qquote(val qquoted_form) abort(); } -static val expand_vars(val vars) +static val expand_vars(val vars, val specials) { + val sym; + if (atom(vars)) { return vars; - } else if (symbolp(car(vars))) { + } else if (special_p(sym = car(vars))) { + val rest_vars = rest(vars); + cons_bind (rest_vars_ex, new_specials, + rlcp(expand_vars(rest_vars, specials), rest_vars)); + val ret_specials = cons(sym, new_specials); + val var_ex = cons(colon_k, cons(nil, cons(sym, nil))); + return cons(rlcp(cons(var_ex, rest_vars_ex), vars), ret_specials); + } else if (symbolp(sym)) { val rest_vars = rest(vars); - val rest_vars_ex = expand_vars(rest_vars); + cons_bind (rest_vars_ex, new_specials, expand_vars(rest_vars, specials)); if (rest_vars == rest_vars_ex) - return vars; - return rlcp(cons(car(vars), rest_vars_ex), vars); + return cons(vars, new_specials); + return cons(rlcp(cons(sym, rest_vars_ex), vars), new_specials); } else { - cons_bind (var, init, car(vars)); + cons_bind (var, init, sym); val rest_vars = rest(vars); val init_ex = rlcp(expand_forms(init), init); - val rest_vars_ex = rlcp(expand_vars(rest_vars), rest_vars); + cons_bind (rest_vars_ex, new_specials, + rlcp(expand_vars(rest_vars, specials), rest_vars)); - if (init == init_ex && rest_vars == rest_vars_ex) - return vars; - - return rlcp(cons(cons(var, init_ex), rest_vars_ex), vars); + if (special_p(var)) { + val ret_specials = cons(var, new_specials); + val var_ex = cons(colon_k, cons(car(init_ex), cons(var, nil))); + return cons(rlcp(cons(var_ex, rest_vars_ex), vars), ret_specials); + } else { + if (init == init_ex && rest_vars == rest_vars_ex) + return cons(vars, new_specials); + return cons(rlcp(cons(cons(var, init_ex), rest_vars_ex), vars), + new_specials); + } } } @@ -1992,13 +2081,13 @@ static val expand_op(val sym, val body) static val expand_catch_clause(val form) { val sym = first(form); - val vars = second(form); + val params = second(form); val body = rest(rest(form)); - val vars_ex = expand_vars(vars); + val params_ex = expand_params(params); val body_ex = expand_forms(body); - if (body == body_ex && vars == vars_ex) + if (body == body_ex && params == params_ex) return form; - return rlcp(cons(sym, cons(vars_ex, body_ex)), form); + return rlcp(cons(sym, cons(params_ex, body_ex)), form); } static val expand_catch(val body) @@ -2017,6 +2106,13 @@ static val expand_catch(val body) return rlcp(expanded, body); } +static val expand_save_specials(val form, val specials) +{ + if (!specials) + return form; + return rlcp(cons(with_saved_vars_s, cons(specials, cons(form, nil))), form); +} + val expand(val form) { val macro = nil; @@ -2035,10 +2131,13 @@ tail: val body = rest(rest(form)); val vars = second(form); val body_ex = expand_forms(body); - val vars_ex = expand_vars(vars); - if (body == body_ex && vars == vars_ex) + cons_bind (vars_ex, specials, expand_vars(vars, nil)); + if (body == body_ex && vars == vars_ex && !specials) { return form; - return rlcp(cons(sym, cons(vars_ex, body_ex)), form); + } else { + val basic_form = rlcp(cons(sym, cons(vars_ex, body_ex)), form); + return expand_save_specials(basic_form, specials); + } } else if (sym == block_s || sym == return_from_s) { val name = second(form); val body = rest(rest(form)); @@ -2134,17 +2233,21 @@ tail: val cond = third(form); val incs = fourth(form); val forms = rest(rest(rest(rest(form)))); - val vars_ex = expand_vars(vars); + cons_bind (vars_ex, specials, expand_vars(vars, nil)); val cond_ex = expand_forms(cond); val incs_ex = expand_forms(incs); val forms_ex = expand_forms(forms); if (vars == vars_ex && cond == cond_ex && - incs == incs_ex && forms == forms_ex) + incs == incs_ex && forms == forms_ex && !specials) { return form; - return rlcp(cons(sym, - cons(vars_ex, - cons(cond_ex, cons(incs_ex, forms_ex)))), form); + } else { + val basic_form = rlcp(cons(sym, + cons(vars_ex, + cons(cond_ex, + cons(incs_ex, forms_ex)))), form); + return expand_save_specials(basic_form, specials); + } } else if (sym == dohash_s) { val spec = second(form); val keysym = first(spec); @@ -2186,6 +2289,17 @@ tail: val args_ex = expand_forms(args); val result = eval_progn(args_ex, make_env(nil, nil, nil), args); return cons(quote_s, cons(result, nil)); + } else if (sym == with_saved_vars_s) { + /* We should never have to expand a machine-generated with-saved-vars + * produced by the expander itself. This is for the sake of someone + * testing with-saved-vars in isolation. + */ + val vars = first(form); + val expr = second(form); + val expr_ex = expand(expr); + if (expr == expr_ex) + return form; + return cons(vars, cons(expr_ex, nil)); } else if ((macro = gethash(top_mb, sym))) { val mac_expand = expand_macro(form, macro, make_env(nil, nil, nil)); if (mac_expand == form) @@ -2624,6 +2738,7 @@ static void reg_var(val sym, val *loc) cv->loc = loc; cv->bind = cons(sym, *loc); sethash(top_vb, sym, cobj((mem_t *) cv, cptr_s, &c_var_ops)); + mark_special(sym); } static val if_fun(val cond, val then, val alt) @@ -2656,10 +2771,12 @@ static val and_fun(val vals) void eval_init(void) { - protect(&top_vb, &top_fb, &top_mb, &op_table, &last_form_evaled, (val *) 0); + protect(&top_vb, &top_fb, &top_mb, &special, + &op_table, &last_form_evaled, (val *) 0); top_fb = make_hash(t, nil, nil); top_vb = make_hash(t, nil, nil); top_mb = make_hash(t, nil, nil); + special = make_hash(t, nil, nil); op_table = make_hash(nil, nil, nil); dwim_s = intern(lit("dwim"), user_package); @@ -2712,6 +2829,7 @@ void eval_init(void) vector_lit_s = intern(lit("vector-lit"), system_package); vector_list_s = intern(lit("vector-list"), user_package); macro_time_s = intern(lit("macro-time"), user_package); + with_saved_vars_s = intern(lit("with-saved-vars"), system_package); whole_k = intern(lit("whole"), keyword_package); sethash(op_table, quote_s, cptr((mem_t *) op_quote)); @@ -2757,6 +2875,7 @@ void eval_init(void) sethash(op_table, dwim_s, cptr((mem_t *) op_dwim)); sethash(op_table, quasi_s, cptr((mem_t *) op_quasi_lit)); sethash(op_table, catch_s, cptr((mem_t *) op_catch)); + sethash(op_table, with_saved_vars_s, cptr((mem_t *) op_with_saved_vars)); reg_fun(cons_s, func_n2(cons)); reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons)); @@ -5154,6 +5154,50 @@ Here, the shorthand 1 .. 3 denotes (cons 1 3). This is treated just like (call '(1 2 3 4) 1 3), which performs range extraction: taking a slice of the list starting at index 1, up to and not including index 3. +.SS Special Variables + +Similarly to Common Lisp, TXR Lisp is lexically scoped by default, but +also has dynamically scoped (a.k.a "special") variables. + +When a variable is defined with defvar, it is introduced as a top-level +(global) binding, regardless of where in the scope the defvar form occurs. + +Furthermore, at the time the defvar form is evaluated, the symbol which +names the variable is tagged as special. + +When a symbol is tagged as special, it behaves differently when it is used +in a lexical binding construct like let, and all other such constructs +such as function parameter lists. Such a binding is not the usual lexical +binding, but a "rebinding" of the global variable. Over the dynamic scope +of the form, the global variable takes on the value given to it by the +rebinding. When the form terminates, the prior value of the variable +is restored. (This is true no matter how the form terminates; even if by +an exception.) + +Because of this "pervasive special" behavior of a symbol that has been +used as the name of a global variable, a good practice is to make global +variables have visually distinct names via the "earmuffs" convention: +beginning and ending the name with an asterisk. + +Certain variables in TXR's library break this convention; however, they at +least have distinct prefixes, examples being example s-ifmt, log-emerg and +sig-hup. + +.TP +Example: + + (defvar *x* 42) ;; *x* has a value of 42 + + (defun print-x () + (format t "~a\en" *x*)) + + (let ((*x* "abc")) ;; this overrides *x* + (print-x)) ;; *x* is now "abc" and so that is printed + + (print-x) ;; *x* is 42 again and so "42" is printed + + + .SH CONTROL FLOW AND SEQUENCING When the first element of a compound expression is an operator symbol, @@ -5807,6 +5851,11 @@ in which the defvar form occurs, not necessarily in the top-level environment. The symbols t and nil may not be used as variables, and neither can be keyword symbols: symbols denoted by a leading colon. +In addition to creating a binding, the defvar operator also marks <sym> +as the name of a special variable. This changes what it means to bind +that symbol in a lexical binding construct such as the let operator, +or a function parameter list. See the section "Special Variables" far above. + .SS Operators let and let* .TP @@ -10918,7 +10967,7 @@ In general, I/O errors are usually turned into exceptions. When the description of error reporting is omitted from the description of a function, it can be assumed that it throws an error. -.SS Variables *stdout*, *stddebug*, *stdin*, *stderr* and *stdnull* +.SS Special variables *stdout*, *stddebug*, *stdin*, *stderr* and *stdnull* These variables hold predefined stream objects. The *stdin*, *stdout* and *stderr* streams closely correspond to the underlying operating system streams. @@ -11558,7 +11607,7 @@ These properties correspond to the similarly-named entires of the struct stat structure in POSIX. For instance, the :dev property has the same value as the st_dev field. -.SS The variables s-ifmt s-iflnk s-ifreg s-ifblk ... s-ixoth +.SS Special variables s-ifmt s-iflnk s-ifreg s-ifblk ... s-ixoth The following variables exist, having integer values. These are bitmasks which can be applied against the value given by the :mode property @@ -11722,7 +11771,7 @@ name. The find-package function performs this lookup. A package may be deleted from the list with the delete-package function, but it continues to exist until the program loses the last reference to that package. -.SS Variables *user-package*, *keyword-package*, *system-package* +.SS Special variables *user-package*, *keyword-package*, *system-package* These variables hold predefined packages. The *user-package* is the one in which symbols are read when a TXR program is being scanned. @@ -11769,7 +11818,7 @@ Note: the variation in name is not the basis of the uniqueness of gensym; the basis of its uniqueness is that it is a freshly instantiated object. make-sym also returns unique symbols even if repeatedly called with the same string. -.SS Variable *gensym-counter* +.SS Special variable *gensym-counter* This variable is initialized to 0. Each time the gensym function is called, it is incremented. The incremented value forms the basis of the numeric @@ -11919,7 +11968,7 @@ returns nil. .SH PSEUDO-RANDOM NUMBERS -.SS Variable *random-state* +.SS Special variable *random-state* The *random-state* variable holds an object which encapsulates the state of a pseudo-random number generator. This variable is the default argument for @@ -12133,7 +12182,7 @@ savings time). .SH ENVIRONMENT VARIABLES AND COMMAND LINE -.SS Variables *args* and *args-full* +.SS Special variables *args* and *args-full* The *args* variable holds a list of strings representing the remaining arguments which follow any options processed by the txr executable, and the @@ -12243,7 +12292,7 @@ Additionally, the sig-check function can be used to dispatch and clear deferred signals. These handlers are then safely called if they were subroutines of sig-check, and not asynchronous interrupts. -.SS Variables sig-hup, sig-int, sig-quit, sig-ill, sig-trap, sig-abrt, sig-bus, sig-fpe, sig-kill, sig-usr1, sig-segv, sig-usr2, sig-pipe, sig-alrm, sig-term, sig-chld, sig-cont, sig-stop, sig-tstp, sig-ttin, sig-ttou, sig-urg, sig-xcpu, sig-xfsz, sig-vtalrm, sig-prof, sig-poll, sig-sys, sig-winch, sig-iot, sig-stkflt, sig-io, sig-lost and sig-pwr +.SS Special variables sig-hup, sig-int, sig-quit, sig-ill, sig-trap, sig-abrt, sig-bus, sig-fpe, sig-kill, sig-usr1, sig-segv, sig-usr2, sig-pipe, sig-alrm, sig-term, sig-chld, sig-cont, sig-stop, sig-tstp, sig-ttin, sig-ttou, sig-urg, sig-xcpu, sig-xfsz, sig-vtalrm, sig-prof, sig-poll, sig-sys, sig-winch, sig-iot, sig-stkflt, sig-io, sig-lost and sig-pwr .TP Description: @@ -12349,7 +12398,7 @@ interface. TXR programs can configure logging via the openlog function, control the loging mask via setlogmask and generate logs vis syslog, or using special syslog streams. -.SS Variables log-pid, log-cons, log-ndelay, log-odelay, log-nowait and log-perror +.SS Special variables log-pid, log-cons, log-ndelay, log-odelay, log-nowait and log-perror These variables take on the values of the corresponding C preprocessor constants from the <syslog.h> header: LOG_PID, LOG_CONS, etc. These @@ -12359,7 +12408,7 @@ openlog function. Note: LOG_PERROR is not in POSIX, and so log-perror might not be available. See notes about LOG_AUTHPRIV in the next section. -.SS Variables log-user, log-daemon, log-auth and log-authpriv +.SS Special variables log-user, log-daemon, log-auth and log-authpriv These variables take on the values of the corresponding C preprocessor constants from the <syslog.h> header: LOG_USER, LOG_DAEMON, LOG_AUTH @@ -12371,14 +12420,14 @@ For portability use code like (of (symbol-value 'log-authpriv) 0) to evaluate to 0 if log-authpriv doesn't exist, or else check for its existence using (boundp 'log-authpriv). -.SS Variables log-emerg, log-alert, log-crit, log-err, log-warning, log-notice, log-info and log-debug +.SS Special variables log-emerg, log-alert, log-crit, log-err, log-warning, log-notice, log-info and log-debug These variables take on the values of the corresponding C preprocessor constants from the <syslog.h> header: LOG_EMERG, LOG_ALERT, etc. These are the integer priority codes specified in the syslog call. -.SS The *stdlog* variable holds a special kind of stream: a syslog stream. -Each newline-terminated line of text sent to this stream becomes a log +.SS The *stdlog* special variable holds a special kind of stream: a syslog +stream. Each newline-terminated line of text sent to this stream becomes a log message. The stream internally maintains a priority value that is applied @@ -12891,7 +12940,7 @@ to the original untransformed source code. .SH MODULARIZATION -.SS Variable *self-path* +.SS Special variable *self-path* This variable holds the invocation path name of the TXR program. |