Starting to remove delegation

basis/compiler/tests/optimizer.factor

@@ -222,16 +222,6 @@ USE: binary-search.private
     [ [ - ] swap old-binsearch ] compile-call 2nip
 ] unit-test
 
-! Regression
-TUPLE: silly-tuple a b ;
-
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [
-    T{ silly-tuple f 1 2 }
-    [
-        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
-    ] compile-call
-] unit-test
-
 ! Regression
 : empty-compound ;
 

basis/peg/peg-tests.factor

@@ -11,7 +11,7 @@ IN: peg.tests
 
 { "begin" "end" } [
   "beginend" "begin" token (parse) 
-  { ast>> remaining>> } get-slots
+  [ ast>> ] [ remaining>> ] bi
   >string
 ] unit-test
 

basis/stack-checker/transforms/transforms.factor

@@ -164,8 +164,3 @@ SYMBOL: +transform-n+
 \ memq? [
     dup sequence? [ memq-quot ] [ drop f ] if
 ] 1 define-transform
-
-! Deprecated
-\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform
-
-\ set-slots [ <reversed> [ get-slots ] curry ] 1 define-transform

basis/ui/gadgets/buttons/buttons.factor

@@ -52,7 +52,7 @@ TUPLE: button-paint plain rollover pressed selected ;
 C: <button-paint> button-paint
 
 : find-button ( gadget -- button )
-    [ [ button? ] is? ] find-parent ;
+    [ button? ] find-parent ;
 
 : button-paint ( button paint -- button paint )
     over find-button {

basis/ui/gadgets/gadgets.factor

@@ -361,8 +361,3 @@ M: f request-focus-on 2drop ;
 
 : focus-path ( world -- seq )
     [ focus>> ] follow ;
-
-! Deprecated
-
-: construct-gadget ( class -- tuple )
-    >r <gadget> { set-delegate } r> construct ; inline

basis/ui/gadgets/labelled/labelled.factor

@@ -45,7 +45,7 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
 TUPLE: closable-gadget < frame content ;
 
 : find-closable-gadget ( parent -- child )
-    [ [ closable-gadget? ] is? ] find-parent ;
+    [ closable-gadget? ] find-parent ;
 
 : <closable-gadget> ( gadget title quot -- gadget )
   closable-gadget new-frame

basis/ui/gadgets/lists/lists.factor

@@ -31,7 +31,7 @@ TUPLE: list < pack index presenter color hook ;
     swap set-list-index ;
 
 : list-presentation-hook ( list -- quot )
-    hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
+    hook>> [ [ list? ] find-parent ] prepend ;
 
 : <list-presentation> ( hook elt presenter -- gadget )
     keep >r >label text-theme r>

basis/ui/gadgets/presentations/presentations-tests.factor

@@ -4,7 +4,7 @@ prettyprint ui.gadgets.buttons io io.streams.string kernel
 classes.tuple ;
 
 [ t ] [
-    "Hi" \ + <presentation> [ gadget? ] is?
+    "Hi" \ + <presentation> gadget?
 ] unit-test
 
 [ "+" ] [

basis/ui/gadgets/scrollers/scrollers.factor

@@ -10,7 +10,7 @@ IN: ui.gadgets.scrollers
 TUPLE: scroller < frame viewport x y follows ;
 
 : find-scroller ( gadget -- scroller/f )
-    [ [ scroller? ] is? ] find-parent ;
+    [ scroller? ] find-parent ;
 
 : scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
 

basis/ui/gestures/gestures.factor

@@ -17,7 +17,7 @@ GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
 M: object handle-gesture* default-gesture-handler ;
 
 : handle-gesture ( gesture gadget -- ? )
-    tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
+    tuck >r 2dup r> handle-gesture* 2nip ;
 
 : send-gesture ( gesture gadget -- ? )
     [ dupd handle-gesture ] each-parent nip ;

basis/ui/tools/search/search.factor

@@ -29,7 +29,7 @@ M: live-search handle-gesture* ( gadget gesture delegate -- ? )
     ] if ;
 
 : find-live-search ( gadget -- search )
-    [ [ live-search? ] is? ] find-parent ;
+    [ live-search? ] find-parent ;
 
 : find-search-list ( gadget -- list )
     find-live-search live-search-list ;

basis/units/units.factor

@@ -1,6 +1,6 @@
-USING: arrays io kernel math namespaces splitting prettyprint
+USING: accessors arrays io kernel math namespaces splitting
-sequences sorting vectors words inverse summary shuffle
+prettyprint sequences sorting vectors words inverse summary
-math.functions sets ;
+shuffle math.functions sets ;
 IN: units
 
 TUPLE: dimensioned value top bot ;
@@ -28,8 +28,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
     dimensioned boa ;
 
 : >dimensioned< ( d -- n top bot )
-    { dimensioned-value dimensioned-top dimensioned-bot }
+    [ value>> ] [ top>> ] [ bot>> ] tri ;
-    get-slots ;
 
 \ <dimensioned> [ >dimensioned< ] define-inverse
 

basis/windows/com/syntax/syntax.factor

@@ -74,7 +74,7 @@ unless
 
 : (define-word-for-function) ( function interface n -- )
     -rot [ (function-word) swap ] 2keep drop
-    { return>> parameters>> } get-slots
+    [ return>> ] [ parameters>> ] bi
     [ (invocation-quot) ] 2keep
     (stack-effect-from-return-and-parameters)
     define-declared ;

core/classes/tuple/tuple-docs.factor

@@ -425,28 +425,6 @@ HELP: new
     }
 } ;
 
