USING: kernel sequences stack-checker.transforms words assocs math.parser classes.tuple accessors generic generic.standard memoize hashtables slots quotations fry math slots.private locals combinators macros arrays compiler.units vocabs ; QUALIFIED: namespaces QUALIFIED: namespaces.private QUALIFIED: assocs.private IN: new-variables : get ( variable -- value ) namespaces:get ; string "new-variables.stupid" create ; TUPLE: variables ; M: variables assoc-size drop 1 ; GENERIC: set-variables ( value key variables -- ) INSTANCE: variables assoc : stupid-gensym-slots ( slots -- slot-names ) length [ number>string ] map ; : create-gensym-tuple-class ( slots -- tuple-class ) stupid-gensym [ swap stupid-gensym-slots variables swap define-tuple-class ] [ [ swap "variables" set-word-prop ] keep ] 2bi ; : slot-nth ( index class -- name ) "slots" word-prop nth name>> ; : define-method ( generic definition class -- ) swap [ swap create-method ] dip define ; : gensym-generic ( effect -- word ) [ gensym dup ] dip define-simple-generic ; : define-get-word ( variable generic -- ) [ [ at ] with assoc define-method ] [ [ drop f ] variables define-method ] bi ; MEMO: get-word ( variable -- word ) (( assoc -- value )) gensym-generic [ define-get-word ] keep ; : replace-namespace ( namespace -- ) namespaces.private:ndrop namespaces.private:>n ; : deoptimize-variables ( value key variables -- ) >hashtable [ set-at ] keep replace-namespace ; : define-set-word ( variable generic -- ) [ [ set-at ] with assoc define-method ] [ [ deoptimize-variables ] with variables define-method ] 2bi ; MEMO: set-word ( variable -- word ) (( value assoc -- )) gensym-generic [ define-set-word ] keep ; : define-get ( slot index class -- ) [ slot-nth reader-word 1quotation ] keep [ get-word ] 2dip define-method ; : define-set ( slot index class -- ) [ slot-nth writer-word 1quotation ] keep [ set-word ] 2dip define-method ; : define-get/set ( variables class -- ) '[ _ [ define-get ] [ define-set ] 3bi ] each-index ; : variable-table ( variables -- hash ) [ swap 2 + ] H{ } assoc-map-as ; : lookup-variable ( key object table -- value/f ? ) swapd at [ slot t ] [ drop f f ] if* ; : define-at* ( variables class -- ) [ \ at* ] [ variable-table '[ _ lookup-variable ] ] [ define-method ] tri* ; : variables>alist ( object slots -- alist ) swap tuple>array rest zip ; : define>alist ( variables class -- ) [ \ >alist ] [ '[ _ variables>alist ] ] [ define-method ] tri* ; :: set-variable ( value key object table -- ) key table at [ value swap object set-slot ] [ value key object deoptimize-variables ] if* ; : define-set-variables ( variables class -- ) [ \ set-variables ] [ variable-table '[ _ set-variable ] ] [ define-method ] tri* ; MEMO: ( variables -- class ) [ dup create-gensym-tuple-class { [ define-get/set ] [ define-at* ] [ define-set-variables ] [ define>alist ] [ nip ] } 2cleave ] with-compilation-unit ; : get-under ( variable -- value ) namespaces.private:namestack* [ length 2 - ] keep assocs.private:(assoc-stack) ; : get-wrapper ( variable word -- quot ) swap '[ namespaces:namespace _ execute [ _ get-under ] unless* ] ; \ get [ dup get-word get-wrapper ] 1 define-transform : set-wrapper ( word -- quot ) '[ namespaces:namespace _ execute ] ; : special-associate ( value key -- hashtable ) associate ; \ special-associate [ 1array '[ _ boa ] ] 1 define-transform MACRO: special-associates ( variables -- quot ) '[ _ boa ] ; PRIVATE> : set ( value variable -- ) namespaces:namespace dup variables? [ set-variables ] [ set-at ] if ; \ set [ set-word set-wrapper ] 1 define-transform : with-variable ( value key quot -- ) [ special-associate ] dip namespaces:bind ; inline : with-variables ( ... keys quot -- ) [ special-associates ] dip namespaces:bind ; inline