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