[comp.binaries.apple2] QF.REGWRDS.[D1.S

tm@polari.UUCP (Toshi Morita) (08/01/90)

Include file for Qforth:


********************************
* Start regular words 1
********************************

*
* Word "execute" - call machine-language subroutine
*

WORD31 ASC 'execute '
 DW EXECUTE

EXECUTE JSR POPDATA
 STY PNTR
 STX PNTR+1

 LDA AREGVAL
 LDX XREGVAL
 LDY YREGVAL
 JMP (PNTR)

*
* Word "areg" - push location of A-register variable
*

WORD32 ASC 'areg '
 DW AREG

AREG LDY #AREGVAL
 LDX #/AREGVAL
 JMP PUSHDATA

AREGVAL HEX 00

*
* Word "xreg" - push location of X-register variable
*

WORD33 ASC 'xreg '
 DW XREG

XREG LDY #XREGVAL
 LDX #/XREGVAL
 JMP PUSHDATA

XREGVAL HEX 00

*
* Word "yreg" - push location of Y-register variable
*

WORD34 ASC 'yreg '
 DW YREG

YREG LDY #YREGVAL
 LDX #/YREGVAL
 JMP PUSHDATA

YREGVAL HEX 00

*
* Word "words" - List out all defined words
*

WORD35 ASC 'words '
 DW WORDS

WORDS JMP LISTWRDS

*
* Word ".s" - dump out data stack
*

WORD36 ASC '.s '
 DW DOT_S

DOT_S LDA DATITEMS
 BEQ :EMPTY

 STA PNTR
 LDA #$FF
 STA PNTR+1

:LOOP LDY PNTR+1
 LDA DATAAREA,Y
 TAX
 DEY
 LDA DATAAREA,Y
 DEY
 STY PNTR+1
 TAY
 JSR PRTSIGND
 DEC PNTR
 BNE :LOOP
 RTS

:EMPTY JSR MSGOUT
 HEX 8D
 ASC "Data stack empty",8D00
 RTS

*
* Subroutine to print out number in signed format
*
* Called by: DOT_S, DOT_R, DOT
*

PRTSIGND TXA
 BPL :POSITIV

 LDA #"-"
 JSR COUT
 TYA
 EOR #$FF
 CLC
 ADC #01
 TAY
 TXA
 EOR #$FF
 ADC #00
 TAX

:POSITIV JMP PRTDEC

*
* Word ".r" - dump out data stack
*

WORD37 ASC '.r '
 DW DOT_R

DOT_R LDA RETITEMS
 BEQ :EMPTY

 STA PNTR
 LDA #$FF
 STA PNTR+1

:LOOP LDY PNTR+1
 LDA RETNAREA,Y
 TAX
 DEY
 LDA RETNAREA,Y
 DEY
 STY PNTR+1
 TAY
 JSR PRTSIGND
 DEC PNTR
 BNE :LOOP
 RTS

:EMPTY JSR MSGOUT
 HEX 8D
 ASC "Return stack empty",8D00
 RTS

*
* Word "!" - Store number at pointer
*

WORD38 ASC '! '
 DW EXCLAM

EXCLAM JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR POPDATA
 TYA
 STA (PNTR)
 LDY #$01
 TXA
 STA (PNTR),Y
 RTS

*
* Word "@" - Fetch number at pointer
*

WORD39 ASC '@ '
 DW ATSIGN

ATSIGN JSR POPDATA
 STY PNTR
 STX PNTR+1
 LDY #$01
 LDA (PNTR),Y
 TAX
 LDA (PNTR)
 TAY
 JMP PUSHDATA

*
* Word "c!" - Store byte at pointer
*

WORD40 ASC 'c! '
 DW CSTORE

CSTORE JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR POPDATA
 TYA
 STA (PNTR)
 RTS

*
* Word "c@" - Fetch byte at pointer
*

WORD41 ASC 'c@ '
 DW CFETCH

CFETCH JSR POPDATA
 STY PNTR
 STX PNTR+1
 LDA (PNTR)
 TAY
 LDX #$00
 JMP PUSHDATA

*
* Word "+!" - Add given value to contents of given address
*

WORD42 ASC '+! '
 DW PLUSQMRK

PLUSQMRK JSR POPDATA ; Fetch address
 STY PNTR
 STX PNTR+1

 JSR POPDATA ; Fetch value to add

 TYA
 CLC
 ADC (PNTR)
 STA (PNTR)
 TXA
 LDY #01
 ADC (PNTR),Y
 STA (PNTR),Y

 RTS

*
* Word "?" - Print contents of address
*

WORD43 ASC '? '
 DW QMARK

QMARK JSR POPDATA
 STY PNTR
 STX PNTR+1
 LDY #$01
 LDA (PNTR),Y
 TAX
 LDA (PNTR)
 TAY
 JMP PRTSIGND

*
* Word "dup" - Duplicate top number on stack
*

WORD44 ASC 'dup '
 DW DUP

DUP JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR PUSHDATA
 LDY PNTR
 LDX PNTR+1
 JMP PUSHDATA

*
* Word "drop" - Discard top item on stack
*

WORD45 ASC 'drop '
 DW DROP

DROP JMP POPDATA

*
* Word "swap" - Reverses top two stack items
*

WORD46 ASC 'swap '
 DW SWAP

SWAP JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR POPDATA
 STY PNTR2
 STX PNTR2+1
 LDY PNTR
 LDX PNTR+1
 JSR PUSHDATA
 LDY PNTR2
 LDX PNTR2+1
 JMP PUSHDATA

*
* Word "over" - Makes a copy of the 2nd item
*                 and pushes it to top
*

WORD47 ASC 'over '
 DW OVER

OVER JSR POPDATA
 STY PNTR2
 STX PNTR2+1
 JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR PUSHDATA
 LDY PNTR2
 LDX PNTR2+1
 JSR PUSHDATA
 LDY PNTR
 LDX PNTR+1
 JMP PUSHDATA

*
* Word "rot" - Rotate the third item to top
*

WORD48 ASC 'rot '
 DW ROT

ROT JSR POPDATA
 STY PNTR3
 STX PNTR3+1
 JSR POPDATA
 STY PNTR2
 STX PNTR2+1
 JSR POPDATA
 STY PNTR
 STX PNTR+1

 LDY PNTR2
 LDX PNTR2+1
 JSR PUSHDATA
 LDY PNTR3
 LDX PNTR3+1
 JSR PUSHDATA
 LDY PNTR
 LDX PNTR+1
 JMP PUSHDATA

*
* Word ">r" - Moves value from data stack to return stack
*

WORD49 ASC '>r '
 DW TOR

TOR JSR POPDATA
 JMP PUSHRETN

*
* Word "r>" - Moves value from return stack to data stack
*

WORD50 ASC 'r> '
 DW RFROM

RFROM JSR POPRETN
 JMP PUSHDATA

*
* Word "r@" - Copy value from return stack to data stack
*

WORD51 ASC 'r@ '
 DW RFETCH

RFETCH JSR POPRETN
 JSR PUSHRETN
 JMP PUSHDATA

*
* Word "." - Print out top number on stack as signed integer
*

WORD52 ASC '. '
 DW DOT

DOT JSR POPDATA
 JMP PRTSIGND

*
* Word "u." - print out top number on stack as unsigned int
*

WORD53 ASC 'u. '
 DW U_DOT

U_DOT JSR POPDATA
 JMP PRTDEC

*
* Word "not" - do logical NOT on top number
*
* Note: Bypasses POPDATA, PUSHDATA for speed
*

WORD54 ASC 'not '
 DW NOT

NOT LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to negate

 LDY DATSTACK
 LDA DATAAREA+1,Y
 ORA DATAAREA+2,Y
 BNE :FALSE
 LDA #$FF
 HEX 2C ; BIT trick
:FALSE LDA #00
 STA DATAAREA+1,Y
 STA DATAAREA+2,Y
 RTS

:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR

*
* Word "and" - perform logical AND on top two stack items
*

WORD55 ASC 'and '
 DW AND

AND JSR POPDATA
 STY TEMP
 TXA
 ORA TEMP
 STA TEMP
 BEQ :FALSE

 JSR POPDATA
 STY TEMP
 TXA
 ORA TEMP
 STA TEMP
 BEQ :FALSE2

 LDX #$FF
 LDY #$FF
 JMP PUSHDATA

:FALSE JSR POPDATA
:FALSE2 LDX #$00
 LDY #$00
 JMP PUSHDATA

*
* Word "or" - Perform logical OR on top two stack items
*

WORD56 ASC 'or '
 DW OR

OR JSR POPDATA
 STY TEMP
 TXA
 ORA TEMP
 STA TEMP
 JSR POPDATA
 TYA
 ORA TEMP
 STA TEMP
 TXA
 ORA TEMP
 STA TEMP
 BNE :TRUE
 LDX #$00
 LDY #$00
 JMP PUSHDATA

:TRUE LDX #$FF
 LDY #$FF
 JMP PUSHDATA

*
* Word "xor" - Do logical XOR on top two stack items
*

WORD57 ASC 'xor '
 DW XOR

XOR JSR POPDATA
 STY TEMP
 TXA
 ORA TEMP
 BEQ :ZERO
 LDA #$FF
 HEX 2C
:ZERO LDA #$00
 STA TEMP

 JSR POPDATA
 STY TEMP2
 TXA
 ORA TEMP2
 BEQ :ZERO2
 LDA #$FF
 HEX 2C
:ZERO2 LDA #$00
 EOR TEMP
 TAY
 TAX
 JMP PUSHDATA

*
* Word "+" - Add two numbers on stack,
*            leave result on stack
*

WORD58 ASC '+ '
 DW ADD

ADD JSR POPDATA
 STY TEMP
 STX TEMP+1
 JSR POPDATA
 TYA
 CLC
 ADC TEMP
 TAY
 TXA
 ADC TEMP+1
 TAX
 JMP PUSHDATA

*
* Word "-" - Subtract top word from next-top word,
*            leave result on stack
*

WORD59 ASC '- '
 DW MINUS

MINUS JSR POPDATA
 STY TEMP
 STX TEMP+1
 JSR POPDATA
 TYA
 SEC
 SBC TEMP
 TAY
 TXA
 SBC TEMP+1
 TAX
 JMP PUSHDATA

*
* Word "*" - Multiply two numbers on stack,
*            leave result on stack (signed)
*

WORD60 ASC '* '
 DW ASTERISK

ASTERISK JSR GETNUMS ; Fetch two signed integers

 STZ TEMP
 LDY #00

 LDX #16
:LOOP LSR PNTR+1
 ROR PNTR
 BCC :SKIPADD
 TYA
 CLC
 ADC PNTR2
 TAY
 LDA PNTR2+1
 ADC TEMP
 STA TEMP
:SKIPADD ASL PNTR2
 ROL PNTR2+1
 DEX
 BNE :LOOP

 LDX TEMP
 BIT TEMP2 ; Check for negative
 BPL :NOTNEG

 TYA
 EOR #$FF
 CLC
 ADC #01
 TAY
 TXA
 EOR #$FF
 ADC #00
 TAX

:NOTNEG JMP PUSHDATA

*
* GETNUMS - subroutine for fetching two signed numbers
*             (called by ASTERISK, SLASH, MOD)
*

GETNUMS JSR POPDATA ; Get first number and store sign
 TXA
 BPL :POS

 LDA #$FF
 STA TEMP2
 TYA
 EOR #$FF
 CLC
 ADC #01
 STA PNTR
 TXA
 EOR #$FF
 ADC #00
 STA PNTR+1
 BRA :MERGE

:POS STZ TEMP2
 STY PNTR
 STX PNTR+1

:MERGE JSR POPDATA ; Get second number and store sign
 TXA
 BPL :POS2

 LDA TEMP2
 EOR #$FF ; Invert high bit of TEMP2
 STA TEMP2

 TYA
 EOR #$FF
 CLC
 ADC #01
 STA PNTR2
 TXA
 EOR #$FF
 ADC #00
 STA PNTR2+1
 RTS

:POS2 STY PNTR2
 STX PNTR2+1
 RTS

*
* Word "/" - Divide two numbers on stack,
*            leave result on stack
*

WORD61 ASC '/ '
 DW SLASH

SLASH JSR GETNUMS

 JSR DIVSUB

 LDY PNTR2
 LDX PNTR2+1
 BIT TEMP2
 BPL :POSITIV

 TYA
 EOR #$FF
 CLC
 ADC #01
 TAY
 TXA
 EOR #$FF
 ADC #00
 TAX

:POSITIV JMP PUSHDATA

*
* DIVSUB - subroutine for division
*            (called by SLASH, MOD)
*

DIVSUB LDA PNTR
 ORA PNTR+1
 BEQ :ERROR
 STZ PNTR3
 STZ PNTR3+1

 LDX #16
:LOOP ASL PNTR2
 ROL PNTR2+1
 ROL PNTR3
 ROL PNTR3+1
 LDA PNTR3
 SEC
 SBC PNTR
 TAY
 LDA PNTR3+1
 SBC PNTR+1
 BCC :NOGOOD
 STA PNTR3+1
 STY PNTR3
 LDA PNTR2
 ORA #01
 STA PNTR2
:NOGOOD DEX
 BNE :LOOP

 RTS

:ERROR LDA #$0E ; "Division by zero"
 JMP PRTERR

*
* Word "mod" - Divide two numbers on stack,
*              leave modulus on stack
*

WORD62 ASC 'mod '
 DW MOD

MOD JSR POPDATA ; Get first number and ignore sign
 TXA
 BPL :POS

 TYA
 EOR #$FF
 CLC
 ADC #01
 STA PNTR
 TXA
 EOR #$FF
 ADC #00
 STA PNTR+1
 BRA :MERGE

:POS STY PNTR
 STX PNTR+1

:MERGE JSR POPDATA ; Get second number and store sign
 TXA
 BPL :POS2

 LDA #$FF
 STA TEMP2
 TYA
 EOR #$FF
 CLC
 ADC #01
 STA PNTR2
 TXA
 EOR #$FF
 ADC #00
 STA PNTR2+1
 BRA :MERGE2

:POS2 STZ TEMP2
 STY PNTR2
 STX PNTR2+1

:MERGE2 JSR DIVSUB

 LDY PNTR3 ; Set sign of modulus to same as dividend
 LDX PNTR3+1
 BIT TEMP2
 BPL :POSITIV

 TYA
 EOR #$FF
 CLC
 ADC #01
 TAY
 TXA
 EOR #$FF
 ADC #00
 TAX

:POSITIV JMP PUSHDATA

********************************
* End regular words 1
********************************