swapforth

1
// The CALL0 calling convention is:
2
//
3
//      a0      Return address
4
//      a1      Stack pointer
5
//      a2-a7   Function args, scratch
6
//      a8      scratch
7
//      a12-a15 Callee-saved
8

9
// So SwapForth assigns
10

11
#define RTOS    a0      // return address
12
#define RSP     a1      // return stack pointer
13
#define TOS     a2      // top of data stack
14
#define DSP     a3      // data stack pointer
15
#define X0      a4      // temp reg
16
#define X1      a5      // temp reg
17
#define X2      a6      // temp reg
18
#define X3      a7      // temp reg
19
#define X4      a8      // temp reg
20
#define X5      a9      // temp reg
21
#define X6      a10     // temp reg
22
#define X7      a11     // temp reg
23
#define CTX     a12     // context pointer
24
#define LPC     a13     // loop count
25
#define LPO     a14     // loop offset
26
#define TRUE    a15     // constant -1
27

28
        .set    ramhere,0
29

30
        .macro  allot   name size
31
        .equ    \name,ramhere
32
        .set    ramhere,ramhere+\size
33
        .endm
34

35
        allot   context_0,0
36
        allot   _dp,4           /* RAM data pointer */
37
        allot   _cp,4           /* Code pointer */
38
        allot   _forth,4        /* Dictionary pointer */
39
        allot   kpool,4         /* Constant pool */
40
        allot   aname,32        /* name buffer, used during dictionary search */
41
        allot   sourceA,4       /* tib+1 */
42
        allot   sourceC,4
43
        allot   _in,4           /* >IN */
44
        allot   _inwas,4        /* >IN at start of previous word */
45
        allot   recent,4        /* most recent CREATE */
46
        allot   thisxt,4        /* most recent xt */
47
        allot   attachpt,4      /* attach point for ; */
48
        allot   leaves,4*8      /* chain of LEAVE pointers */
49
        allot   leaveptr,4      /* Current LEAVE */
50
        allot   delim,4
51
        allot   _source_id,4
52
        allot   _state,4
53
        allot   _base,4
54
        allot   _tethered,4
55
        allot   oburn,4         /* burn offset */
56

57
        allot   _dsp,4
58
        allot   _lpc,4
59
        allot   _lpo,4
60
        allot   _rsp,4
61
        allot   _rdepth,4
62
        allot   _pc,4
63
        allot   _rstk,(4*32)
64

65
        allot   tib,256         /* terminal input buffer */
66
        allot   burn,1024       /* flash burn area */
67

68
        .if 0
69
        allot   cwl,4           /* Compilation word list */
70
        allot   wordlists,4     /* All word lists */
71
        allot   nsearch,4       /* Number of word lists in searchlist */
72
        allot   searchlist,4*16 /* search list */
73
        allot   context_1,0
74
        allot   forth,8         /* Forth word list */
75
        allot   internal,8      /* Internal word list */
76
        allot   handler,4       /* exception handler */
77
        .endif
78

79
        .set    forth_link,0
80
        .equ    INLINE,2
81
        .equ    IMMEDIATE,1
82

83
        .macro  noheader label
84
        .section        .irom0.text
85
        .p2align  2
86
\label:
87
        .endm
88

89
        .macro  header   fname,label,immediate=0
90
        .section        .irom0.text
91
        .p2align  2
92
        .long   forth_link + (\immediate ^ 1)
93
        .set    forth_link,.-4
94
        .byte   1f-.-1
95
        .ascii  "\fname"
96
1:
97
        .p2align  2
98
\label:
99
        .endm
100

101
        .macro  c       d
102
        call0   \d
103
        .endm
104

105
        // prolog, epilog 
106
        // are the entry/exit sequences for non-leaf words
107

108
        .macro  prolog
109
        addi    RSP,RSP,-4
110
        s32i    a0,RSP,0
111
        .endm
112

113
        .macro  epilog
114
        l32i    a0,RSP,0
115
        addi    RSP,RSP,4
116
        ret
117
        .endm
118

119
        .macro  tail    d
120
        l32i.n  a0,RSP,0
121
        addi    RSP,RSP,4
122
        j       \d
123
        .endm
124

125
        // prologL, epilogL are
126
        // as above but also preserving the C callee-saved
127
        // registers a12-15
128
        //
129
        .macro  prologL
130
        addi    RSP,RSP,-32
131
        s32i    a0,RSP,0
132
        s32i    LPC,RSP,4
133
        s32i    LPO,RSP,8
134
        s32i    a15,RSP,12
135
        s32i    CTX,RSP,16
136
        .endm
137

138
        .macro  epilogL
139
        l32i    a0,RSP,0
140
        l32i    LPC,RSP,4
141
        l32i    LPO,RSP,8
142
        l32i    a15,RSP,12
143
        l32i    CTX,RSP,16
144
        addi    RSP,RSP,32
145
        ret
146
        .endm
147

148
        .macro  tailL   d
149
        l32i.n  a0,RSP,0
150
        l32i    LPC,RSP,4
151
        l32i    LPO,RSP,8
152
        addi    RSP,RSP,16
153
        j       \d
154
        .endm
155

156
        .macro  dup
157
        addi    DSP,DSP,-4
158
        s32i    TOS,DSP,0
159
        .endm
160

161
        .macro  lit     v
162
        dup
163
        movi    TOS,\v
164
        .endm
165

166
        .macro  lita    o
167
        dup
168
        addi    TOS,CTX,\o
169
        .endm
170

171
        .macro  ctxvar  o
172
        dup
173
        l32i    TOS,CTX,\o
174
        .endm
175

176
        .macro  popX0
177
        l32i    X0,DSP,0
178
        addi    DSP,DSP,4
179
        .endm
180

181
        .macro  binop   op
182
        popX0
183
        \op     TOS,X0,TOS
184
        ret
185
        .endm
186

187
        .macro  _dropN  n
188
        l32i    TOS,DSP,4*(\n-1)
189
        addi    DSP,DSP,4*\n
190
        .endm
191

192
        .macro  _drop
193
        _dropN  1
194
        .endm
195

196
        .macro  tosX0
197
        mov     X0,TOS
198
        _drop
199
        .endm
200

201
        .macro  to_r
202
        addi    RSP,RSP,-4
203
        s32i    TOS,RSP,0
204
        _drop
205
        .endm
206

207
        .macro  r_at
208
        dup
209
        l32i.n  TOS,RSP,0
210
        .endm
211

212
        .macro  r_from
213
        r_at
214
        addi    RSP,RSP,4
215
        .endm
216

217
        .macro  cmpop   op
218
        popX0
219
        b\op    X0,TOS,1f
220
        movi    TOS,0
221
        ret
222
1:
223
        movi    TOS,-1
224
        ret
225
        .endm
226

227
        .macro  icmpop  op
228
        popX0
229
        b\op    TOS,X0,1f
230
        movi    TOS,0
231
        ret
232
1:
233
        movi    TOS,-1
234
        ret
235
        .endm
236

237
// 
238
// How DO...LOOP is implemented
239
// 
240
// Uses two registers:
241
//    LPC is the counter; it starts negative and counts up. When it reaches 0, loop exits
242
//    LPO is the offset. It is set up at loop start so that I can be computed from (LPC+LPO)
243
// 
244
// So when DO we have ( limit start ) on the stack so need to compute:
245
//      LPC = start - limit
246
//      LPO = limit
247
// 
248
// E.g. for "13 3 DO"
249
//      LPC = -10
250
//      LPO = 13
251
// 
252
// So the loop runs:
253
//      LPC     -10 -9 -8 -7 -6 -5 -4 -3 -2 -1
254
//      I         3  4  5  6  7  8  9 10 11 12
255
// 
256
// +LOOP must detect when LPC transitions from -ve to +ve. If the increment is -ve, then
257
// the sense of this transition is reversed.
258
//
259
// 
260

261
        .macro  _do
262
        addi    RSP,RSP,-8
263
        s32i    LPC,RSP,0
264
        s32i    LPO,RSP,4
265

266
        l32i    LPO,DSP,0       // TOS: start, LPO: limit
267
        sub     LPC,TOS,LPO
268
        _dropN  2
269
        .endm
270

271
        .macro  _qdo
272
        addi    RSP,RSP,-8
273
        s32i    LPC,RSP,0
274
        s32i    LPO,RSP,4
275

276
        l32i    LPO,DSP,0       // TOS: start, LPO: limit