-HELP: construct
-{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
-{ $examples
-    "We can define a class:"
-    { $code "TUPLE: color red green blue alpha ;" }
-    "Together with two constructors:"
-    { $code
-        ": <rgb> ( r g b -- color )"
-        "    { set-color-red set-color-green set-color-blue }"
-        "    color construct ;"
-        ""
-        ": <rgba> ( r g b a -- color )"
-        "    { set-color-red set-color-green set-color-blue set-color-alpha }"
-        "    color construct ;"
-    }
-    "The last definition is actually equivalent to the following:"
-    { $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
-    "Which can be abbreviated further:"
-    { $code "C: <rgba> color" }
-} ;
-
 HELP: boa
 { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
 { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }

core/classes/tuple/tuple.factor

@@ -320,14 +320,3 @@ M: tuple-class boa
     bi <tuple-boa> ;
 
 M: tuple-class initial-value* new ;
-
-! Deprecated
-M: object get-slots ( obj slots -- ... )
-    [ execute ] with each ;
-
-M: object set-slots ( ... obj slots -- )
-    <reversed> get-slots ;
-
-: delegates ( obj -- seq ) [ delegate ] follow ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

core/kernel/kernel.factor

@@ -206,17 +206,3 @@ GENERIC: delegate ( obj -- delegate )
 M: tuple delegate 2 slot ;
 
 M: object delegate drop f ;
-
-GENERIC: set-delegate ( delegate tuple -- )
-
-M: tuple set-delegate 2 set-slot ;
-
-GENERIC# get-slots 1 ( tuple slots -- ... )
-
-GENERIC# set-slots 1 ( ... tuple slots -- )
-
-: construct ( ... slots class -- tuple )
-    new [ swap set-slots ] keep ; inline
-
-: construct-delegate ( delegate class -- tuple )
-    >r { set-delegate } r> construct ; inline

core/syntax/syntax-docs.factor

@@ -533,8 +533,8 @@ $nl
 "Slot specifiers take one of the following three forms:"
 { $list
     { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
-    { { $snippet "{ \"name\" attributes... }" } " - a slot which can hold any object, with optional attributes" }
+    { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
-    { { $snippet "{ \"name\" class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+    { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
 }
 "Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." }
 { $examples