swapforth

1
# r0            TOS
2
# r1..r15       scratch
3
# r20           GPIO shadow
4
# r21           GPIO shadow
5
# r22           GPIO shadow
6
# r24
7
# r25           constant 0
8
# r26           FSP
9
# r27           DSP
10
# r28           do/loop counter
11
# r29           do/loop offset
12
# r30           cc
13
# r31           RSP
14

15
        .if     SIMULATOR
16
        .equ    __RAMSIZE,65536
17
        .endif
18

19
        .equ    PM_UNLOCK,      0x1fc80
20
        .equ    PM_ADDR,        0x1fc84
21
        .equ    PM_DATA,        0x1fc88
22

23
        .section        .text
24
        .equ    FSTACK_TOP,     0xf8fc
25
        .equ    DSTACK_TOP,     0xfcfc
26
.global _start
27
_start:
28
        .if     SIMULATOR
29
                jmp     codestart
30
        .else
31
                jmp     __PMSIZE-4
32
        .endif
33
        jmp     0 /* ft900_watchdog */
34
        jmp     interrupt_0
35
        jmp     interrupt_1
36
        jmp     interrupt_2
37
        jmp     interrupt_3
38
        jmp     interrupt_4
39
        jmp     interrupt_5
40
        jmp     interrupt_6
41
        jmp     interrupt_7
42
        jmp     interrupt_8
43
        jmp     interrupt_9
44
        jmp     interrupt_10
45
        jmp     interrupt_11
46
        jmp     interrupt_12
47
        jmp     interrupt_13
48
        jmp     interrupt_14
49
        jmp     interrupt_15
50
        jmp     interrupt_16
51
        jmp     interrupt_17
52
        jmp     interrupt_18
53
        jmp     interrupt_19
54
        jmp     interrupt_20
55
        jmp     interrupt_21
56
        jmp     interrupt_22
57
        jmp     interrupt_23
58
        jmp     interrupt_24
59
        jmp     interrupt_25
60
        jmp     interrupt_26
61
        jmp     interrupt_27
62
        jmp     interrupt_28
63
        jmp     interrupt_29
64
        jmp     interrupt_30
65
        jmp     interrupt_31
66
        jmp     0x3fff8
67

68
        jmp     codestart
69

70
        /*
71
         Macro to construct the interrupt stub code.
72
         it just saves r0, loads r0 with the int vector
73
         and branches to interrupt_common.
74
        */
75

76
        .macro  inth i=0
77
interrupt_\i:
78
        push    $r0
79
        ldk     $r0,noop
80
        jmp     interrupt_common
81
        .endm
82

83
        inth    0
84
        inth    1
85
        inth    2
86
        inth    3
87
        inth    4
88
        inth    5
89
        inth    6
90
        inth    7
91
        inth    8
92
        inth    9
93
        inth    10
94
        inth    11
95
        inth    12
96
        inth    13
97
        inth    14
98
        inth    15
99
        inth    16
100
        inth    17
101
        inth    18
102
        inth    19
103
        inth    20
104
        inth    21
105
        inth    22
106
        inth    23
107
        inth    24
108
        inth    25
109
        inth    26
110
        inth    27
111
        inth    28
112
        inth    29
113
        inth    30
114
        inth    31
115
        inth    32
116

117
        /* On entry: r0, already saved, holds the handler function */
118
interrupt_common:
119
        push    $r1    /* { */
120
        push    $r2    /* { */
121
        push    $r3    /* { */
122
        push    $r4    /* { */
123
        push    $r5    /* { */
124
        push    $r6    /* { */
125
        push    $r7    /* { */
126
        push    $r8    /* { */
127
        push    $r9    /* { */
128
        push    $r10   /* { */
129
        push    $r11   /* { */
130
        push    $r12   /* { */
131
        push    $r13   /* { */
132
        push    $r14   /* { */
133
        push    $r15   /* { */
134

135
        push    $r27    /* { */
136
        push    $cc    /* { */
137

138
        calli   $r0
139

140
        pop     $cc    /* } */
141
        pop     $r27    /* } */
142

143
        pop     $r15   /* } */
144
        pop     $r14   /* } */
145
        pop     $r13   /* } */
146
        pop     $r12   /* } */
147
        pop     $r11   /* } */
148
        pop     $r10   /* } */
149
        pop     $r9    /* } */
150
        pop     $r8    /* } */
151
        pop     $r7    /* } */
152
        pop     $r6    /* } */
153
        pop     $r5    /* } */
154
        pop     $r4    /* } */
155
        pop     $r3    /* } */
156
        pop     $r2    /* } */
157
        pop     $r1    /* } */
158
        pop     $r0    /* } matching push in interrupt_0-31 above */
159
        reti
160

161
       /* Null function for unassigned interrupt to point at */
162
nullvector:
163
        return
164

165
        .equ    sys_regclkcfg    , 0x10008 
166
        .equ    sys_regmsc0cfg_b2, 0x1001a 
167
        .equ    sys_regmsc0cfg_b3, 0x1001b 
168

169
        .equ    sys_regpad48     , 0x1004c 
170
        .equ    sys_regpad49     , 0x1004d 
171
        .equ    sys_regpad50     , 0x1004e 
172
        .equ    sys_regpad51     , 0x1004f 
173
        .equ    sys_regpad52     , 0x10050 
174
        .equ    sys_regpad53     , 0x10051 
175
        .equ    sys_regpad54     , 0x10052 
176
        .equ    sys_regpad55     , 0x10053 
177

178
        .equ    uart1_rhr        , 0x10320 
179
        .equ    uart1_thr        , 0x10320 
180
        .equ    uart1_ier        , 0x10321 
181
        .equ    uart1_isr_reg    , 0x10322 
182
        .equ    uart1_fcr        , 0x10322 
183
        .equ    uart1_lcr        , 0x10323 
184
        .equ    uart1_mcr        , 0x10324 
185
        .equ    uart1_lsr        , 0x10325 
186
        .equ    uart1_icr        , 0x10325 
187
        .equ    uart1_msr        , 0x10326 
188
        .equ    uart1_spr        , 0x10327 
189
        .equ    uart1_dll        , 0x10320 
190
        .equ    uart1_dlm        , 0x10321 
191

192
        .macro  snap    reg
193
        move    $r0,\reg
194
        call    dot
195
stophere:
196
        jmp     stophere
197
        .endm
198

199
        .macro  lit v=0
200
        call    dupe
201
        ldk     $r0,\v
202
        .endm
203

204
        .macro  litm v=0
205
        call    dupe
206
        lpm     $r0,\v
207
        .endm
208

209
        .set    forth_link,0
210
        .set    internal_link,0
211

212
        .macro  fheader  fname,immediate=0
213
        .section        .text
214
        .align  2
215
        .long   0xe0000000 + forth_link + \immediate
216
        .set    forth_link,.-4
217
        .string "\fname"
218
        .align  2
219
        .endm
220

221
        .macro  header  fname,aname,immediate=0
222
        fheader "\fname",\immediate
223
\aname :
224
        .endm
225

226
        .macro  iheader fname,aname,immediate=0
227
        .section        .text
228
        .align  2
229
        .long   0xe0000000 + internal_link + \immediate
230
        .set    internal_link,.-4
231
        .string "\fname"
232
        .align  2
233
        .endm
234

235
        .macro  _dup
236
        sub     $r27,$r27,4
237
        sti     $r27,0,$r0
238
        .endm
239

240
        .macro  _drop
241
        ldi     $r0,$r27,0
242
        add     $r27,$r27,4
243
        .endm
244

245
        .macro  _2drop
246
        ldi     $r0,$r27,4
247
        add     $r27,$r27,8
248
        .endm
249

250
        .macro  _r1_n
251
        ldi     $r1,$r27,0
252
        add     $r27,$r27,4
253
        .endm
254

255
        .equ    source_spec_size, 16
256

257
        .macro  push_source_spec
258
        lda     $r1,_source_id
259
        push    $r1
260
        lda     $r1,sourceA
261
        push    $r1
262
        lda     $r1,sourceC
263
        push    $r1
264
        lda     $r1,_in
265
        push    $r1
266
        .endm
267

268
        .macro  pop_source_spec
269
        pop     $r1
270
        sta     _in,$r1
271
        pop     $r1
272
        sta     sourceC,$r1
273
        pop     $r1
274
        sta     sourceA,$r1
275
        pop     $r1
276
        sta     _source_id,$r1
277
        .endm
278

279
# Lower-case the text in aname
280
lower_aname:
281
        ldk     $r1,aname
282
lower_aname_0:
283
        ldi.b   $r2,$r1,0
284
        cmp     $r2,'A'
285
        jmpc    b,lower_aname_1
286
        cmp     $r2,'Z'
287
        jmpc    a,lower_aname_1
288
        add     $r2,$r2,'a'-'A'
289
        sti.b   $r1,0,$r2
290
lower_aname_1:
291
        add     $r1,$r1,1
292
        cmp     $r1,aname+32
293
        jmpc    nz,lower_aname_0
294
        return
295

296
mkheader:      /*               ( <spaces>name -- ) */
297
        call    _parse_word
298
       /* XXX - should check for zero string here */
299

300
        call    lower_aname
301
        lda     $r4,cwl        /* $r4 -> cwl */
302
        ldi     $r1,$r4,4      /* $r1 -> previous word */
303
        lda     $r2,cp         /* $r2 -> new header */
304
        sti     $r4,4,$r2
305

306
        sta     PM_ADDR,$r2    /* start writing */
307
        lpm     $r2,store-8    /* the very first header is the link mask */
308
        or      $r1,$r1,$r2
309
        sta     PM_DATA,$r1    /* write link */
310

311
        add     $r3,$r3,4
312
        and     $r3,$r3,~3
313

314
        ldk     $r2,aname
315
        ldk     $r1,PM_DATA
316
        streamout $r1,$r2,$r3  /* write name */
317

318
        lda     $r2,cp
319
        add     $r2,$r2,4
320
        add     $r2,$r2,$r3
321
        sta     cp,$r2
322
        sta     thisxt,$r2
323
        return
324

325
push_r1:
326
        _dup
327
        move    $r0,$r1
328
        return
329

330
#######   ANS CORE   #################################################
331

332
header  "!",store
333
        ldi     $r1,$r27,0
334
        sti     $r0,0,$r1
335
        _2drop
336
        return
337

338

339

340
fheader "*"
341
        _r1_n
342
        mul     $r0,$r0,$r1
343
        return
344

345

346

347
header  "+",plus
348
        _r1_n
349
        add     $r0,$r0,$r1
350
        return
351

352
fheader "allot"
353
        call    __dp
354
        jmp     plus_store
355

356
header  "+!",plus_store
357
        ldi     $r1,$r27,0
358
        ldi     $r2,$r0,0
359
        add     $r2,$r2,$r1
360
        sti     $r0,0,$r2
361
        jmp     two_drop
362

363
header  "(+loop)",do_plus_loop
364
        addcc   $r28,$r0
365
        ashr    $r1,$r0,31
366
        xor     $cc,$cc,$r1
367
        add     $r28,$r28,$r0
368
        _drop
369
        return
370

371
fheader "+loop",1
372
        lit     do_plus_loop
373
        call    compile_comma
374

375
        lshr    $r0,$r0,2
376
        lpm     $r1,_template_jnc
377
        or      $r0,$r0,$r1
378
        call    code_comma
379

380
        jmp     loop_clean
381

382
header  ",",comma
383
        _dup
384
        lda     $r0,dp
385
        add     $r1,$r0,4
386
        sta     dp,$r1
387
        jmp     store
388

389
header  "pm,",pm_comma
390
        call    pmhere
391
        add     $r1,$r0,4
392
        sta     cp,$r1
393
        jmp     pm_store
394

395

396
header  "code,",code_comma
397
        jmp     pm_comma
398

399
header  "sync",sync
400
        return
401

402
header  "-",minus
403
        _r1_n
404
        sub     $r0,$r1,$r0
405
        return
406

407

408
header "/",slash
409
        _r1_n
410
        div     $r0,$r1,$r0