277
        sub     LPC,TOS,LPO
278
        _dropN  1
279
        mov     TOS,LPC
280
        .endm
281

282
        .macro  _unloop
283
        l32i    LPC,RSP,0
284
        l32i    LPO,RSP,4
285
        addi    RSP,RSP,8
286
        .endm
287

288
        .macro  _i
289
        dup
290
        add     TOS,LPC,LPO
291
        .endm
292

293

294
// ====================   FORTH WORDS   =======================
295

296
// See p.598 of
297
//  Xtensa Instruction Set Architecture (ISA) Reference Manual
298
// which lists useful idioms
299

300
        .section        .irom0.text
301

302
header  ".x",dotx
303
        prolog
304
        dup
305
        extui   TOS,TOS,28,4
306
        c       hex1
307
        dup
308
        extui   TOS,TOS,24,4
309
        c       hex1
310
        dup
311
        extui   TOS,TOS,20,4
312
        c       hex1
313
        dup
314
        extui   TOS,TOS,16,4
315
        c       hex1
316
        dup
317
        extui   TOS,TOS,12,4
318
        c       hex1
319
        dup
320
        extui   TOS,TOS,8,4
321
        c       hex1
322
hex2:
323
        dup
324
        extui   TOS,TOS,4,4
325
        c       hex1
326
        extui   TOS,TOS,0,4
327
        c       hex1
328
        c       space
329
        epilog
330
hex1:
331
        blti    TOS,10,2f
332
        addi    TOS,TOS,'A'-'0'-10
333
2:      addi    TOS,TOS,'0'
334
        j       emit
335

336
header  ".x2",dotx2
337
        prolog
338
        j       hex2
339

340
header  "bye",bye
341
        j       abort
342
header  "emit",emit
343
        movi    X1,0x60000000
344
1:
345
        l32i    X0,X1,0x1c      // wait until TX fifo not full
346
        extui   X0,X0,16,8
347
        beqi    X0,0x80,1b
348
        s32i    TOS,X1,0         // transmit
349
        j       drop
350

351
header  "key",key
352
        prolog
353
        c       suspend
354
        c       drop
355
        epilog
356

357
header  "depth",depth
358
        dup
359
        movi    X0,(dstk-4)
360
        sub     TOS,X0,DSP
361
        srai    TOS,TOS,2
362
        ret
363

364
header  "base",base
365
        lita    _base
366
        ret
367

368
header  ">in",to_in
369
        lita    _in
370
        ret
371

372
header  "source",source
373
        lita    sourceA
374
        j       two_fetch
375

376
header  "source-id",source_id
377
        ctxvar  _source_id
378
        ret
379

380
header "2*",two_times,INLINE
381
        add     TOS,TOS,TOS
382
        ret
383

384
header "2/",two_slash,INLINE
385
        srai    TOS,TOS,1
386
        ret
387

388
header "1+",one_plus,INLINE
389
        addi    TOS,TOS,1
390
        ret
391

392
header "1-",one_minus,INLINE
393
        addi    TOS,TOS,-1
394
        ret
395

396
header "0=",zero_equals,INLINE
397
        movnez  TOS,TRUE,TOS
398
        xor     TOS,TOS,TRUE
399
        ret
400

401
header "cell+",cell_plus,INLINE
402
        addi    TOS,TOS,4
403
        ret
404

405
header "cells",cells,INLINE
406
        slli    TOS,TOS,2
407
        ret
408

409
header "<>",not_equal,INLINE
410
        cmpop   ne
411

412
header "=",equal,INLINE
413
        cmpop   eq
414

415
header ">",greater,INLINE
416
        icmpop  lt
417

418
header "<",less,INLINE
419
        cmpop   lt
420

421
header "0<",less_than_zero,INLINE
422
        srai    TOS,TOS,31
423
        ret
424

425
header "0>",greater_than_zero,INLINE
426
        beqz    TOS,1f
427
        srai    TOS,TOS,31
428
        xor     TOS,TOS,TRUE
429
1:
430
        ret
431

432
header "0<>",not_equal_zero,INLINE
433
        movnez  TOS,TRUE,TOS
434
        ret
435

436
header "u<",unsigned_less,INLINE
437
        cmpop   ltu
438

439
header "u>",unsigned_greater,INLINE
440
        icmpop  ltu
441

442
header  "+",plus,INLINE
443
        binop   add
444

445
header  "s>d",s_to_d,INLINE
446
        dup
447
        srai    TOS,TOS,31
448
        ret
449

450
header  "d>s",d_to_s,INLINE
451
        j       drop
452

453
header  "m+",m_plus
454
        prolog
455
        c       s_to_d
456
        tail    d_plus
457

458
header  "d+",d_plus
459
        l32i    X0,DSP,0
460
        l32i    X1,DSP,4
461
        l32i    X2,DSP,8
462

463
        add     X0,X0,X2
464
        add     TOS,TOS,X1
465
        bgeu    X0,X2,1f
466
        addi    TOS,TOS,1
467
1:
468
        addi    DSP,DSP,8
469
        s32i    X0,DSP,0
470
        ret
471

472
header  "d=",d_equal
473
        l32i    X1,DSP,4
474
        bne     TOS,X1,d_false
475
        l32i    X0,DSP,0
476
        l32i    X2,DSP,8
477
        bne     X0,X2,d_false
478
d_true:
479
        movi    TOS,-1
480
        addi    DSP,DSP,12
481
        ret
482
d_false:
483
        movi    TOS,0
484
        addi    DSP,DSP,12
485
        ret
486

487
header  "du<",d_u_less
488
        l32i    X1,DSP,4
489
        bltu    TOS,X1,d_false
490
        bne     X1,TOS,d_true
491
        l32i    X0,DSP,0
492
        l32i    X2,DSP,8
493
        bltu    X2,X0,d_true
494
        j       d_false
495

496
header  "d<",d_less
497
        l32i    X1,DSP,4
498
        blt     TOS,X1,d_false
499
        bne     X1,TOS,d_true
500
        l32i    X0,DSP,0
501
        l32i    X2,DSP,8
502
        bltu    X2,X0,d_true
503
        j       d_false
504

505
header  "d0<",d_less_than_zero
506
        srai    TOS,TOS,31
507
        j       nip
508

509
header  "dnegate",d_negate
510
        prolog
511
        c       invert
512
        c       swap
513
        c       invert
514
        c       swap
515
        lit     1
516
        tail    m_plus
517

518
header  "d-",d_minus
519
        prolog
520
        c       d_negate
521
        tail    d_plus
522

523
header  "d2*",d_two_times,INLINE
524
        l32i    X0,DSP,0
525
        ssai    32-1                    // setup for left funnel shift
526
        src     TOS,TOS,X0
527
        slli    X0,X0,1
528
        s32i    X0,DSP,0
529
        ret
530

531
header  "d2/",d_two_slash,INLINE
532
        l32i    X0,DSP,0
533
        ssai    1                    // setup for right funnel shift
534
        src     X0,TOS,X0
535
        srai    TOS,TOS,1
536
        s32i    X0,DSP,0
537
        ret
538

539
header  "-",minus,INLINE
540
        binop   sub
541

542
header  "negate",negate,INLINE
543
        neg     TOS,TOS
544
        ret
545

546
header  "invert",invert,INLINE
547
        xor     TOS,TOS,TRUE
548
        ret
549

550
header  "and",and,INLINE
551
        binop   and
552

553
header  "or",or,INLINE
554
        binop   or
555

556
header  "xor",xor,INLINE
557
        binop   xor
558

559
header  "lshift",lshift,INLINE
560
        popX0
561
        ssl     TOS
562
        sll     TOS,X0
563
        ret
564

565
header  "rshift",rshift,INLINE
566
        popX0
567
        ssr     TOS
568
        srl     TOS,X0
569
        ret
570

571
header  "abs",_abs,INLINE
572
        abs     TOS,TOS
573
        ret
574

575
header  "um*",u_m_multiply,INLINE
576
        l32i    X0,DSP,0
577
        extui   X1,TOS,16,16
578
        extui   X2,X0,16,16
579
        mul16u  X3,TOS,X0               // lo part
580
        mul16u  X4,X1,X0
581
        mul16u  X5,TOS,X2
582
        mul16u  TOS,X1,X2               // hi part
583
        add     X5,X5,X4                // mid part
584
        bgeu    X5,X4,1f                // mid carry into hi
585
        movi    X4,0x10000
586
        add     TOS,TOS,X4
