swapforth

1
: \     source nip >in ! ; immediate \ Now can use comments!
2
\       
3
\ This file contains definitions in high-level Forth for the
4
\ rest of Swapforth. Many words were already defined in
5
\ nucleus -- this file fills in the gaps.
6
\       
7
\ This file is divided into sections for each word set in ANS
8
\ Forth.
9
\
10
\ The only definitions in this file should be specific to
11
\ Swapforth Python (sfpy).
12

13
\ #######   CORE AND DOUBLE   #################################
14
include core0.fs
15

16
: 2>r   r> -rot swap >r >r >r ;
17
: 2r>
18
    postpone r>
19
    postpone r>
20
    postpone swap
21
; immediate
22
: 2r@   r> 2r> 2dup 2>r rot >r ;
23

24
: >body
25
    8 + @
26
;
27

28
: (  ')' parse 2drop ; immediate
29

30
: dabs      dup 0< if dnegate then ;
31
: d0=       or 0= ;
32
: 2rot      >r >r 2swap r> r> 2swap ;
33

34
include double.fs
35
include core.fs
36

37
: /mod      >r s>d r> sm/rem ;
38
: /         /mod nip ;
39
: mod       /mod drop ;
40

41
\ #######   CORE EXT   ########################################
42

43
: s,  dup c, bounds ?do i c@ c, loop ;
44

45
: c"
46
    here postpone literal
47
    [char] " parse
48
    s,
49
; immediate
50

51
: sliteral
52
    here postpone literal
53
    s,
54
    postpone count
55
; immediate
56

57
: (.")
58
    count type
59
;
60

61
: ."
62
    [char] " parse
63
    state @ if
64
        here postpone literal
65
        s,
66
        postpone (.")
67
    else
68
        type
69
    then
70
; immediate
71

72

73
: unused here negate ;
74
: pad here aligned ;
75

76
include core-ext0.fs
77
include core-ext.fs
78

79
: flashblank ( addr -- )
80
    flashbase -
81
    12 rshift       \ sector number
82
    spi_flash_erase_sector throw ;
83

84
: saligned  ( a0 -- a1 ) \ a1 is sector-aligned address
85
    4095 + -4096 and ;
86

87
: marker
88
    forth @ dp @ cp @
89
    dup saligned cp !  \ Start a new sector
90
    create
91
        , , ,
92
    does>
93
        cp @ over @ saligned begin
94
            2dup u>
95
        while
96
            cr ." blanking " over .x dup .x
97
            dup flashblank
98
            4096 +
99
        repeat 2drop
100
        dup @ cp !
101
        cell+ dup @ dp !
102
        cell+ @ forth !
103
;
104

105
: floats cells ;
106
: faligned aligned ;
107

108
: LOCALWORDS ;
109
: PUBLICWORDS ;
110
: DONEWORDS ;
111

112
include string0.fs
113
include string.fs
114
include tools-ext.fs
115
include value.fs
116
include deferred.fs
117
include forth2012.fs
118
include structures.fs
119
include escaped.fs
120

121
include runtests.fs
122

123
#bye
124

125
: .xt  ( xt -- ) \ print xt's name
126
    >r
127
    forth @
128
    begin
129
        dup 0= if
130
            r> 2drop exit
131
        then
132
        dup
133
        2 +
134
        count + caligned
135
        uw@ r@ <>
136
    while
137
        uw@ -2 and
138
    repeat
139
    r> drop
140
    2 + count type
141
;
142

143
create op4          \ 4-bit field names, bits [11:8]
144
    s" T"           s,
145
    s" N"           s,
146
    s" T+N"         s,
147
    s" T&N"         s,
148
    s" T|N"         s,
149
    s" T^N"         s,
150
    s" ~T"          s,
151
    s" N==T"        s,
152
    s" N<T"         s,
153
    s" N>>T"        s,
154
    s" N<<T"        s,
155
    s" rT"          s,
156
    s" [T]"         s,
157
    s" io[T]"       s,
158
    s" status"      s,
159
    s" Nu<T"        s,
160

161
create op3          \ 3-bit operation, bits [6:4]
162
    s" "            s,
163
    s" T->N"        s,
164
    s" T->R"        s,
165
    s" N->[T]"      s,
166
    s" N->io[T]"    s,
167
    s" _IORD_"      s,
168

169
create opr          \ 2-bit R stack delta, bits [3:2]
170
    s" "            s,
171
    s" r+1"         s,
172
    s" "            s,
173
    s" r-1"         s,
174

175
create opd          \ 2-bit D stack delta, bits [1:0]
176
    s" "            s,
177
    s" d+1"         s,
178
    s" "            s,
179
    s" d-1"         s,
180

181
: skip." ( addr u -- ) \ skip u strings, then print
182
    0 ?do
183
        count +
184
    loop (.")
185
    space
186
;
187

188
: .alu
189
    ." ALU "
190

191
    op4 over 8 rshift skip."
192

193
    op3 over 4 rshift 7 and skip."
194

195
    opr over 2 rshift 3 and skip."
196

197
    opd over 3 and skip."
198

199
    space
200
    $80 and if ." ;" then
201
;
202

203
\ Construct a 4-entry jump table J1op
204
\ for the four J1 opcodes
205

206
( 3:ALU     ) :noname 2/ .alu ;
207
( 2:CALL    ) ' .xt    \ print xt's name
208
( 1:0BRANCH ) :noname [char] Z emit space . ;
209
( 0:JUMP    ) :noname [char] J emit space . ;
210
create J1op , , , ,
211

212
: dis ( addr -- )
213
    base @ swap hex
214
    64 bounds
215
    begin
216
        cr dup .
217
        dup uw@
218
        dup 4 .r space
219
        dup 15 rshift if
220
            32767 and
221
            [char] $ emit dup .
222
            decimal
223
            [char] # emit .
224
            hex
225
        else
226
            dup 8191 and 2* swap
227
            13 rshift cells J1op + @ execute
228
        then
229
        2 +
230
        2dup =
231
    until
232
    2drop
233
    base !
234
;
235

236
: see ' dis ;
237

238
: environment?
239
    2drop false
240
;
241

242
\ #######   DEFERRED WORDS    #################################
243

244
: defer ( "name" -- )
245
  : ['] abort compile, postpone ; ;
246

247
: defer@ ( xt1 -- xt2 )
248
  uw@ 2* ;
249

250
: defer! ( xt2 xt1 -- )
251
  swap 2/ swap w! ;
252

253
: is
254
  state @ if
255
    POSTPONE ['] POSTPONE defer!
256
  else
257
    ' defer!
258
  then ; immediate
259

260
: action-of
261
 state @ if
262
   POSTPONE ['] POSTPONE defer@
263
 else
264
   ' defer@
265
then ; immediate
266

267
\ #######   EVERYTHING ELSE   #################################
268

269
include float0.fs
270
include value.fs
271
include exception.fs
272
include facilityext.fs
273

274

275
include forth2012.fs
276

277
\ include memory.fs
278

279
include comus.fs
280
include mini-oof.fs
281

282
include drivers/gpio.fs
283
include drivers/spi.fs
284
include drivers/time.fs
285

286
: new
287
    s" | marker |" evaluate
288
;
289
marker |
290