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 ;