587
1:
588
        extui   X4,X5,16,16
589
        add     TOS,TOS,X4
590
        slli    X5,X5,16
591
        add     X3,X3,X5
592
        bgeu    X3,X5,1f
593
        addi    TOS,TOS,1
594
1:
595
        s32i    X3,DSP,0
596
        ret
597

598
header  "*",multiply,INLINE
599
        binop   mull
600

601
header  "um/mod",u_m_slash_mod
602
        l32i    X2,DSP,0
603
        l32i    X3,DSP,4                // X2:X3 is the dividend
604
                                        // TOS is the divisor
605
        movi    X0,32
606
        ssai    32-1                    // setup for left funnel shift
607
0:
608
        // Handle large X2 case. After shift, (X2 >= 2**32), so certainly greater than TOS
609
        bltz    X2,3f
610
        src     X2,X2,X3
611
        slli    X3,X3,1
612
        bltu    X2,TOS,1f
613
2:
614
        sub     X2,X2,TOS
615
        addi    X3,X3,1
616
1:
617
        addi    X0,X0,-1
618
        bnez    X0,0b
619

620
        addi    DSP,DSP,4
621
        s32i    X2,DSP,0
622
        mov     TOS,X3
623
        ret
624

625
3:
626
        src     X2,X2,X3
627
        slli    X3,X3,1
628
        j       2b
629

630
header  "c@",c_fetch,INLINE
631
        l8ui    TOS,TOS,0
632
        ret
633

634
header  "c!",c_store,INLINE
635
        l32i    X0,DSP,0
636
        s8i     X0,TOS,0
637
        j       two_drop
638

639
header  "@",fetch,INLINE
640
        l32i    TOS,TOS,0
641
        ret
642

643
header  "!",store,INLINE
644
        l32i    X0,DSP,0
645
        s32i    X0,TOS,0
646
        j       two_drop
647

648
header  "2@",two_fetch,INLINE
649
        l32i    X0,TOS,4
650
        l32i    TOS,TOS,0
651
        addi    DSP,DSP,-4
652
        s32i    X0,DSP,0
653
        ret
654

655
header  "2!",two_store,INLINE
656
        l32i    X0,DSP,0
657
        s32i    X0,TOS,0
658
        l32i    X0,DSP,4
659
        s32i    X0,TOS,4
660

661
        l32i    TOS,DSP,8
662
        addi    DSP,DSP,12
663
        ret
664

665
header  "/string",slash_string
666
        prolog
667
        mov     X0,TOS
668
        c       drop
669
        l32i    X1,DSP,0
670
        add     X1,X1,X0
671
        s32i    X1,DSP,0
672
        sub     TOS,TOS,X0
673
        epilog
674

675
header  "swap",swap,INLINE
676
        l32i    X0,DSP,0
677
        s32i    TOS,DSP,0
678
        mov     TOS,X0
679
        ret
680

681
header  "over",over,INLINE
682
        dup
683
        l32i    TOS,DSP,4
684
        ret
685

686
header "false",false,INLINE
687
        lit     0
688
        ret
689

690
header "true",true,INLINE
691
        lit     -1
692
        ret
693

694
header "bl",_bl,INLINE
695
        lit     ' '
696
        ret
697

698
header "rot",rot,INLINE
699
        l32i    X0,DSP,0
700
        s32i    TOS,DSP,0
701
        l32i    TOS,DSP,4
702
        s32i    X0,DSP,4
703
        ret
704

705
header "noop",noop
706
        ret
707

708
header "-rot",minus_rot,INLINE
709
        l32i    X0,DSP,0
710
        l32i    X1,DSP,4
711

712
        s32i    TOS,DSP,4
713
        s32i    X1,DSP,0
714
        mov     TOS,X0
715
        ret
716

717
header "tuck",tuck
718
        prolog
719
        c       swap
720
        c       over
721
        epilog
722

723
header "?dup",question_dupe
724
        beqz    TOS,1f
725
        dup
726
1:      ret
727

728
header "2dup",two_dup,INLINE
729
        prolog
730
        c       over
731
        tail    over
732

733
header "+!",plus_store,INLINE
734
        l32i    X0,DSP,0
735
        l32i    X1,TOS,0
736
        add     X1,X1,X0
737
        s32i    X1,TOS,0
738
        j       two_drop
739

740
header "2swap",two_swap,INLINE
741
        // rot >r rot r>
742
        prolog
743
        c       rot
744
        to_r
745
        c       rot
746
        r_from
747
        epilog
748

749
header "2over",two_over,INLINE
750
        dup
751
        l32i    TOS,DSP,12
752
        dup
753
        l32i    TOS,DSP,12
754
        ret
755

756
header "min",min,INLINE
757
        popX0
758
        blt     TOS,X0,1f
759
        mov     TOS,X0
760
1:      ret
761

762
header "max",max,INLINE
763
        popX0
764
        bge     TOS,X0,1f
765
        mov     TOS,X0
766
1:      ret
767

768
header  "space",space
769
        lit     ' '
770
        j       emit
771

772
header  "cr",cr
773
        prolog
774
        lit     '\r'
775
        c       emit
776
        lit     '\n'
777
        c       emit
778
        epilog
779

780
header "count",count,INLINE
781
        mov     X0,TOS
782
        addi    TOS,TOS,1
783
        dup
784
        l8ui    TOS,X0,0
785
        ret
786

787
header "dup",dupe,INLINE
788
        dup
789
        ret
790

791
header "drop",drop,INLINE
792
        _drop
793
        ret
794

795
header  "nip",nip,INLINE
796
        addi    DSP,DSP,4
797
        ret
798

799
header "2drop",two_drop,INLINE
800
        _dropN  2
801
        ret
802

803
header "execute",execute
804
        mov     X0,TOS
805
        _drop
806
        jx      X0
807

808
header "bounds",bounds,INLINE
809
        l32i    X0,DSP,0
810
        add     TOS,TOS,X0
811
        s32i    TOS,DSP,0
812
        mov     TOS,X0
813
        ret
814

815
// : within    over - >r - r> u< ;
816
header "within",within,INLINE
817
        l32i    X0,DSP,4
818
        l32i    X1,DSP,0
819
        addi    DSP,DSP,8
820
        // So now have: X0 X1 TOS
821
        //              v  lo hi
822
        sub     TOS,TOS,X1      // TOS is hi-lo
823
        sub     X0,X0,X1        // X0 is v-lo
824
        bltu    X0,TOS,1f
825
        movi    TOS,0
826
        ret
827
1:
828
        movi    TOS,-1
829
        ret
830

831
header "type",type
832
        prolog
833
1:      beqz    TOS,2f
834
        c       over
835
        c       c_fetch
836
        c       emit
837
        lit     1
838
        c       slash_string
839
        j       1b
840
2:      c       two_drop
841
        epilog
842

843
// ( addr -- addr' ) advance to next word in dictionary
844
nextword:
845
        l32i    TOS,TOS,0
846
        movi    X0,~3
847
        and     TOS,TOS,X0
848
        ret
849

850
header  "tolower",tolower
851
        prolog
852
        dup
853
        lit     'A'
854
        lit     'Z'+1
855
        c       within
856
        lit     'a'-'A'
857
        c       and
858
        tail    plus
859

860
noheader case_equal
861
        prolog
862
        c       tolower
863
        c       swap
864
        c       tolower
865
        tail    equal
866
        
867
toaname:        // ( caddr u -- ) store string in aname, padded with zeroes
868
        prolog
869
        dup
870
        lita    aname
871
        c       c_store
872

873
        lita    aname+1
874
        lit     31
875
        lit     0
876
        c       fill
877

878
        lita    aname+1
879
        c       swap
880
        c       cmove
881

882
        lita    aname
883
        c       count
884
        c       bounds
885
        _do
886
1:
887
        _i
888
        c       c_fetch
889
        c       tolower
890
        _i
891
        c       c_store
892

893
        addi    LPC,LPC,1
894
        bnez    LPC,1b
895
        _unloop
896
        epilog
897

898
// SFIND
899
//         ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
900
// 
901
//         Find the definition named in the string at c-addr. If the
902
//         definition is not found, return c-addr and zero. If the definition
903
//         is found, return its execution token xt. If the definition is
904
//         immediate, also return one (1), otherwise also return minus-one
905
//         (-1).
906

907
        .p2align 2
908
compares:
909
        .long   0
910
        .long   cmp4
911
        .long   cmp8
