OpenCores
URL https://opencores.org/ocsvn/forth-cpu/forth-cpu/trunk

Subversion Repositories forth-cpu

[/] [forth-cpu/] [trunk/] [h2.fth] - Blame information for rev 3

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 3 howe.r.j.8
( This program is written in a pseudo Forth like language, it is not
2
Forth and does not behave like it, it just looks like it. This should
3
be thought of as assembly code and not Forth.
4
 
5
A lot of the code has been taken verbatim from "The Zen of eForth by
6
C. H. Ting". Some routines have been adapted from the j1eforth implementation
7
available at https://github.com/samawati/j1eforth.
8
 
9
For a grammar of the language look into the file "h2.c", or "readme.md".
10
 
11
Execution begins at a label called "start".
12
 
13
A problem with this Forth is that is uses a singe block buffer, which can cause
14
problems when using the block word set from within blocks. The main reason for
15
this is due to the limited space on the device.
16
 
17
Forth To Do:
18
* Add do...loop, case statements, put them in block storage
19
* Reformat this so it can be stored in block storage, with
20
a maximum line length of 64 bytes
21
* Implement some words from the C library, like all of "ctype.h" and
22
put them in block storage.
23
* Implement many of the lessons learned whilst making the
24
'embed' Forth interpreter , which
25
cuts down on the interpreter size, and adds more functionality. )
26
 
27
( ======================== System Constants ================= )
28
 
29
constant cell 2 hidden
30
 
31
( The first 8 cells [16 bytes] of memory contain the entry point and interrupt
32
service routine call locations, we can set the instruction to be run [such as
33
a jump or a call] by setting the label to it with the ".set" directive. Later
34
in the program the entry point, the first location in memory, is set to the
35
start label )
36
entry:             .allocate cell ( Entry point - not an interrupt )
37
isrRxFifoNotEmpty: .allocate cell ( UART RX FIFO not empty )
38
isrRxFifoFull:     .allocate cell ( UART RX FIFO full )
39
isrTxFifoNotEmpty: .allocate cell ( UART TX FIFO not empty )
40
isrTxFifoFull:     .allocate cell ( UART TX FIFO full )
41
isrKbdNew:         .allocate cell ( New PS/2 Keyboard character )
42
isrTimer:          .allocate cell ( Timer interrupt )
43
isrDPadButton:     .allocate cell ( Any D-Pad Button Changed state )
44
 
45
.mode 3   ( Turn word header compilation and optimization on )
46
.built-in ( Add the built in words to the dictionary )
47
 
48
constant =exit         $601c hidden ( op code for exit )
49
constant =invert       $6600 hidden ( op code for invert )
50
constant =>r           $6147 hidden ( op code for >r )
51
constant =bl           32    hidden ( blank, or space )
52
constant =cr           13    hidden ( carriage return )
53
constant =lf           10    hidden ( line feed )
54
constant =bs           8     hidden ( back space )
55
constant =escape       27    hidden ( escape character )
56
 
57
constant c/l           64    hidden ( characters per line in a block )
58
constant l/b           16    hidden ( lines in a block )
59
 
60
constant dump-width    16    hidden ( number of columns for 'dump' )
61
constant tib-length    80    hidden ( size of terminal input buffer )
62
constant pad-length    80    hidden ( pad area begins HERE + pad-length )
63
constant word-length   31    hidden ( maximum length of a word )
64
 
65
( Outputs: $6000 - $7FFF )
66
constant oUart         $4000 hidden ( UART TX/RX Control register )
67
constant oVT100        $4002 hidden ( LEDs )
68
constant oTimerCtrl    $4004 hidden ( Timer control register )
69
constant oLeds         $4006 hidden ( VGA X/Y Cursor position )
70
constant oMemDout      $4008 hidden ( Memory output for writes )
71
constant oMemControl   $400A hidden ( Memory control and high address bits )
72
constant oMemAddrLow   $400C hidden ( Lower memory address bits )
73
constant o7SegLED      $400E hidden ( 4x7 Segment display )
74
constant oIrcMask      $4010 hidden ( Interrupt Mask )
75
 
76
( Inputs: $6000 - $7FFF )
77
constant iUart         $4000 hidden ( Matching registers for iUart )
78
constant iVT100        $4002 hidden ( Switch control [on/off] )
79
constant iTimerDin     $4004 hidden ( Current timer value )
80
constant iSwitches     $4006 hidden ( VGA text output, currently broken )
81
constant iMemDin       $4008 hidden ( Memory input for reads )
82
 
83
( ======================== System Constants ================= )
84
 
85
( ======================== System Variables ================= )
86
 
87
( Execution vectors for changing the behaviour of the program,
88
they are set at the end of this file )
89
location _key?      0  ( -- c -1 | 0 : new character available? )
90
location _emit      0  ( c -- : emit character )
91
location _expect    0  ( "accept" vector )
92
location _tap       0  ( "tap" vector, for terminal handling )
93
location _echo      0  ( c -- : emit character )
94
location _prompt    0  ( -- : display prompt )
95
location _boot      0  ( -- : execute program at startup )
96
location _bload     0  ( a u k -- f : load block )
97
location _bsave     0  ( a u k -- f : save block )
98
location _binvalid  0  ( k -- k : throws error if k invalid )
99
location _message   0  ( n -- : display an error message )
100
location last-def   0  ( last, possibly unlinked, word definition )
101
location flash-voc  0  ( flash and memory word set )
102
location cp         0  ( Dictionary Pointer: Set at end of file )
103
location csp        0  ( current data stack pointer - for error checking )
104
location _id        0  ( used for source id )
105
location rendezvous 0  ( saved cp and pwd )
106
.allocate cell
107
location seed       1  ( seed used for the PRNG )
108
location handler    0  ( current handler for throw/catch )
109
variable >in        0  ( Hold character pointer when parsing input )
110
variable state      0  ( compiler state variable )
111
variable hld        0  ( Pointer into hold area for numeric output )
112
variable base       10 ( Current output radix )
113
variable span       0  ( Hold character count received by expect   )
114
variable loaded     0  ( Used by boot block to indicate it has been loaded  )
115
variable border    -1  ( Put border around block begin displayed with 'list' )
116
constant #vocs            8 hidden ( number of vocabularies in allowed )
117
variable forth-wordlist   0 ( set at the end near the end of the file )
118
location context          0 ( holds current context for vocabulary search order )
119
.allocate 14                ( ... space for context )
120
location #tib             0 ( Current count of terminal input buffer    )
121
location tib-buf          0 ( ... and address )
122
.set tib-buf $pc            ( set tib-buf to current dictionary location )
123
.allocate tib-length        ( allocate enough for the terminal input buffer )
124
.allocate cell              ( plus one extra cell for safety )
125
constant block-invalid   -1 hidden ( block invalid number )
126
constant b/buf 1024 ( size of a block )
127
variable blk             -1 ( current blk loaded )
128
location block-dirty      0 ( -1 if loaded block buffer is modified )
129
location block-buffer     0 ( block buffer starts here )
130
.allocate b/buf
131
 