411
        return
412

413
header "/mod",slash_mod
414
        ldi     $r1,$r27,0
415
        mod     $r2,$r1,$r0
416
        sti     $r27,0,$r2
417
        div     $r0,$r1,$r0
418
        return
419

420
fheader "0<"
421
        ashr    $r0,$r0,31
422
        return
423

424
fheader "0="
425
        cmp     $r0,0
426
        bexts   $r0,$r30,(1<<5)|0
427
        return
428

429
fheader "1+"
430
        add     $r0,$r0,1
431
        return
432

433
header  "1-",one_minus
434
        sub     $r0,$r0,1
435
        return
436

437
header  "2!",two_store
438
        ldi     $r1,$r27,0
439
        sti     $r0,0,$r1
440
        ldi     $r1,$r27,4
441
        sti     $r0,4,$r1
442
        ldi     $r0,$r27,8
443
        add     $r27,$r27,12
444
        return
445

446
fheader "2*"
447
        ashl    $r0,$r0,1
448
        return
449

450
fheader "2/"
451
        ashr    $r0,$r0,1
452
        return
453

454
header  "2@",two_fetch
455
        ldi     $r1,$r0,4
456
        ldi     $r0,$r0,0
457
        sub     $r27,$r27,4
458
        sti     $r27,0,$r1
459
        return
460

461
header "2drop",two_drop
462
        _2drop
463
        return
464

465
header  "2dup",two_dupe
466
        ldi     $r1,$r27,0
467
        sub     $r27,$r27,8
468
        sti     $r27,4,$r0
469
        sti     $r27,0,$r1
470
        return
471

472
fheader "2over"
473
        ldi     $r1,$r27,8
474
        call    push_r1
475
        ldi     $r1,$r27,8
476
        jmp     push_r1
477

478
header  "2swap",two_swap
479
        exi     $r0,$r27,4
480
        ldi     $r1,$r27,0
481
        exi     $r1,$r27,8
482
        sti     $r27,0,$r1
483
        return
484

485
header  "2lit",two_lit         /* Push (r1,r2). For optimizer. */
486
        sub     $r27,$r27,8
487
        sti     $r27,4,$r0
488
        sti     $r27,0,$r1
489
        move    $r0,$r2
490
        return
491
        
492
fheader ":"
493
        call    mkheader
494
        lda     $r1,thisxt
495
        sub     $r1,$r1,4
496
        sta     tosmudge,$r1
497
        call    smudge
498
        jmp     right_bracket
499

500
header  "smudge",smudge                /* Flip the top bit of the first char of this name */
501
        lda     $r1,tosmudge
502
        lpmi    $r2,$r1,0
503
        xor     $r2,$r2,-1
504
        sta     PM_ADDR,$r1
505
        sta     PM_DATA,$r2
506
        return
507

508
header  ";",semicolon,1
509
        call    smudge
510
        call    exit
511
        jmp     left_bracket
512

513
fheader "<"
514
        _r1_n
515
        cmp     $r0,$r1
516
        bexts   $r0,$r30,(1<<5)|5
517
        return
518

519

520
header  "=",equal
521
        _r1_n
522
        cmp     $r0,$r1
523
        bexts   $r0,$r30,(1<<5)|0
524
        return
525

526
header  "cmp_cc",cmp_cc
527
        ldi     $r1,$r27,0
528
        cmp     $r1,$r0                /* note order: ( a b ) is compared (a,b) */
529
        _2drop
530
        return
531

532
fheader ">"
533
        _r1_n
534
        cmp     $r1,$r0
535
        bexts   $r0,$r30,(1<<5)|5
536
        return
537

538

539
fheader ">body"
540
       /* "literal" compiles a dupe then "ldk". Extract the field of the "ldk" */
541
        lpmi    $r0,$r0,4
542
        ldk     $r1,0x3ffff
543
        and     $r0,$r0,$r1
544
        return
545

546
header  ">number",to_number
547
        ldi     $r1,$r27,0              /* $r1 is caddr */
548
        ldi     $r2,$r27,4              /* $r2:$r3 is the accumulator */
549
        ldi     $r3,$r27,8
550
        lda     $r4,_base              /* $r4 is base */
551

552
to_number_0:
553
        cmp     $r0,0
554
        jmpc    z,to_number_2
555

556
        ldi.b   $r6,$r1,0
557

558
        cmp     $r6,'a'
559
        ldk     $r7,-'a'+10
560
        jmpc    ae,to_number_1
561

562
        cmp     $r6,'A'
563
        ldk     $r7,-'A'+10
564
        jmpc    ae,to_number_1
565

566
        cmp     $r6,'9'
567
        jmpc    a,to_number_2
568
        ldk     $r7,-'0'+0
569
to_number_1:
570
        add     $r6,$r6,$r7
571
        cmp     $r6,$r4
572
        jmpc    ae,to_number_2
573

574
        muluh   $r5,$r3,$r4            /* $r2:$r3 *= $r4 */
575
        mul     $r3,$r3,$r4
576
        mul     $r2,$r2,$r4
577
        add     $r2,$r2,$r5
578

579
        addcc   $r3,$r6
580
        add     $r3,$r3,$r6
581
        bextu   $r6,$r30,(1 << 5) | 1
582
        add     $r2,$r2,$r6
583

584
        add     $r1,$r1,1
585
        sub     $r0,$r0,1
586

587
        jmp     to_number_0
588

589
to_number_2:
590
        sti     $r27,0,$r1
591
        sti     $r27,4,$r2
592
        sti     $r27,8,$r3
593
        return
594

595
header  ">r",to_r
596
        pop     $r1
597
        push    $r0
598
        _drop
599
        jmpi    $r1
600

601
header  "?dup",question_dupe
602
        cmp     $r0,0
603
        jmpc    nz,dupe
604
        return
605

606
header  "@",fetch
607
        ldi     $r0,$r0,0
608
        return
609

610
header  "ul@",u_l_fetch
611
        ldi     $r0,$r0,0
612
        return
613

614

615
fheader "abs"
616
        cmp     $r0,0
617
        jmpc    lt,negate
618
        return
619

620
fheader "tethered"
621
        lit     _tethered
622
        return
623

624
        .macro   ifteth       label
625
        lda     $cc,_tethered
626
        jmpx    0,$cc,0,\label
627
        .endm
628

629
header  "accept",accept
630
        ifteth  1f
631
        lit     0x1e
632
        call    emit
633
1:
634
        push    $r28
635
        ldk     $r28,0
636

637
accept_1:
638
        call    key
639
        .if SIMULATOR == 1
640
                cmp     $r0,'\n'
641
        .else
642
                cmp     $r0,'\r'
643
        .endif
644
        jmpc    z,accept_2
645

646
        cmp     $r0,8
647
        jmpc    z,accept_backspace
648
        cmp     $r0,0x7f
649
        jmpc    nz,accept_3
650
accept_backspace:
651
        call    drop
652
        cmp     $r28,0
653
        jmpc    z,accept_1
654
        lit     8
655
        call    emit
656
        call    space
657
        lit     8
658
        call    emit
659
        sub     $r28,$r28,1
660
        jmp     accept_1
661
accept_3:
662
        cmp     $r0,'\n'
663
        jmpc    nz,accept_4
664
        call    drop
665
        jmp     accept_1
666
accept_4:
667
        ldi     $r1,$r27,4
668
        add     $r1,$r1,$r28
669
        sti.b   $r1,0,$r0
670
        ifteth  1f
671
        call    drop
672
        jmp     2f
673
1:      call    emit
674
2:      add     $r28,$r28,1
675
        jmp     accept_1
676
accept_2:
677
        call    two_drop
678
        move    $r0,$r28
679
        pop     $r28
680

681
        return
682

683
header  "align",align
684
        lda     $r1,dp
685
        add     $r1,$r1,3
686
        and     $r1,$r1,~3
687
        sta     dp,$r1
688
        return
689

690
fheader "aligned"
691
        add     $r0,$r0,3
692
        and     $r0,$r0,~3
693
        return
694

695
fheader "and"
696
        _r1_n
697
        and     $r0,$r0,$r1
698
        return
699

700
fheader "base"
701
        lit     _base
702
        return
703

704
header  "begin",begin,1
705
        call    check_compiling
706
        call    sync
707
        lda     $r1,cp
708
        jmp     push_r1
709

710
check_compiling:               /* Throw -14 if interpreting */
711
        lda     $r1,_state
712
        cmp     $r1,0
713
        ldk     $r1,-14
714
        jmpc    z,throw_r1
715
        return
716
throw_r1:
717
        call    push_r1
718
        jmp     throw
719

720

721
header  "c!",c_store
722
        ldi     $r1,$r27,0
723
        sti.b   $r0,0,$r1
724
        _2drop
725
        return
726

727
header  "c,",c_comma
728
        _dup
729
        lda     $r0,dp
730
        add     $r1,$r0,1
731
        sta     dp,$r1
732
        jmp     c_store
733

734
header  "c@",c_fetch
735
        ldi.b   $r0,$r0,0
736
        return
737

738
header  "uw@",uw_fetch
739
        ldi.s   $r0,$r0,0
740
        return
741

742
header  "w@",w_fetch
743
        ldi.s   $r0,$r0,0
744
        bexts   $r0,$r0,0
745
        return
746

747
header  "w!",w_store
748
        ldi     $r1,$r27,0
749
        sti.s   $r0,0,$r1
750
        _2drop
751
        return
752

753
header  "w,",w_comma
754
        _dup
755
        lda     $r0,dp
756
        add     $r1,$r0,2
757
        sta     dp,$r1
758
        jmp     w_store
759

760
fheader "cell+"
761
        add     $r0,$r0,4
762
        return
763

764
fheader "cells"
765
        ashl    $r0,$r0,2
766
        return
767

768
header  "count",count
769
        add     $r1,$r0,1
770
        add     $r27,$r27,-4
771
        sti     $r27,0,$r1
772
        ldi.b   $r0,$r0,0
773
        return
774

775
header  "cr",cr
776
        lit     '\r'
777
        call    emit
778
        lit     '\n'
779
        jmp     emit
780

781
fheader "create"
782
        call    mkheader
783
        call    align
784
        _dup
785
        lda     $r0,dp
786
        call    literal
787
        call    sync
788
        lda     $r1,cp
789
        sta     recent,$r1
790
        jmp     exit
791

792
header  "decimal",decimal
793
        ldk     $r1,10
794
        sta     _base,$r1
795
        return
796

797
header  "depth",depth
798
        call    dupe
799
        ldk     $r0,DSTACK_TOP-4
800
        sub     $r0,$r0,$r27
801
        lshr    $r0,$r0,2
802
        return
803

804
/*
805
 * How DO...LOOP is implemented
806
 *
807
 * Uses two registers:
808
 *    $r28 is the counter; it starts negative and counts up. When it reaches 0, loop exits
809
 *    $r29 is the offset. It is set up at loop start so that I can be computed from ($r28+$r29)
810
 *
811
 * So when DO we have ( limit start ) on the stack so need to compute:
812
 *      $r28 = start - limit
813
 *      $r29 = limit
814
 *
815
 * E.g. for "13 3 DO"
816
 *      $r28 = -10
817
 *      $r29 = 13
818
 *
819
 * So the loop runs:
820
 *      $28     -10 -9 -8 -7 -6 -5 -4 -3 -2 -1
821
 *      I         3  4  5  6  7  8  9 10 11 12
822
 *
823
 */
824

825
dodo:
826
        pop     $r1
827
        push    $r28
828
        push    $r29
829
                                       /* $r0 is start */
830
        ldi     $r29,$r27,0             /* $r29 is limit */
831
        cmp     $r0,$r29               /* compare for ?DO */
832
        sub     $r28,$r0,$r29
833
        _2drop
834
        jmpi    $r1
835

836
header  "do0cmp",do0cmp
837
        cmp     $r0,0
838
        _drop
839
        return
840
        
841
fheader "do",1
842
        ldk     $r1,0
843
        sta     leaves,$r1
844

845
        lit     dodo
