summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-12-22 21:29:13 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-12-22 21:29:13 -0800
commit7eef2749ca3282585e65415712ebb810f2462a01 (patch)
tree80b2d4cbd8b13b256fee53895cf024663587bec9
parent85721a1b46f0718393b6344de7863a5a90214446 (diff)
downloadtxr-7eef2749ca3282585e65415712ebb810f2462a01.tar.gz
txr-7eef2749ca3282585e65415712ebb810f2462a01.tar.bz2
txr-7eef2749ca3282585e65415712ebb810f2462a01.zip
new feature: defstruct clause macros.
* lisplib.c (struct_set_entries): Trigger autoload on new symbols define-struct-clause and *struct-clause-expander*. * stdlib/struct.tl (*struct-clause-expander*): New variable. (defstruct): expand-slot local function now returns list of expanded slots, not a single slot; every case in the tree-case is converted to return a list. The syntax of a slot clause is first expanded through *struct-clause-expander hash; if that works then the resulting list is further scanned for expansions. (define-struct-clause): New macro. (:delegate): New struct clause defined with define-struct-clause. Provides single-slot delegation. * tests/012/oop.tl: Tests for :delegate. * txr.1: Documented define-struct-clause and :delegate. * stdlib/doc-syms.tl: Updated.
-rw-r--r--lisplib.c3
-rw-r--r--stdlib/doc-syms.tl2
-rw-r--r--stdlib/struct.tl71
-rw-r--r--tests/012/oop.tl15
-rw-r--r--txr.1240
5 files changed, 313 insertions, 18 deletions
diff --git a/lisplib.c b/lisplib.c
index 7e6dd39f..d556a764 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -213,7 +213,8 @@ static val struct_set_entries(val dlt, val fun)
val name[] = {
lit("defstruct"), lit("qref"), lit("uref"), lit("new"), lit("lnew"),
lit("new*"), lit("lnew*"),
- lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"), nil
+ lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"),
+ lit("*struct-clause-expander*"), lit("define-struct-clause"), nil
};
set_dlt_entries_sys(dlt, sys_name, fun);
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 63894b85..8b263b4c 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -76,6 +76,7 @@
("/" "D-0049")
("//" "N-0054C409")
("/=" "N-003BE40C")
+ (":delegate" "N-037F664C")
(":key" "N-01697547")
(":match" "N-03B92C0D")
("<" "D-0057")
@@ -468,6 +469,7 @@
("define-option-struct" "N-0126C738")
("define-param-expander" "N-019F25A5")
("define-place-macro" "N-02C3089A")
+ ("define-struct-clause" "N-00FF2A51")
("defmacro" "N-02CAEF0B")
("defmatch" "N-0049315A")
("defmeth" "N-0047C7E8")
diff --git a/stdlib/struct.tl b/stdlib/struct.tl
index 55a30721..cb79aad2 100644
--- a/stdlib/struct.tl
+++ b/stdlib/struct.tl
@@ -24,6 +24,9 @@
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvar *struct-clause-expander* (hash))
+
(defun sys:bad-slot-syntax (form arg)
(compile-error form "bad slot syntax ~s" arg))
@@ -48,22 +51,27 @@
(instance-fini-form nil))
(labels ((expand-slot (form slot)
(tree-case slot
+ ((op . args)
+ (iflet ((expander [*struct-clause-expander* op]))
+ (append-each ((exslot [expander slot form]))
+ [expand-slot form exslot])
+ :))
((word name 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
- ,*body))))
+ ^((:function ,name
+ (lambda ,args
+ (block ,name ,*body)))))
+ (:function ^((,word ,name
+ (lambda ,args
+ (block ,name
+ ,*body)))))
((:static :instance)
(when body
(sys:bad-slot-syntax form slot))
- ^(,word ,name ,args))
+ ^((,word ,name ,args)))
(t :)))
((word (arg) . body)
(caseq word
@@ -75,7 +83,7 @@
"duplicate :init"))
(set instance-init-form
(cons arg body))
- ^(,word nil nil))
+ ^((,word nil nil)))
(:postinit
(unless (bindable arg)
(sys:bad-slot-syntax form slot))
@@ -84,7 +92,7 @@
"duplicate :postinit"))
(set instance-postinit-form
(cons arg body))
- ^(,word nil nil))
+ ^((,word nil nil)))
(:fini
(unless (bindable arg)
(sys:bad-slot-syntax form slot))
@@ -93,24 +101,24 @@
"duplicate :fini"))
(set instance-fini-form
(cons arg body))
- ^(,word nil nil))
+ ^((,word nil nil)))
(t (when body
(sys:bad-slot-syntax form slot))
:)))
((word name)
(caseq word
((:static)
- ^(,word ,name))
+ ^((,word ,name)))
((:instance)
- ^(,word ,name nil))
+ ^((,word ,name nil)))
((:method :function)
(sys:bad-slot-syntax form slot))
- (t ^(:instance ,word ,name))))
+ (t ^((:instance ,word ,name)))))
((name)
- ^(:instance ,name nil))
+ ^((:instance ,name nil)))
(name
- ^(:instance ,name nil)))))
- (let* ((slot-init-forms (collect-each ((slot slot-specs))
+ ^((:instance ,name nil))))))
+ (let* ((slot-init-forms (append-each ((slot slot-specs))
(expand-slot form slot)))
(supers (if (and super-spec (atom super-spec))
(list super-spec)
@@ -380,3 +388,32 @@
(sys:rslotset ,',struct ,',sym
,',meth-sym ,val))))
,body)))
+
+(defmacro define-struct-clause (:form form keyword (. params) . body)
+ (if (meq keyword :static :instance :function :method :init :postinit :fini)
+ (compile-error form "~s is a reserved defstruct clause keyword" keyword))
+ (unless (keywordp keyword)
+ (compile-error form "~s: clauses must be named by keyword symbols" keyword))
+ (with-gensyms (slot form)
+ ^(progn
+ (set [*struct-clause-expander* ,keyword]
+ (lambda (,slot ,form)
+ (mac-param-bind ,form ,params (cdr ,slot) ,*body)))
+ ,keyword)))
+
+(compile-only
+ (load-for (struct sys:param-parser-base "param")))
+
+(define-struct-clause :delegate (:form form
+ meth-name params delegate-expr
+ : (target-method meth-name))
+ (unless params
+ (compile-error form "delegate method requires at least one argument"))
+ (let* ((obj (car params))
+ (pp (new (fun-param-parser (cdr params) form)))
+ (opt pp.(opt-syms))
+ (args (append pp.req opt pp.rest)))
+ ^((:method ,meth-name (,obj ,*pp.req
+ ,*(if opt (cons : (mapcar (lop list :) opt)))
+ ,*pp.rest)
+ (qref ,delegate-expr (,target-method ,*args))))))
diff --git a/tests/012/oop.tl b/tests/012/oop.tl
index bab4ab68..a5c57973 100644
--- a/tests/012/oop.tl
+++ b/tests/012/oop.tl
@@ -93,3 +93,18 @@
(new* type a 3 b 4)) #S(ab a 3 b 4)
(let ((type (find-struct-type 'ab)))
(new* (type 3 4))) #S(ab a 3 b 4))
+
+(defstruct worker ()
+ name
+ (:method work (me) `worker @{me.name} works`)
+ (:method relax (me : (min 15)) `worker @{me.name} relaxes for @min min`))
+
+(defstruct contractor ()
+ sub
+ (:delegate work (me) me.sub.sub)
+ (:delegate break (me : min) me.sub.sub relax))
+
+(let ((co (new contractor sub (new contractor sub (new worker name "foo")))))
+ (mtest co.(work) "worker foo works"
+ co.(break) "worker foo relaxes for 15 min"
+ co.(break 5) "worker foo relaxes for 5 min"))
diff --git a/txr.1 b/txr.1
index 46cfe27b..81440eb9 100644
--- a/txr.1
+++ b/txr.1
@@ -28196,6 +28196,23 @@ compares the replacement object in place of the original, and an
hash table uses the replacement object as the key for the purposes of
hashing and comparison.
+.NP* Custom Slot Expansion
+
+The
+.code defstruct
+macro has a provision for for application-defined clauses, which may
+be defined using the
+.code define-struct-clause
+macro. This macro associates new clause keywords with custom expansion.
+The
+.code :delegate
+clause of
+.code defstruct
+is in fact implemented externally to
+.code defstruct
+using
+.codn define-struct-clause .
+
.coNP Macro @ defstruct
.synb
.mets (defstruct >> { name | >> ( name << arg *)} < super
@@ -30803,6 +30820,229 @@ if there are no forms. The invocations of
.code call-finalizers
take place just before the value of the last form is returned.
+.coNP Macro @ define-struct-clause
+.synb
+.mets (define-struct-clause < keyword < params <> [ body-form ]*)
+.syne
+.desc
+The
+.code define-struct-clause
+macro makes available a new, application-defined
+.code defstruct
+clause. The clause is named by
+.metn keyword ,
+which must be a keyword symbol, and is implemented as a macro
+transformation by the
+.meta params
+and
+.metn body-form s
+of the definition. The definition established by
+.code define-struct-clause
+is called a
+.IR "struct clause macro" .
+
+A struct clause macro is invoked when
+.code defstruct
+syntax is processed which contains one or more clauses which are
+headed by the matching
+.meta keyword
+symbol.
+
+The
+.meta params
+comprise a macro-style parameter list which must match the
+invoking clause, otherwise an error exception is thrown.
+When
+.meta params
+successfully matches the clause parameters, the parameters
+are destructured into the parameters and the
+.metn body-form s
+are evaluated in the scope of those parameters.
+
+The
+.metn body-form s
+must return a possibly list of
+.code defstruct
+clauses, not a single clause.
+
+Each of the returned clauses is examined for the possibility that
+it may be a struct clause macro; if so, it is expanded.
+
+The built-in clause keywords
+.codn :static ,
+.codn :instance ,
+.codn :function ,
+.codn :method ,
+.codn :init ,
+.code :postinit
+and
+.code :fini
+may not be used as the names of a struct clause macro; if any of these
+symbols is used as the
+.meta keyword
+parameter of
+.codn define-struct-clause ,
+an error exception is thrown.
+
+The return value of a
+.code define-struct-clause
+macro invocation is the
+.meta keyword
+argument.
+
+.TP* Examples:
+
+.verb
+ ;; Trivial struct clause macro which consumes any number of
+ ;; arguments and produces no slots:
+
+ (define-struct-clause :nothing (. ignored-args))
+
+ ;; Consequently, the following defines a struct with one slot, x:
+ ;; The (:nothing ...) clause disappears by producing no clauses.
+
+ (defstruct foo ()
+ (:nothing 1 2 3 beeblebrox)
+ x)
+
+ ;; struct clause macro called :multi which takes an initial value
+ ;; and zero or more slot names. It produces instance slot definitions
+ ;; which all use that same initial value.
+
+ (define-struct-clause :multi (init-val . names)
+ (mapcar (lop list init-val) names))
+
+ ;; define a struct with three slots initialized to zero:
+
+ (defstruct bar ()
+ (:multi 0 a b c)) ;; expands to (a 0) (b 0) (c 0)
+
+ ;; struct clause macro to define a slot along with a
+ ;; get and set method.
+
+ (define-struct-clause :getset (slot getter setter : init-val)
+ ^((,slot ,init-val)
+ (:method ,getter (obj) obj.,slot)
+ (:method ,setter (obj new) (set obj.,slot new))))
+
+ ;; Example use:
+
+ (defstruct point ()
+ (:getset x get-x set-x 0)
+ (:getset y get-y set-y 0))
+
+ ;; This has exactly the same effect as the following defstruct:
+
+ (defstruct point ()
+ (x 0)
+ (y 0)
+ (:method get-x (obj) obj.x)
+ (:method set-x (ob new) (set obj.x new))
+ (:method get-y (obj) obj.y)
+ (:method set-y (ob new) (set obj.y new)))
+.brev
+
+.coNP Struct clause macro @ :delegate
+.synb
+.mets (:delegate < name <> ( param +) < delegate-expr <> [ target-name ])
+.syne
+.desc
+The
+:delegate
+struct clause macro provides a way to define a method which is implemented entirely
+by delegation to a different object. The name of the method is
+.meta name
+and its parameter list is specified in the sme way as in the
+.meta :method
+clause. Instead of a method body, the
+.code :delegate
+clause has an expression
+.meta delegate-expr
+and an optional
+.meta target-name
+which defaults to
+.metn name .
+The
+.meta delegate-expr
+must be an expression which the delegate method can evaluate to
+produce a delegate object. The delegate method then passes its
+arguments to the target method, given by the
+.meta target-name
+argument, invoked on the delegate object. If the delegate method has optional
+parameters which have not received an argument value, those parameters
+are treated as if they had received the colon symbol
+.code :
+as their value, and that value is passed on. If the delegate method has
+variadic parameters, they are applied to the target. If optional parameters
+specified in
+.code :delegate
+are given argument values, those are discarded, playing no role in the
+delegation.
+
+.TP* Example:
+
+Structure definitions:
+
+.verb
+ (defstruct worker ()
+ name
+ (:method work (me)
+ `worker @{me.name} works`)
+ (:method relax (me : (min 15))
+ `worker @{me.name} relaxes for @min min`))
+
+ ;; "contractor" class has a sub ("subcontractor") slot
+ ;; which is another contractor of the same type.
+ ;; The subcontractor's own sub slot, however is going
+ ;; to be a worker.
+
+ (defstruct contractor ()
+ sub
+ (:delegate work (me) me.sub.sub)
+ (:delegate break (me : min) me.sub.sub relax))
+.brev
+
+The
+.code contractor
+structure's
+.code work
+and
+.code break
+methods delegate to the sub-subcontractor, which is going to be
+instantiated as a
+.code worker
+object. Note that the
+.code break
+method delegates to a differently named method
+.codn relax .
+
+.verb
+ ;; The objects are set up as described above.
+ ;; general contractor co has a co.sub subcontractor,
+ ;; and co.sub.sub is a worker:
+
+ (defvar co (new contractor
+ sub (new contractor
+ sub (new worker name "foo"))))
+
+ ;; Call work method on general contractor:
+ ;; this invokes co.sub.sub.(work) on the worker.
+
+ co.(work) -> "worker foo works"
+
+ ;; Call break method on general contractor with
+ ;; no argument. This causes co.sub.sub.(relax :)
+ ;; to be invoked, triggering argument defaulting:
+
+ co.(break) -> "worker foo relaxes for 15 min"
+
+ ;; Call break method with argument. This
+ ;; invokes co.sub.sub.(relax 5), specifying a
+ ;; value for the default argument:
+
+ co.(break 5) -> "worker foo relaxes for 5 min"
+.brev
+
.SS* Special Structure Functions
Special structure functions are user-defined methods or structure functions