diff options
| -rw-r--r-- | lisplib.c | 3 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 2 | ||||
| -rw-r--r-- | stdlib/struct.tl | 71 | ||||
| -rw-r--r-- | tests/012/oop.tl | 15 | ||||
| -rw-r--r-- | txr.1 | 240 |
5 files changed, 313 insertions, 18 deletions
@@ -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")) @@ -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 |