846
        call    compile_comma
847
        jmp     begin
848

849
header  "does>",does
850
        lda     $r1,recent
851
        sta     PM_ADDR,$r1
852
        pop     $r1                    /* $r1 is the DOES code address */
853
        lshr    $r1,$r1,2
854
        lpm     $r2,_template_jmp
855
        or      $r1,$r1,$r2
856
        sta     PM_DATA,$r1
857
        return
858

859
header  "drop",drop
860
        ldi     $r0,$r27,0
861
        add     $r27,$r27,4
862
        return
863

864
header  "dup",dupe
865
        _dup
866
        return
867

868

869
fheader "evaluate"
870
        push_source_spec
871

872
        call    tosource
873
        sta     _in,$r25
874
        ldk     $r1,-1
875
        sta     _source_id,$r1
876

877
        call    interpret
878

879
        pop_source_spec
880
        return
881

882
header  "execute",execute
883
        move    $r1,$r0
884
        _drop
885
        jmpi    $r1
886

887
header  "exit",exit,1
888
        _dup
889
        lpm     $r0,_template_return
890
        call    code_comma
891
        jmp     sync
892

893
header  "fill",fill
894
        ldi     $r1,$r27,4
895
        ldi     $r2,$r27,0
896
        or      $cc,$r0,$r1
897
        or      $cc,$cc,$r2
898
        jmpx    0,$cc,1,1f
899
        memset.s $r1,$r0,$r2
900
        jmp     9f
901
1:      memset.b $r1,$r0,$r2
902
9:      ldi     $r0,$r27,8
903
        add     $r27,$r27,12
904
        return
905

906

907
header  "here",here
908
        _dup
909
        lda     $r0,dp
910
        return
911

912
header  "noop",noop
913
        nop
914
        return
915

916
header  "atomic-swap",atomic_swap
917
        ldi     $r1,$r27,0
918
        exi.b   $r1,$r0,0
919
        move    $r0,$r1
920
        jmp     nip
921

922
header  "dp",__dp
923
        _dup
924
        ldk     $r0,dp
925
        return
926

927
header  "cp",__cp
928
        _dup
929
        ldk     $r0,cp
930
        return
931

932

933
fheader "i"
934
        _dup
935
        add     $r0,$r28,$r29
936
        return
937

938
header  "(if)",paren_if_paren
939
        call    sync
940
        jmp     1f
941
1:      
942
        litm    call_do0cmp
943
        call    pm_comma
944
        lpm     $r1,_template_jz
945
        lshr    $r0,$r0,2
946
        or      $r0,$r0,$r1
947
        jmp     pm_comma
948
call_do0cmp:    call    do0cmp
949

950
fheader "if",1
951
        call    check_compiling
952
        call    false
953
        call    paren_if_paren
954
forward:                               /* forward ref to the just-compiled jmp */
955
        call    sync
956
        lda     $r1,cp
957
        sub     $r1,$r1,4
958
        jmp     push_r1
959

960
fheader "immediate"
961
       /* dict @ dup pm@ 1 or swap pm! */
962
        call    dupe
963
        lda     $r0,cwl
964
        ldi     $r0,$r0,4
965
        call    dupe
966
        lpmi    $r0,$r0,0
967
        or      $r0,$r0,1
968
        call    swap
969
        jmp     pm_store
970

971
header  "invert",invert
972
        xor     $r0,$r0,-1
973
        return
974

975
fheader "j"
976
        ldi     $r1,$sp,4
977
        ldi     $r2,$sp,8
978
        add     $r1,$r1,$r2
979
        jmp     push_r1
980

981

982
header  "leave",leave,1
983
        call    sync
984
        lda     $r1,leaves
985
        lda     $r2,cp
986
        sta     leaves,$r2
987

988
        ashr    $r1,$r1,2
989
        lpm     $r2,_template_jmp
990
        or      $r1,$r1,$r2
991
        call    push_r1
992
        call    code_comma
993
        jmp     sync
994

995
header  "literal",literal,1
996
        jmp     1f
997
1:      litm    cdupe
998
        call    pm_comma
999
set_r0:
1000
       /* when r0 is outside -100000 to fffff, shift right 10, recurse, then use ldl */
1001
        ldk     $r2,-0x80000
1002
        cmp     $r0,$r2
1003
        jmpc    lt,1f
1004
        ldk     $r2,0x7ffff
1005
        cmp     $r0,$r2
1006
        jmpc    gt,1f
1007

1008
        ashl    $r0,$r0,12
1009
        lshr    $r0,$r0,12
1010
        lpm     $r1,_template_ldk_r0
1011
        or      $r0,$r0,$r1
1012
        jmp     pm_comma
1013

1014
cdupe:
1015
1:      call    dupe
1016
        ashr    $r0,$r0,10
1017
        call    set_r0
1018
        ldk     $r2,0x3ff
1019
        and     $r0,$r0,$r2
1020
        ashl    $r0,$r0,4
1021
        lpm     $r1,_template_ldl_r0
1022
        or      $r0,$r0,$r1
1023
        jmp     pm_comma
1024

1025
fheader "loop",1
1026
        lpm     $r1,_template_inc28
1027
        call    push_r1
1028
        call    code_comma
1029

1030
        lshr    $r0,$r0,2
1031
        lpm     $r1,_template_j28m
1032
        or      $r0,$r0,$r1
1033
        call    code_comma
1034

1035
loop_clean:
1036
        call    sync
1037
        lda     $r1,leaves
1038
loop_0:
1039
        cmp     $r1,0
1040
        jmpc    z,loop_1
1041
        lpmi    $r2,$r1,0
1042
        ldk     $r3,0x3ffff
1043
        and     $r2,$r2,$r3
1044
        ashl    $r2,$r2,2
1045
        push    $r2
1046

1047
        call    push_r1
1048
        call    then
1049
        pop     $r1
1050
        jmp     loop_0
1051
loop_1:
1052

1053
        lit     unloop
1054
        jmp     compile_comma
1055
        
1056
fheader "lshift"
1057
        _r1_n
1058
        ashl    $r0,$r1,$r0
1059
        return
1060

1061
fheader "m*"
1062
        ldi     $r1,$r27,0
1063

1064
        mul     $r2,$r0,$r1
1065
        sti     $r27,0,$r2
1066

1067
        muluh   $r2,$r0,$r1
1068

1069
        ashr    $r3,$r0,31
1070
        and     $r3,$r3,$r1
1071
        sub     $r2,$r2,$r3
1072

1073
        ashr    $r3,$r1,31
1074
        and     $r3,$r3,$r0
1075
        sub     $r0,$r2,$r3
1076

1077
        return
1078

1079
fheader "max"
1080
        ldi     $r1,$r27,0
1081
        cmp     $r1,$r0
1082
        jmpc    gt,drop
1083
        jmp     nip
1084

1085
fheader "min"
1086
        ldi     $r1,$r27,0
1087
        cmp     $r1,$r0
1088
        jmpc    lt,drop
1089
        jmp     nip
1090

1091
fheader "mod"
1092
        _r1_n
1093
        mod     $r0,$r1,$r0
1094
        return
1095

1096
fheader "umod"
1097
        _r1_n
1098
        umod    $r0,$r1,$r0
1099
        return
1100

1101

1102
header  "negate",negate
1103
        sub     $r0,$r25,$r0
1104
        return
1105

1106
fheader "or"
1107
        _r1_n
1108
        or      $r0,$r0,$r1
1109
        return
1110

1111
header  "over",over
1112
        _dup
1113
        ldi     $r0,$r27,4
1114
        return
1115

1116
header  "postpone",postpone,1
1117
        call    parse_name
1118
        call    sfind
1119
        cmp     $r0,1
1120
        _drop
1121
        jmpc    z,_postpone_immed
1122

1123
        call    literal
1124
        lit     compile_comma
1125
_postpone_immed:
1126
        jmp     compile_comma
1127

1128
header  "r>",r_from
1129
        pop     $r1
1130
        _dup
1131
        pop     $r0
1132
        jmpi    $r1
1133

1134
header  "r@",r_fetch
1135
        _dup
1136
        ldi     $r0,$sp,4
1137
        return
1138

1139
header  "recurse",recurse,1
1140
        _dup
1141
        lda     $r0,thisxt
1142
        jmp     compile_comma
1143

1144

1145
header  "rot",rot
1146
        exi     $r0,$r27,0
1147
        exi     $r0,$r27,4
1148
        return
1149

1150
fheader "rshift"
1151
        _r1_n
1152
        lshr    $r0,$r1,$r0
1153
        return
1154

1155

1156
fheader "s>d"
1157
        _dup
1158
        ashr    $r0,$r0,31
1159
        return
1160

1161

1162
header  "space",space
1163
        lit     ' '
1164
        jmp     emit
1165

1166

1167
fheader "state"
1168
        lit     _state
1169
        return
1170

1171
header  "swap",swap
1172
        exi     $r0,$r27,0
1173
        return
1174

1175
header  "then",then,1
1176
        call    check_compiling
1177
        call    sync
1178
        lda     $r1,cp
1179
        lshr    $r1,$r1,2
1180
        lpmi    $r2,$r0,0
1181
        ldk     $r3,~0xffff
1182
        and     $r2,$r2,$r3
1183
        or      $r1,$r1,$r2
1184
        sta     PM_ADDR,$r0
1185
        sta     PM_DATA,$r1
1186
        jmp     drop
1187

1188
fheader "u<"
1189
        _r1_n
1190
        cmp     $r0,$r1
1191
        bexts   $r0,$r30,(1<<5)|6
1192
        return
1193

1194
header "um*",u_m_star
1195
        ldi     $r1,$r27,0
1196
        mul     $r2,$r0,$r1
1197
        muluh   $r0,$r0,$r1
1198
        sti     $r27,0,$r2
1199
        return
1200

1201
header  "unloop",unloop
1202
        pop     $r1
1203
        pop     $r29
1204
        pop     $r28
1205
        jmpi    $r1
1206

1207
header  "until",until,1
1208
        call    check_compiling
1209
        jmp     paren_if_paren
1210

1211
fheader "xor"
1212
        _r1_n
1213
        xor     $r0,$r0,$r1
1214
        return
1215

1216
header  "[",left_bracket,1
1217
        sta     _state,$r25
1218
        return
1219

1220

1221
header "]",right_bracket
1222
        ldk     $r1,3
1223
        sta     _state,$r1
1224
        return
1225

1226
#######   ANS CORE EXT   #############################################
1227

1228

1229
header  "0<>",zero_notequal
1230
        cmp     $r0,0
1231
        bexts   $r0,$r30,(1<<5)|0
1232
        xor     $r0,$r0,-1
1233
        return
1234

1235
fheader "0>"
1236
        cmp     $r0,0
1237
        bexts   $r0,$r30,(1<<5)|5
1238
        return
1239

1240
fheader "2>r"
1241
        pop     $r2
1242
        ldi     $r1,$r27,0
1243
        push    $r1
1244
        push    $r0
1245
        _2drop
1246
        jmpi    $r2
1247

1248
fheader "2r>"
1249
        pop     $r3
1250
        pop     $r2
1251
        pop     $r1
1252
        push    $r3
1253
        jmp     two_lit
1254

1255
fheader "2r@"
1256
        ldi     $r1,$sp,8
1257
        ldi     $r2,$sp,4
1258
        jmp     two_lit
1259

1260
_dummy: .long   0
1261

1262
header  ":noname",colon_noname
1263
        ldk     $r1,_dummy             /* So that ';' will unsmudge nothing */
1264
        sta     tosmudge,$r1
1265
        lda     $r1,cp
1266
        sta     thisxt,$r1
1267
        call    push_r1
1268
        jmp     right_bracket
1269

1270
fheader "<>"
1271
        _r1_n
1272
        cmp     $r0,$r1
1273
        bexts   $r0,$r30,(1<<5)|0
1274
        xor     $r0,$r0,-1
1275
        return
1276

1277
header  "?do",question_do,1
1278
        lit     dodo
1279
        call    compile_comma
1280

1281
        call    sync
