1 \ *****************************************************************************
2 \ * Copyright (c) 2011 IBM Corporation
3 \ * All rights reserved.
4 \ * This program and the accompanying materials
5 \ * are made available under the terms of the BSD License
6 \ * which accompanies this distribution, and is available at
7 \ * http://www.opensource.org/licenses/bsd-license.php
10 \ * IBM Corporation - initial implementation
11 \ ****************************************************************************/
13 \ * Support for old-fashioned local values in FCODE.
15 \ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range
16 \ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack
17 \ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to
18 \ * push 0 up to 8 values from the normal data stack into the current locals
19 \ * stack frame. All other variables in the current stack frame are not
21 \ * The opcodes from 0x410 to 0x417 can be used for reading the first, second,
22 \ * ... eighth value out of the locals stack frame, and the opcode from 0x418
23 \ * to 0x41f can be used to set the first, second, ... eighth value in the
24 \ * stack frame respectively.
27 80 cells CONSTANT LOCALS-STACK-SIZE
29 LOCALS-STACK-SIZE BUFFER: localsstackbuf
31 localsstackbuf VALUE localsstack
34 : fc-local@ ( n -- val )
35 cells localsstack swap - @
38 : fc-local-1-@ 1 fc-local@ ;
39 : fc-local-2-@ 2 fc-local@ ;
40 : fc-local-3-@ 3 fc-local@ ;
41 : fc-local-4-@ 4 fc-local@ ;
42 : fc-local-5-@ 5 fc-local@ ;
43 : fc-local-6-@ 6 fc-local@ ;
44 : fc-local-7-@ 7 fc-local@ ;
45 : fc-local-8-@ 8 fc-local@ ;
48 : fc-local! ( val n -- )
49 cells localsstack swap - !
52 : fc-local-1-! 1 fc-local! ;
53 : fc-local-2-! 2 fc-local! ;
54 : fc-local-3-! 3 fc-local! ;
55 : fc-local-4-! 4 fc-local! ;
56 : fc-local-5-! 5 fc-local! ;
57 : fc-local-6-! 6 fc-local! ;
58 : fc-local-7-! 7 fc-local! ;
59 : fc-local-8-! 8 fc-local! ;
64 \ Create space for the current function on the locals stack.
65 \ Pre-initialized the n first locals with the n top-most data stack items.
66 \ Note: Each function can use up to 8 (initialized or uninitialized) locals.
67 : (fc-push-locals) ( ... n -- )
68 \ cr ." pushing " dup . ." locals" cr
69 8 cells localsstack + TO localsstack
70 localsstack localsstackbuf -
71 LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!"
74 i fc-local! \ Store pre-initialized locals
79 : fc-push-locals ( n -- )
80 \ cr ." compiling push for " dup . ." locals" cr
81 uses-locals? ABORT" Definition pushes locals multiple times!"
83 ( n ) ['] literal execute
84 ['] (fc-push-locals) compile,
87 : fc-push-0-locals 0 fc-push-locals ;
88 : fc-push-1-locals 1 fc-push-locals ;
89 : fc-push-2-locals 2 fc-push-locals ;
90 : fc-push-3-locals 3 fc-push-locals ;
91 : fc-push-4-locals 4 fc-push-locals ;
92 : fc-push-5-locals 5 fc-push-locals ;
93 : fc-push-6-locals 6 fc-push-locals ;
94 : fc-push-7-locals 7 fc-push-locals ;
95 : fc-push-8-locals 8 fc-push-locals ;
98 : fc-pop-locals ( -- )
99 \ ." popping locals" cr
100 localsstack 8 cells - TO localsstack
101 localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!"
107 \ ." compiling pop-locals for exit" cr
108 ['] fc-pop-locals compile,
115 \ ." compiling pop-locals for b(;)" cr
116 ['] fc-pop-locals compile,
118 false TO uses-locals?
123 : fc-set-locals-tokens ( -- )
124 ['] fc-push-0-locals 1 407 set-token
125 ['] fc-push-1-locals 1 408 set-token
126 ['] fc-push-2-locals 1 409 set-token
127 ['] fc-push-3-locals 1 40a set-token
128 ['] fc-push-4-locals 1 40b set-token
129 ['] fc-push-5-locals 1 40c set-token
130 ['] fc-push-6-locals 1 40d set-token
131 ['] fc-push-7-locals 1 40e set-token
132 ['] fc-push-8-locals 1 40f set-token
134 ['] fc-local-1-@ 0 410 set-token
135 ['] fc-local-2-@ 0 411 set-token
136 ['] fc-local-3-@ 0 412 set-token
137 ['] fc-local-4-@ 0 413 set-token
138 ['] fc-local-5-@ 0 414 set-token
139 ['] fc-local-6-@ 0 415 set-token
140 ['] fc-local-7-@ 0 416 set-token
141 ['] fc-local-8-@ 0 417 set-token
143 ['] fc-local-1-! 0 418 set-token
144 ['] fc-local-2-! 0 419 set-token
145 ['] fc-local-3-! 0 41a set-token
146 ['] fc-local-4-! 0 41b set-token
147 ['] fc-local-5-! 0 41c set-token
148 ['] fc-local-6-! 0 41d set-token
149 ['] fc-local-7-! 0 41e set-token
150 ['] fc-local-8-! 0 41f set-token
152 ['] fc-locals-exit 1 33 set-token
153 ['] fc-locals-b(;) 1 c2 set-token