diff options
| -rw-r--r-- | eval.c | 63 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 8 | ||||
| -rw-r--r-- | txr.1 | 86 |
3 files changed, 131 insertions, 26 deletions
@@ -75,7 +75,7 @@ val eval_initing; val eval_error_s; val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s; val handler_bind_s, cond_s, if_s, iflet_s, when_s; -val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s; +val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s; val tree_case_s, tree_bind_s; val sys_mark_special_s; val caseq_s, caseql_s, casequal_s; @@ -405,18 +405,24 @@ loc lookup_global_var_l(val sym) return if3(binding, cdr_l(binding), nulloc); } +static val lookup_mac(val menv, val sym); + val lookup_fun(val env, val sym) { uses_or2; if (nilp(env)) { - if (consp(sym) && car(sym) == meth_s) { - val strct = cadr(sym); - val slot = caddr(sym); - val type = or2(find_struct_type(strct), - if2(lisplib_try_load(strct), + if (consp(sym)) { + if (car(sym) == meth_s) { + val strct = cadr(sym); + val slot = caddr(sym); + val type = or2(find_struct_type(strct), + if2(lisplib_try_load(strct), find_struct_type(strct))); - return if2(type, cons(sym, static_slot(type, slot))); + return if2(type, cons(sym, static_slot(type, slot))); + } else if (car(sym) == macro_s) { + return lookup_mac(nil, cadr(sym)); + } } return or2(gethash(top_fb, sym), if2(lisplib_try_load(sym), gethash(top_fb, sym))); @@ -450,11 +456,15 @@ val func_get_name(val fun, val env) return func_get_name(fun, env->e.up_env); } } else { - uses_or2; - val name = or2(hash_revget(top_fb, fun, eq_f, cdr_f), - method_name(fun)); + val name; - if (name) + if ((name = hash_revget(top_fb, fun, eq_f, cdr_f))) + return name; + + if ((name = hash_revget(top_mb, fun, eq_f, cdr_f))) + return list(macro_s, name, nao); + + if ((name = method_name(fun))) return name; if (interp_fun_p(fun)) @@ -1605,6 +1615,8 @@ static val op_defsymacro(val form, val env) return sym; } +static val op_defmacro(val form, val env); + static val op_defun(val form, val env) { val args = rest(form); @@ -1621,7 +1633,7 @@ static val op_defun(val form, val env) if (eval_initing) sethash(builtin, name, defun_s); return name; - } else { + } else if (car(name) == meth_s) { val binding = lookup_fun(nil, intern(lit("defmeth"), system_package)); val type_sym = second(name); val meth_name = third(name); @@ -1631,6 +1643,26 @@ static val op_defun(val form, val env) bug_unless (binding); return funcall3(cdr(binding), type_sym, meth_name, func_interp(env, fun)); + } else if (car(name) == macro_s) { + val sym = cadr(name); + val block = cons(block_s, cons(sym, body)); + val fun = cons(name, cons(params, cons(block, nil))); + + if (!bindable(sym)) + eval_error(form, lit("defun: ~s isn't a bindable symbol in ~s"), + sym, name, nao); + + if (gethash(op_table, sym)) + eval_error(form, lit("defun: ~s is a special operator in ~s"), + sym, name, nao); + + sethash(top_mb, sym, cons(name, func_interp(env, fun))); + if (eval_initing) + sethash(builtin, sym, defmacro_s); + return name; + } else { + eval_error(form, lit("defun: ~s isn't recognized function name syntax"), + name, nao); } } @@ -1719,11 +1751,13 @@ static void builtin_reject_test(val op, val sym, val form) val builtin_kind = gethash(builtin, sym); val is_operator = gethash(op_table, sym); - if (op == defun_s && consp(sym) && car(sym) == meth_s) { + if (op == defun_s && consp(sym) && + (car(sym) == meth_s || car(sym) == macro_s)) + { return; } else if (!bindable(sym)) { eval_error(form, lit("~s: cannot bind ~s, which is not a bindable symbol"), - is_operator, sym, nao); + op, sym, nao); } else if (opt_compat && opt_compat <= 107) { /* empty */ } else if (builtin_kind) { @@ -4840,6 +4874,7 @@ void eval_init(void) sys_mark_special_s = intern(lit("mark-special"), system_package); defun_s = intern(lit("defun"), user_package); defmacro_s = intern(lit("defmacro"), user_package); + macro_s = intern(lit("macro"), user_package); defsymacro_s = intern(lit("defsymacro"), user_package); tree_case_s = intern(lit("tree-case"), user_package); tree_bind_s = intern(lit("tree-bind"), user_package); diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index a61fb99b..48e4843c 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -795,6 +795,14 @@ (cons (op static-slot struct slot) (op static-slot-set struct slot @1)) :)) + ((type sym) + (if (eq type 'macro) + (let ((cell (gethash sys:top-mb sym))) + (unless cell + (sys:eval-err "unbound macro ~s" sym)) + (cons (op cdr) + (op sys:rplacd cell @1))) + :)) (else (let ((cell (gethash sys:top-fb sym))) (unless cell @@ -12354,11 +12354,13 @@ and .code nil may not be used as function names. Neither can keyword symbols. -It is possible to define methods with +It is possible to define methods as well as macros with .codn defun , as an alternative to the .code defmeth -macro. +and +.code defmacro +forms. To define a method, the syntax .cblk @@ -12366,15 +12368,35 @@ To define a method, the syntax .cble should be used as the argument to the .meta name -parameter. +parameter. This gives rise to the syntax +.cblk +.meti (defun (meth < type << name ) < args << form *) +.cble +which is equivalent to the +.cblk +.meti (defmeth < type < name < args << form *) +.cble +syntax. -The syntax +Macros can be defined using .cblk -.meti (defun (meth type name) args forms) +.meti (macro << name ) .cble -is equivalent to the +as the +.meta name +parameter of +.codn defun . +This way of defining a macro doesn't support destructuring; +it defines the expander as an ordinary function with an ordinary +argument list. To work, the function must accept two arguments: +the entire macro call form that is to be expanded, and the +macro environment. Thus, the macro definition syntax is +.cblk +.meti (defun (macro << name ) < form < env << form *) +.cble +which is equivalent to the .cblk -.meti (defmeth type name args forms) +.meti (defmacro < name (:form < form :env << env ) << form *) .cble syntax. @@ -14854,9 +14876,11 @@ If .meta symbol has no global function binding, then .code nil -is returned. The +is returned. + +The .code symbol-function -function also supports method names of the form +function supports method names of the form .cblk .meti (meth < struct << slot ) .cble @@ -14866,8 +14890,15 @@ names a struct type, and .meta slot a static slot. Names in this format are returned by the .meta func-get-name -function. - +function. The +.code symbol-function +function also supports names of the form +.cblk +.meti (macro << name ) +.cble +which denote macros. Thus, +.code symbol-function +provides unified access to functions, methods and macros. The .code symbol-macro @@ -15201,7 +15232,28 @@ symbols in the global environment resolve to the function, it is not specified which one is returned. If the global function environment search fails, -then the function is considered as a possible method. +then the function is considered as a possible macro. +The global macro environment is searched for a macro +binding whose expander function is +.metn func , +similarly to the way the function environment was +searched. If a binding is found, then the syntax +.cblk +.meti (macro << name ) +.cble +is returned, where +.meta name +is the name of the global macro binding that was found +which resolves to +.metn func . +If two or more global macro bindings share +.metn func , +it is not specified which of those bindings provides +.metn name . + +If the global macro search fails, then +.meta func +is considered as a possible method. The static slot space of all struct types is searched for a slot which contains .metn func . @@ -48576,6 +48628,16 @@ syntax: see the .code func-get-name function. +Macros can be traced; their names are given using +.cblk +.meti (macro << name ) +.cble +syntax. Note that +.code trace +will not show the destructured internal macro arguments, but only the +two arguments passed to the expander function: the whole form, and the +environment. + .SH* INTERACTIVE LISTENER .SS* Overview |