Paste: more-slots

USING: accessors classes.tuple combinators fry kernel namespaces
parser quotations sequences slots words words.alias ;

IN: more-slots

SYMBOL: current-object

SYNTAX: with!
    \ ; parse-until >quotation
    lexer get [ 1 - ] change-column drop
    '[ current-object _ with-variable ] append! ;

: lookup-reader-word ( name -- word )
    ">>" append "accessors" lookup-word ;

: lookup-writer-word ( name -- word )
    "<<" append "accessors" lookup-word ;

: lookup-change-word ( name -- word )
    "change-" prepend "accessors" lookup-word ;

: implicit-reader-word ( name -- )
    [ create-word-in ]
    [ lookup-reader-word 1quotation ] bi
    '[ current-object get @ ] ( -- x ) define-declared ;

: implicit-writer-word ( name -- )
    [ "!" append create-word-in ]
    [ lookup-writer-word 1quotation ] bi
    '[ current-object get @ ] ( x -- ) define-declared ;

: implicit-change-word ( name -- )
    [ "@!" append create-word-in dup make-inline ]
    [ lookup-change-word 1quotation ] bi
    '[ current-object get swap @ drop ] ( quot -- ) define-declared ;

: explicit-reader-word ( name -- )
    [ "." prepend create-word-in ]
    [ lookup-reader-word ] bi define-alias ;

: explicit-writer-word ( name -- )
    [ "." "!" surround create-word-in ]
    [ lookup-writer-word ] bi define-alias ;

: explicit-change-word ( name -- )
    [ "." "@!" surround create-word-in ]
    [ lookup-change-word ] bi define-alias ;

: define-more-slot-words ( tuple-class -- )
    all-slots [
        name>> {
            [ implicit-reader-word ]
            [ implicit-writer-word ]
            [ implicit-change-word ]
            [ explicit-reader-word ]
            [ explicit-writer-word ]
            [ explicit-change-word ]
        } cleave
    ] each ;