912
        .long   cmp12
913
        .long   cmp16
914
        .long   cmp20
915
        .long   cmp24
916
        .long   cmp28
917
        .long   cmp32
918

919
header  "sfind",sfind
920
        prolog
921
        dup
922
        addi    TOS,TOS,1
923
        c       aligned
924
        movi    X0,compares
925
        add     TOS,X0,TOS
926
        l32i    TOS,TOS,0
927
        to_r
928

929
        c       two_dup
930
        c       toaname
931

932
        r_from
933
        mov     X7,TOS
934
        _drop
935
        lita    _forth
936
trynext:
937
        c       nextword
938
        beqz    TOS,1f
939
        jx      X7
940
cmp32:
941
        l32i    X0,CTX,aname
942
        l32i    X1,TOS,4
943
        bne     X0,X1,trynext
944
cmp28:
945
        l32i    X0,CTX,aname
946
        l32i    X1,TOS,4
947
        bne     X0,X1,trynext
948
cmp24:
949
        l32i    X0,CTX,aname
950
        l32i    X1,TOS,4
951
        bne     X0,X1,trynext
952
cmp20:
953
        l32i    X0,CTX,aname
954
        l32i    X1,TOS,4
955
        bne     X0,X1,trynext
956
cmp16:
957
        l32i    X0,CTX,aname
958
        l32i    X1,TOS,4
959
        bne     X0,X1,trynext
960
cmp12:
961
        l32i    X0,CTX,aname
962
        l32i    X1,TOS,4
963
        bne     X0,X1,trynext
964
cmp8:
965
        l32i    X0,CTX,aname+4
966
        l32i    X1,TOS,8
967
        bne     X0,X1,trynext
968
cmp4:
969
        l32i    X0,CTX,aname
970
        l32i    X1,TOS,4
971
        bne     X0,X1,trynext
972

973
        c       nip
974
        c       nip
975
        dup
976
        // TOS is address of word. Go to XT
977
        l32i    X0,TOS,4
978
        extui   X0,X0,0,8
979
        addi    X0,X0,5
980
        add     TOS,TOS,X0
981
        c       aligned
982
        c       swap
983
        l32i    TOS,TOS,0
984
        extui   TOS,TOS,0,1     // immediate: 1, otherwise 0
985
        add     TOS,TOS,TOS     // immediate: 2, otherwise 0
986
        addi    TOS,TOS,-1      // immediate: 1, otherwise -1
987
        c       negate
988
1:
989
        epilog
990

991
header  "words",words
992
        prolog
993
        lita    _forth
994
2:      c       nextword
995
        beqz    TOS,1f
996
        dup
997
        c       cell_plus
998

999
        l32i    X1,TOS,0
1000
        s32i    X1,CTX,aname+0
1001
        l32i    X1,TOS,4
1002
        s32i    X1,CTX,aname+4
1003
        l32i    X1,TOS,8
1004
        s32i    X1,CTX,aname+8
1005
        l32i    X1,TOS,12
1006
        s32i    X1,CTX,aname+12
1007
        l32i    X1,TOS,16
1008
        s32i    X1,CTX,aname+16
1009
        l32i    X1,TOS,20
1010
        s32i    X1,CTX,aname+20
1011
        l32i    X1,TOS,24
1012
        s32i    X1,CTX,aname+24
1013
        l32i    X1,TOS,28
1014
        s32i    X1,CTX,aname+28
1015
        c       drop
1016

1017
        lita    aname
1018
        c       count
1019
        c       type
1020
        c       space
1021

1022
        j       2b
1023
1:
1024
        tail    drop
1025

1026
header "accept",accept  // ( c-addr +n1 -- +n2 )
1027
        prolog
1028
        lit     0x1e            // tethered
1029
        c       emit
1030

1031
        c       drop
1032
        c       dupe
1033
0:
1034
        c       key
1035
        movi    X0,13
1036
        beq     TOS,X0,1f
1037
        c       over
1038
        c       c_store
1039
        c       one_plus
1040
        j       0b
1041
1:
1042
        c       drop
1043
        c       swap
1044
        tail    minus
1045

1046
header  "refill",refill
1047
        prolog
1048
        l32i    X0,CTX,_source_id
1049
        bnez    X0,false
1050

1051
        lita    tib
1052
        c       dupe
1053
        lit     128
1054
        c       accept
1055
        lita    sourceA
1056
        c       two_store
1057
        lit     0
1058
        lita    _in
1059
        c       store
1060
        c       true
1061
1:      epilog
1062

1063
// \ From Forth200x - public domain
1064
// 
1065
// : isspace? ( c -- f )
1066
//     h# 21 u< ;
1067

1068
isspace:
1069
        lit     0x21
1070
        j       unsigned_less
1071

1072
// 
1073
// : isnotspace? ( c -- f )
1074
//     isspace? 0= ;
1075

1076
isnotspace:
1077
        prolog
1078
        c       isspace
1079
        tail    zero_equals
1080
// 
1081
// : xt-skip   ( addr1 n1 xt -- addr2 n2 ) \ gforth
1082
//     \ skip all characters satisfying xt ( c -- f )
1083
//     >r
1084
//     BEGIN
1085
//         over c@ r@ execute
1086
//         overand
1087
//     WHILE
1088
//         d# 1 /string
1089
//     REPEAT
1090
//     r> drop ;
1091

1092
xt_skip:
1093
        prolog
1094
        to_r
1095
0:
1096
        c       over
1097
        c       c_fetch
1098
        r_at
1099
        c       execute
1100
        c       over
1101
        c       and
1102
        tosX0
1103
        beqz    X0,1f
1104
        lit     1
1105
        c       slash_string
1106
        j       0b
1107
1:
1108
        r_from
1109
        tail    drop
1110
// 
1111
// header parse-name
1112
// : parse-name ( "name" -- c-addr u )
1113
//     source >in @ /string
1114
//     ['] isspace? xt-skip over >r
1115
//     ['] isnotspace? xt-skip ( end-word restlen r: start-word )
1116
//     2dup d# 1 min + source drop - >in !
1117
//     drop r> tuck -
1118
// ;
1119

1120
header  "parse-name",parse_name
1121
        prolog
1122
        c       source
1123
        ctxvar  _in
1124
        c       slash_string
1125
        lit     isspace
1126
        c       xt_skip
1127
        c       over
1128
        to_r
1129
        lit     isnotspace
1130
        c       xt_skip
1131
        c       two_dup
1132
        lit     1
1133
        c       min
1134
        c       plus
1135
        c       source
1136
        c       drop
1137
        c       minus
1138
        c       to_in
1139
        c       store
1140
        c       drop
1141
        r_from
1142
        c       tuck
1143
        c       minus
1144
        epilog
1145

1146
// : digit? ( c -- u f )
1147
//    lower
1148
//    dup h# 39 > h# 100 and +
1149
//    dup h# 160 > h# 127 and - h# 30 -
1150
//    dup base @i u<
1151
// ;
1152
isdigit:
1153
        prolog
1154
        movi    X0,'A'
1155
        movi    X1,'Z'+1
1156
        blt     TOS,X0,1f
1157
        bge     TOS,X1,1f
1158
        addi    TOS,TOS,0x20
1159
1:
1160
        c       dupe
1161
        lit     0x39
1162
        c       greater
1163
        lit     0x100
1164
        c       and
1165
        c       plus
1166

1167
        c       dupe
1168
        lit     0x160
1169
        c       greater
1170
        lit     0x127
1171
        c       and
1172
        c       minus
1173
        lit     0x30
1174
        c       minus
1175

1176
        c       dupe
1177
        ctxvar  _base
1178
        tail    unsigned_less
1179

1180
// : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
1181
//     begin
1182
//         dup
1183
//     while
1184
//         over c@ digit?
1185
//         0= if drop ; then
1186
//         >r 2swap base @i
1187
//         \ ud*
1188
//         tuck * >r um* r> +
1189
//         r> m+ 2swap
1190
//         1/string
1191
//     repeat
1192
// ;
1193
header  ">number",to_number
1194
        prolog
1195
0:
1196
        beqz    TOS,1f
1197

1198
        c       over
1199
        c       c_fetch
1200
        c       isdigit
1201
        tosX0
1202
        bnez    X0,2f
1203
        tail    drop
1204
2:
1205

1206
        to_r
1207
        c       two_swap
1208
        ctxvar  _base
1209

1210
        c       tuck
1211
        c       multiply