1282
        lda     $r1,cp
1283
        sta     leaves,$r1
1284
        call    false
1285
        call    jz_comma
1286
        jmp     begin
1287

1288
header  "again",again,1
1289
        call    check_compiling
1290
        jmp     jmp_comma
1291

1292

1293
header  "compile,",compile_comma
1294
        jmp     1f
1295
1:      lshr    $r0,$r0,2
1296
        lpm     $r1,_template_call
1297
        or      $r0,$r0,$r1
1298
        jmp     pm_comma
1299

1300

1301
header  "false",false
1302
        _dup
1303
        ldk     $r0,0
1304
        return
1305

1306
header  "nip",nip
1307
        add     $r27,$r27,4
1308
        return
1309

1310
header  "parse",parse
1311
        move    $r4,$r0
1312
        lda     $r0,_in
1313
        lda     $r1,sourceA
1314
        add     $r0,$r0,$r1
1315
        _dup
1316

1317
        ldk     $r0,-1
1318
        lda     $r2,_in
1319
        lda     $r3,sourceC
1320
       /* r0 is count */
1321
       /* r1 is sourceA */
1322
       /* r2 is >in */
1323
       /* r4 is char */
1324
parse_0:
1325
        add     $r0,$r0,1
1326
        cmp     $r3,$r2
1327
        jmpc    z,parse_1
1328
        add     $r5,$r1,$r2
1329
        ldi.b   $r5,$r5,0
1330
        add     $r2,$r2,1
1331
        cmp     $r4,$r5
1332
        jmpc    nz,parse_0
1333
parse_1:
1334
        sta     _in,$r2
1335
        return
1336

1337
fheader "pick"
1338
        ashl    $r0,$r0,2
1339
        add     $r0,$r0,$r27
1340
        ldi     $r0,$r0,0
1341
        return
1342
        
1343
fheader "query"
1344

1345
header  "refill",refill
1346
        lda     $r1,_source_id /* When the input source is a string from EVALUATE, return false */
1347
        cmp     $r1,-1
1348
        jmpc    z,false
1349

1350
        lit     tib
1351
        lit     256
1352
        call    accept
1353
        sta     sourceC,$r0
1354
        call    drop
1355
        sta     _in,$r25
1356
        jmp     true
1357

1358

1359
header  "roll",roll
1360
        ashl    $r1,$r0,2
1361
        _drop
1362
        add     $r1,$r1,$r27
1363
        move    $r2,$r27
1364
        jmp     2f
1365
1:      exi     $r0,$r2,0
1366
        add     $r2,$r2,4
1367
2:      cmp     $r1,$r2
1368
        jmpc    nz,1b
1369
        return
1370

1371

1372
header "(source-id)",paren_source_id_paren
1373
        lit     _source_id
1374
        return
1375

1376

1377
header  "true",true
1378
        _dup
1379
        ldk     $r0,-1
1380
        return
1381

1382

1383
fheader "u>"
1384
        _r1_n
1385
        cmp     $r1,$r0
1386
        bexts   $r0,$r30,(1<<5)|6
1387
        return
1388

1389
fheader "unused"
1390
        call    dupe
1391
        ldk     $r0,DSTACK_TOP-256
1392
        lda     $r1,dp
1393
        sub     $r0,$r0,$r1
1394
        return
1395

1396
#######   DOUBLE AND DOUBLE EXT   ####################################
1397

1398
header  "2literal",two_literal,1
1399
        call    swap
1400
        call    literal
1401
        jmp     literal
1402

1403
header  "2rot",two_rote        /* ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) */
1404
                               /*   16 12  8  4  0       16 12  8  4  0 */
1405
        exi     $r0,$r27,4
1406
        exi     $r0,$r27,12
1407

1408
        ldi     $r1,$r27,0
1409
        exi     $r1,$r27,8
1410
        exi     $r1,$r27,16
1411
        sti     $r27,0,$r1
1412
        return
1413
        
1414
header  "d+",d_plus
1415
                               /* $r0: ud2.hi */
1416
        ldi     $r1,$r27,0      /* $r1: ud2.lo */
1417
        ldi     $r2,$r27,4      /* $r2: ud1.hi */
1418
        ldi     $r3,$r27,8      /* $r3: ud1.lo */
1419
        addcc   $r1,$r3
1420
        bextu   $r4,$cc,(1<<5)|1
1421
        add     $r1,$r1,$r3
1422
        add     $r0,$r0,$r2
1423
        add     $r0,$r0,$r4
1424
        add     $r27,$r27,8
1425
        sti     $r27,0,$r1
1426
        return
1427

1428
header  "d-",d_minus
1429
        call    d_negate
1430
        jmp     d_plus
1431

1432
header  "d0<",d_zero_less
1433
        add     $r27,$r27,4
1434
        ashr    $r0,$r0,31
1435
        return
1436

1437
header  "d0=",d_zero_equals
1438
        _r1_n
1439
        or      $r0,$r0,$r1
1440
        cmp     $r0,0
1441
        bexts   $r0,$r30,(1<<5)|0
1442
        return
1443
        
1444
header  "d2*",d_two_star
1445
        ldi     $r1,$r27,0
1446
        lshr    $r2,$r1,31
1447
        ashl    $r0,$r0,1
1448
        ashl    $r1,$r1,1
1449
        or      $r0,$r0,$r2
1450
        sti     $r27,0,$r1
1451
        return
1452

1453
header  "d2/",d_two_slash
1454
        ldi     $r1,$r27,0
1455
        ashl    $r2,$r0,31
1456
        ashr    $r0,$r0,1
1457
        lshr    $r1,$r1,1
1458
        or      $r1,$r1,$r2
1459
        sti     $r27,0,$r1
1460
        return
1461

1462
header  "d<",d_less_than
1463
                                /* $r0: ud2.hi */
1464
        ldi     $r2,$r27,4      /* $r2: ud1.hi */
1465
        cmp     $r0,$r2
1466
        jmpc    nz,1f
1467
        ldi     $r1,$r27,0      /* $r1: ud2.lo */
1468
        ldi     $r3,$r27,8      /* $r3: ud1.lo */
1469
        cmp     $r1,$r3
1470
        add     $r27,$r27,12
1471
        bexts   $r0,$cc,(1<<5)|6
1472
        return
1473
1:
1474
        add     $r27,$r27,12
1475
        bexts   $r0,$cc,(1<<5)|5
1476
        return
1477

1478
header  "d=",d_equals
1479
        ldi     $r2,$r27,4      /* $r2: ud1.hi */
1480
        xor     $r0,$r0,$r2
1481
        ldi     $r1,$r27,0      /* $r1: ud2.lo */
1482
        ldi     $r3,$r27,8      /* $r3: ud1.lo */
1483
        xor     $r1,$r1,$r3
1484
        or      $r0,$r0,$r1
1485
        cmp     $r0,0
1486
        add     $r27,$r27,12
1487
        bexts   $r0,$cc,(1<<5)|0
1488
        return
1489

1490
header  "d>s",d_to_s
1491
        jmp     drop
1492

1493
header  "dabs",d_abs
1494
        cmp     $r0,0
1495
        jmpc    lt,d_negate
1496
        return
1497

1498
header  "dnegate",d_negate
1499
        ldi     $r1,$r27,0
1500
        xor     $r0,$r0,-1
1501
        xor     $r1,$r1,-1
1502
        add     $r1,$r1,1
1503
        cmp     $r1,0
1504
        jmpc    nz,d_negate_1
1505
        add     $r0,$r0,1
1506
d_negate_1:
1507
        sti     $r27,0,$r1
1508
        return
1509

1510
header  "du<",d_u_less         /* ( ud1 ud2 -- flag ) */
1511
                               /* $r0: ud2.hi */
1512
        ldi     $r2,$r27,4      /* $r2: ud1.hi */
1513
        cmp     $r2,$r0
1514
        jmpc    nz,known$
1515
        ldi     $r1,$r27,0      /* $r1: ud2.lo */
1516
        ldi     $r3,$r27,8      /* $r3: ud1.lo */
1517
        cmp     $r3,$r1
1518
known$:
1519
        add     $r27,$r27,12
1520
        bexts   $r0,$cc,(1<<5)|1
1521
        return
1522

1523
#######   ANS TOOLS AND TOOLS EXT   ##################################
1524

1525
header  "ahead",ahead,1
1526
        call    check_compiling
1527
        call    false
1528
        call    jmp_comma
1529
        jmp     forward
1530

1531
#######   EXCEPTION   ################################################
1532

1533
header  "catch",catch  /* ( xt -- exception# | 0 ) */
1534
        push_source_spec
1535
        push    $r27
1536
        lda     $r1,handler
1537
        push    $r1
1538
        sta     handler,$sp
1539
        call    execute
1540
        pop     $r1
1541
        sta     handler,$r1
1542
        pop     $r1
1543
        add     $sp,$sp,source_spec_size
1544
        jmp     false
1545

1546
header  "throw",throw
1547
        cmp     $r0,0
1548
        jmpc    z,drop
1549
        lda     $sp,handler
1550
        pop     $r1
1551
        sta     handler,$r1
1552
        pop     $r27
1553
        pop_source_spec
1554
        return
1555

1556
header  "ithrow",ithrow        /* THROW from an interrupt handler */
1557
        ldk     $r1,throw
1558
        push    $r1
1559
        reti
1560

1561
#######   STRING   ###################################################
1562

1563
header  "/string",slash_string
1564
        move    $r2,$r0
1565
        _drop
1566
        sub     $r0,$r0,$r2
1567
        ldi     $r1,$r27,0
1568
        add     $r1,$r1,$r2
1569
        sti     $r27,0,$r1
1570
        return
1571

1572
header  "cmove",cmove
1573
        ldi     $r1,$r27,4
1574
        ldi     $r2,$r27,0
1575
        memcpy.b $r2,$r1,$r0
1576
        ldi     $r0,$r27,8
1577
        add     $r27,$r27,12
1578
        return
1579

1580
header  "cmove>",cmove_up
1581
        ldi     $r1,$r27,4      /*  */
1582
        add     $r1,$r1,$r0    /* $r1: srcptr */
1583
        ldi     $r2,$r27,0      /* $r2: dst */
1584
        add     $r3,$r2,$r0    /* $r3: dstptr */
1585
        jmp     cmove_up_1
1586

1587
cmove_up_0:
1588
        sub     $r1,$r1,1
1589
        sub     $r3,$r3,1
1590
        ldi.b   $r4,$r1,0
1591
        sti.b   $r3,0,$r4
1592
cmove_up_1:
1593
        cmp     $r2,$r3
1594
        jmpc    nz,cmove_up_0
1595

1596
        ldi     $r0,$r27,8
1597
        add     $r27,$r27,12
1598
        return
1599

1600
header  "compare",compare
1601
       /* ( c-addr1 u1 c-addr2 u2 -- n ) */
1602
                               /* $r0: u2 */
1603
        ldi     $r1,$r27,0      /* $r1: addr2 */
1604
        ldi     $r2,$r27,4      /* $r2: u1 */
1605
        ldi     $r3,$r27,8      /* $r3: addr1 */
1606
        add     $r27,$r27,12
1607

1608
        cmp     $r0,$r2
1609
        jmpc    z,2f
1610
        jmpc    b,1f
1611

1612
       /* u2 is larger */
1613
        add     $r2,$r2,$r3
1614
        ldk     $r0,-1
1615
        jmp     4f
1616

1617
1:
1618
        add     $r2,$r0,$r3
1619
        ldk     $r0,1
1620
        jmp     4f
1621

1622
2:
1623
        add     $r2,$r0,$r3
1624
        ldk     $r0,0
1625
        jmp     4f
1626

1627
3:
1628
        ldi.b   $r4,$r1,0
1629
        ldi.b   $r5,$r3,0
1630
        cmp     $r5,$r4
1631
        jmpc    nz,5f
1632
        add     $r1,$r1,1
1633
        add     $r3,$r3,1
1634

1635
4:
1636
        cmp     $r2,$r3
1637
        jmpc    nz,3b