132
location _blockop         0             ( used in 'mblock' )
133
location bcount           0             ( instruction counter used in 'see' )
134
location _test            0             ( used in skip/test )
135
location .s-string        " 
136
location see.unknown      "(no-name)"   ( used by 'see' for calls to anonymous words )
137
location see.lit          "LIT"         ( decompilation -> literal )
138
location see.alu          "ALU"         ( decompilation -> ALU operation )
139
location see.call         "CAL"         ( decompilation -> Call )
140
location see.branch       "BRN"         ( decompilation -> Branch )
141
location see.0branch      "BRZ"         ( decompilation -> 0 Branch )
142
location see.immediate    " immediate " ( used by "see", for immediate words )
143
location see.inline       " inline "    ( used by "see", for inline words )
144
location OK               "ok"          ( used by "prompt" )
145
location redefined        " redefined"  ( used by ":" when a word has been redefined )
146
location hi-string        "eFORTH V"    ( used by "hi" )
147
location loading-string   "loading..."  ( used in start up routine )
148
location failed           "failed"      ( used in start up routine )
149
 
150
( ======================== System Variables ================= )
151
 
152
( ======================== Forth Kernel ===================== )
153
 
154
: [-1] -1 ; hidden         ( -- -1 : space saving measure, push -1 onto stack )
155
: 0x8000 $8000 ; hidden    ( -- $8000 : space saving measure, push $8000 onto stack )
156
: ! store drop ;           ( n a -- : store a value 'n' at location 'a'  )
157
: 256* 8 lshift ; hidden   ( u -- u : shift left by 8, or multiple by 256 )
158
: 256/ 8 rshift ; hidden   ( u -- u : shift right by 8, or divide by 256 )
159
: 1+ 1 + ;                 ( n -- n : increment a value  )
160
: negate invert 1 + ;      ( n -- n : negate a number )
161
: - invert 1 + + ;         ( n1 n2 -- n : subtract n1 from n2 )
162
: 2/ 1 rshift ;            ( n -- n : divide by 2 NB. This isn't actually correct, just useful, "1 arshift" would be acceptable )
163
: 2* 1 lshift ;            ( n -- n : multiply by 2 )
164
: cell- cell - ;           ( a -- a : adjust address to previous cell )
165
: cell+ cell + ;           ( a -- a : move address forward to next cell )
166
: cells 2* ;               ( n -- n : convert number of cells to number to increment address by )
167
: ?dup dup if dup exit then ;   ( n -- 0 | n n : duplicate value if it is not zero )
168
: >  swap < ;              ( n1 n2 -- f : signed greater than, n1 > n2 )
169
: u> swap u< ;             ( u1 u2 -- f : unsigned greater than, u1 > u2 )
170
: u>= u< invert ;          ( u1 u2 -- f : )
171
: <> = invert ;            ( n n -- f : not equal )
172
: 0<> 0= invert ;          ( n n -- f : not equal  to zero )
173
: 0> 0 > ;                 ( n -- f : greater than zero? )
174
: 0< 0 < ;                 ( n -- f : less than zero? )
175
: 2dup over over ;         ( n1 n2 -- n1 n2 n1 n2 )
176
: 2drop drop drop ;        ( n n -- )
177
: tuck swap over ;         ( n1 n2 -- n2 n1 n2 )
178
: +! tuck @ + swap ! ;     ( n a -- : increment value at address by 'n' )
179
: 1+!  1 swap +! ;         ( a -- : increment value at address by 1 )
180
: 1-! [-1] swap +! ; hidden  ( a -- : decrement value at address by 1 )
181
: execute >r ;             ( cfa -- : execute a function )
182
: c@ dup ( -2 and ) @ swap 1 and if 8 rshift exit else $ff and exit then ; ( b -- c )
183
: c!                       ( c b -- )
184
        swap $ff and dup 8 lshift or swap
185
        swap over dup ( -2 and ) @ swap 1 and 0 = $ff xor
186
        >r over xor r> and xor swap ( -2 and ) store drop ;
187
: c, cp @ c! cp 1+! ;    ( c -- : store 'c' at next available location in the dictionary )
188
: 40ns begin dup while 1- repeat drop ; hidden ( n -- : wait for 'n'*40ns + 30us )
189
: ms for 25000 40ns next ; ( n -- : wait for 'n' milliseconds )
190
: doNext r> r> ?dup if 1- >r @ >r exit then cell+ >r ; hidden
191
 
192
: uart? ( a1 a2 -- c -1 | 0 : generic uart input using registers 'a1' and 'a2'  )
193
        swap >r dup >r
194
        @ $0100 and 0=
195
        if
196
                $0400 r> ! r> @ $ff and [-1]
197
        else
198
                rdrop rdrop 0
199
        then ; hidden
200
 
201
: rx?  oUart iUart uart? ; hidden ( -- c -1 | 0 : read in a character of input from UART )
202
: ps2? oVT100 iVT100 uart? ; hidden ( -- c -1 | 0 : PS/2 version of rx? )
203
 
204
: uart! ( c a1 a2 -- : write to a UART, specified with registers a1, a2 )
205
        >r >r
206
        begin r@ @ $1000 and 0= until rdrop ( Wait until TX FIFO is not full )
207
        $2000 or r> ! ; hidden
208
 
209
: tx!  oUart iUart uart! ; hidden
210
: vga! oVT100 iVT100 uart! ; hidden ( n a -- : output character to VT100 display )
211
 
212
: um+ ( w w -- w carry )
213
        over over + >r
214
        r@ 0 < invert >r
215
        over over and
216
 
217
        or 0 < r> and invert 1 +
218
        r> swap ;
219
 
220
: rp! ( n -- , R: ??? -- ??? : set the return stack pointer )
221
        r> swap begin dup rp@ = 0= while rdrop repeat drop >r ; hidden
222
 
223
: rpick ( n -- u, R: un ... u0 )
224
        rdrop
225
        dup
226
        begin dup while rdrop 1- repeat drop r@ swap
227
        begin dup while rup   1- repeat drop
228
        rup ;
229
 
230
( With the built in words defined in the assembler, and the words
231
defined so far, all of the primitive words needed by eForth should
232
be available. "doList" and "doLit" do not need to be implemented as
233
they can implemented in terms of instructions )
234
 
235
( ======================== Forth Kernel ===================== )
236
 
237
( ======================== Word Set ========================= )
238
 
239
: 2! ( d a -- ) tuck ! cell+ ! ;          ( n n a -- )
240
: 2@ ( a -- d ) dup cell+ @ swap @ ;      ( a -- n n )
241
: here cp @ ;                             ( -- a )
242
: source #tib 2@ ;                        ( -- a u )
243
: source-id _id @ ;                       ( -- 0 | -1 )
244
: pad here pad-length + ;                 ( -- a )
245
: @execute @ ?dup if >r then ;            ( cfa -- )
246
: 3drop drop 2drop ; hidden               ( n n n -- )
247
: bl =bl ;                                ( -- c )
248
: within over - >r - r> u< ;              ( u lo hi -- f )
249
: dnegate invert >r invert 1 um+ r> + ;   ( d -- d )
250
: abs dup 0< if negate exit then ;        ( n -- u )
251
: count  dup 1+ swap c@ ;                 ( cs -- b u )
252
: rot >r swap r> swap ;                   ( n1 n2 n3 -- n2 n3 n1 )
253
: -rot swap >r swap r> ;                  ( n1 n2 n3 -- n3 n1 n2 )
254
: min over over < if drop exit else nip exit then ; ( n n -- n )
255
: max over over > if drop exit else nip exit then ; ( n n -- n )
256
: >char $7f and dup 127 =bl within if drop [char] _ then ; ( c -- c )
257
: tib #tib cell+ @ ; hidden               ( -- a )
258
: echo _echo @execute ; hidden            ( c -- )
259
: key? _key? @execute ;                   ( -- c -1 | 0 )
260
: key begin key? until ;                  ( -- c )
261
: allot cp +! ;                           ( u -- )
262
: /string over min rot over + -rot - ;    ( b u1 u2 -- b u : advance a string u2 characters )
263
: last context @ @ ;                      ( -- pwd )
264
: emit _emit @execute ;                   ( c -- : write out a char )
265
: toggle over @ xor swap ! ; hidden       ( a u -- : xor value at addr with u )
266
: cr =cr emit =lf emit ;                  ( -- )
267
: space =bl emit ;                        ( -- )
268
: pick ?dup if swap >r 1- pick r> swap exit then dup ; ( @bug does not work for high stack depths - mashes the return stack )
269
: ndrop for aft drop then next ; hidden   ( n1 ... nu u -- )
270
: type begin dup while swap count emit swap 1- repeat 2drop ; ( b u -- : print a string )
271
: $type begin dup while swap count >char emit swap 1- repeat 2drop ; hidden ( b u -- : print a string )
272
: print count type ; hidden               ( b -- )
273
: nuf? ( -- f ) key =cr = ;  ( -- f : true if 'cr' pressed, blocking )
274
: decimal? 48 58 within ; hidden            ( c -- f : decimal char? )
275
: lowercase? [char] a [char] { within ; hidden  ( c -- f : is character lower case? )
276
: uppercase? [char] A [char] [ within ; hidden  ( c -- f : is character upper case? )
277
\ : >upper dup lowercase? if =bl xor then ; ( c -- c : convert to upper case )
278
: >lower dup uppercase? if =bl xor exit then ; hidden ( c -- c : convert to lower case )
279
: nchars swap 0 max for aft dup emit then next drop ; hidden ( +n c -- : emit c n times  )
280
: spaces =bl nchars ;                     ( +n -- )
281
: cmove for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ; ( b b u -- )
282
: fill swap for swap aft 2dup c! 1+ then next 2drop ; ( b u c -- )
283
: substitute dup @ >r ! r> ; hidden ( u a -- u : substitute value at address )
284
: switch 2dup @ >r @ swap ! r> swap ! ; hidden ( a a -- : swap contents )
285
: aligned dup 1 and if 1+ exit then ;          ( b -- a )
286
: align cp @ aligned cp ! ;               ( -- )
287
 
288
: catch  ( xt -- exception# | 0 : return addr on stack )
289
        sp@ >r        ( xt : save data stack depth )
290
        handler @ >r  ( xt : and previous handler )
291
        rp@ handler ! ( xt : set current handler )
292
        execute       (      execute returns if no throw )
293
        r> handler !  (      restore previous handler )
294
        r> drop       (      discard saved stack ptr )
295
 
296
 
297
: throw  ( ??? exception# -- ??? exception# )
298
        ?dup if ( exc# \ 0 throw is no-op )
299
                handler @ rp! ( exc# : restore prev return stack )
300
                r> handler !  ( exc# : restore prev handler )
301
                r> swap >r    ( saved-sp : exc# on return stack )
302
                sp@ swap - ndrop r>   ( exc# : restore stack )
303
                ( return to the caller of catch because return )
304
                ( stack is restored to the state that existed )
305
                ( when catch began execution )
306
        then ;
307
 
308
: -throw negate throw ; hidden ( space saving measure )
309
 
310
( By making all the Forth primitives call '?depth' it should be possible
311
to get quite good coverage for stack checking, if not there is only a few
312
choice words that need depth checking to get quite a large coverage )
313
: ?depth dup 0= if drop exit then sp@ 1- u> if 4 -throw exit then ; hidden ( u -- )
314
: 1depth 1 ?depth ; hidden
315
\ : 2depth 2 ?depth ; hidden
316
\ : 3depth 3 ?depth ; hidden
317
 
318
: um/mod ( ud u -- ur uq )
319
        ?dup 0= if 10 -throw exit then
320
        2dup u<
321
        if negate 15
322
                for >r dup um+ >r >r dup um+ r> + dup
323
                        r> r@ swap >r um+ r> or
324
                        if >r drop 1 + r> else drop then r>
325
                next
326
                drop swap exit
327
        then drop 2drop  [-1] dup ;
328
 
329
: m/mod ( d n -- r q ) \ floored division
330
        dup 0< dup >r
331
        if
332
                negate >r dnegate r>
333
        then
334
        >r dup 0< if r@ + then r> um/mod r>
335
        if swap negate swap exit then ;
336
 
337
: um* ( u u -- ud )
338
 
339
        for dup um+ >r >r dup um+ r> + r>
340
                if >r over um+ r> + then
341
        next rot drop ;
342
 
343
: /mod  over 0< swap m/mod ; ( n n -- r q )
344
: mod  /mod drop ;           ( n n -- r )
345
: /    /mod nip ;            ( n n -- q )
346
: *    um* drop ;            ( n n -- n )
347
: decimal 10 base ! ;                       ( -- )
348
: hex     16 base ! ;                       ( -- )
349
: radix base @ dup 2 - 34 u> if hex 40 -throw exit then ; hidden
350
: digit  9 over < 7 and + 48 + ; hidden      ( u -- c )
351
: extract  0 swap um/mod swap ; hidden       ( n base -- n c )
352
: ?hold hld @ cp @ u< if 17 -throw exit then ; hidden ( -- )
353
: hold  hld @ 1- dup hld ! ?hold c! ;        ( c -- )
354
: sign  0< if [char] - hold then ;           ( n -- )
355
: #>  drop hld @ pad over - ;                ( w -- b u )
356
: #  1depth radix extract digit hold ;       ( u -- u )
357
: #s begin # dup while repeat ;              ( u -- 0 )
358
: <#  pad hld ! ;                            ( -- )
359
: str dup >r abs <# #s r> sign #> ; hidden   ( n -- b u : convert a signed integer to a numeric string )
360
\ :  .r >r str r> over - spaces type ;       ( n n : print n, right justified by +n )
361
: u.r >r <# #s #> r> over - spaces type ;    ( u +n -- : print u right justified by +n)
362
: u.  <# #s #> space type ;                  ( u -- : print unsigned number )
363
:  .  radix 10 xor if u. exit then str space type ; ( n -- print space, signed number )
364
: ? @ . ;                                    ( a -- : display the contents in a memory cell )
365
 
366
: pack$ ( b u a -- a ) \ null fill
367
        aligned dup >r over
368
        dup 0 cell um/mod ( use -2 and instead of um/mod? ) drop
369
        - over +  0 swap !  2dup c!  1+ swap cmove  r> ;
370
 
371
: ^h ( bot eot cur c -- bot eot cur )
372
        >r over r@ < dup
373
        if
374
                =bs dup echo =bl echo echo
375
        then r> + ; hidden
376
 
377
: tap dup echo over c! 1+ ; hidden ( bot eot cur c -- bot eot cur )
378
 
379
: ktap ( bot eot cur c -- bot eot cur )
380
        dup =cr xor
381
        if =bs xor
382
                if =bl tap else ^h then
383
                exit
384
        then drop nip dup ; hidden
385
 
386
: accept ( b u -- b u )
387
        over + over
388
        begin
389
                2dup xor
390
        while
391
                key  dup =bl - 95 u<
392
                if tap else _tap @execute then
393
        repeat drop over - ;
394
 
395
: expect ( b u -- ) _expect @execute span ! drop ;
396
: query tib tib-length _expect @execute #tib !  drop 0 >in ! ; ( -- )
397
 
398
: =string ( a1 u2 a1 u2 -- f : string equality )
399
        >r swap r> ( a1 a2 u1 u2 )
400
        over xor if 3drop  0 exit then
401
        for ( a1 a2 )
402
                aft
403
                        count >r swap count r> xor
404
                        if 2drop rdrop 0 exit then
405
                then
406
        next 2drop [-1] ;
407
 
408
: address $3fff and ; hidden ( a -- a : mask off address bits )
409
: nfa address cell+ ; hidden ( pwd -- nfa : move to name field address)
410
: cfa nfa dup count nip + cell + $fffe and ; hidden ( pwd -- cfa : move to code field address )
411
: .id nfa print ; hidden ( pwd -- : print out a word )
412
 
413
: logical 0= 0= ; hidden ( n -- f )
414
: immediate? @ $4000 and logical ; hidden ( pwd -- f : is immediate? )
415
: inline?    @ 0x8000 and logical ; hidden ( pwd -- f : is inline? )
416
 
417
: search ( a a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )
418
        swap >r
419
        begin
420
                dup
421
        while
422
                dup nfa count r@ count =string
423
                if ( found! )
424
                        dup immediate? if 1 else [-1] then
425
                        rdrop exit
426
                then
427
                @ address
428
        repeat
429
        drop r> 0 ; hidden
430
 
431
: find ( a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )
432
        >r
433
        context
434
        begin
435
                dup @
436
        while
437
                dup @ @ r@ swap search ?dup if rot rdrop drop exit else drop then
438
                cell+
439
        repeat drop r> 0 ;
440
 
441
: numeric? ( char -- n|-1 : convert character in 0-9 a-z range to number )
442
        >lower
443
        dup lowercase? if 87 - exit then ( 97 = 'a', +10 as 'a' == 10 )
444
        dup decimal?   if 48 - exit then ( 48 = '0' )
445
        drop [-1] ; hidden
446
 
447
: digit? >lower numeric? base @ u< ; hidden ( c -- f : is char a digit given base )
448
 
449
: do-number ( n b u -- n b u : convert string )
450
        begin
451
                ( get next character )
452
                2dup >r >r drop c@ dup digit? ( n char bool, R: b u )
453
                if   ( n char )
454
                        swap base @ * swap numeric? + ( accumulate number )
455
                else ( n char )
456
                        drop
457
                        r> r> ( restore string )
458
                        exit
459
                then
460
                r> r> ( restore string )
461
                1 /string dup 0= ( advance string and test for end )
462
        until ; hidden
463
 
464
: >number ( n b u -- n b u : convert string )
465
        radix >r
466
        over c@ $2D = if 1 /string [-1] >r else 0 >r then ( -negative )
467
        over c@ $24 = if 1 /string hex then ( $hex )
468
        do-number
469
        r> if rot negate -rot then
470
        r> base ! ; hidden
471
 
472
: number? 0 -rot >number nip 0= ; ( b u -- n f : is number? )
473
 
474
: -trailing ( b u -- b u : remove trailing spaces )
475
        for
476
                aft =bl over r@ + c@ <
477
                        if r> 1+ exit then
478
                then
479
        next 0 ; hidden
480
 
481
: lookfor ( b u c -- b u : skip until _test succeeds )
482
        >r
483
        begin
484
                dup
485
        while
486
                over c@ r@ - r@ =bl = _test @execute if rdrop exit then
487
                1 /string
488
        repeat rdrop ; hidden
489
 
490
: skipper if 0> exit else 0<> exit then ; hidden    ( n f -- f )
491
: scanner skipper invert ; hidden         ( n f -- f )
492
: skip ' skipper _test ! lookfor ; hidden ( b u c -- u c )
493
: scan ' scanner _test ! lookfor ; hidden ( b u c -- u c )
494
 
495
: parser ( b u c -- b u delta )
496
        >r over r> swap >r >r
497
        r@ skip 2dup
498
        r> scan swap r> - >r - r> 1+ ; hidden
499
 
500
: parse >r tib >in @ + #tib @ >in @ - r> parser >in +! -trailing 0 max ; ( c -- b u ;  )
501
: ) ; immediate
502
: "(" 41 parse 2drop ; immediate
503
: .( 41 parse type ;
504
: "\" #tib @ >in ! ; immediate
505
: ?length dup word-length u> if 19 -throw exit then ; hidden
506
: word 1depth parse ?length here pack$ ;          ( c -- a ;  )
507
: token =bl word ; hidden
508
: char token count drop c@ ;               ( -- c;  )
509
: .s ( -- ) cr sp@ for aft r@ pick . then next .s-string print ;
510
: unused $4000 here - ; hidden
511
: .free unused u. ; hidden
512
: preset sp@ ndrop tib #tib cell+ ! 0 >in ! 0 _id ! ( console / io! ) ; hidden
513
: ] [-1] state ! ;
514
: [  0 state ! ; immediate
515
 
516
: .error ( n -- )
517
        abs dup 60 < loaded @ and
518
        if
519
                dup l/b / + 32 + _message @execute
520
        else
521
                negate . cr
522
        then ; hidden
523
 
524
: ?error ( n -- : perform actions on error )
525
        ?dup if
526
                [char] ? emit ( print error message )
527
                .error
528
                preset        ( reset machine )
529
                [             ( back into interpret mode )
530
                exit
531
        then ; hidden
532
 
533
: ?dictionary dup $3f00 u> if 8 -throw exit then ; hidden
534
: , here dup cell+ ?dictionary cp ! ! ; ( u -- )
535
: doLit 0x8000 or , ; hidden
536
: ?compile state @ 0= if 14 -throw exit then ; hidden ( fail if not compiling )
537
: literal ( n -- : write a literal into the dictionary )
538
        ?compile
539
        dup 0x8000 and ( n > $7fff ? )
540
        if
541
                invert doLit =invert , exit ( store inversion of n the invert it )
542
        else
543
                doLit exit ( turn into literal, write into dictionary )
544
        then ; immediate
545
 
546
: make-callable 2/ $4000 or ; hidden ( cfa -- instruction )
547
: compile, make-callable , ;         ( cfa -- : compile a code field address )
548
: $compile dup inline? if cfa @ , else cfa compile, then ; hidden ( pwd -- )
549
 
550
: interpret ( ??? a -- ??? : The command/compiler loop )
551
        find ?dup if
552
                state @
553
                if
554
                        0> if \ immediate
555
                                cfa execute exit
556
                        else
557
                                $compile exit
558
                        then
559
                else
560
                        drop cfa execute exit
561
                then
562
        else \ not a word
563
                dup count number? if
564
                        nip
565
                        state @ if literal exit then
566
                else
567
                        drop space print 13 -throw exit
568
                then
569
        then ;
570
 
571
: "immediate" last address $4000 toggle ;
572
: .ok state @ 0= if space OK print space then cr ;
573
: eval begin token dup count nip while interpret repeat drop _prompt @execute ; hidden
574
: quit quitLoop: preset [ begin query ' eval catch ?error again ;
575
 
576
: evaluate ( a u -- )
577
        _prompt @ >r  0 _prompt !
578
        _id     @ >r [-1] _id !
579
        >in     @ >r  0 >in !
580
        source >r >r
581
        #tib 2!
582
        ' eval catch
583
        r> r> #tib 2!
584
        r> >in !
585
        r> _id !
586
        r> _prompt !
587
        throw ;
588
 
589
: ccitt ( crc c -- crc : calculate polynomial $1021 AKA "x16 + x12 + x5 + 1" )
590
        over 256/ xor        ( crc x )
591
        dup  4  rshift xor   ( crc x )
592
        dup  5  lshift xor   ( crc x )
593
        dup  12 lshift xor   ( crc x )
594
        swap 8  lshift xor ; ( crc )
595
 
596
: crc ( b u -- u : calculate ccitt-ffff CRC )
597
        $ffff >r
598
        begin
599
                dup
600
        while
601
                over c@ r> swap ccitt >r 1 /string
602
        repeat 2drop r> ;
603
 
604
: random seed @ dup 15 lshift ccitt dup iTimerDin @ + seed ! ; ( -- u )
605
 
606
: 5u.r 5 u.r ; hidden
607
: dm+ 2/ for aft dup @ space 5u.r cell+ then next ; ( a u -- a )
608
: colon 58 emit ; hidden ( -- )
609
 
610
: dump ( a u -- )
611
        dump-width /
612
        for
613
                aft
614
                        cr dump-width 2dup
615
                        over 5u.r colon space
616
                        dm+ -rot
617
                        2 spaces $type
618
                then
619
        next drop ;
620
 
621
: CSI $1b emit [char] [ emit ; hidden
622
: 10u. base @ >r decimal <# #s #> type r> base ! ; hidden ( u -- )
623
: ansi swap CSI 10u. emit ; ( n c -- )
624
: at-xy CSI 10u. $3b emit 10u. [char] H emit ; ( x y -- )
625
: page 2 [char] J ansi 1 1 at-xy ; ( -- )
626
: sgr [char] m ansi ; ( -- )
627
 
628
( ==================== Extra Words =================================== )
629
 
630
\ : gcd gcdStart: dup if tuck mod branch gcdStart then drop ; ( u1 u2 -- u : greatest common divisor )
631
\ : lcm 2dup gcd / * ; ( u1 u2 -- u : lowest common multiple of u1 and u2 )
632
 
633
( ==================== Extra Words =================================== )
634
 
635
( ==================== Advanced I/O Control ========================== )
636
 
637
: segments! o7SegLED ! ;   ( u -- : display a number on the LED 7 segment display )
638
: led!      oLeds ! ;      ( u -- : write to LED lights )
639
: switches  iSwitches  @ ; ( -- u : get the state of the switches)
640
: timer!    oTimerCtrl ! ; ( u -- )
641
: timer     iTimerDin  @ ; ( -- u )
642
: input rx? if [-1] else ps2? then ; hidden ( -- c -1 | 0 : UART and PS/2 Input )
643
: output dup tx! vga! ; hidden ( c -- : write to UART and VGA display )
644
: printable? 32 127 within ; hidden ( c -- f )
645
: pace 11 emit ; hidden
646
: xio  ' accept _expect ! _tap ! _echo ! _prompt ! ; hidden
647
: file ' pace ' "drop" ' ktap xio ;
648
: star $2A emit ; hidden
649
: [conceal] dup 33 127 within if drop star else output then ; hidden
650
: conceal ' .ok ' [conceal] ' ktap xio ;
651
: hand ' .ok  '  emit  ' ktap xio ; hidden
652
: console ' rx? _key? ! ' tx! _emit ! hand ;
653
: interactive ' input _key? ! ' output _emit ! hand ;
654
: io! $8FFF oTimerCtrl ! interactive 0 ien oIrcMask ! ; ( -- : initialize I/O )
655
: ver $666 ;
656
: hi io! ( save ) hex cr hi-string print ver <# # # 46 hold # #> type cr here . .free cr [ ;
657
 
658
( ==================== Advanced I/O Control ========================== )
659
 
660
( ==================== Control Structures ============================ )
661
 
662
( The following section implements the control structures and high level
663
words used for interpreting Forth. As much error checking is done
664
as possible so the Forth environment is easy to use. )
665
 
666
( @note The word ';' currently throws an exception when it is ran in compile
667
mode, this is so a Forth block can have it's first word as ';' to stop
668
thru from executing it - thru should then ignore it, but it does not at the
669
moment. Another useful word would be one that lists the currently loaded
670
block then stops evaluation of the loaded block, this would be useful for
671
displaying block files as they are read in )
672
 
673
 
674
: !csp sp@ csp ! ; hidden
675
: ?csp sp@ csp @ xor if 22 -throw exit then ; hidden
676
: +csp csp 1+! ; hidden
677
: -csp csp 1-! ; hidden
678
: ?unique dup last search if drop redefined print cr exit else drop exit then ; hidden ( a -- a )
679
: ?nul count 0= if 16 -throw exit then 1- ; hidden ( b -- : check for zero length strings )
680
: find-cfa token find if cfa exit else 13 -throw exit then ; hidden
681
: "'" find-cfa state @ if literal exit then ; immediate
682
: [compile] ?compile find-cfa compile, ; immediate ( -- ;  )
683
: compile  r> dup @ , cell+ >r ; ( -- : Compile next compiled word NB. Works for words, instructions, and numbers below $8000 )
684
: "[char]" ?compile char literal ; immediate ( --,  : )
685
: ?quit state @ 0= if 56 -throw exit then ; hidden
686
: ";" ?quit ( ?compile ) +csp ?csp context @ ! =exit , ( save )  [ ; immediate
687
: ":" align ( save ) !csp here dup last-def ! last address ,  token ?nul ?unique count + aligned cp ! ] ;
688
: jumpz, 2/ $2000 or , ; hidden
689
: jump, 2/ ( $0000 or ) , ; hidden
690
: "begin" ?compile here -csp ; immediate
691
: "until" ?compile jumpz, +csp ; immediate
692
: "again" ?compile jump, +csp ; immediate
693
: "if" ?compile here 0 jumpz, -csp ; immediate
694
: doThen  here 2/ over @ or swap ! ; hidden
695
: "then" ?compile doThen +csp ; immediate
696
: "else" ?compile here 0 jump, swap doThen ; immediate
697
: "while" ?compile call "if" ; immediate
698
: "repeat" ?compile swap call "again" call "then" ; immediate
699
: recurse ?compile last-def @ address cfa compile, ; immediate
700
\ : tail ?compile last-def @ address cfa jump, ; immediate
701
: create call ":" compile doVar context @ ! [ ;
702
: doDoes r> 2/ here 2/ last-def @ address cfa dup cell+ doLit ! , ; hidden
703
: does> ?compile compile doDoes nop ; immediate
704
: "variable" create 0 , ;
705
: ":noname" here ] !csp ;
706
: "for" ?compile =>r , here -csp ; immediate
707
: "next" ?compile compile doNext , +csp ; immediate
708
: "aft" ?compile drop here 0 jump, call "begin" swap ; immediate
709
: doer create =exit last-def @ cfa ! =exit ,  ;
710
: make
711
        find-cfa find-cfa make-callable
712
        state @
713
        if
714
                literal literal compile ! exit
715
        else
716
                swap ! exit
717
        then ; immediate
718
 
719
: "constant" create ' doConst make-callable here cell- ! , ;
720
 
721
\ : [leave] rdrop rdrop rdrop ; hidden
722
\ : leave ?compile compile [leave] ; immediate
723
\ : [do] r> dup >r swap rot >r >r cell+ >r ; hidden
724
\ : do ?compile compile [do] 0 , here ; immediate
725
\ : [loop]
726
\     r> r> 1+ r> 2dup <> if >r >r @ >r exit then
727
\     >r 1- >r cell+ >r ; hidden
728
\ : [unloop] r> rdrop rdrop rdrop >r ; hidden
729
\ : loop compile [loop] dup , compile [unloop] cell- here 2/ swap ! ; immediate
730
\ : [i] r> r> tuck >r >r ; hidden
731
\ : i ?compile compile [i] ; immediate
732
\ : [?do]
733
\    2dup <> if r> dup >r swap rot >r >r cell+ >r exit then 2drop exit ; hidden
734
\ : ?do  ?compile compile [?do] 0 , here ; immediate
735
 
736
 
737
\ : back here cell- @ ; hidden ( a -- : get previous cell )
738
\ : call? back $e000 and $4000 = ; hidden ( -- f : is call )
739
\ : merge? back dup $e000 and $6000 = swap $1c and 0= and ; hidden ( -- f : safe to merge exit )
740
\ : redo here cell- ! ; hidden
741
\ : merge back $1c or redo ; hidden
742
\ : tail-call back $1fff and redo ; hidden ( -- : turn previously compiled call into tail call )
743
\ : compile-exit call? if tail-call else merge? if merge else =exit , then then ; hidden
744
\ : compile-exit call? if tail-call else merge? if merge then then =exit , ; hidden
745
\ : "exit" compile-exit ; immediate
746
\ : "exit" =exit , ; immediate
747
 
748
( Error recovery can be quite difficult when sending Forth large programs
749
over a serial port. One of the problems is if an error occurs in between a
750
colon definition the Forth interpreter would signal an error and go back into
751
command mode, subsequently words which are meant to be compiled are instead
752
executed which can cause the system to become unstable. There are potential
753
ways of getting around this:
754
 
755
1. The sender stops upon encountering an error
756
2. The receiver discards all input until the end of the file [if it can work
757
out when that is].
758
3. A third interpreter state in which words are discarded until a closing
759
';' is encountered.
760
 
761
To keep things simple non of these methods are used, but they highlight ways
762
in which the problem could be solved. )
763
 
764
( ==================== Control Structures ============================ )
765
 
766
( ==================== Strings ======================================= )
767
 
768
: do$ r> r@ r> count + aligned >r swap >r ; hidden ( -- a )
769
: $"| do$ nop ; hidden                             ( -- a : do string NB. nop needed to fool optimizer )
770
: ."| do$ print ; hidden                           ( -- : print string )
771
: $,' 34 word count + aligned cp ! ; hidden        ( -- )
772
: $"  ?compile compile $"| $,' ; immediate         ( -- ;  )
773
: ."  ?compile compile ."| $,' ; immediate         ( -- ;  )
774
\ : abort 0 rp! quit ;                               ( --, R: ??? --- ??? : Abort! )
775
\ : abort" ?compile ." compile abort ; immediate
776
 
777
( ==================== Strings ======================================= )
778
 
779
( ==================== Block Word Set ================================ )
780
 
781
: updated? block-dirty @ ; hidden      ( -- f )
782
: update [-1] block-dirty ! ;          ( -- )
783
: +block blk @ + ;                     ( n -- k )
784
: clean-buffers 0 block-dirty ! ; hidden
785
: empty-buffers clean-buffers block-invalid blk ! ;  ( -- )
786
: save-buffers                         ( -- )
787
        blk @ block-invalid = updated? 0= or if exit then
788
        block-buffer b/buf blk @ _bsave @execute throw
789
        clean-buffers ;
790
: flush save-buffers empty-buffers ;
791
 
792
: block ( k -- a )
793
        1depth
794
        _binvalid @execute                         ( check validity of block number )
795
        dup blk @ = if drop block-buffer exit then ( block already loaded )
796
        flush
797
        dup >r block-buffer b/buf r> _bload @execute throw
798
        blk !
799
        block-buffer ;
800
 
801
: line swap block swap c/l * + c/l ; hidden ( k u -- a u )
802
: loadline line evaluate ; hidden ( k u -- )
803
: load 0 l/b 1- for 2dup >r >r loadline r> r> 1+ next 2drop ;
804
: pipe 124 emit ; hidden
805
: .line line -trailing $type ; hidden
806
: .border border @ if 3 spaces c/l 45 nchars cr exit then ; hidden
807
: #line border @ if dup 2 u.r exit then ; hidden ( u -- u : print line number )
808
: ?pipe border @ if pipe exit then ; hidden
809
: ?page border @ if page exit then ; hidden
810
( @todo 'thru' should catch -56, or QUIT, and continue with next block )
811
\ : ?load ' load catch dup -56 <> if throw then drop ;
812
: thru over - for dup load 1+ next drop ; ( k1 k2 -- )
813
: blank =bl fill ;
814
: message l/b extract .line cr ; ( u -- )
815
: list
816
        ?page
817
        cr
818
        .border
819
 
820
                dup l/b <
821
        while
822
                2dup #line ?pipe line $type ?pipe cr 1+
823
        repeat .border 2drop ;
824
 
825
: index ( k1 k2 -- : show titles for block k1 to k2 )
826
        over - cr
827
        for
828
                dup 5u.r space pipe space dup  0 .line cr 1+
829
        next drop ;
830
 
831
 
832
( all words before this are now in the forth vocabulary, it is also set
833
later on )
834
.set forth-wordlist $pwd
835
 
836
( ==================== Block Word Set ================================ )
837
 
838
( ==================== See =========================================== )
839
 
840
( @warning This disassembler is experimental, and liable not
841
to work / break everything it touches )
842
 
843
: bcounter! bcount @ 0= if 2/ over swap -  bcount ! else drop then ; hidden ( u a -- u )
844
: -bcount   bcount @ if bcount 1-! then ; hidden ( -- )
845
: abits $1fff and ; hidden
846
 
847
: validate ( cfa pwd -- nfa | 0 )
848
        tuck cfa <> if drop 0 else nfa then ; hidden
849
 
850
( @todo Do this for every vocabulary loaded )
851
: name ( cfa -- nfa )
852
        abits 2*
853
        >r
854
        last address
855
        begin
856
                dup
857
        while
858
                address dup r@ swap dup @ address swap within ( simplify? )
859
                if @ address r> swap validate exit then
860
                address @
861
        repeat rdrop ; hidden
862
 
863
: .name name ?dup 0= if see.unknown then print ; hidden
864
: mask-off 2dup and = ; hidden ( u u -- u f )
865
 
866
i.end2t: 2*
867
i.end:   5u.r rdrop exit
868
: i.print print abits ; hidden
869
 
870
( @note A recursive version of 'see' that decompiled no-name words would complicate
871
things, the 'decompiler' word could be called manually on an address if desired )
872
: instruction ( decode instruction )
873
        over >r
874
        0x8000 mask-off if see.lit     print $7fff and      branch i.end then
875
        $6000  mask-off if see.alu     i.print              branch i.end then
876
        $4000  mask-off if see.call    i.print dup 2*       5u.r rdrop space .name exit then
877
        $2000  mask-off if see.0branch i.print r@ bcounter! branch i.end2t then
878
                           see.branch  i.print r@ bcounter! branch i.end2t ; hidden
879
 
880
: continue? ( u a -- f : determine whether to continue decompilation  )
881
        bcount @ if 2drop [-1] exit then
882
        over $e000 and 0= if u> exit else drop then
883
        dup ' doVar make-callable = if drop 0 exit then ( print next address ? )
884
        =exit and =exit <> ; hidden
885
 
886
: decompile ( a -- a : decompile a single instruction )
887
        dup 5u.r colon dup @ 5u.r space
888
        dup @ instruction
889
        dup @ ' doNext make-callable = if cell+ dup ? then
890
        cr
891
        cell+ ; hidden
892
 
893
: decompiler ( a -- : decompile starting at address )
894
 
895
        dup 2/ >r
896
        begin dup @ r@ continue? while decompile -bcount ( nuf? ) repeat decompile rdrop
897
        drop ; hidden
898
 
899
: see ( --,  : decompile a word )
900
        token find 0= if 13 -throw exit then
901
        cr colon space dup .id space
902
        dup inline?    if see.inline    print then
903
        dup immediate? if see.immediate print then
904
        cr
905
        cfa decompiler space 59 emit cr ;
906
 
907
\ : see
908
\       token find 0= if 13 -throw exit then
909
\       begin nuf? while
910
\               dup @ dup $4000 and $4000
911
\               = if space .name else . then cell+
912
\       repeat drop ;
913
 
914
.set forth-wordlist $pwd
915
( ==================== See =========================================== )
916
 
917
( ==================== Miscellaneous ================================= )
918
 
919
\ Testing for the interrupt mechanism, interrupts do not
920
\ work correctly at the moment
921
 
922
( @bug Interrupts work in simulation but not in hardware )
923
variable #irq 0
924
 
925
: doIrq
926
 
927
        switches led!
928
        #irq 1+!
929
        #irq @ segments!
930
        1 ien drop ; hidden
931
 
932
irqTask: doIrq nop exit
933
 
934
 \ doIrq nop exit
935
 
936
.set 2 irqTask
937
.set 4 irqTask
938
.set 6 irqTask
939
.set 8 irqTask
940
.set 10 irqTask
941
.set 12 irqTask
942
.set 14 irqTask
943
 
944
: irq $0040 oIrcMask ! $efff oTimerCtrl !  1 ien drop ;
945
 
946
\ : irqTest2
947
\       $0080 oIrcMask !
948
\       1 ien drop ; )
949
 
950
( ==================== Miscellaneous ================================= )
951
 
952
( ==================== Vocabulary Words ============================== )
953
 
954
: find-empty-cell begin dup @ while cell+ repeat ; hidden ( a -- a )
955
 
956
: get-order ( -- widn ... wid1 n : get the current search order )
957
        context
958
        find-empty-cell
959
        dup cell- swap
960
        context - 2/ dup >r 1- dup 0< if 50 -throw exit then
961
        for aft dup @ swap cell- then next @ r> ;
962
 
963
: set-order ( widn ... wid1 n -- : set the current search order )
964
        dup [-1]  = if drop forth-wordlist 1 set-order exit then
965
        dup #vocs > if 49 -throw exit then
966
        context swap for aft tuck ! cell+ then next 0 swap ! ;
967
 
968
\ : root  -1 set-order ; \ should contain set-order, forth-wordlist, forth, and words
969
: forth -1 set-order ;
970
: flash get-order flash-voc swap 1+ set-order ;
971
 
972
: .words space begin dup while dup .id space @ address repeat drop cr ; hidden
973
: words get-order begin ?dup while swap dup cr u. colon @ .words 1- repeat ;
974
\ : vocs get-order begin ?dup while swap dup . space cell- 2/ .name 1- repeat cr ;
975
 
976
.set forth-wordlist $pwd
977
 
978
( ==================== Vocabulary Words ============================== )
979
 
980
( ==================== Memory Interface ============================== )
981
 
982
( @note The manual for the Nexys 3 board specifies that there is a PCM
983
memory device called the NP8P128A13T1760E, this is a device behaves like
984
normal flash with the addition that individual cells can be written to
985
without first erasing the block, this is accomplished with an extension
986
to the Common Flash Interface that most flash devices support. However,
987
there are boards the PC28F128P33BF60 on in lieu of this, which is a
988
normal flash device without the "bit alterable write" extension. Normal
989
flash memory works by erasing a block of data, setting all bits set,
990
writing the memory works by masking in a value, bits can be cleared in
991
a memory cell but not set, the can only be set by erasing a block.
992
 
993
The Nexys 3 has three memory devices, two of which are accessed over
994
a parallel interface. They share the same data and address bus, and
995
can be selected with a chip select. The signals to be controlled
996
are:
997
 
998
        +-----+-------------------------+
999
        | Bit | Description             |
1000
        |-----|-------------------------|
1001
        | 0-9 | Upper Memory Bits       |
1002
        | 10  | Flash chip select       |
1003
        | 11  | SRAM chip select        |
1004
        | 12  | Memory Wait [not used]  |
1005
        | 13  | Flash Reset             |
1006
        | 14  | Output Enable           |
1007
        | 15  | Write Enable            |
1008
        +-----+-------------------------+
1009
 
1010
The usage of the output enable and write enable are mutually exclusive,
1011
as are both of the chip selects.
1012
 
1013
)
1014
 
1015
.set context forth-wordlist
1016
.set forth-wordlist $pwd
1017
.pwd 0
1018
 
1019
constant memory-upper-mask  $1ff hidden
1020
variable memory-upper       0    ( upper bits of external memory address )
1021
location memory-select      0    ( SRAM/Flash select SRAM = 0, Flash = 1 )
1022
 
1023
: mcontrol! ( u -- : write to memory control register )
1024
        $f3ff and
1025
        memory-select @ if $400 else $800 then or  ( select correct memory device )
1026
        memory-upper-mask invert    and            ( mask off control bits )
1027
        memory-upper @ memory-upper-mask and or         ( or in higher address bits )
1028
        oMemControl ! ; hidden            ( and finally write in control )
1029
 
1030
: m! ( n a -- : write to non-volatile memory )
1031
        oMemAddrLow !
1032
        oMemDout !
1033
        5 40ns
1034
        0x8000 mcontrol!
1035
        5 40ns
1036
        $0000 mcontrol! ;
1037
 
1038
: m@ ( a -- n : read from non-volatile memory )
1039
        oMemAddrLow !
1040
        $4000 mcontrol! ( read enable mode )
1041
        5 40ns
1042
        iMemDin @        ( get input )
1043
        $0000 mcontrol! ;
1044
 
1045
\ : memory-dump ( a u -- : dump non-volatile memory )
1046
\       cr
1047
\       begin
1048
\               dup
1049
\       while
1050
\               over 5u.r 40 emit over m@ 4 u.r 41 emit over 1+ $7 and 0= if cr then
1051
\               1 /string
1052
\       repeat 2drop cr ;
1053
 
1054
: sram 0 memory-select ! ;
1055
: nvram [-1] memory-select ! ; hidden
1056
: block-mode 0 memory-upper substitute ; hidden ( -- hi )
1057
: flash-reset ( -- : reset non-volatile memory )
1058
        $2000 mcontrol!
1059
        5 40ns
1060
        $0000 mcontrol! ; hidden
1061
: flash! dup >r m! r> m! ; hidden ( u u a )
1062
: flash-status nvram $70 0 m! 0 m@ ( dup $2a and if -34 -throw exit then ) ; ( -- status )
1063
: flash-read   $ff 0 m! ;      ( -- )
1064
: flash-setup  memory-select @ 0= if flush then nvram flash-reset block-mode drop 20 ms ;
1065
: flash-wait begin flash-status $80 and until ; hidden
1066
: flash-clear $50 0 m! ; ( -- clear status )
1067
: flash-write $40 swap flash! flash-wait ; ( u a -- )
1068
: flash-unlock block-mode >r $d0 swap $60 swap flash! r> memory-upper ! ; ( ba -- )
1069
\ : flash-lock block-mode >r $01 swap $60 swap flash! r> memory-upper ! ; ( ba -- )
1070
\ : flash-lock-down block-mode >r $2f swap $60 swap flash! r> memory-upper ! ; ( ba -- )
1071
: flash-erase block-mode >r flash-clear $d0 swap $20 swap flash! flash-wait r> memory-upper ! ; ( ba -- )
1072
: flash-query $98 0 m! ; ( -- : query mode )
1073
\ : flash-read-id   $90 0 m! ; ( -- read id mode : does the same as flash-query on the PC28F128P33BF60 )
1074
 
1075
: flash->sram ( a a : transfer flash memory cell to SRAM )
1076
        [-1] memory-select ! flash-clear flash-read
1077
        m@ 0 memory-select ! swap m! ; hidden
1078
 
1079
: transfer ( a a u -- : transfer memory block from Flash to SRAM )
1080
        ?dup 0= if 2drop exit then
1081
        1-
1082
        for
1083
                2dup
1084
                flash->sram
1085
                cell+ swap cell+ swap
1086
        next 2drop ;
1087
.set flash-voc $pwd
1088
 
1089
: minvalid ( k -- k : is 'k' a valid block number, throw on error )
1090
        dup block-invalid = if 35 -throw exit then ; hidden
1091
 
1092
: c>m swap @ swap m! ; hidden      ( a a --  )
1093
: m>c m@ swap ! ; hidden ( a a -- )
1094
 
1095
: mblock ( a u k -- f )
1096
        minvalid
1097
        b/buf um* memory-upper ! >r
1098
        begin
1099
                dup
1100
        while
1101
                over r@ _blockop @execute r> cell+ >r
1102
                cell /string
1103
        repeat
1104
        rdrop 2drop 0 ; hidden
1105
 
1106
: memory-save ' c>m _blockop ! mblock ; hidden
1107
: memory-load ' m>c _blockop ! mblock ; hidden
1108
 
1109
( ==================== Memory Interface ============================== )
1110
 
1111
( ==================== Startup Code ================================== )
1112
 
1113
: .failed failed print ; hidden
1114
: boot ( -- )
1115
 
1116
 
1117
 
1118
        else
1119
                1 -throw exit
1120
        then ; hidden
1121
 
1122
start:
1123
.set entry start
1124
        _boot @execute  ( _boot contains zero by default, does nothing )
1125
        hex io! [
1126
        \ irq
1127
        hi
1128
        cpu-id segments!
1129
        loading-string print
1130
        ' boot catch if .failed else .ok then
1131
        \ loaded @ if 1 list then
1132
        \ login 0 load 1 list
1133
        branch quitLoop ( jump to main interpreter loop if _boot returned )
1134
 
1135
( ==================== Startup Code ================================== )
1136
 
1137
.set cp  $pc
1138
 
1139
.set _key?     input       ( execution vector of ?key,   default to input. )
1140
.set _emit     output      ( execution vector of emit,   default to output )
1141
.set _expect   accept      ( execution vector of expect, default to 'accept'. )
1142
.set _tap      ktap        ( execution vector of tap,    default the ktap. )
1143
.set _echo     output      ( execution vector of echo,   default to output. )
1144
.set _prompt   .ok         ( execution vector of prompt, default to '.ok'. )
1145
.set _boot     0           ( @execute does nothing if zero )
1146
.set _bload    memory-load ( execution vector of _bload, used in block )
1147
.set _bsave    memory-save ( execution vector of _bsave, used in block )
1148
.set _binvalid minvalid    ( execution vector of _invalid, used in block )
1149
.set _message  message     ( execution vector of _message, used in ?error )

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.