1212
        to_r
1213
        c       u_m_multiply
1214
        r_from
1215
        c       plus
1216

1217
        r_from
1218

1219
        c       m_plus
1220
        c       two_swap
1221

1222
        lit     1
1223
        c       slash_string
1224
        j       0b
1225
1:
1226
        epilog
1227

1228

1229
header  "abort",abort
1230
        c       cr
1231
        lit     'A'
1232
        c       emit
1233
        lit     'B'
1234
        c       emit
1235
        lit     'O'
1236
        c       emit
1237
        lit     'R'
1238
        c       emit
1239
        lit     'T'
1240
        c       emit
1241
        c       cr
1242
1:
1243
        j       1b
1244

1245
header  "postpone",postpone,IMMEDIATE
1246
        prolog
1247
        c       parse_name
1248
        c       sfind
1249
        tosX0
1250
        beqz    X0,abort
1251
        bgez    X0,1f
1252
        c       literal
1253
        lit     compile_comma
1254
1:
1255
        tail    compile_comma
1256

1257
isnotdelim:
1258
        ctxvar  delim
1259
        j       not_equal
1260

1261
header  "parse",parse
1262
        prolog
1263
        lita    delim
1264
        c       store
1265
        c       source
1266
        ctxvar  _in
1267
        c       slash_string
1268

1269
    // over >r
1270
        c       over
1271
        to_r
1272
    // ['] isnotdelim xt-skip
1273
        lit     isnotdelim
1274
        c       xt_skip
1275

1276
    // 2dup d# 1 min + source drop - >in !
1277
        c       two_dup
1278
        lit     1
1279
        c       min
1280
        c       plus
1281
        c       source
1282
        c       drop
1283
        c       minus
1284
        c       to_in
1285
        c       store
1286
    // drop r> tuck -
1287

1288
        c       drop
1289
        r_from
1290
        c       tuck
1291
        tail    minus
1292

1293
header  "throw",throw
1294
        beqz    TOS,drop
1295
        j       abort
1296

1297
header  "evaluate",evaluate
1298
        prolog
1299
        c       source
1300
        to_r
1301
        to_r
1302
        ctxvar  _in
1303
        to_r
1304
        ctxvar  _source_id
1305
        to_r
1306
        c       true
1307
        lita    _source_id
1308
        c       store
1309
        
1310
        lita    sourceA
1311
        c       two_store
1312
        c       false
1313
        lita    _in
1314
        c       store
1315

1316
        c       interpret
1317

1318
        r_from
1319
        lita    _source_id
1320
        c       store
1321
        r_from
1322
        lita    _in
1323
        c       store
1324
        r_from
1325
        r_from
1326
        lita    sourceA
1327
        tail    two_store
1328

1329
header  "here",here
1330
        ctxvar  _dp
1331
        ret
1332

1333
header  "dp",dp
1334
        lita    _dp
1335
        ret
1336

1337
header  "chere",chere
1338
        j       abort
1339

1340
header  "cp",cp
1341
        lita    _cp
1342
        ret
1343

1344
header  "forth",forth
1345
        lita    _forth
1346
        ret
1347

1348
header  "state",state
1349
        lita    _state
1350
        ret
1351

1352
header  "unused",unused
1353
        j       abort
1354

1355
header  "aligned",aligned
1356
        addi    TOS,TOS,3
1357
        srli    TOS,TOS,2
1358
        slli    TOS,TOS,2
1359
        ret
1360

1361
header  "align",align
1362
        l32i    X0,CTX,_dp
1363
        addi    X0,X0,3
1364
        srli    X0,X0,2
1365
        slli    X0,X0,2
1366
        s32i    X0,CTX,_dp
1367
        ret
1368

1369
header  "allot",allot
1370
        lita    _dp
1371
        j       plus_store
1372

1373
header  ",",comma
1374
        l32i    X0,CTX,_dp
1375
        s32i    TOS,X0,0
1376
        addi    X0,X0,4
1377
        s32i    X0,CTX,_dp
1378
        _drop
1379
        ret
1380

1381
header  "c,",c_comma
1382
        l32i    X0,CTX,_dp
1383
        s8i     TOS,X0,0
1384
        addi    X0,X0,1
1385
        s32i    X0,CTX,_dp
1386
        _drop
1387
        ret
1388

1389
noheader createstub
1390
        epilog
1391

1392
noheader docreate
1393
        dup
1394
        l32i    TOS,a0,0
1395
        l32i    X0,TOS,-4
1396
        jx      X0
1397

1398
header  "create",create
1399
        prolog
1400
        c       align
1401

1402
        l32i    X0,CTX,_dp
1403
        s32i    X0,CTX,recent
1404

1405
        lit     createstub
1406
        c       comma
1407

1408
        c       mkhdr
1409
        lit     s_prolog
1410
        c       code_s_comma
1411
        lit     docreate
1412
        c       compile_comma
1413
        c       here
1414
        c       code_comma
1415
        c       doburn
1416
        epilog
1417

1418
header  "s,",s_comma
1419
        j       abort
1420

1421
header  ">r",to_r,IMMEDIATE
1422
        lit     s_to_r
1423
        j       code_s_comma
1424

1425
header  "r>",r_from,IMMEDIATE
1426
        lit     s_r_from
1427
        j       code_s_comma
1428

1429
header  "r@",r_at,IMMEDIATE
1430
        lit     s_r_at
1431
        j       code_s_comma
1432

1433
header  "2>r",two_to_r,IMMEDIATE
1434
        j       abort
1435

1436
header  "2r>",two_r_from,IMMEDIATE
1437
        j       abort
1438

1439
header  "2r@",two_r_at
1440
        j       abort
1441

1442
atburn:
1443
        ctxvar  oburn
1444
        lita    burn
1445
        j       plus
1446

1447
header  "code.,",code_comma
1448
        prolog
1449
        c       atburn
1450
        c       store
1451
        lit     4
1452
        lita    oburn
1453
        tail    plus_store
1454

1455
header  "code.,",code_c_comma
1456
        prolog
1457
        c       atburn
1458
        c       c_store
1459
        lit     1
1460
        lita    oburn
1461
        tail    plus_store
1462

1463
header  "code.24,",code_24_comma
1464
        prolog
1465
        dup
1466
        c       code_c_comma
1467

1468
        lit     8
1469
        c       rshift
1470
        dup
1471
        c       code_c_comma
1472

1473
        lit     8
1474
        c       rshift
1475
        tail    code_c_comma
1476

1477
header  "code.s,",code_s_comma
1478
        prolog
1479
        c       count
1480
1:
1481
        beqz    TOS,2f
1482
        c       over
1483
        c       c_fetch
1484
        c       code_c_comma
1485
        lit     1
1486
        c       slash_string
1487
        j       1b
1488
2:      tail    two_drop
1489

1490
header  ":noname",colon_noname
1491
        prolog
1492
        c       right_bracket
1493

1494
        c       false
1495
        lita    attachpt
1496
        c       store
1497

1498
        ctxvar  _cp
1499
        dup
1500
        lita    thisxt
1501
        c       store
1502

1503
        lit     s_prolog
1504
        tail    code_s_comma
1505

1506
noheader mkhdr
1507
        prolog
1508
        ctxvar  _cp
1509
        lita    attachpt
1510
        c       store
1511

1512
        c       parse_name
1513
        beqz    TOS,abort
1514

1515
        ctxvar  _forth
1516
        addi    TOS,TOS,1       // default is non-immediate
1517
        c       code_comma
1518

1519
        c       tuck
1520
        c       toaname
1521
        c       one_plus
1522
        c       aligned         // ( n )
1523
        dup
1524

1525
        lita    aname
1526
        c       atburn
1527
        c       rot             // ( aname burn@ n )
1528
        c       cmove
1529
        lita    oburn
1530
        tail    plus_store      // advance burn pointer
1531

1532
header  ":",colon
1533
        prolog
1534
        c       mkhdr
1535
        c       right_bracket
1536

1537
        ctxvar  _cp
1538
        ctxvar  oburn
1539
        c       plus
1540
        lita    thisxt
1541
        c       store
1542

1543
        lit     s_prolog
1544
        tail    code_s_comma
1545

1546
header  "flashbase",flashbase
1547
        lit     0x40200000
1548
        ret
1549

1550
doburn:
1551
        prolog
1552

1553
        ctxvar  oburn
1554
        c       aligned
1555
        lita    oburn
1556
        c       store
1557