1638
        return
1639

1640
5:
1641
        sub     $r0,$r5,$r4
1642
        ashr    $r0,$r0,31
1643
        or      $r0,$r0,1
1644
        return
1645

1646
        .macro  tolower r
1647
        cmp     \r,'z'
1648
        jmpc    gt,9f
1649
        cmp     \r,'a'
1650
        jmpc    lt,9f
1651
        add     \r,\r,'A'-'a'
1652
9:
1653
        .endm
1654

1655
header  "icompare",icompare
1656
       /* ( c-addr1 u1 c-addr2 u2 -- n ) */
1657
                               /* $r0: u2 */
1658
        ldi     $r1,$r27,0      /* $r1: addr2 */
1659
        ldi     $r2,$r27,4      /* $r2: u1 */
1660
        ldi     $r3,$r27,8      /* $r3: addr1 */
1661
        add     $r27,$r27,12
1662

1663
        cmp     $r0,$r2
1664
        jmpc    z,2f
1665
        jmpc    b,1f
1666

1667
       /* u2 is larger */
1668
        add     $r2,$r2,$r3
1669
        ldk     $r0,-1
1670
        jmp     4f
1671

1672
1:
1673
        add     $r2,$r0,$r3
1674
        ldk     $r0,1
1675
        jmp     4f
1676

1677
2:
1678
        add     $r2,$r0,$r3
1679
        ldk     $r0,0
1680
        jmp     4f
1681

1682
3:
1683
        ldi.b   $r4,$r1,0
1684
        ldi.b   $r5,$r3,0
1685
        tolower $r4
1686
        tolower $r5
1687
        cmp     $r5,$r4
1688
        jmpc    nz,5f
1689
        add     $r1,$r1,1
1690
        add     $r3,$r3,1
1691

1692
4:
1693
        cmp     $r2,$r3
1694
        jmpc    nz,3b
1695
        return
1696

1697
5:
1698
        sub     $r0,$r5,$r4
1699
        ashr    $r0,$r0,31
1700
        or      $r0,$r0,1
1701
        return
1702

1703
#######   ASSEMBLER   ################################################
1704

1705
_template_jmp:          jmp     0
1706
_template_call:         call    0
1707
_template_return:       return
1708
_template_ldk_r0:       ldk     $r0,0
1709
_template_ldl_r0:       ldl     $r0,$r0,0
1710
_template_jz:           jmpc    z,0
1711
_template_inc28:        add     $r28,$r28,1
1712
_template_j28m:         jmpx    31,$r28,1,0
1713
_template_jnc:          jmpc    nc,0
1714

1715
jmp_comma:
1716
        lshr    $r0,$r0,2
1717
        lpm     $r1,_template_jmp
1718
        or      $r0,$r0,$r1
1719
        jmp     code_comma
1720

1721
jz_comma:
1722
        lshr    $r0,$r0,2
1723
        lpm     $r1,_template_jz
1724
        or      $r0,$r0,$r1
1725
        jmp     code_comma
1726

1727
#######   UART   #####################################################
1728

1729
header  "setpad",setpad        /* ( u n -- )  Set chip pad n to function u */
1730
        ldk     $r1,0x1001c
1731
        add     $r0,$r0,$r1
1732
        ldi     $r1,$r27,0
1733
        sti.b   $r0,0,$r1
1734
        jmp     two_drop
1735

1736
orbang:
1737
        ldi     $r1,$r27,0
1738
        ldi     $r2,$r0,0
1739
        or      $r1,$r1,$r2
1740
        sti     $r0,0,$r1
1741
        jmp     two_drop
1742

1743
uart.idx:
1744
        lit     uart1_spr
1745
        call    c_store
1746
        lit     uart1_icr
1747
        jmp     c_store
1748

1749
        .equ    CPR,    1
1750
        .equ    TCR,    2
1751

1752
uart.start:
1753
        lit     0x0010
1754
        lit     sys_regclkcfg
1755
        call    orbang
1756

1757
        lit     0x08
1758
        lit     CPR
1759
        call    uart.idx
1760
        lit     4
1761
        lit     TCR
1762
        call    uart.idx
1763

1764
       /* Enable pad for UART bit [7:6] */
1765
        lit     0xc0
1766
        lit     48
1767
        call    setpad
1768

1769
        lit     0xc0
1770
        lit     49
1771
        call    setpad
1772

1773
        lit     0x28
1774
        lit     sys_regmsc0cfg_b2
1775
        call    c_store
1776

1777
        lit     0x83
1778
        lit     uart1_lcr
1779
        call    c_store
1780

1781
        lit     217 / 8
1782
       /* lit     195 / 8 */
1783
        lit     uart1_dll
1784
        call    c_store
1785

1786
        lit     0
1787
        lit     uart1_dlm
1788
        call    c_store
1789

1790
        lit     0x03
1791
        lit     uart1_lcr
1792
        call    c_store
1793

1794
        lit     0x00
1795
        lit     uart1_fcr
1796
        call    c_store
1797

1798
        lit     0x02
1799
        lit     uart1_mcr
1800
        jmp     c_store
1801

1802
header  "uart-emit",uart_emit
1803
        .if SIMULATOR == 1
1804
                sta.b   0x10000,$r0
1805
        .else
1806
                lda.b   $r1,0x10325
1807
                tst.b   $r1,(1<<5)
1808
                jmpc    z,uart_emit
1809
                sta.b   0x10320,$r0
1810
        .endif
1811
        jmp     drop
1812

1813
header  "uart-key",uart_key
1814
        _dup
1815
        .if SIMULATOR == 1
1816
                lda.b   $r0,0x10000
1817
                cmp.b   $r0,255
1818
                jmpc    nz,1f
1819
                ldk     $r0,0
1820
                sta     0x1fffc,$r0
1821
1:
1822
        .else
1823
key_1:
1824
                lda.b   $r1,0x10325
1825
                tst.b   $r1,(1<<0)
1826
                jmpc    z,key_1
1827
                lda.b   $r0,0x10320
1828
        .endif
1829
        return
1830

1831
#######   CHARACTER I/O   ############################################
1832

1833
default_emit:
1834
        jmp     uart_emit
1835

1836
header  "emit",emit
1837
        jmp     uart_emit
1838

1839
header  "key",key
1840
        jmp     uart_key
1841

1842
header  ".x",hex8
1843
        call    dupe
1844
        lshr    $r0,$r0,16
1845
        call    hex4
1846
hex4:
1847
        call    dupe
1848
        lshr    $r0,$r0,8
1849
        call    hex2
1850
hex2:
1851
        call    dupe
1852
        lshr    $r0,$r0,4
1853
        call    digit
1854
digit:
1855
        and     $r0,$r0,15
1856
        cmp     $r0,10
1857
        ldk     $r1,'0'
1858
        jmpc    lt,hex1a
1859
        ldk     $r1,'a'-10
1860
hex1a:  add     $r0,$r0,$r1
1861
        jmp     emit
1862

1863
#######   FT900   ####################################################
1864

1865
header  "digitalwrite",digitalWrite    /* ( val pin -- ) */
1866
        ldi     $r1,$r27,0
1867

1868
        tst     $r0,0x20
1869
        jmpc    nz,1f
1870
        tst     $r0,0x40
1871
        jmpc    nz,2f
1872

1873
        or      $r0,$r0,1<<5           /* $r0 is the bitfield spec for bins */
1874

1875
        ldl     $r1,$r1,$r0
1876
        bins    $r20,$r20,$r1
1877
        sta     0x10084,$r20
1878
        _2drop
1879
        return
1880

1881
1:     /* For GPIO32-63, $r0 is *already* bitfield spec! */
1882
        ldl     $r1,$r1,$r0
1883
        bins    $r21,$r21,$r1
1884
        sta     0x10088,$r21
1885
        _2drop
1886
        return
1887

1888
2:      /* For GPIO64+, flip r0 bits 5+6 */
1889
        xor     $r0,$r0,3<<5           /* $r0 is the bitfield spec for bins */
1890
        ldl     $r1,$r1,$r0
1891
        bins    $r22,$r22,$r1
1892
        sta     0x1008c,$r22
1893
        _2drop
1894
        return
1895

1896
header  "digitalread",digitalRead    /* ( pin -- val ) */
1897
        tst     $r0,0x60
1898
        jmpc    nz,1f
1899

1900
        or      $r0,$r0,1<<5           /* $r0 is the bitfield spec for bexts */
1901
        lda     $r1,0x10084
1902
        bexts   $r0,$r1,$r0
1903
        return
1904

1905
1:      tst     $r0,0x40
1906
        jmpc    nz,2f
1907
        /* For GPIO32-63, $r0 is *already* bitfield spec! */
1908
        lda     $r1,0x10088
1909
        bexts   $r0,$r1,$r0
1910
        return
1911

1912
2:      /* For GPIO64+, flip r0 bits 5+6 */
1913
        xor     $r0,$r0,0x60           /* $r0 is the bitfield spec for bexts */
1914
        lda     $r1,0x1008c
1915
        bexts   $r0,$r1,$r0
1916
        return
1917

1918

1919
fheader  "streamin"             # ( dst ioddr n -- )
1920
        ldi     $r1,$r27,0
1921
        ldi     $r2,$r27,4
1922
        streamin.l $r2,$r1,$r0
1923
        ldi     $r0,$r27,8
1924
        add     $r27,$r27,12
1925
        return
1926

1927
fheader  "streamin.b"           # ( dst ioddr n -- )
1928
        ldi     $r1,$r27,0
1929
        ldi     $r2,$r27,4
1930
        streamin.b $r2,$r1,$r0
1931
        ldi     $r0,$r27,8
1932
        add     $r27,$r27,12
1933
        return
1934

1935
fheader  "streamout"
1936
        ldi     $r1,$r27,0
1937
        ldi     $r2,$r27,4
1938
        streamout.l $r2,$r1,$r0
1939
        ldi     $r0,$r27,8
1940
        add     $r27,$r27,12
1941
        return
1942

1943
fheader  "streamout.b"
1944
        ldi     $r1,$r27,0
1945
        ldi     $r2,$r27,4
1946
        streamout.b $r2,$r1,$r0
1947
        ldi     $r0,$r27,8
1948
        add     $r27,$r27,12
1949
        return
1950

1951
header  "flip",_flip
1952
        _r1_n
1953
        flip    $r0,$r1,$r0
1954
        return
1955

1956
#######   PROGRAM MEMORY   ###########################################
1957

1958
pm_cold:
1959
        lpm     $r1,magic
1960
        sta     PM_UNLOCK,$r1
1961
        return
1962
magic: .long   0x1337f7d1
1963

1964
header  "pm!", pm_store
1965
        ldi     $r1,$r27,0
1966
        sta     PM_ADDR,$r0
1967
        sta     PM_DATA,$r1
1968
        _2drop
1969
        return
1970

1971
header  "pm@", pm_fetch
1972
        lpmi    $r0,$r0,0
1973
        return
1974

1975
header  "pmc@", pm_c_fetch
1976
        lpmi.b  $r0,$r0,0
1977
        return
1978

1979
fheader "words"
1980
        call    false
1981

1982
words_a:
1983
        call    cr
1984
        call    dupe
1985
        ashl    $r0,$r0,2
1986
        ldi     $r0,$r0,searchlist
1987
        ldi     $r0,$r0,4
1988
        jmp     words_2
1989

1990
words_0:
1991
        call    dupe
1992
        lpmi    $r1,$r0,0
1993
        add     $r0,$r0,4
1994

1995
        # was once useful to mark immediate words with $...
1996
        # tst     $r1,1
1997
        # jmpc    z,emitword
1998
        # lit     '$'
1999
        # call    emit
2000
        jmp     emitword
2001
words_1:
2002
        call    emit
2003
        add     $r0,$r0,1
2004
emitword:
2005
        call    dupe
2006
        lpmi.b  $r0,$r0,0
2007
        cmp     $r0,0
2008
        jmpc    nz,words_1
2009
        call    space
2010
        call    two_drop
2011

2012
        lpmi    $r0,$r0,0
