extra/variables/variables.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors definitions fry kernel locals.types namespaces parser
   3 see sequences words ;
   4 FROM: help.markup.private => link-effect? ;
   5 IN: variables
   6
   7 PREDICATE: variable < word
   8     "variable-setter" word-prop ;
   9
  10 GENERIC: variable-setter ( word -- word' )
  11
  12 M: variable variable-setter "variable-setter" word-prop ;
  13 M: local-reader variable-setter "local-writer" word-prop ;
  14
  15 SYNTAX: set:
  16     scan-object variable-setter suffix! ;
  17
  18 : [variable-getter] ( variable -- quot )
  19     '[ _ get ] ;
  20 : [variable-setter] ( variable -- quot )
  21     '[ _ set ] ;
  22
  23 : (define-variable) ( word getter setter -- )
  24     [ (( -- value )) define-inline ]
  25     [
  26         [
  27             [ name>> "set: " prepend <uninterned-word> ]
  28             [ over "variable-setter" set-word-prop ] bi
  29         ] dip (( value -- )) define-inline
  30     ] bi-curry* bi ;
  31
  32 : define-variable ( word -- )
  33     dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
  34
  35 SYNTAX: VAR:
  36     CREATE-WORD define-variable ;
  37
  38 M: variable definer drop \ VAR: f ;
  39 M: variable definition drop f ;
  40 M: variable link-effect? drop f ;
  41 M: variable print-stack-effect? drop f ;
  42
  43 TUPLE: global-box value ;
  44
  45 PREDICATE: global-variable < variable
  46     "variable-setter" word-prop def>> first global-box? ;
  47
  48 : [global-getter] ( box -- quot )
  49     '[ _ value>> ] ;
  50 : [global-setter] ( box -- quot )
  51     '[ _ (>>value) ] ;
  52
  53 : define-global ( word -- )
  54     global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
  55
  56 SYNTAX: GLOBAL:
  57     CREATE-WORD define-global ;
  58
  59 M: global-variable definer drop \ GLOBAL: f ;
  60