From e4cf235095d5c3123eb706d5b74a208fdaee512e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 21 Nov 2007 16:56:28 -0600 Subject: [PATCH 1/5] Inverse changes --- extra/inverse/inverse.factor | 63 +++++++++++++++++++++--------------- 1 file changed, 37 insertions(+), 26 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 5d0981f06f..ccba5226b7 100644 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -26,6 +26,9 @@ M: fail summary drop "Unification failed" ; : define-inverse ( word quot -- ) "inverse" set-word-prop ; +: define-math-inverse ( word quot1 quot2 -- ) + 2array "math-inverse" set-word-prop ; + DEFER: [undo] : make-inverse ( word -- quot ) @@ -48,32 +51,40 @@ M: word inverse M: object inverse undo-literal ; M: symbol inverse undo-literal ; +: next ( revquot -- revquot* first ) + dup empty? + [ "Badly formed math inverse" throw ] + [ unclip-slice ] if ; + +: constant-word? ( word -- ? ) + stack-effect + [ effect-out length 1 = ] keep + effect-in length 0 = and ; + +: assure-constant ( constant -- quot ) + dup constant-word? + [ "Badly formed math inverse" throw ] unless 1quotation ; + +: swap-inverse ( math-inverse revquot -- revquot* quot ) + next assure-constant rot second compose ; + +: pull-inverse ( math-inverse revquot const -- revquot* quot ) + assure-constant rot first compose ; + +: math-inverse ( revquot math-inverse -- revquot* quot ) + swap 1 tail-slice + next dup \ swap = [ drop swap-inverse ] [ pull-inverse ] if ; + : ?word-prop ( word/object name -- value/f ) over word? [ word-prop ] [ 2drop f ] if ; -: group-pops ( seq -- matrix ) - [ - dup length [ - 2dup swap nth dup "pop-length" ?word-prop - [ 1+ dupd + tuck >r pick r> swap subseq , 1- ] - [ 1quotation , ] ?if - ] repeat drop - ] [ ] make ; - -: inverse-pop ( quot -- inverse ) - unclip >r reverse r> "pop-inverse" word-prop call ; - -: firstn ( n -- quot ) - { [ drop ] [ first ] [ first2 ] [ first3 ] [ first4 ] } nth ; - -: define-pop-inverse ( word n quot -- ) - -rot 2dup "pop-length" set-word-prop - firstn rot append "pop-inverse" set-word-prop ; +: (undo) ( revquot -- ) + dup first "math-inverse" ?word-prop + [ math-inverse ] [ unclip-slice inverse ] if* + % dup empty? [ drop ] [ (undo) ] if ; : [undo] ( quot -- undo ) - reverse group-pops [ - dup length 1 = [ first inverse ] [ inverse-pop ] if - ] map concat [ ] like ; + reverse [ (undo) ] [ ] make ; MACRO: undo ( quot -- ) [undo] ; @@ -107,11 +118,11 @@ MACRO: undo ( quot -- ) [undo] ; : assert-literal ( n -- n ) dup [ word? ] keep symbol? not and [ "Literal missing in pattern matching" throw ] when ; -\ + 1 [ assert-literal [ - ] curry ] define-pop-inverse -\ - 1 [ assert-literal [ + ] curry ] define-pop-inverse -\ * 1 [ assert-literal [ / ] curry ] define-pop-inverse -\ / 1 [ assert-literal [ * ] curry ] define-pop-inverse -\ ^ 1 [ assert-literal recip [ ^ ] curry ] define-pop-inverse +\ + [ - ] [ - ] define-math-inverse +\ - [ + ] [ - ] define-math-inverse +\ * [ / ] [ / ] define-math-inverse +\ / [ * ] [ / ] define-math-inverse +\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse \ ? 2 [ [ assert-literal ] 2apply From 10e3cee913f27d73579a174c0666df384f7e0ff0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 21 Nov 2007 23:43:30 -0600 Subject: [PATCH 2/5] Inverse updates --- extra/inverse/inverse-docs.factor | 6 +- extra/inverse/inverse-tests.factor | 11 +++- extra/inverse/inverse.factor | 88 ++++++++++++++++++------------ 3 files changed, 64 insertions(+), 41 deletions(-) diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor index 1551776982..f8ae3bfbdb 100644 --- a/extra/inverse/inverse-docs.factor +++ b/extra/inverse/inverse-docs.factor @@ -24,7 +24,7 @@ HELP: matches? { $values { "quot" "a quotation" } { "?" "a boolean" } } { $description "Tests if the stack can match the given quotation. The quotation is inverted, and if the inverse can run without a unification failure, then t is returned. Else f is returned. If a different error is encountered (such as stack underflow), this will be propagated." } ; -HELP: which +HELP: switch { $values { "quot-alist" "an alist from inverse quots to quots" } } { $description "The equivalent of a case expression in a programming language with buitlin pattern matchining. It attempts to match the stack with each of the patterns, in order, by treating them as inverse quotations. Failure causes the next pattern to be tested." } { $code @@ -34,7 +34,7 @@ HELP: which " {" " { [ ] [ sum + ] }" " { [ f ] [ 0 ] }" -" } which ;" } +" } switch ;" } { $see-also undo } ; ARTICLE: { "inverse" "intro" } "Invertible quotations" @@ -46,7 +46,7 @@ ARTICLE: { "inverse" "intro" } "Invertible quotations" "To use the inverse quotation for pattern matching" { $subsection undo } { $subsection matches? } -{ $subsection which } ; +{ $subsection switch } ; IN: inverse ABOUT: { "inverse" "intro" } diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 8374caa9ff..77e35a13d2 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,5 +1,6 @@ USING: inverse tools.test arrays math kernel sequences math.functions ; +IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test [ { 3 4 } [ dup 2array ] undo ] unit-test-fails @@ -20,7 +21,7 @@ C: foo { { [ dup 1+ 2array ] [ 3 * ] } { [ 3array ] [ + + ] } - } which ; + } switch ; [ 5 ] [ { 1 2 2 } something ] unit-test [ 6 ] [ { 2 3 } something ] unit-test @@ -35,6 +36,8 @@ C: foo [ { t t f } ] [ { t f 1 } [ [ >boolean ] matches? ] map ] unit-test [ { t f } ] [ { { 1 2 3 } 4 } [ [ >array ] matches? ] map ] unit-test [ 9 9 ] [ 3 [ 1/2 ^ ] undo 3 [ sqrt ] undo ] unit-test +[ 5 ] [ 6 5 - [ 6 swap - ] undo ] unit-test +[ 6 ] [ 6 5 - [ 5 - ] undo ] unit-test TUPLE: cons car cdr ; @@ -49,9 +52,13 @@ C: nil { [ ] [ list-sum + ] } { [ ] [ 0 ] } { [ ] [ "Malformed list" throw ] } - } which ; + } switch ; [ 10 ] [ 1 2 3 4 list-sum ] unit-test +[ ] [ [ ] undo ] unit-test +[ 1 2 ] [ 1 2 [ ] undo ] unit-test +[ t ] [ 1 2 [ ] matches? ] unit-test +[ f ] [ 1 2 [ ] matches? ] unit-test : empty-cons ( -- cons ) cons construct-empty ; : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index ccba5226b7..4d85318c1b 100644 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -29,6 +29,10 @@ M: fail summary drop "Unification failed" ; : define-math-inverse ( word quot1 quot2 -- ) 2array "math-inverse" set-word-prop ; +: define-pop-inverse ( word n quot -- ) + >r dupd "pop-length" set-word-prop r> + "pop-inverse" set-word-prop ; + DEFER: [undo] : make-inverse ( word -- quot ) @@ -39,18 +43,6 @@ TUPLE: no-inverse word ; M: no-inverse summary drop "The word cannot be used in pattern matching" ; -GENERIC: inverse ( word -- quot ) - -M: word inverse - dup "inverse" word-prop [ ] - [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ; - -: undo-literal ( object -- quot ) - [ =/fail ] curry ; - -M: object inverse undo-literal ; -M: symbol inverse undo-literal ; - : next ( revquot -- revquot* first ) dup empty? [ "Badly formed math inverse" throw ] @@ -62,26 +54,46 @@ M: symbol inverse undo-literal ; effect-in length 0 = and ; : assure-constant ( constant -- quot ) - dup constant-word? - [ "Badly formed math inverse" throw ] unless 1quotation ; + dup word? [ + dup constant-word? + [ "Badly formed math inverse" throw ] unless + ] when 1quotation ; : swap-inverse ( math-inverse revquot -- revquot* quot ) - next assure-constant rot second compose ; + next assure-constant rot second [ swap ] swap 3compose ; : pull-inverse ( math-inverse revquot const -- revquot* quot ) assure-constant rot first compose ; -: math-inverse ( revquot math-inverse -- revquot* quot ) - swap 1 tail-slice - next dup \ swap = [ drop swap-inverse ] [ pull-inverse ] if ; - : ?word-prop ( word/object name -- value/f ) over word? [ word-prop ] [ 2drop f ] if ; +GENERIC: inverse ( revquot word -- revquot* quot ) + +M: word inverse + dup "inverse" word-prop [ ] + [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ; + +: undo-literal ( object -- quot ) + [ =/fail ] curry ; + +M: object inverse undo-literal ; +M: symbol inverse undo-literal ; + +PREDICATE: word math-inverse "math-inverse" word-prop ; +M: math-inverse inverse + "math-inverse" word-prop + swap next dup \ swap = + [ drop swap-inverse ] [ pull-inverse ] if ; + +PREDICATE: word pop-inverse "pop-length" word-prop ; +M: pop-inverse inverse + [ "pop-length" word-prop cut-slice swap ] keep + "pop-inverse" word-prop compose call ; + : (undo) ( revquot -- ) - dup first "math-inverse" ?word-prop - [ math-inverse ] [ unclip-slice inverse ] if* - % dup empty? [ drop ] [ (undo) ] if ; + dup empty? [ drop ] + [ unclip-slice inverse % (undo) ] if ; : [undo] ( quot -- undo ) reverse [ (undo) ] [ ] make ; @@ -107,8 +119,6 @@ MACRO: undo ( quot -- ) [undo] ; \ undo 1 [ [ call ] curry ] define-pop-inverse \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse -\ neg [ neg ] define-inverse -\ recip [ recip ] define-inverse \ exp [ log ] define-inverse \ log [ exp ] define-inverse \ not [ not ] define-inverse @@ -171,13 +181,13 @@ MACRO: undo ( quot -- ) [undo] ; : slot-readers ( class -- quot ) "slots" word-prop 1 tail ! tail gets rid of delegate [ slot-spec-reader 1quotation [ keep ] curry ] map concat - [ drop ] append ; + [ ] like [ drop ] compose ; : ?wrapped ( object -- wrapped ) dup wrapper? [ wrapped ] when ; : boa-inverse ( class -- quot ) - [ deconstruct-pred ] keep slot-readers append ; + [ deconstruct-pred ] keep slot-readers compose ; \ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse @@ -197,7 +207,7 @@ MACRO: undo ( quot -- ) [undo] ; [ writer>reader ] map [ get-slots ] curry compose ; -\ construct 2 [ ?wrapped swap construct-inverse ] define-pop-inverse +\ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse ! More useful inverse-based combinators @@ -207,21 +217,27 @@ MACRO: undo ( quot -- ) [undo] ; [ drop call ] [ nip throw ] if ] recover ; inline -: infer-out ( quot -- #out ) - infer effect-out ; +: true-out ( quot effect -- quot' ) + effect-out [ ndrop ] curry + [ t ] 3compose ; -MACRO: matches? ( quot -- ? ) - [undo] [ t ] append - [ [ [ f ] recover-fail ] curry ] keep - infer-out 1- [ nnip ] curry append ; +: false-recover ( effect -- quot ) + effect-in [ ndrop f ] curry [ recover-fail ] curry ; + +: [matches?] ( quot -- undoes?-quot ) + [undo] dup infer [ true-out ] keep false-recover curry ; + +MACRO: matches? ( quot -- ? ) [matches?] ; TUPLE: no-match ; : no-match ( -- * ) \ no-match construct-empty throw ; -M: no-match summary drop "Fall through in which" ; +M: no-match summary drop "Fall through in switch" ; : recover-chain ( seq -- quot ) [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ; -MACRO: which ( quot-alist -- ) - reverse [ >r [undo] r> append ] { } assoc>map +: [switch] ( quot-alist -- quot ) + reverse [ >r [undo] r> compose ] { } assoc>map recover-chain ; + +MACRO: switch ( quot-alist -- ) [switch] ; From 78429bf419f34d848f2fdbdbc955cd9fb2f540cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 21 Nov 2007 23:52:15 -0600 Subject: [PATCH 3/5] Adding unit tests to inverse --- extra/inverse/inverse-tests.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 77e35a13d2..a61be734fc 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,5 +1,5 @@ USING: inverse tools.test arrays math kernel sequences -math.functions ; +math.functions math.constants ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test @@ -65,3 +65,6 @@ C: nil [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test [ 1 2 ] [ 2 1 [ cons* ] undo ] unit-test + +[ t ] [ pi [ pi ] matches? ] unit-test +[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test From eca98a3b8fbaed7dea467fc7781bcdb448770c08 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 23 Nov 2007 23:54:25 -0500 Subject: [PATCH 4/5] Deleting dead code in extra/rss --- extra/rss/rss.factor | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index b0fdc65adb..0d399e620f 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -3,22 +3,14 @@ IN: rss ! USING: kernel http-client xml xml-utils xml-data errors io strings ! sequences xml-writer parser-combinators lazy-lists entities ; -USING: xml.utilities kernel promises parser-combinators assocs - parser-combinators.replace strings sequences xml.data xml.writer +USING: xml.utilities kernel assocs + strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client ; : ?children>string ( tag/f -- string/f ) [ children>string ] [ f ] if* ; -LAZY: '&' ( -- parser ) - "&" token - [ blank? ] satisfy &> - [ "&" swap add ] <@ ; - -: &>& ( string -- string ) - '&' replace ; - TUPLE: feed title link entries ; C: feed From cafefa868724728215c6c8ff23853cd873a0adf2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Nov 2007 10:49:43 -0500 Subject: [PATCH 5/5] extra/delegate module, defining consultation and mimicry --- extra/delegate/author.txt | 1 + extra/delegate/delegate-docs.factor | 52 ++++++++++++++++++++ extra/delegate/delegate-tests.factor | 26 ++++++++++ extra/delegate/delegate.factor | 73 ++++++++++++++++++++++++++++ extra/delegate/summary.txt | 1 + 5 files changed, 153 insertions(+) create mode 100644 extra/delegate/author.txt create mode 100644 extra/delegate/delegate-docs.factor create mode 100644 extra/delegate/delegate-tests.factor create mode 100644 extra/delegate/delegate.factor create mode 100644 extra/delegate/summary.txt diff --git a/extra/delegate/author.txt b/extra/delegate/author.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/delegate/author.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/delegate/delegate-docs.factor b/extra/delegate/delegate-docs.factor new file mode 100644 index 0000000000..5ceeac42bb --- /dev/null +++ b/extra/delegate/delegate-docs.factor @@ -0,0 +1,52 @@ +USING: delegate help.syntax help.markup ; + +HELP: define-protocol +{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } } +{ $description "Defines a symbol as a protocol." } +{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ; + +HELP: PROTOCOL: +{ $syntax "PROTOCOL: protocol-name words... ;" } +{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ; + +{ define-protocol POSTPONE: PROTOCOL: } related-words + +HELP: define-consult +{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } } +{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." } +{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ; + +HELP: CONSULT: +{ $syntax "CONSULT: group class getter... ;" } +{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } } +{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ; + +{ define-consult POSTPONE: CONSULT: } related-words + +HELP: define-mimic +{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } } +{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." } +{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ; + +HELP: MIMIC: +{ $syntax "MIMIC: group mimicker mimicked" } +{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } } +{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ; + +HELP: group-words +{ $values { "group" "a group" } { "words" "an array of words" } } +{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ; + +ARTICLE: { "delegate" "intro" } "Delegation module" +"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use" +{ $subsection POSTPONE: PROTOCOL: } +{ $subsection define-protocol } +"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are" +{ $subsection POSTPONE: CONSULT: } +{ $subsection define-consult } +"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are" +{ $subsection POSTPONE: MIMIC: } +{ $subsection define-mimic } ; + +IN: delegate +ABOUT: { "delegate" "intro" } diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor new file mode 100644 index 0000000000..01ef33b922 --- /dev/null +++ b/extra/delegate/delegate-tests.factor @@ -0,0 +1,26 @@ +USING: delegate kernel arrays tools.test ; + +TUPLE: hello this that ; +C: hello + +TUPLE: goodbye these those ; +C: goodbye + +GENERIC: foo ( x -- y ) +GENERIC: bar ( a -- b ) +PROTOCOL: baz foo bar ; + +CONSULT: baz goodbye goodbye-these ; +M: hello foo hello-this ; +M: hello bar dup hello? swap hello-that 2array ; + +GENERIC: bing ( c -- d ) +CONSULT: hello goodbye goodbye-these ; +M: hello bing dup hello? swap hello-that 2array ; +MIMIC: bing goodbye hello + +[ 1 { t 0 } ] [ 1 0 [ foo ] keep bar ] unit-test +[ { t 0 } ] [ 1 0 bing ] unit-test +[ 1 ] [ 1 0 f foo ] unit-test +[ { t 0 } ] [ 1 0 f bar ] unit-test +[ { f 0 } ] [ 1 0 f bing ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor new file mode 100644 index 0000000000..c232354600 --- /dev/null +++ b/extra/delegate/delegate.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: parser generic kernel classes words slots io definitions +sequences sequences.private assocs prettyprint.sections arrays ; +IN: delegate + +: define-protocol ( wordlist protocol -- ) + swap { } like "protocol-words" set-word-prop ; + +: PROTOCOL: + CREATE dup reset-generic dup define-symbol + parse-definition swap define-protocol ; parsing + +PREDICATE: word protocol "protocol-words" word-prop ; + +GENERIC: group-words ( group -- words ) + +M: protocol group-words + "protocol-words" word-prop ; + +M: generic group-words + 1array ; + +M: tuple-class group-words + "slots" word-prop 1 tail ! The first slot is the delegate + ! 1 tail should be removed when the delegate slot is removed + dup [ slot-spec-reader ] map + swap [ slot-spec-writer ] map append ; + +: spin ( x y z -- z y x ) + swap rot ; + +: define-consult-method ( word class quot -- ) + pick add spin define-method ; + +: define-consult ( class group quot -- ) + >r group-words r> + swapd [ define-consult-method ] 2curry each ; + +: CONSULT: + scan-word scan-word parse-definition swapd define-consult ; parsing + +PROTOCOL: sequence-protocol + clone clone-like like new new-resizable nth nth-unsafe + set-nth set-nth-unsafe length immutable set-length lengthen ; + +PROTOCOL: assoc-protocol + at* assoc-size >alist assoc-find set-at + delete-at clear-assoc new-assoc assoc-like ; + +PROTOCOL: stream-protocol + stream-close stream-read1 stream-read stream-read-until + stream-flush stream-write1 stream-write stream-format + stream-nl make-span-stream make-block-stream stream-readln + make-cell-stream stream-write-table set-timeout ; + +PROTOCOL: definition-protocol + where set-where forget uses redefined* + synopsis* definer definition ; + +PROTOCOL: prettyprint-section-protocol + section-fits? indent-section? unindent-first-line? + newline-after? short-section? short-section long-section +
delegate>block add-section ; + +: define-mimic ( group mimicker mimicked -- ) + >r >r group-words r> r> [ + pick "methods" word-prop at method-def + spin define-method + ] 2curry each ; + +: MIMIC: + scan-word scan-word scan-word define-mimic ; parsing diff --git a/extra/delegate/summary.txt b/extra/delegate/summary.txt new file mode 100644 index 0000000000..ef49220ac4 --- /dev/null +++ b/extra/delegate/summary.txt @@ -0,0 +1 @@ +Delegation and mimicking on top of the Factor object system