gemini - kennedy.gemi.dev

💾 Archived View for mirrors.apple2.org.za › archive › apple2.archive.umich.edu › apple2 › 8bit › pro… captured on 2024-12-17 at 23:11:15.
View Raw
More Information
-=-=-=-=-=-=-

	*******************************
	Start regular words 2
	*******************************

 

	
	Word "abs" - return absolute value of top stack item
	

 
WORD63 ASC 'abs '
 DW ABS
 
ABS JSR POPDATA
 TXA
 BPL GLOB_PUSH
 
NEGATSUB TYA
 EOR #$FF
 CLC
 ADC #01
 TAY
 TXA
 EOR #$FF
 ADC #00
 TAX
 
GLOB_PUSH JMP PUSHDATA
 

	
	Word "negate" - negate top value on stack
	

 
WORD64 ASC 'negate '
 DW NEGATE
 
NEGATE JSR POPDATA
 BRA NEGATSUB
 

	
	Word "<" - comparison operator
	

 
WORD65 ASC '< '
 DW LESSTHAN
 
LESSTHAN JSR POPDATA ; Fetch first signed integer
 STY PNTR
 STX PNTR+1
 
 JSR POPDATA ; Fetch second signed integer
 
 TXA ; Actual comparison done here
 EOR PNTR+1
 AND #$80
 BEQ :SAMESGN
 
 TXA
 BMI :TRUE
 BRA :FALSE
 
:SAMESGN CPX PNTR+1
 BNE :NOCHKLO
 CPY PNTR
:NOCHKLO BCC :TRUE
 
:FALSE LDY #$00
 LDX #$00
 JMP PUSHDATA
 
:TRUE LDY #$FF
 LDX #$FF
 JMP PUSHDATA
 

	
	Word ">" - comparison operator
	

 
WORD66 ASC '> '
 DW MORETHAN
 
MORETHAN JSR POPDATA ; Fetch first signed integer
 STY PNTR
 STX PNTR+1
 
 JSR POPDATA ; Fetch second signed integer
 
 TXA ; Actual comparison done here
 EOR PNTR+1
 AND #$80
 BEQ :SAME
 
 TXA
 BPL :TRUE
 BRA :FALSE
 
:SAME CPX PNTR+1
 BNE :NOCHKLO
 CPY PNTR
:NOCHKLO BCC :FALSE
 BEQ :FALSE
 
:TRUE LDY #$FF
 LDX #$FF
 JMP PUSHDATA
 
:FALSE LDY #$00
 LDX #$00
 JMP PUSHDATA
 

	
	Word "=" - comparison operator
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD67 ASC '= '
 DW EQUAL
 
EQUAL LDA DATITEMS ; Make sure there's at least
 CMP #02 ;   two items on stack
 BCC :ERROR
 
 LDY DATSTACK
 LDA DATAAREA+1,Y
 CMP DATAAREA+3,Y
 BNE :FALSE
 LDA DATAAREA+2,Y
 CMP DATAAREA+4,Y
 BNE :FALSE
 
 LDA #$FF
 HEX 2C
:FALSE LDA #00
 STA DATAAREA+3,Y
 STA DATAAREA+4,Y
 
 INY ; Adjust data stack pointer
 INY
 STY DATSTACK
 
:SKIPINC DEC DATITEMS ; Adjust data items pointer
 RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "<>" - comparison operator
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD68 ASC '<> '
 DW NOTEQUAL
 
NOTEQUAL LDA DATITEMS ; Make sure there's at least
 CMP #02 ;   two items on stack
 BCC :ERROR
 
 LDY DATSTACK
 LDA DATAAREA+1,Y
 CMP DATAAREA+3,Y
 BNE :TRUE
 LDA DATAAREA+2,Y
 CMP DATAAREA+4,Y
 BNE :TRUE
 
 LDA #00
 HEX 2C
:TRUE LDA #$FF
 STA DATAAREA+3,Y
 STA DATAAREA+4,Y
 
 INY ; Adjust data stack pointer
 INY
 STY DATSTACK
 
:SKIPINC DEC DATITEMS ; Adjust data items pointer
 RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "U<" - unsigned compare
	

 
WORD69 ASC 'u< '
 DW ULESS
 
ULESS JSR POPDATA
 STY PNTR
 STX PNTR+1
 
 JSR POPDATA
 CPX PNTR+1
 BCC :TRUE
 BEQ :CHKLOW
 BCS :FALSE
 
:CHKLOW CPY PNTR
 BCC :TRUE
 
:FALSE LDY #00
 LDX #00
 JMP PUSHDATA
 
:TRUE LDY #$FF
 LDX #$FF
 JMP PUSHDATA
 

	
	Word "0=" - compare to zero
	

 
WORD70 ASC '0= '
 DW ZEROEQUA
 
ZEROEQUA JSR POPDATA
 TXA
 BNE :FALSE
 TYA
 BNE :FALSE
 LDA #$FF
 HEX 2C ; BIT trick
:FALSE LDA #00
 TAX
 TAY
 JMP PUSHDATA
 

	
	Word "0<" - compare negative
	

 
