1 ! Copyright (C) 2010 Slava Pestov.
2 USING: gml.types gml.printer gml.runtime math math.ranges
3 continuations combinators arrays kernel vectors accessors
4 prettyprint fry sequences assocs locals hashtables grouping
9 GML: cvx ( array -- proc ) { } <proc> ;
10 GML: cvlit ( proc -- array ) array>> ;
11 GML: exec ( obj -- ) exec-proc ;
14 : pop-slice ( seq n -- subseq )
15 [ tail ] [ swap shorten ] 2bi ;
16 : pop-slice* ( seq n -- subseq )
17 over length swap - pop-slice ;
19 GML: pop ( a -- ) drop ;
21 over operand-stack>> [ length swap - ] keep shorten ;
22 GML: dup ( a -- a a ) dup ;
23 GML: exch ( a b -- b a ) swap ;
24 GML: index ( n -- value )
25 over operand-stack>> [ length 1 - swap - ] keep nth ;
27 ERROR: roll-out-of-bounds n j ;
30 2dup abs < [ roll-out-of-bounds ] when
31 [ [ dup operand-stack>> ] dip over length swap - pop-slice ] dip
32 neg over length rem cut-slice swap append over
33 operand-stack>> push-all ;
35 GML: clear ( -- ) dup operand-stack>> delete-all ;
36 GML: cleartomark ( -- )
37 dup [ find-marker ] [ operand-stack>> ] bi shorten ;
38 GML: count ( -- n ) dup operand-stack>> length ;
39 GML: counttomark ( -- n ) dup [ operand-stack>> length ] [ find-marker ] bi - ;
44 [ [ operand-stack>> ] [ find-marker ] bi pop-slice { } like ]
45 [ operand-stack>> pop* ]
48 GML: array ( n -- array )
49 [ dup operand-stack>> ] dip pop-slice* { } like ;
51 GML: length ( array -- len ) length ;
52 GML: append ( array elt -- array' ) suffix ;
53 GML: eappend ( elt array -- array' ) swap suffix ;
55 GML: pop-back ( -- array' )
56 ! Stupid variable arity word!
57 dup pop-operand dup integer?
58 [ [ dup pop-operand ] dip head* ] [ but-last ] if ;
60 GML: pop-front ( -- array' )
61 ! Stupid variable arity word!
62 dup pop-operand dup integer?
63 [ [ dup pop-operand ] dip tail ] [ rest ] if ;
65 GML: arrayappend ( array1 array2 -- array3 ) append ;
66 GML: arrayremove ( array1 n -- array3 ) swap wrap remove-nth ;
67 GML: aload ( array -- ) over operand-stack>> push-all ;
68 GML: array-get ( array indices -- result ) [ (gml-get) ] with map ;
69 GML: flatten ( array -- flatarray )
70 [ dup array? [ 1array ] unless ] map concat ;
71 GML: reverse ( array -- reversed ) reverse ;
72 GML: slice ( array n k -- slice )
73 [a,b) swap '[ _ wrap nth ] map ;
74 GML:: subarray ( array n k -- slice )
75 k n k + array subseq ;
76 GML: sort-number-permutation ( array -- permutation )
77 zip-index sort-keys reverse values ;
80 ERROR: not-a-dict object ;
81 : check-dict ( obj -- obj' ) dup hashtable? [ not-a-dict ] unless ; inline
83 GML: begin ( dict -- ) check-dict over dictionary-stack>> push ;
84 GML: end ( -- ) dup dictionary-stack>> pop* ;
85 GML: dict ( -- dict ) H{ } clone ;
87 GML: dictfromarray ( -- dict )
88 ! Stupid variable-arity word!
90 { [ dup hashtable? ] [ [ dup pop-operand ] dip ] }
91 { [ dup array? ] [ H{ } clone ] }
93 swap 2 group assoc-union! ;
95 GML: keys ( dict -- keys ) keys ;
96 GML: known ( dict key -- ? ) swap key? >true ;
97 GML: values ( dict -- values ) values ;
98 GML: where ( key -- ? )
99 ! Stupid variable-arity word!
100 over dictionary-stack>> [ key? ] with find swap
101 [ over push-operand 1 ] [ drop 0 ] if ;
103 : current-dict ( gml -- assoc ) dictionary-stack>> last ; inline
105 GML: currentdict ( -- dict ) dup current-dict ;
106 GML: load ( name -- value ) over lookup-name ;
108 ERROR: not-a-name object ;
110 : check-name ( obj -- obj' ) dup name? [ not-a-name ] unless ; inline
112 GML: def ( name value -- ) swap check-name pick current-dict set-at ;
113 GML: edef ( value name -- ) check-name pick current-dict set-at ;
114 GML: undef ( name -- ) check-name over current-dict delete-at ;
116 ! Dictionaries and arrays
117 GML: get ( collection key -- elt ) (gml-get) ;
118 GML: put ( collection key elt -- ) (gml-put) ;
119 GML: copy ( collection -- collection' ) (gml-copy) ;
122 : proc>quot ( proc -- quot: ( registers gml -- registers gml ) )
123 '[ _ exec-proc ] ; inline
124 : proc>quot1 ( proc -- quot: ( registers gml value -- registers gml ) )
125 '[ over push-operand _ exec-proc ] ; inline
126 : proc>quot2 ( proc -- quot: ( registers gml value1 value2 -- registers gml ) )
127 '[ [ over push-operand ] bi@ _ exec-proc ] ; inline
129 GML: if ( flag proc -- ) [ true? ] [ proc>quot ] bi* when ;
130 GML: ifelse ( flag proc0 proc1 -- ) [ true? ] [ proc>quot ] [ proc>quot ] tri* if ;
131 GML:: ifpop ( x y flag -- x/y ) flag true? y x ? ;
132 GML: exit ( -- ) return ;
133 GML: loop ( proc -- )
134 '[ _ proc>quot '[ @ t ] loop ] with-return ;
135 GML: repeat ( n proc -- )
136 '[ _ _ proc>quot times ] with-return ;
137 GML: for ( a s b proc -- )
138 '[ _ _ _ _ [ swap <range> ] dip proc>quot1 each ] with-return ;
139 GML: forx ( a s b proc -- )
140 '[ _ _ _ _ [ 1 - swap <range> ] dip proc>quot1 each ] with-return ;
141 GML: forall ( array proc -- )
142 '[ _ _ proc>quot1 each ] with-return ;
143 GML: twoforall ( array1 array2 proc -- )
144 '[ _ _ _ proc>quot2 2each ] with-return ;
145 GML:: map ( array proc -- )
147 marker gml push-operand
148 gml array proc proc>quot1 each
150 GML:: twomap ( array1 array2 proc -- )
152 marker gml push-operand
153 gml array1 array2 proc proc>quot2 2each
156 ! Extensions to real GML
157 GML: print ( obj -- ) print-gml ;
158 GML: test ( obj1 obj2 -- ) swap assert= ;