MOV @IP+,PC
.ENDIF
- .IFNDEF RFROM1
-; https://forth-standard.org/standard/core/Rfrom
-; R> -- x R: x -- pop from return stack
- FORTHWORD "R>"
-RFROM1 SUB #2,PSP ; 1
- MOV TOS,0(PSP) ; 3
- MOV @RSP+,TOS ; 2
- MOV @IP+,PC ; 4
-
- .ENDIF
- .IFNDEF ZEROLESS
- FORTHWORD "0<"
-; https://forth-standard.org/standard/core/Zeroless
-; 0< n -- flag true if TOS negative
-ZEROLESS ADD TOS,TOS ;1 set carry if TOS negative
- SUBC TOS,TOS ;1 TOS=-1 if carry was clear
-EQUALTRUE XOR #-1,TOS ;1 TOS=-1 if carry was set
- MOV @IP+,PC ;
-
- .ENDIF
- .IFNDEF STOD
-; https://forth-standard.org/standard/core/StoD
-; S>D n -- d single -> double prec.
- FORTHWORD "S>D"
-STOD SUB #2,PSP
- MOV TOS,0(PSP)
- MOV #ZEROLESS,PC
-
- .ENDIF
- .IFNDEF DROP1
-; https://forth-standard.org/standard/core/DROP
-; DROP x -- drop top of stack
- FORTHWORD "DROP"
-DROP1 MOV @PSP+,TOS ; 2
- MOV @IP+,PC ; 4
-
- .ENDIF
- .IFNDEF QDUP
-; https://forth-standard.org/standard/core/DUP
-; DUP x -- x x duplicate top of stack
- FORTHWORD "DUP"
-QDUPNEXT SUB #2,PSP ; 2 push old TOS..
- MOV TOS,0(PSP) ; 3 ..onto stack
-QDUPEND MOV @IP+,PC ; 4
-
-; https://forth-standard.org/standard/core/qDUP
-; ?DUP x -- 0 | x x DUP if nonzero
- FORTHWORD "?DUP"
-QDUP CMP #0,TOS
- JNZ QDUPNEXT
- JZ QDUPEND
-
- .ENDIF
- .IFNDEF SWAP
-; https://forth-standard.org/standard/core/SWAP
-; SWAP x1 x2 -- x2 x1 swap top two items
- FORTHWORD "SWAP"
-SWAP MOV @PSP,W ; 2
- MOV TOS,0(PSP) ; 3
- MOV W,TOS ; 1
- MOV @IP+,PC ; 4
-
- .ENDIF
.IFNDEF OVER
;https://forth-standard.org/standard/core/OVER
;C OVER x1 x2 -- x1 x2 x1
MOV @IP+,PC ; 4
.ENDIF
- .IFNDEF NIP1
- FORTHWORD "NIP"
-; https://forth-standard.org/standard/core/NIP
-; NIP x1 x2 -- x2 Drop the first item below the top of stack
-NIP1 ADD #2,PSP ; 1
- MOV @IP+,PC ; 4
-
- .ENDIF
.IFNDEF ROT
;https://forth-standard.org/standard/core/ROT
;C ROT x1 x2 x3 -- x2 x3 x1
MOV @IP+,PC ; 4
.ENDIF
- .IFNDEF UMSLASHMOD
-;https://forth-standard.org/standard/core/UMDivMOD
-; UM/MOD udlo|udhi u1 -- r q unsigned 32/16->r16 q16
- FORTHWORD "UM/MOD"
-UMSLASHMOD PUSH #DROP ;3 as return address for MU/MOD
- MOV #MUSMOD,PC
-
- .ENDIF
- .IFNDEF FLOORED_DIVISION
- .IFNDEF SMSLASHREM
-;https://forth-standard.org/standard/core/SMDivREM
-;C SM/REM d1lo d1hi n2 -- n3 n4 symmetric signed div
- FORTHWORD "SM/REM"
-SMSLASHREM MOV TOS,S ;1 S=divisor
- MOV @PSP,T ;2 T=rem_sign
- CMP #0,TOS ;1 n2 >= 0 ?
- JGE d1u2SMSLASHREM ;2 yes
- XOR #-1,TOS ;1
- ADD #1,TOS ;1
-d1u2SMSLASHREM ; -- d1 u2
- CMP #0,0(PSP) ;3 d1hi >= 0 ?
- JGE ud1u2SMSLASHREM ;2 yes
- XOR #-1,2(PSP) ;4 d1lo
- XOR #-1,0(PSP) ;4 d1hi
- ADD #1,2(PSP) ;4 d1lo+1
- ADDC #0,0(PSP) ;4 d1hi+C
-ud1u2SMSLASHREM ; -- ud1 u2
- PUSHM #2,S ;4 PUSHM S,T
- CALL #MUSMOD
- MOV @PSP+,TOS
- POPM #2,S ;4 POPM T,S
- CMP #0,T ;1 -- ur uq T=rem_sign>=0?
- JGE SMSLASHREMnruq ;2 yes
- XOR #-1,0(PSP) ;3
- ADD #1,0(PSP) ;3
-SMSLASHREMnruq
- XOR S,T ;1 S=divisor T=quot_sign
- CMP #0,T ;1 -- nr uq T=quot_sign>=0?
- JGE SMSLASHREMnrnq ;2 yes
-NEGAT XOR #-1,TOS ;1
- ADD #1,TOS ;1
-SMSLASHREMnrnq ; -- nr nq S=divisor
- MOV @IP+,PC ;4 34 words
-
- .ENDIF
- .ELSE ; FLOORED_DIVISION
- .IFNDEF FMSLASHMOD
-;https://forth-standard.org/standard/core/FMDivMOD
-;C FM/MOD d1 n1 -- r q floored signed div'n
- FORTHWORD "FM/MOD"
-FMSLASHMOD MOV TOS,S ;1 S=divisor
- MOV @PSP,T ;2 T=rem_sign
- CMP #0,TOS ;1 n2 >= 0 ?
- JGE d1u2FMSLASHMOD ;2 yes
- XOR #-1,TOS ;1
- ADD #1,TOS ;1
-d1u2FMSLASHMOD ; -- d1 u2
- CMP #0,0(PSP) ;3 d1hi >= 0 ?
- JGE ud1u2FMSLASHMOD ;2 yes
- XOR #-1,2(PSP) ;4 d1lo
- XOR #-1,0(PSP) ;4 d1hi
- ADD #1,2(PSP) ;4 d1lo+1
- ADDC #0,0(PSP) ;4 d1hi+C
-ud1u2FMSLASHMOD ; -- ud1 u2
- PUSHM #2,S ;4 PUSHM S,T
- CALL #MUSMOD
- MOV @PSP+,TOS
- POPM #2,S ;4 POPM T,S
- CMP #0,T ;1 -- ur uq T=rem_sign>=0?
- JGE FMSLASHMODnruq ;2 yes
- XOR #-1,0(PSP) ;3
- ADD #1,0(PSP) ;3
-FMSLASHMODnruq
- XOR S,T ;1 S=divisor T=quot_sign
- CMP #0,T ;1 -- nr uq T=quot_sign>=0?
- JGE FMSLASHMODnrnq ;2 yes
-NEGAT XOR #-1,TOS ;1
- ADD #1,TOS ;1
-FMSLASHMODnrnq ; -- nr nq S=divisor
-
- CMP #0,0(PSP) ;
- JZ FMSLASHMODEND
- CMP #1,TOS ; quotient < 1 ?
- JGE FMSLASHMODEND ;
-QUOTLESSONE ADD S,0(PSP) ; add divisor to remainder
- SUB #1,TOS ; decrement quotient
-FMSLASHMODEND
- MOV @RSP+,IP
- MOV @IP+,PC ;
-
- .ENDIF
- .ENDIF
- .IFNDEF SLASH
-;https://forth-standard.org/standard/core/Div
-;C / n1 n2 -- n3 signed divide
- FORTHWORD "/"
-SLASH mDOCOL
- .word TOR,STOD,RFROM
- .IFNDEF FLOORED_DIVISION
- .word SMSLASHREM
- .ELSE
- .word FMSLASHMOD
- .ENDIF
- .word NIP,EXIT
-
- .ENDIF
- .IFNDEF CFETCH
-;https://forth-standard.org/standard/core/CFetch
-; C@ c-addr -- char fetch char from memory
- FORTHWORD "C@"
-CFETCH MOV.B @TOS,TOS ;2
- MOV @IP+,PC ;4
-
- .ENDIF
- .IFNDEF LESS
-; https://forth-standard.org/standard/core/OneMinus
-; 1- n1/u1 -- n2/u2 subtract 1 from TOS
- FORTHWORD "1-"
-ONEMINUS1 SUB #1,TOS
- MOV @IP+,PC
-
- .ENDIF
- .IFNDEF LESS
-;https://forth-standard.org/standard/core/less
-;C < n1 n2 -- flag test n1<n2, signed
- FORTHWORD "<"
-LESS SUB @PSP+,TOS ;1 TOS=n2-n1
- JZ LESSEND ;2 flag Z = 1
- JL TOSFALSE ;2 signed jump
-TOSTRUE MOV #-1,TOS ;1 flag Z = 0
-LESSEND MOV @IP+,PC ;4
-
-;https://forth-standard.org/standard/core/more
-;C > n1 n2 -- flag test n1>n2, signed
- FORTHWORD ">"
-MORE SUB @PSP+,TOS ;2 TOS=n2-n1
- JL TOSTRUE ;2 --> +5
-TOSFALSE AND #0,TOS ;1 flag Z = 1
- MOV @IP+,PC ;4
-
- .ENDIF
-
-; .IFNDEF IFF
-;; https://forth-standard.org/standard/core/IF
-;; IF -- IFadr initialize conditional forward branch
-; FORTHWORDIMM "IF" ; immediate
-;IFF SUB #2,PSP ;
-; MOV TOS,0(PSP) ;
-; MOV &DP,TOS ; -- HERE
-; ADD #4,&DP ; compile one word, reserve one word
-; MOV #QFBRAN,0(TOS) ; -- HERE compile QFBRAN
-; ADD #2,TOS ; -- HERE+2=IFadr
-; MOV @IP+,PC
-;
-; FORTHWORDIMM "ELSE" ; immediate
-;; https://forth-standard.org/standard/core/ELSE
-;; ELSE IFadr -- ELSEadr resolve forward IF branch, leave ELSEadr on stack
-;ELSS ADD #4,&DP ; make room to compile two words
-; MOV &DP,W ; W=HERE+4
-; MOV #BRAN,-4(W)
-; MOV W,0(TOS) ; HERE+4 ==> [IFadr]
-; SUB #2,W ; HERE+2
-; MOV W,TOS ; -- ELSEadr
-; MOV @IP+,PC
-;
-; FORTHWORDIMM "THEN" ; immediate
-;; https://forth-standard.org/standard/core/THEN
-;; THEN IFadr -- resolve forward branch
-;THEN MOV &DP,0(TOS) ; -- IFadr
-; MOV @PSP+,TOS ; --
-; MOV @IP+,PC
-; .ENDIF
-
- .IFNDEF TO
-; https://forth-standard.org/standard/core/TO
- FORTHWORD "TO"
-TO BIS #UF9,SR
- MOV @IP+,PC
-
- .ENDIF
.IFNDEF SPACE
;https://forth-standard.org/standard/core/SPACE
;C SPACE -- output a space
; DOUBLE word set
; ===============================================
.IFNDEF DDOT
+; ; https://forth-standard.org/standard/double/Dd
+; ; D. dlo dhi -- display d (signed)
+; FORTHWORD "D."
+; MOV TOS,S ; S will be pushed as sign
+; MOV #UDOT+10,PC ; U. + 10 = D.
+
; https://forth-standard.org/standard/double/Dd
; D. dlo dhi -- display d (signed)
FORTHWORD "D."
- MOV TOS,S ; S will be pushed as sign
- MOV #UDOT+10,PC ; U. + 10 = D.
+ MOV TOS,S ;1 S will be pushed as sign by UDOTNEXT
+ CMP #0,S ;1
+ JGE DDOTNEXT ;2
+ XOR #-1,0(PSP) ;4
+ XOR #-1,TOS ;1
+ ADD #1,0(PSP) ;4
+ ADDC #0,TOS ;1
+DDOTNEXT MOV #UDOTNEXT,PC ;3
.ENDIF
.IFNDEF TwoROT
; https://forth-standard.org/standard/double/DEqual
FORTHWORD "D="
-DEQUAL ADD #6,PSP ; 2
+ ADD #6,PSP ; 2
CMP TOS,-4(PSP) ; 3 ud1H - ud2H
MOV #0,TOS ; 1
JNZ DSETFLAG ; 2
.IFNDEF DMinus
; https://forth-standard.org/standard/double/DMinus
FORTHWORD "D-"
-DMINUS SUB @PSP+,2(PSP)
+ SUB @PSP+,2(PSP)
SUBC TOS,0(PSP)
MOV @PSP+,TOS
MOV @IP+,PC ; 4
.IFNDEF DMAX
; https://forth-standard.org/standard/double/DMAX
FORTHWORD "DMAX" ; -- d1 d2
-DMAX mDOCOL
+ mDOCOL
.word TWOOVER,TWOOVER ; -- d1 d2 d1 d2
.word DLESS,QFBRAN,DMAX1 ; -- d1 d2
.word TWOTOR,TWODROP,TWORFROM ; -- d2
.IFNDEF DMIN
; https://forth-standard.org/standard/double/DMIN
FORTHWORD "DMIN" ; -- d1 d2
-DMIN mDOCOL
+ mDOCOL
.word TWOOVER,TWOOVER ; -- d1 d2 d1 d2
.word DLESS,QFBRAN,DMIN1 ; -- d1 d2
.word TWODROP ; -- d1
.word EXIT
.ENDIF
+ .IFNDEF TO
+; https://forth-standard.org/standard/core/TO
+; TO name Run-time: ( x -- )
+; Assign the value x to named VALUE.
+ FORTHWORD "TO"
+ BIS #UF9,SR
+ MOV @IP+,PC
+
+ .ENDIF
.IFNDEF TwoVALUE
; https://forth-standard.org/standard/double/TwoVALUE
FORTHWORD "2VALUE" ; x1 x2 "<spaces>name" --
OSDN Git Service
