aboutsummaryrefslogtreecommitdiff
path: root/forth/core.fs
blob: 511288d895e948685a71245db0751da44dc9b786 (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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
\ Some extra core words

-core
marker -core
hex ram

\ Interpret a string. The string must be in ram
: evaluate ( caddr n -- )
  'source 2@ >r >r >in @ >r
  interpret
  r> >in ! r> r> 'source 2!
;

: forget ( --- name )
  bl word latest @ (f) ?abort?
  c>n 2- dup @ ?abort?
  dup flash dp ! @ latest ! ram
;

 ( addr n c -- ) \ fill addr to addr+n with c
: fill rot !p>r swap for dup pc! p+ next r>p drop ;

\  addr n --
: erase  0 fill ;

\ addr n --
: blanks bl fill ;

\ x -- 0 | x x
: ?dup dup if inline dup then ;

\ nfa -- flag
: in? c@ $40 and ;

\ addr -- addr+1 n 
: count c@+ ;

\ MCU with eeprom
: .free
  cr ." Flash:" flash hi here - u. ." bytes"
  cr ." Eeprom:" eeprom hi here - u. ." bytes"
  cr ." Ram:" ram hi here - u. ." bytes"
;

\ xu ... x0 u -- xu ... x0 xu
: pick 2* sp@ + @ ;

-see 
marker -see
hex ram
: *@ dup @ ;
: u.4 4 u.r ;
: *@+ dup cell+ @ u.4 ;
: 5sp 5 spaces ;
: @braddr ( addr -- addr xt-addr )
    *@ fff and dup 800 and 
    if f800 or then 2* over +  cell+ ;
: @xtaddr ( addr -- addr xt-addr )
  dup cell+ @ xa> ;
: .rjmp ( addr -- addr+2 ) @braddr u.4 cell+ ;
: .br  ( addr -- addr+2 )
     *@ 3 rshift 7f and dup 40 and 
     if ff80 or then 2* over + cell+ u.4 cell+ ;
: .reg ( addr -- addr ) 
   dup @ 4 rshift 1f and ." r" decimal 2 u.r hex cell+ ;
: .ldi ( addr -- addr )
  *@ dup 4 rshift dup 000f and 0010 + 
  ." r" decimal 2 u.r hex
  00f0 and swap 000f and + 2 u.r cell+ ;
: ?call ( addr -- addr f ) *@ fe0e and 940e - ;
: ?ret ( addr -- addr f ) *@ 9508 - ;
: ?rcall ( addr -- addr f ) *@ f000 and d000 - ;
: ?jmp  ( addr -- addr f ) *@ fe0e and 940c - ;
: ?rjmp ( addr -- addr f ) *@ f000 and c000 - ;
: ?breq ( addr --  addr f ) *@ fc07 and f001 - ;
: ?brne ( addr --  addr f ) *@ fc07 and f401 - ;
: ?brcc ( addr -- addr f ) *@ fc07 and f400 - ;
: ?pop ( addr -- addr f ) *@ fe0f and 900f - ;
: ?push ( addr -- addr f ) *@ fe0f and 920f - ;
: ?st-y ( addr -- addr f ) *@ fe0f and 920a - ;
: ?ldy+ ( addr -- addr f ) *@ fe0f and 9009 - ;
: ?ijmp ( addr -- addr f ) *@ 9409 - ;
: ?ldi ( addr -- addr f ) *@ f000 and e000 - ;
: (see) ( addr -- addr' | false )
  dup u.4
  *@ u.4
  ?call 0= if *@+ ." call  " @xtaddr c>n .id cell+ cell+ else 
  ?rcall 0= if 5sp ." rcall " @braddr c>n .id cell+ else
  ?breq 0= if 5sp ." breq  " .br else
  ?brne 0= if 5sp ." brne  " .br else
  ?brcc 0= if 5sp ." brcc  " .br else
  ?rjmp 0= if 5sp ." rjmp  " .rjmp else
  ?ijmp 0= if 5sp ." ijmp" drop false else
  ?ret  0= if 5sp ." ret"  drop false else
  ?jmp  0= if *@+ ." jmp   " @xtaddr c>n .id drop false else
  ?pop  0= if 5sp ." pop   " .reg else
  ?push 0= if 5sp ." push  " .reg else
  ?ldy+ 0= if 5sp ." ld    " .reg ." y+" else
  ?st-y 0= if 5sp ." st    -y " .reg else
  ?ldi  0= if 5sp ." ldi   " .ldi else
  cell+
  then then then then then
  then then then then then
  then then then then
  cr ;

: dis ( addr -- )
  hex cr
  begin (see) dup 0=
  until drop ;

: see ( "word" -- )  ' dis ;
hex ram

-doloop
marker -doloop

: compileonly $10 shb ;

#20 constant ind inlined   \ R18:R19 are unused by the kernel

: (do)  ( limit index -- R: leave oldindex xfaxtor ) 
  r>
  dup >a xa> @ >r            \ R: leave 
  ind @ >r                   \ R: leave oldindex
  swap $8000 swap - dup >r   \ R: leave oldindex xfactor
  + ind !
  a> 1+ >r
; compileonly

: (?do) ( limit index -- R: leave oldindex xfactor ) 
  2dup xor
  if
    [ '  (do) ] again  \ branch to (do) 
  then
  r> xa> @ >r 2drop
; compileonly

: (+loop) ( n -- )
  [ $0f48 i, ]   \ add r20, tosl
  [ $1f59 i, ]   \ add r21, tosh
  inline drop
; compileonly

: unloop
  r>
  rdrop r> ind ! rdrop
  >r
; compileonly

: do
  postpone (do)
  postpone begin
  flash 2 allot ram  \ leave address
  postpone begin
; immediate compileonly

: ?do
  postpone (?do)
  postpone begin
  flash 2 allot ram  \ leave address
  postpone begin
; immediate compileonly

: leave
  rdrop rdrop r> ind ! 
; compileonly

: i
  ind @ rp@ 3 + @ >< -
; compileonly

: j
  rp@ 5 + @ >< rp@ 9 + @ >< - 
; compileonly


: loop
  $0d46 i, $1d55 i, \ add 1 to r20:r21
\  postpone (loop)
  $f00b i,               \ bra +2 if overflow
  postpone again
  postpone unloop
  flash here >xa swap ! ram
; immediate compileonly

: +loop
  postpone (+loop)
  $f00b i,               \ bra +2 if overflow
  postpone again
  postpone unloop
  flash here >xa swap ! ram
; immediate compileonly

-bit
marker -bit
: (bio) ( c-addr -- in/out-addr ) $20 - dup $5 lshift or $60f and ;
: (bit) ( c-addr bit flag "name" -- )
  : >r
  over $40 < if
    swap $20 - 3 lshift or
    r> 
    if    $9a00   \ sbi io-addr, bit
    else  $9800   \ cbi io-addr, bit
    then  or i,
  else
    over $60 < 
    if    over (bio) $b100 or   \ in r16 io-addr
    else  $9100 i, over         \ lds r16 c-addr
    then  i, 
    1 swap lshift 
    r>
    if   $6000 >r
    else $7000 >r invert $ff and
    then dup 4 lshift or $f0f and r> or i, \ andi/ori r16, mask
    dup $60 < 
    if   (bio) $b900 or         \ out io-addr r16 
    else $9300 i,               \ sts c-addr r16
    then i,
  then 
  $9508 i,            \ return
  postpone [
;

\ Define a word that clears a bit in ram
\ The defined word can be inlined
( c-addr bit "name" -- )
: bit0: false (bit) ;

\ Define a word that sets a bit in ram
\ The defined word can be inlined
( c-addr bit "name" -- )
: bit1: true (bit) ;

\ Define a word that leaves a true flag if a bit in ram is one
\ and a false flag if a bit is zero.
\ The defined word can be inlined
( c-addr bit "name" -- )
: bit?:
  :
  $939a i, $938a i, $ef8f i, $ef9f i, \ true
  over $40 < if   
    swap $20 - 3 lshift or $9b00 or i, \  sbis io-addr, bit   
  else 
    over $60 < 
    if swap (bio) $b100 or      \ in r16 io-addr
    else $9100 i, swap          \ lds r16 c-addr
    then i, $ff00 or i,         \ sbrs r16, bit
  then
  $9601 i,            \ 1+
  $9508 i,            \ return
  postpone [
;

-task
marker -task
hex ram

\ Near definition saves memory !
: up! up ! ;
: up@ up @ ;
: op@ operator @ ;
: ul@ ulink @ ;
: ul! ulink ! ;
: op! op@ up! ;
\ access user variables of other task
: his ( task-addr var-addr -- addr )
  up@ - swap @ + 
;

\ Define a new task
\ A new task must be defined in the flash memory space
: task: ( tibsize stacksize rsize addsize -- )
  flash create 
  up@ s0 - dup          \ Basic size     ts ss rs as bs bs
  ram here + flash ,    \ User pointer   ts ss rs as bs
  4 for
    over , +
  next
  cell+                 \ Task size
  ram allot
;

\ Initialise a user area and link it to the task loop
\ May only be executed from the operator task
: tinit ( taskloop-addr task-addr -- )
  \ use task user area
  @+ up!                          \ a addsize-addr
  ul@ if                          \ ? Already running
    2drop
  else
    \ Pointer to task area
    dup 2- task ! 
    \ r0 = uarea+addsize+rsize
    @+ swap @+ rot + up@ +         \  a ssize-addr r0
    \ Save r0
    r0 !                           \  a ssize-addr
    \ s0 = r0 + ssize
    @ r0 @ + s0 !                  \  a
    \ Store task-loop address to the return stack
    r0 @ x>r                       \  rsp
    \ Store SP to return stack
    1- dup s0 @ swap !             \ rsp
    \ Store current rsp and space for saving TOS and P PAUSE
    5 - rsave !                    \ 
    \ tiu = s0 + 2
    s0 @ 2+ tiu !
    0 ul!
    0 task 2+ !        \ clear status and cr flag
    decimal            \ Set the base to decimal
  then
  op!                 \ run the operator task again
;

\ Insert a new task after operator in the linked list.
\ May only be executed from the operator task
: run ( task-addr -- )
  @ up! ul@ 0= if              \ ? Already running
    up@                        \ task-uarea
    op! ul@                    \ task-uarea operator-ulink
    over ul!      
    swap up! ul! 
  then
  op!                          \ run operator task
;

\ End a task by linking it out from the linked list
\ May only be executed from the operator task
: end ( task-addr -- )  
  @ up! ul@ if
    up@
    op!
    begin                   \ find the uarea in the linked list
      dup ul@ <>            \ uarea flag
    while
      ul@ up!               \ uarea
    repeat
    up@                     \ uarea prev-uarea
    swap up!                \ prev-uarea
    ul@                     \ prev-uarea next-uarea
    0 ul!                   \ ulink of a ended task is zero
    swap up!                \ next-uarea
    ul!                     \ 
  then
  op!
;

\ End all tasks except the operator task
\ May only be executed from the operator task
: single ( -- )
  ul@ op@ <>  if            \ Are there any running tasks 
    ul@ op@ ul!             \ link operator to himself
    up!                     \ move to next user area
    begin
      ul@ op@ <>            \ is this the last linked user area
    while
      ul@ 0 ul!             \ write zero to ulink
      up!                   \ and move to next user area
    repeat
    0 ul!
    op!
  then
;

\ List all running tasks
: tasks ( -- )
  up@ op!
  begin
    up@ 
    task @ 6 - op! c>n .id space
    up!
    ul@ op@ -
  while
    ul@ up!
  repeat
  up!
;

-io
marker -io

\ TIMER_COUNTER_1
$6f constant TIMSK1		\ Timer/Counter Interrupt Mask Register
$36 constant TIFR1		\ Timer/Counter Interrupt Flag register
$80 constant TCCR1A		\ Timer/Counter1 Control Register A
$81 constant TCCR1B		\ Timer/Counter1 Control Register B
$82 constant TCCR1C		\ Timer/Counter1 Control Register C
$84 constant TCNT1		\ Timer/Counter1  Bytes
$88 constant OCR1A		\ Timer/Counter1 Output Compare Register  Bytes
$8a constant OCR1B		\ Timer/Counter1 Output Compare Register  Bytes
$86 constant ICR1		\ Timer/Counter1 Input Capture Register  Bytes
$43 constant GTCCR		\ General Timer/Counter Control Register

\ TIMER_COUNTER_2
$70 constant TIMSK2		\ Timer/Counter Interrupt Mask register
$37 constant TIFR2		\ Timer/Counter Interrupt Flag Register
$b0 constant TCCR2A		\ Timer/Counter2 Control Register A
$b1 constant TCCR2B		\ Timer/Counter2 Control Register B
$b2 constant TCNT2		\ Timer/Counter2
$b4 constant OCR2B		\ Timer/Counter2 Output Compare Register B
$b3 constant OCR2A		\ Timer/Counter2 Output Compare Register A
$b6 constant ASSR		\ Asynchronous Status Register

\ AD_CONVERTER
$7c constant ADMUX		\ The ADC multiplexer Selection Register
$78 constant ADC		\ ADC Data Register  Bytes
$7a constant ADCSRA		\ The ADC Control and Status register A
$7b constant ADCSRB		\ The ADC Control and Status register B
$7e constant DIDR0		\ Digital Input Disable Register

\ ANALOG_COMPARATOR
$50 constant ACSR		\ Analog Comparator Control And Status Register
$7f constant DIDR1		\ Digital Input Disable Register 0x1

\ PORTB
$25 constant PORTB		\ Port B Data Register
$24 constant DDRB		\ Port B Data Direction Register
$23 constant PINB		\ Port B Input Pins

\ PORTC
$28 constant PORTC		\ Port C Data Register
$27 constant DDRC		\ Port C Data Direction Register
$26 constant PINC		\ Port C Input Pins

\ PORTD
$2b constant PORTD		\ Port D Data Register
$2a constant DDRD		\ Port D Data Direction Register
$29 constant PIND		\ Port D Input Pins

\ TIMER_COUNTER_0
$48 constant OCR0B		\ Timer/Counter0 Output Compare Register
$47 constant OCR0A		\ Timer/Counter0 Output Compare Register
$46 constant TCNT0		\ Timer/Counter0
$45 constant TCCR0B		\ Timer/Counter Control Register B
$44 constant TCCR0A		\ Timer/Counter  Control Register A
$6e constant TIMSK0		\ Timer/Counter0 Interrupt Mask Register
$35 constant TIFR0		\ Timer/Counter0 Interrupt Flag register

\ EXTERNAL_INTERRUPT
$69 constant EICRA		\ External Interrupt Control Register
$3d constant EIMSK		\ External Interrupt Mask Register
$3c constant EIFR		\ External Interrupt Flag Register
$68 constant PCICR		\ Pin Change Interrupt Control Register
$6d constant PCMSK2		\ Pin Change Mask Register 0x2
$6c constant PCMSK1		\ Pin Change Mask Register 0x1
$6b constant PCMSK0		\ Pin Change Mask Register 0x0
$3b constant PCIFR		\ Pin Change Interrupt Flag Register

-main
marker -main