2013
        ldk     $r1,0x3ffff
2014
        ashl    $r1,$r1,2
2015
        and     $r0,$r0,$r1
2016
words_2:
2017
        cmp     $r0,0
2018
        jmpc    nz,words_0
2019

2020
        call    drop
2021

2022
        add     $r0,$r0,1
2023
        lda     $r1,nsearch
2024
        cmp     $r0,$r1
2025
        jmpc    lt,words_a
2026
        jmp     drop
2027

2028
# DEFER! ( xt2 xt1 -- ) CORE-EXT
2029
#
2030
# Set the word xt1 to execute xt2.
2031
#
2032
header  "defer!",defer_store
2033
        call    swap
2034
        lshr    $r0,$r0,2
2035
        lpm     $r1,_template_jmp
2036
        or      $r0,$r0,$r1
2037
        call    swap
2038

2039
        jmp     pm_store
2040

2041
#######   SEARCH   ###################################################
2042

2043
iheader "ctx",internal_context
2044
        lit     context_0
2045
        lit     context_1-context_0
2046
        return
2047

2048
iheader  "_wl",_wl
2049
        lit     wordlists
2050
        return
2051

2052
header  "forth-wordlist",forth_wordlist
2053
        lit     forth
2054
        return
2055

2056
header  "internal-wordlist",internal_wordlist
2057
        lit     internal
2058
        return
2059

2060
header  "get-order",get_order
2061
        _dup
2062
        lda     $r0,nsearch
2063
        ashl    $r1,$r0,2
2064
        sub     $r27,$r27,$r1
2065
        ldk     $r2,searchlist
2066
        memcpy.l $r27,$r2,$r1
2067
        return
2068

2069
header  "set-order",set_order
2070
        sta     nsearch,$r0
2071
        ashl    $r1,$r0,2
2072
        ldk     $r2,searchlist
2073
        memcpy  $r2,$r27,$r1
2074
        add     $r27,$r27,$r1
2075
        jmp     drop
2076

2077
header  "get-current",get_current
2078
        _dup
2079
        lda     $r0,cwl
2080
        return
2081

2082
header  "set-current",set_current
2083
        sta     cwl,$r0
2084
        jmp     drop
2085

2086
header  "definitions",definitions
2087
        lda     $r1,searchlist
2088
        sta     cwl,$r1
2089
        return
2090

2091
header  "search-wordlist",search_wordlist
2092

2093
        move    $r9,$r0
2094
        _drop
2095

2096
        move    $r3,$r0
2097
        ldk     $r1,aname
2098
        add     $r1,$r1,$r0
2099
        sti     $r1,0,$r25
2100

2101
        ldk     $r2,aname
2102
        ldi     $r1,$r27,0
2103
        memcpy.b $r2,$r1,$r0
2104

2105
        call    lower_aname
2106

2107
        call    lookup
2108
        cmp     $r9,0
2109
        jmpc    nz,search_wordlist_1
2110
        call    two_drop
2111
        jmp     false
2112

2113
search_wordlist_1:
2114
        and     $r1,$r1,~3
2115
        sti     $r27,0,$r1
2116
        lpmi    $r0,$r9,0
2117
        and     $r0,$r0,1      /* 0 -> -1, 1 -> 1 */
2118
        cmp     $r0,1
2119
        jmpc    z,search_wordlist_2
2120
        ldk     $r0,-1
2121
search_wordlist_2:
2122
        return
2123

2124
header  "source",source
2125
        _dup
2126
        lda     $r0,sourceA
2127
        _dup
2128
        lda     $r0,sourceC
2129
        return
2130

2131
header  "tosource",tosource
2132
        sta     sourceC,$r0
2133
        call    drop
2134
        sta     sourceA,$r0
2135
        jmp     drop
2136

2137
fheader ">in"
2138
        lit     _in
2139
        return
2140

2141
fheader ">inwas"
2142
        lit     _inwas
2143
        return
2144

2145
#######   FLOAT   ####################################################
2146

2147
fheader "fdup"
2148
        ldi     $r2,$r26,0
2149
fpush:                                  # Push $r2 on the fp-stack
2150
        sub     $r26,$r26,4
2151
        sti     $r26,0,$r2
2152
        return
2153

2154
fheader "fdrop"
2155
        add     $r26,$r26,4
2156
        return
2157

2158
fheader "fswap"
2159
        ldi     $r1,$r26,0
2160
        exi     $r1,$r26,4
2161
        sti     $r26,0,$r1
2162
        return
2163

2164
fheader "f0<"
2165
        _dup
2166
        ldi     $r0,$r26,0
2167
        add     $r26,$r26,4
2168
        bexts   $r0,$r0,(1<<5)|31
2169
        return
2170

2171
header  "f<",f_less
2172
        _dup
2173
        ldi     $r1,$r26,0
2174
        ldi     $r0,$r26,4
2175
        add     $r26,$r26,8
2176

2177
        call    __cmpsf2_       # -1 0 1
2178
        ashr    $r0,$r0,31      # 0 0 -1
2179
        return
2180

2181
fheader "fabs"
2182
        ldi     $r1,$r26,0
2183
        bins    $r1,$r1,(1<<5)|31
2184
        sti     $r26,0,$r1
2185
        return
2186

2187
header  "(fliteral)",_fliteral
2188
        pop     $r1
2189
        lpmi    $r2,$r1,0
2190
        add     $r1,$r1,4
2191
        sub     $r26,$r26,4
2192
        sti     $r26,0,$r2
2193
        jmpi    $r1
2194

2195
header  "fliteral",fliteral,1
2196
        lit     _fliteral
2197
        call    compile_comma
2198
        call    sync
2199
        call    f_from
2200
        call    pm_comma
2201
        jmp     sync
2202

2203
fheader  "fdepth"
2204
        call    dupe
2205
        ldk     $r0,FSTACK_TOP
2206
        sub     $r0,$r0,$r26
2207
        ashr    $r0,$r0,2
2208
        return
2209

2210
header  "s>f",s_to_f
2211
        call    __floatsisf
2212
_to_f:
2213
        sub     $r26,$r26,4
2214
        sti     $r26,0,$r0
2215
        jmp     drop
2216

2217
header  "us>f",us_to_f
2218
        call    __floatunsisf
2219
        jmp     _to_f
2220

2221
header  "f>",f_from
2222
        call    dupe
2223
        ldi     $r0,$r26,0
2224
        add     $r26,$r26,4
2225
        return
2226

2227
header  ">f",to_f
2228
        jmp     _to_f
2229

2230
header  "fnegate",f_negate
2231
        ldi     $r1,$r26,0
2232
        bins    $r2,$r25,-512|(1<<5)|31  # r2 = 80000000
2233
        xor     $r1,$r1,$r2
2234
        sti     $r26,0,$r1
2235
        return
2236

2237
header  "f+",f_plus
2238
        push    $r0
2239
        ldi     $r1,$r26,0
2240
        ldi     $r0,$r26,4
2241

2242
        call    __addsf3
2243
_f2:                                    # handle result of 2-ary operator
2244
        add     $r26,$r26,4
2245
        sti     $r26,0,$r0
2246
        pop     $r0
2247
        return
2248

2249
header  "f-",f_minus
2250
        push    $r0
2251
        ldi     $r1,$r26,0
2252
        ldi     $r0,$r26,4
2253
        call    __subsf3
2254
        jmp     _f2
2255

2256
header  "f*",f_mul
2257
        push    $r0
2258
        ldi     $r1,$r26,0
2259
        ldi     $r0,$r26,4
2260
        call    __mulsf3
2261
        jmp     _f2
2262

2263
header  "f/",f_div
2264
        push    $r0
2265
        ldi     $r1,$r26,0
2266
        ldi     $r0,$r26,4
2267
        call    __divsf3
2268
        jmp     _f2
2269

2270
        .include "float.s"
2271

2272
header  "f>d",f_to_d
2273
        sub     $r27,$r27,8
2274
        sti     $r27,4,$r0
2275

2276
        ldi     $cc,$r26,0
2277
        add     $r26,$r26,4
2278

2279
        jmpx    31,$cc,0,0f
2280

2281
        call    0f
2282
        jmp     d_negate
2283

2284
0:
2285
        ashl    $r2,$cc,8               # mantissa left-justified in r2...
2286
        bins    $r2,$r2,-512|(1 << 5)|31 # ...with implied bit set
2287
        bextu   $r3,$cc,(8<<5)|23       # exponent in r3
2288

2289
        # exponent      lo                      hi
2290
        # --------      --                      --
2291
        # <127          0                       0
2292
        # 127           m>>31                   0
2293
        # ...
2294
        # 158           m>>0                    0
2295
        # 159           m<<1                    m>>31
2296
        # ...
2297
        # 189           m<<31                   m>>1
2298
        # 190           --------  overflow  --------
2299
        #
2300
        # So a little algebra gives three cases:
2301
        #
2302
        # exponent      lo                      hi
2303
        # --------      --                      --
2304
        # <127          0                       0
2305
        # 127 .. 158    m>>(158-e)              0
2306
        # 159 .. 189    m<<(e-158)              m>>(190-e)
2307
        # >=190         --------  overflow  --------
2308

2309
        cmp     $r3,127
2310
        jmpc    gte,1f
2311
        ldk     $r1,0                   # lo
2312
        ldk     $r0,0                   # hi
2313
        jmp     3f
2314

2315
1:      cmp     $r3,158
2316
        jmpc    gt,2f
2317

2318
        ldk     $r4,158                 # 
2319
        sub     $r4,$r4,$r3
2320
        lshr    $r1,$r2,$r4             # lo
2321
        ldk     $r0,0                   # hi
2322
        jmp     3f
2323

2324
2:      sub     $r4,$r3,158
2325
        ashl    $r1,$r2,$r4             # lo
2326
        ldk     $r4,190
2327
        sub     $r4,$r4,$r3
2328
        lshr    $r0,$r2,$r4
2329
3:
2330
        sti     $r27,0,$r1
2331
        return
2332

2333
#######   SYSTEM VARIABLES   #########################################
2334

2335
        .section        .bss
2336

2337
        .set    ramhere,0
2338

2339
        .macro  allot   name size
2340
        .equ    \name,ramhere
2341
        .set    ramhere,ramhere+\size
2342
        .endm
2343

2344
        allot   guardian,4      /*  */
2345
        allot   context_0,0
2346
        allot   dp,4            /* RAM data pointer */
2347
        allot   cp,4            /* Code pointer */
2348
        allot   cwl,4           /* Compilation word list */
2349
        allot   wordlists,4     /* All word lists */
2350
        allot   nsearch,4       /* Number of word lists in searchlist */
2351
        allot   searchlist,4*16 /* search list */
2352
        allot   context_1,0
2353
        allot   forth,8         /* Forth word list */
2354
        allot   internal,8      /* Internal word list */
2355
        allot   handler,4       /* exception handler */
2356
        allot   aname,32        /* name buffer, used during dictionary search */
2357
        allot   tib,256         /* terminal input buffer */
2358
        allot   sourceA,4       /* tib+1 */
2359
        allot   sourceC,4        #
2360
        allot   _in,4           /* >IN */
2361
        allot   _inwas,4        /* >IN at start of previous word */
2362
        allot   recent,4        /* most recent CREATE */
2363
        allot   thisxt,4        /* most recent xt */
2364
        allot   tosmudge,4      /* smudge point, usually xt-4 */
2365
        allot   leaves,4        /* chain of LEAVE pointers */
2366
        allot   _source_id,4
2367
        allot   _state,4
2368
        allot   _base,4
2369
        allot   _tethered,4
2370

2371
__end:
2372
        .section        .text
2373

2374
#######   OUTER INTERPRETER   ########################################
2375

2376
header  "report",report        /* ( u -- 0 ) describe error u */
2377
        jmp     drop
2378

2379
# QUIT implementation based on ANS A.9
2380

2381
header  "quit",quit
2382
        ldk     $sp,0xfffc              # XXX
2383

2384
        sta     _source_id,$r25
2385

2386
        call    left_bracket
2387

