New: %fun% mechanism for current function name.

* eval.c (pct_fun_s): New symbol variable, holding
the usr:%fun% symbol.
(fun_macro_env): New static function.
(do_expand): For defun and defmacro, use fun_macro_env
to establish an environment binding the %fun% symbol
macro, and expand everything in that environment.
(eval_init): Intern the %fun% symbol, initializing
pct_fun_s, and also register a global symbol macro in
that name so that we can freely use %fun% everywhere
without worrying that the code will blow up.
E.g. a logging macro can use it to get the function name,
but still be useful in a top-level form outside of
a named function.

* stdlib/struct.tl (sys:meth-lambda): New macro.
(defstruct, defmeth): Use sys:meth-lambda as a replacement
for lambda to set up the %fun% symbol macro. In the :init
case which doesn't use a lambda, an open-coded symacrolet
does the job.

* tests/019/pct-fun.tl: New file.

* tests/019/pct-fun.expected: Likewise.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

1 files changed, 23 insertions, 15 deletions

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)