-
Notifications
You must be signed in to change notification settings - Fork 66
/
forth.asm
4060 lines (3437 loc) · 97.5 KB
/
forth.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
; STM8EF for STM8S (Value line and Access Line devices)
;
; This is derived work based on
; http://www.forth.org/svfig/kk/07-2010.html
;
; Please refer to LICENSE.md for more information.
;
;--------------------------------------------------------
; Original author, and copyright:
; STM8EF, Version 2.1, 13jul10cht
; Copyright (c) 2000
; Dr. C. H. Ting
; 156 14th Avenue
; San Mateo, CA 94402
; (650) 571-7639
;
; Original main description:
; FORTH Virtual Machine:
; Subroutine threaded model
; SP Return stack pointer
; X Data stack pointer
; A,Y Scratch pad registers
;
;--------------------------------------------------------
; The latest version of this code is available at
; https://github.com/TG9541/stm8ef
;
;
; Docs for the SDCC integrated assembler are scarce, thus
; SDCC was used to write the skeleton for this file.
; However, the code in this file isn't SDCC code.
;--------------------------------------------------------
; File Created by SDCC : free open source ANSI-C Compiler
; Version 3.6.0 #9615 (Linux)
;--------------------------------------------------------
.module forth
.optsdcc -mstm8
;--------------------------------------------------------
; Public variables in this module
;--------------------------------------------------------
.globl _TRAP_Handler
.globl _forth
;--------------------------------------------------------
; ram data
;--------------------------------------------------------
.area DATA
;--------------------------------------------------------
; ram data
;--------------------------------------------------------
.area INITIALIZED
;--------------------------------------------------------
; absolute external ram data
;--------------------------------------------------------
.area DABS (ABS)
;--------------------------------------------------------
; global & static initialisations
;--------------------------------------------------------
.area HOME
.area GSINIT
.area GSFINAL
.area GSINIT
;--------------------------------------------------------
; Home
;--------------------------------------------------------
.area HOME
.area HOME
;--------------------------------------------------------
; code
;--------------------------------------------------------
.area CODE
;************************************
;****** 1) General Constants ******
;************************************
TRUEE = 0xFFFF ; true flag
COMPO = 0x40 ; "COMPO" lexicon compile only bit
IMEDD = 0x80 ; "IMEDD" lexicon immediate bit
MASKK = 0x1F7F ; "MASKK" lexicon bit mask
TIBLENGTH = 80 ; size of TIB (starting at TIBOFFS)
PADOFFS = 80 ; "PADOFFS" offset text buffer above dictionary
CELLL = 2 ; size of a cell
BASEE = 10 ; default radix
BKSPP = 8 ; backspace
LF = 10 ; line feed
PACE = 11 ; pace character for host handshake (ASCII VT)
CRR = 13 ; carriage return
ERR = 27 ; error escape
TIC = 39 ; tick
EXIT_OPC = 0x81 ; RET opcode
DOLIT_OPC = 0x83 ; TRAP opcode as DOLIT
CALLR_OPC = 0xAD ; CALLR opcode for relative addressing
BRAN_OPC = 0xCC ; JP opcode
CALL_OPC = 0xCD ; CALL opcode
; Chip type (set of peripheral addresses and features)
STM8S_LOD = 103 ; STM8S Low Density
STM8S_MED = 105 ; STM8S Medium Density
STM8S_HID = 207 ; STM8S High Density
STM8L_LOD = 051 ; STM8L Low Density, RM0031 family
STM8L_101 = 101 ; STM8L Low Density, RM0013 family
STM8L_MHD = 152 ; STM8L Medium and High Density
; STM8 family flags
STM8S = 0 ; FAMILY: STM8S device
STM8L = 1 ; FAMILY: STM8L device
; legacy chip type (deprecated - preferably use the chip type constants)
STM8L101F3 = STM8L_101 ; L core, 8K flash incl EEPROM, 1.5K RAM, UART1
STM8L051F3 = STM8L_LOD ; L core, 8K flash, 1K RAM, 256 EEPROM, UART1
STM8L152C6 = STM8L_MHD ; L core, 32K flash, 2K RAM, 1K EEPROM, UART1
STM8L152R8 = STM8L_MHD ; L core, 64K flash, 4K RAM, 2K EEPROM, UART1
STM8S003F3 = STM8S_LOD ; 8K flash, 1K RAM, 128 EEPROM, UART1
STM8S103F3 = STM8S_LOD ; like STM8S003F3, 640 EEPROM
STM8S105K4 = STM8S_MED ; 16K/32K flash, 2K RAM, 1K EEPROM, UART2
STM8S207RB = STM8S_HID ; 32K+96K flash, 6K RAM, 2K EEPROM, UART1 or UART2
DEFOSCFREQ = 16000 ; default oscillator frequency in kHz (HSI)
;********************************************
;****** 2) Device hardware addresses ******
;********************************************
;****** STM8 memory addresses ******
RAMBASE = 0x0000 ; STM8 RAM start
; STM8 device specific include (provided by file in board folder)
; sets "TARGET" and memory layout
.include "target.inc"
; STM8 Flash Block Size (depends on "TARGET")
.ifeq (TARGET - STM8S_LOD) * (TARGET - STM8L_101) * (TARGET - STM8L_LOD)
PAGESIZE = 0x40 ; "PAGESIZE" STM8 Low Density: 64 byte page size
.else
PAGESIZE = 0x80 ; "PAGESIZE" STM8 M/H Density: 128 byte page size
.endif
; STM8 family register addresses (depends on "TARGET")
.ifeq (TARGET - STM8S_LOD) * (TARGET - STM8S_MED) * (TARGET - STM8S_HID)
FAMILY = STM8S
.include "stm8device.inc"
.endif
.ifeq (TARGET - STM8L_101) * (TARGET - STM8L_LOD) * (TARGET - STM8L_MHD)
FAMILY = STM8L
.include "stm8ldevice.inc"
.endif
;**********************************
;****** 3) Global defaults ******
;**********************************
; Note: add defaults for new features here
; and configure them in globconf.inc
.include "defconf.inc"
;********************************************
;****** 4) Device dependent features ******
;********************************************
; Define memory location for device dependent features here
.include "globconf.inc"
.include "linkopts.inc"
; console configuration: check if TX simulation has priority over UART
.ifge HAS_TXSIM - HAS_TXUART
.ifeq PNTX-PNRX
CONSOLE_HALF_DUPLEX = 1 ; single wire RX/TX simulation is half duplex
.else
CONSOLE_HALF_DUPLEX = 0 ; RX/TX simulation supports full duplex
.endif
.else
CONSOLE_HALF_DUPLEX = HALF_DUPLEX ; use hardware UART settings
.endif
OSCFREQ = DEFOSCFREQ ; "OSCFREQ" oscillator frequency in kHz
CRAMLEN = FORTHRAM ; "CRAMLEN" RAM starting from 0 not used by Forth
;**************************************
;****** 5) Board Driver Memory ******
;**************************************
; Memory for board related code, e.g. interrupt routines
RAMPOOL = FORTHRAM ; RAM for variables (growing up)
.macro RamByte varname
varname = RAMPOOL
RAMPOOL = RAMPOOL + 1
.endm
.macro RamWord varname
varname = RAMPOOL
RAMPOOL = RAMPOOL + 2
.endm
.macro RamBlck varname, size
varname = RAMPOOL
RAMPOOL = RAMPOOL + size
.endm
;**************************************************
;****** 6) General User & System Variables ******
;**************************************************
; ****** Indirect variables for code in NVM *****
.ifne HAS_CPNVM
ISPPSIZE = 16 ; Size of data stack for interrupt tasks
.else
ISPPSIZE = 0 ; no interrupt tasks without NVM
.endif
UPP = UPPLOC ; "C_UPP" offset user area
PADBG = UPPLOC-1 ; PAD in background task growing down from here
CTOP = CTOPLOC ; dictionary start, growing up
; note: PAD is inbetween CTOP and SPP
SPP = ISPP-ISPPSIZE ; "C_SPP" data stack, growing down (with SPP-1 first)
ISPP = SPPLOC-BSPPSIZE ; "C_ISPP" Interrupt data stack, growing down
BSPP = SPPLOC ; "C_BSPP" Background data stack, growing down
TIBB = SPPLOC ; "C_TIB" Term. Input Buf. TIBLENGTH between SPPLOC and RPP
RPP = RPPLOC ; "C_RPP" return stack, growing down
; Core variables (same order as 'BOOT initializer block)
USRRAMINIT = USREMIT
USREMIT = UPP+0 ; "'EMIT" execution vector of EMIT
USRQKEY = UPP+2 ; "'?KEY" execution vector of QKEY
USRBASE = UPP+4 ; "BASE" radix base for numeric I/O
; USR_6 = UPP+6 ; free
USRPROMPT = UPP+8 ; "'PROMPT" point to prompt word (default .OK)
USRCP = UPP+10 ; "CP" point to top of dictionary
USRLAST = UPP+12 ; "LAST" currently last name in dictionary
NVMCP = UPP+14 ; point to top of dictionary in Non Volatile Memory
; Null initialized core variables (growing down)
USRCTOP = UPP+16 ; "CTOP" point to the start of RAM dictionary
USRVAR = UPP+18 ; "VAR" point to next free USR RAM location
NVMCONTEXT = UPP+20 ; point to top of dictionary in Non Volatile Memory
USRCONTEXT = UPP+22 ; "CONTEXT" start vocabulary search
USREVAL = UPP+24 ; "'EVAL" execution vector of EVAL
USRNTIB = UPP+26 ; "#TIB" count in terminal input buffer
USR_IN = UPP+28 ; ">IN" hold parsing pointer
USRBUFFER = UPP+30 ; "BUFFER" address, defaults to TIBB
; More core variables in zero page (instead of assigning fixed addresses)
RamWord USRHLD ; "HLD" hold a pointer of output string
RamWord YTEMP ; extra working register for core words
RamWord USRIDLE ; "'IDLE" idle routine in KEY
;***********************
;****** 7) Code ******
;***********************
; ==============================================
; Forth header macros
; Macro support in SDCC's assembler "SDAS" has some quirks:
; * strings with "," and ";" aren't allowed in parameters
; * after include files, the first macro call may fail
; unless it's preceded by unconditional code
; ==============================================
LINK = 0 ;
.macro HEADER Label wName
.ifeq UNLINK_'Label
.dw LINK
LINK = .
.db (102$ - 101$)
101$:
.ascii wName
102$:
.endif
;'Label:
.endm
.macro HEADFLG Label wName wFlag
.ifeq UNLINK_'Label
.dw LINK
LINK = .
.db ((102$ - 101$) + wFlag)
101$:
.ascii wName
102$:
.endif
;'Label:
.endm
; ==============================================
; Low level code
; ==============================================
; TRAP handler for DOLIT
; Push the inline literal following the TRAP instruction
_TRAP_Handler:
.ifeq USE_CALLDOLIT
DECW X
DECW X
LDW (3,SP),X ; XH,XL
EXGW X,Y
LDW X,(8,SP) ; PC MSB/LSB
LDW X,(X)
LDW (Y),X
LDW (5,SP),X ; YH,YL
LDW X,(8,SP)
INCW X
INCW X
LDW (8,SP),X
IRET
; Macros for inline literals using the TRAP approach
.macro DoLitC c
TRAP
.dw c
.endm
.macro DoLitW w
TRAP
.dw w
.endm
.else
; Macros for inline literals using CALL DOLIT / CALL DOLITC
.macro DoLitC c
call DOLITC
.db c
.endm
.macro DoLitW w
call DOLIT
.dw w
.endm
.endif
; ==============================================
; Includes for board support code
; Board I/O initialization and E/E mapping code
; Hardware dependent words, e.g. BKEY, OUT!
.include "boardcore.inc"
; ADC routines depending on STM8 family
.include "stm8_adc.inc"
; Generic board I/O: 7S-LED rendering, board key mapping
.include "board_io.inc"
; Simulate serial interface code
.include "sser.inc"
; Background Task: context switch with wakeup unit or timer
.include "bgtask.inc"
; ==============================================
; Configuation table with shadow data for RESET
; 'BOOT ( -- a )
; The application startup vector and NVM USR setting array
HEADER TBOOT "'BOOT"
TBOOT:
CALL DOVAR
UBOOT = .
.dw HI ; start-up code (can be changed with 'BOOT !)
; COLD initialization data (can be changed with <offset> 'BOOT + !)
UZERO = .
.ifge (HAS_TXUART-HAS_TXSIM)
.dw TXSTOR ; TX! as EMIT vector
.dw QRX ; ?KEY as ?KEY vector
.else
.dw TXPSTOR ; TXP! as EMIT vector if (HAS_TXSIM > HAS_TXUART)
.dw QRXP ; ?RXP as ?KEY vector
.endif
.dw BASEE ; BASE
.dw 0 ; (vacant)
.dw DOTOK ; 'PROMPT
COLDCTOP = .
.dw CTOP ; CP in RAM
COLDCONTEXT = .
.dw LASTN ; USRLAST
.ifne HAS_CPNVM
COLDNVMCP = .
.dw END_SDCC_FLASH ; CP in NVM
ULAST = .
; Shadow initialization data for RESET (can be changed with PERSIST)
UDEFAULTS = .
.dw HI ; 'BOOT
.ifge (HAS_TXUART-HAS_TXSIM)
.dw TXSTOR ; TX! as EMIT vector
.dw QRX ; ?KEY as ?KEY vector
.else
.dw TXPSTOR ; TXP! as EMIT vector
.dw QRXP ; ?RXP as ?KEY vector
.endif
.dw BASEE ; BASE
.dw 0 ; (vacant)
.dw DOTOK ; 'PROMPT
.dw CTOP ; CP in RAM
.dw LASTN ; CONTEXT pointer
.dw END_SDCC_FLASH ; CP in NVM
.else
ULAST = .
.endif
; Main entry points and COLD start data
; COLD ( -- )
; The hilevel cold start sequence.
HEADER COLD "COLD"
_forth: ; SDCC entry
; Note: no return to main.c possible unless RAMEND equals SP,
; and RPP init skipped
COLD:
SIM ; disable interrupts
MOV CLK_CKDIVR,#0 ; Clock divider register
LDW X,#(RAMEND-FORTHRAM)
1$: CLR (FORTHRAM,X)
DECW X
JRPL 1$
LDW X,#RPP ; return stack, growing down
LDW SP,X ; initialize return stack
; see "boardcore.inc")
CALL BOARDINIT ; "PC_BOARDINIT" Board initialization
BGTASK_Init ; macro for init of BG task timer, refer to bgtask.inc
.ifne HAS_RXUART+HAS_TXUART
; Init RS232 communication port
; STM8S[01]003F3 init UART
LDW X,#CUARTBRR ; "UARTBRR" def. $6803 / 9600 baud
LDW UART_BRR1,X
.ifne HAS_RXUART*HAS_TXUART
MOV UART_CR2,#0x0C ; Use UART1 full duplex
.ifne HALF_DUPLEX
.ifeq (FAMILY - STM8S)
.ifeq (HALF_DUPLEX - 1)
; STM8S UART1, UART4: pull-up for PD5 single-wire UART
BRES PD_DDR,#5 ; PD5 GPIO input high
BSET PD_CR1,#5 ; PD5 GPIO pull-up
.endif
.ifeq (HALF_DUPLEX - 2)
; STM8S903 type Low Density devices can re-map UART-TX to PA3
LD A,OPT2
AND A,#0x03
CP A,#0x03
JREQ $1
; pull-up for PD5 single-wire UART
BRES PD_DDR,#5 ; PD5 GPIO input high
BSET PD_CR1,#5 ; PD5 GPIO pull-up
JRA $2
$1:
; pull-up for PA3 single-wire UART
BRES PA_DDR,#3 ; PA3 GPIO input high
BSET PA_CR1,#3 ; PA3 GPIO pull-up
$2:
.endif
.endif
MOV UART_CR5,#0x08 ; UART1 Half-Duplex
.endif
.else
.ifne HAS_TXUART
MOV UART_CR2,#0x08 ; UART1 enable tx
.endif
.ifne HAS_RXUART
MOV UART_CR2,#0x04 ; UART1 enable rx
.endif
.endif
.endif
SSER_Init ; macro for init of simulated serial, refer to sser.inc
Board_IO_Init ; macro board_io initialization (7S-LED)
CALL PRESE ; initialize data stack, TIB
DoLitW UZERO
DoLitC USRRAMINIT
DoLitC (ULAST-UZERO)
CALL CMOVE ; initialize user area
CALL WIPE ; initialize dictionary
; Hardware initialization complete
RIM ; enable interrupts
CALL [TBOOT+3] ; application boot
JP QUIT ; start interpretation
; ==============================================
; Device dependent I/O
.ifne HAS_RXUART
; ?RX ( -- c T | F ) ( TOS STM8: -- Y,Z,N )
; Return serial interface input char from and true, or false.
HEADER QRX "?RX"
QRX:
CLR A ; A: flag false
BTJF UART_SR,#5,1$
LD A,UART_DR ; get char in A
1$: JP ATOKEY ; push char or flag false
.endif
.ifne HAS_TXUART
; TX! ( c -- )
; Send character c to the serial interface.
HEADER TXSTOR "TX!"
TXSTOR:
INCW X
LD A,(X)
INCW X
.ifne HALF_DUPLEX
; HALF_DUPLEX with normal UART (e.g. wired-or Rx and Tx)
1$: BTJF UART_SR,#7,1$ ; loop until tdre
BRES UART_CR2,#2 ; disable rx
LD UART_DR,A ; send A
2$: BTJF UART_SR,#6,2$ ; loop until tc
BSET UART_CR2,#2 ; enable rx
.else ; not HALF_DUPLEX
1$: BTJF UART_SR,#7,1$ ; loop until tdre
LD UART_DR,A ; send A
.endif
RET
.endif
; ==============================================
; Device independent I/O
; ?KEY ( -- c T | F ) ( TOS STM8: -- Y,Z,N )
; Return input char and true, or false.
HEADER QKEY "?KEY"
QKEY:
JP [USRQKEY]
; EMIT ( c -- )
; Send character c to output device.
HEADER EMIT "EMIT"
EMIT:
JP [USREMIT]
; ==============================================
; The kernel
; PUSHLIT ( - C )
; Subroutine for DOLITC and CCOMMALIT
PUSHLIT:
LDW Y,(3,SP)
DECW X ; LSB = literal
LD A,(Y)
LD (X),A
DECW X ; MSB = 0
CLR A
LD (X),A
RET
; CCOMMALIT ( - )
; Compile inline literall byte into code dictionary.
CCOMMALIT:
CALLR PUSHLIT
CALL CCOMMA
CSKIPRET:
POPW Y
JP (1,Y)
.ifne USE_CALLDOLIT
; DOLITC ( - C )
; Push an inline literal character (8 bit).
DOLITC:
CALLR PUSHLIT
JRA CSKIPRET
; doLit ( -- w )
; Push an inline literal.
HEADFLG DOLIT "doLit" COMPO
DOLIT:
DECW X ;SUBW X,#2
DECW X
LDW Y,(1,SP)
LDW Y,(Y)
LDW (X),Y
JRA POPYJPY
.endif
.ifne HAS_DOLOOP
; (+loop) ( +n -- )
; Add n to index R@ and test for lower than limit (R-CELL)@.
HEADFLG DOPLOOP "(+loop)" COMPO
DOPLOOP:
LDW Y,(5,SP)
LDW YTEMP,Y
LDW Y,X
LDW Y,(Y)
LD A,YH
INCW X
INCW X
ADDW Y,(3,SP)
CPW Y,YTEMP
PUSH CC
TNZ A
JRMI 1$
POP CC
JRSGE LEAVE
JRA 2$
1$: POP CC
JRSLT LEAVE
2$: LDW (3,SP),Y
JRA BRAN
; LEAVE ( -- )
; Leave a DO .. LOOP/+LOOP loop.
HEADFLG LEAVE "LEAVE" COMPO
LEAVE:
ADDW SP,#6
POPW Y ; DO leaves the address of +loop on the R-stack
JP (2,Y)
.endif
; donext ( -- )
; Code for single index loop.
HEADFLG DONXT "donxt" COMPO
DONXT:
LDW Y,(3,SP)
DECW Y
JRPL NEX1
POPW Y
POP A
POP A
JP (2,Y)
NEX1: LDW (3,SP),Y
JRA BRAN
; QDQBRAN ( n - n )
; QDUP QBRANCH phrase
QDQBRAN:
CALL QDUP
JRA QBRAN
; ?branch ( f -- )
; Branch if flag is zero.
HEADFLG QBRAN "?branch" COMPO
QBRAN:
CALL YFLAGS ; Pull TOS to Y, flags
JREQ BRAN
POPYJPY:
POPW Y
JP (2,Y)
; branch ( -- )
; Branch to an inline address.
HEADFLG BRAN "branch" COMPO ; NOALIAS
BRAN:
POPW Y
LDW Y,(Y)
JP (Y)
; EXECUTE ( ca -- )
; Execute word at ca.
HEADER EXECU "EXECUTE"
EXECU:
CALL YFLAGS ; Pull TOS to Y, flags
JP (Y)
.ifeq REMOVE_EXIT
; EXIT ( -- )
; Terminate a colon definition.
HEADER EXIT "EXIT"
EXIT:
POPW Y
RET
.endif
.ifeq BOOTSTRAP
; 2! ( d a -- ) ( TOS STM8: -- Y,Z,N )
; Store double integer to address a.
HEADER DSTOR "2!"
DSTOR:
CALL SWAPP
CALL OVER
CALLR STORE
CALL CELLP
JRA STORE
.endif
.ifeq BOOTSTRAP
; 2@ ( a -- d )
; Fetch double integer from address a.
HEADER DAT "2@"
DAT:
CALL DUPP
CALL CELLP
CALLR AT
CALL SWAPP
JRA AT
.endif
.ifne WORDS_EXTRAMEM
; 2C! ( n a -- )
; Store word C-wise to 16 bit HW registers "MSB first"
HEADER DCSTOR "2C!"
DCSTOR:
CALL YFLAGS ; a
LD A,(X)
LD (Y),A ; write MSB(n) to a
INCW X
LD A,(X)
LD (1,Y),A ; write LSB(n) to a+1
INCW X
RET
; 2C@ ( a -- n )
; Fetch word C-wise from 16 bit HW config. registers "MSB first"
HEADER DCAT "2C@"
DCAT:
LDW Y,X
LDW X,(X)
LD A,(X)
LD (Y),A
LD A,(1,X)
EXGW X,Y
LD (1,X),A
RET
; B! ( t a u -- )
; Set/reset bit #u (0..7) in the byte at address a to bool t
; Note: creates/executes BSER/BRES + RET code on Data Stack
HEADER BRSS "B!"
BRSS:
LD A,#0x72 ; Opcode BSET/BRES
LD (X),A
LD A,(1,X) ; 2nd byte of BSET/BRES
SLA A ; n *= 2 -> A
OR A,#0x10
LDW Y,X
LDW Y,(4,Y) ; bool b (0..15) -> Z
JRNE 1$ ; b!=0: BSET
INC A ; b==0: BRES
1$: LD (1,X),A
LD A,#EXIT_OPC ; Opcode RET
LD (4,X),A
LDW Y,X
ADDW X,#6
JP (Y)
.endif
; @ ( a -- w ) ( TOS STM8: -- Y,Z,N )
; Push memory location to stack.
HEADER AT "@"
AT:
LDW Y,X
LDW X,(X)
LDW X,(X)
EXGW X,Y
LDW (X),Y
RET
; ! ( w a -- ) ( TOS STM8: -- Y,Z,N )
; Pop data stack to memory.
HEADER STORE "!"
STORE:
CALL YFLAGS ; a
PUSHW X
LDW X,(X) ; w
LDW (Y),X
POPW X
JRA DROP
; C@ ( a -- c ) ( TOS STM8: -- A,Z,N )
; Push byte in memory to stack.
; STM8: Z,N
HEADER CAT "C@"
CAT:
LDW Y,X ; Y=a
LDW Y,(Y)
YCAT:
LD A,(Y)
CLR (X)
LD (1,X),A
RET
; C! ( c a -- )
; Pop data stack to byte memory.
HEADER CSTOR "C!"
CSTOR:
CALL YFLAGS
INCW X
LD A,(X)
LD (Y),A
INCW X
RET
; R> ( -- w ) ( TOS STM8: -- Y,Z,N )
; Pop return stack to data stack.
HEADFLG RFROM "R>" COMPO
RFROM:
POPW Y ; save return addr
LDW YTEMP,Y
POPW Y
DECW X
DECW X
LDW (X),Y
JP [YTEMP]
.ifne HAS_CPNVM
; doVARPTR ( - a ) ( TOS STM8: - Y,Z,N )
DOVARPTR:
POPW Y ; get return addr (pfa)
LDW Y,(Y)
JRA YSTOR
.endif
; doVAR ( -- a ) ( TOS STM8: -- Y,Z,N )
; Code for VARIABLE and CREATE.
HEADFLG DOVAR "doVar" COMPO
DOVAR:
POPW Y ; get return addr (pfa)
; fall through
; Y> ( -- n ) ( TOS STM8: - Y,Z,N )
; push Y to stack
; GENALIAS YSTOR "Y>"
YSTOR:
DECW X ; SUBW X,#2
DECW X
LDW (X),Y ; push on stack
RET ; go to RET of EXEC
; R@ ( -- w ) ( TOS STM8: -- Y,Z,N )
; Copy top of return stack to stack (or the FOR - NEXT index value).
HEADER RAT "R@"
RAT:
LDW Y,(3,SP)
JRA YSTOR
; >R ( w -- ) ( TOS STM8: -- Y,Z,N )
; Push data stack to return stack.
HEADFLG TOR ">R" COMPO
TOR:
EXGW X,Y
LDW X,(1,SP)
PUSHW X
LDW X,Y
LDW X,(X)
EXGW X,Y
LDW (3,SP),Y
JRA DROP
; NIP ( n1 n2 -- n2 )
; Drop 2nd item on the stack
HEADER NIP "NIP"
NIP:
CALLR SWAPP
JRA DROP
; DROP ( w -- ) ( TOS STM8: -- Y,Z,N )
; Discard top stack item.
HEADER DROP "DROP"
DROP:
INCW X ; ADDW X,#2
INCW X
LDW Y,X
LDW Y,(Y)
RET
; 2DROP ( w w -- ) ( TOS STM8: -- Y,Z,N )
; Discard two items on stack.
HEADER DDROP "2DROP"
DDROP:
ADDW X,#4
RET
; DUP ( w -- w w ) ( TOS STM8: -- Y,Z,N )
; Duplicate top stack item.
HEADER DUPP "DUP"
DUPP:
LDW Y,X
LDW Y,(Y)
JRA YSTOR
; SWAP ( w1 w2 -- w2 w1 ) ( TOS STM8: -- Y,Z,N )
; Exchange top two stack items.
HEADER SWAPP "SWAP"
SWAPP:
LDW Y,X
LDW X,(2,X)
PUSHW X
LDW X,Y
LDW X,(X)
EXGW X,Y
LDW (2,X),Y
POPW Y
LDW (X),Y
RET
; OVER ( w1 w2 -- w1 w2 w1 ) ( TOS STM8: -- Y,Z,N )
; Copy second stack item to top.
HEADER OVER "OVER"
OVER:
LDW Y,X
LDW Y,(2,Y)
JRA YSTOR
.ifne WORDS_EXTRACORE
; I ( -- n ) ( TOS STM8: -- Y,Z,N )
; Get inner FOR-NEXT or DO-LOOP index value
HEADER IGET "I"
IGET:
.ifne HAS_ALIAS
JP RAT ; CF JP: NAME> resolves I as ' R@"
.else
JRA RAT
.endif
.endif
.ifeq BOOTSTRAP
; UM+ ( u u -- udsum )
; Add two unsigned single
; and return a double sum.
HEADER UPLUS "UM+"
UPLUS:
CALLR PLUS
CLR A
RLC A
JP ASTOR
.endif
; + ( w w -- sum ) ( TOS STM8: -- Y,Z,N )
; Add top two items.
HEADER PLUS "+"
PLUS:
LD A,(1,X) ;D=w
ADD A,(3,X)