WORD71 ASC '0< '
 DW NEGATIVE
 
NEGATIVE JSR POPDATA
 TXA
 BPL :FALSE
 LDA #$FF
 HEX 2C ; BIT trick
:FALSE LDA #00
 TAX
 TAY
 JMP PUSHDATA
 

	
	Word "0>" - check positive
	

 
WORD72 ASC '0> '
 DW POSITIVE
 
POSITIVE JSR POPDATA
 TXA
 BNE :NOTZERO
 TYA
 BNE :NOTZERO
 BRA :FALSE
 
:NOTZERO TXA
 BMI :FALSE
 LDA #$FF
 HEX 2C ; BIT trick
:FALSE LDA #00
 TAX
 TAY
 JMP PUSHDATA
 

	
	Word "false" - push 0 on stack
	

 
WORD73 ASC 'false '
 DW FALSE
 
FALSE LDY #$00
 LDX #$00
 JMP PUSHDATA
 

	
	Word "true" - push -1 on stack
	

 
WORD74 ASC 'true '
 DW TRUE
 
TRUE LDY #$FF
 LDX #$FF
 JMP PUSHDATA
 

	
	Word "1+" - increment top item on stack
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD75 ASC '1+ '
 DW ONEPLUS
 
ONEPLUS LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to increment
 
 LDX DATSTACK
 INC DATAAREA+1,X
 BNE :SKIPINC
 INC DATAAREA+2,X
:SKIPINC RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "1-" - decrement top item on stack
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD76 ASC '1- '
 DW ONEMINUS
 
ONEMINUS LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to decrement
 
 LDX DATSTACK
 LDA DATAAREA+1,X
 BNE :SKIPDEC
 DEC DATAAREA+2,X
:SKIPDEC DEC DATAAREA+1,X
 RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "2+" - increment top item on stack by 2
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD77 ASC '2+ '
 DW TWOPLUS
 
TWOPLUS LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to increment
 
 LDX DATSTACK
 LDA DATAAREA+1,X
 INC
 INC
 STA DATAAREA+1,X
 BNE :SKIPINC
 INC DATAAREA+2,X
:SKIPINC RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "2-" - decrement top item on stack by 2
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD78 ASC '2- '
 DW TWOMINUS
 
TWOMINUS LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to decrement
 
 LDX DATSTACK
 LDA DATAAREA+1,X
 SEC
 SBC #02
 STA DATAAREA+1,X
 BCS :SKIPDEC
 DEC DATAAREA+2,X
:SKIPDEC RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "2*" - do arithmetic shift left on top stack item
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD79 ASC '2* '
 DW TWOMULT
 
TWOMULT LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to multiply
 
 LDX DATSTACK
 ASL DATAAREA+1,X
 ROL DATAAREA+2,X
 RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "2/" - do logical shift right on top stack item
	
	Note: bypasses POPDATA, PUSHDATA for speed
	

 
WORD80 ASC '2/ '
 DW TWODIV
 
TWODIV LDA DATITEMS ; Make sure there's something on stack
 BEQ :ERROR ;   to multiply
 
 LDX DATSTACK
 LSR DATAAREA+2,X
 ROR DATAAREA+1,X
 RTS
 
:ERROR LDA #04 ; "Data stack underflow"
 JMP PRTERR
 

	
	Word "b.and" - performs binary AND
	

 
WORD81 ASC 'b.and '
 DW B_AND
 
B_AND JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR POPDATA
 TYA
 AND PNTR
 TAY
 TXA
 AND PNTR+1
 TAX
 JMP PUSHDATA
 

	
	Word "b.or" - performs binary OR
	

 
WORD82 ASC 'b.or '
 DW B_OR
 
B_OR JSR POPDATA
 STY PNTR
 STX PNTR+1
 JSR POPDATA
 TYA
 ORA PNTR
 TAY
 TXA
 ORA PNTR+1
 TAX
 JMP PUSHDATA
 

	
	Word "b.clr" - performs twos complement then AND
	

 
WORD83 ASC 'b.clr '
 DW B_CLR
 
B_CLR JSR POPDATA
 TYA
 EOR #$FF
 STA PNTR
 TXA
 EOR #$FF
 STA PNTR+1
 JSR POPDATA
 TYA
 AND PNTR
 TAY
 TXA
 AND PNTR+1
 TAX
 JMP PUSHDATA
 

	
	Word "page" - Clears screen
	

 
WORD84 ASC 'page '
 DW HOME
 
HOME LDA #" " ; Damn $C300 outputs whatever
 JSR $C300 ;  is in accumulator
 STZ CH
 RTS
 

	
	Word "cv" - Sets cursor vertical position
	

 
WORD85 ASC 'cv '
 DW SETCV
 
SETCV JSR POPDATA
 STY CV
 TYA
 JMP BASCALC
 

	
	Word "ch" - Sets cursor horizontal position
	

 
WORD86 ASC 'ch '
 DW SETCH
 
SETCH JSR POPDATA
 STY CH
 RTS
 

	
	Word "key" - Wait for a key
	

 
WORD87 ASC 'key '
 DW KEY
 