1558
        l32i    X0,CTX,attachpt
1559
        beqz    X0,1f
1560
        s32i    X0,CTX,_forth
1561
1:
1562

1563
        ctxvar  _cp
1564
        movi    X0,0x40200000
1565
        sub     TOS,TOS,X0
1566
        lita    burn
1567
        ctxvar  oburn
1568
        c       _spi_flash_write
1569
        c       throw
1570

1571
        ctxvar  oburn
1572
        lita    _cp
1573
        c       plus_store
1574

1575
        c       false
1576
        lita    oburn
1577
        tail    store
1578

1579
header  ";",semi_colon,IMMEDIATE
1580
        prolog
1581
        c       exit
1582
        c       doburn
1583
        tail    left_bracket
1584

1585
header  "exit",exit,IMMEDIATE
1586
        lit     s_epilog
1587
        j       code_s_comma
1588

1589
header  "immediate",immediate
1590
        prolog
1591
        ctxvar  _forth
1592
        l32i    TOS,TOS,0
1593
        srli    TOS,TOS,1       // Clear bit 0
1594
        slli    TOS,TOS,1
1595
        s32i    TOS,CTX,aname
1596
        _drop
1597

1598
        ctxvar  _forth
1599
        movi    X0,0x40200000
1600
        sub     TOS,TOS,X0
1601
        lita    aname
1602
        lit     4
1603
        c       _spi_flash_write
1604
        tail    throw
1605

1606
header  "does>",does
1607
        l32i    X0,CTX,recent
1608
        s32i    a0,X0,0
1609
        epilog
1610

1611
header  "[",left_bracket,IMMEDIATE
1612
        movi    X0,0
1613
        s32i    X0,CTX,_state
1614
        ret
1615

1616
header  "]",right_bracket
1617
        movi    X0,3
1618
        s32i    X0,CTX,_state
1619
        ret
1620

1621
// ====================   LITERALS   ==========================
1622

1623
noheader k_1
1624
        dup
1625
        movi    TOS,1
1626
        ret
1627

1628
noheader k_2
1629
        dup
1630
        movi    TOS,2
1631
        ret
1632

1633
noheader k_3
1634
        dup
1635
        movi    TOS,3
1636
        ret
1637

1638
noheader k_4
1639
        dup
1640
        movi    TOS,4
1641
        ret
1642

1643
        .p2align 2
1644
        .long   true    // -1
1645
fastconsts:
1646
        .long   false   // 0
1647
        .long   k_1
1648
        .long   k_2
1649
        .long   k_3
1650
        .long   k_4
1651

1652
header  "literal",literal,IMMEDIATE
1653
        prolog
1654

1655
        dup
1656
        lit     -1
1657
        lit     5
1658
        c       within
1659
        tosX0
1660
        beqz    X0,1f
1661

1662
        movi    X0,fastconsts
1663
        addx4   TOS,TOS,X0
1664
        l32i    TOS,TOS,0
1665
        tail    compile_comma
1666

1667
1:
1668
        // Now search through kpool, stopping on a match or on FFFFFFFF
1669
        s32i    TOS,CTX,aname
1670
        mov     X0,TOS
1671
        l32i    TOS,CTX,kpool
1672
2:
1673
        l32i    X1,TOS,0
1674
        beq     X1,X0,4f
1675
        beqi    X1,-1,3f
1676

1677
        addi    TOS,TOS,4
1678
        j       2b
1679

1680
3:      // no match found, assign slot at TOS
1681

1682
        dup
1683
        movi    X0,0x40200000
1684
        sub     TOS,TOS,X0
1685
        lita    aname
1686
        lit     4
1687
        c       _spi_flash_write
1688
        c       throw
1689

1690
4:      // match found at TOS
1691

1692
        lit     s_dup
1693
        c       code_s_comma
1694

1695
        srli    TOS,TOS,2
1696
        ctxvar  _cp
1697
        ctxvar  oburn
1698
        c       plus
1699
        addi    TOS,TOS,3
1700
        srli    TOS,TOS,2
1701
        c       minus
1702
        slli    TOS,TOS,8
1703
        addi    TOS,TOS,0x21    // l32r a2,
1704
        tail    code_24_comma
1705

1706
header  "compile,",compile_comma
1707
        prolog
1708
        ctxvar  _cp
1709
        ctxvar  oburn
1710
        c       plus
1711
        srli    TOS,TOS,2
1712
        slli    TOS,TOS,2
1713
        addi    TOS,TOS,4
1714
        c       minus
1715
        lit     2
1716
        c       rshift
1717
        lit     6
1718
        c       lshift
1719
        addi    TOS,TOS,0x05
1720
        tail    code_24_comma
1721

1722
header  "2literal",two_literal,IMMEDIATE
1723
        prolog
1724
        c       swap
1725
        c       literal
1726
        tail    literal
1727

1728
header  "cmove",cmove
1729
        l32i    X0,DSP,0
1730
        l32i    X1,DSP,4
1731
        add     TOS,TOS,X0
1732
        // Move bytes from X1 to X0 until X0 reaches TOS
1733
        j       2f
1734
1:
1735
        l8ui    X2,X1,0
1736
        s8i     X2,X0,0
1737
        addi    X0,X0,1
1738
        addi    X1,X1,1
1739
2:
1740
        bne     TOS,X0,1b
1741
three_drop:
1742
        l32i    TOS,DSP,8
1743
        addi    DSP,DSP,12
1744
        ret
1745

1746
header  "cmove>",cmove_up
1747
        l32i    X0,DSP,0
1748
        l32i    X1,DSP,4
1749
        add     X0,X0,TOS
1750
        add     TOS,TOS,X1
1751
        // Move bytes from TOS to X0 while TOS>=X1
1752
        j       2f
1753
1:
1754
        l8ui    X2,TOS,0
1755
        s8i     X2,X0,0
1756
2:
1757
        addi    X0,X0,-1
1758
        addi    TOS,TOS,-1
1759
        bgeu    TOS,X1,1b
1760
        j       three_drop
1761

1762
header  "fill",fill
1763
        l32i    X0,DSP,0
1764
        l32i    X1,DSP,4
1765
        add     X0,X0,X1
1766
        // Fill X1 with TOS until X1 reaches X0
1767
        j       2f
1768
1:
1769
        s8i     TOS,X1,0
1770
        addi    X1,X1,1
1771
2:
1772
        bne     X1,X0,1b
1773
        j       three_drop
1774

1775
header  "begin",begin,IMMEDIATE
1776
        j       atburn
1777

1778
header  "ahead",ahead,IMMEDIATE
1779
        prolog
1780
        c       begin
1781
        lit     0x000006
1782
        tail    code_24_comma
1783

1784
header  "if",if,IMMEDIATE
1785
        prolog
1786
        lit     s_tosX0
1787
        c       code_s_comma
1788
        c       begin
1789
        lit     0x000416
1790
        tail    code_24_comma
1791

1792
header  "then",then,IMMEDIATE
1793
        prolog
1794
        dup
1795
        addi    TOS,TOS,4
1796
        c       begin
1797
        c       swap
1798
        c       minus
1799
        tail    patch
1800

1801
// patch ( ptr offset )
1802
// patch OFFSET into jump/branch instruction at byte-aligned PTR
1803
// Byte at PTR determines the instruction pattern:
1804
//
1805
// 06:    "J" instruction, so left-shift 6
1806
// else:  branch instruction, so left-shift 12
1807
//
1808

1809
patch:
1810
        l32i    X0,DSP,0   // X0:ptr TOS:insn
1811

1812
        l8ui    X1,X0,0
1813
        beqi    X1,0x06,patch_j
1814
        slli    TOS,TOS,12
1815
        j       or24
1816
patch_j:
1817
        slli    TOS,TOS,6
1818
or24:
1819
        or      X1,X1,TOS
1820
        s8i     X1,X0,0
1821

1822
        l8ui    X1,X0,1
1823
        srli    TOS,TOS,8
1824
        or      X1,X1,TOS
1825
        s8i     X1,X0,1
1826

1827
        l8ui    X1,X0,2
1828
        srli    TOS,TOS,8
1829
        or      X1,X1,TOS
1830
        s8i     X1,X0,2
1831

1832
        _dropN  2
1833
        ret
1834

1835
header  "again",again,IMMEDIATE
1836
        prolog
1837
        c       begin
1838
        addi    TOS,TOS,4
1839
        c       minus
1840
        lit     6
1841
        c       lshift
