extra/variables/variables.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors arrays combinators definitions fry kernel
   3 locals.types namespaces parser quotations see sequences slots
   4 words ;
   5 FROM: kernel.private => declare ;
   6 FROM: help.markup.private => link-effect? ;
   7 IN: variables
   8
   9 PREDICATE: variable < word
  10     "variable-setter" word-prop >boolean ;
  11
  12 GENERIC: variable-setter ( word -- word' )
  13
  14 M: variable variable-setter "variable-setter" word-prop ;
  15 M: local-reader variable-setter "local-writer" word-prop ;
  16
  17 SYNTAX: set:
  18     scan-object variable-setter suffix! ;
  19
  20 : [variable-getter] ( variable -- quot )
  21     '[ _ get ] ;
  22 : [variable-setter] ( variable -- quot )
  23     '[ _ set ] ;
  24
  25 : (define-variable) ( word getter setter -- )
  26     [ ( -- value ) define-inline ]
  27     [
  28         [
  29             [ name>> "set: " prepend <uninterned-word> ]
  30             [ over "variable-setter" set-word-prop ] bi
  31         ] dip ( value -- ) define-inline
  32     ] bi-curry* bi ;
  33
  34 : define-variable ( word -- )
  35     dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
  36
  37 SYNTAX: VAR:
  38     scan-new-word define-variable ;
  39
  40 M: variable definer drop \ VAR: f ;
  41 M: variable definition drop f ;
  42 M: variable link-effect? drop f ;
  43 M: variable print-stack-effect? drop f ;
  44
  45 PREDICATE: typed-variable < variable
  46     "variable-type" word-prop >boolean ;
  47
  48 : [typed-getter] ( quot type -- quot )
  49     1array '[ @ _ declare ] ;
  50 : [typed-setter] ( quot type -- quot )
  51     instance-check-quot prepose ;
  52
  53 : define-typed-variable ( word type -- )
  54     dupd {
  55         [ [ [variable-getter] ] dip [typed-getter] ]
  56         [ [ [variable-setter] ] dip [typed-setter] ]
  57         [ "variable-type" set-word-prop ]
  58         [ initial-value drop swap set-global ]
  59     } 2cleave (define-variable) ;
  60
  61 SYNTAX: TYPED-VAR:
  62     scan-new-word scan-object define-typed-variable ;
  63
  64 M: typed-variable definer drop \ TYPED-VAR: f ;
  65 M: typed-variable definition "variable-type" word-prop 1quotation ;
  66
  67 TUPLE: global-box value ;
  68
  69 PREDICATE: global-variable < variable
  70     def>> first global-box? ;
  71
  72 : [global-getter] ( box -- quot )
  73     '[ _ value>> ] ;
  74 : [global-setter] ( box -- quot )
  75     '[ _ value<< ] ;
  76
  77 : define-global ( word -- )
  78     global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
  79
  80 SYNTAX: GLOBAL:
  81     scan-new-word define-global ;
  82
  83 M: global-variable definer drop \ GLOBAL: f ;
  84
  85 INTERSECTION: typed-global-variable
  86     global-variable typed-variable ;
  87
  88 : define-typed-global ( word type -- )
  89     2dup "variable-type" set-word-prop
  90     dup initial-value drop global-box boa swap
  91     [ [ [global-getter] ] dip [typed-getter] ]
  92     [ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ;
  93
  94 SYNTAX: TYPED-GLOBAL:
  95     scan-new-word scan-object define-typed-global ;
  96
  97 M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;