2388
quit_0:
2389
        lit     repl
2390
        call    catch
2391
        cmp     $r0,0
2392
        jmpc    z,quit_ok
2393

2394
        call    report
2395
        jmp     quit
2396

2397
repl:
2398
        lit     tib
2399
        call    dupe
2400
        lit     256
2401
        call    accept
2402
        call    tosource
2403

2404
        call    space
2405

2406
        sta     _in,$r25
2407
        jmp     interpret
2408

2409
quit_ok:
2410
        call    drop
2411
        call    space
2412
        lit     'o'
2413
        call    emit
2414
        lit     'k'
2415
        call    emit
2416
        call    cr
2417
        jmp     quit_0
2418

2419
header  "hook-number",hook_number
2420
        lit     -13                    /* undefined word ( ANS spec. section 9.3.5 ) */
2421
        call    throw
2422

2423
isvoid:
2424
        call    nip
2425
        call    do0cmp
2426
        jmpc    z,1f
2427
        call    two_drop
2428
        call    hook_number
2429
        pop     $r1
2430
        pop     $r1
2431
1:      return
2432

2433
# consume1  ( caddr u -- caddr' u' )
2434
# if string starts with $r2, bump character and return NZ
2435

2436
consume1:
2437
        ldi     $r3,$r27,0
2438
        ldi.b   $r1,$r3,0
2439
        cmp.b   $r2,$r1
2440
        jmpc    z,1f
2441
0:
2442
        cmp     $r0,$r0                 # Set Z
2443
        return
2444
1:
2445
        cmp     $r0,0
2446
        jmpc    z,0b
2447
        sub     $r0,$r0,1
2448
        add     $r3,$r3,1
2449
        sti     $r27,0,$r3
2450
        return
2451

2452
doubleAlso2:
2453
        lit     0
2454
        lit     0
2455
        call    two_swap
2456
        ldk     $r2,'-'
2457
        call    consume1
2458
        push    $cc
2459
        call    to_number
2460
        ldk     $r2,'.'
2461
        call    consume1
2462
        jmpc    z,1f
2463
        call    isvoid
2464
        pop     $cc
2465
        callc   nz,d_negate
2466
        lit     two_literal
2467
        return
2468
1:
2469
        call    isvoid
2470
        _drop
2471
        pop     $cc
2472
        callc   nz,negate
2473
        lit     literal
2474
        return
2475

2476
# Set BASE to $r2, call doubleAlso2, restore BASE
2477
baseDoubleAlso2:
2478
        lda     $r1,_base
2479
        push    $r1
2480
        sta     _base,$r2
2481
        lit     doubleAlso2
2482
        call    catch
2483
        pop     $r1
2484
        sta     _base,$r1
2485
        jmp     throw
2486

2487
doubleAlso1:
2488
        ldk     $r2,'$'
2489
        call    consume1
2490
        ldk     $r2,16
2491
        jmpc    nz,baseDoubleAlso2
2492

2493
        ldk     $r2,'#'
2494
        call    consume1
2495
        ldk     $r2,10
2496
        jmpc    nz,baseDoubleAlso2
2497

2498
        ldk     $r2,'%'
2499
        call    consume1
2500
        ldk     $r2,2
2501
        jmpc    nz,baseDoubleAlso2
2502

2503
        cmp     $r0,3
2504
        jmpc    nz,doubleAlso2
2505
        ldi     $r1,$r27,0
2506
        ldi.b   $r2,$r1,0
2507
        cmp     $r2,'\''
2508
        jmpc    nz,doubleAlso2
2509
        ldi.b   $r2,$r1,2
2510
        cmp     $r2,'\''
2511
        jmpc    nz,doubleAlso2
2512

2513
        call    drop
2514
        ldi.b   $r0,$r0,1
2515
        lit     literal
2516
        return
2517

2518
doubleAlso:
2519
        call    doubleAlso1
2520
        jmp     drop
2521

2522
doubleAlso_comma:
2523
        call    doubleAlso1
2524
        jmp     execute
2525

2526
dispatch:
2527
        jmp     execute                 #      -1      0       non-immediate
2528
        jmp     doubleAlso              #      0       0       number
2529
        jmp     execute                 #      1       0       immediate
2530

2531
        jmp     compile_comma           #      -1      2       non-immediate
2532
        jmp     doubleAlso_comma        #      0       2       number
2533
        jmp     execute                 #      1       2       immediate
2534
        
2535
guardian:
2536
        .long   0x70617773
2537

2538
header  "interpret",interpret
2539
        lda     $r1,_in
2540
        sta     _inwas,$r1
2541
        call    parse_name
2542
        cmp     $r0,0
2543
        jmpc    z,two_drop
2544

2545
        call    sfind
2546
        lda     $r1,_state
2547
        add     $r0,$r0,$r1
2548
        ashl    $r0,$r0,2
2549
        ldk     $r1,(dispatch+4)
2550
        add     $r0,$r0,$r1
2551
        call    execute
2552

2553
        ldk     $r1,DSTACK_TOP
2554
        cmp     $r27,$r1
2555
        ldk     $r1,-4                 /* stack underflow */
2556
        jmpc    a,throw_r1
2557
        jmp     interpret
2558

2559
        lda     $r1,0
2560
        lpm     $r2,guardian
2561
        cmp     $r1,$r2
2562
        ldk     $r1,-9                 /* memory error */
2563
        jmpc    nz,throw_r1
2564

2565
        jmp     interpret
2566

2567
/*
2568
 *      PARSE-NAME  ( <spaces>name -- c-addr u )
2569

2570
 * Skip leading spaces and parse name delimited by a space. c-addr
2571
 * is the address within the input buffer and u is the length of the
2572
 * selected string. If the parse area is empty, the resulting string has
2573
 * a zero length.
2574
 */
2575

2576
header  "parse-name",parse_name
2577
        call    _skipspaces
2578
        _dup
2579
        lda     $r1,_in
2580
        lda     $r0,sourceA
2581
        add     $r0,$r0,$r1
2582
        call    _parse_word
2583
        _dup
2584
        move    $r0,$r3
2585
        return
2586

2587
_skipspaces:
2588
        lda     $r1,_in
2589
        lda     $r4,sourceC
2590
_skipspaces_0:
2591
        cmp     $r1,$r4
2592
        jmpc    z,_skipspaces_finish
2593
        lda     $r3,sourceA
2594
        add     $r3,$r3,$r1
2595
        ldi.b   $r2,$r3,0
2596
        cmp     $r2,' '
2597
        jmpc    a,_skipspaces_finish
2598
        add     $r1,$r1,1
2599
        jmp     _skipspaces_0
2600
_skipspaces_finish:
2601
        sta     _in,$r1
2602
        return
2603

2604
_parse_word:
2605
        /* Scan the current input buffer for a word
2606
         * $r3 is length, and word copied into aname
2607
         * if end of buffer, $r3 is zero.
2608
         */
2609

2610
        call    _skipspaces
2611

2612
        ldk     $r3,0                  /* Current ptr into aname */
2613
        ldk     $r2,aname
2614
        memset  $r2,$r25,32
2615
        lda     $r4,sourceC
2616

2617
_parse_word_loop:
2618
        lda     $r1,_in
2619
        cmp     $r1,$r4
2620
        jmpc    z,_parse_word_finish
2621

2622
        lda     $r5,sourceA
2623
        add     $r5,$r5,$r1
2624
        ldi.b   $r2,$r5,0
2625
        add     $r1,$r1,1
2626
        sta     _in,$r1
2627

2628
        cmp     $r2,' '
2629
        jmpc    be,_parse_word_finish
2630

2631
       /* append non-blank to aname */
2632
        sti.b   $r3,aname,$r2
2633
        add     $r3,$r3,1
2634
        jmp     _parse_word_loop
2635

2636
_parse_word_finish:
2637
        return
2638

2639
/*
2640

2641
SFIND
2642
        ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
2643

2644
        Find the definition named in the string at c-addr. If the
2645
        definition is not found, return c-addr and zero. If the definition
2646
        is found, return its execution token xt. If the definition is
2647
        immediate, also return one (1), otherwise also return minus-one
2648
        (-1).
2649

2650
*/
2651
header  "sfind",sfind
2652

2653
        move    $r3,$r0
2654
        ldk     $r1,aname
2655
        add     $r1,$r1,$r0
2656
        sti     $r1,0,$r25
2657

2658
        ldk     $r2,aname
2659
        ldi     $r1,$r27,0
2660
        memcpy.b $r2,$r1,$r0
2661

2662
        call    lower_aname
2663

2664
        ldk     $r2,0          /* $r2 counts through search order */
2665
sfind_0:
2666
        push    $r2
2667
        push    $r3
2668
        ashl    $r2,$r2,2
2669
        ldi     $r9,$r2,searchlist
2670
        call    lookup
2671
        pop     $r3
2672
        pop     $r2
2673
        cmp     $r9,0
2674
        jmpc    nz,sfind_1
2675

2676
        add     $r2,$r2,1      /* try next wordlist */
2677
        lda     $r4,nsearch
2678
        cmp     $r2,$r4
2679
        jmpc    lt,sfind_0
2680

2681
        jmp     false
2682
sfind_1:
2683
        and     $r1,$r1,~3
2684
        sti     $r27,0,$r1
2685
        lpmi    $r0,$r9,0
2686
        and     $r0,$r0,1      /* 0 -> -1, 1 -> 1 */
2687
        cmp     $r0,1
2688
        jmpc    z,sfind_2
2689
        ldk     $r0,-1
2690
sfind_2:
2691
        return
2692

2693
lookup:
2694
       /* On entry: */
2695
       /*       $r9     word list to search */
2696
       /*       a word of length $r3 at aname, 0x00 padded */
2697
       /* On exit:  */
2698
       /*       $r13    padded length (in bytes) */
2699
       /*       $r9     found word's link, or zero */
2700
       /*       $r1     found word's xt (if $r9 is nonzero) */
2701

2702
        add     $r13,$r3,4
2703
        and     $r13,$r13,~3
2704

2705
        lda     $r1,aname+0
2706
        lda     $r2,aname+4
2707
        lda     $r3,aname+8
2708
        lda     $r4,aname+12
2709
        lda     $r5,aname+16
2710
        lda     $r6,aname+20
2711
        lda     $r7,aname+24
2712
        lda     $r8,aname+28
2713

2714
        ldi     $r9,$r9,4
2715
        ldk     $r15,0x3ffff
2716
        ashl    $r15,$r15,2
2717

2718
       /* $r12 is comparison code */
2719
        mul     $r14,$r13,3            /* 3 instructions for each compare */
2720
        ldk     $r12,compare_0
2721
        sub     $r12,$r12,$r14
2722
        jmp     lookup_1
2723
nomatch:
2724
        lpmi    $r9,$r9,0
2725
        and     $r9,$r9,$r15
2726
lookup_1:
2727
        cmp     $r9,0
2728
        jmpic    nz,$r12
2729
endsearch:
2730
        return
2731

2732
compare_8:
2733
        lpmi    $r10,$r9,32
2734
        cmp     $r10,$r8
2735
        jmpc    nz,nomatch
2736
compare_7:
2737
        lpmi    $r10,$r9,28
2738
        cmp     $r10,$r7
2739
        jmpc    nz,nomatch
2740
compare_6:
2741
        lpmi    $r10,$r9,24
2742
        cmp     $r10,$r6
2743
        jmpc    nz,nomatch
2744
compare_5:
2745
        lpmi    $r10,$r9,20
2746
        cmp     $r10,$r5
2747
        jmpc    nz,nomatch
2748
compare_4:
2749
        lpmi    $r10,$r9,16
2750
        cmp     $r10,$r4
2751
        jmpc    nz,nomatch
2752
compare_3:
2753
        lpmi    $r10,$r9,12
2754
        cmp     $r10,$r3
2755
        jmpc    nz,nomatch
2756
compare_2:
2757
        lpmi    $r10,$r9,8
2758
        cmp     $r10,$r2
2759
        jmpc    nz,nomatch