1842
        addi    TOS,TOS,0x06
1843
        tail    code_24_comma
1844

1845
header  "until",until,IMMEDIATE
1846
        prolog
1847
        lit     s_tosX0
1848
        c       code_s_comma
1849

1850
        c       begin
1851
        addi    TOS,TOS,4
1852
        c       minus
1853
        slli    TOS,TOS,12
1854
        lit     0x000416
1855
        c       or
1856
        tail    code_24_comma
1857

1858
header  "recurse",recurse,IMMEDIATE
1859
        ctxvar  thisxt
1860
        j       compile_comma
1861

1862
noheader push_leave
1863
        l32i    X0,CTX,leaveptr
1864
        s32i    TOS,X0,0
1865
        addi    X0,X0,4
1866
        s32i    X0,CTX,leaveptr
1867
        j       drop
1868

1869
noheader pop_leave
1870
        l32i    X0,CTX,leaveptr
1871
        dup
1872
        addi    X0,X0,-4
1873
        l32i    TOS,X0,0
1874
        s32i    X0,CTX,leaveptr
1875
        ret
1876

1877
header  "do",do,IMMEDIATE
1878
        prolog
1879
        lit     0
1880
        c       push_leave
1881
        lit     s_do
1882
        c       code_s_comma
1883
        tail    begin
1884

1885
header  "?do",question_do,IMMEDIATE
1886
        prolog
1887

1888
        lit     0
1889
        c       push_leave
1890

1891
        lit     s_qdo
1892
        c       code_s_comma
1893
        c       if
1894
        c       push_leave
1895

1896
        tail    begin
1897

1898
header  "leave",leave,IMMEDIATE
1899
        prolog
1900
        c       ahead
1901
        tail    push_leave
1902

1903
header  "loop",loop,IMMEDIATE
1904
        prolog
1905
        lit     s_loop
1906
        c       code_s_comma
1907

1908
        c       begin
1909
        addi    TOS,TOS,4
1910
        c       minus
1911
        slli    TOS,TOS,12
1912
        lit     0x000d56                // bnez a13 ...
1913
        c       or
1914
        c       code_24_comma
1915
loop_common:
1916
        c       pop_leave
1917
        beqz    TOS,1f
1918
        c       then
1919
        j       loop_common
1920
1:
1921
        _drop
1922
        tail    unloop
1923

1924
noheader do_plus_loop
1925
        // When LPC transitions from -ve to +ve
1926
        srai    X0,TOS,31               // increment sign
1927
        xor     X1,LPC,X0               // X1 old LPC
1928
        add     LPC,LPC,TOS
1929
        xor     X0,LPC,X0               // X0 new LPC
1930
        _drop
1931
        ret
1932

1933
header  "+loop",plus_loop,IMMEDIATE
1934
        prolog
1935
        lit     do_plus_loop
1936
        c       compile_comma
1937

1938
        c       begin
1939
        addi    TOS,TOS,4
1940
        c       minus
1941
        slli    TOS,TOS,16
1942
        lit     0x00b457                // bgeu X0,X1, ...
1943
        c       or
1944
        c       code_24_comma
1945
        j       loop_common
1946

1947
header  "unloop",unloop,IMMEDIATE
1948
        lit     s_unloop
1949
        j       code_s_comma
1950

1951
header  "i",i,IMMEDIATE
1952
        lit     s_i
1953
        j       code_s_comma
1954

1955
header  "j",j
1956
        dup
1957
        l32i    TOS,RSP,0
1958
        l32i    X0,RSP,4
1959
        add     TOS,TOS,X0
1960
        ret
1961

1962
header  "decimal",decimal
1963
        movi    X0,10
1964
        s32i    X0,CTX,_base
1965
        ret
1966

1967
snap:
1968
        c       cr
1969
        c       depth
1970
        c       dotx
1971
        c       space
1972
        j       2f
1973
1:
1974
        c       dotx
1975
2:
1976
        c       depth
1977
        tosX0
1978
        bnez    X0,1b
1979
3:
1980
        j       3b
1981

1982
// ====================   NUMBERS   ===========================
1983

1984
// : isvoid ( caddr u -- ) \ any char remains, abort
1985
isvoid:
1986
        addi    DSP,DSP,4
1987
        tosX0
1988
        bnez    X0,nosuchword
1989
        ret
1990

1991
nosuchword:
1992
        lit     'N'
1993
        c       emit
1994
        lit     'O'
1995
        c       emit
1996
        c       space
1997
        lit     'W'
1998
        c       emit
1999
        c       cr
2000
        c       space
2001
        lita    aname
2002
        c       count
2003
        c       type
2004
        c       cr
2005

2006
        lit     0x1e
2007
        c       emit
2008
1:      
2009
        j       1b
2010

2011
// : consume1 ( caddr u ch -- caddr' u' f )
2012
//     >r over c@ r> =
2013
//     over 0<> and
2014
//     dup>r d# 1 and /string r>
2015
// ;
2016
consume1:
2017
        prolog
2018
        to_r
2019
        c       over
2020
        c       c_fetch
2021
        r_from
2022
        c       equal
2023

2024
        c       over
2025
        c       not_equal_zero
2026
        c       and
2027

2028
        dup
2029
        to_r
2030
        c       negate
2031
        c       slash_string
2032
        r_from
2033
        epilog
2034

2035
doubleAlso2:
2036
        prolog
2037
        lit     0
2038
        dup
2039
        c       two_swap
2040
        lit     '-'
2041
        c       consume1
2042
        to_r
2043
        c       to_number
2044
        lit     '.'
2045
        c       consume1
2046
        tosX0
2047
        beqz    X0,1f
2048
        c       isvoid
2049
        r_from
2050
        tosX0
2051
        beqz    X0,2f
2052
        c       d_negate
2053
2:
2054
        lit     2
2055
        epilog
2056

2057
1:
2058
        c       isvoid
2059
        c       drop
2060
        r_from
2061
        tosX0
2062
        beqz    X0,3f
2063
        c       negate
2064
3:
2065
        lit     1
2066
        epilog
2067

2068
doubleAlso1:
2069
        prolog
2070
        // Handle 'X' here
2071
        bnei    TOS,3,1f
2072
        l32i    X0,DSP,0
2073
        movi    X2,0x27                 // ascii '
2074
        l8ui    X1,X0,0
2075
        bne     X1,X2,1f
2076
        l8ui    X1,X0,2
2077
        bne     X1,X2,1f
2078
        // matches 'X'. Return ( X 1 )
2079
        _drop
2080
        l8ui    TOS,X0,1
2081
        lit     1
2082
        epilog
2083
1:
2084
        lit     '$'                     // hex
2085
        c       consume1
2086
        movi    X1,16
2087
        tosX0
2088
        bnez    X0,inbase
2089
        lit     '#'                     // decimal
2090
        c       consume1
2091
        tosX0
2092
        movi    X1,10
2093
        bnez    X0,inbase
2094
        lit     '%'                     // binary
2095
        c       consume1
2096
        tosX0
2097
        movi    X1,2
2098
        bnez    X0,inbase
2099
        tail    doubleAlso2
2100

2101
inbase:                                 // conversion in base X1
2102
        dup
2103
        l32i    TOS,CTX,_base
2104
        s32i    X1,CTX,_base
2105
        to_r
2106
        c       doubleAlso2
2107
        r_from
2108
        c       base
2109
        tail    store
2110

2111
doubleAlso:
2112
        prolog
2113
        c       doubleAlso1
2114
        tail    drop
2115

2116
doubleAlso_comma:
2117
        prolog
2118
        c       doubleAlso1
2119
        tosX0
2120
        beqi    X0,1,1f
2121
        c       swap
2122
        c       literal
2123
1:
2124
        tail    literal
2125

2126
        .p2align        2
2127

2128
        .long   execute
2129
dispatch:
2130
        .long   doubleAlso
2131
        .long   execute
2132
        .long   compile_comma
2133
        .long   doubleAlso_comma
2134
        .long   execute
2135

2136
interpret:
2137
        prolog
2138
0:
2139
        c       parse_name
2140
        beqz    TOS,1f
2141
        c       sfind                   // -1 0 +1
2142
        l32i    X0,CTX,_state           // -1 0 +1 +2 +3 +4
2143
        add     TOS,TOS,X0
2144
        movi    X0,dispatch
2145
        addx4   TOS,TOS,X0
2146
        l32i    TOS,TOS,0
2147
        c       execute
