2 ;-------------------------------------------------------------------------------
3 ; Vingt fois sur le métier remettez votre ouvrage,
4 ; Polissez-le sans cesse, et le repolissez,
5 ; Ajoutez quelquefois, et souvent effacez. Boileau, L'Art poétique
6 ;-------------------------------------------------------------------------------
8 ;-------------------------------------------------------------------------------
9 ; SCITE editor: copy https://www.scintilla.org/Sc4xx.exe to \prog\scite.exe
10 ;-------------------------------------------------------------------------------
12 ; unzip http://john.ccac.rwth-aachen.de:8000/ftp/as/precompiled/i386-unknown-win32/aswcurr.zip
13 ;-------------------------------------------------------------------------------
14 .listing purecode ; reduce listing to true conditionnal parts
15 MACEXP_DFT noif ; reduce macros listing to true part
16 .PAGE 0 ; listing without pagination
17 ;-------------------------------------------------------------------------------
19 VER .equ "V400" ; FORTH version
21 ;===============================================================================
22 ; before assembling or programming you must set TARGET in scite param1 (SHIFT+F8)
23 ; according to the selected (uncommented) TARGET below
24 ;===============================================================================
26 ;MSP_EXP430FR5739 ; compile for MSP-EXP430FR5739 launchpad
27 ;MSP_EXP430FR5969 ; compile for MSP-EXP430FR5969 launchpad
28 MSP_EXP430FR5994 ;; compile for MSP-EXP430FR5994 launchpad
29 ;MSP_EXP430FR6989 ; compile for MSP-EXP430FR6989 launchpad
30 ;MSP_EXP430FR4133 ; compile for MSP-EXP430FR4133 launchpad
31 ;MSP_EXP430FR2355 ; compile for MSP-EXP430FR2355 launchpad
32 ;MSP_EXP430FR2433 ; compile for MSP-EXP430FR2433 launchpad
33 ;LP_MSP430FR2476 ; compile for LP_MSP430FR2476 launchpad
34 ;CHIPSTICK_FR2433 ; compile for "CHIPSTICK" of M. Ken BOAK
36 ; choose DTC model (Direct Threaded Code); if you don't know, choose 2
37 DTC .equ 2 ; DTC model 1 : DOCOL = CALL rDOCOL 14 cycles 1 word shortest DTC model
38 ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT 13 cycles 2 words best compromize to mix FORTH/ASM code
39 ; DTC model 3 : inlined DOCOL (and LO2HI) 9 cycles 4 words fastest
41 THREADS .equ 16 ; 1, 2 , 4 , 8 , 16, 32 search entries in word-set.
42 ; +0, +28, +48, +56, +90, +154 bytes, usefull to speed up compilation;
43 ; the FORTH interpreter is speed up by about a square root factor of THREADS.
45 FREQUENCY .equ 8 ; fully tested at 1,2,4,8,16 MHz, plus 24 MHz for MSP430FR57xx,MSP430FR2355
48 ; ==============================================================================
49 ;UART_TERMINAL ; COMMENT TO SWITCH FROM UART TO I2C TERMINAL
50 ; ==============================================================================
52 TERMINALBAUDRATE .equ 4000000
53 TERMINAL3WIRES ;; + 18 bytes enable 3 wires XON/XOFF software flow control
54 TERMINAL4WIRES ;; + 12 bytes enable 4 wires RTS hardware flow control
55 ;TERMINAL5WIRES ; + 10 bytes enable 5 wires RTS/CTS hardware flow control
56 ;HALFDUPLEX ; switch to UART half duplex TERMINAL input
58 I2C_TERM_ADR .equ 18 ; I2C_TERMINAL_Slave_Address << 1
61 ;===============================================================================
62 ; KERNEL ADDONs that can't be added later
63 ;===============================================================================
64 DOUBLE_INPUT ;; + 60 bytes : adds the interpretation engine for double numbers (numbers with dot)
65 FIXPOINT_INPUT ;; + 68 bytes : adds the interpretation engine for Q15.16 numbers (numbers with comma)
66 VOCABULARY_SET ;; + 194 bytes : adds words: WORDSET FORTH hidden PREVIOUS ONLY DEFINITIONS
67 SD_CARD_LOADER ;; + 1582 bytes : to load source files from SD_card
68 BOOTLOADER ;; + 82 bytes : includes in WARM process the bootloader SD_CARD\BOOT.4TH.
69 SD_CARD_READ_WRITE ;; + 1168 bytes : to read, create, write and del files + copy text files from PC to target SD_Card
70 LARGE_CODE ;; + 506 bytes : allows assembler to execute code up to 1MB.
71 LARGE_DATA ;; + 1212 bytes : extended assembler to 20 bits addresses and datas.
72 ;PROMPT ; + 18 bytes : to display the prompt "ok ", (obsolete).
73 ;===============================================================================
75 ;-------------------------------------------------------------------------------
76 ; OPTIONS that can be added later by downloading their source file >------------------------------------+
77 ; however, added here, they are protected against WIPE and Deep Reset. |
78 ;------------------------------------------------------------------------------- v
79 ;CORE_COMPLEMENT ; + 2304 bytes, if you want a conventional FORTH ANS94 compliant CORE_ANS.f
80 ;FIXPOINT ; + 422/528 bytes add HOLDS F+ F- F/ F* F#S F. S>F FIXPOINT.f
81 ;UTILITY ; + 434/524 bytes (1/16threads) : add .S .RS WORDS U.R DUMP ? UTILITY.f
82 ;SD_TOOLS ; + 142 bytes for trivial DIR, FAT, CLUSTR. and SECTOR. view, (adds UTILITY) SD_TOOLS.f
83 ;DOUBLE ; DOUBLE word set DOUBLE.f
86 ;===============================================================================
87 ; Software control flow XON/XOFF configuration:
88 ;===============================================================================
89 ; Launchpad <-> UARTtoUSB device <-> TeraTerm TERMINAL
94 ; TERATERM config terminal: NewLine receive : LF,
95 ; NewLine transmit : CR+LF
96 ; Size : 96 chars x 49 lines (adjust lines according to your display)
98 ; TERATERM config serial port: TERMINALBAUDRATE value,
99 ; 8 bits, no parity, 1 Stop bit,
100 ; XON/XOFF flow control,
101 ; delay = 0ms/line, 0ms/char
103 ; don't forget to save always new TERATERM configuration !
105 ; ------------------------------------------------------------------------------
106 ; Only two usb2uart bridges correctly handle XON / XOFF: cp2102 and pl2303.
107 ; ------------------------------------------------------------------------------
108 ; the best and cheapest: UARTtoUSB cable with Prolific PL2303HXD (or PL2303TA)
109 ; works well in 3 WIRES (XON/XOFF) and 4WIRES (GND,RX,TX,RTS) config
110 ; ------------------------------------------------------------------------------
111 ; PL2303TA 4 wires CABLE PL2303HXD 6 wires CABLE
112 ; pads upside: 3V3,txd,rxd,gnd,5V pads upside: gnd, 3V3,txd,rxd,5V
113 ; downside: cts,dcd,dsr,rts,dtr downside: rts,cts
114 ; ------------------------------------------------------------------------------
115 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
116 ; ------------------------------------------------------------------------------
117 ; up to 115200 Bds (500kHz)
118 ; up to 230400 Bds (1MHz)
119 ; up to 460800 Bds (2MHz)
120 ; up to 921600 Bds (4MHz)
121 ; up to 1843200 Bds (8MHz)
122 ; up to 3 MBds (12MHz,PL2303HXD with shortened cable < 80cm)
123 ; up to 4 MBds (16MHz,PL2303HXD with shortened cable < 60cm)
124 ; up to 5 MBds (20MHz,PL2303HXD with shortened cable < 40cm)
125 ; up to 6 MBds (24MHz,PL2303HXD with shortened cable < 20cm)
127 ; UARTtoUSB module with Silabs CP2102 (supply current = 20 mA)
128 ; ------------------------------------------------------------------------------
129 ; WARNING ! if you use it as supply, buy a CP2102 module with a VCC switch 5V/3V3 and swith on 3V3 !
130 ; ------------------------------------------------------------------------------
131 ; 9600,19200,38400 (250kHz)
132 ; + 57600, 115200 (500kHz)
133 ; + 134400,230400 (1MHz)
135 ; + 921600 (4MHz,8MHz,16MHz,24MHz)
137 ;===============================================================================
138 ; Hardware control flow configuration: RTS is wired on UART2USB CTS pin
139 ;===============================================================================
141 ; Launchpad <-> UARTtoUSB
144 ; RTS --> CTS (see launchpad.asm for RTS selected pin)
147 ; RTS pin may be permanently wired on SBWTCK/TEST pin without disturbing SBW 2 wires programming
149 ; TERATERM config terminal : NewLine receive : LF,
150 ; NewLine transmit : CR+LF
151 ; Size : 96 chars x 49 lines (adjust lines to your display)
153 ; TERATERM config serial port : TERMINALBAUDRATE value,
154 ; 8bits, no parity, 1Stopbit,
155 ; Hardware flow control,
156 ; delay = 0ms/line, 0ms/char
158 ; don't forget : save new TERATERM configuration !
160 ; notice that the control flow seems not necessary for TX (CTS <-- RTS)
162 ; UARTtoUSB module with PL2303TA/HXD
163 ; ------------------------------------------------------------------------------
164 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
165 ; ------------------------------------------------------------------------------
166 ; up to 250 kbds / MHz
167 ; ----------------------------------
168 ; 9600,19200,38400,57600 (250kHz)
170 ; + 201600,230400,250000 (1MHz)
171 ; + 403200,460800 (2MHz)
172 ; + 806400,921600 (4MHz)
179 ; UARTtoUSB module with FTDI FT232RL (FT230X don't work correctly)
180 ; ------------------------------------------------------------------------------
181 ; WARNING ! buy a FT232RL module with a switch 5V/3V3 and select 3V3 !
182 ; ------------------------------------------------------------------------------
183 ; 9600,19200,38400,57600,115200 (500kHz)
186 ; + 921600 (4,8,16 MHz)
188 ; ------------------------------------------------------------------------------
189 ; UARTtoBluetooth 2.0 module (RN42 sparkfun bluesmirf) at 921600bds
190 ; ------------------------------------------------------------------------------
191 ; 9600,19200,38400,57600,115200 (500kHz)
194 ; + 921600 (4,8,16 MHz)
196 ; RN42 config : connect RN41/RN42 module on teraterm, via USBtoUART bridge,
197 ; ----------- 8n1, 115200 bds, no flow control, echo on
198 ; $$$ // enter control mode, response: AOK
199 ; SU,92 // set 921600 bds, response: AOK
200 ; R,1 // reset module to take effect
202 ; connect RN42 module on FastForth target
203 ; add new bluetooth device on windows, password=1234
204 ; open the created output COMx port with TERATERM at 921600bds
207 ; TERATERM config terminal : NewLine receive : LF,
208 ; NewLine transmit : CR+LF
209 ; Size : 80 chars x 44 lines (adjust lines to your display)
211 ; TERATERM config serial port : TERMINALBAUDRATE value,
212 ; 8bits, no parity, 1Stopbit,
213 ; Hardware flow control or software flow control or ...no flow control!
214 ; delay = 0ms/line, 0ms/char
216 ; don't forget : save new TERATERM configuration !
218 ; in fact, compared to using a UART USB bridge, only the COMx port is to be updated.
220 ; ------------------------------------------------------------------------------
221 .include "ThingsInFirst.inc" ; macros, target definitions, RAM & INFO variables...
222 ;-------------------------------------------------------------------------------
224 ;-------------------------------------------------------------------------------
225 ; DTCforthMSP430FR5xxx program (FRAM) memory
226 ;-------------------------------------------------------------------------------
227 ; here we place the FORTH primitives without name.
228 ; User can access them via declarations made in \inc\MSP430FRxxxx.pat
229 ; ------------------------------------------------------------------------------
230 ; COMPILING OPERATORS
231 ; ------------------------------------------------------------------------------
232 ; Primitive LIT; compiled by LITERAL
233 ; LIT -- x fetch inline literal to stack
234 ; This is the run-time code of LITERAL.
235 LIT SUB #2,PSP ; 1 save old TOS..
236 MOV TOS,0(PSP) ; 3 ..onto stack
237 MOV @IP+,TOS ; 2 fetch new TOS value
240 TWODUP_XSQUOTE ; see [ELSE]
244 ; Primitive XSQUOTE; compiled by SQUOTE
245 ; (S") -- addr u run-time code to get address and length of a compiled string.
246 XSQUOTE SUB #4,PSP ; 1 push old TOS on stack
247 MOV TOS,2(PSP) ; 3 and reserve one cell on stack
248 MOV.B @IP+,TOS ; 2 -- ? u u = lenght of string
249 MOV IP,0(PSP) ; 3 -- addr u IP is odd...
250 ADD TOS,IP ; 1 IP=addr+u=addr(end_of_string)
251 BIT #1,IP ; 1 IP=addr+u Carry set/clear if odd/even
252 ADDC #0,IP ; 1 IP=addr+u aligned
255 ; primitive MU/MOD; used by ?NUMBER UM/MOD, and M*/ in DOUBLE word set
256 ; MU/MOD UDVDlo UDVDhi UDIVlo -- UREMlo UQUOTlo UQUOThi
257 ;-------------------------------------------------------------------------------
258 ; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient 16-BIT REMainder
259 ;-------------------------------------------------------------------------------
260 ; two times faster if 16 bits DiViDend (cases of U. and . among others)
262 ; reg division MU/MOD NUM M*/
263 ; ---------------------------------------------------------------------
264 ; S = DVD(15-0) = ud1lo = ud1lo ud1lo
265 ; TOS = DVD(31-16) = ud1hi = ud1hi ud1mi
266 ; W = DVD(47-32)/REM = rem = digit --> char --> -[HP] ud1hi
267 ; T = DIV(15-0) = BASE = BASE ud2
268 ; X = QUOTlo = ud2lo = ud2lo QUOTlo
269 ; Y = QUOThi = ud2hi = ud2hi QUOThi
272 MUSMOD MOV TOS,T ;1 T = DIVlo
273 MOV 2(PSP),S ;3 S = DVDlo
274 MOV @PSP,TOS ;2 TOS = DVDhi
275 MUSMOD1 MOV #0,W ;1 W = REMlo = 0
276 MOV #32,rDODOES ;2 init loop count
277 CMP #0,TOS ;1 DVDhi=0 ?
279 ; ----------------------------------;
280 MDIV1DIV2 RRA rDODOES ;1 yes:loop count / 2
281 MOV S,TOS ;1 DVDhi <-- DVDlo
282 MOV #0,S ;1 DVDlo <-- 0
283 MOV #0,X ;1 QUOTlo <-- 0 (to do QUOThi = 0 at the end of division)
284 ; ----------------------------------;
285 MDIV1 CMP T,W ;1 REMlo U>= DIVlo ?
286 JNC MDIV2 ;2 no : carry is reset
287 SUB T,W ;1 yes: REMlo - DIVlo ; carry is set
288 MDIV2 ADDC X,X ;1 RLC quotLO
289 ADDC Y,Y ;1 RLC quotHI
290 SUB #1,rDODOES ;1 Decrement loop counter
293 ADDC TOS,TOS ;1 RLC DVDhi
294 ADDC W,W ;1 RLC REMlo
296 SUB T,W ;1 REMlo - DIVlo
299 ENDMDIV MOV #XDODOES,rDODOES ;2 restore rDODOES
300 MOV W,2(PSP) ;3 REMlo in 2(PSP)
301 MOV X,0(PSP) ;3 QUOTlo in 0(PSP)
302 MOV Y,TOS ;1 QUOThi in TOS
303 RET_ADR MOV @RSP+,PC ;4 35 words, about 466/246 cycles, not FORTH executable !
305 ; : SETIB SOURCE 2! 0 >IN ! ;
306 ; SETIB org len -- set Input Buffer, shared by INTERPRET and [ELSE]
307 SETIB MOV #0,&TOIN ;3
308 MOV @PSP+,&SOURCE_ORG ;4 -- len
309 MOV TOS,&SOURCE_LEN ;3 -- len
310 DROP MOV @PSP+,TOS ;2 --
313 ; REFILL accept one line to input buffer and leave org len' of the filled input buffer
314 ; as it has no more host OS and as waiting command is done by ACCEPT, REFILL's flag is useless
315 ; : REFILL TIB DUP CIB_LEN ACCEPT ; -- org len' shared by QUIT and [ELSE]
317 MOV TOS,2(PSP) ;3 save TOS
318 TWODROP_REFILL ; see [ELSE]
319 MOV #CIB_LEN,TOS ;2 -- x len Current Input Buffer LENght
320 .word 40BFh ; MOV #imm,index(PSP)
321 CIB_ORG .word TIB_ORG ; imm=TIB_ORG
322 .word 0 ;4 -- org len index=0 ==> MOV #TIB_ORG,0(PSP)
323 MOV @PSP,-2(PSP) ;4 -- org len
324 SUB #2,PSP ;1 -- org org len
325 JMP ACCEPT ;2 org org len -- org len'
327 ; Primitive QFBRAN; compiled by IF UNTIL
328 ;Z ?FalseBranch x -- ; branch if TOS is FALSE (TOS = 0)
329 QFBRAN CMP #0,TOS ; 1 test TOS value
330 MOV @PSP+,TOS ; 2 pop new TOS value (doesn't change flags)
331 ZBRAN JNZ SKIPBRANCH ; 2 if TOS was <> 0, skip the branch; 10 cycles
332 BRAN MOV @IP,IP ; 2 take the branch destination
333 MOV @IP+,PC ; 4 ==> branch taken, 11 cycles
335 XDODOES ; 4 for CALL rDODOES
337 MOV TOS,0(PSP) ;+3 save TOS on parameters stack
338 MOV @RSP+,TOS ;+2 TOS = PFA address of master word, i.e. address of its first cell after DOES>
339 PUSH IP ;+3 save IP on return stack
340 MOV @TOS+,IP ;+2 IP = CFA of Master word, TOS = BODY address of created word
341 MOV @IP+,PC ;+4 = 19~ = ITC-2
343 XDOCON ; 4 for CALL rDOCON
345 MOV TOS,0(PSP) ;+3 save TOS on parameters stack
346 MOV @RSP+,TOS ;+2 TOS = PFA address of master word CONSTANT
347 MOV @TOS,TOS ;+2 TOS = CONSTANT value
348 MOV @IP+,PC ;+4 = 16~ = ITC+4
351 .IFNDEF UART_TERMINAL
352 .include "forthMSP430FR_TERM_I2C.asm"
355 .include "forthMSP430FR_TERM_HALF.asm"
357 .include "forthMSP430FR_TERM_UART.asm"
360 .IFDEF SD_CARD_LOADER
361 .include "forthMSP430FR_SD_ACCEPT.asm"
364 .IF DTC = 1 ; DOCOL = CALL rDOCOL, [rDOCOL] = XDOCOL
365 XDOCOL MOV @RSP+,W ; 2
366 PUSH IP ; 3 save old IP on return stack
367 MOV W,IP ; 1 set new IP to PFA
368 MOV @IP+,PC ; 4 = NEXT
372 ;https://forth-standard.org/standard/core/TYPE
373 ;C TYPE adr u -- type string to terminal
375 MOV #TYPE_NEXT+2,IP ;2 because SUB #2,IP
376 MOV @PSP+,X ;2 -- len X = adr
377 TYPELOOP SUB #2,IP ;1 [IP] = TYPE_NEXT
378 SUB #2,PSP ;1 -- x len
379 MOV TOS,0(PSP) ;3 -- len len
380 MOV.B @X+,TOS ;2 -- len char
381 JMP EMIT ;22 S T W regs are free
382 TYPE_NEXT mNEXTADR ; -- len
383 SUB.B #1,TOS ;1 -- len-1 byte operation, according to the /COUNTED-STRING value
384 JNZ TYPELOOP ;2 32~/19~ EMIT loop 312/526 kBds/MHz --> 7.5MBds @ 24 MHz
387 ; ------------------------------------------------------------------------------
388 ; forthMSP430FR : CONDITIONNAL COMPILATION, 114/109 words
389 ; ------------------------------------------------------------------------------
390 ; goal: speed up the false conditionnal to reach true|false equal time: reached!
391 ; ------------------------------------------------------------------------------
393 FORTHWORDIMM "[THEN]" ; does nothing
394 ; https://forth-standard.org/standard/tools/BracketTHEN
397 ; ------------------------------------------------------------------------------
398 ; BRanch if BAD strings COMParaison, [COMPARE ZEROEQUAL QFBRAN] replacement
399 QBRBADCOMP ; addr1 u1 addr2 u2 --
401 MOV @PSP+,Y ;2 Y = addr2
402 CMP @PSP+,S ;2 u1 = u2 ?
403 MOV @PSP+,X ;2 X = addr1
405 JNZ BRAN ;2 -- branch if u1<>u2, 11+6 cycles
406 COMPLOOP CMP.B @Y+,0(X) ;4
407 JNZ BRAN ;2 -- if char1<>char2; branch on first char <> in 17+6 cycles
410 JNZ COMPLOOP ;2 10 cycles char comp loop
411 SKIPBRANCH ADD #2,IP ;1
414 ; [TWODROP ONEMINUS ?DUP ZEROEQUAL QFBRAN next_comp EXIT] replacement
415 QBRNEXTCMP ; -- cnt addr u
416 ADD #2,PSP ;1 -- cnt addr NIP
417 MOV @PSP+,TOS ;2 -- cnt + DROP = TWODROP
418 SUB #1,TOS ;3 -- cnt-1 ONEMINUS
419 JNZ BRAN ;2 -- cnt-1 branch to next comparaison if <> 0
420 DROPEXIT MOV @PSP+,TOS ;2 --
424 FORTHWORDIMM "[ELSE]"
425 ; https://forth-standard.org/standard/tools/BracketELSE
427 ;Perform the execution semantics given below.
429 ;( "<spaces>name ..." -- )
430 ;Skipping leading spaces, parse and discard space-delimited words from the parse area,
431 ;including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
432 ;until the word [THEN] has been parsed and discarded.
433 ;If the parse area becomes exhausted, it is refilled as with REFILL.
434 ;the loop back from BRACKTELSE1 to BRACKTELSE0 is shorten
437 .word BRAN,BRACKTELSE1 ; 6~ versus 5~ for ONEPLUS
438 BRACKTELSE0 .word XSQUOTE ; end of skiped line
439 .byte 5,13,"ko ",10 ; send CR + "ko " + LF
440 .word TYPE ; CR ." ko " LF
441 .word TWODROP_REFILL ; REFILL Input Buffer with next line
442 .word SETIB ; SET Input Buffer pointers SOURCE_LEN, SOURCE_ORG and clear >IN
443 BRACKTELSE1 .word BL_WORD,COUNT ; -- cnt addr u Z = 1 if u = 0
444 .word ZBRAN,BRACKTELSE0 ; -- cnt addr 0 Z = 1 --> end of line, -6~
445 .word TWODUP_XSQUOTE ; 24 ~
446 .byte 6,"[THEN]" ; -- cnt addr u addr1 u1 addr2 u2
447 .word QBRBADCOMP,BRACKTELSE2 ; -- cnt addr u if [THEN] not found, jump for next comparaison
448 .word QBRNEXTCMP,BRACKTELSE1 ; if found, 2DROP, count-1, loop back if count <> 0 | DROP EXIT if count = 0
449 BRACKTELSE2 .word TWODUP_XSQUOTE ;
450 .byte 6,"[ELSE]" ; -- cnt addr u addr1 u1 addr2 u2
451 .word QBRBADCOMP,BRACKTELSE3 ; -- cnt addr u if [ELSE] not found, jump for next comparaison
452 .word QBRNEXTCMP,BRACKTELSE4 ; if found, 2DROP, count-1, loop back if count <> 0
453 BRACKTELSE3 .word XSQUOTE ; 16 ~
454 .byte 4,"[IF]" ; -- cnt addr1 u1 addr2 u2
455 .word QBRBADCOMP,BRACKTELSE1 ; -- cnt if [IF] not found, loop back for next word comparaison
456 BRACKTELSE4 .word ONEPLUS ; -- cnt+1 if found, same loop back with count+1
457 .word BRAN,BRACKTELSE1 ;
459 FORTHWORDIMM "[IF]" ; flag --
460 ; https://forth-standard.org/standard/tools/BracketIF
462 ;Perform the execution semantics given below.
463 ;Execution: ;( flag | flag "<spaces>name ..." -- )
464 ;If flag is true, do nothing. Otherwise, skipping leading spaces,
465 ; parse and discard space-delimited words from the parse area,
466 ; including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
467 ; until either the word [ELSE] or the word [THEN] has been parsed and discarded.
468 ;If the parse area becomes exhausted, it is refilled as with REFILL. [IF] is an immediate word.
469 ;An ambiguous condition exists if [IF] is POSTPONEd,
470 ; or if the end of the input buffer is reached and cannot be refilled before the terminating [ELSE] or [THEN] is parsed.
471 BRACKETIF CMP #0,TOS ; -- f
473 JZ BRACKETELSE ; if false flag output
474 MOV @IP+,PC ; if true flag output
476 FORTHWORDIMM "[UNDEFINED]"
477 ; https://forth-standard.org/standard/tools/BracketUNDEFINED
479 ;Perform the execution semantics given below.
480 ;Execution: ( "<spaces>name ..." -- flag )
481 ;Skip leading space delimiters. Parse name delimited by a space.
482 ;Return a false flag if name is the name of a word that can be found,
483 ;otherwise return a true flag.
487 SUB #1,TOS ;1 borrow if TOS was 0
488 SUBC TOS,TOS ;1 TOS=-1 if borrow was set
489 NIP_EXIT MOV @RSP+,IP
493 FORTHWORDIMM "[DEFINED]"
494 ; https://forth-standard.org/standard/tools/BracketDEFINED
496 ;Perform the execution semantics given below.
498 ;( "<spaces>name ..." -- flag )
499 ;Skip leading space delimiters. Parse name delimited by a space.
500 ;Return a true flag if name is the name of a word that can be found,
501 ;otherwise return a false flag. [DEFINED] is an immediate word.
506 ;-------------------------------------------------------------------------------
508 ;-------------------------------------------------------------------------------
509 ; https://forth-standard.org/standard/core/SWAP
512 ; https://forth-standard.org/standard/core/Rfrom
513 ; R> -- x R: x -- pop from return stack
514 ; VARIABLE run time called by CALL rDOVAR
520 ; https://forth-standard.org/standard/core/DUP
521 ; DUP x -- x x duplicate top of stack
526 ;-------------------------------------------------------------------------------
527 ; ARITHMETIC OPERATIONS
528 ;-------------------------------------------------------------------------------
529 ; https://forth-standard.org/standard/core/Minus
530 ; - n1/u1 n2/u2 -- n3/u3 n3 = n1-n2
531 MINUS SUB @PSP+,TOS ;2 -- n2-n1
532 NEGATE XOR #-1,TOS ;1
533 ONEPLUS ADD #1,TOS ;1 -- n3 = -(n2-n1) = n1-n2
536 ;-------------------------------------------------------------------------------
538 ;-------------------------------------------------------------------------------
540 ; https://forth-standard.org/standard/core/Fetch
541 ; @ a-addr -- x fetch cell from memory
546 ; https://forth-standard.org/standard/core/Store
547 ; ! x a-addr -- store cell in memory
548 STORE MOV @PSP+,0(TOS);4
552 ; ------------------------------------------------------------------------------
554 ; ------------------------------------------------------------------------------
556 ; use SQUOTE+10 to enable separator select
558 FORTHWORDIMM "S\34" ; immediate
559 ; https://forth-standard.org/standard/core/Sq
560 ; S" -- compile in-line string
561 SQUOTE SUB #2,PSP ; first choose separator
563 MOV #'"',TOS ; separator = '"'
564 ; SQUOTE+10 address ;
565 MOV #0,T ; volatile CAPS OFF, only for WORDD+4 below
567 .word LIT,XSQUOTE,COMMA ; obviously use not T register...
568 .word WORDD+4 ; -- c-addr = DP, W=Count_of_chars
570 ADD #1,W ; to include count of chars
572 ADDC W,&DP ; -- addr new DP is aligned
575 FORTHWORDIMM ".\34" ; immediate
576 ; https://forth-standard.org/standard/core/Dotq
577 ; ." -- compile string to print
583 ;-------------------------------------------------------------------------------
585 ;-------------------------------------------------------------------------------
586 ; Numeric conversion is done last digit first, so
587 ; the output buffer is built backwards in memory.
590 ; https://forth-standard.org/standard/core/num-start
591 ; <# -- begin numeric conversion (initialize Hold Pointer)
592 LESSNUM MOV #HOLD_BASE,&HP
596 ; https://forth-standard.org/standard/core/num
597 ; # ud1lo ud1hi -- ud2lo ud2hi convert 1 digit of output
598 NUM MOV &BASEADR,T ;3
599 NUM1 MOV @PSP,S ;2 -- DVDlo DVDhi S = DVDlo
600 SUB #2,PSP ;1 -- x x DVDhi TOS = DVDhi
601 CALL #MUSMOD1 ;244/444 -- REMlo QUOTlo QUOThi T is unchanged W=REMlo X=QUOTlo Y=QUOThi
602 MOV @PSP+,0(PSP) ;4 -- QUOTlo QUOThi W = REMlo
603 TODIGIT CMP.B #10,W ;2
604 JNC TODIGIT1 ;2 jump if U<
606 TODIGIT1 ADD.B #30h,W ;2
607 HOLDW SUB #1,&HP ;3 store W=char --> -[HP]
610 MOV @IP+,PC ;4 22 words, about 276|476 cycles for u|ud one digit
613 ; https://forth-standard.org/standard/core/numS
614 ; #S udlo udhi -- 0 0 convert remaining digits
618 SUB #2,IP ;1 restore NUM return
622 EXIT MOV @RSP+,IP ;2 when DTC=2 rDOCOL is loaded with this EXIT address
623 MOV @IP+,PC ;4 10 words, about 294|494 cycles for u|ud one digit
626 ; https://forth-standard.org/standard/core/num-end
627 ; #> udlo:udhi -- addr u end conversion, get string
628 NUMGREATER MOV &HP,0(PSP) ; -- addr 0
630 SUB @PSP,TOS ; -- addr u
634 ; https://forth-standard.org/standard/core/HOLD
635 ; HOLD char -- add char to output string
641 ; https://forth-standard.org/standard/core/SIGN
642 ; SIGN n -- add minus sign if n<0
646 JN HOLDW ; jump if 0<
653 ; https://forth-standard.org/standard/core/Ud
654 ; U. u -- display u (unsigned)
655 ; note: DDOT = UDOT + 10 (see DOUBLE.f)
656 UDOT MOV #0,S ; 1 -- hi=0
657 SUB #2,PSP ; 1 convert n|u to d|ud with Y = -1|0
658 MOV TOS,0(PSP) ; 3 -- lo lo
659 MOV S,TOS ; 1 -- lo hi
660 DDOT PUSHM #2,IP ; 4 R-- IP S=sign
661 AND #-1,TOS ; clear V, set N
662 JGE DDOTNEXT ; if hi positive (N=0)
667 DDOTNEXT mASM2FORTH ;10
669 .word BL,HOLD ; add a trailing space
670 .word NUMS ; R-- IP sign
671 .word RFROM,SIGN ; R-- IP
672 .word NUMGREATER,TYPE
676 ; https://forth-standard.org/standard/core/d
677 ; . n -- display n (signed)
683 ;-------------------------------------------------------------------------------
685 ;-------------------------------------------------------------------------------
687 ; https://forth-standard.org/standard/core/WORD
688 ; WORD char -- addr Z=1 if len=0
689 ; parse a word delimited by char separator.
690 ; the resulting c-string is left at HERE.
691 ; if CAPS is ON, this word is CAPITALIZED unless for a 'char' input.
692 ; notice that the average lenght of all CORE definitions is about 4.
695 ;-------------------------------;
696 BL_WORD SUB #2,PSP ;1 )
697 MOV TOS,0(PSP) ;3 > 6~ instead of 16~ for CONSTANT BL runtime
698 MOV #' ',TOS ;2 -- BL )
699 WORDD MOV &CAPS,T ;3 CAPS OFF = 0, CAPS ON = $20.
700 MOV #SOURCE_LEN,S ;2 -- WORDD+4 address
701 MOV @S+,X ;2 X = src_len
702 MOV @S+,Y ;2 Y = src_org
703 ADD Y,X ;1 X = src_len + src_org = src_end
704 ADD @S+,Y ;2 Y = >IN + src_org = src_ptr
705 MOV @S,W ;2 W = HERE = dst_ptr
706 ;-------------------------------;
707 SKIPSEPLOOP CMP X,Y ;1 src_ptr >= src_end ?
708 JC SKIPSEPEND ;2 if yes : End Of Line !
709 CMP.B @Y+,TOS ;2 does char = separator ?
710 JZ SKIPSEPLOOP ;2 if yes; 7~ loop
711 ;-------------------------------;
712 SUB #1,Y ;1 decrement the post incremented src_ptr
713 SCANTICK CMP.B #"'",2(Y) ;4 third char = TICK ? (allow ' as first char for a defined word)
714 JNZ SCANWRDLOOP ;2 no
715 MOV #0,T ;1 don't change to upper case for a 'char' input
716 ;-------------------------------;
717 SCANWRDLOOP MOV.B S,0(W) ;3 first, S makes room in dst for word length; next, put char here.
718 CMP X,Y ;1 src_ptr = src_end ?
719 JZ SCANWRDEND ;2 if yes
720 MOV.B @Y+,S ;2 S=char
721 CMP.B S,TOS ;1 -- sep does char = separator ?
722 JZ SCANWRDEND ;2 if yes
723 ADD #1,W ;1 increment dst
724 CMP.B #'a',S ;2 char U< 'a' ? this condition is tested at each loop
725 JNC SCANWRDLOOP ;2 16~ upper case char loop
726 CMP.B #'z'+1,S ;2 char U>= 'z'+1 ?
727 JC SCANWRDLOOP ;2 U>= loopback if yes
728 SUB.B T,S ;1 convert a...z to A...Z if CAPS ON (T=$20)
729 JMP SCANWRDLOOP ;2 23~ lower case char loop
730 SCANWRDEND SUB &SOURCE_ORG,Y ;3 -- sep Y=src_ptr - src_org = new >IN (first char separator next)
731 MOV Y,&TOIN ;3 update >IN for next word search in this input stream
732 SKIPSEPEND MOV &DP,TOS ;3 -- addr TOS = HERE
733 SUB TOS,W ;1 W = Word_Length >= 0
734 MOV.B W,0(TOS) ;3 -- c-addr
735 MOV @IP+,PC ;4 Z=1 <==> Word_Length = 0 <==> EOL, tested by INTERPRET
738 ; https://forth-standard.org/standard/core/FIND
739 ; FIND addr -- c-addr 0 if not found ; flag Z=1 c-addr at transient RAM area (HERE)
740 ; CFA -1 if found ; flag Z=0
741 ; CFA 1 if immediate ; flag Z=0
742 ; compare WORD at c-addr (HERE) with each of words in each of listed vocabularies in CONTEXT
743 ; start of FIND : 5 cycles
744 ; VOCLOOP : 5/12 cycles,
745 ; mismatch word loop: +14 cycles on len,
746 ; +7 cycles on first char,
747 ; +10 cycles char loop,
748 ; WORDFOUND to end : 15/16 cycles.
749 ; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time
750 FIND SUB #2,PSP ;1 -- ???? c-addr reserve one cell, not at FINDEND which would kill the Z flag
751 MOV TOS,S ;1 S=c-addr
752 MOV #CONTEXT,T ;2 T = first cell addr of CONTEXT stack
753 VOCLOOP MOV @T+,TOS ;2 -- ???? VOC_PFA T=CTXT+2
754 CMP #0,TOS ;1 TOS = BODY = voclink; no more vocabulary in CONTEXT ?
755 JZ FINDEND ;2 -- ???? 0 yes ==> exit; Z=1
757 .CASE 1 ; nothing to do
758 .ELSECASE ; searching thread adds 7 cycles & 6 words
759 MOV.B 1(S),Y ;3 -- ???? VOC_PFA0 S=c-addr Y=first char of c-addr string
760 AND.B #(THREADS-1),Y;2 -- ???? VOC_PFA0 Y=thread_x
761 ADD Y,Y ;1 -- ???? VOC_PFA0 Y=thread_offset_x
762 ADD Y,TOS ;1 -- ???? VOC_PFAx TOS = words set entry
764 ADD #2,TOS ;1 -- ???? VOC_PFAx+2
765 WORDLOOP MOV -2(TOS),TOS ;3 -- ???? NFA -2(TOS) = [VOC_PFAx] first, then [LFA]
766 CMP #0,TOS ;1 no more word in the thread ?
767 JZ VOCLOOP ;2 yes ==> search next voc in context
769 MOV.B @X+,Y ;2 TOS = NFA, X= NFA+1, Y = NFA_first_byte = cnt<<2+i (i= immediate flag)
770 RRA.B Y ;1 remove immediate flag, the remainder is the count of the definition name.
771 LENCOMP CMP.B @S,Y ;2 compare lenght
772 JNZ WORDLOOP ;2 14~ word loop on lenght mismatch
773 MOV S,W ;1 S=W=c-addr
774 CHARCOMP CMP.B @X+,1(W) ;4 compare chars
775 JNZ WORDLOOP ;2 21~ word loop on first char mismatch
777 SUB.B #1,Y ;1 decr count
778 JNZ CHARCOMP ;2 10~ char loop
779 WORDFOUND BIT #1,X ;1
781 MOV X,S ;1 S=aligned CFA
782 MOV.B @TOS,TOS ;2 -- ???? NFA_1st_byte
783 AND #1,TOS ;1 -- ???? 0|1 test immediate flag
784 JNZ FINDEND ;2 -- ???? 1 jump if bit 1 is set, as immediate bit
785 SUB #1,TOS ;1 -- ???? -1
786 FINDEND MOV S,0(PSP) ;3 -- xt -1/0/1 if not found: -- c-addr 0 flag Z=1
787 MOV @IP+,PC ;4 34/40 words return to interpreter
790 ; ; https://forth-standard.org/standard/core/FIND
791 ; ; FIND addr -- c-addr 0 if not found ; flag Z=1 c-addr at transient RAM area (HERE)
792 ; ; CFA -1 if found ; flag Z=0
793 ; ; CFA 1 if immediate ; flag Z=0
794 ; ; compare WORD at c-addr (HERE) with each of words in each of listed vocabularies in CONTEXT
795 ; ; start of FIND : 4/11 cycles
796 ; ; VOCLOOP : 6 cycles,
797 ; ; mismatch word loop: +14 cycles on len,
798 ; ; +7 cycles on first char,
799 ; ; +10 cycles char loop,
800 ; ; WORDFOUND to end : 15/17 cycles.
801 ; ; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time
804 ; .CASE 1 ; nothing to do
805 ; .ELSECASE ; searching thread adds 7 cycles & 6 words
806 ; MOV.B 1(TOS),rDOCON ;3 S=c-addr rDOCON=first char of c-addr string
807 ; AND.B #(THREADS-1),rDOCON;2 rDOCON=thread_x
808 ; ADD rDOCON,rDOCON ;1 rDOCON=thread_offset_x
809 ; ADD #2,rDOCON ;1 rDOCON=thread_offset_x+2
811 ; SUB #2,PSP ;1 -- ???? c-addr reserve one cell, not at FINDEND which would kill the Z flag
812 ; MOV TOS,S ;1 S=c-addr
813 ; MOV #CONTEXT,T ;2 T = first cell addr of CONTEXT stack
814 ; VOCLOOP MOV @T+,TOS ;2 -- ???? VOC_PFA T=CTXT+2
815 ; CMP #0,TOS ;1 no more vocabulary in CONTEXT ?
816 ; JZ FINDEND ;2 -- ???? 0 yes ==> exit; Z=1
818 ; .CASE 1 ; nothing to do
819 ; ADD #2,TOS ;1 -- ???? VOC_PFAx+2
820 ; .ELSECASE ; searching thread adds 7 cycles & 6 words
821 ; ADD rDOCON,TOS ;1 -- ???? VOC_PFAx+2 TOS = words set entry
823 ; WORDLOOP MOV -2(TOS),TOS ;3 -- ???? NFA -2(TOS) = [VOC_PFAx] first, then [LFA]
824 ; CMP #0,TOS ;1 no more word in the thread ?
825 ; JZ VOCLOOP ;2 yes ==> search next voc in context
827 ; MOV.B @X+,Y ;2 TOS = NFA, X= NFA+1, Y = NFA_first_byte = cnt<<2+i (i= immediate flag)
828 ; RRA.B Y ;1 remove immediate flag, the remainder is the count of the definition name.
829 ; LENCOMP CMP.B @S,Y ;2 compare lenght
830 ; JNZ WORDLOOP ;2 14~ word loop on lenght mismatch
831 ; MOV S,W ;1 S=W=c-addr
832 ; CHARCOMP CMP.B @X+,1(W) ;4 compare chars
833 ; JNZ WORDLOOP ;2 21~ word loop on first char mismatch
835 ; SUB.B #1,Y ;1 decr count
836 ; JNZ CHARCOMP ;2 10~ char loop
837 ; WORDFOUND BIT #1,X ;1
839 ; MOV X,S ;1 S=aligned CFA
840 ; MOV.B @TOS,TOS ;2 -- ???? NFA_1st_byte
841 ; AND #1,TOS ;1 -- ???? 0|1 test immediate flag
842 ; JNZ FINDEND ;2 -- ???? 1 jump if bit 1 is set, as immediate bit
843 ; SUB #1,TOS ;1 -- ???? -1
845 ; .CASE 1 ; nothing to do
846 ; .ELSECASE ; searching thread adds 7 cycles & 6 words
847 ; MOV #XDOCON,rDOCON ;2
849 ; MOV S,0(PSP) ;3 -- xt -1/0/1 if not found: -- c-addr 0 flag Z=1
850 ; MOV @IP+,PC ;4 34/40 words return to interpreter
852 .IFDEF MPY_32 ; if 32 bits hardware multiplier
855 ; >NUMBER ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2
856 ; https://forth-standard.org/standard/core/toNUMBER
857 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
858 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
859 ; Conversion continues left-to-right until a character that is not convertible (including '.' ',' '_')
860 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
861 ; or the first character past the end of the string if the string was entirely converted.
862 ; cnt2 is the number of unconverted characters in the string.
863 ; An ambiguous condition exists if ud2 overflows during the conversion.
864 TONUMBER MOV &BASEADR,T ;3 T = base
865 MOV @PSP+,S ;2 -- ud1lo ud1hi cnt1 S = addr1
866 MOV @PSP+,Y ;2 -- ud1lo cnt1 Y = ud1hi
867 MOV @PSP,X ;2 -- x cnt1 X = ud1lo
868 SUB #4,PSP ;1 -- x x x cnt1
869 TONUMLD_OP1 MOV T,&MPY ;3 base = MPY = OP1 loaded out of TONUMLOOP
870 TONUMLOOP MOV.B @S,W ;2 -- x x x cnt S=adr, T=base, W=char, X=udlo, Y=udhi
871 DDIGITQ SUB.B #':',W ;2 all Ctrl_Chars < '0' and all chars '0' to '9' become negative
872 JNC DDIGITQNEXT ;2 accept all chars U< ':' (accept $0 up to $39)
873 SUB.B #7,W ;2 W = char - (':' + $07 = 'A')
874 JNC TONUMEND ;2 -- x x x cnt reject all Ctrl_Chars U< 'A', (with Z flag = 0)
875 DDIGITQNEXT ADD.B #0Ah,W ;2 restore digit value: 0 to 15 (and beyond)
876 CMP T,W ;1 digit-base (U>= comparaison rejects all Ctrl_Chars)
877 BIC #Z,SR ;1 reset Z before return to QNUMBER because else
878 JC TONUMEND ;2 to avoid QNUMBER conversion true with digit=base :-(
879 MOV X,&OP2L ;3 Load 2nd operand (ud1lo)
880 MOV Y,&OP2H ;3 Load 2nd operand (ud1hi)
881 MOV &RES0,X ;3 lo result in X (ud2lo)
882 MOV &RES1,Y ;3 hi result in Y (ud2hi)
883 ADD W,X ;1 ud2lo + digit
884 ADDC #0,Y ;1 ud2hi + carry
885 TONUMPLUS ADD #1,S ;1 adr+1
886 SUB #1,TOS ;1 -- x x x cnt cnt-1
887 JNZ TONUMLOOP ;2 if count <>0 34~ digit loop
888 TONUMEND MOV S,0(PSP) ;3 -- x x addr2 cnt2
889 MOV Y,2(PSP) ;3 -- x ud2hi addr2 cnt2
890 MOV X,4(PSP) ;3 -- ud2lo ud2hi addr2 cnt2
891 MOV @IP+,PC ;4 40 words
893 ; ?NUMBER makes the interface between INTERPRET and >NUMBER; it's a subset of INTERPRET.
894 ; convert a string to a signed number; FORTH 2012 prefixes $ % # are recognized,
895 ; FORTH 2012 'char' numbers also, digits separator '_' also.
896 ; with DOUBLE_INPUT option, 32 bits signed numbers (with decimal point) are recognized,
897 ; with FIXPOINT_INPUT option, Q15.16 signed numbers (with comma) are recognized.
898 ; prefixes ' # % $ - are processed before calling >NUMBER
899 ; chars . , _ are processed as >NUMBER exits.
900 ;Z ?NUMBER addr -- n|d -1 if convert ok ; flag Z=0, UF9=1 if double
901 ;Z addr -- addr 0 if convert ko ; flag Z=1
903 .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
904 BIC #UF9,SR ;2 reset UserFlag_9 used as double number flag
906 SUB #8,PSP ;1 -- x x x x addr make room for >NUMBER
907 MOV TOS,6(PSP) ;3 -- addr x x x addr save TOS
908 MOV #0,Y ;1 Y=ud1hi=0
909 MOV #0,X ;1 X=ud1lo=0
910 MOV &BASEADR,T ;3 T=BASE
912 MOV #0,TOS ;1 TOS=sign of result
913 PUSHM #2,TOS ;4 R-- sign IP PUSH TOS,IP
914 MOV #TONUMEXIT,IP ;2 set TONUMEXIT as return from >NUMBER
915 MOV.B @S+,TOS ;2 -- addr x x x cnt TOS=count, S=addr+1
916 QNUMLDCHAR MOV.B @S,W ;2 W=char
919 JC TONUMLD_OP1 ;2 -- addr x x x cnt jump if char U> '-', case of numeric chars
920 QBINARY MOV #2,T ;1 preset base 2
921 ADD.B #8,W ;1 binary '%' prefix ? '%' + 8 = '-'
923 QDECIMAL ADD #8,T ;1 preset base 10
924 ADD.B #2,W ;1 decimal '#' prefix ? '#' + 2 = '%'
926 QHEXA MOV #16,T ;2 preset base 16
927 CMP.B #1,W ;1 hex '$' prefix ? '#' + 1 = '$'
929 QTICK CMP.B #4,W ;1 ' prefix ? '#' + 4 = "'"
930 JNZ QNUMNEXT ;2 -- addr x x x cnt no, abort because other prefixes not recognized
931 CMP #3,TOS ;2 count = 3 ?
932 JNZ QNUMNEXT ;2 no, abort
933 CMP.B @S+,1(S) ;4 -- addr x x x 3 3rd char = 1st char ?
934 MOV.B @S,S ;2 does byte to word conversion
935 MOV S,4(PSP) ;3 -- addr ud2lo x x 3 ud2lo = ASCII code of 'char'
936 JMP QNUMNEXT ;2 -- addr ud2lo x x 3 with happy end only if 3rd char = 1st char = "'"
937 QNUMMINUS MOV #-1,2(RSP) ;3 R-- sign IP set sign flag
938 PREFIXNEXT SUB #1,TOS ;1 -- addr x x x cnt-1 TOS=count-1
939 CMP.B @S+,0(S) ;4 S=adr+1; same prefix ?
940 JNZ QNUMLDCHAR ;2 loopback if no
941 JZ TONUMLD_OP1 ;2 if yes, this 2nd prefix will be rejected by >NUMBER
942 ; ------------------------------;46
943 TONUMEXIT mNEXTADR ; -- addr ud2lo-hi addr2 cnt2 R-- IP sign BASE S=addr2
944 JZ QNUMNEXT ;2 TOS=0 and Z=1 if conversion is ok
945 SUB #2,IP ;1 redefines TONUMEXIT as >NUMBER return, if loopback applicable
946 MOV.B @S,W ;2 reload rejected char
947 CMP.B #'_',W ;2 rejected char by >NUMBER is a underscore ?
948 JZ TONUMPLUS ;2 yes: return to >NUMBER to skip char then resume conversion, 30~ loopback
949 .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
950 BIT #UF9,SR ;2 UF9 already set ? ( if you have typed .. )
951 JNZ QNUMNEXT ;2 yes, goto QNUMKO
952 BIS #UF9,SR ;2 set double number flag
954 .IFDEF DOUBLE_INPUT ;
955 SUB.B #'.',W ;2 rejected char by >NUMBER is a decimal point ?
956 JZ TONUMPLUS ;2 yes, loopback to >NUMBER to skip char, 45~ loopback
958 .IFDEF FIXPOINT_INPUT ;
960 ADD.B #2,W ;1 rejected char by >NUMBER is a comma ? (',' - '.' + 2 = 0)
962 CMP.B #',',W ;2 rejected char by >NUMBER is a comma ?
964 JNZ QNUMNEXT ;2 no: with Z=0 ==> goto QNUMKO
965 S15Q16 MOV TOS,W ;1 -- addr ud2lo x x x W=cnt2
966 MOV #0,X ;1 -- addr ud2lo x 0 x init X = ud2lo' = 0
967 S15Q16LOOP MOV X,2(PSP) ;3 -- addr ud2lo ud2lo' 0 x 2(PSP) = ud2lo'
968 SUB.B #1,W ;1 decrement cnt2
969 MOV W,X ;1 X = cnt2-1
970 ADD S,X ;1 X = end_of_string-1,-2,-3...
971 MOV.B @X,X ;2 X = last char of string first (reverse conversion)
973 JNC QS15Q16DIGI ;2 accept all chars U< ':'
975 JNC S15Q16EOC ;2 reject all chars U< 'A'
976 QS15Q16DIGI ADD.B #10,X ;2 restore digit value
977 CMP T,X ;1 T=Base, is X a digit ?
978 JC S15Q16EOC ;2 -- addr ud2lo ud2lo' ud2lo' x if not a digit
979 MOV X,0(PSP) ;3 -- addr ud2lo ud2lo' digit x
980 MOV T,TOS ;1 -- addr ud2lo ud2lo' digit base R-- IP sign
981 PUSHM #3,S ;5 PUSH S,T,W: R-- IP sign addr2 base cnt2
982 CALL #MUSMOD ;4 -- addr ud2lo ur uqlo uqhi CALL MU/MOD
983 POPM #3,S ;5 restore W,T,S: R-- IP sign
984 JMP S15Q16LOOP ;2 W=cnt
985 S15Q16EOC MOV 4(PSP),2(PSP) ;5 -- addr ud2lo ud2hi uqlo x ud2lo from >NUMBER becomes here ud2hi part of Q15.16
986 MOV @PSP,4(PSP) ;4 -- addr ud2lo ud2hi x x uqlo becomes ud2lo part of Q15.16
987 CMP.B #0,W ;1 count = 0 if end of conversion ok
988 .ENDIF ; FIXPOINT_INPUT
989 ; ------------------------------;
990 QNUMNEXT POPM #2,TOS ;4 -- addr ud2lo-hi x sign R: -- POPM IP,TOS TOS = sign flag = {-1;0}
991 JZ QNUMOK ;2 -- addr ud2lo-hi x sign conversion OK if Z=1
992 ; ------------------------------;
993 QNUMKO ADD #6,PSP ;2 -- addr sign
994 AND #0,TOS ;1 -- addr ff TOS=0 and Z=1 ==> conversion ko
996 ; ------------------------------;
997 .IFDEF DOUBLE_NUMBERS ; -- addr ud2lo-hi x sign
998 QNUMOK ADD #2,PSP ;1 -- addr ud2lo-hi sign
999 MOV 2(PSP),4(PSP) ;5 -- udlo udlo udhi sign
1000 MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back.
1001 XOR #-1,TOS ;1 -- udlo udhi inv(sign)
1002 JNZ QDOUBLE ;2 -- udlo udhi tf if jump : TOS=-1 and Z=0 ==> conversion ok
1003 XOR #-1,TOS ;1 -- udlo udhi tf
1004 QDNEGATE XOR #-1,2(PSP) ;3 -- udlo udhi -1
1005 XOR #-1,0(PSP) ;3 -- (dlo dhi)-1 tf
1008 QDOUBLE BIT #UF9,SR ;2 -- dlo dhi tf decimal point or comma fixpoint ?
1009 JZ NIP ;2 no, goto leave number
1010 QNUMEND MOV @IP+,PC ;4 TOS<>0 and Z=0 ==> conversion ok
1012 QNUMOK ADD #4,PSP ;1 -- addr ud2lo sign
1013 MOV @PSP,2(PSP) ;4 -- u u sign note : PSP is incremented before write back !!!
1014 XOR #-1,TOS ;1 -- udlo udhi inv(sign)
1015 JNZ QNUMEND ;2 -- udlo udhi tf if jump : TOS=-1 and Z=0 ==> conversion ok
1016 XOR #-1,TOS ;1 -- udlo udhi sign
1017 QNEGATE XOR #-1,2(PSP) ;3
1018 ADD #1,2(PSP) ;3 -- n u tf
1019 QNUMEND ADD #2,PSP ;1 -- n tf
1020 MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok
1021 .ENDIF ; DOUBLE_NUMBERS ;
1023 .ELSE ; if no hardware MPY
1025 ; T.I. UNSIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud
1026 ; https://forth-standard.org/standard/core/UMTimes
1027 ; UM* u1 u2 -- ud unsigned 16x16->32 mult.
1028 UMSTAR MOV @PSP,S ;2 MDlo
1029 UMSTAR1 MOV #0,T ;1 MDhi=0
1032 MOV #1,W ;1 BIT TEST REGISTER
1033 UMSTARLOOP BIT W,TOS ;1 TEST ACTUAL BIT MRlo
1034 JZ UMSTARNEXT ;2 IF 0: DO NOTHING
1035 ADD S,X ;1 IF 1: ADD MDlo TO RES0
1036 ADDC T,Y ;1 ADDC MDhi TO RES1
1037 UMSTARNEXT ADD S,S ;1 (RLA LSBs) MDlo x 2
1038 ADDC T,T ;1 (RLC MSBs) MDhi x 2
1039 ADD W,W ;1 (RLA) NEXT BIT TO TEST
1040 JNC UMSTARLOOP ;2 IF BIT IN CARRY: FINISHED 10~ loop
1041 MOV X,0(PSP) ;3 low result on stack
1042 MOV Y,TOS ;1 high result in TOS
1043 MOV @IP+,PC ;4 17 words
1046 ; https://forth-standard.org/standard/core/toNUMBER
1047 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1048 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1049 ; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_',
1050 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1051 ; or the first character past the end of the string if the string was entirely converted.
1052 ; u2 is the number of unconverted characters in the string.
1053 ; An ambiguous condition exists if ud2 overflows during the conversion.
1054 ; >NUMBER ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2
1055 TONUMBER MOV &BASEADR,W ;3 W = base
1057 MOV TOS,T ;1 T=count
1058 TONUMLOOP MOV.B @S,Y ;2 -- ud1lo ud1hi x x S=adr, T=count, W=BASE, Y=char
1059 DDIGITQ SUB.B #':',Y ;2
1060 JNC DDIGITQNEXT ;2 accept all chars <= 9
1061 SUB.B #07,Y ;2 reject all chars between "9" and "A"
1062 JNC TONUMEND ;2 yes: for bad end
1063 DDIGITQNEXT ADD.B #10,Y ;2 restore number
1064 CMP W,Y ;1 -- ud1lo ud1hi x x digit-base
1065 BIC #Z,SR ;1 reset Z before jmp TONUMEND because...
1066 JC TONUMEND ;2 ...QNUMBER conversion will be true if Z = 1 :-(
1067 UDSTAR PUSHM #6,IP ;8 -- ud1lo ud1hi x x save IP S T W X Y used by UM* r-- IP adr count base x digit
1068 MOV 2(PSP),S ;3 -- ud1lo ud1hi x x S=ud1hi
1069 MOV W,TOS ;1 -- ud1lo ud1hi x base
1070 MOV #UMSTARNEXT1,IP ;2
1071 UMSTARONE JMP UMSTAR1 ;2 ud1hi * base -- x ud3hi X=ud3lo
1072 UMSTARNEXT1 mNEXTADR ; -- ud1lo ud1hi x ud3hi
1073 MOV X,2(RSP) ;3 r-- IP adr count base ud3lo digit
1074 MOV 4(PSP),S ;3 -- ud1lo ud1hi x ud3hi S=ud1lo
1075 MOV 4(RSP),TOS ;3 -- ud1lo ud1hi x base
1076 MOV #UMSTARNEXT2,IP ;2
1077 UMSTARTWO JMP UMSTAR1 ;2 -- ud1lo ud1hi x ud4hi X=ud4lo
1078 UMSTARNEXT2 mNEXTADR ; -- ud1lo ud1hi x ud4hi
1079 ADD @RSP+,X ;2 -- ud1lo ud1hi x ud4hi X=ud4lo+digit=ud2lo r-- IP adr count base ud3lo
1080 ADDC @RSP+,TOS ;2 -- ud1lo ud1hi x ud2hi TOS=ud4hi+ud3lo+carry=ud2hi r-- IP adr count base
1081 MOV X,4(PSP) ;3 -- ud2lo ud1hi x ud2hi
1082 MOV TOS,2(PSP) ;3 -- ud2lo ud2hi x x r-- IP adr count base
1083 POPM #4,IP ;6 -- ud2lo ud2hi x x W=base, T=count, S=adr, IP=prevIP r--
1084 TONUMPLUS ADD #1,S ;1
1086 JNZ TONUMLOOP ;2 -- ud2lo ud2hi x x S=adr+1, T=count-1, W=base 68 cycles char loop
1087 TONUMEND MOV S,0(PSP) ;3 -- ud2lo ud2hi adr2 count2
1088 MOV T,TOS ;1 -- ud2lo ud2hi adr2 count2
1089 MOV @IP+,PC ;4 48/82 words/cycles, W = BASE
1091 ; ?NUMBER makes the interface between >NUMBER and INTERPRET; it's a subset of INTERPRET.
1092 ; convert a string to a signed number; FORTH 2012 prefixes ' $, %, # are recognized
1093 ; digits separator '_' also.
1094 ; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized
1095 ; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized.
1096 ; prefixes ' # % $ - are processed before calling >NUMBER
1097 ; chars . , _ are processed as >NUMBER exits
1098 ;Z ?NUMBER addr -- n|d -1 if convert ok ; flag Z=0, UF9=1 if double
1099 ;Z addr -- addr 0 if convert ko ; flag Z=1
1101 .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1102 BIC #UF9,SR ;2 reset flag UF9, before use as double number flag
1104 SUB #8,PSP ;1 -- x x x x addr
1105 MOV TOS,6(PSP) ;3 -- addr x x x addr save TOS
1106 MOV #0,4(PSP) ;3 ud1hi=0
1107 MOV #0,2(PSP) ;3 -- addr 0 0 x addr ud1lo=0
1108 MOV &BASEADR,W ;3 W=BASE
1109 MOV TOS,S ;1 -- addr ud=0 x x S=addr
1111 PUSHM #2,TOS ;4 R-- sign IP (push TOS,IP)
1112 MOV #TONUMEXIT,IP ;2 define >NUMBER return
1113 MOV.B @S+,T ;2 S=addr+1, T=count
1114 QNUMLDCHAR MOV.B @S,Y ;2 Y=char
1115 SUB.B #'-',Y ;2 -- addr ud=0 x x sign minus ?
1117 JC TONUMLOOP ;2 if char U> '-'
1118 QBINARY MOV #2,W ;1 preset base 2
1119 ADD.B #8,Y ;1 binary prefix ? '%' = '-' + 8
1120 JZ PREFIXNEXT ;2 yes
1121 QDECIMAL ADD #8,W ;1 preset base 10
1122 ADD.B #2,Y ;1 decimal prefix ? '#' = '%' + 2
1123 JZ PREFIXNEXT ;2 yes
1124 QHEXA MOV #16,W ;2 preset base 16
1125 CMP.B #1,Y ;1 hex prefix ? '$' = '#' + 1
1126 JZ PREFIXNEXT ;2 yes
1127 QTICK CMP.B #4,Y ;1 prefix = ' ? "'" = '#' + 4
1128 JNZ QNUMNEXT ;2 -- addr x x x cnt no, abort because other prefixes not recognized
1131 CMP.B @S+,1(S) ;4 compare 3rd with first char '
1132 MOV.B @S,S ;2 does char to word conversion
1133 MOV S,4(PSP) ;5 -- addr ud2lo x x 3 ud2lo = ASCII code of 'char'
1134 JMP QNUMNEXT ;2 with happy end if flag Z = 1
1135 QNUMMINUS MOV #-1,2(RSP) ;3 R-- sign IP set sign flag
1136 PREFIXNEXT SUB #1,T ;1 T=count-1
1137 CMP.B @S+,0(S) ;4 S=adr+1; same prefix ?
1138 JNZ QNUMLDCHAR ;2 no
1139 JZ TONUMLOOP ;2 yes, that will abort conversion
1140 ; ------------------------------;43
1141 TONUMEXIT mNEXTADR ; -- addr ud2lo-hi addr2 cnt2 R-- IP sign BASE S=addr2,T=cnt2
1142 JZ QNUMNEXT ;2 if conversion is ok
1144 MOV.B @S,Y ; regenerate rejected char
1145 CMP.B #'_',Y ;2 rejected char by >NUMBER is a underscore ?
1146 JZ TONUMPLUS ; yes: loopback to >NUMBER to skip char
1147 .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1148 BIT #UF9,SR ; UF9 already set ? (you have wrongly typed two points)
1149 JNZ QNUMNEXT ; yes, goto QNUMKO
1150 BIS #UF9,SR ;2 set double number flag
1153 SUB.B #'.',Y ;1 rejected char by >NUMBER is a decimal point ?
1154 JZ TONUMPLUS ;2 to terminate conversion
1156 .IFDEF FIXPOINT_INPUT ;
1158 ADD.B #2,Y ;1 rejected char by >NUMBER is a comma ?
1160 SUB.B #',',Y ;1 rejected char by >NUMBER is a comma ?
1162 JNZ QNUMNEXT ;2 no, goto QNUMKO
1163 S15Q16 MOV #0,X ;1 -- addr ud2lo x 0 x init ud2lo' = 0
1164 S15Q16LOOP MOV X,2(PSP) ;3 -- addr ud2lo ud2lo' ud2lo' x X = 0(PSP) = ud2lo'
1165 SUB.B #1,T ;1 decrement cnt2
1166 MOV T,X ;1 X = cnt2-1
1167 ADD S,X ;1 X = end_of_string-1, first...
1168 MOV.B @X,X ;2 X = last char of string, first...
1170 JNC QS15Q16DIGI ;2 accept all chars U< ':'
1172 JNC S15Q16EOC ;2 reject all chars U< 'A'
1173 QS15Q16DIGI ADD.B #10,X ;2 restore number
1174 CMP W,X ;1 W=BASE, is X a digit ?
1175 JC S15Q16EOC ;2 -- addr ud2lo ud2lo' x ud2lo' if not a digit
1176 MOV X,0(PSP) ;3 -- addr ud2lo ud2lo' digit x
1177 MOV W,TOS ;1 -- addr ud2lo ud2lo' digit base R-- IP sign
1178 PUSHM #3,S ;5 PUSH S,T,W: R-- IP sign addr2 cnt2 base
1179 CALL #MUSMOD ;4 -- addr ud2lo ur uqlo uqhi
1180 POPM #3,S ;5 restore W,T,S: R-- IP sign
1181 JMP S15Q16LOOP ;2 W=cnt
1182 S15Q16EOC MOV 4(PSP),2(PSP) ;5 -- addr ud2lo ud2lo uqlo x ud2lo from >NUMBER part1 becomes here ud2hi=S15 part2
1183 MOV @PSP,4(PSP) ;4 -- addr ud2lo ud2hi x x uqlo becomes ud2lo
1184 CMP.B #0,T ;1 cnt2 = 0 if end of conversion ok
1185 .ENDIF ; FIXPOINT_INPUT ;
1186 ; ------------------------------;97
1187 QNUMNEXT POPM #2,TOS ;4 -- addr ud2lo-hi x sign R: -- POPM IP,TOS TOS = sign flag = {-1;0}
1188 JZ QNUMOK ;2 -- addr ud2lo-hi x sign conversion OK if Z=1
1189 ; ------------------------------;
1190 QNUMKO ADD #6,PSP ;1 -- addr sign
1191 AND #0,TOS ;1 -- addr ff TOS=0 and Z=1 ==> conversion ko
1193 ; ------------------------------;
1194 .IFDEF DOUBLE_NUMBERS
1195 QNUMOK ADD #2,PSP ;1 -- addr ud2lo ud2hi sign
1196 MOV 2(PSP),4(PSP) ; -- udlo udlo udhi sign
1197 MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back !!!
1198 XOR #-1,TOS ;1 -- udlo udhi inv(sign)
1199 JNZ QDOUBLE ;2 if jump : TOS=-1 and Z=0 ==> conversion ok
1200 XOR #-1,TOS ;1 -- udlo udhi tf
1201 Q2NEGATE XOR #-1,2(PSP) ;3
1204 ADDC #0,0(PSP) ;3 -- dlo dhi tf
1205 QDOUBLE BIT #UF9,SR ;2 -- dlo dhi tf decimal point added ?
1206 JZ NIP ; no, goto leave number, Z=0
1207 QNUMEND MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok
1209 QNUMOK ADD #4,PSP ;1 -- addr ud2lo sign
1210 MOV @PSP,2(PSP) ;4 -- udlo udlo sign note : PSP is incremented before write back !!!
1211 XOR #-1,TOS ;1 -- udlo udlo inv(sign)
1212 JNZ QNUMEND ;2 if jump : TOS=-1 and Z=0 ==> conversion ok
1213 XOR #-1,TOS ;1 -- udlo udlo tf TOS=-1 and Z=0
1214 QNEGATE XOR #-1,2(PSP) ;3
1215 ADD #1,2(PSP) ;3 -- n udlo tf
1216 QNUMEND ADD #2,PSP ;1
1217 MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok
1218 .ENDIF ; DOUBLE_NUMBERS
1219 .ENDIF ; of Hardware/Software MPY
1221 FORTHWORDIMM "\\" ; immediate
1222 ; https://forth-standard.org/standard/block/bs
1224 ; everything up to the end of the current line is a comment.
1225 BACKSLASH MOV &SOURCE_LEN,&TOIN ;
1228 ; ------------------------------;
1229 ; INTERPRET = BACKSLASH + 8 ;
1230 ; ------------------------------;
1231 ; INTERPRET i*x addr u -- j*x interpret given buffer
1232 ; This is the common factor of EVALUATE and QUIT.
1233 ; set addr u as input buffer then parse it word by word
1234 INTERPRET mDOCOL ; INTERPRET = BACKSLASH + 8
1235 .word SETIB ; -- set input buffer pointers
1236 INTLOOP .word BL_WORD ; -- c-addr flag Z = 1 <=> End Of Line
1237 .word ZBRAN,FDROPEXIT; early return if End of Line
1239 mNEXTADR ; -- xt|c-addr|xt -1|0|+1 Z=1 --> not found
1240 MOV TOS,W ; W = flag = (-1|0|+1) as (not_immediate|not_found|immediate)
1241 MOV @PSP+,TOS ; -- xt|c-addr|xt
1242 MOV #INTQNUMNEXT,IP ;2 INTQNUMNEXT is the next of QNUMBER
1243 JZ QNUMBER ;2 if Z=1 --> not found, search a number
1244 MOV #INTLOOP,IP ;2 INTLOOP is the continuation of EXECUTE|COMMA
1246 JZ COMMA ;2 -- xt if W xor STATE = 0 compile xt, then loop back to INTLOOP
1247 EXECUTE PUSH TOS ;3 -- xt
1249 MOV @RSP+,PC ;4 xt --> PC, then loop back to INTLOOP
1250 ; ------------------------------;
1251 INTQNUMNEXT mNEXTADR ; -- n|c-addr fl Z = 1 --> not a number, SR(UF9) double number request
1252 MOV @PSP+,TOS ;2 -- n|c-addr
1253 MOV #INTLOOP,IP ;2 INTLOOP is the continuation of LITERAL.
1254 JNZ LITERAL ;2 n -- Z = 0 --> is a number, execute LITERAL then loop back to INTLOOP
1255 NOTFOUND MOV #FABORT_TERM,IP ;2 ABORT_TERM becomes the end of INTERPRET
1256 ADD.B #1,0(TOS) ;3 c-addr -- Z = 1 --> Not a Number : incr string count to add '?'
1257 MOV.B @TOS,Y ;2 Y=count+1
1258 ADD TOS,Y ;1 Y=end of string addr
1259 MOV.B #'?',0(Y) ;5 add '?' to end of string
1260 JMP COUNT ;2 -- addr len return to ABORT_TERM
1261 FDROPEXIT .word DROPEXIT
1263 FORTHWORDIMM "LITERAL" ; immediate
1264 .IFDEF DOUBLE_NUMBERS ; are recognized
1265 ; https://forth-standard.org/standard/core/LITERAL
1266 ; LITERAL n -- append single numeric literal if compiling state
1267 ; d -- append two numeric literals if compiling state and UF9<>0 (not ANS)
1268 LITERAL CMP #0,&STATE ;3
1269 JZ LITERALNEXT ;2 if interpreting state, does nothing else to clear UF9 flag
1270 MOV TOS,X ;1 X = n|dhi
1271 LITERALLOOP MOV &DP,W ;3
1274 MOV X,2(W) ;3 pass 1: compile n, if pass 2: compile dhi
1276 BIT #UF9,SR ;2 double number ?
1277 LITERALNEXT BIC #UF9,SR ;2 in all case, clear UF9
1278 JZ LITERALEND ;2 no goto end if n|interpret_state
1279 MOV TOS,2(W) ;3 yes compile dlo over dhi
1281 LITERALEND MOV @IP+,PC ;4
1283 ; https://forth-standard.org/standard/core/LITERAL
1284 ; LITERAL n -- append single numeric literal if compiling state
1285 LITERAL CMP #0,&STATE ;3
1286 JZ LITERALEND ;2 if interpreting state, does nothing
1292 LITERALEND MOV @IP+,PC ;4
1295 ; https://forth-standard.org/standard/core/DEPTH
1296 ; DEPTH -- +n number of items on stack, must leave 0 if stack empty
1297 QDEPTH MOV TOS,-2(PSP) ; 3
1299 SUB PSP,TOS ; 1 PSP-S0--> TOS
1300 RRA TOS ; 1 TOS/2 --> TOS
1302 ; https://forth-standard.org/standard/core/Zeroless
1303 ; 0< n -- flag true if TOS negative
1304 ZEROLESS ADD TOS,TOS ;1 set carry if TOS negative
1305 SUBC TOS,TOS ;1 TOS=-1 if carry was clear
1306 INVERT XOR #-1,TOS ;1 TOS=-1 if carry was set
1310 ; https://forth-standard.org/standard/core/COUNT
1311 ; COUNT c-addr1 -- adr len counted->adr/len
1316 AND #-1,TOS ;1 Z is set if u=0
1319 QFRAM_FULL SUB #2,PSP ; 2
1322 CMP #FRAM_FULL,&DP ; 4
1327 ; https://forth-standard.org/standard/core/ALLOT
1328 ; ALLOT n -- allocate n bytes
1333 ; ----------------------------------;
1334 ; ABORT = ALLOT + $08 ;
1335 ; QUIT = ALLOT + $0E ;
1336 ; ----------------------------------;
1338 ; https://forth-standard.org/standard/core/ABORT
1339 ; Empty the data stack and perform the function of QUIT,
1340 ; which includes emptying the return stack, without displaying a message.
1341 ; ABORT is the common next of WARM and ABORT"
1342 ABORT MOV #PSTACK,PSP ; clear Parameter stack
1343 MOV #0,TOS ; clear TOS for SYS use.
1344 ; https://forth-standard.org/standard/core/QUIT
1345 ; QUIT -- interpret line by line the input stream
1346 QUIT mASM2FORTH ; QUIT is the level 0 of Return stack
1348 QUIT1 .word XSQUOTE ;
1349 .byte 5,13,10,"ok " ; CR+LF + Forth prompt
1352 QUIT2 .word XSQUOTE ; 16~
1353 .byte 2,13,10 ; CR+LF
1356 .word REFILL ; -- org len refill the input line buffer from ACCEPT
1357 QUIT4 .word INTERPRET ; interpret it
1358 QUIT5 .word QDEPTH ; 15~ stack empty test
1359 .word XSQUOTE ; 16~ ABORT" stack empty"
1360 .byte 11,"stack empty";
1361 .word QABORT ; 14~ see QABORT in forthMSP430FR_TERM_xxx.asm
1362 .word QFRAM_FULL ; 16~ FRAM full test
1363 .word XSQUOTE ; 16~ ABORT" MAIN full"
1364 .byte 9,"MAIN full" ;
1367 .word LIT,STATE,FETCH ; STATE @
1368 .word QFBRAN,QUIT1 ; 0= case of interpretion state
1369 .word XSQUOTE ; 0<> case of compilation state
1370 .byte 5,13,10," " ; CR+LF + 3 spaces
1372 .word BRAN,QUIT2 ; 6~
1374 FORTHWORDIMM "ABORT\34"
1375 ; ; ABORT" is enabled in interpretation mode (+ 11 words) :
1379 ; EXEC_QABORT MOV #0,T ; CAPS OFF
1381 ; .word LIT,'"',WORDD+4,COUNT,QABORT
1383 ;COMP_QABORT mASM2FORTH
1385 ; .word LIT,QABORT,COMMA ; see QABORT in forthMSP430FR_TERM_xxx.asm
1388 ; https://forth-standard.org/standard/core/ABORTq
1389 ; ABORT" " (empty string) displays nothing
1390 ; ABORT" i*x flag -- i*x R: j*x -- j*x flag=0
1391 ; i*x flag -- R: j*x -- flag<>0
1394 .word LIT,QABORT,COMMA ; see QABORT in forthMSP430FR_TERM_xxx.asm
1398 ; https://forth-standard.org/standard/core/Tick
1399 ; ' -- xt find word in dictionary and leave on stack its execution address if exist else error.
1402 .word QFBRAN,FNOTFOUND;
1404 FNOTFOUND .word NOTFOUND ; see INTERPRET
1406 FORTHWORDIMM "[']" ; immediate word, i.e. word executed during compilation
1407 ; https://forth-standard.org/standard/core/BracketTick
1408 ; ['] <name> -- find word & compile it as literal
1410 .word TICK ; get xt of <name>
1411 .word LIT,LIT,COMMA ; append LIT action
1412 .word COMMA,EXIT ; append xt literal
1414 FORTHWORDIMM "[" ; immediate
1415 ; https://forth-standard.org/standard/core/Bracket
1416 ; [ -- enter interpretative state
1417 LEFTBRACKET MOV #0,&STATE
1421 ; https://forth-standard.org/standard/core/right-bracket
1422 ; ] -- enter compiling state
1426 ;-------------------------------------------------------------------------------
1428 ;-------------------------------------------------------------------------------
1430 ; https://forth-standard.org/standard/core/Comma
1431 ; , x -- append cell to dict
1436 MOV @IP+,PC ;4 15~ W = DP
1438 FORTHWORDIMM "POSTPONE"
1439 ; https://forth-standard.org/standard/core/POSTPONE
1442 .word ZBRAN,FNOTFOUND ; BRANch to FNOTFOUND if Z = 1
1443 .word ZEROLESS ; immediate word ?
1444 .word QFBRAN,POST1 ; if immediate
1445 .word LIT,LIT,COMMA ; else compile LIT
1446 .word COMMA ; compile xt
1447 .word LIT,COMMA ; CFA of COMMA
1448 POST1 .word COMMA,EXIT ; then compile xt of word found if immediate else CFA of COMMA
1451 ; https://forth-standard.org/standard/core/Colon
1452 ; : <name> -- begin a colon definition
1453 COLON PUSH #COLONNEXT ;3 define COLONNEXT as HEADER return
1454 ;-----------------------------------;
1455 HEADER BIT #1,&DP ;3 carry set if odd
1456 ADDC #2,&DP ;4 align and make room for LFA
1458 .word BL_WORD ; W = Count_of_chars, up to 127 for definitions
1459 mNEXTADR ; -- HERE HERE is the NFA of this new word
1461 BIS.B #1,W ; W=count is always odd
1462 ADD.B #1,W ; W=add one byte for length
1463 ADD TOS,W ; W=Aligned_CFA
1464 MOV &CURRENT,X ; X=VOC_BODY of CURRENT
1466 ADD.B @TOS+,-1(TOS) ; shift left once NFA_1st_byte (make room for immediate flag, clear it)
1468 .CASE 1 ; nothing to do
1469 .ELSECASE ; multithreading add 5~ 4words
1470 MOV.B @TOS,TOS ; -- char TOS=first CHAR of new word
1471 AND #(THREADS-1),TOS ; -- offset TOS= thread_offset in words
1472 ADD TOS,TOS ; TOS= thread_offset in bytes
1473 ADD TOS,X ; X=VOC_PFAx = thread x of VOC_PFA of CURRENT
1476 HEADEREND MOV Y,&LAST_NFA ; NFA --> LAST_NFA used by QREVEAL, IMMEDIATE
1477 MOV X,&LAST_THREAD ; VOC_PFAx --> LAST_THREAD used by QREVEAL
1478 MOV W,&LAST_CFA ; HERE=CFA --> LAST_CFA used by DOES>, RECURSE
1479 MOV PSP,&LAST_PSP ; save PSP for check compiling, used by QREVEAL
1480 ADD #4,W ; W = BODY of created word...
1482 MOV @RSP+,PC ; RET W is the new DP value )
1483 ;-----------------------------------; X is LAST_THREAD > used by compiling words: CREATE DEFER : CODE ...
1484 COLONNEXT ; Y is NFA )
1485 .SWITCH DTC ; Direct Threaded Code select:
1486 .CASE 1 ; [rDOCOL] = XDOCOL
1487 MOV #DOCOL,-4(W) ; compile CALL R4 = rDOCOL
1488 SUB #2,&DP ; adjust DP
1489 .CASE 2 ; [rDOCOL] = EXIT
1490 MOV #120Dh,-4(W) ; compile PUSH IP 3~
1491 MOV #DOCOL,-2(W) ; compile CALL R4 = rDOCOL
1492 .CASE 3 ; [rDOCOL] = ???
1493 MOV #120Dh,-4(W) ; compile PUSH IP 3~
1494 MOV #400Dh,-2(W) ; compile MOV PC,IP 1~
1495 MOV #522Dh,0(W) ; compile ADD #4,IP 1~
1496 MOV #4D30h,+2(W) ; compile MOV @IP+,PC 4~
1497 ADD #4,&DP ; adjust DP
1499 MOV #-1,&STATE ; enter compiling state
1501 ;-----------------------------------;
1503 ;;Z ?REVEAL -- if no stack mismatch, link this new word in the CURRENT vocabulary
1504 QREVEAL CMP PSP,&LAST_PSP ; Check SP with its saved value by , :NONAME CODE...
1507 BAD_CSP mASM2FORTH ; if stack mismatch.
1509 .byte 15,"stack mismatch!"
1510 FABORT_TERM .word ABORT_TERM
1511 LINK_NFA MOV &LAST_NFA,Y ; if no error, link this definition in its thread
1512 MOV &LAST_THREAD,X ;
1513 REVEAL MOV @X,-2(Y) ; [LAST_THREAD] --> LFA (for NONAME: LFA --> 210h unused PA reg)
1514 MOV Y,0(X) ; LAST_NFA --> [LAST_THREAD] (for NONAME: [LAST_THREAD] --> 212h unused PA reg)
1518 ; https://forth-standard.org/standard/core/Semi
1519 ; ; -- end a colon definition
1520 SEMICOLON CMP #0,&STATE ; if interpret mode, semicolon becomes a comment identifier
1521 JZ BACKSLASH ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th
1522 mDOCOL ; compile mode
1523 .word LIT,EXIT,COMMA
1524 .word QREVEAL,LEFTBRACKET,EXIT
1526 FORTHWORD "IMMEDIATE"
1527 ; https://forth-standard.org/standard/core/IMMEDIATE
1528 ; IMMEDIATE -- make last definition immediate
1529 IMMEDIATE MOV &LAST_NFA,Y ;3
1530 BIS.B #1,0(Y) ;4 FIND process more easier with bit0 for IMMEDIATE flag than bit7
1534 ; https://forth-standard.org/standard/core/CREATE
1535 ; CREATE <name> -- define a CONSTANT with its next address
1536 ; Execution: ( -- a-addr ) ; a-addr is the address of name's data field
1537 ; ; the execution semantics of name may be extended by using DOES>
1538 CREATE CALL #HEADER ; -- W = DP
1539 MOV #DOCON,-4(W) ;4 -4(W) = CFA = CALL rDOCON
1540 MOV W,-2(W) ;3 -2(W) = PFA = W = next address
1541 CREATENEXT JMP REVEAL ; to link the definition in vocabulary
1544 ; https://forth-standard.org/standard/core/DOES
1545 ; DOES> -- set action for the latest CREATEd definition
1546 DOES MOV &LAST_CFA,W ; W = CFA of CREATEd word
1547 MOV #DODOES,0(W) ; replace CALL rDOCON of CREATE by new CFA: CALL rDODOES
1548 MOV IP,2(W) ; replace PFA by the address after DOES> as execution address
1549 MOV @RSP+,IP ; which ends the..
1550 NEXT_ADR MOV @IP+,PC ; ..of a CREATE definition.
1553 ; https://forth-standard.org/standard/core/ColonNONAME
1556 ; X is the LAST_THREAD lure value for REVEAL
1557 ; Y is the LAST_NFA lure value for REVEAL and IMMEDIATE
1558 ; ...because we don't want to modify the word set !
1559 PUSH #COLONNEXT ; define COLONNEXT as HEADEREND RET
1560 HEADERLESS SUB #2,PSP ; -- TOS common part of :NONAME and CODENNM
1564 ADDC #0,W ; W = aligned CFA
1565 MOV W,TOS ; -- xt aligned CFA of :NONAME | CODENNM
1566 MOV #212h,X ; MOV Y,0(X) writes to 212h = unused PA register address (lure for REVEAL)
1567 MOV X,Y ; MOV @X,-2(Y) writes to 210h = unused PA register address (lure for REVEAL and IMMEDIATE)
1570 ;; https://forth-standard.org/standard/core/DEFER
1571 ;; Skip leading space delimiters. Parse name delimited by a space.
1572 ;; Create a definition for name with the execution semantics defined below.
1574 ;; name Execution: --
1575 ;; Execute the xt that name is set to execute, i.e. NEXT (nothing),
1576 ;; until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name.
1579 ; MOV #4030h,-4(W) ;4 first CELL = MOV @PC+,PC = BR #addr
1580 ; MOV #NEXT_ADR,-2(W) ;3 second CELL = ...mNEXT : do nothing by default
1581 ; JMP REVEAL ; to link created word in vocabulary
1583 ; used like this (high level defn.):
1584 ; DEFER DISPLAY create a "do nothing" definition (2 CELLS)
1586 ; or (more elegant low level defn.):
1587 ; CODE DISPLAY create a "do nothing" definition (2 CELLS)
1588 ; MOV #NEXT_ADR,PC NEXT_ADR is the address of NEXT code: MOV @IP+,PC
1591 ; inline command : ' U. IS DISPLAY U. becomes the runtime of the word DISPLAY
1592 ; or in a definition : ... ['] U. IS DISPLAY ... ;
1593 ; KEY, EMIT, CR, ACCEPT are examples of DEFERred words
1596 FORTHWORDIMM "IS" ; immediate
1604 DEFERSTORE MOV @PSP+,2(TOS) ; -- CFA_DEFERed_WORD xt --> [PFA_DEFERed_WORD]
1607 IS_COMPILE mASM2FORTH
1608 .word BRACTICK ; find the word, compile its CFA as literal
1609 .word LIT,DEFERSTORE ; compile DEFERSTORE
1612 ;-------------------------------------------------------------------------------
1613 ; ASSEMBLER building definitions
1614 ;-------------------------------------------------------------------------------
1615 FORTHWORD "CODE" ; a CODE word must be finished with ENDCODE
1616 ASMCODE CALL #HEADER ; (that sets CFA and PFA)
1617 ASMCODE1 SUB #4,&DP ; remove default room for CFA + PFA
1618 .IFDEF VOCABULARY_SET ; if VOCABULARY_SET
1619 JMP hidden ; add hidden word set in CONTEXT stack
1621 hidden MOV &CONTEXT,&CONTEXT+2 ; add hidden word set in CONTEXT stack
1622 MOV #BODYhidden,&CONTEXT;
1626 ; HDNCODE (hidden CODE) is used to define a CODE word which must not to be executed by FORTH interpreter
1627 ; i.e. typically the case of an assembler definition called by CALL and ended by RET, or an interrupt routine.
1628 ; HDNCODE words are only usable in ASSEMBLER CONTEXT.
1630 PUSH &CURRENT ; save CURRENT
1631 MOV #BODYhidden,&CURRENT; select hidden word set as CURRENT to link HDNCODE definition
1636 MOV @RSP+,&CURRENT ; restore CURRENT
1639 FORTHWORD "CODENNM" ; CODENoNaMe is the assembly counterpart of :NONAME
1640 CODENNM PUSH #ASMCODE1 ; define HEADERLESS return
1641 JMP HEADERLESS ; that makes room for CFA and PFA
1644 ENDCODE MOV IP,T ; T is unused by QREVEAL
1649 .IFDEF VOCABULARY_SET
1650 JMP PREVIOUS ; remove hidden word set from CONTEXT stack
1652 PREVIOUS MOV #BODYFORTH,&CONTEXT ; remove hidden word set from CONTEXT stack
1657 ; here are 3 words used to switch FORTH <--> ASSEMBLER
1659 ; COLON -- compile DOCOL, remove ASSEMBLER from CONTEXT stack, switch to compilation state
1664 MOV #DOCOL,0(W) ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL)
1667 MOV #120Dh,0(W) ; compile PUSH IP
1668 COLON1 MOV #DOCOL,2(W) ; compile CALL R4 = rDOCOL
1670 .CASE 3 ; inlined DOCOL
1671 MOV #120Dh,0(W) ; compile PUSH IP
1672 COLON1 MOV #400Dh,2(W) ; compile MOV PC,IP
1673 MOV #522Dh,4(W) ; compile ADD #4,IP
1674 MOV #4D30h,6(W) ; compile MOV @IP+,PC
1677 COLON2 MOV #-1,&STATE ; enter in compile state
1678 JMP PREVIOUS ; to restore CONTEXT
1680 ; LO2HI -- same as COLON but without saving IP
1683 .CASE 1 ; compile 2 words
1685 MOV #12B0h,0(W) ; compile CALL #EXIT, 2 words 4+6=10~
1689 .ELSECASE ; CASE 2 : compile 1 word, CASE 3 : compile 3 words
1690 SUB #2,&DP ; to skip PUSH IP
1695 ; HI2LO -- immediate, switch to low level, set interpretation state, add ASSEMBLER to CONTEXT
1696 FORTHWORDIMM "HI2LO" ;
1698 MOV &DP,W ; W = HERE+2
1699 MOV W,-2(W) ; compile HERE+2 to HERE
1700 MOV #0,&STATE ; LEFTBRACKET
1701 JMP hidden ; to save CURRENT and add ASSEMBLER in context
1703 ;-------------------------------------------------------------------------------
1704 ; WORDS SET for VOCABULARY, not ANS compliant,
1705 ;-------------------------------------------------------------------------------
1706 .IFDEF VOCABULARY_SET
1709 ;X VOCABULARY -- create a new word_set
1715 MOV #0,0(W) ; W = BODY, init thread with 0
1718 MOV #THREADS,X ; count
1719 VOCABULOOP MOV #0,0(W) ; init threads area with 0
1723 .ENDCASE ; W = BODY + THREADS*2
1724 MOV &LASTVOC,0(W) ; link LASTVOC
1726 ADD #2,W ; update DP
1730 ;-----------------------------------;
1731 VOCDOES mNEXTADR ; adds WORD-SET first in context stack
1732 ALSO MOV #14,X ;2 -- move up 7 words, first word in last
1734 MOV CONTEXT(X),CONTEXT+2(X) ; X=src < Y=dst copy W bytes beginning with the end
1736 MOV TOS,CONTEXT(X) ;3 copy word-set BODY --> first cell of CONTEXT
1739 FORTHWORD "DEFINITIONS"
1740 ;X DEFINITIONS -- set last context vocabulary as entry for further defining words
1741 DEFINITIONS MOV &CONTEXT,&CURRENT
1745 ;X ONLY -- fill the context stack with 0 to access only the first word-set, ex.: FORTH ONLY
1754 FORTHWORD "PREVIOUS"
1755 ;X PREVIOUS -- pop first word-set out of context stack
1756 PREVIOUS MOV #8,Y ;1 move down 8 words, first with CONTEXT+2 addr, last with NULL_WORD one
1757 MOV #CONTEXT+2,X ;2 X = org = CONTEXT+2, X-2 = dst = CONTEXT
1758 CMP #0,0(X) ;3 [org] = 0 ?
1759 JZ PREVIOUSEND ;2 to avoid scratch of the first CONTEXT cell by human mistake
1760 PREVIOUSLOO MOV @X+,-4(X) ;4
1762 JNZ PREVIOUSLOO ;2 8~ loop * 8 = 64 ~
1763 PREVIOUSEND MOV @IP+,PC ;4
1765 FORTHWORD "FORTH" ; add FORTH as first context word-set
1769 .ENDIF ; VOCABULARY_SET
1771 BODYFORTH .word lastforthword ; BODY of FORTH
1774 .word lastforthword1
1776 .word lastforthword1
1777 .word lastforthword2
1778 .word lastforthword3
1780 .word lastforthword1
1781 .word lastforthword2
1782 .word lastforthword3
1783 .word lastforthword4
1784 .word lastforthword5
1785 .word lastforthword6
1786 .word lastforthword7
1788 .word lastforthword1
1789 .word lastforthword2
1790 .word lastforthword3
1791 .word lastforthword4
1792 .word lastforthword5
1793 .word lastforthword6
1794 .word lastforthword7
1795 .word lastforthword8
1796 .word lastforthword9
1797 .word lastforthword10
1798 .word lastforthword11
1799 .word lastforthword12
1800 .word lastforthword13
1801 .word lastforthword14
1802 .word lastforthword15
1804 .word lastforthword1
1805 .word lastforthword2
1806 .word lastforthword3
1807 .word lastforthword4
1808 .word lastforthword5
1809 .word lastforthword6
1810 .word lastforthword7
1811 .word lastforthword8
1812 .word lastforthword9
1813 .word lastforthword10
1814 .word lastforthword11
1815 .word lastforthword12
1816 .word lastforthword13
1817 .word lastforthword14
1818 .word lastforthword15
1819 .word lastforthword16
1820 .word lastforthword17
1821 .word lastforthword18
1822 .word lastforthword19
1823 .word lastforthword20
1824 .word lastforthword21
1825 .word lastforthword22
1826 .word lastforthword23
1827 .word lastforthword24
1828 .word lastforthword25
1829 .word lastforthword26
1830 .word lastforthword27
1831 .word lastforthword28
1832 .word lastforthword29
1833 .word lastforthword30
1834 .word lastforthword31
1840 .IFDEF VOCABULARY_SET
1841 FORTHWORD "hidden" ; cannot be found by FORTH interpreter because the string is not capitalized
1845 BODYhidden .word lastasmword ; BODY of hidden words
1914 ;-------------------------------------------------------------------------------
1915 ; FASTFORTH environment management: RST_SET RST_RET MARKER
1916 ;-------------------------------------------------------------------------------
1917 ENV_COPY ; mini MOVE T words from X to W
1918 .IFDEF VOCABULARY_SET
1919 MOV #12,T ; words count for extended environment: DP,LASTVOC,CURRENT,CONTEXT(8),NULL_WORD
1921 MOV #4,T ; words count for basic environment: DP,LASTVOC,CURRENT,CONTEXT
1923 MOV_WORDS MOV @X+,0(W) ; 4 X = src, W = dst, T = words count
1925 SUB #1,T ; 1 words count -1
1929 FORTHWORD "RST_SET" ; define actual environment as new RESET environment
1930 RST_SET MOV #DP,X ; org = RAM value (DP first)
1931 MOV #RST_DP,W ; dst = FRAM value (RST_DP first), see \inc\ThingsInFirst.inc
1932 CALL #ENV_COPY ; copy environment RAM --> FRAM RST, use T,W,X
1935 FORTHWORD "RST_RET" ; init / return_to_previous RESET or MARKER environment
1936 RST_RET MOV #RST_DP,X ; org = FRAM value (first RST_DP), see \inc\ThingsInFirst.inc
1937 MOV #DP,W ; dst = RAM value (first DP)
1938 MOV @X,S ; S = restored DP, used below for comparaison with NFAs below
1939 CALL #ENV_COPY ; copy environment FRAM RST --> RAM, use T,W,X
1940 MOV &LASTVOC,W ; W = init/restored LASTVOC in RAM
1941 .SWITCH THREADS ; init/restore THREAD(s) with NFAs value < DP value, for all word set
1942 .CASE 1 ; mono thread word-set
1943 MARKALLVOC MOV W,Y ; W=VLK Y = VLK
1944 MRKWORDLOOP MOV -2(Y),Y ; W=VLK Y = [THD] then [LFA] = NFA
1945 CMP Y,S ; Y=NFA S=DP CMP = S-Y : OLD_DP-NFA
1946 JNC MRKWORDLOOP ; loop back if S<Y : OLD_DP<NFA
1947 MOV Y,-2(W) ; W=VLK X=THD Y=NFA refresh thread with good NFA
1948 .ELSECASE ; multi threads word-set
1949 MARKALLVOC MOV #THREADS,T ; S=DP T=ThdCnt (Threads Count), VLK = THD_n+1
1950 MOV W,X ; W = VLK X = VLK then THD_n (VOCLINK first, then THREADn)
1951 MRKTHRDLOOP MOV X,Y ;
1953 MRKWORDLOOP MOV -2(Y),Y ; Y = NFA = [THD_n] then [LFA]
1954 CMP Y,S ; Y = NFA S=DP CMP = S-Y : DP-NFA
1955 JNC MRKWORDLOOP ; loop back if S<Y : DP<NFA (if not_carry = if borrow)
1956 MARKTHREAD MOV Y,0(X) ; Y=NFA X=THD_n refresh thread with good NFA
1957 SUB #1,T ; T=ThdCnt-1
1958 JNZ MRKTHRDLOOP ; loopback to process NFA of next thread (thread-1)
1959 .ENDCASE ; of THREADS ;
1960 MOV @W,W ; W=[VLK] = VLK-1
1961 CMP #0,W ; end of vocs ?
1962 JNZ MARKALLVOC ; W=VLK-1 no : loopback
1965 ; https://forth-standard.org/standard/core/MARKER
1967 ;name Execution: ( -- )
1968 ;Restore all dictionary allocation and search order pointers to the state they had just prior to the
1969 ;definition of name. Remove the definition of name and all subsequent definitions. Restoration
1970 ;of any structures still existing that could refer to deleted definitions or deallocated data space is
1971 ;not necessarily provided. No other contextual information such as numeric base is affected.
1972 ; the FORTH environment is it automaticaly restored.
1973 ; FastForth provides all that is necessary for a real time application,
1974 ; by adding a call to a custom asm subroutine to restore all user environment.
1976 MARKER_DOES ; execution part of MARKER definition
1978 .IFDEF VOCABULARY_SET
1979 MOV TOS,X ; X = org (first : BODY = MARKER_DP)
1980 MOV #RST_DP,W ; W = dst (first : RST_DP), see \inc\ThingsInFirst.inc
1981 CALL #ENV_COPY ; restore previous FORTH environment from FRAM MARKER to FRAM RST
1982 MOV X,TOS ; -- USER_DOES RET_ADR by default
1984 MOV @TOS+,&RST_DP ; -- USER_DOES only RST_DP is restored
1986 CALL @TOS+ ; -- USER_PARAM executes defined USER_DOES subroutine (RET_ADR by default),
1987 ; IP is free, TOS is the address of first USER parameter
1990 JMP RST_RET ; which restores previous FORTH environment in RAM
1992 FORTHWORD "MARKER" ; definition part
1993 ;( "<spaces>name" -- )
1994 ;Skip leading space delimiters. Parse name delimited by a space. Create a definition for name
1995 ;with the execution semantics defined above.
1996 ;-------------------------------------------------------------------------------
1997 ; before that, if already defined, "name" executes its MARKER_DOES part.
1998 ; i.e. does: [DEFINED] <name> [IF] <name> [THEN]
2000 ;-------------------------------------------------------------------------------
2001 PUSH &TOIN ; -- save >IN
2003 .word BL_WORD,FIND ; -- addr flag
2004 .word QFBRAN,MARKER_NEXT; -- addr if not found
2005 .word DUP,EXECUTE ; -- MARKER_DOES execute it
2006 MARKER_NEXT mNEXTADR ; -- addr|MARKER_DOES
2009 MOV @RSP+,&TOIN ; restore >IN for HEADER
2010 ;-------------------------------------------------------------------------------
2011 CALL #HEADER ;4 W = BODY, Y = NFA,
2012 MOV #1285h,-4(W) ;4 CFA = CALL rDODOES
2013 MOV #MARKER_DOES,-2(W) ;4 PFA = MARKER_DOES
2014 SUB #2,Y ;1 Y = NFA-2 = LFA = DP to be restored, W = FRAM MARKER_DDP
2015 .IFDEF VOCABULARY_SET
2016 MOV Y,&DP ; Y = previous DP (just before MARKER definition)
2017 MOV #DP,X ; X = org = RAM DP, W = dst = MARKER_BODY
2018 CALL #ENV_COPY ; copy environment RAM --> FRAM MARKER
2019 MOV #RET_ADR,0(W) ;4 USER_DOES default subroutine = RET_ADR
2021 MOV W,&DP ;4 set new RAM DP (after the end of MARKER definition)
2023 MOV Y,0(W) ; DP to be restored
2024 MOV #RET_ADR,2(W) ; USER_DOES default subroutine = RET_ADR
2027 JMP LINK_NFA ; then NEXT
2029 ;-------------------------------------------------------------------------------
2030 ; PUC 7 : SELECT RST_RET|DEEP_RESET <== INIT_FORTH <== (PUC,SYS,QABORT)
2031 ;-------------------------------------------------------------------------------
2032 SEL_RST CMP #0,TOS ;
2033 JGE RST_RET ; RST_RET if TOS >= 0
2034 ;-----------------------------------;
2035 ; DEEP RESET ; DEEP_RESET if TOS < 0
2036 ;-----------------------------------;
2037 ; DEEP INIT SIGNATURES AREA ;
2038 ;-----------------------------------;
2039 MOV #16,X ; max known SIGNATURES length = 12 bytes
2040 SIGNATLOOP SUB #2,X ;
2041 MOV #-1,SIGNATURES(X) ; reset signatures; WARNING ! DON'T CHANGE IMMEDIATE VALUE !
2043 ;-----------------------------------;
2044 ; DEEP INIT VECTORS INT ; X = 0 ;-)
2045 ;-----------------------------------;
2046 MOV #RESET,-2(X) ; write RESET at addr X-2 = FFFEh
2047 INIVECLOOP SUB #2,X ;
2048 MOV #COLD,-2(X) ; -2(X) = FFFCh first
2049 CMP #0FFACh+2,X ; init 41 vectors, FFFCh down to 0FFACh
2050 JNZ INIVECLOOP ; all vectors are initialised to execute COLD routine
2051 ;-----------------------------------;
2052 ; DEEP INIT Terminal Int vector ;
2053 ;-----------------------------------;
2054 MOV #DEEP_ORG,X ; DEEP_ORG values are in FRAM INFO, see \inc\ThingsInFirst.inc
2055 MOV @X+,&TERM_VEC ; TERMINAL_INT as default vector --> FRAM TERM_VEC
2056 ;-----------------------------------;
2057 ; DEEP INIT FRAM RST values ; [COLD,SOFT,HARD,BACKGRND]_APP + RST_[DP,LASTVOC,CURRENT,CONTEXT]
2058 ;-----------------------------------;
2059 MOV #RST_LEN/2,T ; T = words count
2060 MOV #RST_ORG,W ; W = dst, X = org
2062 MOV #0,&RST_CONTEXT+2 ; to do FORTH ONLY
2063 ;-----------------------------------;
2064 .IFDEF BOOTLOADER ; does NOBOOT:
2065 MOV #WARM,&PUCNEXT ; removes XBOOT from PUC chain.
2067 ;-----------------------------------;
2068 ; WARM INIT threads of all word set ;
2069 ;-----------------------------------;
2070 JMP RST_RET ; then go to DUP|PUCNEXT, resp. in QABORT|RESET
2071 ;-----------------------------------;
2073 ;===============================================================================
2074 ; ASSEMBLER KERNEL OPTION
2075 ;===============================================================================
2077 .include "forthMSP430FR_EXTD_ASM.asm"
2079 .include "forthMSP430FR_ASM.asm"
2082 .IFDEF SD_CARD_LOADER
2083 ;===============================================================================
2084 ; SD CARD KERNEL OPTIONS
2085 ;===============================================================================
2086 .include "forthMSP430FR_SD_LowLvl.asm" ; SD primitives
2087 .include "forthMSP430FR_SD_INIT.asm" ; return to INIT_TERM; without use of IP,TOS
2088 .include "forthMSP430FR_SD_LOAD.asm" ; SD LOAD driver
2089 .IFDEF SD_CARD_READ_WRITE
2090 .include "forthMSP430FR_SD_RW.asm" ; SD Read/Write driver
2094 ;===============================================================================
2095 ; ADDONS OPTIONS; if included here they will be protected against Deep_RST
2096 ;===============================================================================
2097 .IFDEF CORE_COMPLEMENT
2098 ;-------------------------------------------------------------------------------
2099 ; COMPLEMENT of definitions to pass ANS94 CORETEST
2100 ;-------------------------------------------------------------------------------
2101 .include "ADDON/CORE_ANS.asm"
2105 ;-------------------------------------------------------------------------------
2107 ;-------------------------------------------------------------------------------
2108 .include "ADDON/UTILITY.asm"
2112 ;-------------------------------------------------------------------------------
2113 ; FIXED POINT OPERATORS
2114 ;-------------------------------------------------------------------------------
2115 .include "ADDON/FIXPOINT.asm"
2119 ;-------------------------------------------------------------------------------
2121 ;-------------------------------------------------------------------------------
2122 .include "ADDON/DOUBLE.asm"
2125 .IFDEF SD_CARD_LOADER
2127 ;-------------------------------------------------------------------------------
2129 ;-------------------------------------------------------------------------------
2130 .include "ADDON/SD_TOOLS.asm"
2134 ;-------------------------------------------------------------------------------
2135 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL and protected against Deep_RST
2136 ;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
2137 ; .include "YOUR_CODE.asm"
2138 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2139 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against Deep_RST)
2140 ;-------------------------------------------------------------------------------
2142 ;-------------------------------------------------------------------------------
2143 ; RESOLVE ASSEMBLY pointers, init interrupt Vectors
2144 ;-------------------------------------------------------------------------------
2145 .include "ThingsInLast.inc"
OSDN Git Service
