-
Notifications
You must be signed in to change notification settings - Fork 0
/
forthMSP430FR.asm
1805 lines (1680 loc) · 93 KB
/
forthMSP430FR.asm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;
;-------------------------------------------------------------------------------
; Vingt fois sur le métier remettez votre ouvrage,
; Polissez-le sans cesse, et le repolissez,
; Ajoutez quelquefois, et souvent effacez. Boileau, L'Art poétique
;-------------------------------------------------------------------------------
;===============================================================================
; SCITE editor: copy https://www.scintilla.org/Sc531.exe to \prog\scite.exe
; copy \config\SciTEUser.properties in your $HOME directory
;===============================================================================
;===============================================================================
; MACRO ASSEMBLER AS: unzip to \prog
; http://john.ccac.rwth-aachen.de:8000/ftp/as/precompiled/i386-unknown-win32/aswcurr.zip
;===============================================================================
.listing purecode ; reduce listing to true conditionnal parts
MACEXP_DFT noif ; reduce macros listing to true part
.PAGE 0 ; listing without pagination
;-------------------------------------------------------------------------------
VER .equ "V401" ; FORTH version
;===============================================================================
; before assembling or programming you must set TARGET in scite param1 (SHIFT+F8)
; according to the selected (uncommented) TARGET below
;===============================================================================
; TARGET ;
;MSP_EXP430FR5739 ; compile for MSP-EXP430FR5739 launchpad
;MSP_EXP430FR5969 ; compile for MSP-EXP430FR5969 launchpad
;MSP_EXP430FR5994 ; compile for MSP-EXP430FR5994 launchpad
;MSP_EXP430FR6989 ; compile for MSP-EXP430FR6989 launchpad
;MSP_EXP430FR4133 ; compile for MSP-EXP430FR4133 launchpad
MSP_EXP430FR2355 ;; compile for MSP-EXP430FR2355 launchpad
;MSP_EXP430FR2433 ; compile for MSP-EXP430FR2433 launchpad
;LP_MSP430FR2476 ; compile for LP_MSP430FR2476 launchpad
;CHIPSTICK_FR2433 ; compile for "CHIPSTICK" of M. Ken BOAK
; choose DTC model (Direct Threaded Code); if you don't know, choose 2
DTC .equ 2 ; DTC model 1 : DOCOL = CALL rDOCOL 14 cycles 1 word shortest but a little slow DTC model
; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT 13 cycles 2 words best compromize to mix FORTH/ASM code
; DTC model 3 : inlined DOCOL (and LO2HI) 9 cycles 4 words fastest
THREADS .equ 16 ; 1, 2 , 4 , 8 , 16, 32 search entries in word-set.
; +0, +28, +48, +56, +90, +154 bytes, usefull to speed up compilation;
; the FORTH interpreter is speed up by about a square root factor of THREADS.
FREQUENCY .equ 24 ; fully tested at 1,2,4,8,16 MHz, plus 24 MHz for MSP430FR57xx,MSP430FR2355
; ==============================================================================
UART_TERMINAL ; COMMENT TO SWITCH FROM UART TO I2C TERMINAL
; ==============================================================================
.IFDEF UART_TERMINAL
TERMINALBAUDRATE .equ 115200
TERMINAL3WIRES ;; + 18 bytes enable 3 wires XON/XOFF software flow control
TERMINAL4WIRES ;; + 12 bytes enable 4 wires RTS hardware flow control
;TERMINAL5WIRES ; + 10 bytes enable 5 wires RTS/CTS hardware flow control
;HALFDUPLEX ; switch to UART half duplex TERMINAL input
.ELSE
I2C_TERM_ADR .equ 18 ; I2C_TERMINAL_Slave_Address << 1
.ENDIF
;===============================================================================
; KERNEL ADDONs that can't be added later
;===============================================================================
DOUBLE_INPUT ;; + 60 bytes : adds the interpretation engine for double numbers (numbers with dot)
FIXPOINT_INPUT ;; + 68 bytes : adds the interpretation engine for Q15.16 numbers (numbers with comma)
;VOCABULARY_SET ; + 194 bytes : adds words: WORDSET FORTH hidden PREVIOUS ONLY DEFINITIONS
;SD_CARD_LOADER ; + 1664 bytes : to load source files from SD_card
;SD_CARD_READ_WRITE ; + 1168 bytes : to read, create, write and del files + copy text files from PC to target SD_Card
;LARGE_CODE ; + 506 bytes : extended assembler to 20 bits addresses (1MB).
;LARGE_DATA ; + 1212 bytes : extended assembler to 20 bits datas.
;PROMPT ; + 18 bytes : to display the prompt "ok" (deprecated).
;===============================================================================
;-------------------------------------------------------------------------------
; OPTIONS that can be added later by downloading their source file >------------------------------------+
; however, added here, they are protected against WIPE and Deep Reset. |
;------------------------------------------------------------------------------- v
;CORE_COMPLEMENT ; + 2304 bytes, if you want a conventional FORTH ANS94 compliant CORE_ANS.f
;FIXPOINT ; + 422/528 bytes add HOLDS F+ F- F/ F* F#S F. S>F FIXPOINT.f
;UTILITY ; + 434/524 bytes (1/16threads) : add .S .RS WORDS U.R DUMP ? UTILITY.f
;SD_TOOLS ; + 142 bytes for trivial DIR, FAT, CLUSTR. and SECTOR. view, (adds UTILITY) SD_TOOLS.f
;DOUBLE ; DOUBLE word set DOUBLE.f
; ------------------------------------------------------------------------------
.include "ThingsInFirst.inc" ; macros, target definitions, RAM & INFO variables...
;-------------------------------------------------------------------------------
.org MAIN_ORG
;-------------------------------------------------------------------------------
; MEMORY OPERATIONS
;-------------------------------------------------------------------------------
FORTHWORD "@"
; https://forth-standard.org/standard/core/Fetch
; @ a-addr -- x fetch cell from memory
FETCH MOV @TOS,TOS
MOV @IP+,PC
FORTHWORD "!"
; https://forth-standard.org/standard/core/Store
; ! x a-addr -- store cell in memory
STORE MOV @PSP+,0(TOS);4
MOV @PSP+,TOS ;2
MOV @IP+,PC ;4
;-----------------------------------;
; modifying TOs is forbidden here ! ;
;-----------------------------------;
INIT_FORTH ; common QABORT|WARM subroutine
;-----------------------------------;
MOV @RSP+,IP ; init IP with CALLER next address
; ;
MOV #PUC_ABORT_ORG,X ; FRAM INFO FRAM MAIN
; ; --------- ---------
MOV @X+,&PFAACCEPT ; BODYACCEPT --> PFAACCEPT
MOV @X+,&PFAEMIT ; BODYEMIT --> PFAEMIT
MOV @X+,&PFAKEY ; BODYKEY --> PFAKEY
MOV @X+,&CIB_ORG ; TIB_ORG --> CIB_ORG TIB = Terminal Input Buffer, CIB = Current Input Buffer
; ;
; ; FRAM INFO REG|RAM
; ; --------- -------
MOV @X+,RSP ; INIT_RSTACK --> R1=RSP PSP is initialised with ABORT
MOV @X+,rDOCOL ; EXIT --> R4=rDOCOL (if DTC=2)
MOV @X+,rDODOES ; XDODOES --> R5=rDODOES
MOV @X+,rDOCON ; XDOCON --> R6=rDOCON
MOV @X+,rDOVAR ; RFROM --> R7=rDOVAR
MOV @X+,&BASEADR ; INIT_BASE --> RAM BASE init decimal base
MOV @X+,&LEAVEPTR ; INIT_LEAVE --> RAM LEAVEPTR
MOV #0,&STATE ; 0 --> RAM STATE
CALL &SOFT_APP ; default SOFT_APP = INIT_SOFT = RET_ADR, value set by DEEP_RESET.
MOV #SEL_RST,PC ; goto PUC 7 to select the user's choice from TOS value: RST_RET|DEEP_RESET
;-----------------------------------;
;-------------------------------------------------------------------------------
; DTCforthMSP430FR5xxx program (FRAM) memory
;-------------------------------------------------------------------------------
.IFNDEF UART_TERMINAL
.include "forthMSP430FR_TERM_I2C.asm"
.ELSE
.IFDEF HALFDUPLEX
.include "forthMSP430FR_TERM_HALF.asm"
.ELSE
.include "forthMSP430FR_TERM_UART.asm"
.ENDIF
.ENDIF
.IFDEF SD_CARD_LOADER
.include "forthMSP430FR_SD_ACCEPT.asm"
.ENDIF
.IF DTC = 1 ; DOCOL = CALL rDOCOL, [rDOCOL] = XDOCOL
XDOCOL MOV @RSP+,W ; 2
PUSH IP ; 3 save old IP on return stack
MOV W,IP ; 1 set new IP to PFA
MOV @IP+,PC ; 4 = NEXT
.ENDIF ; 10 cycles
FORTHWORD "TYPE"
;https://forth-standard.org/standard/core/TYPE
;C TYPE adr u -- type string to terminal
TYPE PUSH IP ;3
MOV #TYPE_NEXT+2,IP ;2 because SUB #2,IP
MOV @PSP+,X ;2 -- len X = adr
TYPELOOP SUB #2,IP ;1 [IP] = TYPE_NEXT
SUB #2,PSP ;1 -- x len
MOV TOS,0(PSP) ;3 -- len len
MOV.B @X+,TOS ;2 -- len char
JMP EMIT ;22 S T W regs are free
TYPE_NEXT mNEXTADR ; -- len
SUB.B #1,TOS ;1 -- len-1 byte operation, according to the /COUNTED-STRING value
JNZ TYPELOOP ;2 32~/19~ EMIT loop 312/526 kBds/MHz --> 7.5MBds @ 24 MHz
JZ DROPEXIT ;2
; ------------------------------------------------------------------------------
; forthMSP430FR : CONDITIONNAL COMPILATION, 114/109 words
; ------------------------------------------------------------------------------
; goal: speed up the false conditionnal to reach true|false equal time: reached!
; ------------------------------------------------------------------------------
FORTHWORDIMM "[THEN]" ; does nothing
; https://forth-standard.org/standard/tools/BracketTHEN
MOV @IP+,PC
; ------------------------------------------------------------------------------
; COMPILING OPERATORS
; ------------------------------------------------------------------------------
; Primitive LIT; compiled by LITERAL
; LIT -- x fetch inline literal to stack
; This is the run-time code of LITERAL.
LIT SUB #2,PSP ; 1 save old TOS..
MOV TOS,0(PSP) ; 3 ..onto stack
MOV @IP+,TOS ; 2 fetch new TOS value
MOV @IP+,PC ; 4 NEXT
TWODUP_XSQUOTE ; see [ELSE]
MOV TOS,-2(PSP) ; 3
MOV @PSP,-4(PSP) ; 4
SUB #4,PSP ; 1
; Primitive XSQUOTE; compiled by SQUOTE
; (S") -- addr u run-time code to get address and length of a compiled string.
XSQUOTE SUB #4,PSP ; 1 push old TOS on stack
MOV TOS,2(PSP) ; 3 and reserve one cell on stack
MOV.B @IP+,TOS ; 2 -- ? u u = lenght of string
MOV IP,0(PSP) ; 3 -- addr u IP is odd...
ADD TOS,IP ; 1 IP=addr+u=addr(end_of_string)
BIT #1,IP ; 1 IP=addr+u Carry set/clear if odd/even
ADDC #0,IP ; 1 IP=addr+u aligned
MOV @IP+,PC ; 4 16~
; : SETIB SOURCE 2! 0 >IN ! ;
; SETIB org len -- set Input Buffer, shared by INTERPRET and [ELSE]
SETIB MOV #0,&TOIN ;3
MOV @PSP+,&SOURCE_ORG ;4 -- len
MOV TOS,&SOURCE_LEN ;3 -- len
MOV @PSP+,TOS ;2 --
MOV @IP+,PC ;4
; REFILL accept one line to input buffer and leave org len' of the filled input buffer
; as it has no more host OS and as waiting command is done by ACCEPT, REFILL's flag is useless
; : REFILL TIB DUP CIB_LEN ACCEPT ; -- org len' shared by QUIT and [ELSE]
REFILL SUB #4,PSP ;1
MOV TOS,2(PSP) ;3 save TOS
TWODROP_REFILL ; see [ELSE]
MOV #CIB_LEN,TOS ;2 -- x len Current Input Buffer LENght
.word 40BFh ; MOV #imm,index(PSP)
CIB_ORG .word TIB_ORG ; imm=TIB_ORG
.word 0 ;4 -- org len index=0 ==> MOV #TIB_ORG,0(PSP)
MOV @PSP,-2(PSP) ;4 -- org len
SUB #2,PSP ;1 -- org org len
JMP ACCEPT ;2 org org len -- org len'
; Primitive QFBRAN; compiled by IF UNTIL
;Z ?FalseBranch x -- ; branch if TOS is FALSE (TOS = 0)
QFBRAN CMP #0,TOS ; 1 test TOS value
MOV @PSP+,TOS ; 2 pop new TOS value (doesn't change flags)
ZBRAN JNZ SKIPBRANCH ; 2 if TOS was <> 0, skip the branch; 10 cycles
BRAN MOV @IP,IP ; 2 take the branch destination
MOV @IP+,PC ; 4 ==> branch taken, 11 cycles
XDODOES ; 4 for CALL rDODOES
SUB #2,PSP ;+1
MOV TOS,0(PSP) ;+3 save TOS on parameters stack
MOV @RSP+,TOS ;+2 TOS = PFA address of master word, i.e. address of its first cell after DOES>
PUSH IP ;+3 save IP on return stack
MOV @TOS+,IP ;+2 IP = CFA of Master word, TOS = BODY address of created word
MOV @IP+,PC ;+4 = 19~ = ITC-2
XDOCON ; 4 for CALL rDOCON
SUB #2,PSP ;+1
MOV TOS,0(PSP) ;+3 save TOS on parameters stack
MOV @RSP+,TOS ;+2 TOS = PFA address of master word CONSTANT
MOV @TOS,TOS ;+2 TOS = CONSTANT value
MOV @IP+,PC ;+4 = 16~ = ITC+4
; ------------------------------------------------------------------------------
; BRanch if BAD strings COMParaison, [COMPARE ZEROEQUAL QFBRAN] replacement
QBRBADCOMP ; addr1 u1 addr2 u2 --
MOV TOS,S ;1 S = u2
MOV @PSP+,Y ;2 Y = addr2
CMP @PSP+,S ;2 u1 = u2 ?
MOV @PSP+,X ;2 X = addr1
MOV @PSP+,TOS ;2 --
JNZ BRAN ;2 -- branch if u1<>u2, 11+6 cycles
COMPLOOP CMP.B @Y+,0(X) ;4
JNZ BRAN ;2 -- if char1<>char2; branch on first char <> in 17+6 cycles
ADD #1,X ;1 addr+1
SUB #1,S ;1 u-1
JNZ COMPLOOP ;2 10 cycles char comp loop
SKIPBRANCH ADD #2,IP ;1
MOV @IP+,PC ;4
; [TWODROP ONEMINUS ?DUP ZEROEQUAL QFBRAN next_comp EXIT] replacement
QBRNEXTCMP ; -- cnt addr u
ADD #2,PSP ;1 -- cnt addr NIP
MOV @PSP+,TOS ;2 -- cnt + DROP = TWODROP
SUB #1,TOS ;3 -- cnt-1 ONEMINUS
JNZ BRAN ;2 -- cnt-1 branch to next comparaison if <> 0
DROPEXIT MOV @RSP+,IP ;2
DROP MOV @PSP+,TOS ;2 --
MOV @IP+,PC ;4
FORTHWORDIMM "[ELSE]"
; https://forth-standard.org/standard/tools/BracketELSE
;Compilation:
;Perform the execution semantics given below.
;Execution:
;( "<spaces>name ..." -- )
;Skipping leading spaces, parse and discard space-delimited words from the parse area,
;including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
;until the word [THEN] has been parsed and discarded.
;If the parse area becomes exhausted, it is refilled as with REFILL.
;the loop back from BRACKTELSE1 to BRACKTELSE0 is shorten
BRACKETELSE mDOCOL
.word LIT,1 ; -- cnt
.word BRAN,BRACKTELSE1 ; 6~ versus 5~ for ONEPLUS
BRACKTELSE0 .word XSQUOTE ; end of skiped line
.byte 5,13,"ko ",10 ; send CR + "ko " + LF
.word TYPE ; -- cnt addr 0
.word TWODROP_REFILL ; -- cnt REFILL Input Buffer with next line
.word SETIB ; SET Input Buffer pointers SOURCE_LEN, SOURCE_ORG and clear >IN
BRACKTELSE1 .word BL_WORD,COUNT ; -- cnt addr u Z = 1 if u = 0
.word ZBRAN,BRACKTELSE0 ; cnt addr 0 -- Z = 1 --> end of line, -6~
.word TWODUP_XSQUOTE ; 24 ~
.byte 6,"[THEN]" ; -- cnt addr u addr1 u1 addr2 u2
.word QBRBADCOMP,BRACKTELSE2 ; -- cnt addr u if [THEN] not found, jump for next comparaison
.word QBRNEXTCMP,BRACKTELSE1 ; if found, 2DROP, count-1, loop back if count <> 0 | DROP EXIT if count = 0
BRACKTELSE2 .word TWODUP_XSQUOTE ;
.byte 6,"[ELSE]" ; -- cnt addr u addr1 u1 addr2 u2
.word QBRBADCOMP,BRACKTELSE3 ; -- cnt addr u if [ELSE] not found, jump for next comparaison
.word QBRNEXTCMP,BRACKTELSE4 ; if found, 2DROP, count-1, loop back if count <> 0
BRACKTELSE3 .word XSQUOTE ; 16 ~
.byte 4,"[IF]" ; -- cnt addr1 u1 addr2 u2
.word QBRBADCOMP,BRACKTELSE1 ; -- cnt if [IF] not found, loop back for next word comparaison
BRACKTELSE4 .word ONEPLUS ; -- cnt+1 if found, same loop back with count+1
.word BRAN,BRACKTELSE1 ;
FORTHWORDIMM "[IF]" ; flag --
; https://forth-standard.org/standard/tools/BracketIF
;Compilation:
;Perform the execution semantics given below.
;Execution: ;( flag | flag "<spaces>name ..." -- )
;If flag is true, do nothing. Otherwise, skipping leading spaces,
; parse and discard space-delimited words from the parse area,
; including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
; until either the word [ELSE] or the word [THEN] has been parsed and discarded.
;If the parse area becomes exhausted, it is refilled as with REFILL. [IF] is an immediate word.
;An ambiguous condition exists if [IF] is POSTPONEd,
; or if the end of the input buffer is reached and cannot be refilled before the terminating [ELSE] or [THEN] is parsed.
CMP #0,TOS ; -- f
MOV @PSP+,TOS ; --
JZ BRACKETELSE ; if false flag output
MOV @IP+,PC ; if true flag output
FORTHWORDIMM "[UNDEFINED]"
; https://forth-standard.org/standard/tools/BracketUNDEFINED
;Compilation:
;Perform the execution semantics given below.
;Execution: ( "<spaces>name ..." -- flag )
;Skip leading space delimiters. Parse name delimited by a space.
;Return a false flag if name is the name of a word that can be found,
;otherwise return a true flag.
mDOCOL
.word BL_WORD,FIND
mNEXTADR
SUB #1,TOS ;1 borrow if TOS was 0
SUBC TOS,TOS ;1 TOS=-1 if borrow is set
NIP_EXIT MOV @RSP+,IP
NIP ADD #2,PSP ;1
MOV @IP+,PC ;4
FORTHWORDIMM "[DEFINED]"
; https://forth-standard.org/standard/tools/BracketDEFINED
;Compilation:
;Perform the execution semantics given below.
;Execution:
;( "<spaces>name ..." -- flag )
;Skip leading space delimiters. Parse name delimited by a space.
;Return a true flag if name is the name of a word that can be found,
;otherwise return a false flag. [DEFINED] is an immediate word.
mDOCOL
.word BL_WORD,FIND
.word NIP_EXIT
;-------------------------------------------------------------------------------
; STACK OPERATIONS
;-------------------------------------------------------------------------------
; https://forth-standard.org/standard/core/SWAP
SWAP PUSH @PSP+ ; 3
; https://forth-standard.org/standard/core/Rfrom
; R> -- x R: x -- pop from return stack
; VARIABLE run time called by CALL rDOVAR
RFROM SUB #2,PSP ; 1
MOV TOS,0(PSP) ; 3
MOV @RSP+,TOS ; 2
MOV @IP+,PC ; 4
; https://forth-standard.org/standard/core/DUP
; DUP x -- x x duplicate top of stack
DUP SUB #2,PSP ; 1
MOV TOS,0(PSP) ; 3
MOV @IP+,PC ; 4
;-------------------------------------------------------------------------------
; ARITHMETIC OPERATIONS
;-------------------------------------------------------------------------------
; https://forth-standard.org/standard/core/Minus
; - n1/u1 n2/u2 -- n3/u3 n3 = n1-n2
MINUS SUB @PSP+,TOS ;2 -- n2-n1
NEGATE XOR #-1,TOS ;1
ONEPLUS ADD #1,TOS ;1 -- n3 = -(n2-n1) = n1-n2
MOV @IP+,PC
; ------------------------------------------------------------------------------
; STRINGS PROCESSING
; ------------------------------------------------------------------------------
; use SQUOTE+10 if you want to define another separator
FORTHWORDIMM "S\34" ; immediate
; https://forth-standard.org/standard/core/Sq
; S" -- compile in-line string
SQUOTE SUB #2,PSP ; first choose separator
MOV TOS,0(PSP)
MOV #'"',TOS ; separator = '"'
MOV #0,T ; volatile CAPS OFF, paired with WORDD+4
mDOCOL
.word LIT,XSQUOTE,COMMA ; obviously use not T register...
.word WORDD+4 ; -- c-addr = DP, W=Count_of_chars
mNEXTADR ;
ADD #1,W ; to include count of chars
BIT #1,W ; C = /Z
ADDC W,&DP ; -- addr new DP is aligned
JMP DROPEXIT ;
FORTHWORDIMM ".\34" ; immediate
; https://forth-standard.org/standard/core/Dotq
; ." -- compile string to print
DOTQUOTE mDOCOL
.word SQUOTE
.word LIT,TYPE,COMMA
.word EXIT
;-------------------------------------------------------------------------------
; NUMERIC OUTPUT
;-------------------------------------------------------------------------------
; Numeric conversion is done last digit first, so
; the output buffer is built backwards in memory.
FORTHWORD "<#"
; https://forth-standard.org/standard/core/num-start
; <# -- begin numeric conversion (initialize Hold Pointer)
LESSNUM MOV #HOLD_BASE,&HP
MOV @IP+,PC
; primitive MU/MOD; used by ?NUMBER UM/MOD, and M*/ in DOUBLE word set
; MU/MOD UDVDlo UDVDhi UDIVlo -- UREMlo UQUOTlo UQUOThi
;-------------------------------------------------------------------------------
; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient 16-BIT REMainder
;-------------------------------------------------------------------------------
; two times faster if 16 bits DiViDend (cases of U. and . among others)
; reg division MU/MOD NUM M*/
; ---------------------------------------------------------------------
; S = DVD(15-0) = ud1lo = ud1lo ud1lo
; TOS = DVD(31-16) = ud1hi = ud1hi ud1mi
; W = DVD(47-32)/REM = rem = digit --> char --> -[HP] ud1hi
; T = DIV(15-0) = BASE = BASE ud2
; X = QUOTlo = ud2lo = ud2lo QUOTlo
; Y = QUOThi = ud2hi = ud2hi QUOThi
; rDODOES = count
MUSMOD MOV TOS,T ;1 T = DIVlo
MOV 2(PSP),S ;3 S = DVDlo
MOV @PSP,TOS ;2 TOS = DVDhi
MUSMOD1 MOV #0,W ;1 W = REMlo = 0
MOV #32,rDODOES ;2 init loop count
CMP #0,TOS ;1 DVDhi=0 ?
JNZ MDIV1 ;2 no
; ----------------------------------;
MDIV1DIV2 RRA rDODOES ;1 yes:loop count / 2
MOV S,TOS ;1 DVDhi <-- DVDlo
MOV #0,S ;1 DVDlo <-- 0
MOV #0,X ;1 QUOTlo <-- 0 (to do QUOThi = 0 at the end of division)
; ----------------------------------;
MDIV1 CMP T,W ;1 REMlo U>= DIVlo ?
JNC MDIV2 ;2 no : carry is reset
SUB T,W ;1 yes: REMlo - DIVlo ; carry is set
MDIV2 ADDC X,X ;1 RLC quotLO
ADDC Y,Y ;1 RLC quotHI
SUB #1,rDODOES ;1 Decrement loop counter
JN ENDMDIV ;2
ADD S,S ;1 RLA DVDlo
ADDC TOS,TOS ;1 RLC DVDhi
ADDC W,W ;1 RLC REMlo
JNC MDIV1 ;2 14~
SUB T,W ;1 REMlo - DIVlo
BIS #1,SR ;1 SETC
JMP MDIV2 ;2 14~
ENDMDIV MOV #XDODOES,rDODOES ;2 restore rDODOES
MOV W,2(PSP) ;3 REMlo in 2(PSP)
MOV X,0(PSP) ;3 QUOTlo in 0(PSP)
MOV Y,TOS ;1 QUOThi in TOS
RET_ADR MOV @RSP+,PC ;4 35 words, about 440/240 cycles, not FORTH executable !
FORTHWORD "#"
; https://forth-standard.org/standard/core/num
; # ud1lo ud1hi -- ud2lo ud2hi convert 1 digit of output
NUM MOV &BASEADR,T ;3
NUM1 MOV @PSP,S ;2 -- DVDlo DVDhi S = DVDlo
SUB #2,PSP ;1 -- x x DVDhi TOS = DVDhi
CALL #MUSMOD1 ;244/444 -- REMlo QUOTlo QUOThi T is unchanged W=REMlo X=QUOTlo Y=QUOThi
MOV @PSP+,0(PSP) ;4 -- QUOTlo QUOThi W = REMlo
TODIGIT CMP.B #10,W ;2
JNC TODIGIT1 ;2 jump if U<
ADD.B #7,W ;2
TODIGIT1 ADD.B #30h,W ;2
HOLDW SUB #1,&HP ;3 store W=char --> -[HP]
MOV &HP,Y ;3
MOV.B W,0(Y) ;3
MOV @IP+,PC ;4 22 words, about 276|476 cycles for u|ud one digit
FORTHWORD "#S"
; https://forth-standard.org/standard/core/numS
; #S udlo udhi -- 0 0 convert remaining digits
NUMS mDOCOL
.word NUM ; X=QUOTlo
mNEXTADR ; next adr
SUB #2,IP ;1 restore NUM return
BIS TOS,X ;1
CMP #0,X ;1 -- ud2lo ud2hi ud = 0 ?
JNZ NUM1 ;2
EXIT MOV @RSP+,IP ;2 when DTC=2 rDOCOL is loaded with this EXIT address
MOV @IP+,PC ;4 10 words, about 294|494 cycles for u|ud one digit
FORTHWORD "#>"
; https://forth-standard.org/standard/core/num-end
; #> udlo:udhi -- addr u end conversion, get string
NUMGREATER MOV &HP,0(PSP) ; -- addr 0
MOV #HOLD_BASE,TOS ;
SUB @PSP,TOS ; -- addr u
MOV @IP+,PC
FORTHWORD "HOLD"
; https://forth-standard.org/standard/core/HOLD
; HOLD char -- add char to output string
HOLD MOV.B TOS,W ;1
MOV @PSP+,TOS ;2
JMP HOLDW ;15
FORTHWORD "SIGN"
; https://forth-standard.org/standard/core/SIGN
; SIGN n -- add minus sign if n<0
SIGN CMP #0,TOS ; 1
MOV @PSP+,TOS ; 2
MOV.B #'-',W ; 2
JN HOLDW ; 2 jump if 0<
MOV @IP+,PC ; 4
BL CALL rDOCON
.word ' '
FORTHWORD "U."
; https://forth-standard.org/standard/core/Ud
; U. u -- display u (unsigned)
; note: DDOT = UDOT + 10 (see DOUBLE.f)
UDOT MOV #0,S ; 1 S=sign
SUB #2,PSP ; 1
MOV TOS,0(PSP) ; 3 -- |lo| x
MOV #0,TOS ; 1 -- |lo| |hi|
UDOTNEXT PUSHM #2,IP ; 4 R-- IP sign
mASM2FORTH ;10
.word LESSNUM
.word BL,HOLD ; add a trailing space
.word NUMS ;
.word RFROM,SIGN ; IP sign R-- IP
.word NUMGREATER,TYPE
.word EXIT ; IP R--
FORTHWORD "."
; https://forth-standard.org/standard/core/d
; . n -- display n (signed)
DOT CMP #0,TOS
JGE UDOT
XOR #-1,TOS ;1 set TOS = |lo|
ADD #1,TOS ;1
MOV #-1,S ;1 set S = minus sign
JMP UDOT+2
;-------------------------------------------------------------------------------
; INTERPRETER
;-------------------------------------------------------------------------------
;
; https://forth-standard.org/standard/core/WORD
; WORD char -- addr Z=1 if len=0
; parse a word delimited by char separator.
; the resulting c-string is left at HERE.
; if CAPS is ON, this word is CAPITALIZED unless for a 'char' input.
; notice that the average lenght of all CORE definitions is about 4.
FORTHWORD "WORD"
JMP WORDD ;2
;-------------------------------;
BL_WORD SUB #2,PSP ;1 )
MOV TOS,0(PSP) ;3 > 6~ instead of 16~ for CONSTANT BL runtime
MOV #' ',TOS ;2 -- BL )
WORDD MOV #20h,T ;3 -- sep CAPS OFF = 0, CAPS ON = $20.
MOV #SOURCE_LEN,S ;2 WORD+16 address
MOV @S+,X ;2 X = src_len
MOV @S+,Y ;2 Y = src_org
ADD Y,X ;1 X = src_len + src_org = src_end
ADD @S+,Y ;2 Y = >IN + src_org = src_ptr
MOV @S,W ;2 W = HERE = dst_ptr
;-------------------------------;
SKIPSEPLOOP CMP X,Y ;1 src_ptr >= src_end ?
JC SKIPSEPEND ;2 if yes : End Of Line !
CMP.B @Y+,TOS ;2 does char = separator ?
JZ SKIPSEPLOOP ;2 if yes; 7~ loop
SUB #1,Y ;1 decrement the post incremented src_ptr
;-------------------------------;
SCANTICK CMP.B #"'",2(Y) ;4 third char = TICK ? (that allows ' as first char for a definition name)
JNZ SCANWRDLOOP ;2 no
MOV #0,T ;1 don't capitalize a 'char' input
;-------------------------------;
SCANWRDLOOP MOV.B S,0(W) ;3 first, make room in dst for word length; next, put char here.
CMP X,Y ;1 src_ptr = src_end ?
JZ SCANWRDEND ;2 if yes
MOV.B @Y+,S ;2 S=char
CMP.B S,TOS ;1 -- sep does char = separator ?
JZ SCANWRDEND ;2 if yes
ADD #1,W ;1 increment dst
CMP.B #'a',S ;2 char U< 'a' ? this condition is tested at each loop
JNC SCANWRDLOOP ;2 16~ upper case char loop
CMP.B #'z'+1,S ;2 char U>= 'z'+1 ?
JC SCANWRDLOOP ;2 U>= loopback if yes
SUB.B T,S ;1 convert a...z to A...Z if CAPS ON (T=$20)
JMP SCANWRDLOOP ;2 23~ lower case char loop
SKIPSEPEND
SCANWRDEND SUB &SOURCE_ORG,Y ;3 -- sep Y=src_ptr - src_org = new >IN (first char separator next)
MOV Y,&TOIN ;3 update >IN for next search in this input stream
MOV &DP,TOS ;3 -- addr TOS = HERE
SUB TOS,W ;1 W = Word_Length >= 0
MOV.B W,0(TOS) ;3 -- c-addr
MOV @IP+,PC ;4 Z=1 <==> Word_Length = 0 <==> EOL, tested by INTERPRET
FORTHWORD "FIND" ;
; https://forth-standard.org/standard/core/FIND
; FIND addr -- c-addr 0 if not found ; flag Z=1 c-addr at transient RAM area (HERE)
; CFA -1 if found ; flag Z=0
; CFA 1 if immediate ; flag Z=0
; compare WORD at c-addr (HERE) with each of words in each of listed vocabularies in CONTEXT
; start of FIND : 24/33 cycles
; +7 cycles on first char,
; +10 cycles x (n-1 char),
; WORDFOUND to end : 16 cycles.
; VOCLOOP : 12/19 cycles.
; name loop : 8 cycles.
; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time
FIND SUB #2,PSP ;1 -- ???? c-addr reserve one cell, not at FINDEND which would kill the Z flag
MOV TOS,S ;1 S=c-addr
MOV #CONTEXT,T ;2 T = first cell addr of CONTEXT stack
VOCLOOP MOV @T+,TOS ;2 -- ???? VOC_PFA T=CTXT+2
CMP #0,TOS ;1 TOS = BODY = voclink; no more vocabulary in CONTEXT ?
JZ FINDEND ;2 -- ???? 0 yes ==> exit; Z=1
.SWITCH THREADS
.CASE 1 ; nothing to do
.ELSECASE ; searching thread adds 7 cycles & 6 words
MOV.B 1(S),Y ;3 -- ???? VOC_PFA0 S=c-addr Y=first char of c-addr string
AND.B #(THREADS-1),Y;2 -- ???? VOC_PFA0 Y=thread_x
ADD Y,Y ;1 -- ???? VOC_PFA0 Y=thread_offset_x
ADD Y,TOS ;1 -- ???? VOC_PFAx TOS = words set entry
.ENDCASE
ADD #2,TOS ;1 -- ???? VOC_PFAx+2
WORDLOOP MOV -2(TOS),TOS ;3 -- ???? NFA -2(TOS) = [VOC_PFAx] first, then [LFA]
CMP #0,TOS ;1 no more word in the thread ?
JZ VOCLOOP ;2 yes ==> search next voc in context
MOV TOS,X ;1
MOV.B @X+,Y ;2 TOS = NFA, X= NFA+1, Y = NFA_first_byte = cnt<<2+i (i= immediate flag)
RRA.B Y ;1 remove immediate flag, the remainder is the count of the definition name.
LENCOMP CMP.B @S,Y ;2 compare lenght
JNZ WORDLOOP ;2 14~ word loop on lenght mismatch
MOV S,W ;1 S=W=c-addr
CHARCOMP CMP.B @X+,1(W) ;4 compare chars
JNZ WORDLOOP ;2 21~ word loop on first char mismatch
ADD #1,W ;1
SUB.B #1,Y ;1 decr count
JNZ CHARCOMP ;2 10~ char loop
WORDFOUND BIT #1,X ;1
ADDC #0,X ;1
MOV X,S ;1 S=aligned CFA
MOV.B @TOS,TOS ;2 -- ???? NFA_1st_byte
AND #1,TOS ;1 -- ???? 0|1 test immediate flag
JNZ FINDEND ;2 -- ???? 1 jump if bit 1 is set, as immediate bit
SUB #1,TOS ;1 -- ???? -1
FINDEND MOV S,0(PSP) ;3 -- xt -1/0/1 if not found: -- c-addr 0 flag Z=1
MOV @IP+,PC ;4 34/40 words return to interpreter
FORTHWORD ">NUMBER"
; >NUMBER ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2
; https://forth-standard.org/standard/core/toNUMBER
; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
; Conversion continues left-to-right until a character that is not convertible (including '.' ',' '_')
; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
; or the first character past the end of the string if the string was entirely converted.
; cnt2 is the number of unconverted characters in the string.
; An ambiguous condition exists if ud2 overflows during the conversion.
MOV &BASEADR,T ;3 T = base
MOV @PSP+,S ;2 -- ud1lo ud1hi cnt1 S = addr1
MOV @PSP+,Y ;2 -- ud1lo cnt1 Y = ud1hi
MOV @PSP,X ;2 -- x cnt1 X = ud1lo
SUB #4,PSP ;1 -- x x x cnt1
TONUM_INPUT ; for QNUMBER
.IFDEF MPY_32 ; if 32 bits hardware multiplier
MOV T,&MPY ;3 base = MPY = OP1 loaded out of TONUMLOOP
.ENDIF
TONUMLOOP MOV.B @S,W ;2 -- x x x cnt S=adr, T=base, W=char, X=udlo, Y=udhi
DDIGITQ SUB.B #':',W ;2 all Ctrl_Chars < '0' and all chars '0' to '9' become negative
JNC DDIGITQNEXT ;2 accept all chars U< ':' (accept $0 up to $39)
SUB.B #7,W ;2 W = char - (':' + $07 = 'A')
JNC TONUMEND ;2 -- x x x cnt reject all Ctrl_Chars U< 'A', (with Z flag = 0)
DDIGITQNEXT ADD.B #0Ah,W ;2 restore digit value: 0 to 15 (and beyond)
CMP T,W ;1 digit - base
BIC #Z,SR ;1 clear Z before return to QNUMBER
JC TONUMEND ;2 to avoid QNUMBER conversion true with digit=base :-(
.IFDEF MPY_32 ; if 32 bits hardware multiplier (ud * base) + digit --> ud
MOV X,&OP2L ;3 Load 2nd operand (ud1lo)
MOV Y,&OP2H ;3 Load 2nd operand (ud1hi)
MOV &RES0,X ;3 lo result in X (ud2lo)
MOV &RES1,Y ;3 hi result in Y (ud2hi)
ADD_DIGIT ADD W,X ;1 ud2lo + digit
ADDC #0,Y ;1 ud2hi + carry
TONUMPLUS ADD #1,S ;1 adr+1
SUB #1,TOS ;1 -- x x x cnt-1 cnt-1
JNZ TONUMLOOP ;2 if count <>0 33~ per digit
TONUMEND MOV S,0(PSP) ;3 -- x x addr2 cnt2
.ELSE ; no hardware multiplier (ud * base) + digit --> ud
MOV #0,rDODOES ;1 RESlo=0
MOV #0,rDOCON ;1 REShi=0
MOV #1,rDOVAR ;1 BIT TEST for base
MUL_LOOP BIT rDOVAR,T ;1 test actual bit in base (OP1)
JZ MUL_SHIFT ;2
ADD X,rDODOES ;1 IF 1: ADD ud1lo TO RESlo (OP2L + RES0 --> RES0)
ADDC Y,rDOCON ;1 ADDC ud1hi TO REShi (OP2H + RES1 + C --> RES1)
MUL_SHIFT ADD X,X ;1 (RLA LSBs) ud1lo *2 (OP2L*2)
ADDC Y,Y ;1 (RLC MSBs) ud1hi *2 (OP2H*2)
ADD rDOVAR,rDOVAR ;1 (RLA) NEXT BIT TO TEST (BIT_TEST<1)
JNC MUL_LOOP ;2 IF BIT IN CARRY: FINISHED
MOV rDODOES,X ;1 RESlo --> ud2lo
MOV rDOCON,Y ;1 REShi --> ud2hi
ADD_DIGIT ADD W,X ;1 ud2lo + digit
ADDC #0,Y ;1 ud2hi + carry
TONUMPLUS ADD #1,S ;1 adr+1
SUB #1,TOS ;1 -- x x x cnt-1 cnt-1
JNZ TONUMLOOP ;2 if count <>0 158/160/158 ~ per digit with base 2/10/16
TONUMEND MOV #FORTH_ORG+4,W ;2
MOV @W+,rDODOES ;2 XDODOES --> R5=rDODOES
MOV @W+,rDOCON ;2 XDOCON --> R6=rDOCON
MOV @W,rDOVAR ;2 RFROM --> R7=rDOVAR
MOV S,0(PSP) ;3 -- x x addr2 cnt2
.ENDIF
MOV Y,2(PSP) ;3 -- x ud2hi addr2 cnt2
MOV X,4(PSP) ;3 -- ud2lo ud2hi addr2 cnt2
MOV @IP+,PC ;4
; ?NUMBER makes the interface between INTERPRET and >NUMBER; also used by ASSEMBLER.
; convert a string to a signed number; FORTH 2012 prefixes $ % # are recognized,
; FORTH 2012 'char' numbers also, digits separator '_' also.
; with DOUBLE_INPUT option, 32 bits signed numbers (with decimal point) are recognized,
; with FIXPOINT_INPUT option, Q15.16 signed numbers (with comma) are recognized.
; prefixes ' # % $ - are processed before calling >NUMBER
; chars . , _ are processed as >NUMBER exits.
;Z ?NUMBER addr -- n|d -1 if convert ok ; flag Z=0, UF9=1 if double
;Z addr -- addr 0 if convert ko ; flag Z=1
INTQNUM MOV #INTQNUMNEXT,IP ;2 INTQNUMNEXT is the next of QNUMBER
QNUMBER ; -- addr
.IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
BIC #UF9,SR ;2 clear UserFlag_9 used as double number flag
.ENDIF ;
SUB #8,PSP ;1 -- x x x x addr make room for >NUMBER
MOV TOS,6(PSP) ;3 -- addr x x x addr save TOS for TONUMEXIT
MOV #0,Y ;1 Y=ud1hi=0
MOV #0,X ;1 X=ud1lo=0
MOV &BASEADR,T ;3 T=BASE
MOV TOS,S ;1 S=addr
MOV #0,TOS ;1 TOS=sign of result
PUSHM #2,TOS ;4 R-- sign IP PUSH TOS,IP
MOV #TONUMEXIT,IP ;2 set TONUMEXIT as return from >NUMBER
MOV.B @S+,TOS ;2 -- addr x x x cnt TOS=count, S=addr+1
QNUMLDCHAR MOV.B @S,W ;2 W=char
SUB.B #'-',W ;2 char '-' ?
JZ QNUMMINUS ;2 negate sign
JC TONUM_INPUT ;2 -- addr x x x cnt jump if char U> '-', case of numeric chars
QBINARY MOV #2,T ;1 preset base 2
ADD.B #8,W ;1 binary '%' prefix ? '%' + 8 = '-'
JZ PREFIXNEXT ;2 yes
QDECIMAL ADD #8,T ;1 preset base 10
ADD.B #2,W ;1 decimal '#' prefix ? '#' + 2 = '%'
JZ PREFIXNEXT ;2 yes
QHEXA MOV #16,T ;2 preset base 16
CMP.B #1,W ;1 hex '$' prefix ? '#' + 1 = '$'
JZ PREFIXNEXT ;2 yes
QTICK CMP.B #4,W ;1 ' prefix ? '#' + 4 = "'"
JNZ QNUMNEXT ;2 -- addr x x x cnt no, abort because other prefixes not recognized
CMP #3,TOS ;2 count = 3 ?
JNZ QNUMNEXT ;2 no, abort
CMP.B @S+,1(S) ;4 -- addr x x x 3 3rd char = 1st char ?
MOV.B @S,S ;2 does byte to word conversion
MOV S,4(PSP) ;3 -- addr ud2lo x x 3 ud2lo = ASCII code of 'char'
JMP QNUMNEXT ;2 -- addr ud2lo x x 3 with happy end only if 3rd char = 1st char = '
QNUMMINUS MOV #-1,2(RSP) ;3 R-- sign IP set sign flag
PREFIXNEXT SUB #1,TOS ;1 -- addr x x x cnt-1 TOS=count-1
CMP.B @S+,0(S) ;4 S=adr+1; same prefix ?
JNZ QNUMLDCHAR ;2 loopback if no
JZ TONUM_INPUT ;2 if yes, this double prefix will be rejected by >NUMBER
; ------------------------------;46
TONUMEXIT mNEXTADR ; -- addr ud2lo-hi addr2 cnt2 R-- IP sign BASE S=addr2
JZ QNUMNEXT ;2 TOS=0 and Z=1 if conversion is ok
SUB #2,IP ;1 redefines TONUMEXIT as >NUMBER return, if loopback applicable
MOV.B @S,W ;2 reload rejected char
CMP.B #'_',W ;2 rejected char by >NUMBER is a underscore ?
JZ TONUMPLUS ;2 yes: return to >NUMBER to skip char then resume conversion, 30~ loopback
.IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
BIT #UF9,SR ;2 UF9 already set ? ( if you have typed .. )
JNZ QNUMNEXT ;2 yes, goto QNUMKO
BIS #UF9,SR ;2 set double number flag
.ENDIF
.IFDEF DOUBLE_INPUT ;
SUB.B #'.',W ;2 rejected char by >NUMBER is a decimal point ?
JZ TONUMPLUS ;2 yes, loopback to >NUMBER to skip char, 45~ loopback
.ENDIF ;
.IFDEF FIXPOINT_INPUT ;
.IFDEF DOUBLE_INPUT
ADD.B #2,W ;1 rejected char by >NUMBER is a comma ? (',' - '.' + 2 = 0)
.ELSE ;
CMP.B #',',W ;2 rejected char by >NUMBER is a comma ?
.ENDIF ;
JNZ QNUMNEXT ;2 no: with Z=0 ==> goto QNUMKO
; ------------------------------; -- addr ud2lo x x x S=addr2, T=base
S15Q16 MOV TOS,W ;1 -- addr ud2lo x x x W=cnt2
MOV #0,X ;1 -- addr ud2lo x x x init X = ud2lo' = 0
S15Q16LOOP MOV X,2(PSP) ;3 -- addr ud2lo ud2lo' x x 2(PSP) = X = ud2lo' = 0 then uqlo
SUB.B #1,W ;1 decrement cnt2
MOV W,X ;1 X = cnt2-1
ADD S,X ;1 X = end_of_string-1,-2,-3...
MOV.B @X,X ;2 X = last char of string first (reverse conversion)
SUB.B #':',X ;2
JNC QS15Q16DIGI ;2 accept all chars U< ':'
SUB.B #7,X ;2
JNC S15Q16EOC ;2 reject all chars U< 'A'
QS15Q16DIGI ADD.B #10,X ;2 restore digit value
CMP T,X ;1 T=Base, is X a digit ?
JC S15Q16EOC ;2 -- addr ud2lo ud2lo' x x if not a digit, --> goto QNUMKO
MOV X,0(PSP) ;3 -- addr ud2lo ud2lo' digit x
MOV T,TOS ;1 -- addr ud2lo ud2lo' digit base R-- IP sign
PUSHM #3,S ;5 -- addr ud2lo ud2lo' ud2hi' base PUSH S,T,W: R-- IP sign addr2 base cnt2
CALL #MUSMOD ;4 CALL MU/MOD
POPM #3,S ;5 -- addr ud2lo ur uqlo uqhi restore W,T,S: R-- IP sign
JMP S15Q16LOOP ;2 X=uqlo
S15Q16EOC MOV 4(PSP),2(PSP) ;5 -- addr ud2lo ud2hi uqlo uqhi ud2lo from >NUMBER becomes ud2hi part of Q15.16
MOV @PSP,4(PSP) ;4 -- addr ud2lo ud2hi uqlo uqhi uqlo becomes ud2lo part of Q15.16
CMP.B #0,W ;1 count = 0 if end of conversion ok
.ENDIF ; FIXPOINT_INPUT
; ------------------------------;
QNUMNEXT POPM #2,TOS ;4 -- addr ud2lo-hi x sign R: -- POPM IP,TOS TOS = sign flag = {-1;0}
JZ QNUMOK ;2 -- addr ud2lo-hi x sign conversion OK if Z=1
; ------------------------------;
QNUMKO ADD #6,PSP ;2 -- addr sign
AND #0,TOS ;1 -- addr ff TOS=0 and Z=1 ==> conversion ko
MOV @IP+,PC ;4
; ------------------------------;
.IFDEF DOUBLE_NUMBERS ; -- addr ud2lo-hi x sign
QNUMOK ADD #2,PSP ;1 -- addr ud2lo-hi sign
MOV 2(PSP),4(PSP) ;5 -- udlo udlo udhi sign
MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back.
XOR #-1,TOS ;1 -- udlo udhi inv(sign)
JNZ QDOUBLE ;2 -- udlo udhi tf if jump : TOS=-1 and Z=0 ==> conversion ok
XOR #-1,TOS ;1 -- udlo udhi tf
QDNEGATE XOR #-1,2(PSP) ;3 -- udlo udhi -1
XOR #-1,0(PSP) ;3 -- (dlo dhi)-1 tf
ADD #1,2(PSP) ;3
ADDC #0,0(PSP) ;3
QDOUBLE BIT #UF9,SR ;2 -- dlo dhi tf decimal point or comma fixpoint ?
JZ NIP ;2 no, remove dhi, set Z=0
QNUMEND MOV @IP+,PC ;4 TOS=tf and Z=0 ==> conversion ok
.ELSE
QNUMOK ADD #4,PSP ;1 -- addr ud2lo sign
MOV @PSP,2(PSP) ;4 -- u u sign note : PSP is incremented before write back !!!
XOR #-1,TOS ;1 -- udlo udhi inv(sign)
JNZ QNUMEND ;2 -- udlo udhi tf if jump : TOS=-1 and Z=0 ==> conversion ok
XOR #-1,TOS ;1 -- udlo udhi sign
QNEGATE XOR #-1,2(PSP) ;3
ADD #1,2(PSP) ;3 -- n u tf
QNUMEND ADD #2,PSP ;1 -- n tf
MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok
.ENDIF ; DOUBLE_NUMBERS ;
FORTHWORDIMM "\\" ; immediate
; https://forth-standard.org/standard/block/bs
; \ -- backslash
; everything up to the end of the current line is a comment.
BACKSLASH MOV &SOURCE_LEN,&TOIN ;
MOV @IP+,PC
; ------------------------------;
; INTERPRET=\\+8 ;
; EXECUTE=\\+$28; ;
; ------------------------------;
; ------------------------------;
; INTERPRET i*x addr u -- j*x interpret given buffer
; This is the common factor of EVALUATE and QUIT.
; set addr u as input buffer then parse it word by word
INTERPRET mDOCOL ; INTERPRET = BACKSLASH + 8
.word SETIB ; -- set input buffer pointers
INTLOOP .word BL_WORD ; -- c-addr flag Z = 1 <=> End Of Line
.word ZBRAN,FDROPEXIT; early return if End of Line
.word FIND ;
mNEXTADR ; -- xt|c-addr|xt -1|0|+1 Z=1 --> not found
MOV TOS,W ; W = flag = (-1|0|+1) as (not_immediate|not_found|immediate)
MOV @PSP+,TOS ; -- xt|c-addr|xt
JZ INTQNUM ;2 if Z=1 --> not found, search a number from c_addr
MOV #INTLOOP,IP ;2 INTLOOP is the next of EXECUTE|COMMA
XOR &STATE,W ;3
JZ COMMA ;2 -- xt if W xor STATE = 0 compile xt, then loop back to INTLOOP
EXECUTE PUSH TOS ;3 -- xt
MOV @PSP+,TOS ;2 --
MOV @RSP+,PC ;4 xt --> PC, then loop back to INTLOOP
; ------------------------------;
INTQNUMNEXT mNEXTADR ; -- n|c-addr fl Z = 1 --> not a number, SR(UF9) double number request
MOV @PSP+,TOS ;2 -- n|c-addr
MOV #INTLOOP,IP ;2 INTLOOP is the next of LITERAL.
JNZ LITERAL ;2 n -- Z = 0 --> is a number, execute LITERAL then loop back to INTLOOP
NOTFOUND MOV #FQABORT_YES,IP ;2 QABORT_YES becomes the end of INTERPRET
ADD.B #1,0(TOS) ;3 c-addr -- Z = 1 --> Not a Number : incr string count to add '?'
MOV.B @TOS,Y ;2 Y=count+1
ADD TOS,Y ;1 Y=end of string addr
MOV.B #'?',0(Y) ;5 add '?' to end of string
JMP COUNT ;2 -- addr len return to ABORT_TERM
FDROPEXIT .word DROPEXIT
FORTHWORDIMM "LITERAL" ; immediate
.IFDEF DOUBLE_NUMBERS ; are recognized
; https://forth-standard.org/standard/core/LITERAL
; LITERAL n -- append single numeric literal if compiling state
; d -- append two numeric literals if compiling state and UF9<>0 (not ANS)
LITERAL CMP #0,&STATE ;3
JZ LITERALNEXT ;2 if interpreting state, does nothing else to clear UF9 flag
MOV TOS,X ;1 X = n|dhi
LITERALLOOP MOV &DP,W ;3
ADD #4,&DP ;3
MOV #LIT,0(W) ;4
MOV X,2(W) ;3 pass 1: compile n, if pass 2: compile dhi
MOV @PSP+,TOS ;2
BIT #UF9,SR ;2 double number ?
LITERALNEXT BIC #UF9,SR ;2 in all case, clear UF9
JZ LITERALEND ;2 no goto end if n|interpret_state
MOV TOS,2(W) ;3 yes compile dlo over dhi
JMP LITERALLOOP ;2
LITERALEND MOV @IP+,PC ;4
.ELSE
; https://forth-standard.org/standard/core/LITERAL
; LITERAL n -- append single numeric literal if compiling state
LITERAL CMP #0,&STATE ;3
JZ LITERALEND ;2 if interpreting state, does nothing
MOV &DP,W ;3
ADD #4,&DP ;3
MOV #LIT,0(W) ;4
MOV TOS,2(W) ;3
MOV @PSP+,TOS ;2
LITERALEND MOV @IP+,PC ;4
.ENDIF
; https://forth-standard.org/standard/core/DEPTH
; DEPTH -- +n number of items on stack, must leave 0 if stack empty
QDEPTH MOV TOS,-2(PSP) ; 3
MOV #PSTACK,TOS ; 2
SUB PSP,TOS ; 1 PSP-S0--> TOS
RRA TOS ; 1 TOS/2 --> TOS
SUB #2,PSP ; 1
; https://forth-standard.org/standard/core/Zeroless
; 0< n -- flag true if TOS negative
ZEROLESS ADD TOS,TOS ;1 set carry if TOS negative
SUBC TOS,TOS ;1 TOS=-1 if carry was clear
INVERT XOR #-1,TOS ;1 TOS=-1 if carry was set
MOV @IP+,PC ;4
QFRAM_FULL SUB #2,PSP ; 2
MOV TOS,0(PSP) ; 3
MOV #0,TOS ; 1
CMP #FRAM_FULL,&DP ; 4
JC INVERT ; 2
MOV @IP+,PC ; 4 16~
FORTHWORD "COUNT"
; https://forth-standard.org/standard/core/COUNT
; COUNT c-addr1 -- adr len counted->adr/len
COUNT SUB #2,PSP ;1
MOV.B @TOS+,W ;2
MOV TOS,0(PSP) ;3
MOV W,TOS ;1
AND #-1,TOS ;1 Z is set if u=0
MOV @IP+,PC ;4 12~
FORTHWORD "ALLOT"
; https://forth-standard.org/standard/core/ALLOT
; ALLOT n -- allocate n bytes
ADD TOS,&DP
MOV @PSP+,TOS
MOV @IP+,PC
; ----------------------------------;
; ABORT = ALLOT + $08 ;
; QUIT = ALLOT + $0E ;
; ----------------------------------;
; FORTHWORD "ABORT"