2148
        j       0b
2149
1:      c       two_drop
2150
        epilog
2151

2152
// ====================   ESP SYSTEM INTERFACE   ==============
2153

2154
// Common calling subroutines. Named for number of
2155
// arguments/return values:
2156
//
2157
//      c_common_X_Y
2158
//
2159
// takes X arguments and returns Y values
2160
//
2161

2162
c_common_3_1:
2163
        l32i    X0,DSP,4
2164
        l32i    X1,DSP,0
2165
        mov     X2,TOS
2166
        _dropN  2
2167
        j       c_common_x_1
2168

2169
c_common_2_1:
2170
        l32i    X0,DSP,0
2171
        mov     X1,TOS
2172
        _dropN  1
2173
        j       c_common_x_1
2174

2175
c_common_0_1:
2176
        dup
2177
        j       c_common_x_1
2178

2179
c_common_1_1:
2180
        mov     X0,TOS
2181
c_common_x_1:
2182
        addi    RSP,RSP,-16
2183
        s32i    DSP,RSP,4
2184
        s32i    a0,RSP,0
2185

2186
        mov     a2,X0
2187
        mov     a3,X1
2188
        mov     a4,X2
2189
        mov     a5,X3
2190
        mov     a6,X4
2191

2192
        callx0  X6
2193

2194
        l32i    a0,RSP,0
2195
        l32i    DSP,RSP,4
2196
        addi    RSP,RSP,16
2197
        ret
2198

2199
header  "us@",us_fetch
2200
        movi    X6,system_get_time
2201
        j       c_common_0_1
2202

2203
header  "spi_flash_write",_spi_flash_write  // ( byte-offset source len )
2204
        movi    X6,spi_flash_write
2205
        j       c_common_3_1
2206

2207
header  "spi_flash_erase_sector",_spi_flash_erase_sector  // ( sector )
2208
        movi    X6,spi_flash_erase_sector
2209
        j       c_common_1_1
2210

2211
header  "ms",ms
2212
        addi    RSP,RSP,-16
2213
        s32i    a0,RSP,0
2214
        s32i    DSP,RSP,4
2215
        mov     a3,a2
2216
        movi    a2,some_timer
2217
        movi    a4,0
2218
        movi    a5,1
2219
        movi    a0,ets_timer_arm_new
2220
        callx0  a0
2221
        l32i    a0,RSP,0
2222
        l32i    DSP,RSP,4
2223
        addi    RSP,RSP,16
2224
        _drop
2225
        j       suspend
2226

2227
noheader suspend
2228
        s32i    a0,CTX,_pc
2229
        dup
2230
        s32i    DSP,CTX,_dsp
2231
        mov     a4,a1
2232
        l32i    a1,CTX,_rsp
2233
        sub     a5,a1,a4
2234
        s32i    a5,CTX,_rdepth
2235
        // Preserve the Rstack by copying from a4..a1 to _rstk
2236
        addi    a5,CTX,_rstk
2237
        j       2f
2238
1:
2239
        l32i    a6,a4,0
2240
        s32i    a6,a5,0
2241
        addi    a4,a4,4
2242
        addi    a5,a5,4
2243
2:      bne     a4,a1,1b
2244

2245
        epilogL
2246

2247
header  "quit",quit
2248
        prolog
2249
1:
2250
        c       refill
2251
        c       drop
2252
        c       interpret
2253
        c       space
2254
        lit     'o'
2255
        c       emit
2256
        lit     'k'
2257
        c       emit
2258
        c       cr
2259
        j       1b
2260
1:      epilog
2261

2262
        .p2align  2
2263
.global swapforth
2264
swapforth:
2265
        prologL
2266
        movi    CTX,_ctx
2267
        s32i    a1,CTX,_rsp
2268

2269
        movi    DSP,dstk
2270
        movi    TRUE,-1
2271

2272
        c       decimal
2273

2274
        addi    X0,CTX,leaves
2275
        s32i    X0,CTX,leaveptr
2276

2277
        lit     64
2278
1:
2279
        dup
2280
        c       _spi_flash_erase_sector
2281
        _drop
2282
        addi    TOS,TOS,1
2283
        movi    X0,96
2284
        bne     TOS,X0,1b
2285
        _drop
2286

2287
        l32i    X0,CTX,_cp
2288
        s32i    X0,CTX,kpool
2289
        addi    X0,X0,(4*256)
2290
        s32i    X0,CTX,_cp
2291

2292
        c       cr
2293
        c       cr
2294
        j       quit
2295

2296
1:
2297
        c       refill
2298
        c       dotx
2299
        ctxvar  _rdepth
2300
        c       dotx
2301
        j       1b
2302

2303

2304
        lit     ssss
2305
        lit     80
2306
        lita    sourceA
2307
        c       two_store
2308

2309
        lit     0
2310
        lita    _in
2311
        c       store
2312

2313
        c       interpret
2314
        c       cr
2315

2316
        lit     0x947
2317
        to_r
2318

2319
1:
2320
        c       refill
2321

2322
        c       source
2323
        c       type
2324
        j       1b
2325

2326
1:
2327
        c       key
2328
        c       dotx
2329
        j       1b
2330

2331
        c       cr
2332
        r_from
2333
        dup
2334
        c       dotx
2335
        c       cr
2336
        c       one_plus
2337
        to_r
2338

2339
        // lit     4000
2340
        // c       ms
2341
        c       suspend
2342

2343
        j       1b
2344

2345
        .p2align  2
2346
.global swapforth2
2347
swapforth2:
2348
        prologL
2349
        mov     X0,a3
2350
        movi    CTX,_ctx
2351
        s32i    a1,CTX,_rsp
2352

2353
        l32i    DSP,CTX,_dsp
2354
        movi    TRUE,-1
2355

2356
        // Stage incoming arguments (a2, a3) on the stack
2357
        addi    DSP,DSP,-4
2358
        s32i    X0,DSP,0                // ( par sig )
2359

2360
        l32i    a4,CTX,_rdepth
2361
        sub     a1,a1,a4
2362
        addi    a5,CTX,_rstk
2363
        add     a4,a5,a4
2364
        // Restore the Rstack by copying from _rstk+4 to r1
2365
        // So copy a5..a4 to a1 up
2366
        mov     a7,a1
2367
        j       2f
2368
1:
2369
        l32i    a6,a5,0
2370
        s32i    a6,a7,0
2371
        addi    a5,a5,4
2372
        addi    a7,a7,4
2373
2:      bne     a4,a5,1b
2374

2375
        l32i    a0,CTX,_pc
2376
        jx      a0
2377

2378
        .section        .data
2379

2380
s_prolog:
2381
        .byte   2f-1f
2382
1:      prolog
2383
2:
2384

2385
s_epilog:
2386
        .byte   2f-1f
2387
1:      epilog
2388
2:
2389

2390
s_tosX0:
2391
        .byte   2f-1f
2392
1:      tosX0
2393
2:
2394

2395
s_dup:
2396
        .byte   2f-1f
2397
1:      dup
2398
2:
2399

2400
s_do:
2401
        .byte   2f-1f
2402
1:      _do
2403
2:
2404

2405
s_qdo:
2406
        .byte   2f-1f
2407
1:      _qdo
2408
2:
2409

2410
s_loop:
2411
        .byte   2f-1f
2412
1:      addi    LPC,LPC,1
2413
2:
2414

2415
s_unloop:
2416
        .byte   2f-1f
2417
1:      _unloop
2418
2:
2419

2420
s_i:
2421
        .byte   2f-1f
2422
1:      _i
2423
2:
2424

2425
s_to_r:
2426
        .byte   2f-1f
2427
1:      to_r
2428
2:
2429

2430
s_r_from:
2431
        .byte   2f-1f
2432
1:      r_from
2433
2:
2434

2435
s_r_at:
2436
        .byte   2f-1f
2437
1:      r_at
2438
2:
2439

2440
        .p2align        2
2441
_ctx:   .long           dseg
2442
        .long           0x40240000      // CP
2443
        .long           forth_link
2444
        .skip           ramhere-12
2445

2446
ssss:   
2447
        # .ascii          "us@ 1+ 1- us@ swap - .x"
2448
        .ascii          "$123456789. 2dup .x .x cr dnegate .x .x"
2449
        .ascii          "                                                                                "
2450

2451
        .p2align        2
2452
        .skip           512
2453
dstk:
2454

2455
        .section        .bss
2456
dseg:   .skip           16384
2457