diff options
| -rw-r--r-- | eval.c | 17 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 1 | ||||
| -rw-r--r-- | stdlib/struct.tl | 38 | ||||
| -rw-r--r-- | tests/019/pct-fun.expected | 18 | ||||
| -rw-r--r-- | tests/019/pct-fun.tl | 41 | ||||
| -rw-r--r-- | txr.1 | 79 |
6 files changed, 176 insertions, 18 deletions
@@ -106,6 +106,7 @@ val load_path_s, load_hooks_s, load_recursive_s, load_search_dirs_s; val load_time_s, load_time_lit_s; val eval_only_s, compile_only_s; val const_foldable_s; +val pct_fun_s; val special_s, unbound_s; val whole_k, form_k, symacro_k; @@ -4776,6 +4777,12 @@ static val rt_load_for(struct args *args) return nil; } +static val fun_macro_env(val menv, val name) +{ + val qname = list(quote_s, name, nao); + return make_env(cons(cons(pct_fun_s, qname), nil), nil, menv); +} + static val expand_catch_clause(val form, val menv) { val sym = first(form); @@ -5005,11 +5012,12 @@ again: { val body = rest(rest(rest(form))); + val menv0 = fun_macro_env(menv, name); cons_bind (params_ex, body_ex0, - expand_params(params, body, menv, + expand_params(params, body, menv0, eq(sym, defmacro_s), form)); - val new_menv = make_var_shadowing_env(menv, get_param_syms(params_ex)); - val body_ex = expand_progn(body_ex0, new_menv); + val menv1 = make_var_shadowing_env(menv0, get_param_syms(params_ex)); + val body_ex = expand_progn(body_ex0, menv1); val form_ex = form; if (body != body_ex || params != params_ex) @@ -6756,6 +6764,7 @@ void eval_init(void) eval_only_s = intern(lit("eval-only"), user_package); compile_only_s = intern(lit("compile-only"), user_package); const_foldable_s = intern(lit("%const-foldable%"), system_package); + pct_fun_s = intern(lit("%fun%"), user_package); qquote_init(); @@ -7488,6 +7497,8 @@ void eval_init(void) reg_var(lazy_streams_s, nil); + reg_symacro(pct_fun_s, nil); + eval_error_s = intern(lit("eval-error"), user_package); case_error_s = intern(lit("case-error"), user_package); uw_register_subtype(eval_error_s, error_s); diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl index 30c81243..59535d41 100644 --- a/stdlib/doc-syms.tl +++ b/stdlib/doc-syms.tl @@ -2,6 +2,7 @@ (hash-from-pairs '(("!>" "N-02B10DF9") ("%e%" "N-03F0FA9E") + ("%fun%" "N-00719365") ("%pi%" "N-03F0FA9E") ("*" "N-022396F7") ("*args*" "N-03DEE18A") diff --git a/stdlib/struct.tl b/stdlib/struct.tl index f0806723..3a89ee3a 100644 --- a/stdlib/struct.tl +++ b/stdlib/struct.tl @@ -36,6 +36,10 @@ (not init-form-present))) slot-init-forms)) +(defmacro sys:meth-lambda (struct slot params . body) + ^(symacrolet ((%fun% '(,struct ,slot))) + (lambda ,params ,*body))) + (defmacro defstruct (:form form name-spec super-spec . slot-specs) (tree-bind (name args) (tree-case name-spec ((atom . args) (list atom args)) @@ -57,22 +61,22 @@ (append-each ((exslot [expander slot form])) [expand-slot form exslot]) :)) - ((word name args . body) + ((word slname args . body) (caseq word (:method (when (not args) - (compile-error form "method ~s needs at least one parameter" name)) - ^((:function ,name - (lambda ,args - (block ,name ,*body))))) - (:function ^((,word ,name - (lambda ,args - (block ,name + (compile-error form "method ~s needs at least one parameter" slname)) + ^((:function ,slname + (sys:meth-lambda ,slname ,name ,args + (block ,slname ,*body))))) + (:function ^((,word ,slname + (sys:meth-lambda ,slname ,name ,args + (block ,slname ,*body))))) ((:static :instance) (when body (sys:bad-slot-syntax form slot)) - ^((,word ,name ,args))) + ^((,word ,slname ,args))) (t :))) ((word (arg) . body) (caseq word @@ -172,11 +176,13 @@ instance-fini-form instance-postfini-form) ^(lambda (,arg-sym) ,*(if (cdr instance-fini-form) - ^((finalize ,arg-sym (lambda (,(car instance-fini-form)) + ^((finalize ,arg-sym (sys:meth-lambda ,name :fini + (,(car instance-fini-form)) ,*(cdr instance-fini-form)) t))) ,*(if (cdr instance-postfini-form) - ^((finalize ,arg-sym (lambda (,(car instance-postfini-form)) + ^((finalize ,arg-sym (sys:meth-lambda ,name :postfini + (,(car instance-postfini-form)) ,*(cdr instance-postfini-form))))) ,*(if inst-si-forms ^((let ((,type-sym (struct-type ,arg-sym))) @@ -184,8 +190,9 @@ (slotset ,arg-sym ',@2 ,@3))) inst-si-forms)))) ,*(if (cdr instance-init-form) - ^((let ((,(car instance-init-form) ,arg-sym)) - ,*(cdr instance-init-form)))))) + ^((symacrolet ((%fun% '(,name :init))) + (let ((,(car instance-init-form) ,arg-sym)) + ,*(cdr instance-init-form))))))) ,(when args (when (> (countql : args) 1) (compile-error form @@ -207,7 +214,7 @@ (slotset ,arg-sym ',@1 ,@2))) opt-args o-gens p-gens)))))) ,(if instance-postinit-form - ^(lambda (,arg-sym) + ^(sys:meth-lambda ,name :postinit (,arg-sym) ,*(if (cdr instance-postinit-form) ^((let ((,(car instance-postinit-form) ,arg-sym)) ,*(cdr instance-postinit-form))))))))))))) @@ -364,7 +371,8 @@ (compile-defr-warning form ^(struct-type . ,type-sym) "definition of struct ~s not seen here" type-sym))) (register-tentative-def ^(slot . ,name)) - ^(sys:define-method ',type-sym ',name (lambda ,arglist + ^(sys:define-method ',type-sym ',name (sys:meth-lambda ,type-sym ,name + ,arglist (block ,name ,*body)))) (defmacro with-slots ((. slot-specs) obj-expr . body) diff --git a/tests/019/pct-fun.expected b/tests/019/pct-fun.expected new file mode 100644 index 00000000..d7da7ee4 --- /dev/null +++ b/tests/019/pct-fun.expected @@ -0,0 +1,18 @@ +(foo :init) +(foo :postinit) +(foo foo) +(foo bar) +(foo :fini) +(foo :postfini) +function +function2 +mac +(foo :init) +(foo :postinit) +(foo foo) +(foo bar) +(foo :fini) +(foo :postfini) +function +function2 +mac diff --git a/tests/019/pct-fun.tl b/tests/019/pct-fun.tl new file mode 100644 index 00000000..eae0d9bb --- /dev/null +++ b/tests/019/pct-fun.tl @@ -0,0 +1,41 @@ +(load "../common") + +(defstruct foo () + (:init (me) (prinl %fun%)) + (:fini (me) (prinl %fun%)) + (:postinit (me) (prinl %fun%)) + (:postfini (me) (prinl %fun%)) + (:method foo (me) (prinl %fun%))) + +(defmeth foo bar (me) + (prinl %fun%)) + +(defmeth foo pat (:match) + (prinl %fun%)) + +(defun function (: (optarg %fun%)) + (prinl %fun%)) + +(defun function2 (: (optarg %fun%)) + (prinl optarg)) + +(defmacro mac () + (prinl %fun%) + nil) + +(with-objects ((f (new foo))) + f.(foo) + f.(pat) + f.(bar)) + +(function) +(function2) + +(mac) + +(test %fun% nil) + +(compile-only + (eval-only + (compile-file (base-name *load-path*) "temp.tlo") + (remove-path "temp.tlo"))) @@ -19801,6 +19801,85 @@ if is a symbol which names a special operator, otherwise it returns .codn nil . +.coNP Symbol macro @ %fun% +.desc +The symbol macro +.code %fun% +indicates the current function name, There is a global +.code %fun% +symbol macro which expands to +.codn nil . +Around certain kinds of named functions, a local binding for +.code %fun% +is established which provides the function name. The purpose of this name +is for use in diagnostic messages; therefore it is an abbreviated name. + +The +.code %fun% +macro is established for +.codn defun , +.code defmacro +and +.code defmeth +forms. It is also established for methods defined inside a +.code defstruct +form including the methods +.codn :init , +.codn :postinit , +.code :fini +and +.codn :postfini . + +The +.code %fun% +macro is visible not only to the its function's body, but also to the +expressions inside the parameter list which compute the default values +for optional parameters. + +The name provided by +.code %fun% +is intended for use in diagnostic messages and is therefore an informal +name, and not the formal name which can be passed to +.code symbol-function +to retrieve the function. + +In the case of a +.code defun +function named +.codn x , +the +.code %fun% +name is that symbol, +.codn x . +Thus, in this case, the name is the same +as the formal name. +In the case of a +.code defmacro +named +.codn x , +.code %fun% +also expands to the symbol x +.codn x , +but that is the formal name of the macro, which is +.codn "(macro x)" . +In the case of a method +.code x +of a structure type +.codn s , +.code %fun% +is the two-element list +.codn "(s x)" , +rather than the formal name +.codn "(meth s x)" . + +.TP* Example: + +.verb + ;; log a message naming the function + (defun connect-to-host (addr) + (format t "~s: connecting to host ~s" %fun% addr)) +.brev + .SS* Object Type In \*(TL, objects obey the following type hierarchy. In this type hierarchy, |