2760
compare_1:
2761
        lpmi    $r10,$r9,4
2762
        cmp     $r10,$r1
2763
        jmpc    nz,nomatch
2764
compare_0:
2765
        add     $r1,$r9,4
2766
        add     $r1,$r1,$r13
2767
        jmp     endsearch
2768

2769
# Save the current pointers to PM so that they will be restored at reboot.
2770
# Append active RAM to the end of PM, so that it will be restored 
2771
# Return the end of the complete PM region
2772

2773
header  "commit",commit        /* ( -- pmend ) */
2774
        call    pmhere
2775
        lit     saved_pmdp
2776
        call    pm_store
2777

2778
        call    dupe
2779
        lda     $r0,dp
2780
        lit     saved_dp
2781
        call    pm_store
2782
        
2783
        call    dupe
2784
        lda     $r0,cp
2785
        sta     PM_ADDR,$r0
2786

2787
        ldk     $r0,PM_DATA
2788
        ldk     $r1,0
2789
        lda     $r2,dp
2790

2791
        streamout $r0,$r1,$r2
2792

2793
        lda     $r0,cp
2794
        add     $r0,$r0,$r2
2795

2796
        return
2797

2798
header  "pmhere",pmhere
2799
        call    dupe
2800
        lda     $r0,cp
2801
        return
2802

2803
header  "int-caller",int_caller
2804
        ldi     $r1,$sp,20*4
2805
        jmp     push_r1
2806

2807
# From Hacker's Delight, 2nd ed. p.195-196
2808
#
2809
# unsigned divlu2(unsigned u1, unsigned u0, unsigned v,
2810
#                 unsigned *r) {
2811
#    const unsigned b = 65536; // Number base (16 bits).
2812
#    unsigned un1, un0,        // Norm. dividend LSD's.
2813
#             vn1, vn0,        // Norm. divisor digits.
2814
#             q1, q0,          // Quotient digits.
2815
#             un32, un21, un10,// Dividend digit pairs.
2816
#             rhat;            // A remainder.
2817
#    int s;                    // Shift amount for norm.
2818
# 
2819
#    if (u1 >= v) {            // If overflow, set rem.
2820
#       if (r != NULL)         // to an impossible value,
2821
#          *r = 0xFFFFFFFF;    // and return the largest
2822
#       return 0xFFFFFFFF;}    // possible quotient.
2823
# 
2824
#    s = nlz(v);               // 0 <= s <= 31.
2825
#    v = v << s;               // Normalize divisor.
2826
#    vn1 = v >> 16;            // Break divisor up into
2827
#    vn0 = v & 0xFFFF;         // two 16-bit digits.
2828
# 
2829
#    un32 = (u1 << s) | (u0 >> 32 - s) & (-s >> 31);
2830
#    un10 = u0 << s;           // Shift dividend left.
2831
# 
2832
#    un1 = un10 >> 16;         // Break right half of
2833
#    un0 = un10 & 0xFFFF;      // dividend into two digits.
2834
# 
2835
#    q1 = un32/vn1;            // Compute the first
2836
#    rhat = un32 - q1*vn1;     // quotient digit, q1.
2837
# again1:
2838
#    if (q1 >= b || q1*vn0 > b*rhat + un1) {
2839
#      q1 = q1 - 1;
2840
#      rhat = rhat + vn1;
2841
#      if (rhat < b) goto again1;}
2842
# 
2843
#    un21 = un32*b + un1 - q1*v;  // Multiply and subtract.
2844
# 
2845
#    q0 = un21/vn1;            // Compute the second
2846
#    rhat = un21 - q0*vn1;     // quotient digit, q0.
2847
# again2:
2848
#    if (q0 >= b || q0*vn0 > b*rhat + un0) {
2849
#      q0 = q0 - 1;
2850
#      rhat = rhat + vn1;
2851
#      if (rhat < b) goto again2;}
2852
# 
2853
#    if (r != NULL)            // If remainder is wanted,
2854
#       *r = (un21*b + un0 - q0*v) >> s;     // return it.
2855
#    return q1*b + q0;
2856
# }
2857

2858
# un1   r1
2859
# un0   r2      also un10
2860
# vn1   r3
2861
# vn0   r4
2862
# q1    r5
2863
# q0    r6
2864
# un32  r7
2865
# un21  r8
2866
#       r9
2867
# rhat  r10
2868
# s     r11
2869

2870
header "um/mod",u_m_slash_mod
2871
        ldi     $r1,$r27,0              # v:r0 u1:r1 r0:r2
2872
        ldi     $r2,$r27,4
2873
        add     $r27,$r27,4
2874

2875
        move    $r9,$r0
2876
        nlz     $r9,$r12                # 0 <= s <= 31.
2877
        ashl    $r0,$r0,$r9             # Normalize divisor.
2878
        lshr    $r3,$r0,16              # Break divisor up into
2879
        bins    $r4,$r0,16              # two 16-bit digits.
2880

2881
        cmp     $r9,0
2882
        jmpc    nz,1f
2883
        move    $r7,$r1
2884
        jmp     2f
2885
1:
2886
        ashl    $r7,$r1,$r9
2887
        ldk     $r12,32
2888
        sub     $r12,$r12,$r9
2889
        lshr    $r12,$r2,$r12
2890
        or      $r7,$r7,$r12
2891
        ashl    $r2,$r2,$r9
2892
2:
2893

2894
        lshr    $r1,$r2,16              # Break right half of
2895
        bins    $r2,$r2,16              # dividend into two digits.
2896

2897
        udiv    $r5,$r7,$r3             # Compute the first
2898
        mul     $r12,$r5,$r3
2899
        sub     $r10,$r7,$r12           # quotient digit, q1.
2900

2901
again1:
2902
        btst    $r5,16
2903
        jmpc    nz,1f
2904
                                        # q1*vn0 > b*rhat + un1
2905
        mul     $cc,$r5,$r4
2906
        ashl    $r12,$r10,16
2907
        add     $r12,$r12,$r1
2908
        cmp     $cc,$r12
2909
        jmpc    be,2f
2910
1:
2911
        sub     $r5,$r5,1               # q1 = q1 - 1;
2912
        add     $r10,$r10,$r3           # rhat = rhat + vn1;
2913
        btst    $r10,16
2914
        jmpc    z,again1
2915
2:
2916

2917
#    un21 = un32*b + un1 - q1*v;  // Multiply and subtract.
2918
# 
2919
#    q0 = un21/vn1;            // Compute the second
2920
#    rhat = un21 - q0*vn1;     // quotient digit, q0.
2921

2922
        ashl    $r8,$r7,16              # Multiply and subtract.
2923
        add     $r8,$r8,$r1             # un21 = un32*b + un1 - q1*v;
2924
        mul     $r12,$r5,$r0
2925
        sub     $r8,$r8,$r12
2926

2927
        udiv    $r6,$r8,$r3             # Compute the second
2928
        mul     $r12,$r6,$r3
2929
        sub     $r10,$r8,$r12           # quotient digit, q0.
2930

2931
again2:
2932
        btst    $r6,16
2933
        jmpc    nz,1f
2934
                                        # q1*vn0 > b*rhat + un1
2935
        mul     $cc,$r6,$r4
2936
        ashl    $r12,$r10,16
2937
        add     $r12,$r12,$r2
2938
        cmp     $cc,$r12
2939
        jmpc    be,2f
2940
1:
2941
        sub     $r6,$r6,1               # q0 = q0 - 1;
2942
        add     $r10,$r10,$r3           # rhat = rhat + vn1;
2943
        btst    $r10,16
2944
        jmpc    z,again2
2945
2:
2946
                                        # *r = (un21*b + un0 - q0*v) >> s;
2947
        ashl    $r8,$r8,16
2948
        add     $r8,$r8,$r2
2949
        mul     $r12,$r6,$r0
2950
        sub     $r8,$r8,$r12
2951
        lshr    $r8,$r8,$r9
2952
        sti     $r27,0,$r8
2953
        
2954
#    return q1*b + q0;                  # quotient
2955
        ashl    $r0,$r5,16
2956
        add     $r0,$r0,$r6
2957
        return
2958

2959
#######   BOOT   #####################################################
2960

2961
h80000000:      .long   0x80000000
2962

2963
codestart:
2964
        ldk     $sp,__RAMSIZE-4
2965
        ldk     $r26,FSTACK_TOP
2966
        ldk     $r27,DSTACK_TOP
2967

2968
        ldk     $r20,0                 /* GPIO shadows */
2969
        ldk     $r21,0
2970
        ldk     $r22,0
2971
        ldk     $r25,0                 /* constant 0 */
2972

2973
        .if SIMULATOR==0
2974
                ldk     $r1,0x80
2975
                sta.b   sys_regmsc0cfg_b3,$r1
2976

2977
               /* Enable the RTC as soon as possible */
2978
               /* Write 1 to RTC_EN in RTC_CCR */
2979
                ldk     $r1,(1 << 2)
2980
                sta     0x1028c,$r1
2981

2982
               /* lpm     $r1,h80000000 */
2983
               /* sta     0x10018,$r1 */
2984
        .endif
2985

2986
                lpm     $r1,saved_pmdp
2987
                sta     cp,$r1
2988
                lpm     $r2,saved_dp
2989
                sta     dp,$r2
2990

2991
               /* copy all of RAM from pm[cp to cp+dp] */
2992
                ldk     $r0,0                  /* dest */
2993
        ramloader:
2994
                lpmi    $r3,$r1,0
2995
                sti     $r0,0,$r3
2996
                add     $r0,$r0,4
2997
                add     $r1,$r1,4
2998
                cmp     $r0,$r2
2999
                jmpc    be,ramloader
3000

3001
        .if SIMULATOR==0
3002
                call    uart.start
3003
        .endif
3004

3005
        sta     _tethered,$r25
3006
        call    decimal
3007
        call    left_bracket
3008
        call    pm_cold
3009

3010
        ldk     $r0,emit
3011
        sta     PM_ADDR,$r0
3012
        lpm     $r0,default_emit
3013
        sta     PM_DATA,$r0
3014

3015
        call    cr
3016
        lit     80
3017
banner:
3018
        lit     '-'
3019
        call    emit
3020
        add     $r0,$r0,-1
3021
        cmp     $r0,0
3022
        jmpc    nz,banner
3023
        call    drop
3024

3025
        lpm     $r1,coldname           /* find a word named 'cold' */
3026
        sta     0,$r1
3027

3028
        lit     0
3029
        lit     4
3030
        call    sfind
3031

3032
        cmp     $r0,0
3033
        call    drop
3034
        jmpc    z,no_cold
3035

3036
        call    execute
3037
        call    cr
3038

3039
        jmp     quit
3040

3041
no_cold:
3042
        call    cr                     /* empty banner */
3043
        call    two_drop
3044
        jmp     quit
3045

3046
coldname:
3047
        .ascii "cold"
3048

3049
# RAM is initialized from PM as follows:
3050
#   cp is loaded from saved_pmdp
3051
#   dp is loaded from saved_dp
3052
#   Then RAM is copied from pm[cp .. cp+dp]
3053

3054
saved_pmdp:     .long   endcode
3055
saved_dp:       .long   ramhere
3056

3057

3058
endcode:
3059
        .long   0x70617773     /* guardian */
3060
        .long   ramhere        /* dp */
3061
        .long   endcode        /* cp */
3062
        .long   forth          /* cwl */
3063
        .long   forth          /* word lists */
3064
        .long   2              /* nsearch */
3065
        .long   forth          /* searchlist */
3066
        .long   internal
3067
        .long   0
3068
        .long   0
3069
        .long   0
3070
        .long   0
3071
        .long   0
3072
        .long   0
3073
        .long   0
3074
        .long   0
3075
        .long   0
3076
        .long   0
3077
        .long   0
3078
        .long   0
3079
        .long   0
3080
        .long   0
3081

3082
        .long   internal       /* forth word list #0 */
3083
        .long   forth_link     /* forth word list #4 */
3084
        .long   0              /* internal word list #0 */
3085
        .long   internal_link  /* internal word list #4 */
3086