---------------PAI Forth--------------- A 4am crack 2021-06-10 --------------------------------------- Name: PAI Forth Version: 3.0 Genre: programming Year: 1985 Publisher: ??? (*) Platform: Apple ][+ or later Media: 5.25-inch disk Sides: 1 OS: custom Previous cracks: none (*) This disk came to me as a protected backup with no accompanying manual or documentation. On boot it says "PAI Forth" but offers no further details. The screens (see below) reference "rlp" and "bobp" which may refer to the author. This disk was automatically cracked by Passport. Here is the transcript: --v-- Reading from S6,D1 T00,S00 Found DOS 3.3 bootloader Using disk's own RWTS Writing to RAM disk T00,S03,$91: AA -> DE T00,S03,$9B: DE -> AA T00,S03,$35: AA -> DE T00,S03,$3F: DE -> AA T00,S06,$AE: AA -> DE T00,S06,$B3: DE -> AA T00,S02,$9E: AA -> DE T00,S02,$A3: DE -> AA Writing to S6,D2 Crack complete. Press any key --^-- More information and source code is available at https://archive.org/details/Passport4am Quod erat liberandum. --------------------------------------- A 4am crack No. 2646 ------------------EOF------------------ ~ Epilogue Like many Forth environments, this one uses "screens" to store and retrieve information from disk. Using modern tools (Applesauce software), I was able to extract these screens, which are included here unedited. ---------------------------------------- ( for recompiling <12/21/85> 39) FORGET-SYS ' CFA ' FORGET ! ' NOOP CFA ' FORGET-SYS ! ' ALSO LFA ' ROOT ! APPENDIX FORGET VIR-BASE MAIN FORGET TEXT 16424 DP ! EXIT --> ( bobp ) ---------------------------------------- ( LOAD BLOCK <12/21/85> 40) \ set up search sequence ONLY FORTH ALSO DEFINITIONS 31 ' WIDTH ! 50 59 THRU \ virtual stuff 41 LOAD \ create A&E 42 LOAD \ create UTIL 43 LOAD \ create FPA 44 LOAD \ create LDR and MLDR 45 LOAD \ ORDER 70 72 THRU \ <@APPENDIX> 41) FORTH DEFINITIONS 0 FWARNING ! \ disable "FWD CALL" msg 60 LOAD \ set up virtual 35 ONB LOAD \ load assembler 5 ' WIDTH ! \ reduce width 44 ONB LOAD \ load editor 31 ' WIDTH ! \ restore width 61 LOAD \ write A&E 1 FWARNING ! ( bobp ) ---------------------------------------- ( load block UTIL <12/21/85> 42) MAIN FORTH DEFINITIONS 0 FWARNING ! \ disable "FWD CALL" msg APPENDIX 35 ONB LOAD \ load assembler MAIN 62 LOAD \ set up UTIL 92 ONB LOAD \ load util 63 LOAD \ write UTIL APPENDIX FORGET ASSEMBLER MAIN 1 FWARNING ! ( PAI ) ---------------------------------------- ( load block FPA <12/20/85> 43) FORTH DEFINITIONS PAGE 2BEEP 2BEEP 2BEEP ." Place FPA disk in drive B " CR ." and press any key to continue. " ?TERMINAL DROP KEY DROP 0 FWARNING ! \ disable "FWD CALL" msg 64 LOAD \ set up virtual 10 ONB LOAD \ load FPA LOADTRANSLATOR ADDDECOMPILER 65 LOAD \ write virtual 1 FWARNING ! ( bobp ) ---------------------------------------- ( load block LDR & MLDR <12/20/85> 44) FORTH DEFINITIONS 66 67 THRU \ create LOADER 68 69 THRU \ create MLOADER ( bobp ) ---------------------------------------- ( ORDER and set DP <12/21/85> 45) MAIN 16424 DP ! \ 42 bytes after graphics ONLY FORTH ALSO ROOT DEFINITIONS : ORDER ; ONLY FORTH ALSO DEFINITIONS ( PAI ) ---------------------------------------- ( VIRTUAL SYSTEMS <12/21/85> 50) APPENDIX FORTH DEFINITIONS 8192 CONSTANT VIR-BASE 8196 CONSTANT SAVE-VDP 0 CONSTANT VDRIVE 0 CONSTANT SYS-LINK1 ' SYS-LINK1 DUP LFA SWAP ! 0 CONSTANT SYS-LINK2 ' SYS-LINK2 DUP LFA SWAP ! VARIABLE SYS-FLG : NOOP ( put-virtual ) 0 SYS-FLG ! SYS-LINK1 SYS-LINK2 ! CURRENT @ CONTEXT ! ; ' CFA ' FORGET-SYS ! ' CFA ' SAVE-FORTH 2+ ! MAIN ( bobp ) ---------------------------------------- ( VIRTUAL vocabulary <12/21/85> 51) APPENDIX FORTH DEFINITIONS VOCABULARY VIRTUAL IMMEDIATE \ remove VIRTUAL from voc-link chain. VOC-LINK @ @ VOC-LINK ! \ Set search order for following scrns. \ FORTH and VIRTUAL will remain in \ search sequence until next invocation \ of ONLY. ONLY FORTH VIRTUAL ALSO FORTH ALSO VIRTUAL DEFINITIONS VARIABLE NEXT-SECTOR VARIABLE NEXT-AUX MAIN ( bobp ) ---------------------------------------- ( VPARMS <12/21/85> 52) APPENDIX VIRTUAL DEFINITIONS VARIABLE VP \ points to vir parameters : VPARM: CREATE , DOES> @ VP @ + ; 00 VPARM: VIR-FLG 02 VPARM: VIR-TST 04 VPARM: LASTLFA 06 VPARM: FIRSTLFA 08 VPARM: AUX-ADDR 10 VPARM: VIR-SIZE 12 VPARM: VIR-SECTS 14 VPARM: VIR-TRK 16 VPARM: VIR-SEC FORTH DEFINITIONS MAIN ( bobp ) ---------------------------------------- ( SYSTEM: <12/21/85> 53) APPENDIX VIRTUAL DEFINITIONS : SYSTEM: CREATE ( vir# size -- ) HERE VP ! HERE 18 0 FILL 18 ALLOT VIR-SIZE ! VIR-FLG ! DOES> ( -- ) VP ! ; HEX ( vir# size ) 1 2000 SYSTEM: A&E 3 1600 SYSTEM: UTIL 4 2000 SYSTEM: FPA 5 2000 SYSTEM: LDR 6 1200 SYSTEM: MLDR DECIMAL FORTH DEFINITIONS MAIN ( bobp ) ---------------------------------------- ( SETPARMS <12/21/85> 54) APPENDIX FORTH DEFINITIONS \ Set everything except LFA links. \ Will be forgotten in next screen. : SETPARMS ( -- ) NEXT-AUX @ AUX-ADDR ! VIR-SIZE @ DUP NEXT-AUX +! 255 + 0 256 U/MOD SWAP DROP DUP VIR-SECTS ! NEGATE NEXT-SECTOR +! NEXT-SECTOR @ 1+ SECS/TRK /MOD VIR-TRK ! VIR-SEC ! MONTH @ 1000 * DAY @ 10 * + YEAR @ 10 MOD + VIR-TST ! ; MAIN ( bobp ) ---------------------------------------- ( allocate virtuals <12/21/85> 55) FORTH DEFINITIONS SECS/TRK TRKS/HD * 1- NEXT-SECTOR ! HEX 800 NEXT-AUX ! A&E SETPARMS UTIL SETPARMS FPA SETPARMS LDR SETPARMS MLDR SETPARMS APPENDIX FORGET SETPARMS DECIMAL MAIN ( bobp ) ---------------------------------------- ( @RWTS-PARAM ?RESIDENT <12/21/85> 56) APPENDIX VIRTUAL DEFINITIONS \ These words assume that VP is set. : @RWTS-PARAM ( -- addr hd dr sec trk ) VIR-BASE 6 VDRIVE VIR-SEC @ VIR-TRK @ ; : ?RESIDENT ( addr -- 0/1 ) D@ VIR-FLG @ VIR-TST @ D= ; : VIR-RES? ( -- ) VIR-BASE ?RESIDENT NOT IF CR ." WRONG DISK -- NO VIRTUAL IMAGE" QUIT THEN ; FORTH DEFINITIONS MAIN ( bobp ) ---------------------------------------- ( V@AUX V!AUX <12/21/85> 57) APPENDIX \ These words assume that VP is set. VIRTUAL DEFINITIONS : V@AUX ( read vir from aux mem ) 1 AUX-ADDR @ 0 VIR-BASE VIR-SIZE @ CMOVEL ; : V!AUX ( write vir to aux mem ) 0 VIR-BASE 1 AUX-ADDR @ VIR-SIZE @ CMOVEL ; : ( read vir from disk ) @RWTS-PARAM 1 VIR-SECTS @ RWTS ; : ( write vir to disk ) @RWTS-PARAM 0 VIR-SECTS @ RWTS ; FORTH DEFINITIONS MAIN ( bobp ) ---------------------------------------- ( GET-VIR <12/21/85> 58) APPENDIX VIRTUAL DEFINITIONS \ These words assume that VP is set. : GET-VIR NOOP SYS-FLG @ VIR-FLG @ = NOT IF ?AUX IF V@AUX VIR-BASE ?RESIDENT NOT IF V!AUX THEN ELSE THEN THEN VIR-RES? SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! VIR-FLG @ SYS-FLG ! ; FORTH DEFINITIONS MAIN ( bobp ) ---------------------------------------- ( GET-A&E etc. <12/21/85> 59) APPENDIX FORTH DEFINITIONS \ These words set VP. : GET-A&E NOOP A&E GET-VIR ; : GET-UTIL NOOP UTIL GET-VIR ; : GET-FPA NOOP FPA VIR-FLG @ IF GET-VIR THEN ; : GET-LOADER NOOP LDR GET-VIR ; : GET-MLOADER NOOP MLDR GET-VIR ; MAIN EXIT ( bobp ) ---------------------------------------- ( make virtual: A&E <12/21/85> 60) MAIN DECIMAL FORTH DEFINITIONS \ save system status FORGET-SYS FREEZE A&E \ set virtual parameter pointer \ switch to virtual mem VIR-BASE DP ! \ fill with A's VIR-BASE 8192 65 FILL \ compile check words VIR-FLG @ VIR-TST @ , , 0 , \ dummy definition for lfa CREATE _ SMUDGE \ remember first LFA LATEST PFA-LFA FIRSTLFA ! ( bobp ) ---------------------------------------- ( write virtual: A&E <12/21/85> 61) FORTH DEFINITIONS A&E \ remember last LFA and DP LATEST PFA-LFA LASTLFA ! HERE SAVE-VDP ! \ restore system status ICEBOX @ VOC-LINK ! ICEBOX 2+ @ DP ! ICEBOX 4 + @ CONTEXT @ ! \ unhook then re-install normally FORGET-SYS A&E VIR-FLG @ SYS-FLG ! SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! \ write to disk V!AUX \ copy to aux bank FORGET-SYS CR CR ." A&E written" CR CR ( bobp ) ---------------------------------------- ( make virtual: UTIL <12/21/85> 62) MAIN DECIMAL FORTH DEFINITIONS \ save system status FORGET-SYS FREEZE UTIL \ set virtual parameter pointer \ switch to virtual mem VIR-BASE DP ! \ fill with B's VIR-BASE 8192 66 FILL \ compile check words VIR-FLG @ VIR-TST @ , , 0 , \ dummy definition for lfa CREATE _ SMUDGE \ remember first LFA LATEST PFA-LFA FIRSTLFA ! ( bobp ) ---------------------------------------- ( write virtual: UTIL <12/21/85> 63) FORTH DEFINITIONS UTIL \ remember last LFA and DP LATEST PFA-LFA LASTLFA ! HERE SAVE-VDP ! \ restore system status ICEBOX @ VOC-LINK ! ICEBOX 2+ @ DP ! ICEBOX 4 + @ CONTEXT @ ! \ unhook then re-install normally FORGET-SYS UTIL VIR-FLG @ SYS-FLG ! SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! \ write to disk V!AUX \ copy to aux bank FORGET-SYS CR CR ." UTIL written" CR CR ( bobp ) ---------------------------------------- ( make virtual: FPA <12/21/85> 64) MAIN DECIMAL FORTH DEFINITIONS \ save system status FORGET-SYS FREEZE FPA \ set virtual parameter pointer \ switch to virtual mem VIR-BASE DP ! \ fill with C's VIR-BASE 8192 67 FILL \ compile check words VIR-FLG @ VIR-TST @ , , 0 , \ dummy definition for lfa CREATE _ SMUDGE \ remember first LFA LATEST PFA-LFA FIRSTLFA ! ( bobp ) ---------------------------------------- ( write virtual: FPA <12/21/85> 65) FORTH DEFINITIONS FPA \ remember last LFA and DP LATEST PFA-LFA LASTLFA ! HERE SAVE-VDP ! \ restore system status ICEBOX @ VOC-LINK ! ICEBOX 2+ @ DP ! ICEBOX 4 + @ CONTEXT @ ! \ unhook then re-install normally FORGET-SYS FPA VIR-FLG @ SYS-FLG ! SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! \ write to disk V!AUX \ copy to aux bank FORGET-SYS CR CR ." FPA written" CR CR ( bobp ) ---------------------------------------- ( make virtual: LOADER <12/21/85> 66) MAIN DECIMAL FORTH DEFINITIONS \ save system status FORGET-SYS FREEZE LDR \ set virtual parameter pointer \ switch to virtual mem VIR-BASE DP ! \ fill with D's VIR-BASE 8192 68 FILL \ compile check words VIR-FLG @ VIR-TST @ , , 0 , \ dummy definition for lfa CREATE _ SMUDGE \ remember first LFA LATEST PFA-LFA FIRSTLFA ! \ make real LOADER vocabulary VOCABULARY LDR-VOC IMMEDIATE ( bobp ) ---------------------------------------- ( write virtual: LOADER <12/21/85> 67) FORTH DEFINITIONS LDR \ remember last LFA and DP LATEST PFA-LFA LASTLFA ! HERE SAVE-VDP ! \ restore system status ICEBOX @ VOC-LINK ! ICEBOX 2+ @ DP ! ICEBOX 4 + @ CONTEXT @ ! \ unhook then re-install normally FORGET-SYS LDR VIR-FLG @ SYS-FLG ! SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! \ write to disk V!AUX \ copy to aux bank FORGET-SYS CR CR ." LOADER written" CR CR ( bobp ) ---------------------------------------- ( make virtual: MLOADER <12/21/85> 68) MAIN DECIMAL FORTH DEFINITIONS \ save system status FORGET-SYS FREEZE MLDR \ set virtual parameter pointer \ switch to virtual mem VIR-BASE DP ! \ fill with E's VIR-BASE 8192 69 FILL \ compile check words VIR-FLG @ VIR-TST @ , , 0 , \ dummy definition for lfa CREATE _ SMUDGE \ remember first LFA LATEST PFA-LFA FIRSTLFA ! ( bobp ) ---------------------------------------- ( write virtual: MLOADER <12/21/85> 69) FORTH DEFINITIONS MLDR \ remember last LFA and DP LATEST PFA-LFA LASTLFA ! HERE SAVE-VDP ! \ restore system status ICEBOX @ VOC-LINK ! ICEBOX 2+ @ DP ! ICEBOX 4 + @ CONTEXT @ ! \ unhook then re-install normally FORGET-SYS MLDR VIR-FLG @ SYS-FLG ! SYS-LINK1 FIRSTLFA @ ! LASTLFA @ SYS-LINK2 ! \ write to disk V!AUX \ copy to aux bank FORGET-SYS CR CR ." MLOADER written" CR CR ( bobp ) ---------------------------------------- ( <@APPENDIX> <12/21/85> 70) ONLY FORTH VIRTUAL ALSO FORTH ALSO DEFINITIONS HEX MAIN 9000 CONSTANT APP-AUX DVARIABLE APP-TEST E000 @ F000 @ APP-TEST D! DECIMAL ( bobp ) ---------------------------------------- ( <@APPENDIX> <12/21/85> 71) MAIN ONLY FORTH ALSO DEFINITIONS HEX \ should only be used after : <@APPENDIX> R2-W2 E000 @ F000 @ APP-TEST D@ D= NOT IF ?AUX IF 1 APP-AUX 0 E000 2000 CMOVEL THEN THEN E000 @ F000 @ APP-TEST D@ D= NOT ?AUX NOT OR IF D000 6 0 8 2 1 20 RWTS APP-SECTS @ IF F000 6 0 SYS-SECTS @ 10 + SECS/TRK /MOD 1 APP-SECTS @ RWTS THEN THEN E000 @ F000 @ APP-TEST D! ; DECIMAL ( bobp ) ---------------------------------------- ( <12/21/85> 72) \ I suspect it will be too dangerous \ to copy the appendix out to disk; \ if you are using a ][ or a ][+ , you \ will lose any changes you have made \ to the appendix. HEX APPENDIX : R2-W2 E000 @ F000 @ APP-TEST D! ?AUX IF 0 E000 1 APP-AUX 2000 CMOVEL THEN ; DECIMAL MAIN ( bobp ) ---------------------------------------- ( READ-VIRS <12/21/85> 75) APPENDIX ONLY FORTH VIRTUAL ALSO FORTH ALSO DEFINITIONS : ?VR 46 EMIT VIR-BASE ?RESIDENT NOT ; : NF ." not found " ; : READ-VIRS ?2E NOT IF EXIT THEN CR ." Reading virtual images " A&E V!AUX ?VR IF CR ." A&E " NF THEN UTIL V!AUX ?VR IF CR ." UTIL " NF THEN FPA V!AUX ?VR IF CR ." FPA " NF THEN LDR V!AUX ?VR IF CR ." LOADER " NF THEN MLDR V!AUX ?VR IF CR ." MLOADER " NF THEN GET-A&E CR CR ; ONLY FORTH ALSO MAIN ( bobp ) ---------------------------------------- ( <12/27/85> 76) APPENDIX : PAGE ." PAI Forth version 3.00 " MONTH @ DAY @ YEAR @ ] LITERAL LITERAL LITERAL 0 .R 45 EMIT 0 .R 45 EMIT 0 .R ." (rlp)" CR ; ' CFA ' LOGO ! ' READ-VIRS CFA ' START-SYS ! MAIN EXIT ." OpDB version 3.10A " [ MONTH @ DAY @ YEAR @ ] LITERAL LITERAL LITERAL 0 .R 45 EMIT 0 .R 45 EMIT 0 .R ." (fah) " CR ; ( bobp ) ---------------------------------------- ( A&E hooks <12/21/85> 77) APPENDIX GET-A&E : CODE GET-A&E [ ASSEMBLER ' CODE CFA ] LITERAL FORTH EXECUTE ; IMMEDIATE : ;CODE GET-A&E [ ASSEMBLER ' ;CODE CFA ] LITERAL FORTH EXECUTE ; IMMEDIATE : EDIT ( scr -- ) MAIN ?NUM GET-A&E [ EDITOR ' EDIT CFA ] LITERAL EXECUTE ; : SCRHDS GET-A&E [ EDITOR ' SCRHDS CFA ] LITERAL EXECUTE ; : ED EDIT ; : EL SCR @ EDIT ; MAIN ( bobp ) ---------------------------------------- ( UTIL hooks <12/21/85> 78) APPENDIX GET-UTIL : COPYSCRNS MAIN GET-UTIL [ ' COPYSCRNS CFA ] LITERAL EXECUTE ; : ERASESCRNS MAIN GET-UTIL [ ' ERASESCRNS CFA ] LITERAL EXECUTE ; : DUMP GET-UTIL [ ' DUMP CFA ] LITERAL EXECUTE ; : INDEX GET-UTIL [ ' INDEX CFA ] LITERAL EXECUTE ; : 4LST GET-UTIL [ ' 4LST CFA ] LITERAL EXECUTE ; : CASE GET-UTIL [ ' CASE CFA ] LITERAL EXECUTE ; IMMEDIATE : IT GET-UTIL [ ' CFA ] LITERAL EXECUTE ; IMMEDIATE MAIN ( bobp ) ---------------------------------------- ( TEXT HG 1HG HGR CLS <12/21/85> 80) HEX MAIN CODE TEXT \ switch to text screen C051 LDA, NEXT JMP, C; CODE HG \ switch to graphics screen C052 LDA, C050 LDA, C054 LDA, C057 LDA, NEXT JMP, C; CODE 1HG \ mixed graphics and text C053 LDA, C050 LDA, ' HG 6 + JMP, C; : CLS FORGET-SYS 2000 2000 0 FILL ; : HGR CLS HG ; DECIMAL ( bobp ) ---------------------------------------- ( TONE <12/21/85> 81) MAIN CODE 2 # LDA, SETUP JSR, N 3 + INC, N 1+ INC, BEGIN, N 3 + LDA, N 4 + STA, N 2+ LDY, 49200 LDA, BEGIN, DEY, 0= IF, N 4 + DEC, THEN, 0= UNTIL, N DEC, 0= IF, N 1+ DEC, THEN, 0= UNTIL, NEXT JMP, C; : TONE ( freq,hz duration,1/100sec -- ) 68500. 4 ROLL U/MOD SWAP DROP SWAP 1278 3 PICK 3 + */ ; EXIT ( bobp ) ---------------------------------------- ( TO REVECTOR <12/21/85> 82) MAIN : R> DUP 2+ >R @ ! ; APPENDIX : TO ?FIND DROP STATE @ IF COMPILE , ELSE ! THEN ; IMMEDIATE : REVECTOR ?FIND DROP CFA [COMPILE] LITERAL ; IMMEDIATE : INTO [COMPILE] TO ; IMMEDIATE MAIN EXIT ( bobp ) ---------------------------------------- ( 1K -ROT WITHIN UWITHIN <12/21/85> 83) MAIN 1024 CONSTANT 1K : ON 1 SWAP ! ; : OFF 0 SWAP ! ; : -ROT ROT ROT ; : WITHIN ( n lo hi -- flag ) 3 PICK MIN MAX = ; : UWITHIN ( n ulo uhi -- flag ) 3 PICK U< >R U< R> OR NOT ; EXIT 8192 CONSTANT 8K ( bobp ) ---------------------------------------- ( BUFFERS <12/21/85> 84) MAIN ( n --, {installs n or max avail.} ) : BUFFERS FLUSH [COMPILE] MAIN LIMIT PAD 200 + - 0 1028 U/MOD SWAP DROP DUP 2 < IF 2BEEP ." OUT OF MEMORY" QUIT THEN MIN 2 MAX ' #BUFF ! \ CR #BUFF . ." BUFFERS INSTALLED" CR #BUFF 1028 * LIMIT SWAP - DUP ' FIRST ! DUP ' MEM-LIMIT ! DUP USE ! PREV ! EMPTY-BUFFERS ; EXIT ( bobp ) ---------------------------------------- ( :$ .$ ;$ N$ N$. <12/21/85> 85) APPENDIX : :$ VARIABLE HERE 2- ; : .$ 1 OVER +! 36 WORD C@ 1+ ALLOT ; : ;$ DROP ; MAIN ( : FIRSTSUB$ 2+ ; ) ( : NEXTSUB$ DUP C@ + 1+ ; ) : N$ OVER OVER @ > 3 PICK 1 < OR IF DROP DROP 0 ELSE ( FIRSTSUB$ ) 2+ SWAP 1 - ?DUP IF 0 DO ( NEXTSUB$ ) DUP C@ + 1+ LOOP THEN 1 THEN ; : N$. N$ IF COUNT TYPE THEN ; EXIT ( bobp ) ---------------------------------------- ( XWORD NOTES <12/21/85> 86) EXIT any word that is preceeded by an "X" is a split head word you should use X' to find the address of the word in the main dictionary, using ' will return the address of the head Do not use DOES with X: as it will get confused and do the wrong thing ( bobp ) ---------------------------------------- ( ?MAIN ?FIND ?APPN <12/21/85> 87) APPENDIX : ?MAIN OLD-DP @ ABORT" MAIN MEMORY ONLY" ; : ?APPN OLD-DP @ NOT ABORT" APPENDIX ONLY" ; \ : ?FIND ( -- PFA FLAG) \ -FIND NOT ABORT" NOT FOUND" ; HEX : APPENDIX? ( ADDR -- T/F) D000 U< NOT ; DECIMAL MAIN EXIT ( bobp ) ---------------------------------------- ( [MAIN] [APPN] <12/21/85> 88) APPENDIX : [MAIN] [COMPILE] MAIN ; : [APPN] [COMPILE] APPENDIX ; MAIN EXIT ( bobp ) ---------------------------------------- ( X' <12/21/85> 89) APPENDIX 0 CONSTANT 'XCREATE : ?MAIN [APPN] CREATE IMMEDIATE [MAIN] DP C@ 255 = ALLOT HERE ' , [APPN] ( MAIN-HERE ) , DOES> [ HERE 3 - ' 'XCREATE ! ] @ STATE @ IF , ELSE EXECUTE THEN ; : X' ?FIND DROP DUP CFA @ 'XCREATE = NOT ABORT" Not an X word" @ 2+ [COMPILE] LITERAL ; IMMEDIATE MAIN ( bobp ) ---------------------------------------- ( XCREATE XVAR XCONST <12/21/85> 90) APPENDIX : XCREATE [MAIN] ; : XVARIABLE XCREATE 0 , ; : XCONSTANT ?NUM [MAIN] -2 ALLOT ' , , ; : XVAR XVARIABLE ; : XCONST XCONSTANT ; MAIN EXIT ( bobp ) ---------------------------------------- ( XCODE <12/21/85> 91) GET-A&E APPENDIX : XCODE ?MAIN GET-A&E SMUDGE [MAIN] [COMPILE] ASSEMBLER ASSEMBLER MEM !CSP HERE DUP 2- ! ; : XC; ?MAIN ?CSP [APPN] SMUDGE [MAIN] CURRENT @ CONTEXT ! ; IMMEDIATE MAIN EXIT ( bobp ) ---------------------------------------- ( X: X; <12/21/85> 92) APPENDIX : X: ?MAIN 20 ( flag for X; ) SP@ CSP ! CURRENT @ CONTEXT ! SMUDGE [MAIN] -2 ALLOT ' <:> , [COMPILE] ] ; : X; ?MAIN ?CSP 20 - ABORT" NOT STARTED WITH X:" COMPILE EXIT [APPN] SMUDGE [MAIN] [COMPILE] [ ; IMMEDIATE MAIN EXIT ( bobp ) ---------------------------------------- ( <12/21/85> 93) APPENDIX : OLD-DP @ NOT \ remember where we were (T= main) >IN @ ?FIND DROP APPENDIX? IF [APPN] ELSE [MAIN] THEN >IN ! \ now restore to original IF [MAIN] ELSE [APPN] THEN ; ' CFA ' FORGET ! MAIN ( bobp ) ---------------------------------------- ( .SS .S ASCII <12/21/85> 94) APPENDIX : .SS DEPTH IF SP@ 2- S0 2- DO I @ 0 D. -2 +LOOP ELSE ." EMPTY STACK " THEN ; : .S CR .SS CR ; \ compile ascii value of next char : ASCII BL WORD 1+ C@ [COMPILE] LITERAL ; IMMEDIATE MAIN EXIT ( bobp ) ---------------------------------------- ( E-B S-B ? X. <12/21/85> 95) APPENDIX : E-B EMPTY-BUFFERS ; : S-B SAVE-BUFFERS ; : ? @ . ; : X. BASE @ >R HEX U. R> BASE ! ; MAIN ( bobp ) ---------------------------------------- ( BITTBL &BIT <12/21/85> 96) MAIN CREATE BITTBL 1 C, 2 C, 4 C, 8 C, 16 C, 32 C, 64 C, 128 C, \ takes { adr offset } on stack \ leaves new adr on stack; drops offset \ sets .A to bit mask \ leaves .Y set to 0 XCODE &BIT BOT LDA, N STA, BOT 1+ LDA, N 1+ STA, INX, INX, N LDA, # 7 AND, TAY, N 1+ LSR, N ROR, N 1+ LSR, N ROR, N 1+ LSR, N ROR, CLC, BOT LDA, N ADC, BOT STA, BOT 1+ LDA, N 1+ ADC, BOT 1+ STA, BITTBL ,Y LDA, # 0 LDY, RTS, XC; EXIT ( bobp ) ---------------------------------------- ( @BIT !BIT <12/21/85> 97) MAIN \ "Offset" can be any unsigned number. \ Note backwards syntax for !BIT . CODE @BIT ( addr offset -- 0/1 ) X' &BIT JSR, 0 X) AND, 0= NOT IF, INY, THEN, TYA, PHA, 0 # LDA, PUT JMP, C; CODE !BIT ( addr offset 0/1 -- ) BOT LDA, BOT 1+ ORA, PHP, ( save flag) INX, INX, X' &BIT JSR, PLP, 0= IF, # 255 EOR, 0 X) AND, ELSE, 0 X) ORA, THEN, 0 X) STA, POP JMP, C; FORGET &BIT EXIT ( bobp ) ---------------------------------------- ( ?EXIT ?LEAVE <12/21/85> 98) : ?EXIT IF R> DROP THEN ; : ?LEAVE IF R> LEAVE >R THEN ; ( bobp ) ---------------------------------------- ( DECOMPILE <12/21/85> 99) APPENDIX GET-FPA : DECOMPILE GET-FPA [ ' DECOMPILE CFA ] LITERAL EXECUTE ; MAIN ( bobp ) ---------------------------------------- ( <@APPENDIX> <12/21/85>100) ONLY FORTH VIRTUAL ALSO FORTH ALSO DEFINITIONS MAIN HEX NEXT-AUX @ CONSTANT APP-AUX 2000 NEXT-AUX +! DVARIABLE APP-TEST E000 @ F000 @ APP-TEST D! DECIMAL ( bobp ) ---------------------------------------- ( <@APPENDIX> <12/21/85>101) ONLY FORTH VIRTUAL ALSO FORTH ALSO DEFINITIONS MAIN HEX \ should only be used after : <@APPENDIX> R2-W2 E000 @ F000 @ APP-TEST D@ D= NOT IF ?AUX IF 1 APP-AUX 0 E000 2000 BMOVE THEN E000 @ F000 @ APP-TEST D@ D= NOT ?AUX NOT OR IF D000 6 0 8 2 1 20 RWTS APP-SECTS @ IF F000 6 0 SYS-SECTS @ 10 + SECS/TRK /MOD 1 APP-SECTS @ RWTS THEN THEN THEN E000 @ F000 @ APP-TEST D! ; DECIMAL ( bobp ) ---------------------------------------- ( <12/21/85>102) \ I suspect it will be too dangerous \ to copy the appendix out to disk; \ if you are using a ][ or a ][+ , you \ will lose any changes you have made \ to the appendix. HEX : R2-W2 E000 @ F000 @ APP-TEST D! ?AUX IF 0 E000 1 APP-AUX 2000 BMOVE THEN ; ( bobp )