extra/variables/variables.factor

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