KEY JSR GETKEY
 TAY
 LDX #00
 JMP PUSHDATA
 

	
	Word "key?" - Check for keypress
	

 
WORD88 ASC 'key? '
 DW KEY?
 
KEY? BIT KYBD
 BMI :TRUE
 
 LDA #00 ; Speed not crucial here
 HEX 2C ; BIT trick
:TRUE LDA #$FF
 TAY
 TAX
 JMP PUSHDATA
 

	
	Word "expect" - awaits characters from keyboard
	

 
WORD89 ASC 'expect '
 DW EXPECT
 
EXPECT JSR POPDATA ; Get number of characters max
 STY PNTR2
 STX PNTR2+1
 
 JSR POPDATA ; Get address to store characters
 STY PNTR
 STX PNTR+1
 
 STZ SPANVAL ; Current number of keys
 STZ SPANVAL+1
 
:LOOP JSR GETKEY ; Get a key
 
 CMP #$08
 BEQ :BACK
 CMP #$7F
 BNE :NOTBACK
:BACK LDA SPANVAL ; Make sure we have characters to erase
 ORA SPANVAL+1
 BEQ :LOOP
 LDA SPANVAL ; Decrement number of characters
 BNE :SKIPDEC
 DEC SPANVAL+1
:SKIPDEC DEC SPANVAL
 LDA #$08 ; Erase previous character on screen
 JSR COUT
 LDA #' '
 JSR COUT
 LDA #$08
 JSR COUT
 BRA :LOOP
 
:NOTBACK CMP #$0D
 BNE :NOTRETN
 RTS
 
:NOTRETN LDY SPANVAL ; Make sure we haven't reached
 CPY PNTR2 ;   maximum # of characters yet
 BNE :OK
 LDY SPANVAL+1
 CPY PNTR2+1
 BEQ :LOOP
 
:OK TAY ; Store character at address
 LDA PNTR
 CLC
 ADC SPANVAL
 STA PNTR3
 LDA PNTR+1
 ADC SPANVAL+1
 STA PNTR3+1
 TYA
 STA (PNTR3)
 
 JSR COUT ; Echo key to screen
 
 INC SPANVAL ; Increment character count
 BNE :SKIPINC
 INC SPANVAL+1
 
:SKIPINC BRA :LOOP
 

	
	Word "span" - returns number of characters received by expect
	

 
WORD90 ASC 'span '
 DW SPAN
 
SPAN LDY SPANVAL
 LDX SPANVAL+1
 JMP PUSHDATA
 
SPANVAL HEX 0000
 

	
	Word "emit" - outputs character value on stack, low byte
	

 
WORD91 ASC 'emit '
 DW EMIT
 
EMIT JSR POPDATA
 TYA
 JMP COUT
 

	
	Word "space" - outputs space
	

 
WORD92 ASC 'space '
 DW SPACE
 
SPACE LDA #' '
PRT JMP COUT
 

	
	Word "spaces" - outputs multiples spaces
	

 
WORD93 ASC 'spaces '
 DW SPACES
 
SPACES JSR POPDATA
 STY PNTR
 STX PNTR+1
 
 LDA #" "
 
:LOOP LDX PNTR
 BNE :SKIPDEC
 DEC PNTR+1
 LDX PNTR+1
 CPX #$FF
 BEQ :FINIS
:SKIPDEC DEC PNTR
 JSR COUT
 BRA :LOOP
 
:FINIS RTS
 

	
	Word "cr" - outputs return
	

 
WORD94 ASC 'cr '
 DW CR
 
CR LDA #$8D
 BRA PRT
 

	
	Word "fill" - fills memory with value
	

 
WORD95 ASC 'fill '
 DW FILL
 
FILL JSR POPDATA ; Fetch fill value
 STY TEMP
 
FILL2 JSR POPDATA ; Fetch fill counter
 PHY
 PHX
 JSR POPDATA ; Fetch fill address
 STY PNTR
 STX PNTR+1
 
 LDA TEMP ; Set up fill value
 
 PLX ; Check if any pages
 BEQ :NOPAGE
 
 LDY #00 ; Fill in pages
:LOOP STA (PNTR),Y
 INY
 BNE :LOOP
 INC PNTR+1
 DEX
 BNE :LOOP
 
:NOPAGE PLX ; Fill in fractional pages
 BEQ :FINIS
 LDY #00
:LOOP2 STA (PNTR),Y
 INY
 DEX
 BNE :LOOP2
 
:FINIS RTS
 

	
	Word "erase" - fills memory with zeros
	

 
WORD96 ASC 'erase '
 DW ERASE
 
ERASE LDA #00
 STA TEMP
 JMP FILL2
 

	
	Word "close" - closes all open files
	

 
WORD97 ASC 'close '
 DW CLOSE
 
CLOSE JMP CLOSFILE
 

	
	Word "bye" - exits Qforth
	

 
WORD98 ASC 'bye '
 DW BYE
 
BYE JSR MLI
 DFB $65
 DW :PARMS
 
:PARMS DFB 4
 HEX 00
 HEX 0000
 HEX 00
 HEX 0000
 

	*******************************
	End regular words 2
	*******************************