diff --git a/6502/C64/Makefile b/6502/C64/Makefile index 7280c81..3fdfdd5 100644 --- a/6502/C64/Makefile +++ b/6502/C64/Makefile @@ -30,11 +30,21 @@ test: test-c64.result test-c16.result test64: test-c64.result +debug-64: emulator/tcbase.T64 emulator/build-vf.sh \ + disks/vforth4_2.d64 disks/tc38q.d64 $(vf_fth_files_petscii) + emulator/build-vf.sh vf-c64-main.fth + # Temporary bincmp target while the old and the new binaries are still # expected to be binary identical. +# Note: There is now 1 byte difference between the +# old c64/c16-volksforth83 and the new c64/c16-vf-reference: +# Byte $1b64 changed from $7c (old) to $dc (new). +# This corresponds to the ." |" string in .name (blk/page $4e). +# Since both represent the same character in PETSCII, namely | , +# the difference is acceptable, and a new reference binary was set. bincmp: cbmfiles/c64-vf-latest cbmfiles/c16-vf-latest - cmp cbmfiles/c64-vf-latest cbmfiles/c64-volksforth83 - cmp cbmfiles/c16-vf-latest cbmfiles/c16-volksforth83 + cmp -b -l cbmfiles/c64-vf-latest tests/c64-vf-reference + cmp -b -l cbmfiles/c16-vf-latest tests/c16-vf-reference run-devenv: emulator/devenv.T64 emulator/run-in-vice.sh devenv diff --git a/6502/C64/cbmfiles/c16-vf-latest b/6502/C64/cbmfiles/c16-vf-latest index 0b38587..117e2fa 100644 Binary files a/6502/C64/cbmfiles/c16-vf-latest and b/6502/C64/cbmfiles/c16-vf-latest differ diff --git a/6502/C64/cbmfiles/c64-vf-latest b/6502/C64/cbmfiles/c64-vf-latest index ec518dd..fea72c7 100644 Binary files a/6502/C64/cbmfiles/c64-vf-latest and b/6502/C64/cbmfiles/c64-vf-latest differ diff --git a/6502/C64/cbmfiles/tcbase b/6502/C64/cbmfiles/tcbase index cdbdb8d..b7daffa 100644 Binary files a/6502/C64/cbmfiles/tcbase and b/6502/C64/cbmfiles/tcbase differ diff --git a/6502/C64/disks/tc38q.d64 b/6502/C64/disks/tc38q.d64 index 7903ee6..3881c40 100644 --- a/6502/C64/disks/tc38q.d64 +++ b/6502/C64/disks/tc38q.d64 @@ -1 +1 @@ -\ ### ÍAIN ÄIRECTORY ### CCLV05JAN87 ÖERSION ÈISTORY $02 (Ã16 (Ã64 ) $03 ÒELOCATE ÓYSTEM $04 ÓPECIAL-ÁSSEMBLER $05 SAVESYSTEM $0Å ÔARGET-COMPILER $10 FREE $34 ÔARGET ÃOMPILER ÍAN $56 \ ### ÍAIN ÄIRECTORY ### CCLV05JAN87 ÖERSION ÈISTORY $02 (Ã16 (Ã64 ) $03 ÒELOCATE ÓYSTEM $04 ÓPECIAL-ÁSSEMBLER $05 SAVESYSTEM $0Å ÔARGET-COMPILER $10 FREE $34 ÔARGET ÃOMPILER ÍAN $56 \ CCLV06DEC88 CAS18AUG06 - ENGLISH TRANSLATION CLV06DEC88 - REWRITTEN ÍANUAL CLV/RE APR-OCT87 FOR REV 3.8 - Ã16/Ã64 ÓCR 3,4,C,10,12,1B,2F CLV2:JUL87 \ ÒELOCATING A SYSTEM CLV2:JULL87 $9400 $0400 ( STACKLENGTH RSTACKLENGTH -) EMPTY HEX OVER + ORIGIN + ORIGIN 0Á + ! \ R0 ORIGIN + DUP ORIGIN 1+ ! \ TASK 6 - ORIGIN 8 + ! \ S0 (16 $C000 ' LIMIT >BODY ! Ã) COLD \\ SYMBOLIC MAP OF SYSTEM UP@ ORIGIN - IS STACKLENGTH R0 @ UP@ - IS RSTACKLENGTH DISK-BUFFER LIMIT FIRST @ RSTACK R0 @ RP@ USER, WARM UP@ UDP @ + UP@ (HEAP) UP@ HEAP STACK S0 @ SP@ SYSTEM HERE ORIGIN 0ÆÅ + USER, COLD ORIGIN 0ÆÅ + ORIGIN SCREEN 0800 0400 PAGE 0-3 0400 0000 ( ÆORTH-6502 ÁSSEMBLER ×ÆÒ ) ( ÂASIS: ÆORTH ÄIMENSIONS ÖÏÌ ÉÉÉ ÎO. 5) ÏNLYFORTH ÁSSEMBLER ALSO DEFINITIONS 1 8 +THRU ( ÆORTH-83 6502-ÁSSEMBLER ) : END-CODE CONTEXT 2- @ CONTEXT ! ; ÃREATE INDEX 0909 , 1505 , 0115 , 8011 , 8009 , 1Ä0Ä , 8019 , 8080 , 0080 , 1404 , 8014 , 8080 , 8080 , 1Ã0à , 801à , 2Ã80 , Ü ÖARIABLE MODE : ÍODE: ( N -) ÃREATE C, ÄOES> ( -) C@ MODE ! ; 0 ÍODE: .Á 1 ÍODE: # 2 Ü ÍODE: MEM 3 ÍODE: ,Ø 4 ÍODE: ,Ù 5 ÍODE: Ø) 6 ÍODE: )Ù 0Æ ÍODE: ) ( ÃODE GENERATING PRIMITIVES 27JUN85WE) ÖARIABLE >CODES Ü ÃREATE NRC ] C, , C@ HERE ALLOT ! C! [ : NONRELOCATE NRC >CODES ! ; NONRELOCATE Ü : >EXEC ÃREATE C, ÄOES> C@ >CODES @ + @ EXECUTE ; Ü 0 >EXEC >C, Ü 2 >EXEC >, Ü 4 >EXEC >C@ Ü 6 >EXEC >HERE Ü 8 >EXEC >ALLOT Ü 0Á >EXEC >! Ü 0à >EXEC >C! ( UPMODE CPU ) Ü : UPMODE ( ADDR0 F0 - ADDR1 F1) ÉÆ MODE @ 8 OR MODE ! ÔÈÅÎ 1 MODE @ 0Æ AND ?DUP ÉÆ 0 ÄÏ DUP + ÌÏÏÐ ÔÈÅÎ OVER 1+ @ AND 0= ; : CPU ( 8B -) ÃREATE C, ÄOES> ( -) C@ >C, MEM ; 00 CPU BRK 18 CPU CLC Ä8 CPU CLD 58 CPU CLI Â8 CPU CLV ÃÁ CPU DEX 88 CPU DEY Å8 CPU INX Ã8 CPU INY ÅÁ CPU NOP 48 CPU PHA 08 CPU PHP 68 CPU PLA 28 CPU PLP 40 CPU RTI 60 CPU RTS 38 CPU SEC Æ8 CPU SED 78 CPU SEI ÁÁ CPU TAX Á8 CPU TAY ÂÁ CPU TSX 8Á CPU TXA 9Á CPU TXS 98 CPU TYA ( M/CPU ) : M/CPU ( MODE OPCODE -) ÃREATE C, , ÄOES> DUP 1+ @ 80 AND ÉÆ 10 MODE +! ÔÈÅÎ OVER ÆÆ00 AND UPMODE UPMODE ÉÆ MEM TRUE ÁBORT" INVALID" ÔÈÅÎ C@ MODE @ INDEX + C@ + >C, MODE @ 7 AND ÉÆ MODE @ 0Æ AND 7 < ÉÆ >C, ÅÌÓÅ >, ÔÈÅÎ ÔÈÅÎ MEM ; 1Ã6Å 60 M/CPU ADC 1Ã6Å 20 M/CPU AND 1Ã6Å Ã0 M/CPU CMP 1Ã6Å 40 M/CPU EOR 1Ã6Å Á0 M/CPU LDA 1Ã6Å 00 M/CPU ORA 1Ã6Å Å0 M/CPU SBC 1Ã6à 80 M/CPU STA 0Ä0Ä 01 M/CPU ASL 0Ã0à Ã1 M/CPU DEC 0Ã0à Å1 M/CPU INC 0Ä0Ä 41 M/CPU LSR 0Ä0Ä 21 M/CPU ROL 0Ä0Ä 61 M/CPU ROR 0414 81 M/CPU STX 0486 Å0 M/CPU CPX 0486 Ã0 M/CPU CPY 1496 Á2 M/CPU LDX 0Ã8Å Á0 M/CPU LDY 048à 80 M/CPU STY 0480 14 M/CPU JSR 8480 40 M/CPU JMP 0484 20 M/CPU BIT ( ÁSSEMBLER CONDITIONALS ) Ü : RANGE? ( BRANCH -- BRANCH ) DUP ABS 07Æ U> ÁBORT" OUT OF RANGE " ; : [[ ( ÂÅÇÉÎ) >HERE ; : ?] ( ÕÎÔÉÌ) >C, >HERE 1+ - RANGE? >C, ; : ?[ ( ÉÆ) >C, >HERE 0 >C, ; : ?[[ ( ×ÈÉÌÅ) ?[ SWAP ; : ]? ( ÔÈÅÎ) >HERE OVER >C@ ÉÆ SWAP >! ÅÌÓÅ OVER 1+ - RANGE? SWAP >C! ÔÈÅÎ ; : ][ ( ÅÌÓÅ) >HERE 1+ 1 JMP SWAP >HERE OVER 1+ - RANGE? SWAP >C! ; : ]] ( ÁÇÁÉÎ) JMP ; : ]]? ( ÒÅÐÅÁÔ) JMP ]? ; ( ÁSSEMBLER CONDITIONALS ) 90 ÃONSTANT ÃÓ Â0 ÃONSTANT Ãà Ä0 ÃONSTANT 0= Æ0 ÃONSTANT 0<> 10 ÃONSTANT 0< 30 ÃONSTANT 0>= 50 ÃONSTANT ÖÓ 70 ÃONSTANT Öà : NOT 20 [ ÆORTH ] XOR ; : BEQ 0<> ?] ; : BMI 0>= ?] ; : BNE 0= ?] ; : BPL 0< ?] ; : BCC ÃÓ ?] ; : BVC ÖÓ ?] ; : BCS Ãà ?] ; : BVS Öà ?] ; \ 2/W/INC/DEC C16 RAM/ROM.. CCLV2:JUL87 : 2INC DUP LDA CLC 2 # ADC DUP STA ÃÓ ?[ SWAP 1+ INC ]? ; : 2DEC DUP LDA SEC 2 # SBC DUP STA Ãà ?[ SWAP 1+ DEC ]? ; : WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; : WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; : ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; (16 \ Ã16+ÍACROS FOR ÂANKSWITCHING : RAM $FF3F STA ; : ROM $FF3E STA ; ' ÊSR ÁLIAS ÎORMÊSR ÄEFER ÊSR : Ã16+ÊSR DUP 0C000 U> ÉÆ ROM ÎORMÊSR RAM ÅÌÓÅ ÎORMÊSR ÔÈÅÎ ; ' Ã16+ÊSR ÉS ÊSR Ã) ( ÁSSEMBLER ;CODE ÃODE ÌABEL 03FEB85BP) ÏNLYFORTH : ÁSSEMBLER ÁSSEMBLER [ ÁSSEMBLER ] MEM ; : ;ÃODE [COMPILE] ÄOES> -3 ALLOT [COMPILE] ; -2 ALLOT ÁSSEMBLER ; IMMEDIATE : ÃODE ÃREATE HERE DUP 2- ! ÁSSEMBLER ; : >LABEL ( ADR -) HERE Ü ÃREATE SWAP , 4 HALLOT HEAP 1 AND HALLOT \ 6502-ALIGN HERE 4 - HEAP 4 CMOVE HEAP LAST @ COUNT 01Æ AND + ! DP ! ÄOES> ( - ADR) @ ; : ÌABEL [ ÁSSEMBLER ] >HERE >LABEL ÁSSEMBLER ; \ CÓAVE CÌOAD.. CLV08AUG87 \NEEDS ÃODE .( ?! ÃODE ?!) \\ ÁSSEMBLER (16 \NEEDS ROM .( ?! ROM ?!) \\ Ã) ÏNLYFORTH $ÆÆ90 >LABEL SETÍSG $90 >LABEL STATUS $ÆÆÂÁ >LABEL SETLFS $ÆÆÂÄ >LABEL SETÎAM $ÆÆÄ8 >LABEL ÂÓÁÖÅ $ÆÆÄ5 >LABEL ÂÌÏÁÄ ÌABEL SLÐARS SETUP JSR (16 ROM Ã) $80 # LDA SETÍSG JSR 0 # LDA STATUS STA Î LDA SEC 8 # SBC (DRV STA Ãà ?[ DEX ]? (DRV 1+ STX Î LDX Î 1+ LDY 1 # LDA SETLFS JSR Î 4 + LDX Î 5 + LDY Î 2+ LDA SETNAM JSR Î 6 + LDX Î 7 + LDY RTS END-CODE ÌABEL SLÅRR \ ÁÒ=ËERNALERROR Ãà ?[ 0 # LDA ]? PHA STATUS LDA $ÂÆ # AND (16 RAM Ã) PUSH JMP END-CODE --> \ SAVESYSTEM 02OCT87RE ÏNLYFORTH ÃODE CÓAVE ( F T+1 ÎAME ÎLEN DEV--ERR) 5 # LDA ÓÌÐARS JSR Î 8 + # LDA BSAVE JSR SLÅRR JMP END-CODE : SAVESYSTEM \ -- ÎAME MUST FOLLOW \ ÆORTH-ËERNAL A LA BOOT: SCR PUSH 1 SCR ! R# PUSH 0 R# ! \ ÅDITOR A LA BOOT [ ÅDITOR ] STAMP$ PUSH STAMP$ OFF (PAD PUSH (PAD OFF \ NUN GEHT'S LOS SAVE ORIGIN $17 - HERE 0 PARSE 8 CSAVE ABORT" ÓAVE-ÅRROR" ; \ ÔARGET COMPILER LOADSCR CLV14OCT87 \ ÉDEA AND FIRST ÉMPLEMENTATION BY KS/BP \ ÉMPLEMENTED ON 6502 BY KS/BP \ VOLKSÆÏÒÔÈ83-ÖERSION BY BP/WE ÏNLYFORTH HEX \NEEDS (16 .( ?! (16 (64 ?! Ã) QUIT ÁSSEMBLER \NEEDS NONRELOCATE 5 LOAD ÁSSEMBLER NONRELOCATE ÖARIABLE ÉMAGE Ã000 ÉMAGE ! ÖOCABULARY ÔTOOLS ÖOCABULARY ÄEFINING 1 10 +THRU \ ÔARGET COMPILER 11 13 +THRU \ ÔARGET ÔOOLS 14 16 +THRU \ ÒEDEFINITIONS CLEAR \ HEX 17 20 +THRU \ PREDEFINITIONS \ ÔARGET HEADER POINTERS BP27JUN85WE ÖARIABLE TDP : THERE TDP @ ; ÖARIABLE DISPLACE ÖARIABLE ?THEAD 0 ?THEAD ! ÖARIABLE TLAST 0 TLAST ! ÖARIABLE GLAST' 0 GLAST' ! ÖARIABLE TDOES> ÖARIABLE >IN: ÖARIABLE TVOC 0 TVOC ! ÖARIABLE TVOC-LINK 0 TVOC-LINK ! \ ÉMAGE AND BYTEORDER CLV2:JULL87 ÃODE ROMOFF (64 SEI 034 # LDA 01 STA Ã) ÎEXT JMP ÃODE ROMON (64 036 # LDA 01 STA CLI Ã) ÎEXT JMP ÃODE >BYTE ( 16B - 8BL 8BH) ÓÐ )Ù LDA PHA TXA ÓÐ )Ù STA ÓÐ 2DEC TXA ÓÐ )Ù STA PLA ÐUTÁ JMP ÃODE BYTE> ( 8BL 8BH - 16B) ÓÐ Ø) LDA PHA ÓÐ 2INC PLA ÓÐ )Ù STA ÎEXT JMP END-CODE : >IMAGE ( ADDR1 - ADDR2) DISPLACE @ - IMAGE @ + ; : >HEAP ( FROM QUAN -) HEAP OVER - 1 AND + \ 6502-ALIGN DUP HALLOT HEAP SWAP CMOVE ; \ ÇHOST-CREATING BP27JUN85WE 0 Ü ÃONSTANT 0 Ü ÃONSTANT Ü : ÍAKE.GHOST ( - CFA.GHOST) HERE ÓTATE @ ÉÆ ÃONTEXT @ ÅÌÓÅ ÃURRENT ÔÈÅÎ @ DUP @ , NAME DUP C@ 1 01Æ UWITHIN NOT ABORT" INVAL.ÇNAME" 1 OVER +! C@ 1+ ALLOT HERE 2 PICK - -ROT , 0 , 0 , OVER 2+ C@ 1 AND 1 XOR >R OVER R@ - HERE OVER - >HEAP HEAP R@ + SWAP ! ÄP ! HEAP R> + + ; \ GHOST WORDS KS27JUN85WE : GFIND ( STRING - CFA TF / STRING FF) DUP >R 1 OVER +! FIND -1 R> +! ; : GHOST ( - CFA) >IN @ NAME GFIND ÉÆ NIP EXIT ÔÈÅÎ DROP >IN ! ÍAKE.GHOST ; : ×ORD, GHOST EXECUTE ; : GDOES> ( CFA.GHOST - CFA.DOES) 4 + DUP @ ÉÆ @ EXIT ÔÈÅÎ HERE DUP , 0 , 4 >HEAP ÄÐ ! HEAP DUP ROT ! ; \ GHOST UTILITIES KS27JUN85WE : G' NAME GFIND 0= ABORT" ?" ; : '. G' DUP @ CASE? ÉÆ ." FORW" ÅÌÓÅ - ABORT" ??" ." RES" ÔÈÅÎ 2+ DUP @ 5 U.R 2+ @ ?DUP ÉÆ DUP @ CASE? ÉÆ ." FDEF" ÅÌÓÅ - ABORT" ??" ." RDEF" ÔÈÅÎ 2+ @ 5 U.R ÔÈÅÎ ; ' ' ÁLIAS H' \ .UNRESOLVED BP27JUN85WE Ü : FORWARD? ( CFA - CFA / EXIT&TRUE) DUP @ = OVER 2+ @ AND ÉÆ DROP ÔRUE RDROP EXIT ÔÈÅÎ ; Ü : UNRESOLVED? ( ADDR - F) 2+ DUP C@ 01Æ AND OVER + C@ ÂÌ = ÉÆ NAME> FORWARD? 4 + @ DUP ÉÆ FORWARD? ÔÈÅÎ ÔÈÅÎ DROP ÆALSE ; Ü : UNRESOLVED-WORDS ÂÅÇÉÎ @ ?DUP ×ÈÉÌÅ DUP UNRESOLVED? ÉÆ DUP 2+ .NAME ?CR ÔÈÅÎ ÒÅÐÅÁÔ ; : .UNRESOLVED VOC-LINK @ ÂÅÇÉÎ DUP 4 - UNRESOLVED-WORDS @ ?DUP 0= ÕÎÔÉÌ ; \ ÅXT. VOCS FOR T-COMPILAT. BP27JUN85WE : ÖOCABULARY ÖOCABULARY 0 , HERE TVOC @ , TVOC ! ; ÖOCABULARY ÔRANSIENT 0 TVOC ! ÏNLY DEFINITIONS ÆORTH ALSO : Ô ÔRANSIENT ; IMMEDIATE : È ÆORTH ; IMMEDIATE DEFINITIONS \ ÔRANSIENT PRIMITIVES KS04JUL85WE ÔRANSIENT DEFINITIONS : C@ È >IMAGE ROMOFF C@ ROMON ; : C! È >IMAGE ROMOFF C! ROMON ; : @ Ô DUP C@ SWAP 1+ C@ BYTE> ; : ! >R >BYTE R@ 1+ Ô C! R> C! ; : CMOVE ( FROM.MEM TO.TARGET QUAN -) BOUNDS ?ÄÏ DUP È C@ É Ô C! È 1+ ÌÏÏÐ DROP ; : HERE THERE ; : ALLOT ÔDP +! ; : C, Ô HERE C! 1 ALLOT È ; : , Ô HERE ! 2 ALLOT È ; \ ÔRANSIENT PRIMITIVES BP27JUN85WE : ," ÁSCII " PARSE DUP Ô C, UNDER THERE SWAP CMOVE ALLOT È ; : FILL ( ADDR QUAN 8B -) -ROT BOUNDS ?ÄÏ DUP É Ô C! È ÌÏÏÐ DROP ; : ERASE 0 Ô FILL ; : BLANK ÂÌ Ô FILL ; : HERE! È TDP ! ; \ ÒESOLVING KS29JUN85WE ÆORTH DEFINITIONS : RESOLVE ( CFA.GHOST CFA.TARGET -) OVER DUP @ = ÉÆ SPACE DUP >NAME .NAME ." EXISTS " 2+ ! DROP EXIT ÔÈÅÎ >R >R 2+ @ ?DUP ÉÆ ÂÅÇÉÎ DUP Ô @ È 2DUP = ABORT" RESOLVE LOOP" R@ ROT Ô ! È ?DUP 0= ÕÎÔÉÌ ÔÈÅÎ R> R> OVER ! 2+ ! ; : RESDOES> ( CFA.GHOST CFA.TARGET -) SWAP GDOES> DUP @ = ÉÆ 2+ ! EXIT ÔÈÅÎ SWAP RESOLVE ; ] ÄOES> [ HERE 3 - 0 ] DUP @ THERE ROT ! Ô , È ; ' >BODY ! ] ÄOES> [ HERE 3 - 0 ] @ Ô , È ; ' >BODY ! \ MOVE-THREADS 6502-ALIGN CLV24.3.87) : MOVE-THREADS ÔVOC @ ÔVOC-LINK @ ÂÅÇÉÎ OVER ?DUP ×ÈÉÌÅ 2- @ OVER 2- Ô ! @ È SWAP @ SWAP ÒÅÐÅÁÔ ERROR" SOME UNDEF. ÔARGET-ÖOCS LEFT" DROP ; : TLATEST ( - ADDR) ÃURRENT @ 6 + ; : 6502-TALIGN ( SUPPOSED CFA -- ) 0ÆÆ AND 0ÆÆ = ÉÆ 1 Ô ALLOT È ÔÈÅÎ ; : SAVE-TARGET \ NAME MUST FOLLOW 08 02 BUSOPEN 0 PARSE BUSTYPE " ,P,W" COUNT BUSTYPE BUSOFF 08 02 BUSOUT DISPLACE @ 100 U/MOD SWAP BUS! BUS! THERE DISPLACE @ ÄÏ É Ô C@ È BUS! ÌÏÏÐ 08 02 BUSCLOSE ; \ COMPILING NAMES INTO TARG. BP27JUN85WE : (THEADER ?THEAD @ ÉÆ 1 ?THEAD +! THERE 6502-TALIGN EXIT ÔÈÅÎ >IN @ NAME SWAP >IN ! DUP C@ 1 020 UWITHIN NOT ABORT" INVAL. ÔNAME" DUP C@ 5 + THERE + 6502-TALIGN BLK @ Ô , È THERE TLATEST DUP @ Ô , È ! THERE DUP TLAST ! OVER C@ 1+ DUP Ô ALLOT CMOVE È ; : ÔHEADER TLAST OFF (THEADER ÇHOST DUP GLAST' ! THERE RESOLVE ; \ PREBUILD DEFINING WORDS BP27JUN85WE Ü : EXECUTABLE? ( ADR - ADR F) DUP ; Ü : TPFA, THERE , ; Ü : (PREBUILD ( CFA.ADR -) >IN @ ÃREATE >IN ! HERE 2- ! ; : PREBUILD ( ADR 0.FROM.: - 0) 0 ?PAIRS EXECUTABLE? DUP >R ÉÆ [COMPILE] ÌITERAL COMPILE (PREBUILD ÅÌÓÅ DROP ÔÈÅÎ COMPILE ÔHEADER ÇHOST GDOES> , R> ÉÆ COMPILE TPFA, ÔÈÅÎ 0 ; IMMEDIATE RESTRICT \ CODE PORTION OF DEF.WORDS BP27JUN85WE : DUMMY 0 ; : ÄO> ( - ADR.OF.JMP.DODOES> 0) [COMPILE] DOES> HERE 3 - COMPILE @ 0 ] ; \ THE 6502 ÁSSEMBLER BP27JUN85WE Ü ÃREATE RELOCATE ] Ô C, , C@ HERE ALLOT ! C! È [ ÔRANSIENT DEFINITIONS : ÁSSEMBLER È [ ÁSSEMBLER ] RELOCATE >CODES ! ÁSSEMBLER ; : >LABEL ( 16B -) È >IN @ NAME GFIND ROT >IN ! ÉÆ OVER RESOLVE DUP ÔÈÅÎ DROP ÃONSTANT ; : ÌABEL È THERE Ô >LABEL ÁSSEMBLER È ; : ÃODE È ÔHEADER THERE 2+ Ô , ÁSSEMBLER È ; \ IMMED. RESTR. ' Ü COMPILE BP27JUN85WE : ?PAIRS ( N1 N2 -- ) È - ABORT" UNSTRUCTURED" ; : >MARK ( - ADDR) È THERE Ô 0 , È ; : >RESOLVE ( ADDR -) È THERE OVER - SWAP Ô ! È ; : - CFA) È G' DUP @ - ABORT" ?" 2+ @ ; : Ü È ?THEAD @ ?EXIT ?THEAD ON ; : COMPILE È ÇHOST , ; IMMEDIATE RESTRICT \ ÔARGET TOOLS KS27JUN85WE ÏNLYFORTH ÔTOOLS ALSO DEFINITIONS Ü : TTYPE ( ADR N -) BOUNDS ?ÄÏ É Ô C@ È EMIT ÌÏÏÐ ; : .NAME ( NFA -) ?DUP ÉÆ DUP 1+ SWAP Ô C@ È 01Æ AND TTYPE ÅÌÓÅ ." ??? " ÔÈÅÎ SPACE ?CR ; Ü : NFA? ( CFA LFA - NFA / CFA FF) ÂÅÇÉÎ DUP ×ÈÉÌÅ 2DUP 2+ DUP Ô C@ È 01Æ AND + 1+ = ÉÆ 2+ NIP EXIT ÔÈÅÎ Ô @ È ÒÅÐÅÁÔ ; : >NAME ( CFA - NFA / FF) ÔVOC ÂÅÇÉÎ @ DUP ×ÈÉÌÅ UNDER 2- @ NFA? ?DUP ÉÆ NIP EXIT ÔÈÅÎ SWAP ÒÅÐÅÁÔ NIP ; \ ÔTOOLS FOR DECOMPILING KS29JUN85WE Ü : ?: DUP 4 U.R ." :" ; Ü : @? DUP Ô @ È 6 U.R ; Ü : C? DUP Ô C@ È 3 .R ; : S ( ADR - ADR+) ?: SPACE C? 3 SPACES DUP 1+ OVER Ô C@ È TTYPE DUP Ô C@ È + 1+ ; : N ( ADR - ADR+2) ?: @? 2 SPACES DUP Ô @ È [ ÔTOOLS ] >NAME .NAME È 2+ ; : D ( ADR N - ADR+N) 2DUP SWAP ?: SWAP 0 ÄÏ C? 1+ ÌÏÏÐ 2 SPACES -ROT TTYPE ; \ ÔOOLS FOR DECOMPILING BP29JUN85WE : L ( ADR - ADR+2) ?: 5 SPACES @? 2+ ; : C ( ADR - ADR+1) 1 D ; : B ( ADR - ADR+1) ?: @? DUP Ô @ È OVER + 5 U.R 2+ ; : DUMP ( ADR N -) BOUNDS ?ÄÏ CR É 8 D DROP STOP? ÉÆ ÌÅÁÖÅ ÔÈÅÎ 8 +ÌÏÏÐ ; : VIEW Ô ' È [ ÔTOOLS ] >NAME ?DUP ÉÆ 4 - Ô @ È EDIT ÔÈÅÎ ; \ REINTERPRETATION DEF.-WORDS 27JUN85WE ÏNLYFORTH : REDEFINITION TDOES> @ ÉÆ >IN PUSH [ ' >INTERPRET >BODY ] ÌITERAL PUSH ÓTATE PUSH ÃONTEXT PUSH >IN: @ >IN ! NAME [ ' ÔRANSIENT 2+ ] ÌITERAL (FIND NIP 0= ÉÆ CR ." ÒEDEFINITION: " HERE .NAME >IN: @ >IN ! : ÄEFINING INTERPRET ÔÈÅÎ ÔÈÅÎ 0 TDOES> ! ; \ ÃREATE..DOES> STRUCTURE BP27JUN85WE Ü : (;TCODE ÔLAST @ DUP Ô C@ + 1+ ! È RDROP ; Ü : CHANGECFA COMPILE LIT TDOES> @ , COMPILE (;TCODE ; ÄEFINING DEFINITIONS : ;CODE 0 ?PAIRS CHANGECFA REVEAL RDROP ; IMMEDIATE RESTRICT ÄEFINING ' ;CODE ÁLIAS DOES> IMMEDIATE RESTRICT : ; [COMPILE] ; RDROP ; IMMEDIATE RESTRICT \ REDEFINITION CONDITIONALS BP27JUN85WE ' ÄÏ ÁLIAS ÄÏ IMMEDIATE RESTRICT ' ?ÄÏ ÁLIAS ?ÄÏ IMMEDIATE RESTRICT ' ÌÏÏÐ ÁLIAS ÌÏÏÐ IMMEDIATE RESTRICT ' ÉÆ ÁLIAS ÉÆ IMMEDIATE RESTRICT ' ÔÈÅÎ ÁLIAS ÔÈÅÎ IMMEDIATE RESTRICT ' ÅÌÓÅ ÁLIAS ÅÌÓÅ IMMEDIATE RESTRICT ' ÂÅÇÉÎ ÁLIAS ÂÅÇÉÎ IMMEDIATE RESTRICT ' ÕÎÔÉÌ ÁLIAS ÕÎÔÉÌ IMMEDIATE RESTRICT ' ×ÈÉÌÅ ÁLIAS ×ÈÉÌÅ IMMEDIATE RESTRICT ' ÒÅÐÅÁÔ ÁLIAS ÒÅÐÅÁÔ IMMEDIATE RESTRICT \ CLEAR ÌITER. ÁSCII ['] ." BP27JUN85WE ÏNLYFORTH ÔRANSIENT DEFINITIONS : CLEAR ÔRUE ABORT" ÔHERE ARE GHOSTS" ; : ÌITERAL ( N -) È DUP $ÆÆ00 AND ÉÆ Ô COMPILE LIT , ÅÌÓÅ COMPILE CLIT C, È ÔÈÅÎ ; IMMEDIATE : ÁSCII È ÂÌ WORD 1+ C@ ÓTATE @ ÉÆ Ô [COMPILE] ÌITERAL È ÔÈÅÎ ; IMMEDIATE : ['] Ô ' [COMPILE] ÌITERAL È ; IMMEDIATE RESTRICT : " Ô COMPILE (" ," È ; IMMEDIATE RESTRICT : ." Ô COMPILE (." ," È ; IMMEDIATE RESTRICT \ ÔARGET COMPILATION ] [ BP03JUL85WE ÆORTH DEFINITIONS : TCOMPILE ?STACK >IN @ NAME FIND ?DUP ÉÆ 0> ÉÆ NIP EXECUTE >INTERPRET ÔÈÅÎ DROP DUP >IN ! NAME ÔÈÅÎ GFIND ÉÆ NIP EXECUTE >INTERPRET ÔÈÅÎ NULLSTRING? ÉÆ DROP EXIT ÔÈÅÎ NUMBER? ?DUP ÉÆ 0> ÉÆ SWAP Ô [COMPILE] ÌITERAL ÔÈÅÎ [COMPILE] ÌITERAL È DROP >INTERPRET ÔÈÅÎ DROP >IN ! ×ORD, >INTERPRET ; -2 ALLOT ÔRANSIENT DEFINITIONS : ] È ÓTATE ON ['] TCOMPILE IS >INTERPRET ; \ ÔARGET CONDITIONALS BP27JUN85WE : ÉÆ Ô COMPILE ?BRANCH >MARK È 1 ; IMMEDIATE RESTRICT : ÔÈÅÎ ABS 1 Ô ?PAIRS >RESOLVE È ; IMMEDIATE RESTRICT : ÅÌÓÅ Ô 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE È -1 ; IMMEDIATE RESTRICT : ÂÅÇÉÎ Ô MARK -2 È 2SWAP ; IMMEDIATE RESTRICT Ü : (REPEAT Ô 2 ?PAIRS RESOLVE È ÒÅÐÅÁÔ ; : ÕÎÔÉÌ Ô COMPILE ?BRANCH (REPEAT È ; IMMEDIATE RESTRICT : ÒÅÐÅÁÔ Ô COMPILE BRANCH (REPEAT È ; IMMEDIATE RESTRICT \ ÔARGET CONDITIONALS BP27JUN85WE : ÄÏ Ô COMPILE (DO >MARK È 3 ; IMMEDIATE RESTRICT : ?ÄÏ Ô COMPILE (?DO >MARK È 3 ; IMMEDIATE RESTRICT : ÌÏÏÐ Ô 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE È ; IMMEDIATE RESTRICT : +ÌÏÏÐ Ô 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE È ; IMMEDIATE RESTRICT \ PREDEFINITIONS BP27JUN85WE : ABORT" Ô COMPILE (ABORT" ," È ; IMMEDIATE : ERROR" Ô COMPILE (ERR" ," È ; IMMEDIATE ÆORTH DEFINITIONS ÖARIABLE TORIGIN ÖARIABLE TUDP 0 TUDP ! : >USER Ô C@ È TORIGIN @ + ; \ ÄATATYPES BP27JUN85WE ÔRANSIENT DEFINITIONS : ORIGIN! È TORIGIN ! ; : USER' ( - 8B) Ô ' 2 + C@ È ; : UALLOT ( N -) È TUDP @ SWAP TUDP +! ; ÄO> >USER ; : ÕSER PREBUILD ÕSER 2 Ô UALLOT C, ; ÄO> ; : ÃREATE PREBUILD ÃREATE ; \ ÄATATYPES BP27JUN85WE ÄO> Ô @ È ; : ÃONSTANT PREBUILD ÃONSTANT Ô , ; : ÖARIABLE ÃREATE 2 Ô ALLOT ; DUMMY : ÖOCABULARY È >IN @ ÖOCABULARY >IN ! Ô PREBUILD ÖOCABULARY 0 , 0 , HERE È TVOC-LINK @ Ô , È TVOC-LINK ! ; ÄO> ; : ÄEFER PREBUILD ÄEFER 2 Ô ALLOT ; : ÉS Ô ' È >BODY ÓTATE @ ÉÆ Ô COMPILE (IS , È ÅÌÓÅ Ô ! È ÔÈÅÎ ; IMMEDIATE \ TARGET DEFINING WORDS BP27JUN85WE Ü : DODOES> Ô COMPILE (;CODE È ÇLAST' @ THERE RESDOES> THERE TDOES> ! ; : ;CODE 0 Ô ?PAIRS DODOES> ÁSSEMBLER È [COMPILE] [ REDEFINITION ; IMMEDIATE RESTRICT : DOES> Ô DODOES> $4à C, COMPILE (DODOES> È ; IMMEDIATE RESTRICT DUMMY : : È TDOES> OFF >IN @ >IN: ! Ô PREBUILD : È CURRENT @ CONTEXT ! Ô ] È 0 ; \ : ÁLIAS ; 02OCT87RE : ÁLIAS ( N -- ) È ÔLAST OFF (THEADER ÇHOST OVER RESOLVE TLAST @ Ô C@ È 20 OR TLAST @ Ô C! , È ; : ; Ô 0 ?PAIRS COMPILE UNNEST [COMPILE] [ È REDEFINITION ; IMMEDIATE RESTRICT DUMMY : ÉNPUT: È TDOES> OFF >IN @ >IN: ! Ô PREBUILD ÉNPUT: È CURRENT @ CONTEXT ! Ô ] È 0 ; DUMMY : ÏUTPUT: È TDOES> OFF >IN @ >IN: ! Ô PREBUILD ÏUTPUT: È CURRENT @ CONTEXT ! Ô ] È 0 ; \ PREDEFINITIONS BP03JUL85WE : COMPILE Ô COMPILE COMPILE È ; IMMEDIATE RESTRICT : ÈOST È ÏNLYFORTH ÔTOOLS ALSO ; : ÃOMPILER Ô ÈOST È ÔRANSIENT ALSO DEFINITIONS ; : [COMPILE] È ×ORD, ; IMMEDIATE RESTRICT : ÏNLYPATCH È THERE 3 - 0 TDOES> ! 0 ; ÏNLYFORTH : ÔARGET ÏNLYFORTH ÔRANSIENT ALSO DEFINITIONS ; ÔRANSIENT DEFINITIONS ÇHOST C, DROP \ ÔARGET ÃOMPILER ÍANUAL CLV06DEC88 ÔARGET-ÃOMPILER VOLKSÆÏÒÔÈ 3.8 6502 (C) VOLKSÆÏÒÔÈ-ÄEVELOPERS 1985-2006 AND ÆORTH ÇESELLSCHAFT E.Ö. HTTP://WWW.FORTH-EV.DE \ ..ÇEBRAUCHSANWEISUNG.. CLV05JAN87 1. ÉNTRODUCTION ÔHE ÔARGETCOMPILER IS WEIRD, KRYPTIC AND SOMETIMES DANGEROUS. ÉF AN ERROR OCCURS, REBOOT MACHINE AND START FROM SCRATCH. \ ..ÍANUAL CLV06DEC88 2. ÌOAD 2.1. ÒELOCATE ÓYSTEM ÔHE ÒELOCATE ÓCREEN ON THIS ÄISK CREATS AN ÅNVIRONMENT WITH ÓTACKS ÓTACKLEN $9400 RÓTACKLEN $0400 ÌIMIT MUST BE $C000 WHICH IS DEFAULT FOR Ã64, FOR Ã16 THIS VALUE MUST BE DOWN-PATCHED 2.1. LOAD SAVE-SYSTEM FROM DISK 1 2.2. LOAD ÅDITOR (IF NEEDED) 2.3. ÌOAD ÔARGETCOMPILER WITH ÌOADSCR. FIRST ONLY THE RESIDENT PART 2.4. EXECUTE SAVESYSTEM 2.5. LOAD ÔRAGETCOMPILER PREDEFINITIONS (SEE BOTTOM OF ÌOADSCREEN) AVOLKSFORTH 3.8tc  U3 2A    ÿ\ ..ÍANUAL CLV06DEC88 2.6. LOAD ÓOURCES OF ÆORTH ËERNEL ON A REAL MACHINE, THIS TAKES ABOUT 30 MINUTES! - ÈOST AND ÔARGETMACHINE THE ÓOURCES ARE PREPARED FOR Ã16 & Ã64. ÃHANGE THE DEFINITIONS OF (Ã16 (Ã64 (SEE ÓCREEN AND ÈANDBOOK) - ÂLK ## HERE #### THERE #### WILL BE PRINTED AS STATUS MSG. - VARIOUS EXISTS ÍESSAGES ARE OK - AT THE ÅND ÓÁÖÅÓÙÓÔÅÍ WILL BE PRINTED. ÃHANGE ÄISK! AND THEN PRESS TO SAVE NEW ÆORTH ÓYSTEM \\ ..ÅXAMPLE SESSION CLV06DEC88 3. ÅXAMPLE FOR ÃÂÍ ÐLUS 4 ÕSED ÄISKS: 1OF4 .. 4OF4 - VOLKSÆORTH ÄISKS 3.8 ÔÃQ - ÔARGETÃOMP ÓOURCE ÔÃF - " ÆILES (EMPTY) 3.1. ÃREATE A ÔARGETCOMPILER ÓYSTEM ÓWITCH ON ÐLUS4, INSERT ÄISK 1OF4 ÄÉÒÅÃÔÏÒÙ -> ... ÌÏÁÄ "Ã16ÕÌÔÒÁÆÏÒÔÈ83",8 -> SEARCHING... LOADING...READY. ÒÕÎ -> ULTRAÆÏÒÔÈ ... OK \\ ..ÅXAMPLE ÓESSION CLV06DEC88 INSERT ÄISK ÔÃQ 4 LOAD FLUSH \ RELOCATE -> VOLKSÆÏÒÔÈ83 ... OK INSERT ÄISK 3OF4 19 LOAD FLUSH \ ÅDITOR -> BLK 4 BLK 5 ...... OK \ APPR5 MIN INSERT ÄISK 1OF4 26 LOAD FLUSH \ SAVESYSTEM INSERT ÄISK ÔÃQ $10 LOAD FLUSH \ ÔÃ-RESIDENT ÐART INSERT ÄISK ÔÃF SAVESYSTEM @:VF-TC-3.8 -> OK ÉF ÆLOPPY FLASHES: ÅRROR \ @: IS: OVERWRITE IF NEEDED \ THIS FILE WILL LATER REPLACE \ THE RUNNING ÆORTH ÓYSTEM \\ ..ÅXAMPLE ÓESSION CLV06DEC88 3.2. ÃOMPILING A NEW ÓYSTEM FIRST AS FOR 3.1. OR: ÌÏÁÄ "VF-TC-3.8",8 -> SEARCHING...LOADING..READY. ÒÕÎ -> VOLKSÆÏÒÔÈ83 ... OK INSERT ÄISK ÔÃQ HEX 27 30 THRU FLUSH \ LOAD TRANSIENT ÐART OF Ôà INSERT ÄISK 2OF4 (ÆORTH ÓOURCE) $09 L \ EDIT ÓCREEN 9 (C64 (C16 (C16+ (C16- (COMMENT IN OR OUT DEPEND. ON ÔARGET-ÍASCHINE $F LOAD \ COMPILE SYSTEM INSERT ÔÃF OR BLANK DISK SAVETARGET C16ULTRAFORTH83 OR SAVETARGET C64ULTRAFORTH83 - ÅÎÄÅ - \\ ÔERMS: ÈOST 'NORMAL' ÆORTH-ÓYSTEM IN ÍACHINE ÔARGET ÓYSTEM TO BE COMPILED ÔRANSIENT ÖOCABULARY FOR Ô-ÃOMPILATION IN ÈOST NEEDS THE ÓPECIALASSEMBLER FOR Ôà 'NORMAL' ÁSSEMBLER ÓTARTADDRESS OF ÔARGET ÓYSTEMS IN ÈOST ÔOOLS FOR ÔARGET-ÓYSTEM ×ORDS FOR ÒEDEFINITIONS \\ ÔARGET-DP HERE IN ÔARGET ÓTARTADDRESS OF ÔARGET-ÓYSTEMS ÉF 0, WE CREATE HEADER IN ÔARGET NFA OF LAST CREATED WORD CFA OF LAST CREATED GHOST CFA OF ÃODE FOR ÄOES>-ÐARTS ÁDDRESS OF LAST : IN ÂLOCK ÔVOC-ÌINK FOR ÈOST ÔVOC-ÌINK FOR ÔARGET \\ SWITCHES TO ÒÁÍ UNDER ÏÓ SWITCHES ÂACK CALCULATES PHYSICAL ÁDDRESS FROM TARGET ÁDDRESS CMOVE TO ÈEAP WITH AUTOMATIC HALLOT >IMAGE MUST BE ADJUSTED WHEN CHANGING MEMORY MANAGENT FOR TARGET SYSTEM SAME WITH C@ AND C! \\ POINTS TO CODE FOR FORWARD POINTS TO CODE FOR RESOLVED IF COMPILING, ÇHOST WILL BE LINKED UNDER(!) LAST ÃONTEXT ×ORD ELSE APPENDED TO ÃURRENT AS NORMAL LFA ÇHOST POINTS TO LAST WORD (S.A) GET NAME AND CHECKS FOR VALID LENGTH ENLARGES NAME BY ONE BLANK CALCULATES NAMELENGTH ( LEN START LINK) CF.ÇHOST, CFA.ÔARGET, ÐTR TO ÄOES>.CFA 6502-ALIGN CMOVED ÇHOST ON ÈEAP LAST WORD POINTS NOT TO ÇHOST CACLCULATES CFA.GHOST ÌAST (ÃURRENT @) WILL BE LINKED TO ; IN REVEAL \\ SEARCH FOR GHOST SEARCH FOR GHOST IF FOUND, FINISH IF NOT FOUND, IT WILL BE CREATED STORES CFA.GHOST ( OR ) ÁDR OF ÐTR TO ÄOES>.CFA IF EXISTING, CFA OF ÄOES> ELSE CREATE ÐÔÒ AND SEE ABOVE >HEAP STARTS ON EVEN ADDRESSES => 6502-ALIGN \\ GETS CFA OF ÇHOST GET STATE OF GHOST, IF FORWARD REFERENCE OR ALREADY RESOLVED (WITH CFA.ÔARGET) SAME FOR POSSIB. ÄOES>-ÐARTS WHILE ÔARGET-ÃOMPILATION ' WILL BE DONE FOR ÇHOSTS \\ IF CF = AND AN ÁDDRESS EXISTS IN ÔARGET ÓYSTEM EXIT UNRESOLVED? WITH ÔRUE-ÆLAG CHECKS IF NAME IS A ÇHOST GETS CFA AND CHECKS FOR UNRESOLVED SAME WITH ÄOES>-ÐART PRINT FOR ÖOCABULARY ALL UNRESOLVED WORDS SEARCH THROUGH ALL ÖOCABULARIES PRINT NON-RESOLVED WORDS \\ ÖOCABULARY STRUCTURE: ÎAME ÂYTES ÃODE FUER ÖOCABULARYS ÌATEST 0 1 ÃOLD-ÌATEST 2 3 NORMAL ÖOC-LINK 4 5 ------------------- ÔLATEST 6 7 ADDITIONAL ÔVOC-LINK 8 9 Ô AND È ARE ÉMMEDIATE AND REPLACING [ ÔRANSIENT ] OR [ ÆORTH ] È => ÈOST \\ ×ORDS FOR ÔARGET-ÃOMPILATION ×ORDS FOR VIRTUAL ÔARGET-ÍEMORY Ô C@ ACCES ÒÁÍ BELOW ÏÓ Ô C! ALSO ÁLL FOLLOWING WORDS USE C@ AND C! CMOVE WORKS ONLY FROM ÈOST TO ÔARGET, NOT OTHER DIRECTION ÏN CHANGES TO THE VIRTUAL ÍEMORY- ÍANAGEMENT, C@, C! AND >IMAGE MUST BE ADJUSTED! \\ ×ORDS FOR ÔARGET-ÃOMPILATION \\ RESOLVES FORWARD REFERENCES CHECKS, IF ALREADY RESOLVED PRINT WARNING IF YES SET CFA.TARGET TO NEW VALUE, ÅND ÆORWARDREFERENCE AVAILABLE ? ÙES, GET ADDRESS IN ÔARGET ÃANCEL, IF POINTING TO ITSELF AND SET CFA.TARGET UNTIL ÅND CFA.TARGET TO CFA.GHOST AND RESOLVED AS CF.TARGET SAME FOR ÄOES>-ÐARTS ÄOES> COMPILES A ÊÍÐ (DODOES> (DODOES> BRINGS THE ON CFA.GHOST FOLLLOWING ADDRESS, WHICH IS CFA.TARGET, ON THE STACK CFA.GHOST IS EITHER OR CFA.TARGET IS THE CFA IN ÔARGET-ÓYSTEM ALSO OR ALREADY VALID \\ FOR ALL ÖOCABLUARIES IN ÔRANSIENT AND ÔARGET SET ÔARGET-ÃOLD-ÌATEST TO ÔRANSIENT-ÔLATEST ÅRROR, IF ÔVOC-LINK ALSO POINTS TO OTHER ÖOCABULARYS ÐOINTS TO ÔLATEST IN ÔRANSIENT-ÖOCS SAVES A ÔARGETSYSTEM AS ÐROGRAMM- FILE ON ÄISK (Ã64-ÓPECIAL!!) \\ IF 0, ÈEADER, ELSE ?THEAD INCREMENT 6502-ALIGN AND ÅNDE GETS ÎAME AN CONVERTS TO CAPITAL ÅRROR ON WRONG LENGTH CALULATES CFA AND 6502-ALIGN ÂLOCKNUMBER FOR VIEW LINK IN OF NEW NAME IN ÃURRENT ÔLAST FOR IMMEDIATE AND RESTRIC CREATE SAVE ÎAME IN ÔARGET SET ÔLAST TO 0 CREATE ÈEADER, CREATE ÇHOST, IF NEW, CFA.GHOST TO ÇLAST' AND RESOLVE \\ ON ÃREATE, ÕSER, ÃONSTANT, ÖARIABLE AND ÄEFER, NOT FOR : UND ÖOCABULARY COMPILING ÐTR TO PFA.TARGET IN ÈOST CREATES ÈEADER IN ÈOST WITH CFA.ADR ÔHIS POINTS TO A ÄOES>-ÐART IN ÔARGET (S.BELOW) FROM: IF CREATED WORD SHOULD BE EXECUTABLE IN CURRENT, CREATE A HEADER ELSE NOT WITH CORRESPONDING CFA ELSE NOT CREATE HEADER IN ÔARGET AND COMPILE AS CFA OF ÄOES>-ÐART STORE THIS ADDRESS IN ÈOST AS PDF PREBUILD IS A ÄEFINING-×ORD FOR ÄEFINING-×ORDS !! \\ RESULTS THAT WITH FOLLWING ÄEFINING-×ORD CREATED WORDS CANNOT BE EXECUTED ÓPECIAL-ÄOES> FOR ×ORDS CREATED IN ÃURRENT, GIVES PFA IN ÔARGET ! ÄO> ... ; : ... ÂUILD ... ; SAME AS ÃREATE ... ÄOES> : ÄO> [COMPILE] DOES> HERE 3 - 0 ] ; : (BUILD ÃREATE HERE 2- ! ; : ÂUILD (CFA 0 - 0) 0 ?PAIRS [COMPILE] ÌITERAL COMPILE (BUILD 0 ; \\ ÁSSEMBLER ASSEMBLES IN ÔARGET NOW ENABLES ÁSSEMBLER AND RELOCATE IF LABEL ALREADY EXISTS AS ÇHOST, RESOLVE FORWARD REFERENCE AS ÃONSTANT IN ÈOST ÌABEL POINTS TO THERE ÓPECIAL-ÃODE FOR ÔARGET \\ ÃONTROLSTRUCTURES FOR ÔARGET-ÓYSTEM ' IN ÔRANSIENT ACCESSES ÇHOSTS AND GETS CFA.TARGET ÔHE NEXT WORD WILL BE CREATED WITHOUT HEADER WORKS ON ÈOST, NOT ON ÔARGET \\ ÔOOLS FOR ÔARGET-ÓYSTEM SIMILAR TO NORMAL TOOLS PRINTS N CHARS AT ADDR PRINTS NAME OF WORD, IF NFA <>0 ELSE ??? CHECKS, IF LFA NFA OF CFA IS AND RETURNS NFA, ELSE CFA AND FF CONVERTS CFA IN NFA, IF POSSIBLE \\ ÔOOLS FOR ÔARGET-ÓYSTEM SIMILAR TO NORMAL TOOLS PRINTS STRING AT ADR AND ADJUSTS ADR PRINT NAME OF COMPILE WORD AND ADJUST ADR PRINTS N BYTES FROM ADR AND ADJUSTS ADR \\ ÔOOLS FOR ÔARGET-ÓYSTEM PRINTS N ÂYTES AT ADR, LIKE D, BUT NICE FORMATTED DISPLAYS ÓOURCECODESCREEN OF WORD \\ ALLOWS EXECUTION OF NEW CREATED DEFINING WORDS DURING TARGET COMPILATION IS ;CODE OR DOES> ? YES, SAVE SYSTEMSTATE >IN TO BEGIN OF LAST ÃOLONDEF. NO AS PREDEFINITION IN ÔRANSIENT AVAILABLE? YES, PRINT "ÒEDEFINITION: " AND LAST ÎAMES >IN ADJUST, ÆORTH-: EXECUTE AND SWITCH ON ÄEFININING AS ÃONTEXT RESET TDOES> \\ CHANGES THE CFA OF LST DEFINED WORD TO ÄOES>-ÐART IN ÔARGET COMPILES, WHICH COMPILES THE ADR OF ÄOES>-PART AND (;CODE WHEN EXECUTED ;CODE AND ÄOES> MUST BE DEFINED IN REDEF SAME AS ÄO> FOR PREBUILD STORES LAST WORD IN ÈOST AND JUMPS IN REDEFINITION BEHIND INTERPRET ÓTRUCTUR OF A IN ÈOST CREATED WORD: LFA\NAME\CFA TO JMP (DOEDOES\PFA TO ÄOES>-ÐART IN ÔARGET ×ORDS, CREATED BY ÒEDEFINITION OF ÄEFINING ×ORDS, RETURN THEIR ÐÆÁ, WHEN EXECUTED IN ÈOST \\ ÆORTH-ÃONTROLLSTRUCTURES, BECAUSE ÔRANSIENT WILL FIND WORDS FOR ÔARGET \\ ÐREDEFINITIONS ×ORDS THAT MUST BE EXECUTABLE IN ÔRANSIENT \\ MAIN ÃOMPILELOOP SEARCH FOR NAMES IN ÔRANSIENT AND ÆORTH FOUND, EXECUTE, IF IMMEDIATE ELSE RESET >IN SEARCH ÇHOST AND EXDCUTE CFA ÎUMBER?, IF YES, EXECUTE ÌITERAL (Ô!) CREATE NEW GHOST AND COMPILE FORWARD REFERENCE ENABLE ÃOMPILER, SET >INTERPRET FROM TCOMPILE \\ ÃONDITIONALS FOR ÔARGET-ÃOMPILATION \\ ÃONDITIONALS FOR ÔARGET-ÃOMPILATION \\ ÉMMEDIATE-×ORDS FOR ÔARGET ORIGIN IN TARGET UDP IN TARGET CALCULATES ÁDDRESS IN ÕSER-ÁREA FROM ÁDDRESS OF ÏFFSET \\ ÕSER-ÖARIABLE ARE ALSO EXECUTABLE IN ÔRANSIENT AND RETURN ÔARGET-ÁDDRESSES ×ITG ÃREATE COMPILED ×ORDS ARE EXECUT- ABLE IN ÔRANSIENT AND RETURN THE PFA.TARGET \\ ÁLSO ÃONSTANT AND ÖARIABLE CAN BE EXECUT ED IN ÔRANSIENT AND REZTURN THE ÔARGET ÖALUES ÖOCABULARYS ARE EXECUTABLE IN TRANSIENT ÖOCABULARY 'NAME' CREATED: 1. Á ÖOCABULARY ÅNTRY IN ÃURRENT WITH 5 FIELDS CONNECTED ON TVOC 2. Á ÖOCABULARY ÅNTRY IN ÃURRENT WITH 3 ÆIELDS CONNECTED ON TVOC-LINK 3. Á ÇHOST \\ CREATES A ÖARIABLE-HEADER SAME AS ÉS IN ÆORTH CREATES ÃODE KILE ;CODE IN ÆORTH ÆORWARDREFERNCE FOR ÄOES>-ÐART WILL RESOLVED AND TDOES> SET FOR REDEFINITION LIKE ;CODE IN ÆORTH, BUT WITH REDEFINITI ON LIKE ÄOES> IN ÆORTH, BUT WITH DODOES> \\ DISABLE REDEFINITION CREATE SMALL ENTRY IN ÔRANSIENT FOR WITH : CREATED WORDS SET ÃONTEXT TO FIRST FIX ÖOC CREATE ÈEADER IN ÔARGET AND RESOLVE FORWARD-REFERNCE WITH ÁLIAS-CFA SAME AS HIDE IN ÆORTH SAME AS ; IN ÆORTH, AND REDEFINITION IS STARTED \\ CREATES COMPILE AS FORWARDREFERNCE !! SET ORDER TO: ÔTOOLS ÔTOOLS ÆORTH ÏNLY AS ÈOST, ORDER: ÔRANSIENT ÔRANSIENT ÔTOOLS ÆORTH ÏNLY COMPILS THE CFA.TARGET OF ÇHOSTS ÓPECIAL-ÃODE FOR ÏNLY-ÖOCABULARY SET ORDER FOR ÔARGET-ÃOMPILATION: ÔRANSIENT ÔRANSIENT ÆORTH ÏNLY ÔHANKS TO ËLAUS FOR 'PUNCTUATION?' !!! \ No newline at end of file +\ ### ÍAIN ÄIRECTORY ### CCLV05JAN87 ÖERSION ÈISTORY $02 (Ã16 (Ã64 ) $03 ÒELOCATE ÓYSTEM $04 ÓPECIAL-ÁSSEMBLER $05 SAVESYSTEM $0Å ÔARGET-COMPILER $10 FREE $34 ÔARGET ÃOMPILER ÍAN $56 \ ### ÍAIN ÄIRECTORY ### CCLV05JAN87 ÖERSION ÈISTORY $02 (Ã16 (Ã64 ) $03 ÒELOCATE ÓYSTEM $04 ÓPECIAL-ÁSSEMBLER $05 SAVESYSTEM $0Å ÔARGET-COMPILER $10 FREE $34 ÔARGET ÃOMPILER ÍAN $56 \ CCLV06DEC88 CAS18AUG06 - ENGLISH TRANSLATION CLV06DEC88 - REWRITTEN ÍANUAL CLV/RE APR-OCT87 FOR REV 3.8 - Ã16/Ã64 ÓCR 3,4,C,10,12,1B,2F CLV2:JUL87 \ ÒELOCATING A SYSTEM CLV2:JULL87 $9400 $0400 ( STACKLENGTH RSTACKLENGTH -) EMPTY HEX OVER + ORIGIN + ORIGIN 0Á + ! \ R0 ORIGIN + DUP ORIGIN 1+ ! \ TASK 6 - ORIGIN 8 + ! \ S0 (16 $C000 ' LIMIT >BODY ! Ã) COLD \\ SYMBOLIC MAP OF SYSTEM UP@ ORIGIN - IS STACKLENGTH R0 @ UP@ - IS RSTACKLENGTH DISK-BUFFER LIMIT FIRST @ RSTACK R0 @ RP@ USER, WARM UP@ UDP @ + UP@ (HEAP) UP@ HEAP STACK S0 @ SP@ SYSTEM HERE ORIGIN 0ÆÅ + USER, COLD ORIGIN 0ÆÅ + ORIGIN SCREEN 0800 0400 PAGE 0-3 0400 0000 ( ÆORTH-6502 ÁSSEMBLER ×ÆÒ ) ( ÂASIS: ÆORTH ÄIMENSIONS ÖÏÌ ÉÉÉ ÎO. 5) ÏNLYFORTH ÁSSEMBLER ALSO DEFINITIONS 1 8 +THRU ( ÆORTH-83 6502-ÁSSEMBLER ) : END-CODE CONTEXT 2- @ CONTEXT ! ; ÃREATE INDEX 0909 , 1505 , 0115 , 8011 , 8009 , 1Ä0Ä , 8019 , 8080 , 0080 , 1404 , 8014 , 8080 , 8080 , 1Ã0à , 801à , 2Ã80 , Ü ÖARIABLE MODE : ÍODE: ( N -) ÃREATE C, ÄOES> ( -) C@ MODE ! ; 0 ÍODE: .Á 1 ÍODE: # 2 Ü ÍODE: MEM 3 ÍODE: ,Ø 4 ÍODE: ,Ù 5 ÍODE: Ø) 6 ÍODE: )Ù 0Æ ÍODE: ) ( ÃODE GENERATING PRIMITIVES 27JUN85WE) ÖARIABLE >CODES Ü ÃREATE NRC ] C, , C@ HERE ALLOT ! C! [ : NONRELOCATE NRC >CODES ! ; NONRELOCATE Ü : >EXEC ÃREATE C, ÄOES> C@ >CODES @ + @ EXECUTE ; Ü 0 >EXEC >C, Ü 2 >EXEC >, Ü 4 >EXEC >C@ Ü 6 >EXEC >HERE Ü 8 >EXEC >ALLOT Ü 0Á >EXEC >! Ü 0à >EXEC >C! ( UPMODE CPU ) Ü : UPMODE ( ADDR0 F0 - ADDR1 F1) ÉÆ MODE @ 8 OR MODE ! ÔÈÅÎ 1 MODE @ 0Æ AND ?DUP ÉÆ 0 ÄÏ DUP + ÌÏÏÐ ÔÈÅÎ OVER 1+ @ AND 0= ; : CPU ( 8B -) ÃREATE C, ÄOES> ( -) C@ >C, MEM ; 00 CPU BRK 18 CPU CLC Ä8 CPU CLD 58 CPU CLI Â8 CPU CLV ÃÁ CPU DEX 88 CPU DEY Å8 CPU INX Ã8 CPU INY ÅÁ CPU NOP 48 CPU PHA 08 CPU PHP 68 CPU PLA 28 CPU PLP 40 CPU RTI 60 CPU RTS 38 CPU SEC Æ8 CPU SED 78 CPU SEI ÁÁ CPU TAX Á8 CPU TAY ÂÁ CPU TSX 8Á CPU TXA 9Á CPU TXS 98 CPU TYA ( M/CPU ) : M/CPU ( MODE OPCODE -) ÃREATE C, , ÄOES> DUP 1+ @ 80 AND ÉÆ 10 MODE +! ÔÈÅÎ OVER ÆÆ00 AND UPMODE UPMODE ÉÆ MEM TRUE ÁBORT" INVALID" ÔÈÅÎ C@ MODE @ INDEX + C@ + >C, MODE @ 7 AND ÉÆ MODE @ 0Æ AND 7 < ÉÆ >C, ÅÌÓÅ >, ÔÈÅÎ ÔÈÅÎ MEM ; 1Ã6Å 60 M/CPU ADC 1Ã6Å 20 M/CPU AND 1Ã6Å Ã0 M/CPU CMP 1Ã6Å 40 M/CPU EOR 1Ã6Å Á0 M/CPU LDA 1Ã6Å 00 M/CPU ORA 1Ã6Å Å0 M/CPU SBC 1Ã6à 80 M/CPU STA 0Ä0Ä 01 M/CPU ASL 0Ã0à Ã1 M/CPU DEC 0Ã0à Å1 M/CPU INC 0Ä0Ä 41 M/CPU LSR 0Ä0Ä 21 M/CPU ROL 0Ä0Ä 61 M/CPU ROR 0414 81 M/CPU STX 0486 Å0 M/CPU CPX 0486 Ã0 M/CPU CPY 1496 Á2 M/CPU LDX 0Ã8Å Á0 M/CPU LDY 048à 80 M/CPU STY 0480 14 M/CPU JSR 8480 40 M/CPU JMP 0484 20 M/CPU BIT ( ÁSSEMBLER CONDITIONALS ) Ü : RANGE? ( BRANCH -- BRANCH ) DUP ABS 07Æ U> ÁBORT" OUT OF RANGE " ; : [[ ( ÂÅÇÉÎ) >HERE ; : ?] ( ÕÎÔÉÌ) >C, >HERE 1+ - RANGE? >C, ; : ?[ ( ÉÆ) >C, >HERE 0 >C, ; : ?[[ ( ×ÈÉÌÅ) ?[ SWAP ; : ]? ( ÔÈÅÎ) >HERE OVER >C@ ÉÆ SWAP >! ÅÌÓÅ OVER 1+ - RANGE? SWAP >C! ÔÈÅÎ ; : ][ ( ÅÌÓÅ) >HERE 1+ 1 JMP SWAP >HERE OVER 1+ - RANGE? SWAP >C! ; : ]] ( ÁÇÁÉÎ) JMP ; : ]]? ( ÒÅÐÅÁÔ) JMP ]? ; ( ÁSSEMBLER CONDITIONALS ) 90 ÃONSTANT ÃÓ Â0 ÃONSTANT Ãà Ä0 ÃONSTANT 0= Æ0 ÃONSTANT 0<> 10 ÃONSTANT 0< 30 ÃONSTANT 0>= 50 ÃONSTANT ÖÓ 70 ÃONSTANT Öà : NOT 20 [ ÆORTH ] XOR ; : BEQ 0<> ?] ; : BMI 0>= ?] ; : BNE 0= ?] ; : BPL 0< ?] ; : BCC ÃÓ ?] ; : BVC ÖÓ ?] ; : BCS Ãà ?] ; : BVS Öà ?] ; \ 2/W/INC/DEC C16 RAM/ROM.. CCLV2:JUL87 : 2INC DUP LDA CLC 2 # ADC DUP STA ÃÓ ?[ SWAP 1+ INC ]? ; : 2DEC DUP LDA SEC 2 # SBC DUP STA Ãà ?[ SWAP 1+ DEC ]? ; : WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; : WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; : ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; (16 \ Ã16+ÍACROS FOR ÂANKSWITCHING : RAM $FF3F STA ; : ROM $FF3E STA ; ' ÊSR ÁLIAS ÎORMÊSR ÄEFER ÊSR : Ã16+ÊSR DUP 0C000 U> ÉÆ ROM ÎORMÊSR RAM ÅÌÓÅ ÎORMÊSR ÔÈÅÎ ; ' Ã16+ÊSR ÉS ÊSR Ã) ( ÁSSEMBLER ;CODE ÃODE ÌABEL 03FEB85BP) ÏNLYFORTH : ÁSSEMBLER ÁSSEMBLER [ ÁSSEMBLER ] MEM ; : ;ÃODE [COMPILE] ÄOES> -3 ALLOT [COMPILE] ; -2 ALLOT ÁSSEMBLER ; IMMEDIATE : ÃODE ÃREATE HERE DUP 2- ! ÁSSEMBLER ; : >LABEL ( ADR -) HERE Ü ÃREATE SWAP , 4 HALLOT HEAP 1 AND HALLOT \ 6502-ALIGN HERE 4 - HEAP 4 CMOVE HEAP LAST @ COUNT 01Æ AND + ! DP ! ÄOES> ( - ADR) @ ; : ÌABEL [ ÁSSEMBLER ] >HERE >LABEL ÁSSEMBLER ; \ CÓAVE CÌOAD.. CLV08AUG87 \NEEDS ÃODE .( ?! ÃODE ?!) \\ ÁSSEMBLER (16 \NEEDS ROM .( ?! ROM ?!) \\ Ã) ÏNLYFORTH $ÆÆ90 >LABEL SETÍSG $90 >LABEL STATUS $ÆÆÂÁ >LABEL SETLFS $ÆÆÂÄ >LABEL SETÎAM $ÆÆÄ8 >LABEL ÂÓÁÖÅ $ÆÆÄ5 >LABEL ÂÌÏÁÄ ÌABEL SLÐARS SETUP JSR (16 ROM Ã) $80 # LDA SETÍSG JSR 0 # LDA STATUS STA Î LDA SEC 8 # SBC (DRV STA Ãà ?[ DEX ]? (DRV 1+ STX Î LDX Î 1+ LDY 1 # LDA SETLFS JSR Î 4 + LDX Î 5 + LDY Î 2+ LDA SETNAM JSR Î 6 + LDX Î 7 + LDY RTS END-CODE ÌABEL SLÅRR \ ÁÒ=ËERNALERROR Ãà ?[ 0 # LDA ]? PHA STATUS LDA $ÂÆ # AND (16 RAM Ã) PUSH JMP END-CODE --> \ SAVESYSTEM 02OCT87RE ÏNLYFORTH ÃODE CÓAVE ( F T+1 ÎAME ÎLEN DEV--ERR) 5 # LDA ÓÌÐARS JSR Î 8 + # LDA BSAVE JSR SLÅRR JMP END-CODE : SAVESYSTEM \ -- ÎAME MUST FOLLOW \ ÆORTH-ËERNAL A LA BOOT: SCR PUSH 1 SCR ! R# PUSH 0 R# ! \ ÅDITOR A LA BOOT [ ÅDITOR ] STAMP$ PUSH STAMP$ OFF (PAD PUSH (PAD OFF \ NUN GEHT'S LOS SAVE ORIGIN $17 - HERE 0 PARSE 8 CSAVE ABORT" ÓAVE-ÅRROR" ; \ ÔARGET COMPILER LOADSCR 11JUL20PZ \ ÉDEA AND FIRST ÉMPLEMENTATION BY KS/BP \ ÉMPLEMENTED ON 6502 BY KS/BP \ VOLKSÆÏÒÔÈ83-ÖERSION BY BP/WE ÏNLYFORTH HEX : (BLK@ BLK @ ; ÄEFER BLK@ ' (BLK@ IS BLK@ \NEEDS (16 .( ?! (16 (64 ?! Ã) QUIT ÁSSEMBLER \NEEDS NONRELOCATE 5 LOAD ÁSSEMBLER NONRELOCATE ÖARIABLE ÉMAGE Ã000 ÉMAGE ! ÖOCABULARY ÔTOOLS ÖOCABULARY ÄEFINING 1 10 +THRU \ ÔARGET COMPILER 11 13 +THRU \ ÔARGET ÔOOLS 14 16 +THRU \ ÒEDEFINITIONS CLEAR \ HEX 17 20 +THRU \ PREDEFINITIONS \ ÔARGET HEADER POINTERS BP27JUN85WE ÖARIABLE TDP : THERE TDP @ ; ÖARIABLE DISPLACE ÖARIABLE ?THEAD 0 ?THEAD ! ÖARIABLE TLAST 0 TLAST ! ÖARIABLE GLAST' 0 GLAST' ! ÖARIABLE TDOES> ÖARIABLE >IN: ÖARIABLE TVOC 0 TVOC ! ÖARIABLE TVOC-LINK 0 TVOC-LINK ! \ ÉMAGE AND BYTEORDER CLV2:JULL87 ÃODE ROMOFF (64 SEI 034 # LDA 01 STA Ã) ÎEXT JMP ÃODE ROMON (64 036 # LDA 01 STA CLI Ã) ÎEXT JMP ÃODE >BYTE ( 16B - 8BL 8BH) ÓÐ )Ù LDA PHA TXA ÓÐ )Ù STA ÓÐ 2DEC TXA ÓÐ )Ù STA PLA ÐUTÁ JMP ÃODE BYTE> ( 8BL 8BH - 16B) ÓÐ Ø) LDA PHA ÓÐ 2INC PLA ÓÐ )Ù STA ÎEXT JMP END-CODE : >IMAGE ( ADDR1 - ADDR2) DISPLACE @ - IMAGE @ + ; : >HEAP ( FROM QUAN -) HEAP OVER - 1 AND + \ 6502-ALIGN DUP HALLOT HEAP SWAP CMOVE ; \ ÇHOST-CREATING BP27JUN85WE 0 Ü ÃONSTANT 0 Ü ÃONSTANT Ü : ÍAKE.GHOST ( - CFA.GHOST) HERE ÓTATE @ ÉÆ ÃONTEXT @ ÅÌÓÅ ÃURRENT ÔÈÅÎ @ DUP @ , NAME DUP C@ 1 01Æ UWITHIN NOT ABORT" INVAL.ÇNAME" 1 OVER +! C@ 1+ ALLOT HERE 2 PICK - -ROT , 0 , 0 , OVER 2+ C@ 1 AND 1 XOR >R OVER R@ - HERE OVER - >HEAP HEAP R@ + SWAP ! ÄP ! HEAP R> + + ; \ GHOST WORDS KS27JUN85WE : GFIND ( STRING - CFA TF / STRING FF) DUP >R 1 OVER +! FIND -1 R> +! ; : GHOST ( - CFA) >IN @ NAME GFIND ÉÆ NIP EXIT ÔÈÅÎ DROP >IN ! ÍAKE.GHOST ; : ×ORD, GHOST EXECUTE ; : GDOES> ( CFA.GHOST - CFA.DOES) 4 + DUP @ ÉÆ @ EXIT ÔÈÅÎ HERE DUP , 0 , 4 >HEAP ÄÐ ! HEAP DUP ROT ! ; \ GHOST UTILITIES KS27JUN85WE : G' NAME GFIND 0= ABORT" ?" ; : '. G' DUP @ CASE? ÉÆ ." FORW" ÅÌÓÅ - ABORT" ??" ." RES" ÔÈÅÎ 2+ DUP @ 5 U.R 2+ @ ?DUP ÉÆ DUP @ CASE? ÉÆ ." FDEF" ÅÌÓÅ - ABORT" ??" ." RDEF" ÔÈÅÎ 2+ @ 5 U.R ÔÈÅÎ ; ' ' ÁLIAS H' \ .UNRESOLVED BP27JUN85WE Ü : FORWARD? ( CFA - CFA / EXIT&TRUE) DUP @ = OVER 2+ @ AND ÉÆ DROP ÔRUE RDROP EXIT ÔÈÅÎ ; Ü : UNRESOLVED? ( ADDR - F) 2+ DUP C@ 01Æ AND OVER + C@ ÂÌ = ÉÆ NAME> FORWARD? 4 + @ DUP ÉÆ FORWARD? ÔÈÅÎ ÔÈÅÎ DROP ÆALSE ; Ü : UNRESOLVED-WORDS ÂÅÇÉÎ @ ?DUP ×ÈÉÌÅ DUP UNRESOLVED? ÉÆ DUP 2+ .NAME ?CR ÔÈÅÎ ÒÅÐÅÁÔ ; : .UNRESOLVED VOC-LINK @ ÂÅÇÉÎ DUP 4 - UNRESOLVED-WORDS @ ?DUP 0= ÕÎÔÉÌ ; \ ÅXT. VOCS FOR T-COMPILAT. BP27JUN85WE : ÖOCABULARY ÖOCABULARY 0 , HERE TVOC @ , TVOC ! ; ÖOCABULARY ÔRANSIENT 0 TVOC ! ÏNLY DEFINITIONS ÆORTH ALSO : Ô ÔRANSIENT ; IMMEDIATE : È ÆORTH ; IMMEDIATE DEFINITIONS \ ÔRANSIENT PRIMITIVES KS04JUL85WE ÔRANSIENT DEFINITIONS : C@ È >IMAGE ROMOFF C@ ROMON ; : C! È >IMAGE ROMOFF C! ROMON ; : @ Ô DUP C@ SWAP 1+ C@ BYTE> ; : ! >R >BYTE R@ 1+ Ô C! R> C! ; : CMOVE ( FROM.MEM TO.TARGET QUAN -) BOUNDS ?ÄÏ DUP È C@ É Ô C! È 1+ ÌÏÏÐ DROP ; : HERE THERE ; : ALLOT ÔDP +! ; : C, Ô HERE C! 1 ALLOT È ; : , Ô HERE ! 2 ALLOT È ; \ ÔRANSIENT PRIMITIVES BP27JUN85WE : ," ÁSCII " PARSE DUP Ô C, UNDER THERE SWAP CMOVE ALLOT È ; : FILL ( ADDR QUAN 8B -) -ROT BOUNDS ?ÄÏ DUP É Ô C! È ÌÏÏÐ DROP ; : ERASE 0 Ô FILL ; : BLANK ÂÌ Ô FILL ; : HERE! È TDP ! ; \ ÒESOLVING KS29JUN85WE ÆORTH DEFINITIONS : RESOLVE ( CFA.GHOST CFA.TARGET -) OVER DUP @ = ÉÆ SPACE DUP >NAME .NAME ." EXISTS " 2+ ! DROP EXIT ÔÈÅÎ >R >R 2+ @ ?DUP ÉÆ ÂÅÇÉÎ DUP Ô @ È 2DUP = ABORT" RESOLVE LOOP" R@ ROT Ô ! È ?DUP 0= ÕÎÔÉÌ ÔÈÅÎ R> R> OVER ! 2+ ! ; : RESDOES> ( CFA.GHOST CFA.TARGET -) SWAP GDOES> DUP @ = ÉÆ 2+ ! EXIT ÔÈÅÎ SWAP RESOLVE ; ] ÄOES> [ HERE 3 - 0 ] DUP @ THERE ROT ! Ô , È ; ' >BODY ! ] ÄOES> [ HERE 3 - 0 ] @ Ô , È ; ' >BODY ! \ MOVE-THREADS 6502-ALIGN CLV24.3.87) : MOVE-THREADS ÔVOC @ ÔVOC-LINK @ ÂÅÇÉÎ OVER ?DUP ×ÈÉÌÅ 2- @ OVER 2- Ô ! @ È SWAP @ SWAP ÒÅÐÅÁÔ ERROR" SOME UNDEF. ÔARGET-ÖOCS LEFT" DROP ; : TLATEST ( - ADDR) ÃURRENT @ 6 + ; : 6502-TALIGN ( SUPPOSED CFA -- ) 0ÆÆ AND 0ÆÆ = ÉÆ 1 Ô ALLOT È ÔÈÅÎ ; : SAVE-TARGET \ NAME MUST FOLLOW 08 02 BUSOPEN 0 PARSE BUSTYPE " ,P,W" COUNT BUSTYPE BUSOFF 08 02 BUSOUT DISPLACE @ 100 U/MOD SWAP BUS! BUS! THERE DISPLACE @ ÄÏ É Ô C@ È BUS! ÌÏÏÐ 08 02 BUSCLOSE ; \ COMPILING NAMES INTO TARG. 11JUL20PZ : (THEADER ?THEAD @ ÉÆ 1 ?THEAD +! THERE 6502-TALIGN EXIT ÔÈÅÎ >IN @ NAME SWAP >IN ! DUP C@ 1 020 UWITHIN NOT ABORT" INVAL. ÔNAME" DUP C@ 5 + THERE + 6502-TALIGN BLK@ Ô , È THERE TLATEST DUP @ Ô , È ! THERE DUP TLAST ! OVER C@ 1+ DUP Ô ALLOT CMOVE È ; : ÔHEADER TLAST OFF (THEADER ÇHOST DUP GLAST' ! THERE RESOLVE ; \ PREBUILD DEFINING WORDS BP27JUN85WE Ü : EXECUTABLE? ( ADR - ADR F) DUP ; Ü : TPFA, THERE , ; Ü : (PREBUILD ( CFA.ADR -) >IN @ ÃREATE >IN ! HERE 2- ! ; : PREBUILD ( ADR 0.FROM.: - 0) 0 ?PAIRS EXECUTABLE? DUP >R ÉÆ [COMPILE] ÌITERAL COMPILE (PREBUILD ÅÌÓÅ DROP ÔÈÅÎ COMPILE ÔHEADER ÇHOST GDOES> , R> ÉÆ COMPILE TPFA, ÔÈÅÎ 0 ; IMMEDIATE RESTRICT \ CODE PORTION OF DEF.WORDS BP27JUN85WE : DUMMY 0 ; : ÄO> ( - ADR.OF.JMP.DODOES> 0) [COMPILE] DOES> HERE 3 - COMPILE @ 0 ] ; \ THE 6502 ÁSSEMBLER BP27JUN85WE Ü ÃREATE RELOCATE ] Ô C, , C@ HERE ALLOT ! C! È [ ÔRANSIENT DEFINITIONS : ÁSSEMBLER È [ ÁSSEMBLER ] RELOCATE >CODES ! ÁSSEMBLER ; : >LABEL ( 16B -) È >IN @ NAME GFIND ROT >IN ! ÉÆ OVER RESOLVE DUP ÔÈÅÎ DROP ÃONSTANT ; : ÌABEL È THERE Ô >LABEL ÁSSEMBLER È ; : ÃODE È ÔHEADER THERE 2+ Ô , ÁSSEMBLER È ; \ IMMED. RESTR. ' Ü COMPILE BP27JUN85WE : ?PAIRS ( N1 N2 -- ) È - ABORT" UNSTRUCTURED" ; : >MARK ( - ADDR) È THERE Ô 0 , È ; : >RESOLVE ( ADDR -) È THERE OVER - SWAP Ô ! È ; : - CFA) È G' DUP @ - ABORT" ?" 2+ @ ; : Ü È ?THEAD @ ?EXIT ?THEAD ON ; : COMPILE È ÇHOST , ; IMMEDIATE RESTRICT \ ÔARGET TOOLS KS27JUN85WE ÏNLYFORTH ÔTOOLS ALSO DEFINITIONS Ü : TTYPE ( ADR N -) BOUNDS ?ÄÏ É Ô C@ È EMIT ÌÏÏÐ ; : .NAME ( NFA -) ?DUP ÉÆ DUP 1+ SWAP Ô C@ È 01Æ AND TTYPE ÅÌÓÅ ." ??? " ÔÈÅÎ SPACE ?CR ; Ü : NFA? ( CFA LFA - NFA / CFA FF) ÂÅÇÉÎ DUP ×ÈÉÌÅ 2DUP 2+ DUP Ô C@ È 01Æ AND + 1+ = ÉÆ 2+ NIP EXIT ÔÈÅÎ Ô @ È ÒÅÐÅÁÔ ; : >NAME ( CFA - NFA / FF) ÔVOC ÂÅÇÉÎ @ DUP ×ÈÉÌÅ UNDER 2- @ NFA? ?DUP ÉÆ NIP EXIT ÔÈÅÎ SWAP ÒÅÐÅÁÔ NIP ; \ ÔTOOLS FOR DECOMPILING KS29JUN85WE Ü : ?: DUP 4 U.R ." :" ; Ü : @? DUP Ô @ È 6 U.R ; Ü : C? DUP Ô C@ È 3 .R ; : S ( ADR - ADR+) ?: SPACE C? 3 SPACES DUP 1+ OVER Ô C@ È TTYPE DUP Ô C@ È + 1+ ; : N ( ADR - ADR+2) ?: @? 2 SPACES DUP Ô @ È [ ÔTOOLS ] >NAME .NAME È 2+ ; : D ( ADR N - ADR+N) 2DUP SWAP ?: SWAP 0 ÄÏ C? 1+ ÌÏÏÐ 2 SPACES -ROT TTYPE ; \ ÔOOLS FOR DECOMPILING BP29JUN85WE : L ( ADR - ADR+2) ?: 5 SPACES @? 2+ ; : C ( ADR - ADR+1) 1 D ; : B ( ADR - ADR+1) ?: @? DUP Ô @ È OVER + 5 U.R 2+ ; : DUMP ( ADR N -) BOUNDS ?ÄÏ CR É 8 D DROP STOP? ÉÆ ÌÅÁÖÅ ÔÈÅÎ 8 +ÌÏÏÐ ; : VIEW Ô ' È [ ÔTOOLS ] >NAME ?DUP ÉÆ 4 - Ô @ È EDIT ÔÈÅÎ ; \ REINTERPRETATION DEF.-WORDS 27JUN85WE ÏNLYFORTH : REDEFINITION TDOES> @ ÉÆ >IN PUSH [ ' >INTERPRET >BODY ] ÌITERAL PUSH ÓTATE PUSH ÃONTEXT PUSH >IN: @ >IN ! NAME [ ' ÔRANSIENT 2+ ] ÌITERAL (FIND NIP 0= ÉÆ CR ." ÒEDEFINITION: " HERE .NAME >IN: @ >IN ! : ÄEFINING INTERPRET ÔÈÅÎ ÔÈÅÎ 0 TDOES> ! ; \ ÃREATE..DOES> STRUCTURE BP27JUN85WE Ü : (;TCODE ÔLAST @ DUP Ô C@ + 1+ ! È RDROP ; Ü : CHANGECFA COMPILE LIT TDOES> @ , COMPILE (;TCODE ; ÄEFINING DEFINITIONS : ;CODE 0 ?PAIRS CHANGECFA REVEAL RDROP ; IMMEDIATE RESTRICT ÄEFINING ' ;CODE ÁLIAS DOES> IMMEDIATE RESTRICT : ; [COMPILE] ; RDROP ; IMMEDIATE RESTRICT \ REDEFINITION CONDITIONALS BP27JUN85WE ' ÄÏ ÁLIAS ÄÏ IMMEDIATE RESTRICT ' ?ÄÏ ÁLIAS ?ÄÏ IMMEDIATE RESTRICT ' ÌÏÏÐ ÁLIAS ÌÏÏÐ IMMEDIATE RESTRICT ' ÉÆ ÁLIAS ÉÆ IMMEDIATE RESTRICT ' ÔÈÅÎ ÁLIAS ÔÈÅÎ IMMEDIATE RESTRICT ' ÅÌÓÅ ÁLIAS ÅÌÓÅ IMMEDIATE RESTRICT ' ÂÅÇÉÎ ÁLIAS ÂÅÇÉÎ IMMEDIATE RESTRICT ' ÕÎÔÉÌ ÁLIAS ÕÎÔÉÌ IMMEDIATE RESTRICT ' ×ÈÉÌÅ ÁLIAS ×ÈÉÌÅ IMMEDIATE RESTRICT ' ÒÅÐÅÁÔ ÁLIAS ÒÅÐÅÁÔ IMMEDIATE RESTRICT \ CLEAR ÌITER. ÁSCII ['] ." BP27JUN85WE ÏNLYFORTH ÔRANSIENT DEFINITIONS : CLEAR ÔRUE ABORT" ÔHERE ARE GHOSTS" ; : ÌITERAL ( N -) È DUP $ÆÆ00 AND ÉÆ Ô COMPILE LIT , ÅÌÓÅ COMPILE CLIT C, È ÔÈÅÎ ; IMMEDIATE : ÁSCII È ÂÌ WORD 1+ C@ ÓTATE @ ÉÆ Ô [COMPILE] ÌITERAL È ÔÈÅÎ ; IMMEDIATE : ['] Ô ' [COMPILE] ÌITERAL È ; IMMEDIATE RESTRICT : " Ô COMPILE (" ," È ; IMMEDIATE RESTRICT : ." Ô COMPILE (." ," È ; IMMEDIATE RESTRICT \ ÔARGET COMPILATION ] [ BP03JUL85WE ÆORTH DEFINITIONS : TCOMPILE ?STACK >IN @ NAME FIND ?DUP ÉÆ 0> ÉÆ NIP EXECUTE >INTERPRET ÔÈÅÎ DROP DUP >IN ! NAME ÔÈÅÎ GFIND ÉÆ NIP EXECUTE >INTERPRET ÔÈÅÎ NULLSTRING? ÉÆ DROP EXIT ÔÈÅÎ NUMBER? ?DUP ÉÆ 0> ÉÆ SWAP Ô [COMPILE] ÌITERAL ÔÈÅÎ [COMPILE] ÌITERAL È DROP >INTERPRET ÔÈÅÎ DROP >IN ! ×ORD, >INTERPRET ; -2 ALLOT ÔRANSIENT DEFINITIONS : ] È ÓTATE ON ['] TCOMPILE IS >INTERPRET ; \ ÔARGET CONDITIONALS BP27JUN85WE : ÉÆ Ô COMPILE ?BRANCH >MARK È 1 ; IMMEDIATE RESTRICT : ÔÈÅÎ ABS 1 Ô ?PAIRS >RESOLVE È ; IMMEDIATE RESTRICT : ÅÌÓÅ Ô 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE È -1 ; IMMEDIATE RESTRICT : ÂÅÇÉÎ Ô MARK -2 È 2SWAP ; IMMEDIATE RESTRICT Ü : (REPEAT Ô 2 ?PAIRS RESOLVE È ÒÅÐÅÁÔ ; : ÕÎÔÉÌ Ô COMPILE ?BRANCH (REPEAT È ; IMMEDIATE RESTRICT : ÒÅÐÅÁÔ Ô COMPILE BRANCH (REPEAT È ; IMMEDIATE RESTRICT \ ÔARGET CONDITIONALS BP27JUN85WE : ÄÏ Ô COMPILE (DO >MARK È 3 ; IMMEDIATE RESTRICT : ?ÄÏ Ô COMPILE (?DO >MARK È 3 ; IMMEDIATE RESTRICT : ÌÏÏÐ Ô 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE È ; IMMEDIATE RESTRICT : +ÌÏÏÐ Ô 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE È ; IMMEDIATE RESTRICT \ PREDEFINITIONS BP27JUN85WE : ABORT" Ô COMPILE (ABORT" ," È ; IMMEDIATE : ERROR" Ô COMPILE (ERR" ," È ; IMMEDIATE ÆORTH DEFINITIONS ÖARIABLE TORIGIN ÖARIABLE TUDP 0 TUDP ! : >USER Ô C@ È TORIGIN @ + ; \ ÄATATYPES BP27JUN85WE ÔRANSIENT DEFINITIONS : ORIGIN! È TORIGIN ! ; : USER' ( - 8B) Ô ' 2 + C@ È ; : UALLOT ( N -) È TUDP @ SWAP TUDP +! ; ÄO> >USER ; : ÕSER PREBUILD ÕSER 2 Ô UALLOT C, ; ÄO> ; : ÃREATE PREBUILD ÃREATE ; \ ÄATATYPES BP27JUN85WE ÄO> Ô @ È ; : ÃONSTANT PREBUILD ÃONSTANT Ô , ; : ÖARIABLE ÃREATE 2 Ô ALLOT ; DUMMY : ÖOCABULARY È >IN @ ÖOCABULARY >IN ! Ô PREBUILD ÖOCABULARY 0 , 0 , HERE È TVOC-LINK @ Ô , È TVOC-LINK ! ; ÄO> ; : ÄEFER PREBUILD ÄEFER 2 Ô ALLOT ; : ÉS Ô ' È >BODY ÓTATE @ ÉÆ Ô COMPILE (IS , È ÅÌÓÅ Ô ! È ÔÈÅÎ ; IMMEDIATE \ TARGET DEFINING WORDS BP27JUN85WE Ü : DODOES> Ô COMPILE (;CODE È ÇLAST' @ THERE RESDOES> THERE TDOES> ! ; : ;CODE 0 Ô ?PAIRS DODOES> ÁSSEMBLER È [COMPILE] [ REDEFINITION ; IMMEDIATE RESTRICT : DOES> Ô DODOES> $4à C, COMPILE (DODOES> È ; IMMEDIATE RESTRICT DUMMY : : È TDOES> OFF >IN @ >IN: ! Ô PREBUILD : È CURRENT @ CONTEXT ! Ô ] È 0 ; \ : ÁLIAS ; 02OCT87RE : ÁLIAS ( N -- ) È ÔLAST OFF (THEADER ÇHOST OVER RESOLVE TLAST @ Ô C@ È 20 OR TLAST @ Ô C! , È ; : ; Ô 0 ?PAIRS COMPILE UNNEST [COMPILE] [ È REDEFINITION ; IMMEDIATE RESTRICT DUMMY : ÉNPUT: È TDOES> OFF >IN @ >IN: ! Ô PREBUILD ÉNPUT: È CURRENT @ CONTEXT ! Ô ] È 0 ; DUMMY : ÏUTPUT: È TDOES> OFF >IN @ >IN: ! Ô PREBUILD ÏUTPUT: È CURRENT @ CONTEXT ! Ô ] È 0 ; \ PREDEFINITIONS BP03JUL85WE : COMPILE Ô COMPILE COMPILE È ; IMMEDIATE RESTRICT : ÈOST È ÏNLYFORTH ÔTOOLS ALSO ; : ÃOMPILER Ô ÈOST È ÔRANSIENT ALSO DEFINITIONS ; : [COMPILE] È ×ORD, ; IMMEDIATE RESTRICT : ÏNLYPATCH È THERE 3 - 0 TDOES> ! 0 ; ÏNLYFORTH : ÔARGET ÏNLYFORTH ÔRANSIENT ALSO DEFINITIONS ; ÔRANSIENT DEFINITIONS ÇHOST C, DROP \ ÔARGET ÃOMPILER ÍANUAL CLV06DEC88 ÔARGET-ÃOMPILER VOLKSÆÏÒÔÈ 3.8 6502 (C) VOLKSÆÏÒÔÈ-ÄEVELOPERS 1985-2006 AND ÆORTH ÇESELLSCHAFT E.Ö. HTTP://WWW.FORTH-EV.DE \ ..ÇEBRAUCHSANWEISUNG.. CLV05JAN87 1. ÉNTRODUCTION ÔHE ÔARGETCOMPILER IS WEIRD, KRYPTIC AND SOMETIMES DANGEROUS. ÉF AN ERROR OCCURS, REBOOT MACHINE AND START FROM SCRATCH. \ ..ÍANUAL CLV06DEC88 2. ÌOAD 2.1. ÒELOCATE ÓYSTEM ÔHE ÒELOCATE ÓCREEN ON THIS ÄISK CREATS AN ÅNVIRONMENT WITH ÓTACKS ÓTACKLEN $9400 RÓTACKLEN $0400 ÌIMIT MUST BE $C000 WHICH IS DEFAULT FOR Ã64, FOR Ã16 THIS VALUE MUST BE DOWN-PATCHED 2.1. LOAD SAVE-SYSTEM FROM DISK 1 2.2. LOAD ÅDITOR (IF NEEDED) 2.3. ÌOAD ÔARGETCOMPILER WITH ÌOADSCR. FIRST ONLY THE RESIDENT PART 2.4. EXECUTE SAVESYSTEM 2.5. LOAD ÔRAGETCOMPILER PREDEFINITIONS (SEE BOTTOM OF ÌOADSCREEN) AVOLKSFORTH 3.8tc  U3 2A    ÿ\ ..ÍANUAL CLV06DEC88 2.6. LOAD ÓOURCES OF ÆORTH ËERNEL ON A REAL MACHINE, THIS TAKES ABOUT 30 MINUTES! - ÈOST AND ÔARGETMACHINE THE ÓOURCES ARE PREPARED FOR Ã16 & Ã64. ÃHANGE THE DEFINITIONS OF (Ã16 (Ã64 (SEE ÓCREEN AND ÈANDBOOK) - ÂLK ## HERE #### THERE #### WILL BE PRINTED AS STATUS MSG. - VARIOUS EXISTS ÍESSAGES ARE OK - AT THE ÅND ÓÁÖÅÓÙÓÔÅÍ WILL BE PRINTED. ÃHANGE ÄISK! AND THEN PRESS TO SAVE NEW ÆORTH ÓYSTEM \\ ..ÅXAMPLE SESSION CLV06DEC88 3. ÅXAMPLE FOR ÃÂÍ ÐLUS 4 ÕSED ÄISKS: 1OF4 .. 4OF4 - VOLKSÆORTH ÄISKS 3.8 ÔÃQ - ÔARGETÃOMP ÓOURCE ÔÃF - " ÆILES (EMPTY) 3.1. ÃREATE A ÔARGETCOMPILER ÓYSTEM ÓWITCH ON ÐLUS4, INSERT ÄISK 1OF4 ÄÉÒÅÃÔÏÒÙ -> ... ÌÏÁÄ "Ã16ÕÌÔÒÁÆÏÒÔÈ83",8 -> SEARCHING... LOADING...READY. ÒÕÎ -> ULTRAÆÏÒÔÈ ... OK \\ ..ÅXAMPLE ÓESSION CLV06DEC88 INSERT ÄISK ÔÃQ 4 LOAD FLUSH \ RELOCATE -> VOLKSÆÏÒÔÈ83 ... OK INSERT ÄISK 3OF4 19 LOAD FLUSH \ ÅDITOR -> BLK 4 BLK 5 ...... OK \ APPR5 MIN INSERT ÄISK 1OF4 26 LOAD FLUSH \ SAVESYSTEM INSERT ÄISK ÔÃQ $10 LOAD FLUSH \ ÔÃ-RESIDENT ÐART INSERT ÄISK ÔÃF SAVESYSTEM @:VF-TC-3.8 -> OK ÉF ÆLOPPY FLASHES: ÅRROR \ @: IS: OVERWRITE IF NEEDED \ THIS FILE WILL LATER REPLACE \ THE RUNNING ÆORTH ÓYSTEM \\ ..ÅXAMPLE ÓESSION CLV06DEC88 3.2. ÃOMPILING A NEW ÓYSTEM FIRST AS FOR 3.1. OR: ÌÏÁÄ "VF-TC-3.8",8 -> SEARCHING...LOADING..READY. ÒÕÎ -> VOLKSÆÏÒÔÈ83 ... OK INSERT ÄISK ÔÃQ HEX 27 30 THRU FLUSH \ LOAD TRANSIENT ÐART OF Ôà INSERT ÄISK 2OF4 (ÆORTH ÓOURCE) $09 L \ EDIT ÓCREEN 9 (C64 (C16 (C16+ (C16- (COMMENT IN OR OUT DEPEND. ON ÔARGET-ÍASCHINE $F LOAD \ COMPILE SYSTEM INSERT ÔÃF OR BLANK DISK SAVETARGET C16ULTRAFORTH83 OR SAVETARGET C64ULTRAFORTH83 - ÅÎÄÅ - \\ ÔERMS: ÈOST 'NORMAL' ÆORTH-ÓYSTEM IN ÍACHINE ÔARGET ÓYSTEM TO BE COMPILED ÔRANSIENT ÖOCABULARY FOR Ô-ÃOMPILATION IN ÈOST NEEDS THE ÓPECIALASSEMBLER FOR Ôà 'NORMAL' ÁSSEMBLER ÓTARTADDRESS OF ÔARGET ÓYSTEMS IN ÈOST ÔOOLS FOR ÔARGET-ÓYSTEM ×ORDS FOR ÒEDEFINITIONS \\ ÔARGET-DP HERE IN ÔARGET ÓTARTADDRESS OF ÔARGET-ÓYSTEMS ÉF 0, WE CREATE HEADER IN ÔARGET NFA OF LAST CREATED WORD CFA OF LAST CREATED GHOST CFA OF ÃODE FOR ÄOES>-ÐARTS ÁDDRESS OF LAST : IN ÂLOCK ÔVOC-ÌINK FOR ÈOST ÔVOC-ÌINK FOR ÔARGET \\ SWITCHES TO ÒÁÍ UNDER ÏÓ SWITCHES ÂACK CALCULATES PHYSICAL ÁDDRESS FROM TARGET ÁDDRESS CMOVE TO ÈEAP WITH AUTOMATIC HALLOT >IMAGE MUST BE ADJUSTED WHEN CHANGING MEMORY MANAGENT FOR TARGET SYSTEM SAME WITH C@ AND C! \\ POINTS TO CODE FOR FORWARD POINTS TO CODE FOR RESOLVED IF COMPILING, ÇHOST WILL BE LINKED UNDER(!) LAST ÃONTEXT ×ORD ELSE APPENDED TO ÃURRENT AS NORMAL LFA ÇHOST POINTS TO LAST WORD (S.A) GET NAME AND CHECKS FOR VALID LENGTH ENLARGES NAME BY ONE BLANK CALCULATES NAMELENGTH ( LEN START LINK) CF.ÇHOST, CFA.ÔARGET, ÐTR TO ÄOES>.CFA 6502-ALIGN CMOVED ÇHOST ON ÈEAP LAST WORD POINTS NOT TO ÇHOST CACLCULATES CFA.GHOST ÌAST (ÃURRENT @) WILL BE LINKED TO ; IN REVEAL \\ SEARCH FOR GHOST SEARCH FOR GHOST IF FOUND, FINISH IF NOT FOUND, IT WILL BE CREATED STORES CFA.GHOST ( OR ) ÁDR OF ÐTR TO ÄOES>.CFA IF EXISTING, CFA OF ÄOES> ELSE CREATE ÐÔÒ AND SEE ABOVE >HEAP STARTS ON EVEN ADDRESSES => 6502-ALIGN \\ GETS CFA OF ÇHOST GET STATE OF GHOST, IF FORWARD REFERENCE OR ALREADY RESOLVED (WITH CFA.ÔARGET) SAME FOR POSSIB. ÄOES>-ÐARTS WHILE ÔARGET-ÃOMPILATION ' WILL BE DONE FOR ÇHOSTS \\ IF CF = AND AN ÁDDRESS EXISTS IN ÔARGET ÓYSTEM EXIT UNRESOLVED? WITH ÔRUE-ÆLAG CHECKS IF NAME IS A ÇHOST GETS CFA AND CHECKS FOR UNRESOLVED SAME WITH ÄOES>-ÐART PRINT FOR ÖOCABULARY ALL UNRESOLVED WORDS SEARCH THROUGH ALL ÖOCABULARIES PRINT NON-RESOLVED WORDS \\ ÖOCABULARY STRUCTURE: ÎAME ÂYTES ÃODE FUER ÖOCABULARYS ÌATEST 0 1 ÃOLD-ÌATEST 2 3 NORMAL ÖOC-LINK 4 5 ------------------- ÔLATEST 6 7 ADDITIONAL ÔVOC-LINK 8 9 Ô AND È ARE ÉMMEDIATE AND REPLACING [ ÔRANSIENT ] OR [ ÆORTH ] È => ÈOST \\ ×ORDS FOR ÔARGET-ÃOMPILATION ×ORDS FOR VIRTUAL ÔARGET-ÍEMORY Ô C@ ACCES ÒÁÍ BELOW ÏÓ Ô C! ALSO ÁLL FOLLOWING WORDS USE C@ AND C! CMOVE WORKS ONLY FROM ÈOST TO ÔARGET, NOT OTHER DIRECTION ÏN CHANGES TO THE VIRTUAL ÍEMORY- ÍANAGEMENT, C@, C! AND >IMAGE MUST BE ADJUSTED! \\ ×ORDS FOR ÔARGET-ÃOMPILATION \\ RESOLVES FORWARD REFERENCES CHECKS, IF ALREADY RESOLVED PRINT WARNING IF YES SET CFA.TARGET TO NEW VALUE, ÅND ÆORWARDREFERENCE AVAILABLE ? ÙES, GET ADDRESS IN ÔARGET ÃANCEL, IF POINTING TO ITSELF AND SET CFA.TARGET UNTIL ÅND CFA.TARGET TO CFA.GHOST AND RESOLVED AS CF.TARGET SAME FOR ÄOES>-ÐARTS ÄOES> COMPILES A ÊÍÐ (DODOES> (DODOES> BRINGS THE ON CFA.GHOST FOLLLOWING ADDRESS, WHICH IS CFA.TARGET, ON THE STACK CFA.GHOST IS EITHER OR CFA.TARGET IS THE CFA IN ÔARGET-ÓYSTEM ALSO OR ALREADY VALID \\ FOR ALL ÖOCABLUARIES IN ÔRANSIENT AND ÔARGET SET ÔARGET-ÃOLD-ÌATEST TO ÔRANSIENT-ÔLATEST ÅRROR, IF ÔVOC-LINK ALSO POINTS TO OTHER ÖOCABULARYS ÐOINTS TO ÔLATEST IN ÔRANSIENT-ÖOCS SAVES A ÔARGETSYSTEM AS ÐROGRAMM- FILE ON ÄISK (Ã64-ÓPECIAL!!) \\ IF 0, ÈEADER, ELSE ?THEAD INCREMENT 6502-ALIGN AND ÅNDE GETS ÎAME AN CONVERTS TO CAPITAL ÅRROR ON WRONG LENGTH CALULATES CFA AND 6502-ALIGN ÂLOCKNUMBER FOR VIEW LINK IN OF NEW NAME IN ÃURRENT ÔLAST FOR IMMEDIATE AND RESTRIC CREATE SAVE ÎAME IN ÔARGET SET ÔLAST TO 0 CREATE ÈEADER, CREATE ÇHOST, IF NEW, CFA.GHOST TO ÇLAST' AND RESOLVE \\ ON ÃREATE, ÕSER, ÃONSTANT, ÖARIABLE AND ÄEFER, NOT FOR : UND ÖOCABULARY COMPILING ÐTR TO PFA.TARGET IN ÈOST CREATES ÈEADER IN ÈOST WITH CFA.ADR ÔHIS POINTS TO A ÄOES>-ÐART IN ÔARGET (S.BELOW) FROM: IF CREATED WORD SHOULD BE EXECUTABLE IN CURRENT, CREATE A HEADER ELSE NOT WITH CORRESPONDING CFA ELSE NOT CREATE HEADER IN ÔARGET AND COMPILE AS CFA OF ÄOES>-ÐART STORE THIS ADDRESS IN ÈOST AS PDF PREBUILD IS A ÄEFINING-×ORD FOR ÄEFINING-×ORDS !! \\ RESULTS THAT WITH FOLLWING ÄEFINING-×ORD CREATED WORDS CANNOT BE EXECUTED ÓPECIAL-ÄOES> FOR ×ORDS CREATED IN ÃURRENT, GIVES PFA IN ÔARGET ! ÄO> ... ; : ... ÂUILD ... ; SAME AS ÃREATE ... ÄOES> : ÄO> [COMPILE] DOES> HERE 3 - 0 ] ; : (BUILD ÃREATE HERE 2- ! ; : ÂUILD (CFA 0 - 0) 0 ?PAIRS [COMPILE] ÌITERAL COMPILE (BUILD 0 ; \\ ÁSSEMBLER ASSEMBLES IN ÔARGET NOW ENABLES ÁSSEMBLER AND RELOCATE IF LABEL ALREADY EXISTS AS ÇHOST, RESOLVE FORWARD REFERENCE AS ÃONSTANT IN ÈOST ÌABEL POINTS TO THERE ÓPECIAL-ÃODE FOR ÔARGET \\ ÃONTROLSTRUCTURES FOR ÔARGET-ÓYSTEM ' IN ÔRANSIENT ACCESSES ÇHOSTS AND GETS CFA.TARGET ÔHE NEXT WORD WILL BE CREATED WITHOUT HEADER WORKS ON ÈOST, NOT ON ÔARGET \\ ÔOOLS FOR ÔARGET-ÓYSTEM SIMILAR TO NORMAL TOOLS PRINTS N CHARS AT ADDR PRINTS NAME OF WORD, IF NFA <>0 ELSE ??? CHECKS, IF LFA NFA OF CFA IS AND RETURNS NFA, ELSE CFA AND FF CONVERTS CFA IN NFA, IF POSSIBLE \\ ÔOOLS FOR ÔARGET-ÓYSTEM SIMILAR TO NORMAL TOOLS PRINTS STRING AT ADR AND ADJUSTS ADR PRINT NAME OF COMPILE WORD AND ADJUST ADR PRINTS N BYTES FROM ADR AND ADJUSTS ADR \\ ÔOOLS FOR ÔARGET-ÓYSTEM PRINTS N ÂYTES AT ADR, LIKE D, BUT NICE FORMATTED DISPLAYS ÓOURCECODESCREEN OF WORD \\ ALLOWS EXECUTION OF NEW CREATED DEFINING WORDS DURING TARGET COMPILATION IS ;CODE OR DOES> ? YES, SAVE SYSTEMSTATE >IN TO BEGIN OF LAST ÃOLONDEF. NO AS PREDEFINITION IN ÔRANSIENT AVAILABLE? YES, PRINT "ÒEDEFINITION: " AND LAST ÎAMES >IN ADJUST, ÆORTH-: EXECUTE AND SWITCH ON ÄEFININING AS ÃONTEXT RESET TDOES> \\ CHANGES THE CFA OF LST DEFINED WORD TO ÄOES>-ÐART IN ÔARGET COMPILES, WHICH COMPILES THE ADR OF ÄOES>-PART AND (;CODE WHEN EXECUTED ;CODE AND ÄOES> MUST BE DEFINED IN REDEF SAME AS ÄO> FOR PREBUILD STORES LAST WORD IN ÈOST AND JUMPS IN REDEFINITION BEHIND INTERPRET ÓTRUCTUR OF A IN ÈOST CREATED WORD: LFA\NAME\CFA TO JMP (DOEDOES\PFA TO ÄOES>-ÐART IN ÔARGET ×ORDS, CREATED BY ÒEDEFINITION OF ÄEFINING ×ORDS, RETURN THEIR ÐÆÁ, WHEN EXECUTED IN ÈOST \\ ÆORTH-ÃONTROLLSTRUCTURES, BECAUSE ÔRANSIENT WILL FIND WORDS FOR ÔARGET \\ ÐREDEFINITIONS ×ORDS THAT MUST BE EXECUTABLE IN ÔRANSIENT \\ MAIN ÃOMPILELOOP SEARCH FOR NAMES IN ÔRANSIENT AND ÆORTH FOUND, EXECUTE, IF IMMEDIATE ELSE RESET >IN SEARCH ÇHOST AND EXDCUTE CFA ÎUMBER?, IF YES, EXECUTE ÌITERAL (Ô!) CREATE NEW GHOST AND COMPILE FORWARD REFERENCE ENABLE ÃOMPILER, SET >INTERPRET FROM TCOMPILE \\ ÃONDITIONALS FOR ÔARGET-ÃOMPILATION \\ ÃONDITIONALS FOR ÔARGET-ÃOMPILATION \\ ÉMMEDIATE-×ORDS FOR ÔARGET ORIGIN IN TARGET UDP IN TARGET CALCULATES ÁDDRESS IN ÕSER-ÁREA FROM ÁDDRESS OF ÏFFSET \\ ÕSER-ÖARIABLE ARE ALSO EXECUTABLE IN ÔRANSIENT AND RETURN ÔARGET-ÁDDRESSES ×ITG ÃREATE COMPILED ×ORDS ARE EXECUT- ABLE IN ÔRANSIENT AND RETURN THE PFA.TARGET \\ ÁLSO ÃONSTANT AND ÖARIABLE CAN BE EXECUT ED IN ÔRANSIENT AND REZTURN THE ÔARGET ÖALUES ÖOCABULARYS ARE EXECUTABLE IN TRANSIENT ÖOCABULARY 'NAME' CREATED: 1. Á ÖOCABULARY ÅNTRY IN ÃURRENT WITH 5 FIELDS CONNECTED ON TVOC 2. Á ÖOCABULARY ÅNTRY IN ÃURRENT WITH 3 ÆIELDS CONNECTED ON TVOC-LINK 3. Á ÇHOST \\ CREATES A ÖARIABLE-HEADER SAME AS ÉS IN ÆORTH CREATES ÃODE KILE ;CODE IN ÆORTH ÆORWARDREFERNCE FOR ÄOES>-ÐART WILL RESOLVED AND TDOES> SET FOR REDEFINITION LIKE ;CODE IN ÆORTH, BUT WITH REDEFINITI ON LIKE ÄOES> IN ÆORTH, BUT WITH DODOES> \\ DISABLE REDEFINITION CREATE SMALL ENTRY IN ÔRANSIENT FOR WITH : CREATED WORDS SET ÃONTEXT TO FIRST FIX ÖOC CREATE ÈEADER IN ÔARGET AND RESOLVE FORWARD-REFERNCE WITH ÁLIAS-CFA SAME AS HIDE IN ÆORTH SAME AS ; IN ÆORTH, AND REDEFINITION IS STARTED \\ CREATES COMPILE AS FORWARDREFERNCE !! SET ORDER TO: ÔTOOLS ÔTOOLS ÆORTH ÏNLY AS ÈOST, ORDER: ÔRANSIENT ÔRANSIENT ÔTOOLS ÆORTH ÏNLY COMPILS THE CFA.TARGET OF ÇHOSTS ÓPECIAL-ÃODE FOR ÏNLY-ÖOCABULARY SET ORDER FOR ÔARGET-ÃOMPILATION: ÔRANSIENT ÔRANSIENT ÆORTH ÏNLY ÔHANKS TO ËLAUS FOR 'PUNCTUATION?' !!! \ No newline at end of file diff --git a/6502/C64/disks/tc38q.fth b/6502/C64/disks/tc38q.fth index 463b343..362de15 100644 --- a/6502/C64/disks/tc38q.fth +++ b/6502/C64/disks/tc38q.fth @@ -449,12 +449,15 @@ Code cSave ( f t+1 Name Nlen dev--err) \ *** Block No. 16, Hexblock 10 -\ Target compiler loadscr clv14oct87 +\ Target compiler loadscr 11jul20pz \ Idea and first Implementation by ks/bp \ Implemented on 6502 by ks/bp \ volksFORTH83-Version by bp/we Onlyforth hex +: (blk@ blk @ ; +Defer blk@ ' (blk@ is blk@ + \needs (16 .( ?! (16 (64 ?! C) quit Assembler \needs nonrelocate 5 load Assembler nonrelocate @@ -472,9 +475,6 @@ clear \ hex 17 20 +thru \ predefinitions - - - \ *** Block No. 17, Hexblock 11 \ Target header pointers bp27jun85we @@ -785,7 +785,7 @@ Forth definitions \ *** Block No. 28, Hexblock 1c -\ compiling names into targ. bp27jun85we +\ compiling names into targ. 11jul20pz : (theader ?thead @ IF 1 ?thead +! @@ -794,7 +794,7 @@ Forth definitions dup c@ 1 020 uwithin not abort" inval. Tname" dup c@ 5 + there + 6502-talign - blk @ T , H + blk@ T , H there tlatest dup @ T , H ! there dup tlast ! over c@ 1+ dup T allot cmove H ; diff --git a/6502/C64/emulator/build-vf.sh b/6502/C64/emulator/build-vf.sh index cf4d611..0493029 100755 --- a/6502/C64/emulator/build-vf.sh +++ b/6502/C64/emulator/build-vf.sh @@ -13,9 +13,10 @@ basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")" source="$1" target="$2" -rm -f "${basedir}/cbmfiles/${target}" +test -n "$target" && rm -f "${basedir}/cbmfiles/${target}" keybuf="include ${source}\nsave-target ${target}\ndos s0:notdone\n" +test -z "$target" && keybuf="include ${source}\n" DISK9=vforth4_2 DISK10=tc38q "${emulatordir}/run-in-vice.sh" \ "tcbase" "${keybuf}" diff --git a/6502/C64/src/vf-c16-32k.fth b/6502/C64/src/vf-c16-32k.fth index 075599e..681c7a1 100644 --- a/6502/C64/src/vf-c16-32k.fth +++ b/6502/C64/src/vf-c16-32k.fth @@ -6,8 +6,9 @@ hex 1 drive Onlyforth hex - c load \ clear memory and - d e thru \ clr labels .status +\ clear memory and clr labels .status +include vf-tc-prep.fth + \ *** Block No. 9, Hexblock 9 diff --git a/6502/C64/src/vf-c16-main.fth b/6502/C64/src/vf-c16-main.fth index 2bb8569..5699797 100644 --- a/6502/C64/src/vf-c16-main.fth +++ b/6502/C64/src/vf-c16-main.fth @@ -6,8 +6,9 @@ hex 1 drive Onlyforth hex - c load \ clear memory and - d e thru \ clr labels .status +\ clear memory and clr labels .status +include vf-tc-prep.fth + \ *** Block No. 9, Hexblock 9 diff --git a/6502/C64/src/vf-c64-main.fth b/6502/C64/src/vf-c64-main.fth index 1ee019a..602d5a1 100644 --- a/6502/C64/src/vf-c64-main.fth +++ b/6502/C64/src/vf-c64-main.fth @@ -6,8 +6,9 @@ hex 1 drive Onlyforth hex - c load \ clear memory and - d e thru \ clr labels .status +\ clear memory and clr labels .status +include vf-tc-prep.fth + \ *** Block No. 9, Hexblock 9 diff --git a/6502/C64/src/vf-finalize.fth b/6502/C64/src/vf-finalize.fth new file mode 100644 index 0000000..c4c128e --- /dev/null +++ b/6502/C64/src/vf-finalize.fth @@ -0,0 +1,82 @@ + +\ *** Block No. 123, Hexblock 7b +7b fthpage + +\ The remainder to do after loading the +\ system-dependent part of the sources. + +Host ' Transient 8 + @ + Transient Forth Context @ 6 + ! +Target + +Forth also definitions + +(C16 : (64 ) \ jumps belhind C) +(C64 : (16 ) + BEGIN name count 0= abort" C) missing" + @ [ Ascii C Ascii ) $100 * + ] Literal + = UNTIL ; immediate + +: C) ; immediate + +(C16 : (16 ) (C64 : (64 ) ; immediate + +: forth-83 ; \ last word in Dictionary + + + +\ *** Block No. 124, Hexblock 7c +7c fthpage + +( System dependent Constants bp/ks) + +Vocabulary Assembler +Assembler definitions +Transient Assembler + +PushA Constant PushA + \ put A sign-extended on stack +Push0A Constant Push0A + \ put A on stack +Push Constant Push + \ MSB in A and LSB on jsr-stack + +RP Constant RP +UP Constant UP +SP Constant SP +IP Constant IP +N Constant N +Puta Constant Puta +W Constant W +Setup Constant Setup +Next Constant Next +xyNext Constant xyNext +(2drop Constant Poptwo +(drop Constant Pop + +\ *** Block No. 125, Hexblock 7d +7d fthpage + +\ System patchup clv06aug87 + +Forth definitions + +(C64 C000 ' limit >body ! 7B00 s0 ! 7F00 r0 ! ) + +(C16 8000 ' limit >body ! 7700 s0 ! 7b00 r0 ! ) + +\ (C16+ fd00 ' limit >body ! +\ 7B00 s0 ! 7F00 r0 ! ) + +s0 @ dup s0 2- ! 6 + s0 7 - ! +here dp ! + +Host Tudp @ Target udp ! +Host Tvoc-link @ Target voc-link ! +Host move-threads + +\ Final part of loadscreen + +Assembler nonrelocate + +.unresolved diff --git a/6502/C64/src/vf-main.fth b/6502/C64/src/vf-main.fth index 7430516..c2b2840 100644 --- a/6502/C64/src/vf-main.fth +++ b/6502/C64/src/vf-main.fth @@ -2,17 +2,12 @@ include vf-pr-target.fth -Onlyforth +include vf-sys-indep.fth -(C64 $801 ) (C16 $1001 ) dup displace ! +$7E $93 thru \ CBM-Interface +(c16+ $94 load ) \ c16init RamIRQ -Target definitions here! - -$10 $7D thru - -Assembler nonrelocate - -.unresolved +include vf-finalize.fth ' .blk is .status diff --git a/6502/C64/src/vf-sys-indep.fth b/6502/C64/src/vf-sys-indep.fth new file mode 100644 index 0000000..2bb6293 --- /dev/null +++ b/6502/C64/src/vf-sys-indep.fth @@ -0,0 +1,2999 @@ +\ The main and mostly system independent part of CBM VolkForth + +\ Initial part of load screen + +Onlyforth + +(C64 $801 ) (C16 $1001 ) dup displace ! + +Target definitions here! + + +\ *** Block No. 16, Hexblock 10 +10 fthpage + +\ FORTH Preamble and ID clv06aug87 + +(C64 $D c, $8 c, $A c, 00 c, 9E c, 28 c, 32 c, 30 c, ) +(C64 36 c, 34 c, 29 c, 00 c, 00 c, 00 c, 00 c, ) \ SYS(2064) +(C16 $D c, 10 c, $A c, 00 c, 9E c, 28 c, 34 c, 31 c, ) +(C16 31 c, 32 c, 29 c, 00 c, 00 c, 00 c, 00 c, ) \ SYS(4112) + +Assembler + nop 0 jmp here 2- >label >cold + nop 0 jmp here 2- >label >restart + +here dup origin! +\ Here are coldstart- and Uservariables +\ +0 jmp 0 jsr here 2- >label >wake + end-code +$100 allot + +Create logo + (C64 ," volksFORTH-83 3.80.1-C64 " ) + (C16+ ," volksFORTH-83 3.80.1-C16+ " ) + (C16- ," volksFORTH-83 3.80.1-C16- " ) + + +\ *** Block No. 17, Hexblock 11 +11 fthpage + +( Zero page Variables & Next 03apr85bp) + +02 dup >label RP 2+ + dup >label UP 2+ + + dup >label Puta 1+ + dup >label SP 2+ + dup >label Next + dup 5 + >label IP + 13 + >label W + + W 8 + >label N + + +\ *** Block No. 18, Hexblock 12 +12 fthpage + +( Next, moved into Zero page 08apr85bp) + +Label Bootnext + -1 sta \ -1 is dummy SP + IP )Y lda W 1+ sta + -1 lda W sta \ -1 is dummy IP + clc IP lda 2 # adc IP sta + CS not ?[ Label Wjmp -1 ) jmp ]? + IP 1+ inc Wjmp bcs +end-code + +here Bootnext - >label Bootnextlen + +Code end-trace ( Patch Next for trace ) + $A5 # lda Next $A + sta + IP # lda Next $B + sta + $69 # lda Next $C + sta + 2 # lda Next $D + sta + Next jmp end-code + + +\ *** Block No. 19, Hexblock 13 +13 fthpage + +\ ;c: noop 02nov87re + +Create recover ( -- adr ) Assembler + pla W sta pla W 1+ sta + W wdec 0 jmp end-code + +here 2- >label >recover +\ handcrafted forward reference for +\ jmp command + +Compiler Assembler also definitions + H : ;c: 0 T recover jsr + end-code ] H ; +Target + +Code noop Next here 2- ! end-code + + + + + + + + + + +\ *** Block No. 20, Hexblock 14 +14 fthpage + +\ User variables clv14oct87 + +Constant origin 8 uallot drop + \ For multitasker + +User s0 $7CFA s0 ! +User r0 $7FFE r0 ! +User dp +User offset 0 offset ! +User base &10 base ! +User output +User input +User errorhandler + \ pointer for Abort" -code +User voc-link +User udp + \ points to next free addr in User + + + + + + + + + +\ *** Block No. 21, Hexblock 15 +15 fthpage + +( manipulate system pointers 29jan85bp) + +Code sp@ ( -- addr) + SP lda N sta SP 1+ lda N 1+ sta + N # ldx +Label Xpush + SP 2dec 1 ,X lda SP )Y sta + 0 ,X lda 0 # ldx Puta jmp end-code + +Code sp! ( addr --) + SP X) lda tax SP )Y lda + SP 1+ sta SP stx 0 # ldx + Next jmp end-code + +Code up@ ( -- addr) + UP # ldx Xpush jmp end-code + +Code up! ( addr --) UP # ldx +Label Xpull SP )Y lda 1 ,X sta + dey SP )Y lda 0 ,X sta +Label (xydrop 0 # ldx 1 # ldy +Label (drop SP 2inc Next jmp +end-code restrict + + + +\ *** Block No. 22, Hexblock 16 +16 fthpage + +( manipulate returnstack 16feb85bp/ks) + +Code rp@ ( -- addr ) + RP # ldx Xpush jmp end-code + +Code rp! ( addr -- ) + RP # ldx Xpull jmp end-code restrict + +Code >r ( 16b -- ) + RP 2dec SP X) lda RP X) sta + SP )Y lda RP )Y sta (drop jmp +end-code restrict + +Code r> ( -- 16b) + SP 2dec RP X) lda SP X) sta + RP )Y lda SP )Y sta +Label (rdrop 2 # lda +Label (nrdrop clc RP adc RP sta + CS ?[ RP 1+ inc ]? + Next jmp end-code restrict + + + + + + +\ *** Block No. 23, Hexblock 17 +17 fthpage + +\ r@ rdrop exit ?exit clv12jul87 + +Code r@ ( -- 16b) + SP 2dec RP )Y lda SP )Y sta + RP X) lda Puta jmp +end-code + +Code rdrop (rdrop here 2- ! +end-code restrict + +Code exit + RP X) lda IP sta + RP )Y lda IP 1+ sta + (rdrop jmp end-code +Code unnest + RP X) lda IP sta + RP )Y lda IP 1+ sta + (rdrop jmp end-code + +Code ?exit ( flag -- ) + SP X) lda SP )Y ora + php SP 2inc plp + ' exit @ bne Next jmp +end-code + + +\ *** Block No. 24, Hexblock 18 +18 fthpage + +( execute perform 08apr85bp) + +Code execute ( addr --) + SP X) lda W sta + SP )Y lda W 1+ sta + SP 2inc W 1- jmp end-code + +: perform ( addr -- ) @ execute ; + + + + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 +19 fthpage + +( c@ c! ctoggle 10jan85bp) + +Code c@ ( addr -- 8b) + SP X) lda N sta SP )Y lda N 1+ sta +Label (c@ 0 # lda SP )Y sta + N X) lda Puta jmp end-code + +Code c! ( 16b addr --) + SP X) lda N sta SP )Y lda N 1+ sta + iny SP )Y lda N X) sta dey +Label (2drop + SP lda clc 4 # adc SP sta + CS ?[ SP 1+ inc ]? + Next jmp end-code + +: ctoggle ( 8b addr --) + under c@ xor swap c! ; + + + + + + + + + +\ *** Block No. 26, Hexblock 1a +1a fthpage + +( @ ! +! 08apr85bp) + +Code @ ( addr -- 16b) + SP X) lda N sta SP )Y lda N 1+ sta + N )Y lda SP )Y sta + N X) lda Puta jmp end-code + +Code ! ( 16b addr --) + SP X) lda N sta SP )Y lda N 1+ sta + iny SP )Y lda N X) sta + iny SP )Y lda 1 # ldy +Label (! + N )Y sta (2drop jmp end-code + +Code +! ( n addr --) + SP X) lda N sta SP )Y lda N 1+ sta + iny SP )Y lda clc N X) adc N X) sta + iny SP )Y lda 1 # ldy N )Y adc + (! jmp end-code + + + + + + + +\ *** Block No. 27, Hexblock 1b +1b fthpage + +( drop swap 24may84ks) + +Code drop ( 16b --) + (drop here 2- ! end-code + +Code swap ( 16b1 16b2 -- 16b2 16b1 ) + SP )Y lda tax + 3 # ldy SP )Y lda N sta + txa SP )Y sta + N lda 1 # ldy SP )Y sta + iny 0 # ldx + SP )Y lda N sta SP X) lda SP )Y sta + dey + N lda Puta jmp end-code + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c +1c fthpage + +( dup ?dup 08may85bp) + +Code dup ( 16b -- 16b 16b) + SP 2dec + 3 # ldy SP )Y lda 1 # ldy SP )Y sta + iny SP )Y lda dey + Puta jmp end-code + +Code ?dup ( 16b -- 16b 16b / false) + SP X) lda SP )Y ora + 0= ?[ Next jmp ]? + ' dup @ jmp end-code + + +\ : ?dup ( 16b -- 16b 16b / false) +\ dup IF dup THEN ; +\ +\ : dup Sp@ @ ; + + +\ *** Block No. 29, Hexblock 1d +1d fthpage + +( over rot 13jun84ks) + +Code over ( 16b1 16b2 - 16b1 16b3 16b1) + + SP 2dec 4 # ldy SP )Y lda SP X) sta + iny SP )Y lda 1 # ldy SP )Y sta + Next jmp end-code + +Code rot + ( 16b1 16b2 16b3 -- 16b2 16b3 16b1) + 3 # ldy SP )Y lda N 1+ sta + 1 # ldy SP )Y lda 3 # ldy SP )Y sta + 5 # ldy SP )Y lda N sta + N 1+ lda SP )Y sta + 1 # ldy N lda SP )Y sta + iny SP )Y lda N 1+ sta + SP X) lda SP )Y sta + 4 # ldy SP )Y lda SP X) sta + N 1+ lda SP )Y sta + 1 # ldy Next jmp end-code + +\ : rot >r swap r> swap ; +\ : over >r dup r> swap ; + + + +\ *** Block No. 30, Hexblock 1e +1e fthpage + +( -rot nip under pick roll 24dec83ks) + +: -rot + ( 16b1 16b2 16b3 -- 16b3 16b1 16b2) + rot rot ; + +: nip ( 16b1 16b2 -- 16b2) + swap drop ; + +: under ( 16b1 16b2 -- 16b2 16b1 16b2) + swap over ; + +: pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; + +: roll ( n --) + dup >r pick sp@ dup 2+ r> 1+ 2* cmove> + drop ; + +\ : -roll ( n --) +\ >r dup sp@ dup 2+ dup 2+ swap +\ r@ 2* cmove r> 1+ 2* + ! ; + + +\ *** Block No. 31, Hexblock 1f +1f fthpage + +( double word stack manip. 21apr83ks) + +: 2swap ( 32b1 32b2 -- 32b2 32b1) + rot >r rot r> ; + +Code 2drop ( 32b -- ) + (2drop here 2- ! end-code + +\ : 2drop ( 32b -- ) drop drop ; + +: 2dup ( 32b -- 32b 32b) + over over ; + + + + + + + + + + + + + + +\ *** Block No. 32, Hexblock 20 +20 fthpage + +( + and or xor 08apr85bp) + +Compiler Assembler also definitions + +H : Dyadop ( opcode --) T + iny SP X) lda dup c, SP c, + SP )Y sta + dey SP )Y lda 3 # ldy c, SP c, + SP )Y sta + (xydrop jmp H ; + +Target + +Code + ( n1 n2 -- n3) + clc $71 Dyadop end-code + +Code or ( 16b1 16b2 -- 16b3) + $11 Dyadop end-code + +Code and ( 16b1 16b2 -- 16b3) + $31 Dyadop end-code + +Code xor ( 16b1 16b2 -- 16b3) + $51 Dyadop end-code + + +\ *** Block No. 33, Hexblock 21 +21 fthpage + +( - not negate 24dec83ks) + +Code - ( n1 n2 -- n3) + iny SP )Y lda sec SP X) sbc SP )Y sta + iny SP )Y lda + 1 # ldy SP )Y sbc 3 # ldy SP )Y sta + (xydrop jmp end-code + +Code not ( 16b1 -- 16b2) clc +Label (not + txa SP X) sbc SP X) sta txa + SP )Y sbc SP )Y sta + Next jmp end-code + +Code negate ( n1 -- n2 ) + sec (not bcs end-code + +\ : - negate + ; + + + + + + + + +\ *** Block No. 34, Hexblock 22 +22 fthpage + +( dnegate setup d+ 14jun84ks) + +Code dnegate ( d1 -- -d1) + iny sec + txa SP )Y sbc SP )Y sta iny + txa SP )Y sbc SP )Y sta + txa SP X) sbc SP X) sta 1 # ldy + txa SP )Y sbc SP )Y sta + Next jmp end-code + +Label Setup ( quan in A) + .A asl tax tay dey + [[ SP )Y lda N ,Y sta dey 0< ?] + txa clc SP adc SP sta + CS ?[ SP 1+ inc ]? + 0 # ldx 1 # ldy rts end-code + +Code d+ ( d1 d2 -- d3) + 2 # lda Setup jsr iny + SP )Y lda clc N 2+ adc SP )Y sta iny + SP )Y lda N 3 + adc SP )Y sta + SP X) lda N adc SP X) sta 1 # ldy + SP )Y lda N 1+ adc SP )Y sta + Next jmp end-code + + +\ *** Block No. 35, Hexblock 23 +23 fthpage + +( 1+ 2+ 3+ 1- 2- 08apr85bp) + +Code 1+ ( n1 -- n2) 1 # lda +Label n+ clc SP X) adc + CS not ?[ Puta jmp ]? + SP X) sta SP )Y lda 0 # adc SP )Y sta + Next jmp end-code + +Code 2+ ( n1 -- n2) + 2 # lda n+ bne end-code +Code 3+ ( n1 -- n2) + 3 # lda n+ bne end-code +| Code 4+ ( n1 -- n2) + 4 # lda n+ bne end-code +| Code 6+ ( n1 -- n2) + 6 # lda n+ bne end-code + +Code 1- ( n1 -- n2) sec +Label (1- SP X) lda 1 # sbc + CS ?[ Puta jmp ]? + SP X) sta SP )Y lda 0 # sbc SP )Y sta + Next jmp end-code + +Code 2- ( n1 -- n2) + clc (1- bcc end-code + +\ *** Block No. 36, Hexblock 24 +24 fthpage + +( number Constants 24dec83ks) + +-1 Constant true 0 Constant false + +' true Alias -1 ' false Alias 0 + +1 Constant 1 2 Constant 2 +3 Constant 3 4 Constant 4 + +: on ( addr -- ) true swap ! ; +: off ( addr -- ) false swap ! ; + + + + + + + + + + + + + + + +\ *** Block No. 37, Hexblock 25 +25 fthpage + +( words for number literals 24may84ks) + +Code clit ( -- 8b) + SP 2dec IP X) lda SP X) sta + txa SP )Y sta IP winc + Next jmp end-code restrict + +Code lit ( -- 16b) + SP 2dec IP )Y lda SP )Y sta + IP X) lda SP X) sta +Label (bump IP 2inc + Next jmp end-code restrict + +: Literal ( 16b --) + dup $FF00 and + IF compile lit , exit THEN + compile clit c, ; +immediate restrict + + +\ : lit r> dup 2+ >r @ ; +\ : clit r> dup 1+ >r c@ ; + + +\ *** Block No. 38, Hexblock 26 +26 fthpage + +( comparision code words 13jun84ks) + +Code 0< ( n -- flag) + SP )Y lda 0< ?[ +Label putTrue $FF # lda $24 c, ]? +Label putFalse txa SP )Y sta + Puta jmp end-code + +Code 0= ( 16b -- flag) + SP X) lda SP )Y ora + putTrue beq + putFalse bne end-code + +Code uwithin ( u1 [low up[ -- flag) + 2 # lda Setup jsr + 1 # ldy SP X) lda N cmp + SP )Y lda N 1+ sbc + CS not ?[ ( N>SP) SP X) lda N 2+ cmp + SP )Y lda N 3 + sbc + putTrue bcs ]? + putFalse jmp end-code + + + + + +\ *** Block No. 39, Hexblock 27 +27 fthpage + +( comparision code words 13jun84ks) + +Code < ( n1 n2 -- flag) + SP X) lda N sta SP )Y lda N 1+ sta + SP 2inc + N 1+ lda SP )Y eor ' 0< @ bmi + SP X) lda N cmp SP )Y lda N 1+ sbc + ' 0< @ 2+ jmp end-code + +Code u< ( u1 u2 -- flag) + SP X) lda N sta SP )Y lda N 1+ sta + SP 2inc + SP X) lda N cmp SP )Y lda N 1+ sbc + CS not ?[ putTrue jmp ]? + putFalse jmp end-code + + + + + + + + + + + +\ *** Block No. 40, Hexblock 28 +28 fthpage + +( comparision words 24dec83ks) + +\ : 0< $8000 and 0<> ; + +: > ( n1 n2 -- flag) swap < ; + +: 0> ( n -- flag) negate 0< ; + +: 0<> ( n -- flag) 0= not ; + +: u> ( u1 u2 -- flag) swap u< ; + +: = ( n1 n2 -- flag) - 0= ; + +: d0= ( d -- flag) or 0= ; + +: d= ( d1 d2 -- flag) dnegate d+ d0= ; + +: d< ( d1 d2 -- flag) rot 2dup - + IF > nip nip ELSE 2drop u< THEN ; + + + + + + +\ *** Block No. 41, Hexblock 29 +29 fthpage + +( min max umax umin extend dabs abs ks) + +| : minimax ( n1 n2 flag -- n3) + rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3) + 2dup > minimax ; + +: max ( n1 n2 -- n3) + 2dup < minimax ; + +: umax ( u1 u2 -- u3) + 2dup u< minimax ; + +: umin ( u1 u2 -- u3) + 2dup u> minimax ; + + +: extend ( n -- d) dup 0< ; + +: dabs ( d -- ud) + extend IF dnegate THEN ; + +: abs ( n -- u) + extend IF negate THEN ; + +\ *** Block No. 42, Hexblock 2a +2a fthpage + +\ loop primitives 02nov87re + +| : dodo + rdrop r> 2+ dup >r rot >r swap >r >r ; + +: (do ( limit star -- ) + over - dodo ; restrict + +: (?do ( limit start -- ) + over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict + +: bounds ( start count -- limit start ) + over + swap ; + +Code endloop ( -- ) + 6 # lda (nrdrop jmp end-code restrict + +\ dodo puts "index | limit | +\ adr.of.DO" on return-stack + + +\ *** Block No. 43, Hexblock 2b +2b fthpage + +\ (loop (+loop 02nov87re + +Code (loop + clc 1 # lda RP X) adc RP X) sta + CS ?[ RP )Y lda 0 # adc RP )Y sta + CS ?[ Next jmp ]? ]? +Label doloop 5 # ldy + RP )Y lda IP 1+ sta dey + RP )Y lda IP sta 1 # ldy + Next jmp end-code restrict + +Code (+loop ( n -- ) + clc SP X) lda RP X) adc RP X) sta + SP )Y lda RP )Y adc RP )Y sta + .A ror SP )Y eor + php SP 2inc plp doloop bpl + Next jmp end-code restrict + + + + + + + + + +\ *** Block No. 44, Hexblock 2c +2c fthpage + +( loop indices 08apr85bp) + +Code I ( -- n) 0 # ldy +Label loopindex SP 2dec clc + RP )Y lda iny iny + RP )Y adc SP X) sta dey + RP )Y lda iny iny + RP )Y adc 1 # ldy SP )Y sta + Next jmp end-code restrict + +Code J ( -- n) + 6 # ldy loopindex bne + end-code restrict + + + + + + + + + + + + + +\ *** Block No. 45, Hexblock 2d +2d fthpage + +\ branching 02nov87re + +Code branch + clc IP lda IP X) adc N sta + IP 1+ lda IP )Y adc IP 1+ sta + N lda IP sta + Next jmp end-code restrict + +Code ?branch ( flag -- ) + SP X) lda SP )Y ora + php SP 2inc plp + ' branch @ beq (bump jmp +end-code restrict + + +\ : branch r> dup @ + >r ; restrict + +\ : ?branch ( flag -- ) +\ 0= r> over not over 2+ and -rot +\ dup @ + and or >r ; restrict + + +\ *** Block No. 46, Hexblock 2e +2e fthpage + +( resolve loops and branches 03feb85bp) + +: >mark ( -- addr) here 0 , ; + +: >resolve ( addr --) + here over - swap ! ; + +: mark 1 ; + immediate restrict + +: THEN abs 1 ?pairs >resolve ; + immediate restrict + +: ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; + immediate restrict + +: BEGIN mark -2 2swap ; + immediate restrict + +| : (reptil resolve REPEAT ; + +: REPEAT 2 ?pairs compile branch + (reptil ; immediate restrict +: UNTIL 2 ?pairs compile ?branch + (reptil ; immediate restrict + +\ *** Block No. 49, Hexblock 31 +31 fthpage + +( Loops 29jan85ks/bp) + +: DO compile (do >mark 3 ; + immediate restrict + +: ?DO compile (?do >mark 3 ; + immediate restrict + +: LOOP 3 ?pairs compile (loop + compile endloop >resolve ; + immediate restrict + +: +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; + immediate restrict + +: LEAVE endloop r> 2- dup @ + >r ; + restrict + +\ Returnstack: calladr | index +\ limit | adr of DO + + +\ *** Block No. 50, Hexblock 32 +32 fthpage + +( um* bp/ks13.2.85) + +Code um* ( u1 u2 -- ud) + SP )Y lda N sta SP X) lda N 1+ sta + iny N 2 + stx N 3 + stx $10 # ldx + [[ N 3 + asl N 2+ rol N 1+ rol N rol + CS ?[ clc + SP )Y lda N 3 + adc N 3 + sta + iny SP )Y lda dey + N 2 + adc N 2 + sta + CS ?[ N 1+ inc + 0= ?[ N inc ]? ]? ]? + dex 0= ?] + N 3 + lda SP )Y sta iny + N 2 + lda SP )Y sta 1 # ldy + N lda SP )Y sta + N 1+ lda SP X) sta + Next jmp end-code + + +\ : um* ( u1 u2 -- ud3) +\ >r 0 0 0 r> $10 0 +\ DO dup 2/ >r 1 and IF 2over d+ THEN +\ >r >r 2dup d+ r> r> r> LOOP +\ drop 2swap 2drop ; + +\ *** Block No. 51, Hexblock 33 +33 fthpage + +( m* 2* 04jul84ks) + +: m* ( n1 n2 -- d) + dup 0< dup >r IF negate THEN + swap dup 0< IF negate r> not >r THEN + um* r> IF dnegate THEN ; + +: * ( n n -- prod) um* drop ; + +Code 2* ( n1 -- n2) + SP X) lda .A asl SP X) sta + SP )Y lda .A rol SP )Y sta + Next jmp end-code + + +\ : 2* dup + ; + + + + + + + + + + +\ *** Block No. 52, Hexblock 34 +34 fthpage + +( um/mod 04jul84ks) + +| : divovl + true Abort" division overflow" ; + +Code um/mod ( ud u -- urem uquot) + SP X) lda N 5 + sta + SP )Y lda N 4 + sta SP 2inc + SP X) lda N 1+ sta + SP )Y lda N sta iny + SP )Y lda N 3 + sta iny + SP )Y lda N 2+ sta $11 # ldx clc + [[ N 6 + ror sec N 1+ lda N 5 + sbc + tay N lda N 4 + sbc + CS not ?[ N 6 + rol ]? + CS ?[ N sta N 1+ sty ]? + N 3 + rol N 2+ rol N 1+ rol N rol + dex 0= ?] + 1 # ldy N ror N 1+ ror + CS ?[ ;c: divovl ; Assembler ]? + N 2+ lda SP )Y sta iny + N 1+ lda SP )Y sta iny + N lda SP )Y sta 1 # ldy + N 3 + lda + Puta jmp end-code + +\ *** Block No. 53, Hexblock 35 +35 fthpage + +( 2/ m/mod 24dec83ks) + +: m/mod ( d n -- mod quot) + dup >r abs over + 0< IF under + swap THEN + um/mod r@ + 0< IF negate over IF swap r@ + swap 1- + THEN THEN rdrop ; + +Code 2/ ( n1 -- n2) + SP )Y lda .A asl + SP )Y lda .A ror SP )Y sta + SP X) lda .A ror + Puta jmp end-code + + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 +36 fthpage + +( /mod / mod */mod */ u/mod ud/mod ks) + +: /mod ( n1 n2 -- rem quot) + >r extend r> m/mod ; + +: / ( n1 n2 -- quot) /mod nip ; + +: mod ( n1 n2 -- rem) /mod drop ; + +: */mod ( n1 n2 n3 -- rem quot) + >r m* r> m/mod ; + +: */ ( n1 n2 n3 -- quot) */mod nip ; + +: u/mod ( u1 u2 -- urem uquot) + 0 swap um/mod ; + +: ud/mod ( ud1 u2 -- urem udquot) + >r 0 r@ um/mod r> + swap >r um/mod r> ; + + + + + + +\ *** Block No. 55, Hexblock 37 +37 fthpage + +( cmove cmove> (cmove> bp 08apr85) + +Code cmove ( from to quan --) + 3 # lda Setup jsr dey + [[ [[ N cpy 0= ?[ N 1+ dec 0< ?[ + 1 # ldy Next jmp ]? ]? + N 4 + )Y lda N 2+ )Y sta iny 0= ?] + N 5 + inc N 3 + inc ]] end-code + +Code cmove> ( from to quan --) + 3 # lda Setup jsr + clc N 1+ lda N 3 + adc N 3 + sta + clc N 1+ lda N 5 + adc N 5 + sta + N 1+ inc N ldy clc CS ?[ +Label (cmove> + dey N 4 + )Y lda N 2+ )Y sta ]? + tya (cmove> bne + N 3 + dec N 5 + dec N 1+ dec + (cmove> bne 1 # ldy + Next jmp end-code + +: move ( from to quan --) + >r 2dup u< IF r> cmove> exit THEN + r> cmove ; + + +\ *** Block No. 56, Hexblock 38 +38 fthpage + +( place count erase 16feb85bp/ks) + +: place ( addr len to --) + over >r rot over 1+ r> move c! ; + +Code count ( addr -- addr+1 len) + SP X) lda N sta clc 1 # adc SP X) sta + SP )Y lda N 1+ sta 0 # adc SP )Y sta + SP 2dec (c@ jmp end-code + +\ : count ( adr -- adr+1 len ) +\ dup 1+ swap c@ ; + +: erase ( addr quan --) 0 fill ; + + + + + + + + + + + + +\ *** Block No. 57, Hexblock 39 +39 fthpage + +( fill 11jun85bp) + +Code fill ( addr quan 8b -- ) + 3 # lda Setup jsr dey + N lda N 3 + ldx + 0<> ?[ [[ [[ N 4 + )Y sta iny 0= ?] + N 5 + inc dex 0= ?] + ]? N 2+ ldx + 0<> ?[ [[ N 4 + )Y sta iny dex 0= ?] + ]? 1 # ldy + Next jmp end-code + + +\ : fill ( addr quan 8b --) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove +\ exit THEN 2drop ; + + +\ *** Block No. 58, Hexblock 3a +3a fthpage + +( here Pad allot , c, compile 24dec83ks) + +: here ( -- addr) dp @ ; + +: pad ( -- addr) here $42 + ; + +: allot ( n --) dp +! ; + +: , ( 16b --) here ! 2 allot ; + +: c, ( 8b --) here c! 1 allot ; + +: compile r> dup 2+ >r @ , ; + restrict + + + + + + + + + + + + +\ *** Block No. 59, Hexblock 3b +3b fthpage + +( input strings 24dec83ks) + +Variable #tib 0 #tib ! +Variable >tib here >tib ! $50 allot +Variable >in 0 >in ! +Variable blk 0 blk ! +Variable span 0 span ! + +: tib ( -- addr ) >tib @ ; + +: query + tib $50 expect + span @ #tib ! >in off blk off ; + + + + + + + + + + + + + +\ *** Block No. 60, Hexblock 3c +3c fthpage + +( scan skip /string 12oct84bp) + +: scan ( addr0 len0 char -- addr1 len1) + >r + BEGIN dup WHILE over c@ r@ - + WHILE 1- swap 1+ swap REPEAT + rdrop ; + +: skip ( addr len del -- addr1 len1) + >r + BEGIN dup WHILE over c@ r@ = + WHILE 1- swap 1+ swap REPEAT + rdrop ; + +: /string ( addr0 len0 +n - addr1 len1) + over umin rot over + -rot - ; + + + + + + + + + + +\ *** Block No. 61, Hexblock 3d +3d fthpage + +\ capital clv06aug87 + +Label (capital \ for commodore only + \ for Ascii: next scr + Ascii a # cmp CS + ?[ Ascii z $21 + # cmp CC + ?[ Ascii a $21 + # cmp CS + ?[ $df # and ]? \ 2nd up to low + Ascii z 1+ # cmp CC + ?[ $80 # ora \ low to up + ]? ]? ]? rts end-code + +Code capital ( char -- char' ) + SP X) lda (capital jsr SP X) sta + Next jmp end-code + +\ The new (capital does: + +\ No 00-40,5b-60,7b-c1-da-dc-ff no change +\ == -@ , [-@ , -A -Z -| - .. + +\ No 41-5a,61-7a changes to:c1-da +\ == a-z , A-Z A-Z + + +\ *** Block No. 62, Hexblock 3e +3e fthpage + +\ capitalize clv06aug87 + +Code capitalize ( string -- string ) + SP X) lda N sta SP )Y lda N 1+ sta + N X) lda N 2+ sta dey + [[ N 2+ cpy 0= ?[ 1 # ldy Next jmp ]? + iny N )Y lda (capital jsr N )Y sta + ]] end-code + +\ : capitalize ( string -- string ) +\ dup count bounds +\ ?DO I c@ capital I c! THEN LOOP ; + +\ capital ( char -- char ) +\ Ascii a Ascii z 1+ uwithin +\ IF I c@ [ Ascii a Ascii A - ] +\ Literal - ; + +\ Label (capital \ for Ascii only +\ Ascii a # cmp +\ CS ?[ Ascii z 1+ # cmp +\ CC ?[ sec +\ Ascii a Ascii A - # sbc +\ ]? ]? rts end-code + + +\ *** Block No. 63, Hexblock 3f +3f fthpage + +( (word 08apr85bp) + +| Code (word ( char adr0 len0 -- adr) + \ N : length of source + \ N+2 : ptr in source / next char + \ N+4 : string start adress + \ N+6 : string length + N 6 + stx \ 0 =: string_length + 3 # ldy + [[ SP )Y lda N ,Y sta dey 0< ?] + 1 # ldy clc + >in lda N 2+ adc N 2+ sta + \ >in+adr0 =: N+2 + >in 1+ lda N 3 + adc N 3 + sta + sec N lda >in sbc N sta + \ len0->in =: N + N 1+ lda >in 1+ sbc N 1+ sta + CC ?[ SP X) lda >in sta + \ stream exhausted + SP )Y lda >in 1+ sta + + + + + + +\ *** Block No. 64, Hexblock 40 +40 fthpage + +( (word 08apr85bp) + +][ 4 # ldy [[ N lda N 1+ ora + \ skip char's + 0= not ?[[ N 2+ X) lda SP )Y cmp + \ while count <>0 + 0= ?[[ N 2+ winc N wdec ]]? + N 2+ lda N 4 + sta + \ save string_start_adress + N 3 + lda N 5 + sta + [[ N 2+ X) lda SP )Y cmp php + \ scan for char + N 2+ winc N wdec plp + 0= not ?[[ N 6 + inc + \ count string_length + N lda N 1+ ora + 0= ?] ]? ]? + \ from count = 0 in skip) + sec 2 # ldy + \ adr_after_string - adr0 =: >in) + N 2+ lda SP )Y sbc >in sta iny + N 3 + lda SP )Y sbc >in 1+ sta + + + + +\ *** Block No. 65, Hexblock 41 +41 fthpage + +( (word 08apr85bp) + +]? \ from 1st ][, stream was exhausted + \ when word called) + clc 4 # lda SP adc SP sta + CS ?[ SP 1+ inc ]? \ 2drop + user' dp # ldy UP )Y lda + SP X) sta N sta iny + UP )Y lda 1 # ldy + SP )Y sta N 1+ sta \ dp @ + dey N 6 + lda \ store count byte first + [[ N )Y sta N 4 + )Y lda iny + N 6 + dec 0< ?] + $20 # lda N )Y sta \ add a blank + 1 # ldy Next jmp end-code + + + + + + + + + + + +\ *** Block No. 66, Hexblock 42 +42 fthpage + +( source word parse name 08apr85bp) + +: source ( -- addr len) + blk @ ?dup IF block b/blk exit THEN + tib #tib @ ; + +: word ( char -- addr) source (word ; + +: parse ( char -- addr len) + >r source >in @ /string over swap + r> scan >r over - dup r> 0<> - >in +! ; + +: name ( -- addr) + bl word capitalize exit ; + + +\ : word ( char -- addr) >r +\ source over swap >in @ /string +\ r@ skip over swap r> scan +\ >r rot over swap - r> 0<> - >in ! +\ over - here place bl here count + c! +\ here ; + + +\ *** Block No. 67, Hexblock 43 +43 fthpage + +\ state Ascii ," (" " 02nov87re + +Variable state 0 state ! + +: Ascii ( -- char ) ( -- ) + bl word 1+ c@ state @ + IF [compile] Literal THEN ; immediate + +: ," Ascii " parse + here over 1+ allot place ; + +: "lit ( -- adr ) + r> r> under count + >r >r ; restrict + +: (" ( -- adr ) "lit ; restrict + +: " compile (" ," ; + immediate restrict + + + + + + + + +\ *** Block No. 68, Hexblock 44 +44 fthpage + +( ." ( .( \ \\ hex decimal 08sep84ks) + +: (." "lit count type ; restrict + +: ." compile (." ," ; + immediate restrict + +: ( Ascii ) parse 2drop ; + immediate + +: .( Ascii ) parse type ; + immediate + +: \ >in @ c/l / 1+ c/l * >in ! ; + immediate + +: \\ b/blk >in ! ; immediate + +: \needs + name find nip IF [compile] \ THEN ; + +: hex $10 base ! ; +: decimal $A base ! ; + + + +\ *** Block No. 69, Hexblock 45 +45 fthpage + +( number conv.: digit? accumulate ks) + +: digit? ( char -- digit true/ false ) + Ascii 0 - dup 9 u> + IF [ Ascii A Ascii 9 - 1- ] + Literal - dup 9 u> + IF [ 2swap ( unstructured ) ] THEN + base @ over u> ?dup ?exit + THEN drop false ; + +: accumulate ( +d0 adr digit - +d1 adr) + swap >r swap base @ um* drop rot + base @ um* d+ r> ; + +: convert ( +d1 addr0 -- +d2 addr2) + 1+ BEGIN count digit? + WHILE accumulate REPEAT 1- ; + +: end? ( -- flag ) ptr @ 0= ; + +: char ( addr0 -- addr1 char ) + count -1 ptr +! ; + +: previous ( addr0 -- addr0 char) + 1- count ; + +\ *** Block No. 70, Hexblock 46 +46 fthpage + +( ?nonum ?num fixbase? 13feb85ks) + +Variable dpl -1 dpl ! + +| : ?nonum ( flag -- exit if true ) + IF rdrop 2drop drop rdrop false THEN ; + +| : ?num ( flag -- exit if true ) + IF rdrop drop r> IF dnegate THEN + rot drop dpl @ 1+ ?dup ?exit + drop true THEN ; + +| : fixbase? + ( char - char false / newbase true ) + Ascii & case? IF $A true exit THEN + Ascii $ case? IF 10 true exit THEN + Ascii H case? IF 10 true exit THEN + Ascii % case? IF 2 true exit THEN + false ; + +| : punctuation? ( char -- flag) + Ascii , over = swap Ascii . = or ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + +\ *** Block No. 71, Hexblock 47 +47 fthpage + +( number? number 'number 01oct87clv/re) + +| Variable ptr \ points into string + +: number? + ( string - string false / n 0< / d 0> ) + base push dup count ptr ! dpl on + 0 >r ( +sign) + 0 0 rot end? ?nonum char + Ascii - case? + IF rdrop true >r end? ?nonum char THEN + fixbase? + IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num + char digit? 0= UNTIL + previous punctuation? 0= ?nonum + dpl off end? ?num char REPEAT ; + +Defer 'number? ' number? Is 'number? + +: number ( string -- d ) + 'number? ?dup 0= Abort" ?" + 0< IF extend THEN ; + + +\ *** Block No. 72, Hexblock 48 +48 fthpage + +( hide reveal immediate restrict ks) + +Variable last 0 last ! + +| : last? ( -- false / acf true) + last @ ?dup ; + +: hide + last? IF 2- @ current @ ! THEN ; + +: reveal + last? IF 2- current @ ! THEN ; + +: Recursive reveal ; + immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN + drop ; + +: immediate $40 flag! ; +: restrict $80 flag! ; + + + + +\ *** Block No. 73, Hexblock 49 +49 fthpage + +( clearstack hallot heap heap?11feb85bp) + +Code clearstack + user' s0 # ldy + UP )Y lda SP sta iny + UP )Y lda SP 1+ sta + 1 # ldy Next jmp end-code + +: hallot ( quan -- ) + s0 @ over - swap + sp@ 2+ dup rot - dup s0 ! + 2 pick over - move clearstack s0 ! ; + +: heap ( -- addr) s0 @ 6+ ; + +: heap? ( addr -- flag) + heap up@ uwithin ; + +| : heapmove ( from -- from) + dup here over - + dup hallot heap swap cmove + heap over - last +! reveal ; + + + + +\ *** Block No. 74, Hexblock 4a +4a fthpage + +( Does> ; 30dec84ks/bp) + +Label (dodoes> RP 2dec +IP 1+ lda RP )Y sta IP lda RP X) sta + \ put IP on RP +clc W X) lda 3 # adc IP sta +txa W )Y adc IP 1+ sta \ W@ + 3 -> IP + +Label docreate + 2 # lda clc W adc pha txa W 1+ adc + Push jmp end-code + +| : (;code r> last @ name> ! ; + +: Does> + compile (;code $4C c, + compile (dodoes> ; immediate restrict + + + + + + + + + +\ *** Block No. 75, Hexblock 4b +4b fthpage + +( 6502-align ?head | 08sep84bp) + +| : 6502-align/1 ( adr -- adr' ) + dup $FF and $FF = - ; + +| : 6502-align/2 ( lfa -- lfa ) + here $FF and $FF = + IF dup dup 1+ here over - 1+ + cmove> \ lfa now invalid + 1 last +! 1 allot THEN ; + + +Variable ?head 0 ?head ! + +: | ?head @ ?exit -1 ?head ! ; + + + + + + + + + + + +\ *** Block No. 76, Hexblock 4c +4c fthpage + +( warning Create 30dec84bp) + +Variable warning 0 warning ! + +| : exists? + warning @ ?exit + last @ current @ (find nip + IF space last @ .name ." exists " ?cr + THEN ; + +: Create + here blk @ , current @ @ , + name c@ dup 1 $20 + uwithin not Abort" invalid name" + here last ! 1+ allot + exists? ?head @ + IF 1 ?head +! dup 6502-align/1 , + \ Pointer to code + heapmove $20 flag! 6502-align/1 dp ! + ELSE 6502-align/2 drop + THEN reveal 0 , + ;Code docreate jmp end-code + + + + +\ *** Block No. 77, Hexblock 4d +4d fthpage + +( nfa? 30dec84bp) + + Code nfa? + ( vocabthread cfa -- nfa / false) + SP X) lda N 4 + sta + SP )Y lda N 5 + sta SP 2inc + [[ [[ SP X) lda N 2+ sta + SP )Y lda N 3 + sta + N 2+ ora 0= ?[ putFalse jmp ]? + N 2+ )Y lda SP )Y sta N 1+ sta + N 2+ X) lda SP X) sta N sta + N 1+ ora 0= ?[ Next jmp ]? + \ N=link + N 2inc N X) lda pha sec $1F # and + N adc N sta CS ?[ N 1+ inc ]? + pla $20 # and 0= not + ?[ N )Y lda pha + N X) lda N sta pla N 1+ sta ]? + N lda N 4 + cmp 0= ?] + N 1+ lda N 5 + cmp 0= ?] + ' 2+ @ jmp end-code + +\ vocabthread=0 that is empty Vocabul- +\ ary in nfa? is not allowed + + +\ *** Block No. 78, Hexblock 4e +4e fthpage + +( >name name> >body .name 03feb85bp) + +: >name ( cfa -- nfa / false) + voc-link + BEGIN @ dup WHILE 2dup 4 - swap + nfa? ?dup IF -rot 2drop exit THEN + REPEAT nip ; + +| : (name> ( nfa -- cfa) + count $1F and + ; + +: name> ( nfa -- cfa) + dup (name> swap c@ $20 and IF @ THEN ; + +: >body ( cfa -- pfa) 2+ ; + +: .name ( nfa --) + ?dup IF dup heap? IF ." |" THEN + count $1F and type + ELSE ." ???" + THEN space ; + + + + + +\ *** Block No. 79, Hexblock 4f +4f fthpage + +\ : ; Constant Variable clv16jul87 + +: Create: Create hide + current @ context ! ] 0 ; + +: : Create: ;Code here >recover ! + \ resolve fwd. reference + RP 2dec IP lda RP X) sta + IP 1+ lda RP )Y sta + W lda clc 2 # adc IP sta + txa W 1+ adc IP 1+ sta + Next jmp end-code + +: ; 0 ?pairs compile unnest + [compile] [ reveal ; immediate restrict + + +: Constant ( 16b --) Create , + ;Code SP 2dec 2 # ldy + W )Y lda SP X) sta iny + W )Y lda 1 # ldy SP )Y sta + Next jmp end-code + +: Variable Create 2 allot ; + + +\ *** Block No. 80, Hexblock 50 +50 fthpage + +( uallot User Alias 10jan85ks/bp) + +: uallot ( quan -- offset) + dup udp @ + $FF + u> Abort" Userarea full" + udp @ swap udp +! ; + +: User Create 2 uallot c, + ;Code SP 2dec 2 # ldy + W )Y lda clc UP adc SP X) sta + txa iny UP 1+ adc 1 # ldy + SP )Y sta Next jmp end-code + +: Alias ( cfa --) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN + (name> ! ; + + + + + + + + + +\ *** Block No. 81, Hexblock 51 +51 fthpage + +( voc-link vp current context also bp) + +Create vp $10 allot +Variable current + +: context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) + vp 2+ context ; +\ "Only Forth also Assembler" gives vp : +\ countword = 6 |Only|Forth|Assembler + +: also vp @ + $A > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + +: toss -2 vp +! ; + + + + + + + + + +\ *** Block No. 82, Hexblock 52 +52 fthpage + +( Vocabulary Forth Only Forth-83 ks/bp) + +: Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; + +\ Name | Code | Thread | Coldthread | +\ Voc-link + +Vocabulary Forth + +Vocabulary Only +] Does> [ Onlypatch ] 0 vp ! + context ! also ; ' Only ! + +: Onlyforth + Only Forth also definitions ; + + + + + + + + +\ *** Block No. 83, Hexblock 53 +53 fthpage + +( definitions order words 13jan84bp/ks) + +: definitions context @ current ! ; + +| : .voc ( adr -- ) + @ 2- >name .name ; + +: order + thru.vocstack DO I .voc -2 +LOOP + 2 spaces current .voc ; + +: words context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ .name space + REPEAT drop ; + + + + + + + + + + + +\ *** Block No. 84, Hexblock 54 +54 fthpage + +( (find 08apr85bp) + +Code (find +( string thread -- string false / namefield true) + 3 # ldy [[ SP )Y lda N ,Y sta dey 0< ?] + N 2+ X) lda $1F # and N 4 + sta + +Label findloop 0 # ldy + N )Y lda tax iny + N )Y lda N 1+ sta N stx N ora + 0= ?[ 1 # ldy 0 # ldx putFalse jmp ]? + iny N )Y lda $1F # and N 4 + cmp + findloop bne \ countbyte match + clc 2 # lda N adc N 5 + sta + 0 # lda N 1+ adc N 6 + sta + N 4 + ldy + [[ N 2+ )Y lda N 5 + )Y cmp + findloop bne dey 0= ?] + 3 # ldy N 6 + lda SP )Y sta dey + N 5 + lda SP )Y sta + dey 0 # ldx putTrue jmp end-code + + + + + +\ *** Block No. 85, Hexblock 55 +55 fthpage + +( found 29jan85bp) + +| Code found ( nfa -- cfa n ) + SP X) lda N sta SP )Y lda N 1+ sta + N X) lda N 2+ sta $1F # and + sec N adc N sta + CS ?[ N 1+ inc ]? + N 2+ lda $20 # and + 0= ?[ N lda SP X) sta N 1+ lda + ][ N X) lda SP X) sta + N )Y lda ]? SP )Y sta + SP 2dec N 2+ lda 0< ?[ iny ]? + .A asl + 0< not ?[ tya $FF # eor tay iny ]? + tya SP X) sta + 0< ?[ $FF # lda 24 c, ]? + txa 1 # ldy SP )Y sta + Next jmp end-code + +\ | : found ( nfa -- cfa n ) +\ dup c@ >r (name> +\ r@ $20 and IF @ THEN +\ -1 r@ $80 and IF 1- THEN +\ r> $40 and IF negate THEN ; + + +\ *** Block No. 86, Hexblock 56 +56 fthpage + +( find ' ['] 13jan85bp) + +: find ( string -- cfa n / string false) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find + IF nip found exit THEN + over vp 2+ u> + WHILE swap 2- + REPEAT nip false ; + +: ' ( -- cfa ) + name find 0= Abort" What?" ; + +: [compile] ' , ; immediate restrict + +: ['] ' [compile] Literal ; + immediate restrict + +: nullstring? + ( string -- string false / true) + dup c@ 0= dup IF nip THEN ; + + + + + +\ *** Block No. 87, Hexblock 57 +57 fthpage + +( >interpret 28feb85bp) + +Label jump + iny clc W )Y lda 2 # adc IP sta + iny W )Y lda 0 # adc IP 1+ sta + 1 # ldy Next jmp end-code + +Variable >interpret + +jump ' >interpret ! + +\ make Variable >interpret to special +\ Defer + + +\ *** Block No. 88, Hexblock 58 +58 fthpage + +( interpret interactive 01oct87clv/re) + +Defer notfound + +: no.extensions ( string -- ) + Error" Haeh?" ; \ string not 0 + +' no.extensions Is notfound + +: interpret >interpret ; + +| : interactive + ?stack name find ?dup + IF 1 and IF execute >interpret THEN + Abort" compile only" THEN + nullstring? ?exit 'number? + 0= IF notfound THEN >interpret ; + + +' interactive >interpret ! + + + + + + +\ *** Block No. 89, Hexblock 59 +59 fthpage + +( compiling [ ] 01oct87clv/re) + +| : compiling + ?stack name find ?dup + IF 0> IF execute >interpret THEN + , >interpret THEN + nullstring? ?exit 'number? ?dup + IF 0> IF swap [compile] Literal THEN + [compile] Literal + ELSE notfound THEN >interpret ; + + +: [ ['] interactive Is >interpret + state off ; immediate + +: ] ['] compiling Is >interpret + state on ; + + + + + + + + + +\ *** Block No. 90, Hexblock 5a +5a fthpage + +\ perfom Defer Is 02nov87re + +| : crash true Abort" Crash" ; + +: Defer Create ['] crash , + ;Code 2 # ldy + W )Y lda pha iny W )Y lda + W 1+ sta pla W sta 1 # ldy + W 1- jmp end-code + +: (is ( cfa -- ) r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ ['] notfound @ over = + swap ['] >interpret @ = or + not Abort" not deferred" ; + +: Is ( cfa -- ) ( -- ) + ' dup def? >body + state @ IF compile (is , exit THEN + ! ; immediate + + + + + +\ *** Block No. 91, Hexblock 5b +5b fthpage + +( ?stack 01oct87clv/re) + +| Create alarm 1 allot 0 alarm c! + +| : stackfull ( -- ) + depth $20 > abort" tight stack" + alarm c@ 0= IF -1 alarm c! + true abort" dictionary full" THEN + ." still full " ; + +Code ?stack + user' dp # ldy + sec SP lda UP )Y sbc + iny SP 1+ lda UP )Y sbc + 0= ?[ 1 # ldy ;c: stackfull ; + Assembler ]? alarm stx + user' s0 # ldy + UP )Y lda SP cmp iny + UP )Y lda SP 1+ sbc + 1 # ldy CS ?[ Next jmp ]? + ;c: true Abort" stack empty" ; + +\ : ?stack +\ sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; + +\ *** Block No. 92, Hexblock 5c +5c fthpage + +( .status push load 08sep84ks) + +Defer .status ' noop Is .status + +| Create pull 0 ] r> r> ! ; + +: push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; + restrict + +: load ( blk --) + ?dup 0= ?exit blk push blk ! + >in push >in off + .status interpret ; + + + + + + + + + + + + +\ *** Block No. 93, Hexblock 5d +5d fthpage + +( +load thru +thru --> rdepth depth ks) + +: +load ( offset --) blk @ + load ; + +: thru ( from to --) + 1+ swap DO I load LOOP ; + +: +thru ( off0 off1 --) + 1+ swap DO I +load LOOP ; + +: --> + 1 blk +! >in off .status ; immediate + +: rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; + +: depth ( -- +n) sp@ s0 @ swap - 2/ ; + + + + + + + + + + +\ *** Block No. 94, Hexblock 5e +5e fthpage + +( quit (quit abort 07jun85bp) + +| : prompt + state @ IF ." compiling" exit THEN + ." ok" ; + +: (quit + BEGIN .status cr query interpret prompt + REPEAT ; + +Defer 'quit ' (quit Is 'quit + +: quit r0 @ rp! [compile] [ 'quit ; + + +: standardi/o + [ output ] Literal output 4 cmove ; + +Defer 'abort ' noop Is 'abort + +: abort + clearstack end-trace 'abort + standardi/o quit ; + + + +\ *** Block No. 95, Hexblock 5f +5f fthpage + +\ (error Abort" Error" 02nov87re + +Variable scr 1 scr ! Variable r# 0 r# ! + +: (error ( string -- ) + standardi/o space here .name count type + space ?cr blk @ ?dup + IF scr ! >in @ r# ! THEN quit ; + +' (error errorhandler ! + +: (abort" ( flag -- ) "lit swap + IF >r clearstack r> + errorhandler perform exit + THEN drop ; restrict + +| : (err" ( flag -- ) "lit swap + IF errorhandler perform exit + THEN drop ; restrict + +: Abort" ( flag -- ) compile (abort" + ," ; immediate restrict + +: Error" ( flag -- ) compile (err" + ," ; immediate restrict + +\ *** Block No. 96, Hexblock 60 +60 fthpage + +( -trailing 08apr85bp) + +020 Constant bl + +Code -trailing ( addr n1 -- adr n2 ) + tya Setup jsr + SP X) lda N 2+ sta clc + SP )Y lda N 1+ adc N 3 + sta + N ldy clc CS ?[ +Label (-trail + dey N 2+ )Y lda bl # cmp + 0<> ?[ iny 0= ?[ N 1+ inc ]? + tya pha N 1+ lda Push jmp ]? + ]? tya (-trail bne + N 3 + dec N 1 + dec (-trail bpl + tya Push0A jmp end-code + + +\ *** Block No. 97, Hexblock 61 +61 fthpage + +( space spaces 29jan85ks/bp) + +: space bl emit ; + +: spaces ( u --) 0 ?DO space LOOP ; + + +\ : -trailing ( addr n1 -- addr n2) +\ 2dup bounds +\ ?DO 2dup + 1- c@ bl - +\ IF LEAVE THEN 1- LOOP ; + + +\ *** Block No. 98, Hexblock 62 +62 fthpage + +( hold <# #> sign # #s 24dec83ks) + +| : hld ( -- addr) pad 2- ; + +: hold ( char -- ) + -1 hld +! hld @ c! ; + +: <# hld hld ! ; + +: #> ( 32b -- addr +n ) + 2drop hld @ hld over - ; + +: sign ( n -- ) + 0< IF Ascii - hold THEN ; + +: # ( +d1 -- +d2) + base @ ud/mod rot 09 over < + IF [ Ascii A Ascii 9 - 1- ] + Literal + + THEN Ascii 0 + hold ; + +: #s ( +d -- 0 0 ) + BEGIN # 2dup d0= UNTIL ; + + + +\ *** Block No. 99, Hexblock 63 +63 fthpage + +( print numbers 24dec83ks) + +: d.r -rot under dabs <# #s rot sign #> + rot over max over - spaces type + ; + +: .r swap extend rot d.r ; + +: u.r 0 swap d.r ; + +: d. 0 d.r space ; + +: . extend d. ; + +: u. 0 d. ; + + + + + + + + + + + +\ *** Block No. 100, Hexblock 64 +64 fthpage + +\ .s list c/l l/s clv4:jul87 + +: .s sp@ s0 @ over - 020 umin + bounds ?DO I @ u. 2 +LOOP ; + +40 (C drop 29 ) Constant c/l + \ Screen line length +10 (C drop 19 ) Constant l/s + \ lines per screen + +: list ( blk --) + scr ! ." Scr " scr @ dup blk/drv mod u. + ." Dr " drv? . + l/s 0 DO stop? IF leave THEN + cr I 2 .r space scr @ block + I c/l * + c/l (C 1- ) + -trailing type LOOP cr ; + + + + + + + + + +\ *** Block No. 101, Hexblock 65 +65 fthpage + +( multitasker primitives bp03nov85) + +Code pause Next here 2- ! end-code + +: lock ( addr --) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT + up@ swap ! ; + +: unlock ( addr --) dup lock off ; + +Label wake wake >wake ! + pla sec 5 # sbc UP sta + pla 0 # sbc UP 1+ sta + 04C # lda UP X) sta + 6 # ldy UP )Y lda SP sta + iny UP )Y lda SP 1+ sta 1 # ldy + SP X) lda RP sta + SP )Y lda RP 1+ sta SP 2inc + IP # ldx Xpull jmp +end-code + + + + + +\ *** Block No. 102, Hexblock 66 +66 fthpage + +( buffer mechanism 15dec83ks) + +User file 0 file ! + \ adr of file control block +Variable prev 0 prev ! + \ Listhead +Variable buffers 0 buffers ! + \ Semaphore +0408 Constant b/buf + \ Physical Size + +\ Structure of Buffer: +\ 0 : link +\ 2 : file +\ 4 : blocknr +\ 6 : statusflags +\ 8 : Data .. 1 KB .. + +\ Statusflag bits: 15 1 -> updated + +\ file = -1 empty buffer +\ = 0 no fcb , direct access +\ = else adr of fcb +\ ( system dependent ) + + +\ *** Block No. 103, Hexblock 67 +67 fthpage + +( search for blocks in memory 11jun85bp) + +Label thisbuffer? 2 # ldy + [[ N 4 + )Y lda N 2- ,Y cmp + 0= ?[[ iny 6 # cpy 0= ?] ]? rts + \ zero if this buffer ) + +| Code (core? + ( blk file -- addr / blk file ) + \ N-Area : 0 blk 2 file 4 buffer + \ 6 predecessor + 3 # ldy + [[ SP )Y lda N ,Y sta dey 0< ?] + user' offset # ldy + clc UP )Y lda N 2+ adc N 2+ sta + iny UP )Y lda N 3 + adc N 3 + sta + prev lda N 4 + sta + prev 1+ lda N 5 + sta + thisbuffer? jsr 0= ?[ + + + + + + + +\ *** Block No. 104, Hexblock 68 +68 fthpage + +( " 11jun85bp) + +Label blockfound SP 2inc + 1 # ldy + 8 # lda clc N 4 + adc SP X) sta + N 5 + lda 0 # adc SP )Y sta + ' exit @ jmp ]? + [[ N 4 + lda N 6 + sta + N 5 + lda N 7 + sta + N 6 + X) lda N 4 + sta 1 # ldy + N 6 + )Y lda N 5 + sta N 4 + ora + 0= ?[ ( list empty ) Next jmp ]? + thisbuffer? jsr 0= ?] \ found, relink + N 4 + X) lda N 6 + X) sta 1 # ldy + N 4 + )Y lda N 6 + )Y sta + prev lda N 4 + X) sta + prev 1+ lda N 4 + )Y sta + N 4 + lda prev sta + N 5 + lda prev 1+ sta + blockfound jmp end-code + + + + + + +\ *** Block No. 105, Hexblock 69 +69 fthpage + +\ (core? 23sep85bp + +\ | : this? ( blk file bufadr -- flag ) +\ dup 4+ @ swap 2+ @ d= ; + +\ | : (core? +\ ( blk file -- dataaddr / blk file ) +\ BEGIN over offset @ + over prev @ +\ this? IF rdrop 2drop prev @ 8 + exit +\ THEN +\ 2dup >r offset @ + >r prev @ +\ BEGIN dup @ ?dup +\ 0= IF rdrop rdrop drop exit THEN +\ dup r> r> 2dup >r >r rot this? 0= +\ WHILE nip REPEAT +\ dup @ rot ! prev @ over ! prev ! +\ rdrop rdrop +\ REPEAT ; + + +\ *** Block No. 106, Hexblock 6a +6a fthpage + +( (diskerr 11jun85bp) + +: (diskerr ." error ! r to retry " + key dup Ascii r = swap Ascii R = + or not Abort" aborted" ; + + +Defer diskerr ' (diskerr Is diskerr + +Defer r/w + + + + + + + + + + + + + + + + +\ *** Block No. 107, Hexblock 6b +6b fthpage + +( backup emptybuf readblk 11jun85bp) + +| : backup ( bufaddr --) + dup 6+ @ 0< + IF 2+ dup @ 1+ + \ buffer empty if file = -1 + IF input push output push standardi/o + BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE ." write " diskerr + REPEAT THEN + 080 over 4+ 1+ ctoggle THEN + drop ; + +| : emptybuf ( bufaddr --) + 2+ dup on 4+ off ; + +| : readblk + ( blk file addr -- blk file addr) + dup emptybuf input push output push + standardi/o >r + BEGIN over offset @ + over + r@ 8 + -rot 1 r/w + WHILE ." read " diskerr + REPEAT r> ; + + +\ *** Block No. 108, Hexblock 6c +6c fthpage + +( take mark updates? full? core? bp) + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = + UNTIL + buffers lock dup backup ; + +| : mark + ( blk file bufaddr -- blk file ) + 2+ >r 2dup r@ ! offset @ + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ + 0< UNTIL ; + +| : full? ( -- flag) + prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ; + +: core? ( blk file -- addr /false) + (core? 2drop false ; + + + + + +\ *** Block No. 109, Hexblock 6d +6d fthpage + +( block & buffer manipulation 11jun85bp) + +: (buffer ( blk file -- addr) + BEGIN (core? take mark + REPEAT ; + +: (block ( blk file -- addr) + BEGIN (core? take readblk mark + REPEAT ; + +| Code file@ ( -- n ) + user' file # ldy + UP )Y lda pha iny UP )Y lda + Push jmp end-code + +: buffer ( blk -- addr ) + file@ (buffer ; + +: block ( blk -- addr ) + file@ (block ; + + + + + + +\ *** Block No. 110, Hexblock 6e +6e fthpage + +( block & buffer manipulation 09sep84ks) + +: update 080 prev @ 6+ 1+ c! ; + +: save-buffers + buffers lock BEGIN updates? ?dup + WHILE backup REPEAT + buffers unlock ; + +: empty-buffers + buffers lock prev + BEGIN @ ?dup + WHILE dup emptybuf + REPEAT buffers unlock ; + +: flush save-buffers empty-buffers ; + + + + + + + + + + +\ *** Block No. 111, Hexblock 6f +6f fthpage + +( moving blocks 15dec83ks) + + : (copy ( from to --) + dup file@ + core? IF prev @ emptybuf THEN + full? IF save-buffers THEN + offset @ + swap block 2- 2- ! update ; + + : blkmove ( from to quan --) + save-buffers >r + over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ + 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 + 1 d+ LOOP + THEN save-buffers 2drop ; + +: copy ( from to --) 1 blkmove ; + +: convey ( [blk1 blk2] [to.blk --) + swap 1+ 2 pick - dup 0> not + Abort" no!!" blkmove ; + + + + +\ *** Block No. 112, Hexblock 70 +70 fthpage + +\ Allocating buffers clv12jul87 + +E400 Constant limit Variable first + +: allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! + first @ dup emptybuf + prev @ over ! prev ! ; + +: freebuffer ( -- ) + first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - + WHILE @ REPEAT + first @ @ swap ! b/buf first +! + THEN ; + +: all-buffers + BEGIN first @ allotbuffer + first @ = UNTIL ; + + + + + +\ *** Block No. 113, Hexblock 71 +71 fthpage + +( endpoints of forget 04jan85bp/ks) + +| : |? ( nfa -- flag ) c@ 020 and ; + +| : forget? ( adr nfa -- flag ) + \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoints ( addr -- addr symb) + heap voc-link @ >r + BEGIN r> @ ?dup \ through all Vocabs + WHILE dup >r 4 - >r \ link on returnst. + BEGIN r> @ >r over 1- dup r@ u< + \ until link or + swap r@ 2+ name> u< and + \ code under adr + WHILE r@ heap? [ 2dup ] UNTIL + \ search for a name in heap + r@ 2+ |? IF over r@ 2+ forget? + IF r@ 2+ (name> 2+ umax + THEN \ then update symb + THEN + REPEAT rdrop + REPEAT ; + + +\ *** Block No. 114, Hexblock 72 +72 fthpage + +\ remove 23jul85we + +| Code remove ( dic symb thr - dic symb) + 5 # ldy [[ SP )Y lda N ,Y sta dey 0< ?] + user' s0 # ldy + clc UP )Y lda 6 # adc N 6 + sta + iny UP )Y lda 0 # adc N 7 + sta + 1 # ldy + [[ N X) lda N 8 + sta + N )Y lda N 9 + sta N 8 + ora 0<> + ?[[ N 8 + lda N 6 + cmp + N 9 + lda N 7 + sbc CS + ?[ N 8 + lda N 2 + cmp + N 9 + lda N 3 + sbc + ][ N 4 + lda N 8 + cmp + N 5 + lda N 9 + sbc + ]? CC + ?[ N 8 + X) lda N X) sta + N 8 + )Y lda N )Y sta + ][ N 8 + lda N sta + N 9 + lda N 1+ sta ]? + ]]? (drop jmp end-code + + + + +\ *** Block No. 115, Hexblock 73 +73 fthpage + +( remove- forget-words 29apr85bp) + +| : remove-words ( dic symb -- dic symb) + voc-link BEGIN @ ?dup + WHILE dup >r 4 - remove r> REPEAT ; + +| : remove-tasks ( dic --) + up@ BEGIN 1+ dup @ up@ - + WHILE 2dup @ swap here uwithin + IF dup @ 1+ @ over ! 1- ELSE @ THEN + REPEAT 2drop ; + +| : remove-vocs ( dic symb -- dic symb) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN + -2 +LOOP + 2dup current @ -rot uwithin + IF [ ' Forth 2+ ] Literal current ! + THEN ; + +Defer custom-remove +' noop Is custom-remove + + + +\ *** Block No. 116, Hexblock 74 +74 fthpage + +( deleting words from dict. 13jan83ks) + +| : forget-words ( dic symb --) + over remove-tasks remove-vocs + remove-words custom-remove + heap swap - hallot dp ! 0 last ! ; + +: clear + here dup up@ forget-words dp ! ; + +: (forget ( adr --) + dup heap? Abort" is symbol" + endpoints forget-words ; + +: forget ' dup [ dp ] Literal @ + u< Abort" protected" + >name dup heap? + IF name> ELSE 2- 2- THEN + (forget ; + +: empty [ dp ] Literal @ + up@ forget-words + [ udp ] Literal @ udp ! ; + + + +\ *** Block No. 117, Hexblock 75 +75 fthpage + +\ save bye stop? ?cr clv2:jull87 + +: save + here up@ forget-words + voc-link @ BEGIN dup 2- 2- @ over + 2- ! @ ?dup 0= UNTIL + up@ origin $100 cmove ; + +: bye save-buffers (bye ; +\ : bye flush empty (bye ; + +| : end? key ( #cr ) (C 3 ) = + IF true rdrop THEN ; + +: stop? ( -- flag) + key? IF end? end? THEN false ; + +: ?cr col c/l $A - u> IF cr THEN ; + + + + + + + + +\ *** Block No. 118, Hexblock 76 +76 fthpage + +( in/output structure 02mar85bp) + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; + +0 Out: emit Out: cr Out: type + Out: del Out: page Out: at + Out: at? +drop + +: row ( -- row) at? drop ; +: col ( -- col) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; + +0 In: key In: key? In: decode + In: expect +drop + +\ *** Block No. 119, Hexblock 77 +77 fthpage + +( Alias only definitionen 29jan85bp) + +Only definitions Forth + +: seal 0 ['] Only >body ! ; + \ kill all words in Only) + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also +' definitions Alias definitions + +Host Target + + + + + + + + + + + + +\ *** Block No. 120, Hexblock 78 +78 fthpage + +\ 'cold 01oct87clv/re) + +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4 - ! + @ ?dup 0= UNTIL ; + +| : init-buffers + 0 prev ! limit first ! all-buffers ; + +Defer 'cold ' noop Is 'cold + +| : (cold + init-vocabularys init-buffers + Onlyforth 'cold + page logo count type cr + (restart ; + +Defer 'restart ' noop Is 'restart + +| : (restart + ['] (quit Is 'quit + drvinit 'restart [ errorhandler ] + Literal @ errorhandler ! + ['] noop Is 'abort abort ; + + +\ *** Block No. 121, Hexblock 79 +79 fthpage + +\ forth-init 01oct87clv/re) + +Label forth-init + Bootnextlen 1- # ldy + [[ Bootnext ,Y lda PutA ,Y sta + dey 0< ?] + clc s0 lda 6 # adc UP sta + s0 1+ lda 0 # adc UP 1+ sta + user' s0 # ldy UP )Y lda SP sta + iny UP )Y lda SP 1+ sta + user' r0 # ldy UP )Y lda RP sta + iny UP )Y lda RP 1+ sta + 0 # ldx 1 # ldy txa RP X) sta RP )Y sta +Label donothing rts + + +\ *** Block No. 122, Hexblock 7a +7a fthpage + +\ cold restart 06nov87re + +Code cold here >cold ! + $FF # ldx txs +Label bootsystem + donothing jsr \ patch for first-init + clc s0 lda 6 # adc N sta + s0 1+ lda 0 # adc N 1+ sta 0 # ldy + [[ origin ,Y lda N )Y sta iny 0= ?] + forth-init jsr + ;c: init-system (cold ; + +Code restart here >restart ! + $FF # ldx txs +Label warmboot + donothing jsr \ patch for first-init + forth-init jsr + ;c: init-system (restart ; + +Label xyNext + 0 # ldx 1 # ldy Next jmp end-code diff --git a/6502/C64/src/vf-tc-prep.fth b/6502/C64/src/vf-tc-prep.fth new file mode 100644 index 0000000..6885d64 --- /dev/null +++ b/6502/C64/src/vf-tc-prep.fth @@ -0,0 +1,75 @@ +\ *** Block No. 12, Hexblock c + +\ ramfill 3: + +Onlyforth + +Code ramfill ( adr n 8b -) + sei 34 # lda 1 sta + 3 # lda setup jsr + N 3 + ldx txa N 2+ ora 0<> + ?[ N lda 0 # ldy + [[ 0 # cpx 0<> + ?[[ [[ N 4 + )Y sta iny 0= ?] + N 5 + inc dex ]]? + N 2+ ldx 0<> ?[ + [[ N 4 + )Y sta iny N 2+ cpy CS ?] ]? + ]? + 36 # lda 1 sta cli + 0 # ldx 1 # ldy Next jmp +end-code + +$C000 $4000 (16 $300 - C) 0 ramfill + +forget ramfill + + +\ *** Block No. 13, Hexblock d + +( Deleting Assembler Labels bp27jun85we) + +: delete Assembler name find + IF >name count $1F and + bounds ?DO $1F I c! LOOP + ELSE count type space THEN ; + +delete setup delete xyNext +delete Puta delete SP +delete Pop delete Next +delete N delete UP +delete Poptwo delete W +delete IP delete RP +delete Push delete Push0A +delete PushA delete ;c: + +forget delete Onlyforth + + +\ *** Block No. 14, Hexblock e + +( Definition for .status 28jun85we) + +: status + blk @ ?dup IF + ." blk " u. + ." here " here u. + ." there " there u. + ." heap " heap u. cr + THEN ; + +' status is .status + +variable current-page 0 current-page ! + +: fthpage ( page# -- ) + dup current-page ! + ." page " u. + ." here " here u. + ." there " there u. + ." heap " heap u. cr ; + +: blk-or-page@ ( -- blk#/page# ) + blk @ ?dup ?exit + current-page @ ; + +' blk-or-page@ is blk@ diff --git a/6502/C64/tests/c16-vf-reference b/6502/C64/tests/c16-vf-reference new file mode 100644 index 0000000..117e2fa Binary files /dev/null and b/6502/C64/tests/c16-vf-reference differ diff --git a/6502/C64/tests/c64-vf-reference b/6502/C64/tests/c64-vf-reference new file mode 100644 index 0000000..fea72c7 Binary files /dev/null and b/6502/C64/tests/c64-vf-reference differ