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 ;
9 TUPLE: name < identity-tuple { string read-only } ;
13 names [ H{ } clone ] initialize
15 : name ( string -- name ) names get-global [ \ name boa ] cache ;
17 TUPLE: gml { operand-stack vector } { dictionary-stack vector } ;
19 : push-operand ( value gml -- ) operand-stack>> push ; inline
21 : peek-operand ( gml -- value ? )
22 operand-stack>> [ f f ] [ last t ] if-empty ; inline
24 : pop-operand ( gml -- value ) operand-stack>> pop ; inline
26 GENERIC: (exec) ( registers gml obj -- registers gml )
29 FROM: kernel.private => declare ;
31 : is-gml ( registers gml obj -- registers gml obj )
32 { array gml object } declare ; inline
36 : (EXEC:) ( quot -- method def )
37 scan-word \ (exec) create-method-in
38 swap call( -- quot ) [ is-gml ] prepend ;
40 SYNTAX: EXEC: [ parse-definition ] (EXEC:) define ;
42 SYNTAX: EXEC:: [ [ parse-definition ] parse-locals-definition drop ] (EXEC:) define ;
47 EXEC: object over push-operand ;
49 EXEC: proc array>> pick <proc> over push-operand ;
52 TUPLE: exec-name < identity-tuple name ;
54 MEMO: exec-name ( string -- name ) name \ exec-name boa ;
56 SYNTAX: exec" lexer get skip-blank parse-string exec-name suffix! ;
58 ERROR: unbound-name { name name } ;
60 : lookup-name ( name gml -- value )
61 dupd dictionary-stack>> assoc-stack
62 [ ] [ unbound-name ] ?if ; inline
64 GENERIC: exec-proc ( registers gml proc -- registers gml )
66 M:: proc exec-proc ( registers gml proc -- registers gml )
69 proc array>> [ (exec) ] each 2drop
72 FROM: combinators.private => execute-effect-unsafe ;
74 CONSTANT: primitive-effect ( registers gml -- registers gml )
76 M: word exec-proc primitive-effect execute-effect-unsafe ;
78 M: object exec-proc (exec) ;
80 EXEC: exec-name name>> over lookup-name exec-proc ;
83 ERROR: unbound-register name ;
85 :: lookup-register ( registers gml obj -- value )
86 obj n>> registers nth [
87 obj name>> unbound-register
90 TUPLE: read-register { name string } { n fixnum } ;
92 : <read-register> ( name -- read-register ) 0 read-register boa ;
95 [ 2dup ] dip lookup-register over push-operand ;
97 TUPLE: exec-register { name string } { n fixnum } ;
99 : <exec-register> ( name -- exec-register ) 0 exec-register boa ;
102 [ 2dup ] dip lookup-register exec-proc ;
104 TUPLE: write-register { name string } { n fixnum } ;
106 : <write-register> ( name -- write-register ) 0 write-register boa ;
108 EXEC:: write-register ( registers gml obj -- registers gml )
109 gml pop-operand obj n>> registers set-nth
112 TUPLE: use-registers { n fixnum } ;
114 : <use-registers> ( -- use-registers ) use-registers new ;
117 n>> f <array> '[ drop _ ] dip ;
120 TUPLE: pathname names ;
122 C: <pathname> pathname
124 : at-pathname ( pathname assoc -- value )
125 swap names>> [ swap ?at [ unbound-name ] unless ] each ;
127 EXEC:: pathname ( registers gml obj -- registers gml )
128 obj gml pop-operand at-pathname gml push-operand
131 ! List building and stuff
132 TUPLE: marker < identity-tuple ;
133 CONSTANT: marker T{ marker }
135 ERROR: no-marker-found ;
136 ERROR: gml-stack-underflow ;
138 : find-marker ( gml -- n )
139 operand-stack>> [ marker eq? ] find-last
140 [ 1 + ] [ no-marker-found ] if ; inline
143 : check-stack ( seq n -- seq n )
144 2dup swap length > [ gml-stack-underflow ] when ; inline
146 : lastn ( seq n -- elts... )
148 [ tail-slice* ] keep firstn-unsafe ; inline
150 : popn ( seq n -- elts... )
152 [ lastn ] [ over length swap - swap shorten ] 2bi ; inline
154 : set-lastn ( elts... seq n -- )
155 [ tail-slice* ] keep set-firstn-unsafe ; inline
157 : pushn ( elts... seq n -- )
158 [ over length + swap lengthen ] 2keep set-lastn ; inline
160 MACRO: inputs ( inputs# -- quot: ( gml -- gml inputs... ) )
161 '[ dup operand-stack>> _ popn ] ;
163 MACRO: outputs ( outputs# -- quot: ( gml outputs... -- gml ) )
164 [ 1 + ] keep '[ _ npick operand-stack>> _ pushn ] ;
166 MACRO: gml-primitive (
169 quot: ( registers gml inputs... -- outputs... )
171 quot: ( registers gml -- registers gml )
173 swap '[ _ inputs @ _ outputs ] ;
175 SYMBOL: global-dictionary
177 global-dictionary [ H{ } clone ] initialize
179 : add-primitive ( word name -- )
180 name global-dictionary get-global set-at ;
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 ;
188 : scan-gml-name ( -- word name )
189 scan-token [ "gml-" prepend create-word-in ] keep ;
191 : (GML:) ( -- word name effect def )
192 scan-gml-name scan-effect parse-definition ;
195 (GML:) define-gml-primitive ;
199 scan-gml-name :> ( word name )
200 word [ parse-definition ] parse-locals-definition :> ( word def effect )
201 word name effect def define-gml-primitive
206 global-dictionary get clone 1vector >>dictionary-stack
207 V{ } clone >>operand-stack ;
209 : exec ( gml proc -- gml ) [ { } ] 2dip exec-proc nip ;