extra/gml/runtime/runtime.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors arrays assocs fry generic.parser kernel locals
   3 locals.parser macros math math.ranges memoize parser sequences
   4 sequences.private strings strings.parser lexer namespaces
   5 vectors words generalizations sequences.generalizations
   6 effects.parser gml.types ;
   7 IN: gml.runtime
   8
   9 TUPLE: gml-name < identity-tuple { string read-only } ;
  10
  11 SYMBOL: gml-names
  12
  13 gml-names [ H{ } clone ] initialize
  14
  15 : >gml-name ( string -- name ) gml-names get-global [ \ gml-name boa ] cache ;
  16
  17 TUPLE: gml { operand-stack vector } { dictionary-stack vector } ;
  18
  19 : push-operand ( value gml -- ) operand-stack>> push ; inline
  20
  21 : peek-operand ( gml -- value ? )
  22     operand-stack>> [ f f ] [ last t ] if-empty ; inline
  23
  24 : pop-operand ( gml -- value ) operand-stack>> pop ; inline
  25
  26 GENERIC: (exec) ( registers gml obj -- registers gml )
  27
  28 ! A bit of efficiency
  29 FROM: kernel.private => declare ;
  30
  31 : is-gml ( registers gml obj -- registers gml obj )
  32     { array gml object } declare ; inline
  33
  34 <<
  35
  36 : (EXEC:) ( quot -- method def )
  37     scan-word \ (exec) create-method-in
  38     swap call( -- quot ) [ is-gml ] prepend ;
  39
  40 SYNTAX: EXEC: [ parse-definition ] (EXEC:) define ;
  41
  42 SYNTAX: EXEC:: [ [ parse-definition ] parse-locals-definition drop ] (EXEC:) define ;
  43
  44 >>
  45
  46 ! Literals
  47 EXEC: object over push-operand ;
  48
  49 EXEC: proc array>> pick <proc> over push-operand ;
  50
  51 ! Executable names
  52 TUPLE: gml-exec-name < identity-tuple name ;
  53
  54 MEMO: >gml-exec-name ( string -- name ) >gml-name \ gml-exec-name boa ;
  55
  56 SYNTAX: exec" lexer get skip-blank parse-string >gml-exec-name suffix! ;
  57
  58 ERROR: unbound-name { name gml-name } ;
  59
  60 : lookup-name ( name gml -- value )
  61     dupd dictionary-stack>> assoc-stack
  62     [ ] [ unbound-name ] ?if ; inline
  63
  64 GENERIC: exec-proc ( registers gml proc -- registers gml )
  65
  66 M:: proc exec-proc ( registers gml proc -- registers gml )
  67     proc registers>>
  68     gml
  69     proc array>> [ (exec) ] each 2drop
  70     registers gml ;
  71
  72 FROM: combinators.private => execute-effect-unsafe ;
  73
  74 CONSTANT: primitive-effect ( registers gml -- registers gml )
  75
  76 M: word exec-proc primitive-effect execute-effect-unsafe ;
  77
  78 M: object exec-proc (exec) ;
  79
  80 EXEC: gml-exec-name name>> over lookup-name exec-proc ;
  81
  82 ! Registers
  83 ERROR: unbound-register name ;
  84
  85 :: lookup-register ( registers gml obj -- value )
  86     obj n>> registers nth [
  87         obj name>> unbound-register
  88     ] unless* ;
  89
  90 TUPLE: read-register { name string } { n fixnum } ;
  91
  92 : <read-register> ( name -- read-register ) 0 read-register boa ;
  93
  94 EXEC: read-register
  95     [ 2dup ] dip lookup-register over push-operand ;
  96
  97 TUPLE: exec-register { name string } { n fixnum } ;
  98
  99 : <exec-register> ( name -- exec-register ) 0 exec-register boa ;
 100
 101 EXEC: exec-register
 102     [ 2dup ] dip lookup-register exec-proc ;
 103
 104 TUPLE: write-register { name string } { n fixnum } ;
 105
 106 : <write-register> ( name -- write-register ) 0 write-register boa ;
 107
 108 EXEC:: write-register ( registers gml obj -- registers gml )
 109     gml pop-operand obj n>> registers set-nth
 110     registers gml ;
 111
 112 TUPLE: use-registers { n fixnum } ;
 113
 114 : <use-registers> ( -- use-registers ) use-registers new ;
 115
 116 EXEC: use-registers
 117     n>> f <array> '[ drop _ ] dip ;
 118
 119 ! Pathnames
 120 TUPLE: pathname names ;
 121
 122 C: <pathname> pathname
 123
 124 : at-pathname ( pathname assoc -- value )
 125     swap names>> [ swap ?at [ unbound-name ] unless ] each ;
 126
 127 EXEC:: pathname ( registers gml obj -- registers gml )
 128     obj gml pop-operand at-pathname gml push-operand
 129     registers gml ;
 130
 131 ! List building and stuff
 132 TUPLE: gml-marker < identity-tuple ;
 133 CONSTANT: marker T{ gml-marker }
 134
 135 ERROR: no-marker-found ;
 136 ERROR: gml-stack-underflow ;
 137
 138 : find-marker ( gml -- n )
 139     operand-stack>> [ marker eq? ] find-last
 140     [ 1 + ] [ no-marker-found ] if ; inline
 141
 142 ! Primitives
 143 : check-stack ( seq n -- seq n )
 144     2dup swap length > [ gml-stack-underflow ] when ; inline
 145
 146 : lastn ( seq n -- elts... )
 147     check-stack
 148     [ tail-slice* ] keep firstn-unsafe ; inline
 149
 150 : popn ( seq n -- elts... )
 151     check-stack
 152     [ lastn ] [ over length swap - swap shorten ] 2bi ; inline
 153
 154 : set-lastn ( elts... seq n -- )
 155     [ tail-slice* ] keep set-firstn-unsafe ; inline
 156
 157 : pushn ( elts... seq n -- )
 158     [ over length + swap lengthen ] 2keep set-lastn ; inline
 159
 160 MACRO: inputs ( inputs# -- quot: ( gml -- gml inputs... ) )
 161     '[ dup operand-stack>> _ popn ] ;
 162
 163 MACRO: outputs ( outputs# -- quot: ( gml outputs... -- gml ) )
 164     [ 1 + ] keep '[ _ npick operand-stack>> _ pushn ] ;
 165
 166 MACRO: gml-primitive (
 167     inputs#
 168     outputs#
 169     quot: ( registers gml inputs... -- outputs... )
 170     --
 171     quot: ( registers gml -- registers gml )
 172 )
 173     swap '[ _ inputs @ _ outputs ] ;
 174
 175 SYMBOL: global-dictionary
 176
 177 global-dictionary [ H{ } clone ] initialize
 178
 179 : add-primitive ( word name -- )
 180     >gml-name global-dictionary get-global set-at ;
 181
 182 : define-gml-primitive ( word name effect def -- )
 183     [ '[ _ add-primitive ] keep ]
 184     [ [ in>> length ] [ out>> length ] bi ]
 185     [ '[ { gml } declare _ _ _ gml-primitive ] ] tri*
 186     primitive-effect define-declared ;
 187
 188 : scan-gml-name ( -- word name )
 189     scan-token [ "gml-" prepend create-word-in ] keep ;
 190
 191 : (GML:) ( -- word name effect def )
 192     scan-gml-name scan-effect parse-definition ;
 193
 194 SYNTAX: GML:
 195     (GML:) define-gml-primitive ;
 196
 197 SYNTAX: GML::
 198     [let
 199         scan-gml-name :> ( word name )
 200         word [ parse-definition ] parse-locals-definition :> ( word def effect )
 201         word name effect def define-gml-primitive
 202     ] ;
 203
 204 : <gml> ( -- gml )
 205     gml new
 206     global-dictionary get clone 1vector >>dictionary-stack
 207     V{ } clone >>operand-stack ;
 208
 209 : exec ( gml proc -- gml ) [ { } ] 2dip exec-proc nip ;