Set of Apple II Hard Drive Images

home *** CD-ROM | disk | FTP | other *** search

/ Set of Apple II Hard Drive Images / hard.hdv / HARD / LISTINGS / MAF2.SRC < prev next >

Wrap

Text File | 1995-07-06 | 24.5 KB | 1,644 lines | [04] ASCII Text (0x0000)

* Mad Apple Forth * Part 2 * Originally started at 0xE6D REL DAT DSK MAF.2 N = $01 XSAVE = $EB DATASTK = $0300 * Externals.... PUSH EXT ; = $094D PUT EXT ; = $094F NEXT EXT ; = $0956 SETUP EXT ; = $0981 POPTWO EXT ; = $0A91 POP EXT ; = $0A93 H0BBF EXT ; = $0BBF LINK1 EXT ; = $0E56 ; link to previous file * Local.. CH = $24 CV = $25 UP = $FE KEY = $C000 STROBE = $C010 VTAB = $FC22 VTABZ = $FC24 CLREOP = $FC42 HOME = $FC58 SCROLL = $FC70 CLREOL = $FC9C HFC9E = $FC9E RDKEY = $FD0C HFD35 = $FD35 CROUT = $FD8E COUT = $FDED HFE80 = $FE80 HFE84 = $FE84 ******************************** * * * SVR&P * * * ******************************** RPSAVE ENT DB $FD ; $1FD... (room for 1 16b) SPSAVE ENT DB $C7 ; $3C7... H0E6D DA LINK1 HEX 85 DCI 'SVR&P' SVRP ENT ; ( n --- ) DA *+2 ; number of stack items LDA #2 JSR SETUP ; put one stack item in N STX XSAVE ASL N ; first byte (lo): 2* TXA ; X to A: SP CLC ADC N ; add N to SP STA SPSAVE ; save.. TSX ; stack ptr to X STY $DE ; zero (?) to Applesoft ERR H0E8A STX RPSAVE ; put RP in e6b LDX XSAVE ; restore X JMP NEXT ******************************** * * * SVRP- * * * ******************************** H0E92 DA H0E6D HEX 85 DCI 'SVRP-' SVRPSUB ENT ; no args DA *+2 ; leaves room for 1 16b val ; on SP restore STX XSAVE ; save X STX SPSAVE ; save SP TSX ; get RP DEX ; room for one DEX JMP H0E8A ; share code ******************************** * * * RSR&P * * * ******************************** H0EA7 DA H0E92 HEX 85 DCI 'RSR&P' RSRP ENT DA *+2 LDX RPSAVE ; restore RP TXS LDX SPSAVE ; restore SP JMP NEXT ******************************** * * * 0= * * * ******************************** H0EBB DA H0EA7 HEX 82 DCI '0=' ZEQUALS ENT DA *+2 LDA DATASTK,X ORA DATASTK+1,X BNE H0ECB INY H0ECB TYA H0ECC PHA LDA #0 JMP PUT ******************************** * * * 0< * * * ******************************** H0ED2 DA H0EBB HEX 82 DCI '0<' ZLESS ENT DA *+2 LDA DATASTK+1,X ; sign is b8 ASL ; sign to carry TYA ; zero A (carry unaffected) ROR ; roll carry bit to bit 0 JMP H0ECC ; put A as low byte ******************************** * * * 0> * * * ******************************** H0EE2 DA H0ED2 HEX 82 DCI '0>' ZGREATER ENT DA *+2 LDA DATASTK+1,X ; hibyte BMI H0EF5 ; if neg, exit(0) ORA DATASTK,X BEQ H0EF5 SEC H0EF5 TYA ROR JMP H0ECC ******************************** * * * 2^ * * * ******************************** H0EFA DA H0EE2 HEX 82 DCI '2^' TWOPWR ENT ; used? DA *+2 LDA DATASTK,X TAY LDA #$00 SEC H0F09 ROL DEY BPL H0F09 JMP H0ECC *=============================== * Unsigned comparison for equality H0F10 LDA DATASTK+1,X ; bottom stack item lo CMP DATASTK+3,X ; second item lo BNE H0F21 ; equality LDA DATASTK,X ; bottom stack item hi CMP DATASTK+2,X ; second item hi BNE H0F21 ; equality INY ; 1 is true H0F21 TYA ; put Y (t/f) in accum RTS ******************************** * * * = * * * ******************************** H0F23 DA H0EFA HEX 81 ASC "=" EQUALS ENT DA *+2 JSR H0F10 H0F2C INX INX JMP H0ECC ******************************** * * * <> * * * ******************************** H0F31 DA H0F23 HEX 82 DCI '<>' NOTEQ ENT DA *+2 JSR H0F10 H0F3B EOR #1 ; invert flag JMP H0F2C *=============================== * Signed comparison * really is "<" code H0F40 LDA DATASTK+2,X ; second item lo SEC SBC DATASTK,X ; subtract first item lo LDA DATASTK+3,X ; second item hi SBC DATASTK+1,X ; first item hi H0F4D BVC H0F51 ; overflow EOR #$80 ; sign-bit wrong: change H0F51 BPL H0F54 ; exit(0) if result positive INY H0F54 TYA RTS ******************************** * * * < * * * ******************************** H0F56 DA H0F31 HEX 81 ASC "<" LESSTHAN ENT DA *+2 JSR H0F40 JMP H0F2C ******************************** * * * >= * * * ******************************** H0F62 DA H0F56 HEX 82 DCI '>=' GRTROREQ ENT DA *+2 JSR H0F40 JMP H0F3B ******************************** * * * MAX * * * ******************************** H0F6F DA H0F62 HEX 83 DCI 'MAX' MAX ENT DA *+2 JSR H0F40 H0F7A BNE H0F7F JMP POP H0F7F LDA DATASTK,X PHA LDA DATASTK+1,X H0F86 INX INX JMP PUT *=============================== * Signed comparison #2 * really code for ">" H0F8B LDA DATASTK,X ; first item lo SEC SBC DATASTK+2,X ; subtract 2nd item lo LDA DATASTK+1,X ; get first item hi SBC DATASTK+3,X ; subtract 2nd item hi JMP H0F4D ; steal code: other signed cmp. ******************************** * * * > * * * ******************************** H0F9B DA H0F6F HEX 81 ASC ">" GREATER ENT DA *+2 JSR H0F8B JMP H0F2C ******************************** * * * =< * * * ******************************** H0FA7 DA H0F9B HEX 82 DCI '=<' EQORLESS ENT DA *+2 JSR H0F8B JMP H0F3B ******************************** * * * MIN * * * ******************************** H0FB4 DA H0FA7 HEX 83 DCI 'MIN' MIN ENT DA *+2 JSR H0F8B JMP H0F7A ******************************** * * * U< * * * ******************************** H0FC2 DA H0FB4 HEX 82 DCI 'U<' ULESS ENT DA *+2 LDA DATASTK+2,X CMP DATASTK,X LDA DATASTK+3,X SBC DATASTK+1,X BCS H0FD8 INY H0FD8 TYA JMP H0F2C ******************************** * * * + * * * ******************************** H0FDC DA H0FC2 HEX 81 ASC "+" PLUS ENT DA *+2 CLC LDA DATASTK,X ADC DATASTK+2,X STA DATASTK+2,X LDA DATASTK+1,X ADC DATASTK+3,X STA DATASTK+3,X JMP POP ******************************** * * * - * * * ******************************** H0FF8 DA H0FDC HEX 81 ASC "-" MINUS ENT DA *+2 SEC LDA DATASTK+2,X SBC DATASTK,X STA DATASTK+2,X LDA DATASTK+3,X SBC DATASTK+1,X STA DATASTK+3,X JMP POP ******************************** * * * NEGATE * * * ******************************** H1014 DA H0FF8 HEX 86 DCI 'NEGATE' NEGATE ENT DA *+2 H101F SEC ; borrowed by ABS H1020 TYA SBC DATASTK,X STA DATASTK,X TYA SBC DATASTK+1,X STA DATASTK+1,X JMP NEXT ******************************** * * * ABS * * * ******************************** H1031 DA H1014 HEX 83 DCI 'ABS' ABS ENT DA *+2 LDA DATASTK+1,X BPL H1041 JMP H101F H1041 JMP NEXT ******************************** * * * D+ * * * ******************************** H1044 DA H1031 HEX 82 DCI 'D+' DPLUS ENT DA *+2 CLC LDA DATASTK+2,X ADC DATASTK+6,X STA DATASTK+6,X LDA DATASTK+3,X ADC DATASTK+7,X STA DATASTK+7,X LDA DATASTK,X ADC DATASTK+4,X STA DATASTK+4,X LDA DATASTK+1,X ADC DATASTK+5,X STA DATASTK+5,X JMP POPTWO ******************************** * * * DNEGATE * * * ******************************** H1073 DA H1044 HEX 87 DCI 'DNEGATE' DNEGATE ENT DA *+2 H107F SEC TYA SBC DATASTK+2,X STA DATASTK+2,X TYA SBC DATASTK+3,X STA DATASTK+3,X JMP H1020 ******************************** * * * DABS * * * ******************************** H1091 DA H1073 HEX 84 DCI 'DABS' DABS ENT H1098 DA *+2 H109A LDA DATASTK+1,X BPL H10A2 JMP H107F H10A2 JMP NEXT ******************************** * * * DROP * * * ******************************** H10A5 DA H1091 HEX 84 DCI 'DROP' DROP ENT DA POP ; steal code ******************************** * * * 2DROP * * * ******************************** H10AE DA H10A5 HEX 85 DCI '2DROP' TWODROP ENT DA POPTWO ; steal code ******************************** * * * PLUCK * * * ******************************** H10B8 DA H10AE HEX 85 DCI 'PLUCK' PLUCK ENT DA *+2 H10C2 LDA DATASTK,X PHA LDA DATASTK+1,X JMP H0F86 ******************************** * * * PICK * * * ******************************** H10CC DA H10B8 HEX 84 DCI 'PICK' PICK ENT DA *+2 H10D5 STX XSAVE CLC TXA ADC DATASTK,X ADC DATASTK,X ; double: for 16bit quatities TAX ; modify stack pointer LDA DATASTK,X ; get item PHA LDA DATASTK+1,X ; full 16bits LDX XSAVE ; restore X JMP PUT ; put item on top ******************************** * * * OVER * * * ******************************** H10EC DA H10CC HEX 84 DCI 'OVER' OVER ENT DA *+2 H10F5 LDA DATASTK+2,X ; pick up 2nd item PHA LDA DATASTK+3,X JMP PUSH ; put on top ******************************** * * * DUP * * * ******************************** H10FF DA H10EC HEX 83 DCI 'DUP' DUP ENT DA *+2 H1107 LDA DATASTK,X PHA LDA DATASTK+1,X JMP PUSH ******************************** * * * ?DUP * * * ******************************** H1111 DA H10FF ; points to DUP HEX 84 DCI '?DUP' QDUP ENT DA *+2 H111A ENT LDA DATASTK,X ORA DATASTK+1,X BNE H1125 JMP NEXT H1125 JMP H1107 ******************************** * * * 2DUP * * * ******************************** H1128 DA H1111 HEX 84 DCI '2DUP' TWODUP ENT DA *+2 H1131 LDA DATASTK,X PHA LDA DATASTK+1,X PHA LDA DATASTK+2,X PHA LDA DATASTK+3,X H1140 DEX DEX STA DATASTK+1,X PLA STA DATASTK,X PLA JMP PUSH ******************************** * * * 2OVER * * * ******************************** H114D DA H1128 HEX 85 DCI '2OVER' TWOVER ENT DA H1157 H1157 LDA DATASTK+4,X PHA LDA DATASTK+5,X PHA LDA DATASTK+6,X PHA LDA DATASTK+7,X JMP H1140 ******************************** * * * SWAP * * * ******************************** H1169 DA H114D HEX 84 DCI 'SWAP' SWAP ENT DA *+2 H1172 LDA DATASTK+2,X PHA LDA DATASTK,X STA DATASTK+2,X LDA DATASTK+3,X PHA LDA DATASTK+1,X STA DATASTK+3,X PLA JMP PUT ******************************** * * * 2SWAP * * * ******************************** H118A DA H1169 HEX 85 DCI '2SWAP' TWOSWAP ENT DA *+2 H1194 LDA DATASTK+4,X PHA LDA DATASTK+5,X PHA LDA DATASTK+6,X PHA LDA DATASTK+7,X PHA LDA DATASTK,X STA DATASTK+4,X LDA DATASTK+1,X STA DATASTK+5,X LDA DATASTK+2,X STA DATASTK+6,X LDA DATASTK+3,X STA DATASTK+7,X PLA STA DATASTK+3,X PLA STA DATASTK+2,X PLA JMP PUT ******************************** * * * ROT * * * ******************************** H11C8 DA H118A HEX 83 DCI 'ROT' ROT ENT DA *+2 H11D0 LDA DATASTK+4,X PHA LDA DATASTK+5,X PHA LDA DATASTK+3,X STA DATASTK+5,X LDA DATASTK+2,X STA DATASTK+4,X LDA DATASTK+1,X STA DATASTK+3,X LDA DATASTK,X STA DATASTK+2,X PLA JMP PUT ******************************** * * * BURY * * * ******************************** H11F4 DA H11C8 HEX 84 DCI 'BURY' BURY ENT DA *+2 H11FD LDA DATASTK+2,X PHA LDA DATASTK+3,X PHA LDA DATASTK+4,X STA DATASTK+2,X LDA DATASTK+5,X STA DATASTK+3,X LDA DATASTK,X STA DATASTK+4,X LDA DATASTK+1,X STA DATASTK+5,X PLA JMP PUT ******************************** * * * 1+ * * * ******************************** H1221 DA H11F4 HEX 82 DCI '1+' ONEPLUS ENT DA *+2 H1228 CLC LDA DATASTK,X ADC #1 H122E STA DATASTK,X LDA DATASTK+1,X ADC #0 STA DATASTK+1,X JMP NEXT ******************************** * * * 2+ * * * ******************************** H123C DA H1221 HEX 82 DCI '2+' TWOPLUS ENT DA *+2 CLC LDA DATASTK,X ADC #2 JMP H122E ; borrow code from 1+ ******************************** * * * 3+ * * * ******************************** DA H123C ; new word.... adding in HEX 82 DCI '3+' THREEPL ENT DA *+2 CLC LDA DATASTK,X ADC #3 JMP H122E ; borrow from 1+ ******************************** * * * 1- * * * ******************************** H124C DA THREEPL-5 ; -2 (name) -1 (count) -2 (link) HEX 82 DCI '1-' ONEMINUS ENT DA *+2 H1253 SEC LDA DATASTK,X SBC #1 H1259 STA DATASTK,X LDA DATASTK+1,X SBC #$00 STA DATASTK+1,X JMP NEXT ******************************** * * * 2- * * * ******************************** H1267 DA H124C HEX 82 DCI '2-' TWOMINUS ENT DA *+2 SEC LDA DATASTK,X SBC #2 JMP H1259 ******************************** * * * 3- * * * ******************************** DA H1267 HEX 82 DCI '3-' THREEMI ENT DA *+2 SEC LDA DATASTK,X SBC #3 JMP H1259 ******************************** * * * 2* * * * ******************************** H1277 DA THREEMI-5 HEX 82 DCI '2*' TWOTIMES ENT DA *+2 H127E LDA DATASTK,X ASL PHA LDA DATASTK+1,X ROL JMP PUT ******************************** * * * 2/ * * * ******************************** H128A DA H1277 HEX 82 DCI '2/' TWOSLSH ENT DA *+2 * This is a SIGNED 2/ CLC LDA DATASTK+1,X BPL :ROLLIN SEC ; negative: roll in sign bit :ROLLIN ROR DATASTK+1,X ; roll in sign bit ROR DATASTK,X ; shift 16b lo JMP NEXT ******************************** * * * 2U/ * * * ******************************** H12AA DA H128A HEX 83 DCI '2U/' TWOUSLSH ENT DA *+2 LSR DATASTK+1,X ROR DATASTK,X JMP NEXT ******************************** * * * +! * * * ******************************** H12C3 DA H12AA HEX 82 DCI '+!' PLUSTORE ENT DA *+2 H12CA LDA #$04 JSR SETUP STX XSAVE LDX #$00 CLC LDA (N,X) ADC $03 STA (N,X) INC N BNE H12E0 INC $02 H12E0 LDA (N,X) ADC $04 STA (N,X) LDX XSAVE JMP NEXT ******************************** * * * TOGGLE * * * ******************************** H12EB DA H12C3 HEX 86 DCI 'TOGGLE' TOGGLE ENT DA *+2 H12F6 LDA #$04 JSR SETUP STX XSAVE LDX #$00 LDA ($03,X) EOR N STA ($03,X) LDX XSAVE JMP NEXT ******************************** * * * !0 * * * ******************************** H130A DA H12EB HEX 82 DCI '!0' STOREZER ENT DA *+2 * Obvious improvement is to use STZ H1311 LDA #$02 JSR SETUP TYA STA (N),Y INY STA (N),Y JMP NEXT *=============================== H131F LDA #2 ; compile 8b from stack to dict JSR SETUP ; get user var #41: put in 3,4 LDY #$29 LDA (UP),Y ; user var -- DP STA $03 INY LDA (UP),Y ; 16bit user var STA $04 LDY #0 LDA N ; get former top data stack STA ($03),Y ; compile into dictonary at HERE CLC RTS ******************************** * * * , * * * ******************************** H1337 DA H130A HEX 81 ASC "," COMMA ENT DA *+2 H133D JSR H131F ; compile 8b INY LDA $02 ; compile other half of 16b STA ($03),Y LDY #$29 ; add 2 to DP LDA (UP),Y CLC ADC #$02 H134C STA (UP),Y ; general inc DP INY LDA (UP),Y ADC #$00 STA (UP),Y JMP NEXT ******************************** * * * C, * * * ******************************** H1358 DA H1337 HEX 82 DCI 'C,' CCOMMA ENT DA *+2 H135F JSR H131F ; compile 8b LDY #$29 LDA (UP),Y CLC ADC #1 ; add 1 to DP JMP H134C ; share code ******************************** * * * HERE2+ * * * ******************************** H136C DA H1358 HEX 86 DCI 'HERE2+' HERE2PL ENT DA *+2 H1377 LDY #$29 CLC LDA (UP),Y ADC #$02 PHA INY LDA (UP),Y ADC #$00 JMP PUSH ******************************** * * * @ * * * ******************************** H1387 DA H136C HEX 81 ASC "@" FETCH ENT DA *+2 H138D LDA DATASTK,X STA N LDA DATASTK+1,X STA $02 STX XSAVE LDX #$00 LDA (N,X) PHA INC N BNE H13A4 INC $02 H13A4 LDA (N,X) LDX XSAVE JMP PUT ******************************** * * * C@ * * * ******************************** H13AB DA H1387 HEX 82 DCI 'C@' CFETCH ENT DA *+2 H13B2 LDA DATASTK,X STA N LDA DATASTK+1,X STA $02 STX XSAVE LDX #$00 LDA (N,X) LDX XSAVE PHA TYA JMP PUT ******************************** * * * ! * * * ******************************** H13C9 DA H13AB HEX 81 ASC "!" STORE ENT DA *+2 H13CF LDA #$04 JSR SETUP STX XSAVE LDX #$00 LDA $03 STA (N,X) INC N BNE H13E2 INC $02 H13E2 LDA $04 STA (N,X) LDX XSAVE JMP NEXT ******************************** * * * C! * * * ******************************** H13EB DA H13C9 HEX 82 DCI 'C!' CSTORE ENT DA *+2 H13F2 LDA #$04 JSR SETUP STX XSAVE LDX #$00 LDA $03 STA (N,X) LDX XSAVE JMP NEXT ******************************** * * * COUT * * * ******************************** H1404 DA H13EB HEX 84 DCI 'COUT' FCOUT ENT DA *+2 H140D LDA DATASTK,X ; get char H1410 JSR COUT ; vectored output LDY #$3F ; user var -- OUT LDA (UP),Y CLC ADC #1 ; inc OUT by 1 STA (UP),Y ; put back JMP POP ; pop char off stack ******************************** * * * SCOUT * * * ******************************** H141F DA H1404 HEX 85 DCI 'SCOUT' SCOUT ENT ; Screen COUT DA *+2 H1429 LDA DATASTK,X ; get char ORA #$80 ; turn to apple scrn char JMP H1410 ; do COUT ******************************** * * * (CR) * * * ******************************** H1431 DA H141F HEX 84 DCI '(CR)' PRNCR ENT DA *+2 H143A JSR CROUT LDA #0 LDY #$3F ; user var -- OUT STA (UP),Y ; zero: at left edge JMP NEXT ******************************** * * * NORMAL * * * ******************************** H1446 DA H1431 HEX 86 DCI 'NORMAL' NORMAL ENT DA *+2 H1451 JSR HFE84 JMP NEXT ******************************** * * * INVERSE * * * ******************************** H1457 DA H1446 HEX 87 DCI 'INVERSE' INVERSE ENT DA *+2 H1463 JSR HFE80 JMP NEXT ******************************** * * * RDCHAR * * * ******************************** H1469 DA H1457 HEX 86 DCI 'RDCHAR' FRDCHAR ENT DA *+2 H1474 JSR HFD35 ; get char in A CMP #$95 ; is --> BNE H147D ; nope.. skip LDA ($28),Y ; get screen char H147D AND #$7F ; strip hibit JMP H0BBF ; push 8b from A ******************************** * * * RDKEY * * * ******************************** H1482 DA H1469 HEX 85 DCI 'RDKEY' FRDKEY ENT DA *+2 H148C JSR RDKEY JMP H147D ******************************** * * * (?TERMINAL) * * * ******************************** H1492 DA H1482 HEX 8B DCI '(?TERMINAL)' PRNQTERM ENT DA *+2 H14A0 LDA KEY BPL H14AD ; no key CMP #$83 BNE H14AD ; not ctrl-C LDA STROBE ; strobe only if ^C INY ; 1: true H14AD TYA JMP H0BBF ; push 8b from A ******************************** * * * WTOP! * * * ******************************** H14B1 DA H1492 HEX 85 DCI 'WTOP!' WTOPSTOR ENT DA *+2 H14BB LDA DATASTK,X STA $22 JMP POP ******************************** * * * WBTM! * * * ******************************** H14C3 DA H14B1 HEX 85 DCI 'WBTM!' WBOTSTOR ENT DA *+2 H14CD LDA DATASTK,X STA $23 JMP POP ******************************** * * * HOME * * * ******************************** H14D5 DA H14C3 HEX 84 DCI 'HOME' FHOME ENT DA *+2 H14DE JSR HOME JMP NEXT ******************************** * * * SCROLL * * * ******************************** H14E4 DA H14D5 HEX 86 DCI 'SCROLL' FSCROLL ENT DA *+2 H14EF JSR SCROLL JMP NEXT ******************************** * * * CLREOL * * * ******************************** H14F5 DA H14E4 HEX 86 DCI 'CLREOL' FCLREOL ENT DA *+2 H1500 JSR CLREOL JMP NEXT ******************************** * * * CLREOP * * * ******************************** H1506 DA H14F5 HEX 86 DCI 'CLREOP' FCLREOP ENT DA *+2 H1511 JSR CLREOP JMP NEXT ******************************** * * * VTAB * * * ******************************** H1517 DA H1506 HEX 84 DCI 'VTAB' FVTAB ENT DA *+2 H1520 TXA PHA PHP ; saves... why? LDA DATASTK,X STA CV ; put val in cursor vertical JSR VTAB ; go do... PLP PLA TAX JMP POP ******************************** * * * HTAB * * * ******************************** H1531 DA H1517 HEX 84 DCI 'HTAB' HTAB ENT DA *+2 H153A LDA DATASTK,X STA CH JMP POP ******************************** * * * <SCROLL * * * ******************************** LINK2 ENT DA H1531 HEX 87 DCI '<SCROLL' BKSCROLL ENT DA *+2 H154E LDA $23 SEC SBC #1 PHA JSR VTABZ H1557 LDA $28 STA $2A LDA $29 STA $2B LDY $21 DEY PLA PHA JSR VTABZ H1567 LDA ($28),Y STA ($2A),Y DEY BPL H1567 PLA SEC SBC #1 PHA CLC ADC #1 CMP $22 BNE H1557 PLA LDY #$00 JSR HFC9E JSR VTAB JMP NEXT