From adef4143af67eb8874e7013eb2c0b40da2099e5b Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sat, 29 Oct 2016 15:49:33 -0700
Subject: Extend symbol-function accessor to methods.

* eval.c (looup_fun): Handle (meth ...) syntax.

* share/txr/stdlib/place.tl (sys:get-fb): Function
removed.
(sys:get-fun-getter-setter): New function.
(defplace symbol-function): Rework getter and
setter using new function which works for method
as well as regular function bindings.

* txr.1: Documentation updated in several places.
The mention of symbol-function in the list of place
forms altered so it doesn't insinuate that the argument
must be a symbol. Description of symbol-function
updated. Also under the trace and untrace macros,
a note added that tracing methods is possible.
---
 eval.c                    |  8 ++++++++
 share/txr/stdlib/place.tl | 24 +++++++++++++++++-------
 txr.1                     | 35 +++++++++++++++++++++++++++++++----
 3 files changed, 56 insertions(+), 11 deletions(-)

diff --git a/eval.c b/eval.c
index b0ae9a03..30ecbb99 100644
--- a/eval.c
+++ b/eval.c
@@ -401,6 +401,14 @@ 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),
+                         find_struct_type(strct)));
+      return if2(type, cons(sym, static_slot(type, slot)));
+    }
     return or2(gethash(top_fb, sym),
                if2(lisplib_try_load(sym), gethash(top_fb, sym)));
   } else  {
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index c2421c3c..d5fdf778 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -754,16 +754,26 @@
                     ^(fmakunbound ',',sym)))
        ,body)))
 
-(defun sys:get-fb (sym)
-  (or (gethash sys:top-fb sym)
-      (sys:eval-err "unbound function ~s" sym)))
+(defun sys:get-fun-getter-setter (sym)
+  (tree-case sym
+    ((type struct slot)
+      (if (eq type 'meth)
+        (cons (op static-slot struct slot)
+              (op static-slot-set struct slot @1))
+        :))
+    (else
+      (let ((cell (gethash sys:top-fb sym)))
+        (unless cell
+          (sys:eval-err "unbound function ~s" sym))
+        (cons (op cdr)
+              (op sys:rplacd cell @1))))))
 
 (defplace (symbol-function sym-expr) body
   (getter setter
-    (with-gensyms (binding-sym)
-      ^(let ((,binding-sym (sys:get-fb ,sym-expr)))
-          (macrolet ((,getter () ^(cdr ,',binding-sym))
-                     (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+    (with-gensyms (gs-sym)
+      ^(let ((,gs-sym (sys:get-fun-getter-setter ,sym-expr)))
+          (macrolet ((,getter () ^(call (car ,',gs-sym)))
+                     (,setter (val) ^(call (cdr ,',gs-sym) ,val)))
             ,body))))
   :
   (deleter
diff --git a/txr.1 b/txr.1
index a0f78617..cdefd6d1 100644
--- a/txr.1
+++ b/txr.1
@@ -11395,7 +11395,7 @@ defined by \*(TX programs.
 .mets (dwim < obj-place < index <> [ alt ])
 .mets >> [ obj-place < index <> [ alt ]] ;; equivalent to dwim
 .mets (symbol-value << symbol-valued-form )
-.mets (symbol-function << symbol-valued-form )
+.mets (symbol-function << function-name-valued-form )
 .mets (symbol-macro << symbol-valued-form )
 .mets (fun << function-name )
 .mets (force << promise )
@@ -14386,7 +14386,7 @@ then the binding takes place in the global environment.
 .SS* Global Environment
 .coNP Accessors @, symbol-function @ symbol-macro and @ symbol-value
 .synb
-.mets (symbol-function << symbol )
+.mets (symbol-function >> { symbol | << method-name } )
 .mets (symbol-macro << symbol )
 .mets (symbol-value << symbol )
 .mets (set (symbol-function << symbol ) << new-value )
@@ -14395,7 +14395,9 @@ then the binding takes place in the global environment.
 .syne
 .desc
 
-The
+If given a
+.meta symbol
+argument, the
 .code symbol-function
 function retrieves the value of the global function binding of the
 given
@@ -14406,7 +14408,20 @@ If
 .meta symbol
 has no global function binding, then
 .code nil
-is returned.
+is returned. The
+.code symbol-function
+function also supports method names of the form
+.cblk
+.meti (meth < struct << slot )
+.cble
+where
+.meta struct
+names a struct type, and
+.meta slot
+a static slot. Names in this format are returned by the
+.meta func-get-name
+function.
+
 
 The
 .code symbol-macro
@@ -14488,6 +14503,10 @@ of the place, which doesn't exist, the macro yields
 the value
 .codn nil .
 
+Deleting a method via
+.code symbol-function
+is not possible; an attempt to do so has no effect.
+
 .TP* "Dialect note:"
 
 In ANSI Common Lisp, the
@@ -46541,6 +46560,14 @@ and produces the diagnostics around it. When
 .code untrace
 is used to disable tracing, the previous definition is restored.
 
+Methods can be traced; their names are given using
+.cblk
+.meti (meth < struct << slot )
+.cble
+syntax: see the
+.code func-get-name
+function.
+
 .SH* INTERACTIVE LISTENER
 
 .SS* Overview
-- 
cgit v1.2.3