6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2024-05-29 02:41:32 +00:00
Code Issues Projects Releases Wiki Activity

Tools: fb2fth (Forth-Block to Forth Source) in gforth

Browse Source
This commit is contained in:
Carsten Strotmann 2020-07-20 23:47:02 +02:00
parent a32b5f8901
commit fabfc21586
193 changed files with 33975 additions and 31632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
sources/Apple1/2words.fb.src
View File

@ -1,68 +0,0 @@
Screen 0 not modified
0 \ Additional definitions for 32bit values cas 26jan06
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ 2Words Loadscreen cas 26jan06
1
2 hex
3 &2 &3 thru
4 decimal
5
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE)
1
2 CODE 2! ( D ADR --)
3 TYA SETUP JSR 3 # LDY
4 [[ SP )Y LDA N )Y STA DEY 0< ?]
5 1 # LDY POPTWO JMP END-CODE
6
7 CODE 2@ ( ADR -- D)
8 SP X) LDA N STA SP )Y LDA N 1+ STA
9 SP 2DEC 3 # LDY
10 [[ N )Y LDA SP )Y STA DEY 0< ?]
11 XYNEXT JMP END-CODE
12
13
14
15
Screen 3 not modified
0 \
1
2 : 2VARIABLE ( --) CREATE 4 ALLOT ;
3 ( -- ADR)
4
5 : 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ;
6
7 \ 2DUP EXISTS
8 \ 2SWAP EXISTS
9 \ 2DROP EXISTS
10
11
12
13
14
15

68
sources/Apple1/2words.fth Normal file
View File

@ -0,0 +1,68 @@
\ *** Block No. 0 Hexblock 0
\ Additional definitions for 32bit values cas 26jan06
\ *** Block No. 1 Hexblock 1
\ 2Words Loadscreen cas 26jan06
hex
&2 &3 thru
decimal
\ *** Block No. 2 Hexblock 2
\ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE)
CODE 2! ( D ADR --)
TYA SETUP JSR 3 # LDY
[[ SP )Y LDA N )Y STA DEY 0< ?]
1 # LDY POPTWO JMP END-CODE
CODE 2@ ( ADR -- D)
SP X) LDA N STA SP )Y LDA N 1+ STA
SP 2DEC 3 # LDY
[[ N )Y LDA SP )Y STA DEY 0< ?]
XYNEXT JMP END-CODE
\ *** Block No. 3 Hexblock 3
\
: 2VARIABLE ( --) CREATE 4 ALLOT ;
( -- ADR)
: 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ;
\ 2DUP EXISTS
\ 2SWAP EXISTS
\ 2DROP EXISTS

2244
sources/Apple1/6502f83.fb.src
View File

File diff suppressed because it is too large Load Diff

2244
sources/Apple1/6502f83.fth Normal file
View File

File diff suppressed because it is too large Load Diff

204
sources/Apple1/as65.fb.src
View File

@ -1,204 +0,0 @@
Screen 0 not modified
0 \ FORTH-6502 ASSEMBLER WFR ) cas 26jan06
1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5)
2
3 Load from Screen 1 for the transient assembler:
4 This 6502 Forth Assembler can be loaded into the heap
5 and then not be saved in the final binary to save memory.
6
7 Load from Screen 2 for the regular assembler:
8 This 6502 Forth Assembler will be loaded into normal
9 memory and will be saved into the final binary.
10
11
12
13
14
15
Screen 1 not modified
0 \ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88
1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5)
2
3 ( INTERNAL LOADING 04MAY85BP/RE)
4 hex
5 \ HERE $200 HALLOT HEAP DP !
6 &10 LOAD
7 &11 LOAD
8 3 &8 THRU
9 &9 LOAD \ for System-Assembler
10
11 \ DP !
12
13 ONLYFORTH
14 decimal
15
Screen 2 not modified
0 \ FORTH-65 ASSEMBLER WFR ) er14dez88
1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5)
2 ONLYFORTH
3 Vocabulary tassembler
4 TASSEMBLER ALSO DEFINITIONS
5 hex
6
7 8 +load \ relocate
8 1 6 +THRU
9 \ 7 +load \ System Assembler
10 decimal
11
12
13
14
15
Screen 3 not modified
0 \ FORTH-83 6502-ASSEMBLER ) er14dez88
1 : END-CODE CONTEXT 2- @ CONTEXT ! ;
2 CREATE INDEX
3 09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c,
4 09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c,
5 80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c,
6 80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c,
7
8 | VARIABLE MODE
9
10 : MODE: ( N -) CREATE C, DOES> ( -) C@ MODE ! ;
11
12 0 MODE: .A 1 MODE: # 2 | MODE: MEM 3 MODE: ,X
13 4 MODE: ,Y 5 MODE: X) 6 MODE: )Y 0F MODE: )
14 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: )
15 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: )
Screen 4 not modified
0 \ UPMODE CPU ) er14dez88
1 | : UPMODE ( ADDR0 F0 - ADDR1 F1)
2 IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F AND ?DUP IF
3 0 DO DUP + LOOP THEN OVER 1+ @ AND 0= ;
4
5 : CPU ( 8B -) CREATE C, DOES> ( -) C@ >c, MEM ;
6
7 00 CPU BRK 18 CPU CLC D8 CPU CLD
8 58 CPU CLI B8 CPU CLV CA CPU DEX
9 88 CPU DEY E8 CPU INX C8 CPU INY
10 EA CPU NOP 48 CPU PHA 08 CPU PHP
11 68 CPU PLA 28 CPU PLP 40 CPU RTI
12 60 CPU RTS 38 CPU SEC F8 CPU SED
13 78 CPU SEI AA CPU TAX A8 CPU TAY
14 BA CPU TSX 8A CPU TXA 9A CPU TXS
15 98 CPU TYA
Screen 5 not modified
0 \ M/CPU ) er14dez88
1
2 : M/CPU ( MODE OPCODE -) CREATE C, , DOES>
3 DUP 1+ @ 80 AND IF 10 MODE +! THEN OVER FF00 AND UPMODE UPMODE
4 IF MEM TRUE ABORT" INVALID" THEN
5 C@ MODE @ INDEX + C@ + >c, MODE @ 7 AND
6 IF MODE @ 0F AND 7 < IF >c, ELSE >, THEN THEN MEM ;
7
8 1C6E 60 M/CPU ADC 1C6E 20 M/CPU AND 1C6E C0 M/CPU CMP
9 1C6E 40 M/CPU EOR 1C6E A0 M/CPU LDA 1C6E 00 M/CPU ORA
10 1C6E E0 M/CPU SBC 1C6C 80 M/CPU STA 0D0D 01 M/CPU ASL
11 0C0C C1 M/CPU DEC 0C0C E1 M/CPU INC 0D0D 41 M/CPU LSR
12 0D0D 21 M/CPU ROL 0D0D 61 M/CPU ROR 0414 81 M/CPU STX
13 0486 E0 M/CPU CPX 0486 C0 M/CPU CPY 1496 A2 M/CPU LDX
14 0C8E A0 M/CPU LDY 048C 80 M/CPU STY 0480 14 M/CPU JSR
15 8480 40 M/CPU JMP 0484 20 M/CPU BIT
Screen 6 not modified
0 \ ASSEMBLER CONDITIONALS ) er14dez88
1
2 | : RANGE? ( BRANCH -- BRANCH )
3 DUP ABS 07F U> ABORT" OUT OF RANGE " ;
4
5 : [[ ( BEGIN) >here ;
6 : ?] ( UNTIL) >c, >here 1+ - RANGE? >c, ;
7 : ?[ ( IF) >c, >here 0 >c, ;
8 : ?[[ ( WHILE) ?[ SWAP ;
9 : ]? ( THEN) >here OVER >c@ IF SWAP >!
10 ELSE OVER 1+ - RANGE? SWAP >c! THEN ;
11 : ][ ( ELSE) >here 1+ 1 JMP
12 SWAP >here OVER 1+ - RANGE? SWAP >c! ;
13 : ]] ( AGAIN) JMP ;
14 : ]]? ( REPEAT) JMP ]? ;
15
Screen 7 not modified
0 \ ASSEMBLER CONDITIONALS ) er14dez88
1
2 90 CONSTANT CS B0 CONSTANT CC
3 D0 CONSTANT 0= F0 CONSTANT 0<>
4 10 CONSTANT 0< 30 CONSTANT 0>=
5 50 CONSTANT VS 70 CONSTANT VC
6
7 : NOT 20 [ FORTH ] XOR ;
8
9 : BEQ 0<> ?] ; : BMI 0>= ?] ;
10 : BNE 0= ?] ; : BPL 0< ?] ;
11 : BCC CS ?] ; : BVC VS ?] ;
12 : BCS CC ?] ; : BVS VC ?] ;
13
14
15
Screen 8 not modified
0 \ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88
1
2 : 2INC
3 DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ;
4
5 : 2DEC
6 DUP LDA SEC 2 # SBC DUP STA CC ?[ SWAP 1+ DEC ]? ;
7
8 : WINC DUP INC 0= ?[ SWAP 1+ INC ]? ;
9
10 : WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ;
11
12 : ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ;
13
14
15
Screen 9 not modified
0 \ ;CODE CODE CODE> BP 03 02 85) er14dez88
1 ONLYFORTH
2
3 : ASSEMBLER ASSEMBLER [ ASSEMBLER ] MEM ;
4
5 : ;CODE [COMPILE] DOES> -3 >allot
6 [COMPILE] ; -2 >allot ASSEMBLER ; IMMEDIATE
7
8 : CODE CREATE >here DUP 2- >! ASSEMBLER ;
9
10 : >LABEL ( ADR -)
11 >here | CREATE SWAP , 4 HALLOT
12 HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE
13 HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ;
14
15 : LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ;
Screen 10 not modified
0 \ Code generating primitives er14dez88
1
2 Variable >codes
3 | Create nrc ] c, , c@ here allot ! c! [
4
5 : nonrelocate nrc >codes ! ; nonrelocate
6
7 | : >exec Create c,
8 Does> c@ >codes @ + @ execute ;
9
10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@
11 | 6 >exec >here | 8 >exec >allot | $0A >exec >!
12 | $0C >exec >c!
13
14
15
Screen 11 not modified
0 \ FORTH-65 ASSEMBLER WFR ) er14dez88
1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5)
2 ONLYFORTH
3
4 ASSEMBLER ALSO DEFINITIONS
5
6
7
8
9
10
11
12
13
14
15

204
sources/Apple1/as65.fth Normal file
View File

@ -0,0 +1,204 @@
\ *** Block No. 0 Hexblock 0
\ FORTH-6502 ASSEMBLER WFR ) cas 26jan06
( BASIS: FORTH DIMENSIONS VOL III NO. 5)
Load from Screen 1 for the transient assembler:
This 6502 Forth Assembler can be loaded into the heap
and then not be saved in the final binary to save memory.
Load from Screen 2 for the regular assembler:
This 6502 Forth Assembler will be loaded into normal
memory and will be saved into the final binary.
\ *** Block No. 1 Hexblock 1
\ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88
( BASIS: FORTH DIMENSIONS VOL III NO. 5)
( INTERNAL LOADING 04MAY85BP/RE)
hex
\ HERE $200 HALLOT HEAP DP !
&10 LOAD
&11 LOAD
3 &8 THRU
&9 LOAD \ for System-Assembler
\ DP !
ONLYFORTH
decimal
\ *** Block No. 2 Hexblock 2
\ FORTH-65 ASSEMBLER WFR ) er14dez88
( BASIS: FORTH DIMENSIONS VOL III NO. 5)
ONLYFORTH
Vocabulary tassembler
TASSEMBLER ALSO DEFINITIONS
hex
8 +load \ relocate
1 6 +THRU
\ 7 +load \ System Assembler
decimal
\ *** Block No. 3 Hexblock 3
\ FORTH-83 6502-ASSEMBLER ) er14dez88
: END-CODE CONTEXT 2- @ CONTEXT ! ;
CREATE INDEX
09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c,
09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c,
80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c,
80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c,
| VARIABLE MODE
: MODE: ( N -) CREATE C, DOES> ( -) C@ MODE ! ;
0 MODE: .A 1 MODE: # 2 | MODE: MEM 3 MODE: ,X
4 MODE: ,Y 5 MODE: X) 6 MODE: )Y 0F MODE: )
6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: )
6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: )
\ *** Block No. 4 Hexblock 4
\ UPMODE CPU ) er14dez88
| : UPMODE ( ADDR0 F0 - ADDR1 F1)
IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F AND ?DUP IF
0 DO DUP + LOOP THEN OVER 1+ @ AND 0= ;
: CPU ( 8B -) CREATE C, DOES> ( -) C@ >c, MEM ;
00 CPU BRK 18 CPU CLC D8 CPU CLD
58 CPU CLI B8 CPU CLV CA CPU DEX
88 CPU DEY E8 CPU INX C8 CPU INY
EA CPU NOP 48 CPU PHA 08 CPU PHP
68 CPU PLA 28 CPU PLP 40 CPU RTI
60 CPU RTS 38 CPU SEC F8 CPU SED
78 CPU SEI AA CPU TAX A8 CPU TAY
BA CPU TSX 8A CPU TXA 9A CPU TXS
98 CPU TYA
\ *** Block No. 5 Hexblock 5
\ M/CPU ) er14dez88
: M/CPU ( MODE OPCODE -) CREATE C, , DOES>
DUP 1+ @ 80 AND IF 10 MODE +! THEN OVER FF00 AND UPMODE UPMODE
IF MEM TRUE ABORT" INVALID" THEN
C@ MODE @ INDEX + C@ + >c, MODE @ 7 AND
IF MODE @ 0F AND 7 < IF >c, ELSE >, THEN THEN MEM ;
1C6E 60 M/CPU ADC 1C6E 20 M/CPU AND 1C6E C0 M/CPU CMP
1C6E 40 M/CPU EOR 1C6E A0 M/CPU LDA 1C6E 00 M/CPU ORA
1C6E E0 M/CPU SBC 1C6C 80 M/CPU STA 0D0D 01 M/CPU ASL
0C0C C1 M/CPU DEC 0C0C E1 M/CPU INC 0D0D 41 M/CPU LSR
0D0D 21 M/CPU ROL 0D0D 61 M/CPU ROR 0414 81 M/CPU STX
0486 E0 M/CPU CPX 0486 C0 M/CPU CPY 1496 A2 M/CPU LDX
0C8E A0 M/CPU LDY 048C 80 M/CPU STY 0480 14 M/CPU JSR
8480 40 M/CPU JMP 0484 20 M/CPU BIT
\ *** Block No. 6 Hexblock 6
\ ASSEMBLER CONDITIONALS ) er14dez88
| : RANGE? ( BRANCH -- BRANCH )
DUP ABS 07F U> ABORT" OUT OF RANGE " ;
: [[ ( BEGIN) >here ;
: ?] ( UNTIL) >c, >here 1+ - RANGE? >c, ;
: ?[ ( IF) >c, >here 0 >c, ;
: ?[[ ( WHILE) ?[ SWAP ;
: ]? ( THEN) >here OVER >c@ IF SWAP >!
ELSE OVER 1+ - RANGE? SWAP >c! THEN ;
: ][ ( ELSE) >here 1+ 1 JMP
SWAP >here OVER 1+ - RANGE? SWAP >c! ;
: ]] ( AGAIN) JMP ;
: ]]? ( REPEAT) JMP ]? ;
\ *** Block No. 7 Hexblock 7
\ ASSEMBLER CONDITIONALS ) er14dez88
90 CONSTANT CS B0 CONSTANT CC
D0 CONSTANT 0= F0 CONSTANT 0<>
10 CONSTANT 0< 30 CONSTANT 0>=
50 CONSTANT VS 70 CONSTANT VC
: NOT 20 [ FORTH ] XOR ;
: BEQ 0<> ?] ; : BMI 0>= ?] ;
: BNE 0= ?] ; : BPL 0< ?] ;
: BCC CS ?] ; : BVC VS ?] ;
: BCS CC ?] ; : BVS VC ?] ;
\ *** Block No. 8 Hexblock 8
\ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88
: 2INC
DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ;
: 2DEC
DUP LDA SEC 2 # SBC DUP STA CC ?[ 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 ;
\ *** Block No. 9 Hexblock 9
\ ;CODE CODE CODE> BP 03 02 85) er14dez88
ONLYFORTH
: ASSEMBLER ASSEMBLER [ ASSEMBLER ] MEM ;
: ;CODE [COMPILE] DOES> -3 >allot
[COMPILE] ; -2 >allot ASSEMBLER ; IMMEDIATE
: CODE CREATE >here DUP 2- >! ASSEMBLER ;
: >LABEL ( ADR -)
>here | CREATE SWAP , 4 HALLOT
HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE
HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ;
: LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ;
\ *** Block No. 10 Hexblock A
\ Code generating primitives er14dez88
Variable >codes
| Create nrc ] c, , c@ here allot ! c! [
: nonrelocate nrc >codes ! ; nonrelocate
| : >exec Create c,
Does> c@ >codes @ + @ execute ;
| 0 >exec >c, | 2 >exec >, | 4 >exec >c@
| 6 >exec >here | 8 >exec >allot | $0A >exec >!
| $0C >exec >c!
\ *** Block No. 11 Hexblock B
\ FORTH-65 ASSEMBLER WFR ) er14dez88
( BASIS: FORTH DIMENSIONS VOL III NO. 5)
ONLYFORTH
ASSEMBLER ALSO DEFINITIONS

323
sources/Apple1/assemble.fb.src
View File

@ -1,323 +0,0 @@
Screen 0 not modified
0 \\ *** Assembler *** 25may86we
1
2 Dieses File enth„lt den 68000-Assembler f<>r volksFORTH-83.
3 Der Assembler basiert auf dem von Michael Perry f<>r F83 entwik-
4 kelten, enth„lt aber einige zus„tzliche Features.
5 Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels
6 verwendbar. Aus Geschwindigkeitsgr<67>nden enth„lt der Assembler
7 kaum Fehler<65>berpr<70>fung, es empfiehlt sich daher, nach getaner
8 Tat die Code-Worte mit einem Disassembler zu <20>berpr<70>fen.
9
10 Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten
11 Assembler auf den Heap laden kann, damit er w„hrend der Kompila-
12 tionszeit zur Verf<72>gung steht, aber keinen Platz im Dictionary
13 verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt,
14 wenn er nicht mehr ben”tigt wird.
15
Screen 1 not modified
0 \ 68000 Assembler Load Screen 26oct86we
1
2 Onlyforth
3 Vocabulary Assembler Assembler also definitions
4
5 : end-code context 2- @ context ! ;
6 ' swap | Alias *swap
7
8 base @ 4 $11 +thru base !
9
10 : reg) size push .l 0 *swap FP DI) ;
11 : Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp
12 >here next-link @ , next-link ! ;
13
14 2 3 +thru Onlyforth
15
Screen 2 not modified
0 \ Internal Assembler 09sep86we
1
2 Onlyforth
3
4 here
5 $1300 hallot heap dp ! -1 +load
6 dp !
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ Extended adressing modes 09sep86we
1
2 : R#) ( addr -- ) size push
3 [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg)
4 [ Forth ] exit THEN .w FP D) ;
5
6
7 | : inrange? ( addr -- offset f ) [ Forth ]
8 >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN
9 dup >here negate > ;
10 : pcrel) ( addr -- ) \ pc-relativ adressing mode
11 inrange? [ Forth ] 0= abort" out of range" pcd) ;
12
13 : ;c: 0 recover R#) jsr end-code ] ;
14
15
Screen 4 not modified
0 \ Assembler Forth words 09sep86we
1 Forth definitions
2 : Assembler Assembler [ Assembler ] .w ;
3 : Code Create here dup 2- ! Assembler ;
4
5 | : (;code r> last @ name> ! ;
6 : ;Code 0 ?pairs compile (;code [compile] [ reveal
7 Assembler ; immediate restrict
8
9 : >label ( addr -- ) here | Create swap , immediate
10 4 hallot >here 4- heap 4 cmove
11 heap last @ count $1F and + even ! dp !
12 Does> ( -- addr ) @
13 state @ IF [compile] Literal THEN ;
14 : Label [ Assembler ] >here [ Forth ] 1 and
15 [ Assembler ] >allot >here >label Assembler ;
Screen 5 not modified
0 \ Code generating primitives 26oct86we
1
2 Variable >codes
3 | Create nrc ] c, , c@ here allot ! c! [
4
5 : nonrelocate nrc >codes ! ; nonrelocate
6
7 | : >exec Create c,
8 Does> c@ >codes @ + @ execute ;
9
10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@
11 | 6 >exec >here | 8 >exec >allot | $0A >exec >!
12 | $0C >exec >c!
13
14
15
Screen 6 not modified
0 \ 68000 Meta Assembler 04sep86we
1
2 | : ?, IF >, THEN >, ;
3 | : 2, >, >, ;
4 8 base !
5 Variable size
6 : .b 10000 size ! ;
7 : .w 30100 size ! ; .w
8 : .l 24600 size ! ;
9
10 | : Sz Constant Does> @ size @ and or ;
11 00300 | Sz sz3 00400 | Sz sz4
12 04000 | Sz sz40 30000 | Sz sz300
13
14 | : long? size @ 24600 = ;
15 | : -sz1 long? IF 100 or THEN ;
Screen 7 not modified
0 \ addressing modes 09sep86we
1
2 | : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ;
3 | : Mode Constant Does> @ *swap 7007 and or ;
4 0000 Regs D0 D1 D2 D3 D4 D5 D6 D7
5 0110 Regs A0 A1 A2 A3 A4 A5 A6 A7
6 0220 Mode ) \ address register indirect
7 0330 Mode )+ \ adr reg ind post-increment
8 0440 Mode -) \ adr reg ind pre-decrement
9 0550 Mode D) \ adr reg ind displaced
10 0660 Mode (DI) \ adr reg ind displaced indexed s.u.
11 0770 Constant #) \ immediate address
12 1771 Constant L#) \ immediate long address
13 2772 Constant pcD) \ pc relative displaced
14 3773 Constant (pcDI) \ pc relative displaced indexed
15 4774 Constant # \ immediate data
Screen 8 not modified
0 \ fields and register assignments 08sep86we
1
2 | : Field Constant Does> @ and ;
3 7000 | Field rd 0007 | Field rs
4 0070 | Field ms 0077 | Field eas
5 0377 | Field low
6 | : dn? ( ea -- ea flag ) dup ms 0= ;
7 | : src ( ea instr -- ea instr' ) over eas or ;
8 | : dst ( ea instr -- ea instr' ) *swap rd or ;
9
10 | : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ;
11 | : ??an ( mod -- mod ) dup ms 1 =
12 abort" needs Adress-Register" ;
13
14 A6 Constant SP A5 Constant RP A4 Constant IP
15 A3 Constant FP
Screen 9 not modified
0 \ extended addressing 09sep86we
1 : DI) (DI) size @ *swap ;
2 : pcDI) (pcDI) size @ *swap ;
3
4 | : double? ( mode -- flag) dup L#) = *swap
5 # = long? and or ;
6 | : index? ( {n} mode -- {m} mode )
7 dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or
8 IF size @ >r size !
9 dup rd 10 * *swap ms IF 100000 or THEN
10 sz40 *swap low or r> size !
11 THEN r> ;
12
13 | : more? ( ea -- ea flag ) dup ms 0040 > ;
14 | : ,more ( ea -- ) more?
15 IF index? double? ?, ELSE drop THEN ;
Screen 10 not modified
0 \ extended addressing extras 09sep86we
1
2 | Create extra here 5 dup allot erase \ temporary storage area
3
4 | : extra? ( {n} mode -- mode ) more?
5 IF >r r@ index? double? extra 1+ *swap
6 IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r>
7 ELSE 0 extra !
8 THEN ;
9
10 | : ,extra ( -- ) extra c@ ?dup
11 IF extra 1+ *swap 1 =
12 IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase
13 THEN ;
14
15
Screen 11 not modified
0 \ immediates & address register specific 15jan86we
1 | : Imm Constant Does> @ >r extra? eas r> or
2 sz3 >, long? ?, ,extra ; ( n ea)
3 0000 Imm ori 1000 Imm andi
4 2000 Imm subi 3000 Imm addi
5 5000 Imm eori 6000 Imm cmpi
6 | : Immsr Constant Does> @ sz3 2, ; ( n )
7 001074 Immsr andi>sr
8 005074 Immsr eori>sr
9 000074 Immsr ori>sr
10 | : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or
11 r> or sz3 >, ,extra ; ( n ea )
12 050000 Iq addq 050400 Iq subq
13 | : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an )
14 150300 Ieaa adda 130300 Ieaa cmpa
15 040700 Ieaa lea 110300 Ieaa suba
Screen 12 not modified
0 \ shifts, rotates, and bit manipulation 15jan86we
1 | : Isr Constant Does> @ >r dn?
2 IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN
3 rd *swap rs or r> or 160000 or sz3 >,
4 ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or
5 160000 or >, ,more
6 THEN ; ( dm dn ) ( m # dn ) ( ea )
7 400 Isr asl 000 Isr asr
8 410 Isr lsl 010 Isr lsr
9 420 Isr roxl 020 Isr roxr
10 430 Isr rol 030 Isr ror
11 | : Ibit Constant does> @ >r extra? dn?
12 IF rd src 400 ELSE drop dup eas 4000 THEN
13 or r> or >, ,extra ,more ; ( ea dn ) ( ea n # )
14 000 Ibit btst 100 Ibit bchg
15 200 Ibit bclr 300 Ibit bset
Screen 13 not modified
0 \ branch, loop, and set conditionals 15jan86we
1
2 | : Setclass ' *swap 0 DO I over execute LOOP drop ;
3 | : Ibra 400 * 060000 or Constant ( label )
4 Does> @ *swap >here 2+ - dup abs 200 <
5 IF low or >, ELSE *swap 2, THEN ;
6 20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq
7 bvc bvs bpl bmi bge blt bgt ble
8 | : Idbr 400 * 050310 or Constant ( label \ dn - )
9 Does> @ *swap rs or >, >here - >, ;
10 20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq
11 dbvc dbvs dbpl dbmi dbge dblt dbgt dble
12 | : Iset 400 * 050300 or Constant ( ea )
13 Does> @ src >, ,more ;
14 20 Setclass Iset set sno shi sls scc scs sne seq
15 svc svs spl smi sge slt sgt sle
Screen 14 not modified
0 \ moves 15jan86we
1
2 : move extra? 7700 and src sz300 >,
3 ,more ,extra ; ( ea ea )
4 : moveq ??dn rd *swap low or 070000 or >, ; ( n dn )
5 : move>usp ??an rs 047140 or >, ; ( an )
6 : move<usp ??an rs 047150 or >, ; ( an )
7 : movem>
8 extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea )
9 : movem<
10 extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea )
11 : movep dn? IF rd *swap rs or 410 or
12 ELSE rs rot rd or 610 or THEN -sz1 2, ;
13 ( dm d an ) ( d an dm )
14 : lmove 7700 and *swap eas or 20000 or >, ;
15 ( long reg move )
Screen 15 not modified
0 \ odds and ends 15jan86we
1
2 : cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ )
3 : exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r
4 ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap
5 THEN rs dst r> or >, ; ( rn rm )
6 : ext ??dn rs 044200 or -sz1 >, ; ( dn )
7 : swap ??dn rs 044100 or >, ; ( dn )
8 : stop 47162 2, ; ( n )
9 : trap 17 and 47100 or >, ; ( n )
10 : link ??an rs 047120 or 2, ; ( n an )
11 : unlk ??an rs 047130 or >, ; ( an )
12 : eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea )
13 : cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn )
14
15
Screen 16 not modified
0 \ arithmetic and logic 15jan86we
1 | : Ibcd Constant Does> @ dst over rs or *swap ms
2 IF 10 or THEN >, ; ( dn dm ) ( an@- am@- )
3 140400 Ibcd abcd 100400 Ibcd sbcd
4 | : Idd Constant Does> @ dst over rs or *swap ms
5 IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- )
6 150400 Idd addx 110400 Idd subx
7 | : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea )
8 IF rd src r> or sz3 >, ,more
9 ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ;
10 150000 Idea add 110000 Idea sub
11 140000 Idea and 100000 Idea or
12 | : Iead Constant Does> @ >r ??dn r> dst src
13 >, ,more ; ( ea dn)
14 040600 Iead chk 100300 Iead divu 100700 Iead divs
15 140300 Iead mulu 140700 Iead muls
Screen 17 not modified
0 \ arithmetic and control 15jan86we
1
2 | : Iea Constant Does> @ src >, ,more ; ( ea )
3 047200 Iea jsr 047300 Iea jmp
4 042300 Iea move>ccr
5 040300 Iea move<sr 043300 Iea move>sr
6 044000 Iea nbcd 044100 Iea pea
7 045300 Iea tas
8 | : Ieas Constant Does> @ src sz3 >, ,more ; ( ea )
9 041000 Ieas clr 043000 Ieas not
10 042000 Ieas neg 040000 Ieas negx
11 045000 Ieas tst
12 | : Icon Constant Does> @ >, ;
13 47160 Icon reset 47161 Icon nop
14 47163 Icon rte 47165 Icon rts
15 47166 Icon trapv 47167 Icon rtr
Screen 18 not modified
0 \ structured conditionals +/- 256 bytes 15jan86we
1 : THEN >here over 2+ - *swap 1+ >c! ;
2 : IF >, >here 2- ; hex
3 : ELSE 6000 IF *swap THEN ;
4 : BEGIN >here ;
5 : UNTIL >, >here - >here 1- >c! ;
6 : AGAIN 6000 UNTIL ;
7 : WHILE IF *swap ;
8 : REPEAT AGAIN THEN ;
9 : DO >here *swap ;
10 : LOOP dbra ;
11 6600 Constant 0= 6700 Constant 0<>
12 6A00 Constant 0< 6B00 Constant 0>=
13 6C00 Constant < 6D00 Constant >=
14 6E00 Constant <= 6F00 Constant >
15 6500 Constant CC 6400 Constant CS

323
sources/Apple1/assemble.fth Normal file
View File

@ -0,0 +1,323 @@
\ *** Block No. 0 Hexblock 0
\\ *** Assembler *** 25may86we
Dieses File enth„lt den 68000-Assembler f<EFBFBD>r volksFORTH-83.
Der Assembler basiert auf dem von Michael Perry f<EFBFBD>r F83 entwik-
kelten, enth„lt aber einige zus„tzliche Features.
Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels
verwendbar. Aus Geschwindigkeitsgr<EFBFBD>nden enth„lt der Assembler
kaum Fehler<EFBFBD>berpr<EFBFBD>fung, es empfiehlt sich daher, nach getaner
Tat die Code-Worte mit einem Disassembler zu <EFBFBD>berpr<EFBFBD>fen.
Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten
Assembler auf den Heap laden kann, damit er w„hrend der Kompila-
tionszeit zur Verf<EFBFBD>gung steht, aber keinen Platz im Dictionary
verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt,
wenn er nicht mehr ben”tigt wird.
\ *** Block No. 1 Hexblock 1
\ 68000 Assembler Load Screen 26oct86we
Onlyforth
Vocabulary Assembler Assembler also definitions
: end-code context 2- @ context ! ;
' swap | Alias *swap
base @ 4 $11 +thru base !
: reg) size push .l 0 *swap FP DI) ;
: Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp
>here next-link @ , next-link ! ;
2 3 +thru Onlyforth
\ *** Block No. 2 Hexblock 2
\ Internal Assembler 09sep86we
Onlyforth
here
$1300 hallot heap dp ! -1 +load
dp !
\ *** Block No. 3 Hexblock 3
\ Extended adressing modes 09sep86we
: R#) ( addr -- ) size push
[ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg)
[ Forth ] exit THEN .w FP D) ;
| : inrange? ( addr -- offset f ) [ Forth ]
>here 2+ - >here 0< IF dup $FFFE >here - < exit THEN
dup >here negate > ;
: pcrel) ( addr -- ) \ pc-relativ adressing mode
inrange? [ Forth ] 0= abort" out of range" pcd) ;
: ;c: 0 recover R#) jsr end-code ] ;
\ *** Block No. 4 Hexblock 4
\ Assembler Forth words 09sep86we
Forth definitions
: Assembler Assembler [ Assembler ] .w ;
: Code Create here dup 2- ! Assembler ;
| : (;code r> last @ name> ! ;
: ;Code 0 ?pairs compile (;code [compile] [ reveal
Assembler ; immediate restrict
: >label ( addr -- ) here | Create swap , immediate
4 hallot >here 4- heap 4 cmove
heap last @ count $1F and + even ! dp !
Does> ( -- addr ) @
state @ IF [compile] Literal THEN ;
: Label [ Assembler ] >here [ Forth ] 1 and
[ Assembler ] >allot >here >label Assembler ;
\ *** Block No. 5 Hexblock 5
\ Code generating primitives 26oct86we
Variable >codes
| Create nrc ] c, , c@ here allot ! c! [
: nonrelocate nrc >codes ! ; nonrelocate
| : >exec Create c,
Does> c@ >codes @ + @ execute ;
| 0 >exec >c, | 2 >exec >, | 4 >exec >c@
| 6 >exec >here | 8 >exec >allot | $0A >exec >!
| $0C >exec >c!
\ *** Block No. 6 Hexblock 6
\ 68000 Meta Assembler 04sep86we
| : ?, IF >, THEN >, ;
| : 2, >, >, ;
8 base !
Variable size
: .b 10000 size ! ;
: .w 30100 size ! ; .w
: .l 24600 size ! ;
| : Sz Constant Does> @ size @ and or ;
00300 | Sz sz3 00400 | Sz sz4
04000 | Sz sz40 30000 | Sz sz300
| : long? size @ 24600 = ;
| : -sz1 long? IF 100 or THEN ;
\ *** Block No. 7 Hexblock 7
\ addressing modes 09sep86we
| : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ;
| : Mode Constant Does> @ *swap 7007 and or ;
0000 Regs D0 D1 D2 D3 D4 D5 D6 D7
0110 Regs A0 A1 A2 A3 A4 A5 A6 A7
0220 Mode ) \ address register indirect
0330 Mode )+ \ adr reg ind post-increment
0440 Mode -) \ adr reg ind pre-decrement
0550 Mode D) \ adr reg ind displaced
0660 Mode (DI) \ adr reg ind displaced indexed s.u.
0770 Constant #) \ immediate address
1771 Constant L#) \ immediate long address
2772 Constant pcD) \ pc relative displaced
3773 Constant (pcDI) \ pc relative displaced indexed
4774 Constant # \ immediate data
\ *** Block No. 8 Hexblock 8
\ fields and register assignments 08sep86we
| : Field Constant Does> @ and ;
7000 | Field rd 0007 | Field rs
0070 | Field ms 0077 | Field eas
0377 | Field low
| : dn? ( ea -- ea flag ) dup ms 0= ;
| : src ( ea instr -- ea instr' ) over eas or ;
| : dst ( ea instr -- ea instr' ) *swap rd or ;
| : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ;
| : ??an ( mod -- mod ) dup ms 1 =
abort" needs Adress-Register" ;
A6 Constant SP A5 Constant RP A4 Constant IP
A3 Constant FP
\ *** Block No. 9 Hexblock 9
\ extended addressing 09sep86we
: DI) (DI) size @ *swap ;
: pcDI) (pcDI) size @ *swap ;
| : double? ( mode -- flag) dup L#) = *swap
# = long? and or ;
| : index? ( {n} mode -- {m} mode )
dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or
IF size @ >r size !
dup rd 10 * *swap ms IF 100000 or THEN
sz40 *swap low or r> size !
THEN r> ;
| : more? ( ea -- ea flag ) dup ms 0040 > ;
| : ,more ( ea -- ) more?
IF index? double? ?, ELSE drop THEN ;
\ *** Block No. 10 Hexblock A
\ extended addressing extras 09sep86we
| Create extra here 5 dup allot erase \ temporary storage area
| : extra? ( {n} mode -- mode ) more?
IF >r r@ index? double? extra 1+ *swap
IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r>
ELSE 0 extra !
THEN ;
| : ,extra ( -- ) extra c@ ?dup
IF extra 1+ *swap 1 =
IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase
THEN ;
\ *** Block No. 11 Hexblock B
\ immediates & address register specific 15jan86we
| : Imm Constant Does> @ >r extra? eas r> or
sz3 >, long? ?, ,extra ; ( n ea)
0000 Imm ori 1000 Imm andi
2000 Imm subi 3000 Imm addi
5000 Imm eori 6000 Imm cmpi
| : Immsr Constant Does> @ sz3 2, ; ( n )
001074 Immsr andi>sr
005074 Immsr eori>sr
000074 Immsr ori>sr
| : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or
r> or sz3 >, ,extra ; ( n ea )
050000 Iq addq 050400 Iq subq
| : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an )
150300 Ieaa adda 130300 Ieaa cmpa
040700 Ieaa lea 110300 Ieaa suba
\ *** Block No. 12 Hexblock C
\ shifts, rotates, and bit manipulation 15jan86we
| : Isr Constant Does> @ >r dn?
IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN
rd *swap rs or r> or 160000 or sz3 >,
ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or
160000 or >, ,more
THEN ; ( dm dn ) ( m # dn ) ( ea )
400 Isr asl 000 Isr asr
410 Isr lsl 010 Isr lsr
420 Isr roxl 020 Isr roxr
430 Isr rol 030 Isr ror
| : Ibit Constant does> @ >r extra? dn?
IF rd src 400 ELSE drop dup eas 4000 THEN
or r> or >, ,extra ,more ; ( ea dn ) ( ea n # )
000 Ibit btst 100 Ibit bchg
200 Ibit bclr 300 Ibit bset
\ *** Block No. 13 Hexblock D
\ branch, loop, and set conditionals 15jan86we
| : Setclass ' *swap 0 DO I over execute LOOP drop ;
| : Ibra 400 * 060000 or Constant ( label )
Does> @ *swap >here 2+ - dup abs 200 <
IF low or >, ELSE *swap 2, THEN ;
20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq
bvc bvs bpl bmi bge blt bgt ble
| : Idbr 400 * 050310 or Constant ( label \ dn - )
Does> @ *swap rs or >, >here - >, ;
20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq
dbvc dbvs dbpl dbmi dbge dblt dbgt dble
| : Iset 400 * 050300 or Constant ( ea )
Does> @ src >, ,more ;
20 Setclass Iset set sno shi sls scc scs sne seq
svc svs spl smi sge slt sgt sle
\ *** Block No. 14 Hexblock E
\ moves 15jan86we
: move extra? 7700 and src sz300 >,
,more ,extra ; ( ea ea )
: moveq ??dn rd *swap low or 070000 or >, ; ( n dn )
: move>usp ??an rs 047140 or >, ; ( an )
: move<usp ??an rs 047150 or >, ; ( an )
: movem>
extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea )
: movem<
extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea )
: movep dn? IF rd *swap rs or 410 or
ELSE rs rot rd or 610 or THEN -sz1 2, ;
( dm d an ) ( d an dm )
: lmove 7700 and *swap eas or 20000 or >, ;
( long reg move )
\ *** Block No. 15 Hexblock F
\ odds and ends 15jan86we
: cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ )
: exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r
ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap
THEN rs dst r> or >, ; ( rn rm )
: ext ??dn rs 044200 or -sz1 >, ; ( dn )
: swap ??dn rs 044100 or >, ; ( dn )
: stop 47162 2, ; ( n )
: trap 17 and 47100 or >, ; ( n )
: link ??an rs 047120 or 2, ; ( n an )
: unlk ??an rs 047130 or >, ; ( an )
: eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea )
: cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn )
\ *** Block No. 16 Hexblock 10
\ arithmetic and logic 15jan86we
| : Ibcd Constant Does> @ dst over rs or *swap ms
IF 10 or THEN >, ; ( dn dm ) ( an@- am@- )
140400 Ibcd abcd 100400 Ibcd sbcd
| : Idd Constant Does> @ dst over rs or *swap ms
IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- )
150400 Idd addx 110400 Idd subx
| : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea )
IF rd src r> or sz3 >, ,more
ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ;
150000 Idea add 110000 Idea sub
140000 Idea and 100000 Idea or
| : Iead Constant Does> @ >r ??dn r> dst src
>, ,more ; ( ea dn)
040600 Iead chk 100300 Iead divu 100700 Iead divs
140300 Iead mulu 140700 Iead muls
\ *** Block No. 17 Hexblock 11
\ arithmetic and control 15jan86we
| : Iea Constant Does> @ src >, ,more ; ( ea )
047200 Iea jsr 047300 Iea jmp
042300 Iea move>ccr
040300 Iea move<sr 043300 Iea move>sr
044000 Iea nbcd 044100 Iea pea
045300 Iea tas
| : Ieas Constant Does> @ src sz3 >, ,more ; ( ea )
041000 Ieas clr 043000 Ieas not
042000 Ieas neg 040000 Ieas negx
045000 Ieas tst
| : Icon Constant Does> @ >, ;
47160 Icon reset 47161 Icon nop
47163 Icon rte 47165 Icon rts
47166 Icon trapv 47167 Icon rtr
\ *** Block No. 18 Hexblock 12
\ structured conditionals +/- 256 bytes 15jan86we
: THEN >here over 2+ - *swap 1+ >c! ;
: IF >, >here 2- ; hex
: ELSE 6000 IF *swap THEN ;
: BEGIN >here ;
: UNTIL >, >here - >here 1- >c! ;
: AGAIN 6000 UNTIL ;
: WHILE IF *swap ;
: REPEAT AGAIN THEN ;
: DO >here *swap ;
: LOOP dbra ;
6600 Constant 0= 6700 Constant 0<>
6A00 Constant 0< 6B00 Constant 0>=
6C00 Constant < 6D00 Constant >=
6E00 Constant <= 6F00 Constant >
6500 Constant CC 6400 Constant CS

34
sources/Apple1/ccompile.fb.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \ Crosscompile Script for 6502 Target cas 26jan06
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ loadscreen for cross-compiler cas 26jan06
1
2 include assemble.fb \ load 68000 assembler
3 2 loadfrom as65.fb page \ load 6502 assembler
4 include crostarg.fb page \ load target compiler
5 include 6502f83.fb \ load Forth Kernel Source
6
7 save-target f6502.com \ save new forth as f6502.com
8 key drop page .( Ready ) cr \ wait for keypress
9 bye \ and exit forth
10
11
12
13
14
15

34
sources/Apple1/ccompile.fth Normal file
View File

@ -0,0 +1,34 @@
\ *** Block No. 0 Hexblock 0
\ Crosscompile Script for 6502 Target cas 26jan06
\ *** Block No. 1 Hexblock 1
\ loadscreen for cross-compiler cas 26jan06
include assemble.fb \ load 68000 assembler
2 loadfrom as65.fb page \ load 6502 assembler
include crostarg.fb page \ load target compiler
include 6502f83.fb \ load Forth Kernel Source
save-target f6502.com \ save new forth as f6502.com
key drop page .( Ready ) cr \ wait for keypress
bye \ and exit forth

680
sources/Apple1/crostarg.fb.src
View File

@ -1,680 +0,0 @@
Screen 0 not modified
0 \\ *** volksFORTH-84 Target-Compiler *** cas 26jan06
1
2 This Target Compiler can be used to create a new Forth System
3 using the Sourcecode 6502F82.FB.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Target compiler loadscr 09sep86we
1 \ Idea and first Implementation by ks/bp
2 \ Implemented on 6502 by ks/bp
3 \ ultraFORTH83-Version by bp/we
4 \ Atari 520 ST - Version by we
5 Onlyforth Assembler nonrelocate
6 07 Constant imagepage \ Virtual memory bank
7 Vocabulary Ttools
8 Vocabulary Defining
9 : .stat .blk .s ; ' .stat Is .status
10 \ : 65( [compile] ( ; immediate
11 : 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte|
12 1 $14 +thru \ Target compiler
13 $15 $17 +thru \ Target Tools
14 $18 $1A +thru \ Redefinitions
15 save $1B $24 +thru \ Predefinitions
Screen 2 not modified
0 \ Target header pointers bp05mar86we
1
2 Variable tdp : there tdp @ ;
3 Variable displace
4 Variable ?thead 0 ?thead !
5 Variable tlast 0 tlast !
6 Variable glast' 0 glast' !
7 Variable tdoes>
8 Variable >in:
9 Variable tvoc 0 tvoc !
10 Variable tvoc-link 0 tvoc-link !
11 Variable tnext-link 0 tnext-link !
12
13 : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
14
15
Screen 3 not modified
0 \ Image and byteorder 15sep86we
1
2 : >image ( addr1 - addr2 ) displace @ - ;
3
4 : >heap ( from quan - )
5 heap over - 1 and + \ 68000-align
6 dup hallot heap swap cmove ;
7 \\
8 : >ascii 2drop ; ' noop Alias C64>ascii
9
10 Code Lc@ ( laddr -- 8b )
11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move
12 .w D0 SP -) move Next end-code
13 Code Lc! ( 8b addr -- )
14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
15 Next end-code
Screen 4 not modified
0 \ Ghost-creating 05mar86we
1
2 0 | Constant <forw> 0 | Constant <res>
3
4 | : Make.ghost ( - cfa.ghost )
5 here dup 1 and allot here
6 state @ IF context @ ELSE current THEN @
7 dup @ , name
8 dup c@ 1 $1F uwithin not abort" inval.Gname"
9 dup c@ 1+ over c!
10 c@ dup 1+ allot 1 and 0= IF bl c, THEN
11 here 2 pick - -rot
12 <forw> , 0 , 0 ,
13 swap here over - >heap
14 heap swap ! swap dp !
15 heap + ;
Screen 5 not modified
0 \ ghost words 05mar86we
1
2 : gfind ( string - cfa tf / string ff )
3 dup count + 1+ bl swap c!
4 dup >r 1 over c+! find -1 r> c+! ;
5
6 : ghost ( - cfa )
7 >in @ name gfind IF nip exit THEN
8 drop >in ! Make.ghost ;
9
10 : Word, ghost execute ;
11
12 : gdoes> ( cfa.ghost - cfa.does )
13 4+ dup @ IF @ exit THEN
14 here dup <forw> , 0 , 4 >heap
15 dp ! heap dup rot ! ;
Screen 6 not modified
0 \ ghost utilities 04dec85we
1
2 : g' name gfind 0= abort" ?" ;
3
4 : '.
5 g' dup @ <forw> case?
6 IF ." forw" ELSE <res> - abort" ??" ." res" THEN
7 2+ dup @ 5 u.r
8 2+ @ ?dup
9 IF dup @ <forw> case?
10 IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
11 2+ @ 5 u.r THEN ;
12
13 ' ' Alias h'
14
15
Screen 7 not modified
0 \ .unresolved 05mar86we
1
2 | : forward? ( cfa - cfa / exit&true )
3 dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
4
5 | : unresolved? ( addr - f )
6 2+ dup c@ $1F and over + c@ BL =
7 IF name> forward? 4+ @ dup IF forward? THEN
8 THEN drop false ;
9
10 | : unresolved-words
11 BEGIN @ ?dup WHILE dup unresolved?
12 IF dup 2+ .name ?cr THEN REPEAT ;
13
14 : .unresolved voc-link @
15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
Screen 8 not modified
0 \ Extending Vocabularys for Target-Compilation 05mar86we
1
2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
3
4 Vocabulary Transient 0 tvoc !
5
6 Only definitions Forth also
7
8 : T Transient ; immediate
9 : H Forth ; immediate
10
11 definitions
12
13
14
15
Screen 9 not modified
0 \ Transient primitives 05mar86we
1
2 Code byte> ( 8bh 8bl -- 16b )
3 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
4 .w D0 SP ) move Next end-code
5 Code >byte ( 16b -- 8bl 8bh )
6 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
7 D0 SP -) move D1 SP -) move Next end-code
8
9 Transient definitions
10 : c@ H >image imagepage lc@ ;
11 : c! H >image imagepage lc! ;
12 : @ dup T c@ swap 1+ T c@ 65( swap ) byte> ;
13 : ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ;
14 : cmove ( from.mem to.target quan -)
15 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
Screen 10 not modified
0 \ Transient primitives bp05mar86we
1
2 : here there ;
3 : allot Tdp +! ;
4 : c, T here c! 1 allot H ;
5 : , T here ! 2 allot H ;
6
7 : ," Ascii " parse dup T c,
8 under there swap cmove
9 .( dup 1 and 0= IF 1+ THEN ) allot H ;
10
11 : fill ( addr quan 8b -)
12 -rot bounds ?DO dup I T c! H LOOP drop ;
13 : erase 0 T fill ;
14 : blank bl T fill ;
15 : here! H Tdp ! ;
Screen 11 not modified
0 \ Resolving 08dec85we
1 Forth definitions
2 : resolve ( cfa.ghost cfa.target -)
3 over dup @ <res> =
4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
5 >r >r 2+ @ ?dup
6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
7 H ?dup 0= UNTIL
8 THEN r> r> <res> over ! 2+ ! ;
9
10 : resdoes> ( cfa.ghost cfa.target -)
11 swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
13 ' <forw> >body !
14 ] Does> [ here 4- 0 ] @ T , H ;
15 ' <res> >body !
Screen 12 not modified
0 \ move-threads 68000-align cas 26jan06
1
2 : move-threads Tvoc @ Tvoc-link @
3 BEGIN over ?dup
4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
5 error" some undef. Target-Vocs left" drop ;
6
7 | : tlatest ( - addr) current @ 6 + ;
8
9 \\
10 not used for the 6502 architecture
11
12 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
13
14
15
Screen 13 not modified
0 \ save-target 09sep86we
1
2 Dos definitions
3
4 Code (filewrite ( buff len handle -- n)
5 SP )+ D0 move .l D2 clr .w SP )+ D2 move
6 .l 0 imagepage # D1 move .w SP )+ D1 move
7 .l D1 A7 -) move \ buffer adress
8 .l D2 A7 -) move \ buffer length
9 .w D0 A7 -) move \ handle
10 $40 # A7 -) move \ call WRITE
11 1 trap $0C # A7 adda
12 .w D0 SP -) move Next end-code Forth definitions
13
14
15
Screen 14 not modified
0 \ save Target-System 09sep86we
1
2 : save-target [ Dos ]
3 bl word count dup 0= abort" missing filename"
4 over + off (createfile dup >r 0< abort" no device "
5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
6 0 there r@ (filewrite there - abort" write error"
7 r> (closefile 0< abort" close error" ;
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \\ 6502-ALIGN ?HEAD \ 08SEP84BP)
1
2 | : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ;
3
4
5 | : 6502-align/2 ( lfa -- lfa )
6 there 0FF and 0FF =
7 IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid
8 1 tlast +! 1 tallot THEN ;
9
10
11
12
13
14
15
Screen 16 not modified
0 \\ WARNING CREATE 30DEC84BP)
1
2 VARIABLE WARNING 0 WARNING !
3
4 | : EXISTS?
5 WARNING @ ?EXIT
6 LAST @ CURRENT @ (FIND NIP
7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ;
8
9 : CREATE HERE BLK @ , CURRENT @ @ ,
10 NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME"
11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @
12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE
13 HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP !
14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 ,
15 ;CODE DOCREATE JMP END-CODE
Screen 17 not modified
0 \ compiling names into targ. 05mar86we
1
2 : (theader
3 ?thead @ IF 1 ?thead +!
4 there $FF and $FF = IF 1 T allot H THEN exit THEN
5 >in @ name swap >in !
6 dup c@ 1 $20 uwithin not abort" inval. Tname"
7 dup c@ 3 + there + $FF and $FF =
8 there 2+ $FF and $FF = or IF 1 T allot H THEN
9 blk @ T , H there tlatest dup @ T , H ! there dup tlast !
10 over c@ 1+ .( even ) dup T allot cmove H ;
11
12 : Theader tlast off
13 (theader Ghost dup glast' !
14 there resolve ;
15
Screen 18 not modified
0 \ prebuild defining words bp27jun85we
1
2 | : executable? ( adr - adr f ) dup ;
3 | : tpfa, there , ;
4 | : (prebuild ( cfa.adr -- )
5 >in @ Create >in ! here 2- ! ;
6
7 : prebuild ( adr 0.from.: - 0 )
8 0 ?pairs executable? dup >r
9 IF [compile] Literal compile (prebuild ELSE drop THEN
10 compile Theader Ghost gdoes> ,
11 r> IF compile tpfa, THEN 0 ; immediate restrict
12
13
14
15
Screen 19 not modified
0 \ code portion of def.words bp11sep86we
1
2 : dummy 0 ;
3
4 : DO> ( - adr.of.jmp.dodoes> 0 )
5 [compile] Does> here 4- compile @ 0 ] ;
6
7
8
9
10
11
12
13
14
15
Screen 20 not modified
0 \ the 68000 Assembler 11sep86we
1
2 Forth definitions
3 | Create relocate ] T c, , c@ here allot ! c! H [
4
5 Transient definitions
6
7 : Assembler H [ Tassembler ] relocate >codes ! Tassembler ;
8 : >label ( 16b -) H >in @ name gfind rot >in !
9 IF over resolve dup THEN drop Constant ;
10 : Label T .( here 1 and allot ) here >label Assembler H ;
11 : Code H Theader there 2+ T , Assembler H ;
12
13
14
15
Screen 21 not modified
0 \ immed. restr. ' \ compile bp05mar86we
1
2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
3 : >mark ( - addr ) H there T 0 , H ;
4 : >resolve ( addr - ) H there over - swap T ! H ;
5 : <mark ( - addr ) H there ;
6 : <resolve ( addr - ) H there - T , H ;
7 : immediate H Tlast @ ?dup
8 IF dup T c@ $40 or swap c! H THEN ;
9 : restrict H Tlast @ ?dup
10 IF dup T c@ $80 or swap c! H THEN ;
11 : ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
12 : | H ?thead @ ?exit ?thead on ;
13 : compile H Ghost , ; immediate restrict
14
15
Screen 22 not modified
0 \ Target tools ks05mar86we
1
2 Onlyforth Ttools also definitions
3
4 | : ttype ( adr n -) bounds ?DO I T c@ H dup
5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
7 ELSE ." ??? " THEN space ?cr ;
8 | : nfa? ( cfa lfa - nfa / cfa ff)
9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) =
10 IF 2+ nip exit THEN
11 T @ H REPEAT ;
12 : >name ( cfa - nfa / ff)
13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
14 IF nip exit THEN
15 swap REPEAT nip ;
Screen 23 not modified
0 \ Ttools for decompiling ks05mar86we
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup T @ H 6 u.r ;
4 | : c? dup T c@ H 3 .r ;
5
6 : s ( addr - addr+ ) ?: space c? 3 spaces
7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
8
9 : n ( addr - addr+2 ) ?: @? 2 spaces
10 dup T @ H [ Ttools ] >name .name H 2+ ;
11
12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
13 2 spaces -rot ttype ;
14
15
Screen 24 not modified
0 \ Tools for decompiling bp05mar86we
1
2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
3
4 : c ( addr -- addr+1 ) 1 d ;
5
6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
7
8 : dump ( adr n -) bounds ?DO cr I $10 d drop
9 stop? IF LEAVE THEN $10 +LOOP ;
10
11 : view T ' H [ Ttools ] >name ?dup
12 IF 4- T @ H l THEN ;
13
14
15
Screen 25 not modified
0 \ reinterpretation def.-words 05mar86we
1
2 Onlyforth
3
4 : redefinition
5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push
6 state push context push >in: @ >in !
7 name [ ' Transient 2+ ] Literal (find nip 0=
8 IF cr ." Redefinition: " here .name
9 >in: @ >in ! : Defining interpret THEN
10 THEN 0 tdoes> ! ;
11
12
13
14
15
Screen 26 not modified
0 \ Create..does> structure bp05mar86we
1
2 | : (;tcode
3 Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ;
4 | : changecfa compile lit tdoes> @ , compile (;tcode ;
5
6 Defining definitions
7
8 : ;code 0 ?pairs changecfa reveal rdrop ;
9 immediate restrict
10
11 Defining ' ;code Alias does> immediate restrict
12
13 : ; [compile] ; rdrop ; immediate restrict
14
15
Screen 27 not modified
0 \ redefinition conditionals bp27jun85we
1
2 ' DO Alias DO immediate restrict
3 ' ?DO Alias ?DO immediate restrict
4 ' LOOP Alias LOOP immediate restrict
5 ' IF Alias IF immediate restrict
6 ' THEN Alias THEN immediate restrict
7 ' ELSE Alias ELSE immediate restrict
8 ' BEGIN Alias BEGIN immediate restrict
9 ' UNTIL Alias UNTIL immediate restrict
10 ' WHILE Alias WHILE immediate restrict
11 ' REPEAT Alias REPEAT immediate restrict
12
13
14
15
Screen 28 not modified
0 \ clear Liter. Ascii ['] ." bp05mar86we
1
2 Onlyforth Transient definitions
3
4 : clear true abort" There are ghosts" ;
5 : Literal ( n -) T compile lit , H ; immediate
6 : Ascii H bl word 1+ c@ state @
7 IF T [compile] Literal H THEN ; immediate
8 : ['] T ' [compile] Literal H ; immediate restrict
9 : " T compile (" ," H ; immediate restrict
10 : ." T compile (." ," H ; immediate restrict
11
12
13
14
15
Screen 29 not modified
0 \ Target compilation ] [ bp05mar86we
1
2 Forth definitions
3
4 : tcompile
5 ?stack >in @ name find ?dup
6 IF 0> IF nip execute >interpret THEN
7 drop dup >in ! name
8 THEN gfind IF nip execute >interpret THEN
9 nullstring? IF drop exit THEN
10 number? ?dup IF 0> IF swap T [compile] Literal THEN
11 [compile] Literal H drop >interpret THEN
12 drop >in ! Word, >interpret ;
13
14 Transient definitions
15 : ] H state on ['] tcompile is >interpret ;
Screen 30 not modified
0 \ Target conditionals bp05mar86we
1
2 : IF T compile ?branch >mark H 1 ; immediate restrict
3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict
4 : ELSE T 1 ?pairs compile branch >mark swap >resolve
5 H -1 ; immediate restrict
6 : BEGIN T <mark H 2 ; immediate restrict
7 : WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
8 immediate restrict
9 | : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
10 WHILE drop T >resolve H REPEAT ;
11 : UNTIL T compile ?branch (repeat H ; immediate restrict
12 : REPEAT T compile branch (repeat H ; immediate restrict
13
14
15
Screen 31 not modified
0 \ Target conditionals bp27jun85we
1
2 : DO T compile (do >mark H 3 ; immediate restrict
3 : ?DO T compile (?do >mark H 3 ; immediate restrict
4 : LOOP T 3 ?pairs compile (loop compile endloop
5 >resolve H ; immediate restrict
6 : +LOOP T 3 ?pairs compile (+loop compile endloop
7 >resolve H ; immediate restrict
8
9
10
11
12
13
14
15
Screen 32 not modified
0 \ predefinitions bp05mar86we
1
2 : abort" T compile (abort" ," H ; immediate
3 : error" T compile (err" ," H ; immediate
4
5 Forth definitions
6
7 Variable torigin
8 Variable tudp 0 Tudp !
9
10 : >user T c@ H torigin @ + ;
11
12
13
14
15
Screen 33 not modified
0 \ Datatypes bp05mar86we
1
2 Transient definitions
3 : origin! H torigin ! ;
4 : user' ( -- n ) T ' >body c@ H ;
5 : uallot ( n -- ) H tudp @ swap tudp +! ;
6
7 DO> >user ;
8 : User prebuild User 2 T uallot c, ;
9
10 DO> ;
11 : Create prebuild Create ;
12
13 DO> T @ H ;
14 : Constant prebuild Constant T , ;
15 : Variable Create 2 T allot ;
Screen 34 not modified
0 \ Datatypes bp05mar86we
1
2 dummy
3 : Vocabulary
4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
5 here H tvoc-link @ T , H tvoc-link ! ;
6
7
8
9
10
11
12
13
14
15
Screen 35 not modified
0 \ target defining words bp08sep86we
1
2 Do> ;
3 : Defer prebuild Defer 2 T allot ;
4 : Is T ' H >body state @ IF T compile (is , H
5 ELSE T ! H THEN ; immediate
6 | : dodoes> T compile (;code H Glast' @
7 there resdoes> there tdoes> ! ;
8
9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [
10 redefinition ; immediate restrict
11
12 : does> T dodoes> $04C C,
13 compile (dodoes> H ; immediate restrict
14
15
Screen 36 not modified
0 \ : Alias ; bp25mar86we
1
2 : Create: T Create H current @ context ! T ] H 0 ;
3
4 dummy
5 : : H tdoes> off >in @ >in: ! T prebuild :
6 H current @ context ! T ] H 0 ;
7
8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve
9 tlast @ T c@ H $20 or tlast @ T c! , H ;
10
11 : ; T 0 ?pairs compile exit .( unnest gegen exit getauscht)
12 [compile] [ H redefinition ; immediate restrict
13
14
15
Screen 37 not modified
0 \ predefinitions bp11sep86we
1
2 : compile T compile compile H ; immediate restrict
3 : Host H Onlyforth Ttools also ;
4 : Compiler T Host H Transient also definitions ;
5 : [compile] H Word, ; immediate restrict
6 : Onlypatch H there 3 - 0 tdoes> ! 0 ;
7
8 Onlyforth
9 : Target Onlyforth Transient also definitions ;
10
11 Transient definitions
12 Ghost c, drop
13
14
15
Screen 38 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 39 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

680
sources/Apple1/crostarg.fth Normal file
View File

@ -0,0 +1,680 @@
\ *** Block No. 0 Hexblock 0
\\ *** volksFORTH-84 Target-Compiler *** cas 26jan06
This Target Compiler can be used to create a new Forth System
using the Sourcecode 6502F82.FB.
\ *** Block No. 1 Hexblock 1
\ Target compiler loadscr 09sep86we
\ Idea and first Implementation by ks/bp
\ Implemented on 6502 by ks/bp
\ ultraFORTH83-Version by bp/we
\ Atari 520 ST - Version by we
Onlyforth Assembler nonrelocate
07 Constant imagepage \ Virtual memory bank
Vocabulary Ttools
Vocabulary Defining
: .stat .blk .s ; ' .stat Is .status
\ : 65( [compile] ( ; immediate
: 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte|
1 $14 +thru \ Target compiler
$15 $17 +thru \ Target Tools
$18 $1A +thru \ Redefinitions
save $1B $24 +thru \ Predefinitions
\ *** Block No. 2 Hexblock 2
\ Target header pointers bp05mar86we
Variable tdp : there tdp @ ;
Variable displace
Variable ?thead 0 ?thead !
Variable tlast 0 tlast !
Variable glast' 0 glast' !
Variable tdoes>
Variable >in:
Variable tvoc 0 tvoc !
Variable tvoc-link 0 tvoc-link !
Variable tnext-link 0 tnext-link !
: c+! ( 8b addr -- ) dup c@ rot + swap c! ;
\ *** Block No. 3 Hexblock 3
\ Image and byteorder 15sep86we
: >image ( addr1 - addr2 ) displace @ - ;
: >heap ( from quan - )
heap over - 1 and + \ 68000-align
dup hallot heap swap cmove ;
\\
: >ascii 2drop ; ' noop Alias C64>ascii
Code Lc@ ( laddr -- 8b )
.l SP )+ A0 move .w D0 clr .b A0 ) D0 move
.w D0 SP -) move Next end-code
Code Lc! ( 8b addr -- )
.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
Next end-code
\ *** Block No. 4 Hexblock 4
\ Ghost-creating 05mar86we
0 | Constant <forw> 0 | Constant <res>
| : Make.ghost ( - cfa.ghost )
here dup 1 and allot here
state @ IF context @ ELSE current THEN @
dup @ , name
dup c@ 1 $1F uwithin not abort" inval.Gname"
dup c@ 1+ over c!
c@ dup 1+ allot 1 and 0= IF bl c, THEN
here 2 pick - -rot
<forw> , 0 , 0 ,
swap here over - >heap
heap swap ! swap dp !
heap + ;
\ *** Block No. 5 Hexblock 5
\ ghost words 05mar86we
: gfind ( string - cfa tf / string ff )
dup count + 1+ bl swap c!
dup >r 1 over c+! find -1 r> c+! ;
: ghost ( - cfa )
>in @ name gfind IF nip exit THEN
drop >in ! Make.ghost ;
: Word, ghost execute ;
: gdoes> ( cfa.ghost - cfa.does )
4+ dup @ IF @ exit THEN
here dup <forw> , 0 , 4 >heap
dp ! heap dup rot ! ;
\ *** Block No. 6 Hexblock 6
\ ghost utilities 04dec85we
: g' name gfind 0= abort" ?" ;
: '.
g' dup @ <forw> case?
IF ." forw" ELSE <res> - abort" ??" ." res" THEN
2+ dup @ 5 u.r
2+ @ ?dup
IF dup @ <forw> case?
IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
2+ @ 5 u.r THEN ;
' ' Alias h'
\ *** Block No. 7 Hexblock 7
\ .unresolved 05mar86we
| : forward? ( cfa - cfa / exit&true )
dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
| : unresolved? ( addr - f )
2+ dup c@ $1F and over + c@ BL =
IF name> forward? 4+ @ dup IF forward? THEN
THEN drop false ;
| : unresolved-words
BEGIN @ ?dup WHILE dup unresolved?
IF dup 2+ .name ?cr THEN REPEAT ;
: .unresolved voc-link @
BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
\ *** Block No. 8 Hexblock 8
\ Extending Vocabularys for Target-Compilation 05mar86we
: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
Vocabulary Transient 0 tvoc !
Only definitions Forth also
: T Transient ; immediate
: H Forth ; immediate
definitions
\ *** Block No. 9 Hexblock 9
\ Transient primitives 05mar86we
Code byte> ( 8bh 8bl -- 16b )
SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
.w D0 SP ) move Next end-code
Code >byte ( 16b -- 8bl 8bh )
SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
D0 SP -) move D1 SP -) move Next end-code
Transient definitions
: c@ H >image imagepage lc@ ;
: c! H >image imagepage lc! ;
: @ dup T c@ swap 1+ T c@ 65( swap ) byte> ;
: ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ;
: cmove ( from.mem to.target quan -)
bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
\ *** Block No. 10 Hexblock A
\ Transient primitives bp05mar86we
: here there ;
: allot Tdp +! ;
: c, T here c! 1 allot H ;
: , T here ! 2 allot H ;
: ," Ascii " parse dup T c,
under there swap cmove
.( dup 1 and 0= IF 1+ THEN ) allot H ;
: fill ( addr quan 8b -)
-rot bounds ?DO dup I T c! H LOOP drop ;
: erase 0 T fill ;
: blank bl T fill ;
: here! H Tdp ! ;
\ *** Block No. 11 Hexblock B
\ Resolving 08dec85we
Forth definitions
: resolve ( cfa.ghost cfa.target -)
over dup @ <res> =
IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
>r >r 2+ @ ?dup
IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
H ?dup 0= UNTIL
THEN r> r> <res> over ! 2+ ! ;
: resdoes> ( cfa.ghost cfa.target -)
swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
' <forw> >body !
] Does> [ here 4- 0 ] @ T , H ;
' <res> >body !
\ *** Block No. 12 Hexblock C
\ move-threads 68000-align cas 26jan06
: move-threads Tvoc @ Tvoc-link @
BEGIN over ?dup
WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
error" some undef. Target-Vocs left" drop ;
| : tlatest ( - addr) current @ 6 + ;
\\
not used for the 6502 architecture
| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
\ *** Block No. 13 Hexblock D
\ save-target 09sep86we
Dos definitions
Code (filewrite ( buff len handle -- n)
SP )+ D0 move .l D2 clr .w SP )+ D2 move
.l 0 imagepage # D1 move .w SP )+ D1 move
.l D1 A7 -) move \ buffer adress
.l D2 A7 -) move \ buffer length
.w D0 A7 -) move \ handle
$40 # A7 -) move \ call WRITE
1 trap $0C # A7 adda
.w D0 SP -) move Next end-code Forth definitions
\ *** Block No. 14 Hexblock E
\ save Target-System 09sep86we
: save-target [ Dos ]
bl word count dup 0= abort" missing filename"
over + off (createfile dup >r 0< abort" no device "
T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
0 there r@ (filewrite there - abort" write error"
r> (closefile 0< abort" close error" ;
\ *** Block No. 15 Hexblock F
\\ 6502-ALIGN ?HEAD \ 08SEP84BP)
| : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ;
| : 6502-align/2 ( lfa -- lfa )
there 0FF and 0FF =
IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid
1 tlast +! 1 tallot THEN ;
\ *** Block No. 16 Hexblock 10
\\ 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 020 UWITHIN NOT ABORT" INVALID NAME"
HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @
IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE
HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP !
ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 ,
;CODE DOCREATE JMP END-CODE
\ *** Block No. 17 Hexblock 11
\ compiling names into targ. 05mar86we
: (theader
?thead @ IF 1 ?thead +!
there $FF and $FF = IF 1 T allot H THEN exit THEN
>in @ name swap >in !
dup c@ 1 $20 uwithin not abort" inval. Tname"
dup c@ 3 + there + $FF and $FF =
there 2+ $FF and $FF = or IF 1 T allot H THEN
blk @ T , H there tlatest dup @ T , H ! there dup tlast !
over c@ 1+ .( even ) dup T allot cmove H ;
: Theader tlast off
(theader Ghost dup glast' !
there resolve ;
\ *** Block No. 18 Hexblock 12
\ prebuild defining words bp27jun85we
| : executable? ( adr - adr f ) dup ;
| : tpfa, there , ;
| : (prebuild ( cfa.adr -- )
>in @ Create >in ! here 2- ! ;
: prebuild ( adr 0.from.: - 0 )
0 ?pairs executable? dup >r
IF [compile] Literal compile (prebuild ELSE drop THEN
compile Theader Ghost gdoes> ,
r> IF compile tpfa, THEN 0 ; immediate restrict
\ *** Block No. 19 Hexblock 13
\ code portion of def.words bp11sep86we
: dummy 0 ;
: DO> ( - adr.of.jmp.dodoes> 0 )
[compile] Does> here 4- compile @ 0 ] ;
\ *** Block No. 20 Hexblock 14
\ the 68000 Assembler 11sep86we
Forth definitions
| Create relocate ] T c, , c@ here allot ! c! H [
Transient definitions
: Assembler H [ Tassembler ] relocate >codes ! Tassembler ;
: >label ( 16b -) H >in @ name gfind rot >in !
IF over resolve dup THEN drop Constant ;
: Label T .( here 1 and allot ) here >label Assembler H ;
: Code H Theader there 2+ T , Assembler H ;
\ *** Block No. 21 Hexblock 15
\ immed. restr. ' \ compile bp05mar86we
: ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
: >mark ( - addr ) H there T 0 , H ;
: >resolve ( addr - ) H there over - swap T ! H ;
: <mark ( - addr ) H there ;
: <resolve ( addr - ) H there - T , H ;
: immediate H Tlast @ ?dup
IF dup T c@ $40 or swap c! H THEN ;
: restrict H Tlast @ ?dup
IF dup T c@ $80 or swap c! H THEN ;
: ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
: | H ?thead @ ?exit ?thead on ;
: compile H Ghost , ; immediate restrict
\ *** Block No. 22 Hexblock 16
\ Target tools ks05mar86we
Onlyforth Ttools also definitions
| : ttype ( adr n -) bounds ?DO I T c@ H dup
bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
ELSE ." ??? " THEN space ?cr ;
| : nfa? ( cfa lfa - nfa / cfa ff)
BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) =
IF 2+ nip exit THEN
T @ H REPEAT ;
: >name ( cfa - nfa / ff)
Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
IF nip exit THEN
swap REPEAT nip ;
\ *** Block No. 23 Hexblock 17
\ Ttools for decompiling ks05mar86we
| : ?: dup 4 u.r ." :" ;
| : @? dup T @ H 6 u.r ;
| : c? dup T c@ H 3 .r ;
: s ( addr - addr+ ) ?: space c? 3 spaces
dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
: n ( addr - addr+2 ) ?: @? 2 spaces
dup T @ H [ Ttools ] >name .name H 2+ ;
: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
2 spaces -rot ttype ;
\ *** Block No. 24 Hexblock 18
\ Tools for decompiling bp05mar86we
: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
: c ( addr -- addr+1 ) 1 d ;
: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
: dump ( adr n -) bounds ?DO cr I $10 d drop
stop? IF LEAVE THEN $10 +LOOP ;
: view T ' H [ Ttools ] >name ?dup
IF 4- T @ H l THEN ;
\ *** Block No. 25 Hexblock 19
\ reinterpretation def.-words 05mar86we
Onlyforth
: redefinition
tdoes> @ IF >in push [ ' >interpret >body ] Literal push
state push context push >in: @ >in !
name [ ' Transient 2+ ] Literal (find nip 0=
IF cr ." Redefinition: " here .name
>in: @ >in ! : Defining interpret THEN
THEN 0 tdoes> ! ;
\ *** Block No. 26 Hexblock 1A
\ Create..does> structure bp05mar86we
| : (;tcode
Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ;
| : changecfa compile lit tdoes> @ , compile (;tcode ;
Defining definitions
: ;code 0 ?pairs changecfa reveal rdrop ;
immediate restrict
Defining ' ;code Alias does> immediate restrict
: ; [compile] ; rdrop ; immediate restrict
\ *** Block No. 27 Hexblock 1B
\ redefinition conditionals bp27jun85we
' DO Alias DO immediate restrict
' ?DO Alias ?DO immediate restrict
' LOOP Alias LOOP immediate restrict
' IF Alias IF immediate restrict
' THEN Alias THEN immediate restrict
' ELSE Alias ELSE immediate restrict
' BEGIN Alias BEGIN immediate restrict
' UNTIL Alias UNTIL immediate restrict
' WHILE Alias WHILE immediate restrict
' REPEAT Alias REPEAT immediate restrict
\ *** Block No. 28 Hexblock 1C
\ clear Liter. Ascii ['] ." bp05mar86we
Onlyforth Transient definitions
: clear true abort" There are ghosts" ;
: Literal ( n -) T compile lit , H ; immediate
: Ascii H bl word 1+ c@ state @
IF T [compile] Literal H THEN ; immediate
: ['] T ' [compile] Literal H ; immediate restrict
: " T compile (" ," H ; immediate restrict
: ." T compile (." ," H ; immediate restrict
\ *** Block No. 29 Hexblock 1D
\ Target compilation ] [ bp05mar86we
Forth definitions
: tcompile
?stack >in @ name find ?dup
IF 0> IF nip execute >interpret THEN
drop dup >in ! name
THEN gfind IF nip execute >interpret THEN
nullstring? IF drop exit THEN
number? ?dup IF 0> IF swap T [compile] Literal THEN
[compile] Literal H drop >interpret THEN
drop >in ! Word, >interpret ;
Transient definitions
: ] H state on ['] tcompile is >interpret ;
\ *** Block No. 30 Hexblock 1E
\ Target conditionals bp05mar86we
: IF T compile ?branch >mark H 1 ; immediate restrict
: THEN abs 1 T ?pairs >resolve H ; immediate restrict
: ELSE T 1 ?pairs compile branch >mark swap >resolve
H -1 ; immediate restrict
: BEGIN T <mark H 2 ; immediate restrict
: WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
immediate restrict
| : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
WHILE drop T >resolve H REPEAT ;
: UNTIL T compile ?branch (repeat H ; immediate restrict
: REPEAT T compile branch (repeat H ; immediate restrict
\ *** Block No. 31 Hexblock 1F
\ Target conditionals bp27jun85we
: DO T compile (do >mark H 3 ; immediate restrict
: ?DO T compile (?do >mark H 3 ; immediate restrict
: LOOP T 3 ?pairs compile (loop compile endloop
>resolve H ; immediate restrict
: +LOOP T 3 ?pairs compile (+loop compile endloop
>resolve H ; immediate restrict
\ *** Block No. 32 Hexblock 20
\ predefinitions bp05mar86we
: abort" T compile (abort" ," H ; immediate
: error" T compile (err" ," H ; immediate
Forth definitions
Variable torigin
Variable tudp 0 Tudp !
: >user T c@ H torigin @ + ;
\ *** Block No. 33 Hexblock 21
\ Datatypes bp05mar86we
Transient definitions
: origin! H torigin ! ;
: user' ( -- n ) T ' >body c@ H ;
: uallot ( n -- ) H tudp @ swap tudp +! ;
DO> >user ;
: User prebuild User 2 T uallot c, ;
DO> ;
: Create prebuild Create ;
DO> T @ H ;
: Constant prebuild Constant T , ;
: Variable Create 2 T allot ;
\ *** Block No. 34 Hexblock 22
\ Datatypes bp05mar86we
dummy
: Vocabulary
H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
here H tvoc-link @ T , H tvoc-link ! ;
\ *** Block No. 35 Hexblock 23
\ target defining words bp08sep86we
Do> ;
: Defer prebuild Defer 2 T allot ;
: Is T ' H >body state @ IF T compile (is , H
ELSE T ! H THEN ; immediate
| : dodoes> T compile (;code H Glast' @
there resdoes> there tdoes> ! ;
: ;code 0 T ?pairs dodoes> Assembler H [compile] [
redefinition ; immediate restrict
: does> T dodoes> $04C C,
compile (dodoes> H ; immediate restrict
\ *** Block No. 36 Hexblock 24
\ : Alias ; bp25mar86we
: Create: T Create H current @ context ! T ] H 0 ;
dummy
: : H tdoes> off >in @ >in: ! T prebuild :
H current @ context ! T ] H 0 ;
: Alias ( n -- ) H Tlast off (theader Ghost over resolve
tlast @ T c@ H $20 or tlast @ T c! , H ;
: ; T 0 ?pairs compile exit .( unnest gegen exit getauscht)
[compile] [ H redefinition ; immediate restrict
\ *** Block No. 37 Hexblock 25
\ predefinitions bp11sep86we
: compile T compile compile H ; immediate restrict
: Host H Onlyforth Ttools also ;
: Compiler T Host H Transient also definitions ;
: [compile] H Word, ; immediate restrict
: Onlypatch H there 3 - 0 tdoes> ! 0 ;
Onlyforth
: Target Onlyforth Transient also definitions ;
Transient definitions
Ghost c, drop
\ *** Block No. 38 Hexblock 26
\ *** Block No. 39 Hexblock 27

187
sources/Apple1/systemio.fb.src
View File

@ -1,187 +0,0 @@
Screen 0 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ loadscreen for system IO for Apple1 cas2013apr05
1
2
3 1 9 +thru
4
5
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ 65KEY? GETKEY cas2013apr05
1 | $D010 Constant KBDDTA
2 | $D011 Constant KBDCTL
3
4 | CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]?
5 push0a jmp end-code
6
7 | CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND
8 push0a jmp end-code
9
10 | CODE CURON ( --) NEXT JMP END-CODE
11
12 | CODE CUROFF ( --) NEXT JMP END-CODE
13
14 : 65KEY ( -- 8B)
15 CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ;
Screen 3 not modified
0 \ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05
1 08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC
2
3 : 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2)
4 #BS CASE? IF DUP IF DEL 1- THEN EXIT THEN
5 #CR CASE? IF DUP SPAN ! EXIT THEN
6 >R 2DUP + R@ SWAP C! R> EMIT 1+ ;
7
8 : 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0
9 BEGIN DUP SPAN @ U<
10 WHILE KEY DECODE
11 REPEAT 2DROP SPACE ;
12
13 INPUT: KEYBOARD [ HERE INPUT ! ]
14 65KEY 65KEY? 65DECODE 65EXPECT [
15
Screen 4 not modified
0 \ senden? (emit 65emit 25JAN85RE) cas2013apr05
1
2 | $D012 Constant DSP
3
4 | Code send? ( -- flg )
5 DSP lda $80 # AND $80 # EOR push0a jmp end-code
6
7 Code (emit ( 8b -- )
8 SP X) LDA DSP sta (drop jmp end-code
9
10
11
12
13
14
15
Screen 5 not modified
0 \ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05
1
2 | Variable out 0 out ! | &40 Constant c/row
3
4 : 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ;
5
6 : 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ;
7
8 : 65DEL ASCII _ 65emit -1 out +! ;
9
10 : 65PAGE &24 0 DO CR LOOP out off ;
11
12 : 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ;
13
14 : 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ;
15
Screen 6 not modified
0 \ er14dez88
1
2 : 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ;
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 7 not modified
0 \ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88
1
2 OUTPUT: DISPLAY [ HERE OUTPUT ! ]
3 65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [
4
5
6 | : (bye ;
7
8
9
10
11
12
13
14
15
Screen 8 not modified
0 \ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88
1
2 $400 CONSTANT B/BLK
3
4 $0AA CONSTANT BLK/DRV
5
6 | VARIABLE (DRV 0 (DRV !
7
8 | : DISK ( -- DEV.NO ) (DRV @ 8 + ;
9
10 : DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ;
11
12
13
14
15
Screen 9 not modified
0 \ er14dez88
1 : >DRIVE ( BLOCK DRV# -- BLOCK' )
2 BLK/DRV * + OFFSET @ - ;
3 : DRV? ( BLOCK -- DRV# )
4 OFFSET @ + BLK/DRV / ;
5
6 : DRVINIT NOOP ;
7 .( fuer reads. u. writes. ist errorhandler erforderlich )
8 | : readserial ( adr blk -- )
9 &27 emit .( rb ) space base push decimal . cr
10 $400 bounds DO key I c! LOOP ;
11
12 | : writeserial ( adr blk -- )
13 &27 emit .( wb ) space base push decimal . cr
14 $400 bounds DO I c@ emit LOOP ;
15
Screen 10 not modified
0 \ (r/w er14decas
1
2 : (R/W ( ADR BLK FILE R/WF -- FLAG)
3 swap abort" no file"
4 IF readserial ELSE writeserial THEN false ;
5
6 ' (R/W IS R/W
7
8
9
10
11
12
13
14
15

187
sources/Apple1/systemio.fth Normal file
View File

@ -0,0 +1,187 @@
\ *** Block No. 0 Hexblock 0
\ *** Block No. 1 Hexblock 1
\ loadscreen for system IO for Apple1 cas2013apr05
1 9 +thru
\ *** Block No. 2 Hexblock 2
\ 65KEY? GETKEY cas2013apr05
| $D010 Constant KBDDTA
| $D011 Constant KBDCTL
| CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]?
push0a jmp end-code
| CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND
push0a jmp end-code
| CODE CURON ( --) NEXT JMP END-CODE
| CODE CUROFF ( --) NEXT JMP END-CODE
: 65KEY ( -- 8B)
CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ;
\ *** Block No. 3 Hexblock 3
\ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05
08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC
: 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2)
#BS CASE? IF DUP IF DEL 1- THEN EXIT THEN
#CR CASE? IF DUP SPAN ! EXIT THEN
>R 2DUP + R@ SWAP C! R> EMIT 1+ ;
: 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0
BEGIN DUP SPAN @ U<
WHILE KEY DECODE
REPEAT 2DROP SPACE ;
INPUT: KEYBOARD [ HERE INPUT ! ]
65KEY 65KEY? 65DECODE 65EXPECT [
\ *** Block No. 4 Hexblock 4
\ senden? (emit 65emit 25JAN85RE) cas2013apr05
| $D012 Constant DSP
| Code send? ( -- flg )
DSP lda $80 # AND $80 # EOR push0a jmp end-code
Code (emit ( 8b -- )
SP X) LDA DSP sta (drop jmp end-code
\ *** Block No. 5 Hexblock 5
\ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05
| Variable out 0 out ! | &40 Constant c/row
: 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ;
: 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ;
: 65DEL ASCII _ 65emit -1 out +! ;
: 65PAGE &24 0 DO CR LOOP out off ;
: 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ;
: 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ;
\ *** Block No. 6 Hexblock 6
\ er14dez88
: 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ;
\ *** Block No. 7 Hexblock 7
\ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88
OUTPUT: DISPLAY [ HERE OUTPUT ! ]
65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [
| : (bye ;
\ *** Block No. 8 Hexblock 8
\ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88
$400 CONSTANT B/BLK
$0AA CONSTANT BLK/DRV
| VARIABLE (DRV 0 (DRV !
| : DISK ( -- DEV.NO ) (DRV @ 8 + ;
: DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ;
\ *** Block No. 9 Hexblock 9
\ er14dez88
: >DRIVE ( BLOCK DRV# -- BLOCK' )
BLK/DRV * + OFFSET @ - ;
: DRV? ( BLOCK -- DRV# )
OFFSET @ + BLK/DRV / ;
: DRVINIT NOOP ;
.( fuer reads. u. writes. ist errorhandler erforderlich )
| : readserial ( adr blk -- )
&27 emit .( rb ) space base push decimal . cr
$400 bounds DO key I c! LOOP ;
| : writeserial ( adr blk -- )
&27 emit .( wb ) space base push decimal . cr
$400 bounds DO I c@ emit LOOP ;
\ *** Block No. 10 Hexblock A
\ (r/w er14decas
: (R/W ( ADR BLK FILE R/WF -- FLAG)
swap abort" no file"
IF readserial ELSE writeserial THEN false ;
' (R/W IS R/W

170
sources/Apple1/tasker.fb.src
View File

@ -1,170 +0,0 @@
Screen 0 not modified
0 \ Multitasking Extension to volksFORTH cas 26jan06
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Tasker Loadscreen
1
2 \NEEDS CODE abort( Assembler needed )
3 hex
4 1 5 +thru \ load Tasker
5 7 load \ Task-Demo
6 decimal
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ MULTITASKER BP 13.9.84 )
1
2 CODE STOP
3 SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA
4 SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA
5 6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA
6 1 # LDY TYA CLC UP ADC W STA
7 TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE
8
9 | CREATE TASKPAUSE ASSEMBLER
10 2C # LDA UP X) STA ' STOP @ JMP END-CODE
11
12 : SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ;
13
14 : MULTITASK TASKPAUSE ['] PAUSE ! ;
15
Screen 3 not modified
0 \ PASS ACTIVATE KS 8 MAY 84 )
1
2 : PASS ( N0 .. NR-1 TADR R -- )
3 BEGIN [ ROT ( TRICK ! ) ]
4 SWAP 02C OVER C! \ AWAKE TASK
5 R> -ROT \ IP R ADDR
6 8 + >R \ S0 OF TASK
7 R@ 2+ @ SWAP \ IP R0 R
8 2+ 2* \ BYTES ON TASKSTACK
9 \ INCL. R0 & IP
10 R@ @ OVER - \ NEW SP
11 DUP R> 2- ! \ INTO SSAVE
12 SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT
13
14
15
Screen 4 not modified
0 \
1
2 : ACTIVATE ( TADR --)
3 0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT
4
5 : SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE
6
7 : WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE
8
9 | : TASKERROR ( STRING -)
10 STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE
11 MULTITASK STOP ;
12
13
14
15
Screen 5 not modified
0 \ BUILDING A TASK BP 13.9.84 )
1
2 : TASK ( RLEN SLEN -- )
3 ALLOT \ STACK
4 HERE 00FF AND 0FE =
5 IF 1 ALLOT THEN \ 6502-ALIGN
6 UP@ HERE 100 CMOVE \ INIT USER AREA
7 HERE 04C C, \ JMP OPCODE TO SLEEP TASK
8 UP@ 1+ @ ,
9 DUP UP@ 1+ ! \ LINK TASK
10 3 ALLOT \ ALLOT JSR WAKE
11 DUP 6 - DUP , , \ SSAVE AND S0
12 2DUP + , \ HERE + RLEN = R0
13 UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER
14 [ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ;
15
Screen 6 not modified
0 \ MORE TASKS KS/BP 26APR85RE)
1
2 : RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ;
3
4 | : STATESMART STATE @ IF [COMPILE] LITERAL THEN ;
5
6 : 'S ( TADR - ADR.OF.TASKUSERVAR)
7 ' >BODY C@ + STATESMART ; IMMEDIATE
8
9 \ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY
10
11 : TASKS ( -) ." MAIN " CR UP@ DUP 1+ @
12 BEGIN 2DUP - WHILE
13 DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME
14 DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ;
15
Screen 7 not modified
0 \ TASKDEMO 27APR85RE)
1 : TASKMARK ;
2
3 VARIABLE COUNTER COUNTER OFF
4
5 100 100 TASK BACKGROUND
6
7 : >COUNT ( N -) BACKGROUND 1 PASS COUNTER !
8 BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP
9 WHILE PAUSE 0 <# #S #> type REPEAT stop ;
10
11 : WAIT BACKGROUND SLEEP ;
12
13 : GO BACKGROUND WAKE ;
14
15
Screen 8 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

170
sources/Apple1/tasker.fth Normal file
View File

@ -0,0 +1,170 @@
\ *** Block No. 0 Hexblock 0
\ Multitasking Extension to volksFORTH cas 26jan06
\ *** Block No. 1 Hexblock 1
\ Tasker Loadscreen
\NEEDS CODE abort( Assembler needed )
hex
1 5 +thru \ load Tasker
7 load \ Task-Demo
decimal
\ *** Block No. 2 Hexblock 2
\ MULTITASKER BP 13.9.84 )
CODE STOP
SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA
SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA
6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA
1 # LDY TYA CLC UP ADC W STA
TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE
| CREATE TASKPAUSE ASSEMBLER
2C # LDA UP X) STA ' STOP @ JMP END-CODE
: SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ;
: MULTITASK TASKPAUSE ['] PAUSE ! ;
\ *** Block No. 3 Hexblock 3
\ PASS ACTIVATE KS 8 MAY 84 )
: PASS ( N0 .. NR-1 TADR R -- )
BEGIN [ ROT ( TRICK ! ) ]
SWAP 02C OVER C! \ AWAKE TASK
R> -ROT \ IP R ADDR
8 + >R \ S0 OF TASK
R@ 2+ @ SWAP \ IP R0 R
2+ 2* \ BYTES ON TASKSTACK
\ INCL. R0 & IP
R@ @ OVER - \ NEW SP
DUP R> 2- ! \ INTO SSAVE
SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT
\ *** Block No. 4 Hexblock 4
\
: ACTIVATE ( TADR --)
0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT
: SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE
: WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE
| : TASKERROR ( STRING -)
STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE
MULTITASK STOP ;
\ *** Block No. 5 Hexblock 5
\ BUILDING A TASK BP 13.9.84 )
: TASK ( RLEN SLEN -- )
ALLOT \ STACK
HERE 00FF AND 0FE =
IF 1 ALLOT THEN \ 6502-ALIGN
UP@ HERE 100 CMOVE \ INIT USER AREA
HERE 04C C, \ JMP OPCODE TO SLEEP TASK
UP@ 1+ @ ,
DUP UP@ 1+ ! \ LINK TASK
3 ALLOT \ ALLOT JSR WAKE
DUP 6 - DUP , , \ SSAVE AND S0
2DUP + , \ HERE + RLEN = R0
UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER
[ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ;
\ *** Block No. 6 Hexblock 6
\ MORE TASKS KS/BP 26APR85RE)
: RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ;
| : STATESMART STATE @ IF [COMPILE] LITERAL THEN ;
: 'S ( TADR - ADR.OF.TASKUSERVAR)
' >BODY C@ + STATESMART ; IMMEDIATE
\ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY
: TASKS ( -) ." MAIN " CR UP@ DUP 1+ @
BEGIN 2DUP - WHILE
DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME
DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ;
\ *** Block No. 7 Hexblock 7
\ TASKDEMO 27APR85RE)
: TASKMARK ;
VARIABLE COUNTER COUNTER OFF
100 100 TASK BACKGROUND
: >COUNT ( N -) BACKGROUND 1 PASS COUNTER !
BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP
WHILE PAUSE 0 <# #S #> type REPEAT stop ;
: WAIT BACKGROUND SLEEP ;
: GO BACKGROUND WAKE ;
\ *** Block No. 8 Hexblock 8
\ *** Block No. 9 Hexblock 9

255
sources/Apple1/tools.fb.src
View File

@ -1,255 +0,0 @@
Screen 0 not modified
0 \ Development Tools cas 26jan06
1
2 Interactive Tracer
3
4 One-Step Debugger
5
6 Traps
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ TOOLS LOADSCREEN 22MAR85RE)
1
2 ONLYFORTH
3
4 \NEEDS CODE abort( Assembler is needed )
5
6 VOCABULARY TOOLS
7
8 TOOLS ALSO DEFINITIONS
9 hex
10 1 &11 +THRU
11 decimal
12 ONLYFORTH
13
14
15
Screen 2 not modified
0 \ HANDLE STEPS BP 10 02 85)
1
2 ASSEMBLER ALSO DEFINITIONS
3
4 ONLY FORTH ALSO TOOLS ALSO DEFINITIONS
5 | VARIABLE (W | VARIABLE RPT
6
7 | CODE STEP
8 RPT DEC RP X) LDA IP STA
9 RP )Y LDA IP 1+ STA RP 2INC
10 (W LDA W STA (W 1+ LDA W 1+ STA
11 W 1- JMP END-CODE
12
13 | CREATE NEXTSTEP ] STEP [
14
15
Screen 3 not modified
0 \ THROW STATUS ON R-STACK B 23JUL85RE)
1
2 | CREATE NPULL 0 ]
3 RP@ COUNT 2DUP + RP! R> SWAP CMOVE ;
4
5 : NPUSH ( ADDR LEN -)
6 R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE
7 NPULL >R >R ;
8
9 | : ONELINE .STATUS SPACE QUERY INTERPRET
10 -82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ;
11
12
13
14
15
Screen 4 not modified
0 \ TRAP AND DISPLAY KS 26MAR85RE)
1 LABEL TNEXT
2 IP 2INC RP LDA RPT CMP 0<> ?[
3 [[ W 1- JMP SWAP ]?
4 RP 1+ LDA RPT 1+ CMP 0= ?]
5 LABEL DOTRACE
6 RPT INC ( DISABLE TRACER )
7 W LDA (W STA W 1+ LDA (W 1+ STA
8 ;C: R@ NEXTSTEP >R
9 INPUT PUSH KEYBOARD
10 OUTPUT PUSH DISPLAY
11 CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES
12 >NAME .NAME 1C COL - 0 MAX SPACES .S
13 STATE PUSH BLK PUSH >IN PUSH
14 [ ' 'QUIT >BODY ] LITERAL PUSH
15 [ ' >INTERPRET >BODY ] LITERAL PUSH
Screen 5 not modified
0 \
1 #TIB PUSH TIB #TIB @ NPUSH R0 PUSH
2 RP@ R0 ! 082 ALLOT
3 ['] ONELINE IS 'QUIT QUIT ; -2 ALLOT
4
5
6
7
8
9
10
11
12
13
14
15
Screen 6 not modified
0 \ TRACER COMMANDS BP 23JUL85RE)
1
2 | CODE (TRACE TNEXT 0 100 M/MOD
3 # LDA NEXT 0C + STA
4 # LDA NEXT 0B + STA
5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE
6
7 : TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ;
8
9 : BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT
10
11 : TRACEL: CREATE , DOES> @ RPT +! ;
12
13 -6 TRACEL: +DO 6 TRACEL: -DO
14 -2 TRACEL: +R 2 TRACEL: -R
15 -6 TRACEL: +PUSH 6 TRACEL: -PUSH
Screen 7 not modified
0 \ WATCH TRAP BP 10 02 85 )
1
2 | VARIABLE WATCHPT 2 ALLOT
3
4 LABEL WNEXT IP 2INC
5 WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA
6 N X) LDA WATCHPT 2+ CMP 0<> ?[
7 [[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA
8 ( SET TO TNEXT) TNEXT 0 100 M/MOD
9 # LDA NEXT 0C + STA # LDA NEXT 0B + STA
10 DOTRACE JMP SWAP ]?
11 N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE
12
13
14
15
Screen 8 not modified
0 \ WATCH COMMANDS BP 10 02 85 )
1
2 | CODE (WATCH WNEXT 0 100 M/MOD
3 # LDA NEXT 0C + STA
4 # LDA NEXT 0B + STA
5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE
6
7 : WATCH' ( ADR -- )
8 DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ;
9
10 : CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ;
11
12 ( SYNTAX : <VARNAME> WATCH' <PROCEDURE> )
13
14
15
Screen 9 not modified
0 \ TOOLS FOR DECOMPILING, KS 4 APR 83 )
1 ( INTERACTIVE USE )
2 | : ?: DUP 4 U.R ." :" ;
3 | : @? DUP @ 6 U.R ;
4 | : C? DUP C@ 3 .R ;
5 | : BL 024 COL - 0 MAX SPACES ;
6
7 : S ( ADR - ADR+) ( PRINT LITERAL STRING)
8 ?: SPACE C? 4 SPACES DUP COUNT TYPE
9 DUP C@ + 1+ BL ; ( COUNT + RE)
10
11 : N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA)
12 ?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ;
13
14 : L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ;
15
Screen 10 not modified
0 \ TOOLS FOR DECOMPILING, INTERACTIVE )
1
2 : D ( ADR N - ADR+N) ( DUMP N BYTES)
3 2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP
4 4 SPACES -ROT TYPE BL ;
5
6 : C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ;
7
8 : B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION )
9 ?: @? DUP @ OVER + 6 U.R 2+ BL ;
10
11 ( USED FOR : )
12 ( NAME STRING LITERAL DUMP CLIT BRANCH )
13 ( - - - - - - )
14
15
Screen 11 not modified
0 \ DEBUGGING UTILITIES BP 19 02 85 )
1
2 : UNRAVEL \ UNRAVEL PERFORM (ABORT"
3 RDROP RDROP RDROP CR ." TRACE DUMP IS " CR
4
5 BEGIN RP@ R0 @ -
6 WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR
7 REPEAT (ERROR ;
8
9 ' UNRAVEL ERRORHANDLER !
10
11
12
13
14
15
Screen 12 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 13 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 14 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

255
sources/Apple1/tools.fth Normal file
View File

@ -0,0 +1,255 @@
\ *** Block No. 0 Hexblock 0
\ Development Tools cas 26jan06
Interactive Tracer
One-Step Debugger
Traps
\ *** Block No. 1 Hexblock 1
\ TOOLS LOADSCREEN 22MAR85RE)
ONLYFORTH
\NEEDS CODE abort( Assembler is needed )
VOCABULARY TOOLS
TOOLS ALSO DEFINITIONS
hex
1 &11 +THRU
decimal
ONLYFORTH
\ *** Block No. 2 Hexblock 2
\ HANDLE STEPS BP 10 02 85)
ASSEMBLER ALSO DEFINITIONS
ONLY FORTH ALSO TOOLS ALSO DEFINITIONS
| VARIABLE (W | VARIABLE RPT
| CODE STEP
RPT DEC RP X) LDA IP STA
RP )Y LDA IP 1+ STA RP 2INC
(W LDA W STA (W 1+ LDA W 1+ STA
W 1- JMP END-CODE
| CREATE NEXTSTEP ] STEP [
\ *** Block No. 3 Hexblock 3
\ THROW STATUS ON R-STACK B 23JUL85RE)
| CREATE NPULL 0 ]
RP@ COUNT 2DUP + RP! R> SWAP CMOVE ;
: NPUSH ( ADDR LEN -)
R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE
NPULL >R >R ;
| : ONELINE .STATUS SPACE QUERY INTERPRET
-82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ;
\ *** Block No. 4 Hexblock 4
\ TRAP AND DISPLAY KS 26MAR85RE)
LABEL TNEXT
IP 2INC RP LDA RPT CMP 0<> ?[
[[ W 1- JMP SWAP ]?
RP 1+ LDA RPT 1+ CMP 0= ?]
LABEL DOTRACE
RPT INC ( DISABLE TRACER )
W LDA (W STA W 1+ LDA (W 1+ STA
;C: R@ NEXTSTEP >R
INPUT PUSH KEYBOARD
OUTPUT PUSH DISPLAY
CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES
>NAME .NAME 1C COL - 0 MAX SPACES .S
STATE PUSH BLK PUSH >IN PUSH
[ ' 'QUIT >BODY ] LITERAL PUSH
[ ' >INTERPRET >BODY ] LITERAL PUSH
\ *** Block No. 5 Hexblock 5
\
#TIB PUSH TIB #TIB @ NPUSH R0 PUSH
RP@ R0 ! 082 ALLOT
['] ONELINE IS 'QUIT QUIT ; -2 ALLOT
\ *** Block No. 6 Hexblock 6
\ TRACER COMMANDS BP 23JUL85RE)
| CODE (TRACE TNEXT 0 100 M/MOD
# LDA NEXT 0C + STA
# LDA NEXT 0B + STA
04C # LDA NEXT 0A + STA NEXT JMP END-CODE
: TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ;
: BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT
: TRACEL: CREATE , DOES> @ RPT +! ;
-6 TRACEL: +DO 6 TRACEL: -DO
-2 TRACEL: +R 2 TRACEL: -R
-6 TRACEL: +PUSH 6 TRACEL: -PUSH
\ *** Block No. 7 Hexblock 7
\ WATCH TRAP BP 10 02 85 )
| VARIABLE WATCHPT 2 ALLOT
LABEL WNEXT IP 2INC
WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA
N X) LDA WATCHPT 2+ CMP 0<> ?[
[[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA
( SET TO TNEXT) TNEXT 0 100 M/MOD
# LDA NEXT 0C + STA # LDA NEXT 0B + STA
DOTRACE JMP SWAP ]?
N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE
\ *** Block No. 8 Hexblock 8
\ WATCH COMMANDS BP 10 02 85 )
| CODE (WATCH WNEXT 0 100 M/MOD
# LDA NEXT 0C + STA
# LDA NEXT 0B + STA
04C # LDA NEXT 0A + STA NEXT JMP END-CODE
: WATCH' ( ADR -- )
DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ;
: CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ;
( SYNTAX : <VARNAME> WATCH' <PROCEDURE> )
\ *** Block No. 9 Hexblock 9
\ TOOLS FOR DECOMPILING, KS 4 APR 83 )
( INTERACTIVE USE )
| : ?: DUP 4 U.R ." :" ;
| : @? DUP @ 6 U.R ;
| : C? DUP C@ 3 .R ;
| : BL 024 COL - 0 MAX SPACES ;
: S ( ADR - ADR+) ( PRINT LITERAL STRING)
?: SPACE C? 4 SPACES DUP COUNT TYPE
DUP C@ + 1+ BL ; ( COUNT + RE)
: N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA)
?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ;
: L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ;
\ *** Block No. 10 Hexblock A
\ TOOLS FOR DECOMPILING, INTERACTIVE )
: D ( ADR N - ADR+N) ( DUMP N BYTES)
2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP
4 SPACES -ROT TYPE BL ;
: C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ;
: B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION )
?: @? DUP @ OVER + 6 U.R 2+ BL ;
( USED FOR : )
( NAME STRING LITERAL DUMP CLIT BRANCH )
( - - - - - - )
\ *** Block No. 11 Hexblock B
\ DEBUGGING UTILITIES BP 19 02 85 )
: UNRAVEL \ UNRAVEL PERFORM (ABORT"
RDROP RDROP RDROP CR ." TRACE DUMP IS " CR
BEGIN RP@ R0 @ -
WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR
REPEAT (ERROR ;
' UNRAVEL ERRORHANDLER !
\ *** Block No. 12 Hexblock C
\ *** Block No. 13 Hexblock D
\ *** Block No. 14 Hexblock E

34
sources/AtariST/ALLOCATE.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \\ *** Allocate *** 12oct86we
1
2 Dieses File enth„lt die Betriebssystemroutinen, mit denen man
3 RAM-Speicher beim Betriebssystem an- und abmelden kann.
4
5 MALLOC erwartet die - doppelt genaue - Anzahl der zu reservie-
6 renden Bytes und gibt die Langadresse des allokierten Speicher-
7 bereichs zur<75>ck. Wenn nicht genug Speicherplatz zur Verf<72>gung
8 steht, wird der Befehl abgebrochen.
9
10 MFREE gibt den Speicher ab laddr wieder frei. Bei Fehlern wird
11 der Befehl abgebrochen.
12
13
14
15
Screen 1 not modified
0 \ malloc mfree 16oct86we
1
2 Code malloc ( d -- laddr )
3 .l SP ) A7 -) move .w $48 # A7 -) move 1 trap
4 6 A7 addq .l D0 SP ) move
5 ;c: 2dup or 0= abort" No more RAM" ;
6
7 Code mfree ( laddr -- )
8 .l SP )+ A7 -) move .w $49 # A7 -) move 1 trap
9 6 A7 addq .w D0 SP -) move ;c: abort" mfree Error!" ;
10
11
12
13
14
15

34
sources/AtariST/ALLOCATE.fth Normal file
View File

@ -0,0 +1,34 @@
\ *** Block No. 0 Hexblock 0
\\ *** Allocate *** 12oct86we
Dieses File enth„lt die Betriebssystemroutinen, mit denen man
RAM-Speicher beim Betriebssystem an- und abmelden kann.
MALLOC erwartet die - doppelt genaue - Anzahl der zu reservie-
renden Bytes und gibt die Langadresse des allokierten Speicher-
bereichs zur<EFBFBD>ck. Wenn nicht genug Speicherplatz zur Verf<EFBFBD>gung
steht, wird der Befehl abgebrochen.
MFREE gibt den Speicher ab laddr wieder frei. Bei Fehlern wird
der Befehl abgebrochen.
\ *** Block No. 1 Hexblock 1
\ malloc mfree 16oct86we
Code malloc ( d -- laddr )
.l SP ) A7 -) move .w $48 # A7 -) move 1 trap
6 A7 addq .l D0 SP ) move
;c: 2dup or 0= abort" No more RAM" ;
Code mfree ( laddr -- )
.l SP )+ A7 -) move .w $49 # A7 -) move 1 trap
6 A7 addq .w D0 SP -) move ;c: abort" mfree Error!" ;

323
sources/AtariST/ASSEMBLE.FB.src
View File

@ -1,323 +0,0 @@
Screen 0 not modified
0 \\ *** Assembler *** 25may86we
1
2 Dieses File enth„lt den 68000-Assembler f<>r volksFORTH-83.
3 Der Assembler basiert auf dem von Michael Perry f<>r F83 entwik-
4 kelten, enth„lt aber einige zus„tzliche Features.
5 Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels
6 verwendbar. Aus Geschwindigkeitsgr<67>nden enth„lt der Assembler
7 kaum Fehler<65>berpr<70>fung, es empfiehlt sich daher, nach getaner
8 Tat die Code-Worte mit einem Disassembler zu <20>berpr<70>fen.
9
10 Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten
11 Assembler auf den Heap laden kann, damit er w„hrend der Kompila-
12 tionszeit zur Verf<72>gung steht, aber keinen Platz im Dictionary
13 verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt,
14 wenn er nicht mehr ben”tigt wird.
15
Screen 1 not modified
0 \ 68000 Assembler Load Screen 26oct86we
1
2 Onlyforth
3 Vocabulary Assembler Assembler also definitions
4
5 : end-code context 2- @ context ! ;
6 ' swap | Alias *swap
7
8 base @ 4 $11 +thru base !
9
10 : reg) size push .l 0 *swap FP DI) ;
11 : Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp
12 >here next-link @ , next-link ! ;
13
14 2 3 +thru Onlyforth
15
Screen 2 not modified
0 \ Internal Assembler 09sep86we
1
2 Onlyforth
3
4 here
5 $1300 hallot heap dp ! -1 +load
6 dp !
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ Extended adressing modes 09sep86we
1
2 : R#) ( addr -- ) size push
3 [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg)
4 [ Forth ] exit THEN .w FP D) ;
5
6
7 | : inrange? ( addr -- offset f ) [ Forth ]
8 >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN
9 dup >here negate > ;
10 : pcrel) ( addr -- ) \ pc-relativ adressing mode
11 inrange? [ Forth ] 0= abort" out of range" pcd) ;
12
13 : ;c: 0 recover R#) jsr end-code ] ;
14
15
Screen 4 not modified
0 \ Assembler Forth words 09sep86we
1 Forth definitions
2 : Assembler Assembler [ Assembler ] .w ;
3 : Code Create here dup 2- ! Assembler ;
4
5 | : (;code r> last @ name> ! ;
6 : ;Code 0 ?pairs compile (;code [compile] [ reveal
7 Assembler ; immediate restrict
8
9 : >label ( addr -- ) here | Create swap , immediate
10 4 hallot >here 4- heap 4 cmove
11 heap last @ count $1F and + even ! dp !
12 Does> ( -- addr ) @
13 state @ IF [compile] Literal THEN ;
14 : Label [ Assembler ] >here [ Forth ] 1 and
15 [ Assembler ] >allot >here >label Assembler ;
Screen 5 not modified
0 \ Code generating primitives 26oct86we
1
2 Variable >codes
3 | Create nrc ] c, , c@ here allot ! c! [
4
5 : nonrelocate nrc >codes ! ; nonrelocate
6
7 | : >exec Create c,
8 Does> c@ >codes @ + @ execute ;
9
10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@
11 | 6 >exec >here | 8 >exec >allot | $0A >exec >!
12 | $0C >exec >c!
13
14
15
Screen 6 not modified
0 \ 68000 Meta Assembler 04sep86we
1
2 | : ?, IF >, THEN >, ;
3 | : 2, >, >, ;
4 8 base !
5 Variable size
6 : .b 10000 size ! ;
7 : .w 30100 size ! ; .w
8 : .l 24600 size ! ;
9
10 | : Sz Constant Does> @ size @ and or ;
11 00300 | Sz sz3 00400 | Sz sz4
12 04000 | Sz sz40 30000 | Sz sz300
13
14 | : long? size @ 24600 = ;
15 | : -sz1 long? IF 100 or THEN ;
Screen 7 not modified
0 \ addressing modes 09sep86we
1
2 | : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ;
3 | : Mode Constant Does> @ *swap 7007 and or ;
4 0000 Regs D0 D1 D2 D3 D4 D5 D6 D7
5 0110 Regs A0 A1 A2 A3 A4 A5 A6 A7
6 0220 Mode ) \ address register indirect
7 0330 Mode )+ \ adr reg ind post-increment
8 0440 Mode -) \ adr reg ind pre-decrement
9 0550 Mode D) \ adr reg ind displaced
10 0660 Mode (DI) \ adr reg ind displaced indexed s.u.
11 0770 Constant #) \ immediate address
12 1771 Constant L#) \ immediate long address
13 2772 Constant pcD) \ pc relative displaced
14 3773 Constant (pcDI) \ pc relative displaced indexed
15 4774 Constant # \ immediate data
Screen 8 not modified
0 \ fields and register assignments 08sep86we
1
2 | : Field Constant Does> @ and ;
3 7000 | Field rd 0007 | Field rs
4 0070 | Field ms 0077 | Field eas
5 0377 | Field low
6 | : dn? ( ea -- ea flag ) dup ms 0= ;
7 | : src ( ea instr -- ea instr' ) over eas or ;
8 | : dst ( ea instr -- ea instr' ) *swap rd or ;
9
10 | : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ;
11 | : ??an ( mod -- mod ) dup ms 1 =
12 abort" needs Adress-Register" ;
13
14 A6 Constant SP A5 Constant RP A4 Constant IP
15 A3 Constant FP
Screen 9 not modified
0 \ extended addressing 09sep86we
1 : DI) (DI) size @ *swap ;
2 : pcDI) (pcDI) size @ *swap ;
3
4 | : double? ( mode -- flag) dup L#) = *swap
5 # = long? and or ;
6 | : index? ( {n} mode -- {m} mode )
7 dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or
8 IF size @ >r size !
9 dup rd 10 * *swap ms IF 100000 or THEN
10 sz40 *swap low or r> size !
11 THEN r> ;
12
13 | : more? ( ea -- ea flag ) dup ms 0040 > ;
14 | : ,more ( ea -- ) more?
15 IF index? double? ?, ELSE drop THEN ;
Screen 10 not modified
0 \ extended addressing extras 09sep86we
1
2 | Create extra here 5 dup allot erase \ temporary storage area
3
4 | : extra? ( {n} mode -- mode ) more?
5 IF >r r@ index? double? extra 1+ *swap
6 IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r>
7 ELSE 0 extra !
8 THEN ;
9
10 | : ,extra ( -- ) extra c@ ?dup
11 IF extra 1+ *swap 1 =
12 IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase
13 THEN ;
14
15
Screen 11 not modified
0 \ immediates & address register specific 15jan86we
1 | : Imm Constant Does> @ >r extra? eas r> or
2 sz3 >, long? ?, ,extra ; ( n ea)
3 0000 Imm ori 1000 Imm andi
4 2000 Imm subi 3000 Imm addi
5 5000 Imm eori 6000 Imm cmpi
6 | : Immsr Constant Does> @ sz3 2, ; ( n )
7 001074 Immsr andi>sr
8 005074 Immsr eori>sr
9 000074 Immsr ori>sr
10 | : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or
11 r> or sz3 >, ,extra ; ( n ea )
12 050000 Iq addq 050400 Iq subq
13 | : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an )
14 150300 Ieaa adda 130300 Ieaa cmpa
15 040700 Ieaa lea 110300 Ieaa suba
Screen 12 not modified
0 \ shifts, rotates, and bit manipulation 15jan86we
1 | : Isr Constant Does> @ >r dn?
2 IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN
3 rd *swap rs or r> or 160000 or sz3 >,
4 ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or
5 160000 or >, ,more
6 THEN ; ( dm dn ) ( m # dn ) ( ea )
7 400 Isr asl 000 Isr asr
8 410 Isr lsl 010 Isr lsr
9 420 Isr roxl 020 Isr roxr
10 430 Isr rol 030 Isr ror
11 | : Ibit Constant does> @ >r extra? dn?
12 IF rd src 400 ELSE drop dup eas 4000 THEN
13 or r> or >, ,extra ,more ; ( ea dn ) ( ea n # )
14 000 Ibit btst 100 Ibit bchg
15 200 Ibit bclr 300 Ibit bset
Screen 13 not modified
0 \ branch, loop, and set conditionals 15jan86we
1
2 | : Setclass ' *swap 0 DO I over execute LOOP drop ;
3 | : Ibra 400 * 060000 or Constant ( label )
4 Does> @ *swap >here 2+ - dup abs 200 <
5 IF low or >, ELSE *swap 2, THEN ;
6 20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq
7 bvc bvs bpl bmi bge blt bgt ble
8 | : Idbr 400 * 050310 or Constant ( label \ dn - )
9 Does> @ *swap rs or >, >here - >, ;
10 20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq
11 dbvc dbvs dbpl dbmi dbge dblt dbgt dble
12 | : Iset 400 * 050300 or Constant ( ea )
13 Does> @ src >, ,more ;
14 20 Setclass Iset set sno shi sls scc scs sne seq
15 svc svs spl smi sge slt sgt sle
Screen 14 not modified
0 \ moves 15jan86we
1
2 : move extra? 7700 and src sz300 >,
3 ,more ,extra ; ( ea ea )
4 : moveq ??dn rd *swap low or 070000 or >, ; ( n dn )
5 : move>usp ??an rs 047140 or >, ; ( an )
6 : move<usp ??an rs 047150 or >, ; ( an )
7 : movem>
8 extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea )
9 : movem<
10 extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea )
11 : movep dn? IF rd *swap rs or 410 or
12 ELSE rs rot rd or 610 or THEN -sz1 2, ;
13 ( dm d an ) ( d an dm )
14 : lmove 7700 and *swap eas or 20000 or >, ;
15 ( long reg move )
Screen 15 not modified
0 \ odds and ends 15jan86we
1
2 : cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ )
3 : exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r
4 ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap
5 THEN rs dst r> or >, ; ( rn rm )
6 : ext ??dn rs 044200 or -sz1 >, ; ( dn )
7 : swap ??dn rs 044100 or >, ; ( dn )
8 : stop 47162 2, ; ( n )
9 : trap 17 and 47100 or >, ; ( n )
10 : link ??an rs 047120 or 2, ; ( n an )
11 : unlk ??an rs 047130 or >, ; ( an )
12 : eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea )
13 : cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn )
14
15
Screen 16 not modified
0 \ arithmetic and logic 15jan86we
1 | : Ibcd Constant Does> @ dst over rs or *swap ms
2 IF 10 or THEN >, ; ( dn dm ) ( an@- am@- )
3 140400 Ibcd abcd 100400 Ibcd sbcd
4 | : Idd Constant Does> @ dst over rs or *swap ms
5 IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- )
6 150400 Idd addx 110400 Idd subx
7 | : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea )
8 IF rd src r> or sz3 >, ,more
9 ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ;
10 150000 Idea add 110000 Idea sub
11 140000 Idea and 100000 Idea or
12 | : Iead Constant Does> @ >r ??dn r> dst src
13 >, ,more ; ( ea dn)
14 040600 Iead chk 100300 Iead divu 100700 Iead divs
15 140300 Iead mulu 140700 Iead muls
Screen 17 not modified
0 \ arithmetic and control 15jan86we
1
2 | : Iea Constant Does> @ src >, ,more ; ( ea )
3 047200 Iea jsr 047300 Iea jmp
4 042300 Iea move>ccr
5 040300 Iea move<sr 043300 Iea move>sr
6 044000 Iea nbcd 044100 Iea pea
7 045300 Iea tas
8 | : Ieas Constant Does> @ src sz3 >, ,more ; ( ea )
9 041000 Ieas clr 043000 Ieas not
10 042000 Ieas neg 040000 Ieas negx
11 045000 Ieas tst
12 | : Icon Constant Does> @ >, ;
13 47160 Icon reset 47161 Icon nop
14 47163 Icon rte 47165 Icon rts
15 47166 Icon trapv 47167 Icon rtr
Screen 18 not modified
0 \ structured conditionals +/- 256 bytes 15jan86we
1 : THEN >here over 2+ - *swap 1+ >c! ;
2 : IF >, >here 2- ; hex
3 : ELSE 6000 IF *swap THEN ;
4 : BEGIN >here ;
5 : UNTIL >, >here - >here 1- >c! ;
6 : AGAIN 6000 UNTIL ;
7 : WHILE IF *swap ;
8 : REPEAT AGAIN THEN ;
9 : DO >here *swap ;
10 : LOOP dbra ;
11 6600 Constant 0= 6700 Constant 0<>
12 6A00 Constant 0< 6B00 Constant 0>=
13 6C00 Constant < 6D00 Constant >=
14 6E00 Constant <= 6F00 Constant >
15 6500 Constant CC 6400 Constant CS

323
sources/AtariST/ASSEMBLE.fth Normal file
View File

@ -0,0 +1,323 @@
\ *** Block No. 0 Hexblock 0
\\ *** Assembler *** 25may86we
Dieses File enth„lt den 68000-Assembler f<EFBFBD>r volksFORTH-83.
Der Assembler basiert auf dem von Michael Perry f<EFBFBD>r F83 entwik-
kelten, enth„lt aber einige zus„tzliche Features.
Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels
verwendbar. Aus Geschwindigkeitsgr<EFBFBD>nden enth„lt der Assembler
kaum Fehler<EFBFBD>berpr<EFBFBD>fung, es empfiehlt sich daher, nach getaner
Tat die Code-Worte mit einem Disassembler zu <EFBFBD>berpr<EFBFBD>fen.
Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten
Assembler auf den Heap laden kann, damit er w„hrend der Kompila-
tionszeit zur Verf<EFBFBD>gung steht, aber keinen Platz im Dictionary
verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt,
wenn er nicht mehr ben”tigt wird.
\ *** Block No. 1 Hexblock 1
\ 68000 Assembler Load Screen 26oct86we
Onlyforth
Vocabulary Assembler Assembler also definitions
: end-code context 2- @ context ! ;
' swap | Alias *swap
base @ 4 $11 +thru base !
: reg) size push .l 0 *swap FP DI) ;
: Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp
>here next-link @ , next-link ! ;
2 3 +thru Onlyforth
\ *** Block No. 2 Hexblock 2
\ Internal Assembler 09sep86we
Onlyforth
here
$1300 hallot heap dp ! -1 +load
dp !
\ *** Block No. 3 Hexblock 3
\ Extended adressing modes 09sep86we
: R#) ( addr -- ) size push
[ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg)
[ Forth ] exit THEN .w FP D) ;
| : inrange? ( addr -- offset f ) [ Forth ]
>here 2+ - >here 0< IF dup $FFFE >here - < exit THEN
dup >here negate > ;
: pcrel) ( addr -- ) \ pc-relativ adressing mode
inrange? [ Forth ] 0= abort" out of range" pcd) ;
: ;c: 0 recover R#) jsr end-code ] ;
\ *** Block No. 4 Hexblock 4
\ Assembler Forth words 09sep86we
Forth definitions
: Assembler Assembler [ Assembler ] .w ;
: Code Create here dup 2- ! Assembler ;
| : (;code r> last @ name> ! ;
: ;Code 0 ?pairs compile (;code [compile] [ reveal
Assembler ; immediate restrict
: >label ( addr -- ) here | Create swap , immediate
4 hallot >here 4- heap 4 cmove
heap last @ count $1F and + even ! dp !
Does> ( -- addr ) @
state @ IF [compile] Literal THEN ;
: Label [ Assembler ] >here [ Forth ] 1 and
[ Assembler ] >allot >here >label Assembler ;
\ *** Block No. 5 Hexblock 5
\ Code generating primitives 26oct86we
Variable >codes
| Create nrc ] c, , c@ here allot ! c! [
: nonrelocate nrc >codes ! ; nonrelocate
| : >exec Create c,
Does> c@ >codes @ + @ execute ;
| 0 >exec >c, | 2 >exec >, | 4 >exec >c@
| 6 >exec >here | 8 >exec >allot | $0A >exec >!
| $0C >exec >c!
\ *** Block No. 6 Hexblock 6
\ 68000 Meta Assembler 04sep86we
| : ?, IF >, THEN >, ;
| : 2, >, >, ;
8 base !
Variable size
: .b 10000 size ! ;
: .w 30100 size ! ; .w
: .l 24600 size ! ;
| : Sz Constant Does> @ size @ and or ;
00300 | Sz sz3 00400 | Sz sz4
04000 | Sz sz40 30000 | Sz sz300
| : long? size @ 24600 = ;
| : -sz1 long? IF 100 or THEN ;
\ *** Block No. 7 Hexblock 7
\ addressing modes 09sep86we
| : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ;
| : Mode Constant Does> @ *swap 7007 and or ;
0000 Regs D0 D1 D2 D3 D4 D5 D6 D7
0110 Regs A0 A1 A2 A3 A4 A5 A6 A7
0220 Mode ) \ address register indirect
0330 Mode )+ \ adr reg ind post-increment
0440 Mode -) \ adr reg ind pre-decrement
0550 Mode D) \ adr reg ind displaced
0660 Mode (DI) \ adr reg ind displaced indexed s.u.
0770 Constant #) \ immediate address
1771 Constant L#) \ immediate long address
2772 Constant pcD) \ pc relative displaced
3773 Constant (pcDI) \ pc relative displaced indexed
4774 Constant # \ immediate data
\ *** Block No. 8 Hexblock 8
\ fields and register assignments 08sep86we
| : Field Constant Does> @ and ;
7000 | Field rd 0007 | Field rs
0070 | Field ms 0077 | Field eas
0377 | Field low
| : dn? ( ea -- ea flag ) dup ms 0= ;
| : src ( ea instr -- ea instr' ) over eas or ;
| : dst ( ea instr -- ea instr' ) *swap rd or ;
| : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ;
| : ??an ( mod -- mod ) dup ms 1 =
abort" needs Adress-Register" ;
A6 Constant SP A5 Constant RP A4 Constant IP
A3 Constant FP
\ *** Block No. 9 Hexblock 9
\ extended addressing 09sep86we
: DI) (DI) size @ *swap ;
: pcDI) (pcDI) size @ *swap ;
| : double? ( mode -- flag) dup L#) = *swap
# = long? and or ;
| : index? ( {n} mode -- {m} mode )
dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or
IF size @ >r size !
dup rd 10 * *swap ms IF 100000 or THEN
sz40 *swap low or r> size !
THEN r> ;
| : more? ( ea -- ea flag ) dup ms 0040 > ;
| : ,more ( ea -- ) more?
IF index? double? ?, ELSE drop THEN ;
\ *** Block No. 10 Hexblock A
\ extended addressing extras 09sep86we
| Create extra here 5 dup allot erase \ temporary storage area
| : extra? ( {n} mode -- mode ) more?
IF >r r@ index? double? extra 1+ *swap
IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r>
ELSE 0 extra !
THEN ;
| : ,extra ( -- ) extra c@ ?dup
IF extra 1+ *swap 1 =
IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase
THEN ;
\ *** Block No. 11 Hexblock B
\ immediates & address register specific 15jan86we
| : Imm Constant Does> @ >r extra? eas r> or
sz3 >, long? ?, ,extra ; ( n ea)
0000 Imm ori 1000 Imm andi
2000 Imm subi 3000 Imm addi
5000 Imm eori 6000 Imm cmpi
| : Immsr Constant Does> @ sz3 2, ; ( n )
001074 Immsr andi>sr
005074 Immsr eori>sr
000074 Immsr ori>sr
| : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or
r> or sz3 >, ,extra ; ( n ea )
050000 Iq addq 050400 Iq subq
| : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an )
150300 Ieaa adda 130300 Ieaa cmpa
040700 Ieaa lea 110300 Ieaa suba
\ *** Block No. 12 Hexblock C
\ shifts, rotates, and bit manipulation 15jan86we
| : Isr Constant Does> @ >r dn?
IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN
rd *swap rs or r> or 160000 or sz3 >,
ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or
160000 or >, ,more
THEN ; ( dm dn ) ( m # dn ) ( ea )
400 Isr asl 000 Isr asr
410 Isr lsl 010 Isr lsr
420 Isr roxl 020 Isr roxr
430 Isr rol 030 Isr ror
| : Ibit Constant does> @ >r extra? dn?
IF rd src 400 ELSE drop dup eas 4000 THEN
or r> or >, ,extra ,more ; ( ea dn ) ( ea n # )
000 Ibit btst 100 Ibit bchg
200 Ibit bclr 300 Ibit bset
\ *** Block No. 13 Hexblock D
\ branch, loop, and set conditionals 15jan86we
| : Setclass ' *swap 0 DO I over execute LOOP drop ;
| : Ibra 400 * 060000 or Constant ( label )
Does> @ *swap >here 2+ - dup abs 200 <
IF low or >, ELSE *swap 2, THEN ;
20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq
bvc bvs bpl bmi bge blt bgt ble
| : Idbr 400 * 050310 or Constant ( label \ dn - )
Does> @ *swap rs or >, >here - >, ;
20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq
dbvc dbvs dbpl dbmi dbge dblt dbgt dble
| : Iset 400 * 050300 or Constant ( ea )
Does> @ src >, ,more ;
20 Setclass Iset set sno shi sls scc scs sne seq
svc svs spl smi sge slt sgt sle
\ *** Block No. 14 Hexblock E
\ moves 15jan86we
: move extra? 7700 and src sz300 >,
,more ,extra ; ( ea ea )
: moveq ??dn rd *swap low or 070000 or >, ; ( n dn )
: move>usp ??an rs 047140 or >, ; ( an )
: move<usp ??an rs 047150 or >, ; ( an )
: movem>
extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea )
: movem<
extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea )
: movep dn? IF rd *swap rs or 410 or
ELSE rs rot rd or 610 or THEN -sz1 2, ;
( dm d an ) ( d an dm )
: lmove 7700 and *swap eas or 20000 or >, ;
( long reg move )
\ *** Block No. 15 Hexblock F
\ odds and ends 15jan86we
: cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ )
: exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r
ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap
THEN rs dst r> or >, ; ( rn rm )
: ext ??dn rs 044200 or -sz1 >, ; ( dn )
: swap ??dn rs 044100 or >, ; ( dn )
: stop 47162 2, ; ( n )
: trap 17 and 47100 or >, ; ( n )
: link ??an rs 047120 or 2, ; ( n an )
: unlk ??an rs 047130 or >, ; ( an )
: eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea )
: cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn )
\ *** Block No. 16 Hexblock 10
\ arithmetic and logic 15jan86we
| : Ibcd Constant Does> @ dst over rs or *swap ms
IF 10 or THEN >, ; ( dn dm ) ( an@- am@- )
140400 Ibcd abcd 100400 Ibcd sbcd
| : Idd Constant Does> @ dst over rs or *swap ms
IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- )
150400 Idd addx 110400 Idd subx
| : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea )
IF rd src r> or sz3 >, ,more
ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ;
150000 Idea add 110000 Idea sub
140000 Idea and 100000 Idea or
| : Iead Constant Does> @ >r ??dn r> dst src
>, ,more ; ( ea dn)
040600 Iead chk 100300 Iead divu 100700 Iead divs
140300 Iead mulu 140700 Iead muls
\ *** Block No. 17 Hexblock 11
\ arithmetic and control 15jan86we
| : Iea Constant Does> @ src >, ,more ; ( ea )
047200 Iea jsr 047300 Iea jmp
042300 Iea move>ccr
040300 Iea move<sr 043300 Iea move>sr
044000 Iea nbcd 044100 Iea pea
045300 Iea tas
| : Ieas Constant Does> @ src sz3 >, ,more ; ( ea )
041000 Ieas clr 043000 Ieas not
042000 Ieas neg 040000 Ieas negx
045000 Ieas tst
| : Icon Constant Does> @ >, ;
47160 Icon reset 47161 Icon nop
47163 Icon rte 47165 Icon rts
47166 Icon trapv 47167 Icon rtr
\ *** Block No. 18 Hexblock 12
\ structured conditionals +/- 256 bytes 15jan86we
: THEN >here over 2+ - *swap 1+ >c! ;
: IF >, >here 2- ; hex
: ELSE 6000 IF *swap THEN ;
: BEGIN >here ;
: UNTIL >, >here - >here 1- >c! ;
: AGAIN 6000 UNTIL ;
: WHILE IF *swap ;
: REPEAT AGAIN THEN ;
: DO >here *swap ;
: LOOP dbra ;
6600 Constant 0= 6700 Constant 0<>
6A00 Constant 0< 6B00 Constant 0>=
6C00 Constant < 6D00 Constant >=
6E00 Constant <= 6F00 Constant >
6500 Constant CC 6400 Constant CS

34
sources/AtariST/C.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 ( Target compiler commands for volksForth Atari ST/TTcas20130105
1
2 include c.fb to build a new volksforth kernel named
3 "4thimg.prg"
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 ( load screen for target compilation )
1
2 include assemble.fb ( load assembler )
3 include target.fb ( load target compiler )
4 include forth83.fb ( compile volksForth from source )
5
6 save-target 4thimg.prg ( save the new minimal image )
7
8 .( Done )
9
10
11
12
13
14
15

34
sources/AtariST/C.fth Normal file
View File

@ -0,0 +1,34 @@
\ *** Block No. 0 Hexblock 0
( Target compiler commands for volksForth Atari ST/TTcas20130105
include c.fb to build a new volksforth kernel named
"4thimg.prg"
\ *** Block No. 1 Hexblock 1
( load screen for target compilation )
include assemble.fb ( load assembler )
include target.fb ( load target compiler )
include forth83.fb ( compile volksForth from source )
save-target 4thimg.prg ( save the new minimal image )
.( Done )

680
sources/AtariST/CROSTARG.FB.src
View File

@ -1,680 +0,0 @@
Screen 0 not modified
0 \\ *** volksFORTH-84 Target-Compiler ***
1
2 Mit dem Target-Compiler l„žt sich ein neues System aus dem
3 Quelltext FORTH_83.SCR 'hochziehen'.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Target compiler loadscr 09sep86we
1 \ Idea and first Implementation by ks/bp
2 \ Implemented on 6502 by ks/bp
3 \ ultraFORTH83-Version by bp/we
4 \ Atari 520 ST - Version by we
5 Onlyforth Assembler nonrelocate
6 07 Constant imagepage \ Virtual memory bank
7 Vocabulary Ttools
8 Vocabulary Defining
9 : .stat .blk .s ; ' .stat Is .status
10 \ : 65( [compile] ( ; immediate
11 : 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte|
12 1 $14 +thru \ Target compiler
13 $15 $17 +thru \ Target Tools
14 $18 $1A +thru \ Redefinitions
15 save $1B $25 +thru \ Predefinitions
Screen 2 not modified
0 \ Target header pointers bp05mar86we
1
2 Variable tdp : there tdp @ ;
3 Variable displace
4 Variable ?thead 0 ?thead !
5 Variable tlast 0 tlast !
6 Variable glast' 0 glast' !
7 Variable tdoes>
8 Variable >in:
9 Variable tvoc 0 tvoc !
10 Variable tvoc-link 0 tvoc-link !
11 Variable tnext-link 0 tnext-link !
12 Variable tdodo
13 Variable tfile-link 0 tfile-link !
14
15 : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
Screen 3 not modified
0 \ Image and byteorder 15sep86we
1
2 : >image ( addr1 - addr2 ) displace @ - ;
3
4 : >heap ( from quan - )
5 heap over - 1 and + \ 68000-align
6 dup hallot heap swap cmove ;
7
8 \ : >ascii 2drop ; ' noop Alias C64>ascii
9
10 Code Lc@ ( laddr -- 8b )
11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move
12 .w D0 SP -) move Next end-code
13 Code Lc! ( 8b addr -- )
14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
15 Next end-code
Screen 4 not modified
0 \ Ghost-creating 05mar86we
1
2 0 | Constant <forw> 0 | Constant <res>
3
4 | : Make.ghost ( - cfa.ghost )
5 here dup 1 and allot here
6 state @ IF context @ ELSE current THEN @
7 dup @ , name
8 dup c@ 1 $1F uwithin not abort" inval.Gname"
9 dup c@ 1+ over c!
10 c@ dup 1+ allot 1 and 0= IF bl c, THEN
11 here 2 pick - -rot
12 <forw> , 0 , 0 ,
13 swap here over - >heap
14 heap swap ! swap dp !
15 heap + ;
Screen 5 not modified
0 \ ghost words 05mar86we
1
2 : gfind ( string - cfa tf / string ff )
3 dup count + 1+ bl swap c!
4 dup >r 1 over c+! find -1 r> c+! ;
5
6 : ghost ( - cfa )
7 >in @ name gfind IF nip exit THEN
8 drop >in ! Make.ghost ;
9
10 : Word, ghost execute ;
11
12 : gdoes> ( cfa.ghost - cfa.does )
13 4+ dup @ IF @ exit THEN
14 here dup <forw> , 0 , 4 >heap
15 dp ! heap dup rot ! ;
Screen 6 not modified
0 \ ghost utilities 04dec85we
1
2 : g' name gfind 0= abort" ?" ;
3
4 : '.
5 g' dup @ <forw> case?
6 IF ." forw" ELSE <res> - abort" ??" ." res" THEN
7 2+ dup @ 5 u.r
8 2+ @ ?dup
9 IF dup @ <forw> case?
10 IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
11 2+ @ 5 u.r THEN ;
12
13 ' ' Alias h'
14
15
Screen 7 not modified
0 \ .unresolved 05mar86we
1
2 | : forward? ( cfa - cfa / exit&true )
3 dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
4
5 | : unresolved? ( addr - f )
6 2+ dup c@ $1F and over + c@ BL =
7 IF name> forward? 4+ @ dup IF forward? THEN
8 THEN drop false ;
9
10 | : unresolved-words
11 BEGIN @ ?dup WHILE dup unresolved?
12 IF dup 2+ .name ?cr THEN REPEAT ;
13
14 : .unresolved voc-link @
15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
Screen 8 not modified
0 \ Extending Vocabularys for Target-Compilation 05mar86we
1
2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
3
4 Vocabulary Transient 0 tvoc !
5
6 Only definitions Forth also
7
8 : T Transient ; immediate
9 : H Forth ; immediate
10
11 definitions
12
13
14
15
Screen 9 not modified
0 \ Transient primitives 05mar86we
1 Code byte> ( 8bh 8bl -- 16b )
2 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
3 .w D0 SP ) move Next end-code
4 Code >byte ( 16b -- 8bl 8bh )
5 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
6 D0 SP -) move D1 SP -) move Next end-code
7 Transient definitions
8 : c@ H >image imagepage lc@ ;
9 : c! H >image imagepage lc! ;
10 : @ dup T c@ swap 1+ T c@ 65( swap ) byte> ;
11 : ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ;
12 : cmove ( from.mem to.target quan -)
13 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
14 : place ( addr len to --)
15 over >r rot over 1+ r> T cmove c! H ;
Screen 10 not modified
0 \ Transient primitives bp05mar86we
1
2 : here there ;
3 : allot Tdp +! ;
4 : c, T here c! 1 allot H ;
5 : , T here ! 2 allot H ;
6
7 : ," Ascii " parse dup T c,
8 under there swap cmove
9 .( dup 1 and 0= IF 1+ THEN ) allot H ;
10
11 : fill ( addr quan 8b -)
12 -rot bounds ?DO dup I T c! H LOOP drop ;
13 : erase 0 T fill ;
14 : blank bl T fill ;
15 : here! H Tdp ! ;
Screen 11 not modified
0 \ Resolving 08dec85we
1 Forth definitions
2 : resolve ( cfa.ghost cfa.target -)
3 over dup @ <res> =
4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
5 >r >r 2+ @ ?dup
6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
7 H ?dup 0= UNTIL
8 THEN r> r> <res> over ! 2+ ! ;
9
10 : resdoes> ( cfa.ghost cfa.target -)
11 swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
13 ' <forw> >body !
14 ] Does> [ here 4- 0 ] @ T , H ;
15 ' <res> >body !
Screen 12 not modified
0 \ move-threads 68000-align 13jun86we
1
2 : move-threads Tvoc @ Tvoc-link @
3 BEGIN over ?dup
4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
5 error" some undef. Target-Vocs left" drop ;
6
7 | : tlatest ( - addr) current @ 6 + ;
8
9 \\
10 wird fuer 6502 nicht gebraucht
11
12 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
13
14
15
Screen 13 not modified
0 \ save-target 09sep86we
1
2 Dos definitions
3
4 Code (filewrite ( buff len handle -- n)
5 SP )+ D0 move .l D2 clr .w SP )+ D2 move
6 .l 0 imagepage # D1 move .w SP )+ D1 move
7 .l D1 A7 -) move \ buffer adress
8 .l D2 A7 -) move \ buffer length
9 .w D0 A7 -) move \ handle
10 $40 # A7 -) move \ call WRITE
11 1 trap $0C # A7 adda
12 .w D0 SP -) move Next end-code Forth definitions
13
14
15
Screen 14 not modified
0 \ save Target-System 09sep86we
1
2 : save-target [ Dos ]
3 bl word count dup 0= abort" missing filename"
4 over + off (createfile dup >r 0< abort" no device "
5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
6 0 there r@ (filewrite there - abort" write error"
7 r> (closefile 0< abort" close error" ;
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ 8086-ALIGN
1
2 : even ( addr -- addr1 ) ; immediate
3 : align ( -- ) ; immediate
4 : halign ( -- ) ; immediate
5
6
7
8
9
10
11
12
13
14
15
Screen 16 not modified
0 \\ Create Variable ks 19 m„r 88
1
2 Defer makeview ' 0 Is makeview
3
4 : Create align here makeview , current @ @ ,
5 name c@ dup 1 $20 uwithin not Abort" invalid name"
6 here last ! 1+ allot align ?exists
7 ?head @ IF 1 ?head +! dup , \ Pointer to Code
8 halign heapmove $20 flag! dup dp !
9 THEN drop reveal 0 ,
10 ;Code ( -- addr ) D push 2 W D) D lea Next end-code
11
12 : Variable Create 0 , ;
13
14
15
Screen 17 not modified
0 \ compiling names into targ. 05mar86we
1
2 : (theader
3 ?thead @ IF 1 ?thead +!
4 .( there $FF and $FF = IF 1 T allot H THEN ) exit THEN
5 >in @ name swap >in !
6 dup c@ 1 $20 uwithin not abort" inval. Tname"
7 .( dup c@ 3 + there + $FF and $FF =
8 there 2+ $FF and $FF = or IF 1 T allot H THEN )
9 blk @ T , H there tlatest dup @ T , H ! there dup tlast !
10 over c@ 1+ .( even ) dup T allot cmove H ;
11
12 : Theader tlast off
13 (theader Ghost dup glast' !
14 there resolve ;
15
Screen 18 not modified
0 \ prebuild defining words bp27jun85we
1
2 | : executable? ( adr - adr f ) dup ;
3 | : tpfa, there , ;
4 | : (prebuild ( cfa.adr -- )
5 >in @ Create >in ! here 2- ! ;
6
7 : prebuild ( adr 0.from.: - 0 )
8 0 ?pairs executable? dup >r
9 IF [compile] Literal compile (prebuild ELSE drop THEN
10 compile Theader Ghost gdoes> ,
11 r> IF compile tpfa, THEN 0 ; immediate restrict
12
13
14
15
Screen 19 not modified
0 \ code portion of def.words bp11sep86we
1
2 : dummy 0 ;
3
4 : DO> ( - adr.of.jmp.dodoes> 0 )
5 [compile] Does> here 4- compile @ 0 ] ;
6
7
8
9
10
11
12
13
14
15
Screen 20 not modified
0 \ the 68000 Assembler 11sep86we
1
2 Forth definitions
3 | Create relocate ] T c, , c@ here allot ! c! H [
4
5 Transient definitions
6
7 : Assembler H [ Tassembler ] relocate >codes !
8 Tassembler ;
9 : >label ( 16b -) H >in @ name gfind rot >in !
10 IF over resolve dup THEN drop Constant ;
11 : Label T .( here 1 and allot ) here >label Assembler H ;
12 : Code H Theader there 2+ T , Assembler H ;
13
14
15
Screen 21 not modified
0 \ immed. restr. ' \ compile bp05mar86we
1
2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
3 : >mark ( - addr ) H there T 0 , H ;
4 : >resolve ( addr - ) H there over - swap T ! H ;
5 : <mark ( - addr ) H there ;
6 : <resolve ( addr - ) H there - T , H ;
7 : immediate H Tlast @ ?dup
8 IF dup T c@ $40 or swap c! H THEN ;
9 : restrict H Tlast @ ?dup
10 IF dup T c@ $80 or swap c! H THEN ;
11 : ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
12 : | H ?thead @ ?exit ?thead on ;
13 : compile H Ghost , ; immediate restrict
14
15
Screen 22 not modified
0 \ Target tools ks05mar86we
1
2 Onlyforth Ttools also definitions
3
4 | : ttype ( adr n -) bounds ?DO I T c@ H dup
5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
7 ELSE ." ??? " THEN space ?cr ;
8 | : nfa? ( cfa lfa - nfa / cfa ff)
9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) =
10 IF 2+ nip exit THEN
11 T @ H REPEAT ;
12 : >name ( cfa - nfa / ff)
13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
14 IF nip exit THEN
15 swap REPEAT nip ;
Screen 23 not modified
0 \ Ttools for decompiling ks05mar86we
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup T @ H 6 u.r ;
4 | : c? dup T c@ H 3 .r ;
5
6 : s ( addr - addr+ ) ?: space c? 3 spaces
7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
8
9 : n ( addr - addr+2 ) ?: @? 2 spaces
10 dup T @ H [ Ttools ] >name .name H 2+ ;
11
12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
13 2 spaces -rot ttype ;
14
15
Screen 24 not modified
0 \ Tools for decompiling bp05mar86we
1
2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
3
4 : c ( addr -- addr+1 ) 1 d ;
5
6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
7
8 : dump ( adr n -) bounds ?DO cr I $10 d drop
9 stop? IF LEAVE THEN $10 +LOOP ;
10
11 : view T ' H [ Ttools ] >name ?dup
12 IF 4- T @ H l THEN ;
13
14
15
Screen 25 not modified
0 \ reinterpretation def.-words 05mar86we
1
2 Onlyforth
3
4 : redefinition
5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push
6 state push context push >in: @ >in !
7 name [ ' Transient 2+ ] Literal (find nip 0=
8 IF cr ." Redefinition: " here .name
9 >in: @ >in ! : Defining interpret THEN
10 THEN 0 tdoes> ! ;
11
12
13
14
15
Screen 26 not modified
0 \ Create..does> structure bp05mar86we
1
2 | : (;tcode
3 Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ;
4 | : changecfa compile lit tdoes> @ , compile (;tcode ;
5
6 Defining definitions
7
8 : ;code 0 ?pairs changecfa reveal rdrop ;
9 immediate restrict
10
11 Defining ' ;code Alias does> immediate restrict
12
13 : ; [compile] ; rdrop ; immediate restrict
14
15
Screen 27 not modified
0 \ redefinition conditionals bp27jun85we
1
2 ' DO Alias DO immediate restrict
3 ' ?DO Alias ?DO immediate restrict
4 ' LOOP Alias LOOP immediate restrict
5 ' IF Alias IF immediate restrict
6 ' THEN Alias THEN immediate restrict
7 ' ELSE Alias ELSE immediate restrict
8 ' BEGIN Alias BEGIN immediate restrict
9 ' UNTIL Alias UNTIL immediate restrict
10 ' WHILE Alias WHILE immediate restrict
11 ' REPEAT Alias REPEAT immediate restrict
12
13
14
15
Screen 28 not modified
0 \ clear Liter. Ascii ['] ." bp05mar86we
1
2 Onlyforth Transient definitions
3
4 : clear true abort" There are ghosts" ;
5
6 : Literal ( 16b -- )
7 dup $FF00 and IF T compile lit , H exit THEN
8 T compile clit c, H ; immediate restrict
9
10 : Ascii H bl word 1+ c@ state @
11 IF T [compile] Literal H THEN ; immediate
12 : ['] T ' [compile] Literal H ; immediate restrict
13 : " T compile (" ," align H ; immediate restrict
14 : ." T compile (." ," align H ; immediate restrict
15
Screen 29 not modified
0 \ Target compilation ] [ bp05mar86we
1
2 Forth definitions
3
4 : tcompile
5 ?stack >in @ name find ?dup
6 IF 0> IF nip execute >interpret THEN
7 drop dup >in ! name
8 THEN gfind IF nip execute >interpret THEN
9 nullstring? IF drop exit THEN
10 number? ?dup IF 0> IF swap T [compile] Literal THEN
11 [compile] Literal H drop >interpret THEN
12 drop >in ! Word, >interpret ;
13
14 Transient definitions
15 : ] H state on ['] tcompile is >interpret ;
Screen 30 not modified
0 \ Target conditionals bp05mar86we
1
2 : IF T compile ?branch >mark H 1 ; immediate restrict
3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict
4 : ELSE T 1 ?pairs compile branch >mark swap >resolve
5 H -1 ; immediate restrict
6 : BEGIN T <mark H 2 ; immediate restrict
7 : WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
8 immediate restrict
9 | : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
10 WHILE drop T >resolve H REPEAT ;
11 : UNTIL T compile ?branch (repeat H ; immediate restrict
12 : REPEAT T compile branch (repeat H ; immediate restrict
13
14
15
Screen 31 not modified
0 \ Target conditionals bp27jun85we
1
2 : DO T compile (do >mark H 3 ; immediate restrict
3 : ?DO T compile (?do >mark H 3 ; immediate restrict
4 : LOOP T 3 ?pairs compile (loop compile endloop
5 >resolve H ; immediate restrict
6 : +LOOP T 3 ?pairs compile (+loop compile endloop
7 >resolve H ; immediate restrict
8
9
10
11
12
13
14
15
Screen 32 not modified
0 \ predefinitions bp05mar86we
1
2 : abort" T compile (abort" ," H ; immediate
3 : error" T compile (error" ," H ; immediate
4
5 Forth definitions
6
7 Variable torigin
8 Variable tudp 0 Tudp !
9
10 : >user T c@ H torigin @ + ;
11
12 : >udefer T @ H torigin @ + ;
13
14
15
Screen 33 not modified
0 \ Datatypes bp05mar86we
1
2 Transient definitions
3 : origin! H torigin ! ;
4 : user' ( -- n ) T ' >body c@ H ;
5 : uallot ( n -- ) H tudp @ swap tudp +! ;
6
7 DO> >user ;
8 : User prebuild User 2 T uallot c, ;
9
10 DO> ;
11 : Create prebuild Create ;
12
13 DO> T @ H ;
14 : Constant prebuild Constant T , ;
15 : Variable Create 2 T allot ;
Screen 34 not modified
0 \ Datatypes bp05mar86we
1
2 dummy
3 : Vocabulary
4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
5 here H tvoc-link @ T , H tvoc-link ! ;
6
7 : off ( tadr -- ) H false swap T ! H ;
8
9 : on ( tadr -- ) H true swap T ! H ;
10
11 Forth definitions
12 : Fcbytes ( n1 len -- n2 ) Create over H c, + Does> c@ + ;
13
14
15
Screen 35 not modified
0 \ File >file ks 23 m„r 88
1 &30 Constant tfnamelen \ default length in FCB
2 \ first field for file-link
3 2 1 Fcbytes tf.no \ must be first field
4 2 Fcbytes tf.handle
5 2 Fcbytes tf.date
6 2 Fcbytes tf.time
7 4 Fcbytes tf.size
8 tfnamelen Fcbytes tf.name Constant tb/fcb
9 Transient definitions
10 dummy
11 : File H >in @ >r prebuild File H tfile-link @
12 there tfile-link ! T , H
13 there [ tb/fcb 2 - ] Literal dup T allot erase H
14 tfile-link @ dup T @ H tf.no T c@ H 1+ over tf.no T c!
15 H r> >in ! name count $1F and rot tf.name T place ;
Screen 36 not modified
0 \ target defining words bp08sep86we
1 \ Do> ;
2 \ : Defer prebuild Defer 2 T allot ;
3 \ : Is T ' H >body state @ IF T compile (is , H
4 \ ELSE T ! H THEN ; immediate
5 Do> ;
6 : Defer prebuild Defer 2 T uallot , ;
7 : Is T ' H >body state @ IF T compile (is T @ , H
8 ELSE >udefer T ! H THEN ; immediate
9 | : dodoes> T compile (;code H Glast' @
10 there resdoes> there tdoes> ! ;
11 : ;code 0 T ?pairs dodoes> Assembler H [compile] [
12 redefinition ; immediate restrict
13
14 : does> T dodoes> $E9 C, \ JMP Code
15 H tdodo @ there 2+ - T , H ; immediate restrict
Screen 37 not modified
0 \ : Alias ; bp25mar86we
1
2 : Create: T Create H current @ context ! T ] H 0 ;
3
4 dummy
5 : : H tdoes> off >in @ >in: ! T prebuild :
6 H current @ context ! T ] H 0 ;
7
8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve
9 tlast @ T c@ H $20 or tlast @ T c! , H ;
10
11 : ; T 0 ?pairs compile unnest
12 [compile] [ H redefinition ; immediate restrict
13
14
15
Screen 38 not modified
0 \ predefinitions bp11sep86we
1
2 : compile T compile compile H ; immediate restrict
3 : Host H Onlyforth Ttools also ;
4 : Compiler T Host H Transient also definitions ;
5 : [compile] H Word, ; immediate restrict
6 : Onlypatch H there 3 - 0 tdoes> ! 0 ;
7
8 Onlyforth
9 : Target Onlyforth Transient also definitions ;
10
11 Transient definitions
12 Ghost c, drop
13
14
15
Screen 39 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

680
sources/AtariST/CROSTARG.fth Normal file
View File

@ -0,0 +1,680 @@
\ *** Block No. 0 Hexblock 0
\\ *** volksFORTH-84 Target-Compiler ***
Mit dem Target-Compiler l„žt sich ein neues System aus dem
Quelltext FORTH_83.SCR 'hochziehen'.
\ *** Block No. 1 Hexblock 1
\ Target compiler loadscr 09sep86we
\ Idea and first Implementation by ks/bp
\ Implemented on 6502 by ks/bp
\ ultraFORTH83-Version by bp/we
\ Atari 520 ST - Version by we
Onlyforth Assembler nonrelocate
07 Constant imagepage \ Virtual memory bank
Vocabulary Ttools
Vocabulary Defining
: .stat .blk .s ; ' .stat Is .status
\ : 65( [compile] ( ; immediate
: 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte|
1 $14 +thru \ Target compiler
$15 $17 +thru \ Target Tools
$18 $1A +thru \ Redefinitions
save $1B $25 +thru \ Predefinitions
\ *** Block No. 2 Hexblock 2
\ Target header pointers bp05mar86we
Variable tdp : there tdp @ ;
Variable displace
Variable ?thead 0 ?thead !
Variable tlast 0 tlast !
Variable glast' 0 glast' !
Variable tdoes>
Variable >in:
Variable tvoc 0 tvoc !
Variable tvoc-link 0 tvoc-link !
Variable tnext-link 0 tnext-link !
Variable tdodo
Variable tfile-link 0 tfile-link !
: c+! ( 8b addr -- ) dup c@ rot + swap c! ;
\ *** Block No. 3 Hexblock 3
\ Image and byteorder 15sep86we
: >image ( addr1 - addr2 ) displace @ - ;
: >heap ( from quan - )
heap over - 1 and + \ 68000-align
dup hallot heap swap cmove ;
\ : >ascii 2drop ; ' noop Alias C64>ascii
Code Lc@ ( laddr -- 8b )
.l SP )+ A0 move .w D0 clr .b A0 ) D0 move
.w D0 SP -) move Next end-code
Code Lc! ( 8b addr -- )
.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
Next end-code
\ *** Block No. 4 Hexblock 4
\ Ghost-creating 05mar86we
0 | Constant <forw> 0 | Constant <res>
| : Make.ghost ( - cfa.ghost )
here dup 1 and allot here
state @ IF context @ ELSE current THEN @
dup @ , name
dup c@ 1 $1F uwithin not abort" inval.Gname"
dup c@ 1+ over c!
c@ dup 1+ allot 1 and 0= IF bl c, THEN
here 2 pick - -rot
<forw> , 0 , 0 ,
swap here over - >heap
heap swap ! swap dp !
heap + ;
\ *** Block No. 5 Hexblock 5
\ ghost words 05mar86we
: gfind ( string - cfa tf / string ff )
dup count + 1+ bl swap c!
dup >r 1 over c+! find -1 r> c+! ;
: ghost ( - cfa )
>in @ name gfind IF nip exit THEN
drop >in ! Make.ghost ;
: Word, ghost execute ;
: gdoes> ( cfa.ghost - cfa.does )
4+ dup @ IF @ exit THEN
here dup <forw> , 0 , 4 >heap
dp ! heap dup rot ! ;
\ *** Block No. 6 Hexblock 6
\ ghost utilities 04dec85we
: g' name gfind 0= abort" ?" ;
: '.
g' dup @ <forw> case?
IF ." forw" ELSE <res> - abort" ??" ." res" THEN
2+ dup @ 5 u.r
2+ @ ?dup
IF dup @ <forw> case?
IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
2+ @ 5 u.r THEN ;
' ' Alias h'
\ *** Block No. 7 Hexblock 7
\ .unresolved 05mar86we
| : forward? ( cfa - cfa / exit&true )
dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
| : unresolved? ( addr - f )
2+ dup c@ $1F and over + c@ BL =
IF name> forward? 4+ @ dup IF forward? THEN
THEN drop false ;
| : unresolved-words
BEGIN @ ?dup WHILE dup unresolved?
IF dup 2+ .name ?cr THEN REPEAT ;
: .unresolved voc-link @
BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
\ *** Block No. 8 Hexblock 8
\ Extending Vocabularys for Target-Compilation 05mar86we
: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
Vocabulary Transient 0 tvoc !
Only definitions Forth also
: T Transient ; immediate
: H Forth ; immediate
definitions
\ *** Block No. 9 Hexblock 9
\ Transient primitives 05mar86we
Code byte> ( 8bh 8bl -- 16b )
SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
.w D0 SP ) move Next end-code
Code >byte ( 16b -- 8bl 8bh )
SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
D0 SP -) move D1 SP -) move Next end-code
Transient definitions
: c@ H >image imagepage lc@ ;
: c! H >image imagepage lc! ;
: @ dup T c@ swap 1+ T c@ 65( swap ) byte> ;
: ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ;
: cmove ( from.mem to.target quan -)
bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
: place ( addr len to --)
over >r rot over 1+ r> T cmove c! H ;
\ *** Block No. 10 Hexblock A
\ Transient primitives bp05mar86we
: here there ;
: allot Tdp +! ;
: c, T here c! 1 allot H ;
: , T here ! 2 allot H ;
: ," Ascii " parse dup T c,
under there swap cmove
.( dup 1 and 0= IF 1+ THEN ) allot H ;
: fill ( addr quan 8b -)
-rot bounds ?DO dup I T c! H LOOP drop ;
: erase 0 T fill ;
: blank bl T fill ;
: here! H Tdp ! ;
\ *** Block No. 11 Hexblock B
\ Resolving 08dec85we
Forth definitions
: resolve ( cfa.ghost cfa.target -)
over dup @ <res> =
IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
>r >r 2+ @ ?dup
IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
H ?dup 0= UNTIL
THEN r> r> <res> over ! 2+ ! ;
: resdoes> ( cfa.ghost cfa.target -)
swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
' <forw> >body !
] Does> [ here 4- 0 ] @ T , H ;
' <res> >body !
\ *** Block No. 12 Hexblock C
\ move-threads 68000-align 13jun86we
: move-threads Tvoc @ Tvoc-link @
BEGIN over ?dup
WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
error" some undef. Target-Vocs left" drop ;
| : tlatest ( - addr) current @ 6 + ;
\\
wird fuer 6502 nicht gebraucht
| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
\ *** Block No. 13 Hexblock D
\ save-target 09sep86we
Dos definitions
Code (filewrite ( buff len handle -- n)
SP )+ D0 move .l D2 clr .w SP )+ D2 move
.l 0 imagepage # D1 move .w SP )+ D1 move
.l D1 A7 -) move \ buffer adress
.l D2 A7 -) move \ buffer length
.w D0 A7 -) move \ handle
$40 # A7 -) move \ call WRITE
1 trap $0C # A7 adda
.w D0 SP -) move Next end-code Forth definitions
\ *** Block No. 14 Hexblock E
\ save Target-System 09sep86we
: save-target [ Dos ]
bl word count dup 0= abort" missing filename"
over + off (createfile dup >r 0< abort" no device "
T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
0 there r@ (filewrite there - abort" write error"
r> (closefile 0< abort" close error" ;
\ *** Block No. 15 Hexblock F
\ 8086-ALIGN
: even ( addr -- addr1 ) ; immediate
: align ( -- ) ; immediate
: halign ( -- ) ; immediate
\ *** Block No. 16 Hexblock 10
\\ Create Variable ks 19 m„r 88
Defer makeview ' 0 Is makeview
: Create align here makeview , current @ @ ,
name c@ dup 1 $20 uwithin not Abort" invalid name"
here last ! 1+ allot align ?exists
?head @ IF 1 ?head +! dup , \ Pointer to Code
halign heapmove $20 flag! dup dp !
THEN drop reveal 0 ,
;Code ( -- addr ) D push 2 W D) D lea Next end-code
: Variable Create 0 , ;
\ *** Block No. 17 Hexblock 11
\ compiling names into targ. 05mar86we
: (theader
?thead @ IF 1 ?thead +!
.( there $FF and $FF = IF 1 T allot H THEN ) exit THEN
>in @ name swap >in !
dup c@ 1 $20 uwithin not abort" inval. Tname"
.( dup c@ 3 + there + $FF and $FF =
there 2+ $FF and $FF = or IF 1 T allot H THEN )
blk @ T , H there tlatest dup @ T , H ! there dup tlast !
over c@ 1+ .( even ) dup T allot cmove H ;
: Theader tlast off
(theader Ghost dup glast' !
there resolve ;
\ *** Block No. 18 Hexblock 12
\ prebuild defining words bp27jun85we
| : executable? ( adr - adr f ) dup ;
| : tpfa, there , ;
| : (prebuild ( cfa.adr -- )
>in @ Create >in ! here 2- ! ;
: prebuild ( adr 0.from.: - 0 )
0 ?pairs executable? dup >r
IF [compile] Literal compile (prebuild ELSE drop THEN
compile Theader Ghost gdoes> ,
r> IF compile tpfa, THEN 0 ; immediate restrict
\ *** Block No. 19 Hexblock 13
\ code portion of def.words bp11sep86we
: dummy 0 ;
: DO> ( - adr.of.jmp.dodoes> 0 )
[compile] Does> here 4- compile @ 0 ] ;
\ *** Block No. 20 Hexblock 14
\ the 68000 Assembler 11sep86we
Forth definitions
| Create relocate ] T c, , c@ here allot ! c! H [
Transient definitions
: Assembler H [ Tassembler ] relocate >codes !
Tassembler ;
: >label ( 16b -) H >in @ name gfind rot >in !
IF over resolve dup THEN drop Constant ;
: Label T .( here 1 and allot ) here >label Assembler H ;
: Code H Theader there 2+ T , Assembler H ;
\ *** Block No. 21 Hexblock 15
\ immed. restr. ' \ compile bp05mar86we
: ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
: >mark ( - addr ) H there T 0 , H ;
: >resolve ( addr - ) H there over - swap T ! H ;
: <mark ( - addr ) H there ;
: <resolve ( addr - ) H there - T , H ;
: immediate H Tlast @ ?dup
IF dup T c@ $40 or swap c! H THEN ;
: restrict H Tlast @ ?dup
IF dup T c@ $80 or swap c! H THEN ;
: ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
: | H ?thead @ ?exit ?thead on ;
: compile H Ghost , ; immediate restrict
\ *** Block No. 22 Hexblock 16
\ Target tools ks05mar86we
Onlyforth Ttools also definitions
| : ttype ( adr n -) bounds ?DO I T c@ H dup
bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
ELSE ." ??? " THEN space ?cr ;
| : nfa? ( cfa lfa - nfa / cfa ff)
BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) =
IF 2+ nip exit THEN
T @ H REPEAT ;
: >name ( cfa - nfa / ff)
Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
IF nip exit THEN
swap REPEAT nip ;
\ *** Block No. 23 Hexblock 17
\ Ttools for decompiling ks05mar86we
| : ?: dup 4 u.r ." :" ;
| : @? dup T @ H 6 u.r ;
| : c? dup T c@ H 3 .r ;
: s ( addr - addr+ ) ?: space c? 3 spaces
dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
: n ( addr - addr+2 ) ?: @? 2 spaces
dup T @ H [ Ttools ] >name .name H 2+ ;
: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
2 spaces -rot ttype ;
\ *** Block No. 24 Hexblock 18
\ Tools for decompiling bp05mar86we
: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
: c ( addr -- addr+1 ) 1 d ;
: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
: dump ( adr n -) bounds ?DO cr I $10 d drop
stop? IF LEAVE THEN $10 +LOOP ;
: view T ' H [ Ttools ] >name ?dup
IF 4- T @ H l THEN ;
\ *** Block No. 25 Hexblock 19
\ reinterpretation def.-words 05mar86we
Onlyforth
: redefinition
tdoes> @ IF >in push [ ' >interpret >body ] Literal push
state push context push >in: @ >in !
name [ ' Transient 2+ ] Literal (find nip 0=
IF cr ." Redefinition: " here .name
>in: @ >in ! : Defining interpret THEN
THEN 0 tdoes> ! ;
\ *** Block No. 26 Hexblock 1A
\ Create..does> structure bp05mar86we
| : (;tcode
Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ;
| : changecfa compile lit tdoes> @ , compile (;tcode ;
Defining definitions
: ;code 0 ?pairs changecfa reveal rdrop ;
immediate restrict
Defining ' ;code Alias does> immediate restrict
: ; [compile] ; rdrop ; immediate restrict
\ *** Block No. 27 Hexblock 1B
\ redefinition conditionals bp27jun85we
' DO Alias DO immediate restrict
' ?DO Alias ?DO immediate restrict
' LOOP Alias LOOP immediate restrict
' IF Alias IF immediate restrict
' THEN Alias THEN immediate restrict
' ELSE Alias ELSE immediate restrict
' BEGIN Alias BEGIN immediate restrict
' UNTIL Alias UNTIL immediate restrict
' WHILE Alias WHILE immediate restrict
' REPEAT Alias REPEAT immediate restrict
\ *** Block No. 28 Hexblock 1C
\ clear Liter. Ascii ['] ." bp05mar86we
Onlyforth Transient definitions
: clear true abort" There are ghosts" ;
: Literal ( 16b -- )
dup $FF00 and IF T compile lit , H exit THEN
T compile clit c, H ; immediate restrict
: Ascii H bl word 1+ c@ state @
IF T [compile] Literal H THEN ; immediate
: ['] T ' [compile] Literal H ; immediate restrict
: " T compile (" ," align H ; immediate restrict
: ." T compile (." ," align H ; immediate restrict
\ *** Block No. 29 Hexblock 1D
\ Target compilation ] [ bp05mar86we
Forth definitions
: tcompile
?stack >in @ name find ?dup
IF 0> IF nip execute >interpret THEN
drop dup >in ! name
THEN gfind IF nip execute >interpret THEN
nullstring? IF drop exit THEN
number? ?dup IF 0> IF swap T [compile] Literal THEN
[compile] Literal H drop >interpret THEN
drop >in ! Word, >interpret ;
Transient definitions
: ] H state on ['] tcompile is >interpret ;
\ *** Block No. 30 Hexblock 1E
\ Target conditionals bp05mar86we
: IF T compile ?branch >mark H 1 ; immediate restrict
: THEN abs 1 T ?pairs >resolve H ; immediate restrict
: ELSE T 1 ?pairs compile branch >mark swap >resolve
H -1 ; immediate restrict
: BEGIN T <mark H 2 ; immediate restrict
: WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
immediate restrict
| : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
WHILE drop T >resolve H REPEAT ;
: UNTIL T compile ?branch (repeat H ; immediate restrict
: REPEAT T compile branch (repeat H ; immediate restrict
\ *** Block No. 31 Hexblock 1F
\ Target conditionals bp27jun85we
: DO T compile (do >mark H 3 ; immediate restrict
: ?DO T compile (?do >mark H 3 ; immediate restrict
: LOOP T 3 ?pairs compile (loop compile endloop
>resolve H ; immediate restrict
: +LOOP T 3 ?pairs compile (+loop compile endloop
>resolve H ; immediate restrict
\ *** Block No. 32 Hexblock 20
\ predefinitions bp05mar86we
: abort" T compile (abort" ," H ; immediate
: error" T compile (error" ," H ; immediate
Forth definitions
Variable torigin
Variable tudp 0 Tudp !
: >user T c@ H torigin @ + ;
: >udefer T @ H torigin @ + ;
\ *** Block No. 33 Hexblock 21
\ Datatypes bp05mar86we
Transient definitions
: origin! H torigin ! ;
: user' ( -- n ) T ' >body c@ H ;
: uallot ( n -- ) H tudp @ swap tudp +! ;
DO> >user ;
: User prebuild User 2 T uallot c, ;
DO> ;
: Create prebuild Create ;
DO> T @ H ;
: Constant prebuild Constant T , ;
: Variable Create 2 T allot ;
\ *** Block No. 34 Hexblock 22
\ Datatypes bp05mar86we
dummy
: Vocabulary
H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
here H tvoc-link @ T , H tvoc-link ! ;
: off ( tadr -- ) H false swap T ! H ;
: on ( tadr -- ) H true swap T ! H ;
Forth definitions
: Fcbytes ( n1 len -- n2 ) Create over H c, + Does> c@ + ;
\ *** Block No. 35 Hexblock 23
\ File >file ks 23 m„r 88
&30 Constant tfnamelen \ default length in FCB
\ first field for file-link
2 1 Fcbytes tf.no \ must be first field
2 Fcbytes tf.handle
2 Fcbytes tf.date
2 Fcbytes tf.time
4 Fcbytes tf.size
tfnamelen Fcbytes tf.name Constant tb/fcb
Transient definitions
dummy
: File H >in @ >r prebuild File H tfile-link @
there tfile-link ! T , H
there [ tb/fcb 2 - ] Literal dup T allot erase H
tfile-link @ dup T @ H tf.no T c@ H 1+ over tf.no T c!
H r> >in ! name count $1F and rot tf.name T place ;
\ *** Block No. 36 Hexblock 24
\ target defining words bp08sep86we
\ Do> ;
\ : Defer prebuild Defer 2 T allot ;
\ : Is T ' H >body state @ IF T compile (is , H
\ ELSE T ! H THEN ; immediate
Do> ;
: Defer prebuild Defer 2 T uallot , ;
: Is T ' H >body state @ IF T compile (is T @ , H
ELSE >udefer T ! H THEN ; immediate
| : dodoes> T compile (;code H Glast' @
there resdoes> there tdoes> ! ;
: ;code 0 T ?pairs dodoes> Assembler H [compile] [
redefinition ; immediate restrict
: does> T dodoes> $E9 C, \ JMP Code
H tdodo @ there 2+ - T , H ; immediate restrict
\ *** Block No. 37 Hexblock 25
\ : Alias ; bp25mar86we
: Create: T Create H current @ context ! T ] H 0 ;
dummy
: : H tdoes> off >in @ >in: ! T prebuild :
H current @ context ! T ] H 0 ;
: Alias ( n -- ) H Tlast off (theader Ghost over resolve
tlast @ T c@ H $20 or tlast @ T c! , H ;
: ; T 0 ?pairs compile unnest
[compile] [ H redefinition ; immediate restrict
\ *** Block No. 38 Hexblock 26
\ predefinitions bp11sep86we
: compile T compile compile H ; immediate restrict
: Host H Onlyforth Ttools also ;
: Compiler T Host H Transient also definitions ;
: [compile] H Word, ; immediate restrict
: Onlypatch H there 3 - 0 tdoes> ! 0 ;
Onlyforth
: Target Onlyforth Transient also definitions ;
Transient definitions
Ghost c, drop
\ *** Block No. 39 Hexblock 27

255
sources/AtariST/DEMO.FB.src
View File

@ -1,255 +0,0 @@
Screen 0 not modified
0 \\ *** Graphic - Demonstrationen *** 26may86we
1
2 Dieses File enth„lt einige Graphic-Demos, die von den Line-A
3 Routinen Gebrauch machen.
4
5 Hier bietet sich auch dem Anf„nger ein weites Feld f<>r eigene
6 Versuche. Mit CHECKING ON kann man die gr”bsten Fehler abfan-
7 gen, alledings auf Kosten der Geschwindigkeit.
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Demo Loadscreen 21sep86we
1
2 \needs Graphics include line_a.scr
3
4 Onlyforth Graphics also definitions
5 1 &11 +thru
6
7 moire
8 kaleidos
9 lines
10 boxes
11 rechtecke
12 rechtecke1
13
14
15
Screen 2 not modified
0 \ patterns 18sep86we
1
2 1 ?head !
3 : !pattern ( d -- ) Create , , ;
4
5 $C000.C000 !pattern p1 $CCCC.3333 !pattern p2
6 $C0C0.3030 !pattern p3 $0303.0C0C !pattern p4
7 $C003.300C !pattern p5 $C3C3.3C3C !pattern p6
8 $FFFF.8001 !pattern p7 $40A0.8040 !pattern p8
9 $4444.0000 !pattern p9 $FFFF.2222 !pattern p10
10 $4444.8282 !pattern p11 $8080.8888 !pattern p12
11 $0000.1010 !pattern p13 $0101.8080 !pattern p14
12 $7777.8888 !pattern p15 $7E7E.8181 !pattern p16
13 $E640.FFFF !pattern p17 $3838.C6C6 !pattern p18
14
15 0 ?head !
Screen 3 not modified
0 \ patterns 21may86we
1
2 Create patterns p1 , p2 , p3 , p4 , p5 , p6 ,
3 p7 , p8 , p9 , p10 , p11 , p12 ,
4 p13 , p14 , p15 , p16 , p17 , p18 ,
5
6
7
8
9
10
11
12
13
14
15
Screen 4 not modified
0 \ diamonds 20sep86we
1
2 | : yscale &400 &640 */ ;
3
4 : diamond ( size -- )
5 >r cur_x @ cur_y @
6 2dup swap r@ - swap 2swap 2over set
7 2dup r@ yscale - draw
8 2dup swap r@ + swap draw
9 2dup r> yscale + draw
10 2swap draw set ;
11
12 : big_diamond 2 wr_mode !
13 &319 0 &639 &200 &319 &399 0 &200 4 polygon ;
14
15
Screen 5 not modified
0 \ some usefull definitions 20sep86we
1
2 : overwrite 0 wr_mode ! ;
3 : exorwrite 2 wr_mode ! ;
4
5 | : home get_res scr_res ! 0 0 set ;
6 | : center &320 &200 set ;
7
8 | : wait BEGIN pause key? UNTIL &25 0 at
9 getkey $FF and #esc = abort" stopped" ;
10
11 | : logo &117 0 DO ." volksFORTH 83 " LOOP ;
12
13 | : titel
14 &21 &24 at ." *** v o l k s F O R T H *** "
15 &22 &31 at ." Line-A Graphic " ;
Screen 6 not modified
0 \ patterns example 18sep86we
1
2 : muster
3 page overwrite 1 pat_mask !
4 $10 0 DO patterns I 2* + @ pattern !
5 $10 I $10 * + dup $80 $80 rectangle LOOP
6 6 pat_mask !
7 $10 0 DO patterns I 2* + @ pattern !
8 $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP
9 1 pat_mask ! wait ;
10
11
12
13
14
15
Screen 7 not modified
0 \ kaleidoskop 20sep86we
1
2 | : kaleid exorwrite home center
3 patterns &30 + @ pattern !
4 2 0 DO
5 $40 1 DO $140 0 DO I diamond J +LOOP LOOP
6 LOOP ;
7
8 : kaleidos page big_diamond kaleid wait ;
9 : kaleid1 page logo kaleid wait ;
10
11 : diamonds 1 pat_mask !
12 $10 0 DO patterns I 2* + @ pattern !
13 page big_diamond wait LOOP ;
14
15
Screen 8 not modified
0 \ polygon example 18sep86we
1
2 | : (poly ( x y -- )
3 2dup >r &100 + r> &10 +
4 2dup >r &10 + r> &90 +
5 2dup >r &30 - r> &20 +
6 2dup >r &50 - r> &35 -
7 2dup >r &30 - r> &85 - 6 polygon ;
8
9 : poly page
10 &10 0 DO patterns I 5 + 2* + @ pattern !
11 I I * &5 * I &30 * (poly LOOP
12 &10 0 DO patterns I 5 + 2* + @ pattern !
13 &510 I I * &5 * - I &30 * (poly LOOP
14 wait ;
15
Screen 9 not modified
0 \ moire
1
2 : moire page curoff exorwrite titel
3 &400 1 DO
4 &640 0 DO I &399 &639 I - 0 line J +LOOP
5 &400 0 DO &639 &398 I - 0 I line J +LOOP
6 LOOP
7 1 &399 DO
8 &640 0 DO I &399 &639 I - 0 line J +LOOP
9 &400 0 DO &639 &398 I - 0 I line J +LOOP
10 -1 +LOOP wait ;
11
12
13
14
15
Screen 10 not modified
0 \ boxes 17sep86we
1
2 : boxes exorwrite page
3 &162 0 DO I I set I dup box
4 &639 I 2* - I set I dup box
5 I &399 I 2* - set I dup box
6 &639 I 2* - &399 I 2* - set I dup box 2 +LOOP
7 wait ;
8
9 | Code a>r 4 SP D) D0 move D0 SP ) sub
10 6 SP D) D0 move D0 2 SP D) sub Next end-code
11
12 : abox ( x1 y1 x2 y2 -- ) a>r 2swap set box ;
13
14
15
Screen 11 not modified
0 \ Rechtecke 17sep86we
1
2 : rechtecke exorwrite page
3 0 BEGIN stop? not WHILE
4 8 + dup >r r@ &640 mod r@ &400 mod
5 &639 r@ - &640 mod &399 r> - &400 mod
6 abox REPEAT drop ;
7
8 : rechtecke1 page exorwrite fullpattern pattern !
9 BEGIN stop? not WHILE
10 &99 3 DO &300 0 DO
11 I dup dup J + dup a>r rectangle J +LOOP
12 LOOP
13 3 &98 DO &300 0 DO
14 I dup dup J + dup a>r rectangle J +LOOP
15 -1 +LOOP REPEAT ;
Screen 12 not modified
0 \ linien punkte 18sep86we
1
2 | : (lines ( abstand -- ) exorwrite
3 &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP
4 dup +LOOP drop ;
5
6 : lines page home curoff &45 (lines &90 (lines
7 BEGIN &45 (lines stop? UNTIL &25 0 at ;
8
9 : kreis_moire page &320 0 DO
10 &199 0 DO I dup * J dup * + &300 / 1 and
11 IF &320 J + &200 I + 1 put_pixel
12 &320 J - &200 I + 1 put_pixel
13 &320 J - &200 I - 1 put_pixel
14 &320 J + &200 I - 1 put_pixel
15 THEN 2 +LOOP LOOP wait ;
Screen 13 not modified
0 \ Sprites 20sep86we
1
2 \needs q : q ;
3 forget q : q ;
4
5 : Sprite: Create 5 0 DO 4 I - roll , LOOP
6 $10 0 DO $FFFF , $0F I - roll , LOOP ;
7
8
9 Create spritebuf &74 allot
10
11
12
13
14
15 -->
Screen 14 not modified
0 %0000000000000000 \ 20sep86we
1 %0111111111111100
2 %0100000000000000
3 %0100000000000000
4 %0100000000000000
5 %0100000000000000
6 %0100000000000000
7 %0111111111110000
8 %0100000000000000
9 %0100000000000000
10 %0100000000000000
11 %0100000000000000
12 %0100000000000000
13 %0100000000000000
14 %0100000000000000
15 %0000000000000000 0 0 1 0 1 Sprite: test

255
sources/AtariST/DEMO.fth Normal file
View File

@ -0,0 +1,255 @@
\ *** Block No. 0 Hexblock 0
\\ *** Graphic - Demonstrationen *** 26may86we
Dieses File enth„lt einige Graphic-Demos, die von den Line-A
Routinen Gebrauch machen.
Hier bietet sich auch dem Anf„nger ein weites Feld f<EFBFBD>r eigene
Versuche. Mit CHECKING ON kann man die gr”bsten Fehler abfan-
gen, alledings auf Kosten der Geschwindigkeit.
\ *** Block No. 1 Hexblock 1
\ Demo Loadscreen 21sep86we
\needs Graphics include line_a.scr
Onlyforth Graphics also definitions
1 &11 +thru
moire
kaleidos
lines
boxes
rechtecke
rechtecke1
\ *** Block No. 2 Hexblock 2
\ patterns 18sep86we
1 ?head !
: !pattern ( d -- ) Create , , ;
$C000.C000 !pattern p1 $CCCC.3333 !pattern p2
$C0C0.3030 !pattern p3 $0303.0C0C !pattern p4
$C003.300C !pattern p5 $C3C3.3C3C !pattern p6
$FFFF.8001 !pattern p7 $40A0.8040 !pattern p8
$4444.0000 !pattern p9 $FFFF.2222 !pattern p10
$4444.8282 !pattern p11 $8080.8888 !pattern p12
$0000.1010 !pattern p13 $0101.8080 !pattern p14
$7777.8888 !pattern p15 $7E7E.8181 !pattern p16
$E640.FFFF !pattern p17 $3838.C6C6 !pattern p18
0 ?head !
\ *** Block No. 3 Hexblock 3
\ patterns 21may86we
Create patterns p1 , p2 , p3 , p4 , p5 , p6 ,
p7 , p8 , p9 , p10 , p11 , p12 ,
p13 , p14 , p15 , p16 , p17 , p18 ,
\ *** Block No. 4 Hexblock 4
\ diamonds 20sep86we
| : yscale &400 &640 */ ;
: diamond ( size -- )
>r cur_x @ cur_y @
2dup swap r@ - swap 2swap 2over set
2dup r@ yscale - draw
2dup swap r@ + swap draw
2dup r> yscale + draw
2swap draw set ;
: big_diamond 2 wr_mode !
&319 0 &639 &200 &319 &399 0 &200 4 polygon ;
\ *** Block No. 5 Hexblock 5
\ some usefull definitions 20sep86we
: overwrite 0 wr_mode ! ;
: exorwrite 2 wr_mode ! ;
| : home get_res scr_res ! 0 0 set ;
| : center &320 &200 set ;
| : wait BEGIN pause key? UNTIL &25 0 at
getkey $FF and #esc = abort" stopped" ;
| : logo &117 0 DO ." volksFORTH 83 " LOOP ;
| : titel
&21 &24 at ." *** v o l k s F O R T H *** "
&22 &31 at ." Line-A Graphic " ;
\ *** Block No. 6 Hexblock 6
\ patterns example 18sep86we
: muster
page overwrite 1 pat_mask !
$10 0 DO patterns I 2* + @ pattern !
$10 I $10 * + dup $80 $80 rectangle LOOP
6 pat_mask !
$10 0 DO patterns I 2* + @ pattern !
$110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP
1 pat_mask ! wait ;
\ *** Block No. 7 Hexblock 7
\ kaleidoskop 20sep86we
| : kaleid exorwrite home center
patterns &30 + @ pattern !
2 0 DO
$40 1 DO $140 0 DO I diamond J +LOOP LOOP
LOOP ;
: kaleidos page big_diamond kaleid wait ;
: kaleid1 page logo kaleid wait ;
: diamonds 1 pat_mask !
$10 0 DO patterns I 2* + @ pattern !
page big_diamond wait LOOP ;
\ *** Block No. 8 Hexblock 8
\ polygon example 18sep86we
| : (poly ( x y -- )
2dup >r &100 + r> &10 +
2dup >r &10 + r> &90 +
2dup >r &30 - r> &20 +
2dup >r &50 - r> &35 -
2dup >r &30 - r> &85 - 6 polygon ;
: poly page
&10 0 DO patterns I 5 + 2* + @ pattern !
I I * &5 * I &30 * (poly LOOP
&10 0 DO patterns I 5 + 2* + @ pattern !
&510 I I * &5 * - I &30 * (poly LOOP
wait ;
\ *** Block No. 9 Hexblock 9
\ moire
: moire page curoff exorwrite titel
&400 1 DO
&640 0 DO I &399 &639 I - 0 line J +LOOP
&400 0 DO &639 &398 I - 0 I line J +LOOP
LOOP
1 &399 DO
&640 0 DO I &399 &639 I - 0 line J +LOOP
&400 0 DO &639 &398 I - 0 I line J +LOOP
-1 +LOOP wait ;
\ *** Block No. 10 Hexblock A
\ boxes 17sep86we
: boxes exorwrite page
&162 0 DO I I set I dup box
&639 I 2* - I set I dup box
I &399 I 2* - set I dup box
&639 I 2* - &399 I 2* - set I dup box 2 +LOOP
wait ;
| Code a>r 4 SP D) D0 move D0 SP ) sub
6 SP D) D0 move D0 2 SP D) sub Next end-code
: abox ( x1 y1 x2 y2 -- ) a>r 2swap set box ;
\ *** Block No. 11 Hexblock B
\ Rechtecke 17sep86we
: rechtecke exorwrite page
0 BEGIN stop? not WHILE
8 + dup >r r@ &640 mod r@ &400 mod
&639 r@ - &640 mod &399 r> - &400 mod
abox REPEAT drop ;
: rechtecke1 page exorwrite fullpattern pattern !
BEGIN stop? not WHILE
&99 3 DO &300 0 DO
I dup dup J + dup a>r rectangle J +LOOP
LOOP
3 &98 DO &300 0 DO
I dup dup J + dup a>r rectangle J +LOOP
-1 +LOOP REPEAT ;
\ *** Block No. 12 Hexblock C
\ linien punkte 18sep86we
| : (lines ( abstand -- ) exorwrite
&640 0 DO &640 0 DO I &399 J 0 line dup +LOOP
dup +LOOP drop ;
: lines page home curoff &45 (lines &90 (lines
BEGIN &45 (lines stop? UNTIL &25 0 at ;
: kreis_moire page &320 0 DO
&199 0 DO I dup * J dup * + &300 / 1 and
IF &320 J + &200 I + 1 put_pixel
&320 J - &200 I + 1 put_pixel
&320 J - &200 I - 1 put_pixel
&320 J + &200 I - 1 put_pixel
THEN 2 +LOOP LOOP wait ;
\ *** Block No. 13 Hexblock D
\ Sprites 20sep86we
\needs q : q ;
forget q : q ;
: Sprite: Create 5 0 DO 4 I - roll , LOOP
$10 0 DO $FFFF , $0F I - roll , LOOP ;
Create spritebuf &74 allot
-->
\ *** Block No. 14 Hexblock E
%0000000000000000 \ 20sep86we
%0111111111111100
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0111111111110000
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0100000000000000
%0000000000000000 0 0 1 0 1 Sprite: test

357
sources/AtariST/DISASS.FB.src
View File

@ -1,357 +0,0 @@
Screen 0 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ 68000 Disassembler loadscreen 05dec86we
1
2 Onlyforth
3
4 \needs >absaddr : >absaddr 0 forthstart d+ ;
5 \needs Code .( Load assemble.scr first) abort
6
7 1 ?head ! \ alle Disassembler-Worte headerless
8 1 $12 +thru
9
10 0 ?head !
11 $13 +load \ Benutzer-Worte mit Header
12
13
14
15
Screen 2 not modified
0 \ long words and presigns 14oct86we
1
2 : l+ ( n -- ) extend d+ ;
3 : l- ( n -- ) extend d- ;
4 : l+! ( n addr -- ) >absaddr ln+! ;
5
6 : .# Ascii # emit ;
7 : .$ Ascii $ emit ;
8 : ., Ascii , emit ;
9 : .- Ascii - emit ;
10 : .. Ascii . emit ;
11
12 : .0r ( n width --) over abs swap
13 <# 0 DO # LOOP swap sign #> type space ;
14
15
Screen 3 not modified
0 \ signed / unsigned byte, word and long output 28jan86ma
1
2 : .lformat ( laddr --) <# #s #> dup 8 swap - spaces type ;
3
4 : .lu ( d -- ) <# #s #> type ;
5 : .$lu ( d -- ) .$ .lu ;
6
7 : .wo ( n -- ) 0 <# # # # # #> type ;
8 : .$wu ( n -- ) .$ .wo ;
9 : .$ws ( n -- ) dup $7FFF u>
10 IF .- 1.0000 rot d- THEN .$ .wo ;
11 : .by ( 8b -- ) 0 <# # # #> type ;
12 : .$bu ( 8b -- ) .$ .by ;
13 : .$bs ( 8b -- ) $FF and dup $7F >
14 IF .- 100 swap - THEN .$ .by ;
15 : .lb ( hi lo len -- ) bounds ?DO I over lc@ .by LOOP ;
Screen 4 not modified
0 \ Variables and tabs 18jan86ma
1
2 2Variable addr 2Variable dispaddr 2Variable saveaddr
3 Variable opcode Variable mne Variable mode
4 Variable reg Variable length Variable sr
5 Variable predec
6
7 &10 constant bytfld : tab row swap at ;
8 &32 constant mnefld
9 &40 constant adrfld : tab1 row adrfld at ;
10
11 : getword
12 addr 2@ 2 l+ 2dup addr 2! l@ ;
13 : getlong
14 addr 2@ 4 l+ 2dup addr 2! 2dup 2 l- l@ >r l@ r> ;
15
Screen 5 not modified
0 \ print registernumber, dump 18jan86ma
1
2 : .reg ( n -- ) 7 and Ascii 0 + emit ;
3 : .(areg) ( n -- ) Ascii A emit .reg ;
4 : .(dreg) ( n -- ) Ascii D emit .reg ;
5
6 : .areg reg @ .(areg) ;
7 : .dreg reg @ .(dreg) ;
8
9 : .aind Ascii ( emit .areg Ascii ) emit ;
10 : .apost .aind Ascii + emit ;
11 : .apre .- .aind ;
12
13 : dumpws getword .$ws ;
14 : dumpw getword .$wu ;
15 : dumpl getlong .$lu ;
Screen 6 not modified
0 \ print length , bitmasking 04mar86we
1
2 : len. length @
3 0 case? IF ." .b" tab1 exit THEN
4 1 case? IF ." .w" tab1 exit THEN
5 2 case? IF ." .l" tab1 exit THEN
6 tab1 drop ;
7
8 Code shift ( n -- ) SP )+ D0 move SP ) D1 move
9 D0 D1 lsr D1 SP ) move Next end-code
10 : 4shft 4 shift ; : 8shft 8 shift ;
11 : cshft $0C shift ;
12 : bitce $0C shift 7 and ; : bit5 5 shift 1 and ;
13 : bit6 6 shift 1 and ; : bit7 7 shift 1 and ;
14 : bit10 $0A shift 1 and ; : bit11 $0B shift 1 and ;
15 : bit8b 8 shift $0F and ;
Screen 7 not modified
0 \ bitmasking 2 28jan86ma
1
2 : bit02 7 and ; : bit8 8 shift 1 and ;
3 : bit35 3 shift 7 and ; : bit3 3 shift 1 and ;
4 : bit68 6 shift 7 and ; : bit9b 9 shift 7 and ;
5 : bit67 6 shift 3 and ; : bit37 3 shift $1F and ;
6
7 : len!. length ! len. ;
8 : length6 opcode @ bit6 1+ len!. ;
9 : length67 opcode @ bit67 len!. ;
10
11 : reg02! opcode @ bit02 reg ! ;
12 : reg9b! opcode @ bit9b reg ! ;
13
14 : bit9b. .# opcode @ bit9b dup 0=
15 IF drop 8 THEN .$bu ;
Screen 8 not modified
0 \ list register 26jan86ma
1
2 : reglist
3 getword 10 0 DO
4 dup 2/ swap 1 and
5 IF I predec @
6 IF $0F swap - THEN dup 7 >
7 IF .(areg) ELSE .(dreg) THEN dup
8 IF ." /" THEN
9 THEN LOOP drop ;
10
11 : mnext length6 reg02! .dreg ;
12
13
14
15
Screen 9 not modified
0 \ print adressing mode bp 28Aug86
1
2 : .a/pcreg mode @ 7 =
3 IF ." PC" ELSE .areg THEN ;
4 : l? ( ext.word -- ) $800 and IF ." .L" exit THEN ." .W" ;
5 : i8bit
6 getword dup .$bs
7 Ascii ( emit .a/pcreg ., dup $7FFF >
8 IF Ascii A emit ELSE Ascii D emit THEN
9 dup bitce .reg l? Ascii ) emit ;
10
11 : imm
12 .# length @
13 0 case? IF getword .$bu exit THEN
14 1 case? IF dumpw exit THEN
15 2 case? IF dumpl exit THEN drop ;
Screen 10 not modified
0 \ print adressing mode 28jan86ma
1
2 : mode7 reg @
3 0 case? IF dumpws exit THEN
4 1 case? IF dumpl exit THEN
5 2 case? IF dumpws ." (PC)" exit THEN
6 3 case? IF i8bit exit THEN
7 4 case? IF sr @ IF ." SR" ELSE imm THEN exit THEN
8 drop ." ???" ;
9
10 : effadr mode @
11 0 case? IF .dreg exit THEN 1 case? IF .areg exit THEN
12 2 case? IF .aind exit THEN 3 case? IF .apost exit THEN
13 4 case? IF .apre exit THEN 5 case? IF dumpws .aind exit THEN
14 6 case? IF i8bit exit THEN 7 case? IF mode7 exit THEN
15 drop ;
Screen 11 not modified
0 \ find register and mode 28jan86ma
1 : .ea opcode @ dup bit02 reg ! bit35 mode ! effadr ;
2 : .eadest opcode @ dup bit68 mode ! bit9b reg ! effadr ;
3 : mnabcd
4 tab1 opcode @ bit3
5 IF reg02! .apre ., reg9b! .apre
6 ELSE reg02! .dreg ., reg9b! .dreg THEN ;
7 : mnaddx length67 mnabcd ;
8 : mncmpm length67 reg02! .apost ., reg9b! .apost ;
9 : mnexg
10 tab1 reg9b! opcode @ bit37
11 dup 9 = IF .areg ELSE .dreg THEN ., reg02!
12 8 = IF .dreg ELSE .areg THEN ;
13 : mnadd length67 opcode @
14 bit8 IF reg9b! .dreg ., .ea
15 ELSE .ea ., reg9b! .dreg THEN ;
Screen 12 not modified
0 \ find register and mode 26jan86ma
1 : mnadda opcode @ bit8 1+ len!. .ea ., reg9b! .areg ;
2 : mnaddi length67 imm ., 1 sr ! .ea ;
3 : mnaddq length67 bit9b. ., .ea ;
4 : mnmoveq tab1 .# opcode @ .$bs ., reg9b! .dreg ;
5 : mnswap tab1 reg02! .dreg ;
6 : mnunlk tab1 reg02! .areg ;
7 : mnclr length67 .ea ;
8 : mnjmp tab1 .ea ;
9 : mnchk mnjmp ., reg9b! .dreg ;
10 : mnlea tab1 .ea ., reg9b! .areg ;
11 : mnbchg tab1 opcode @ bit8
12 IF reg9b! .dreg ELSE .# dumpw THEN ., .ea ;
13 : mnbchg2 tab1 reg9b! .dreg ., .ea ;
14 : .dir opcode @ bit8
15 IF Ascii l emit ELSE Ascii r emit THEN ;
Screen 13 not modified
0 \ find register and mode 23sep86we
1
2 : mnshft
3 .dir length67 opcode @ bit5
4 IF reg9b! .dreg ELSE bit9b. THEN ., reg02! .dreg ;
5 : mnshft2 .dir mnjmp ;
6 : reladr2
7 getword dup $7FFF >
8 IF 1.0000 rot d- THEN 2+ dispaddr 2@ rot l+ .$lu ;
9 : reladr
10 opcode @ $FF and ?dup
11 IF dup $7F > IF 100 - THEN 2+ dispaddr 2@ rot l+ .$lu
12 ELSE reladr2 THEN ;
13 : quote Create $22 word drop $22 allot Does> 1+ ;
14 quote ctbl0 t f hilscccsneeqvcvsplmigeltgtle"
15 quote ctbl1 rasrhilscccsneeqvcvsplmigeltgtle"
Screen 14 not modified
0 \ find register and mode 18jan86ma
1
2 : .cond ( ctblflag --> )
3 IF ctbl1 ELSE ctbl0 THEN
4 opcode @ bit8b 2* + 2 type tab1 ;
5 : mnscc 0 .cond .ea ;
6 : mnbcc 1 .cond reladr ;
7 : mndbcc 0 .cond reg02! .dreg ., reladr2 ;
8 : mnlink tab1 reg02! .areg ., .# dumpws ;
9 : mnmove
10 4 opcode @ bitce - dup 3 = IF drop 0 THEN
11 len!. .ea ., .eadest ;
12 : mnmoveccr mnjmp ." ,ccr" ;
13 : mnmovesr mnjmp ." ,sr" ;
14 : mnmovefsr tab1 ." sr," .ea ;
15
Screen 15 not modified
0 \ find register and mode 26jan86ma
1
2 : mnmoveusp tab1 reg02! opcode @ bit3
3 IF ." usp," .areg ELSE .areg ." ,usp" THEN ;
4 : mnmovem
5 length6 opcode @ dup bit35 4 = predec ! bit10
6 IF .ea ., reglist ELSE reglist ., .ea THEN ;
7 : mnmovep
8 length6 opcode @ bit7
9 IF reg9b! .dreg ., dumpws reg02! .aind
10 ELSE dumpws reg02! .aind ., reg9b! .dreg THEN ;
11 : mnstop tab1 .# dumpw ;
12 : mntrap tab1 .# opcode @ $0F and .$bu ;
13 : mnimp ;
14
15 : t, swap , , [compile] ' , bl word drop 8 allot ;
Screen 16 not modified
0 \ mask- and opcode-table 18jan86ma
1
2 Create mntbl base @ hex
3 ff00 0600 t, mnaddi addi ff00 0200 t, mnaddi andi
4 ff00 0c00 t, mnaddi cmpi ff00 0a00 t, mnaddi eori
5 ff00 0000 t, mnaddi ori ff00 0400 t, mnaddi subi
6 ffc0 0840 t, mnbchg bchg ffc0 0880 t, mnbchg bclr
7 ffc0 08c0 t, mnbchg bset ffc0 0800 t, mnbchg btst
8 e1c0 2040 t, mnmove movea c000 0000 t, mnmove move
9 ffff 4afc t, mnimp illegal ffff 4e71 t, mnimp nop
10 ffff 4e70 t, mnimp reset ffff 4e73 t, mnimp rte
11 ffff 4e77 t, mnimp rtr ffff 4e75 t, mnimp rts
12 ffff 4e76 t, mnimp trapv ffff 4e72 t, mnstop stop
13 fff0 4e40 t, mntrap trap fff8 4840 t, mnswap swap
14 fff8 4e58 t, mnunlk unlk fff8 4e50 t, mnlink link
15 ffb8 4880 t, mnext ext ffc0 44c0 t, mnmoveccr move
Screen 17 not modified
0 \ mask- and opcode-table 18jan86ma
1
2 ffc0 46c0 t, mnmovesr move ffc0 40c0 t, mnmovefsr move
3 fff0 4e60 t, mnmoveusp move ffc0 4ac0 t, mnjmp tas
4 ff00 4200 t, mnclr clr ff00 4400 t, mnclr neg
5 ff00 4000 t, mnclr negx ff00 4600 t, mnclr not
6 ff00 4a00 t, mnclr tst ffc0 4ec0 t, mnjmp jmp
7 ffc0 4e80 t, mnjmp jsr ffc0 4800 t, mnjmp nbcd
8 ffc0 4840 t, mnjmp pea f1c0 41c0 t, mnlea lea
9 f1c0 4180 t, mnchk chk fb80 4880 t, mnmovem movem
10 f0f8 50c8 t, mndbcc db f0c0 50c0 t, mnscc s
11 f100 5000 t, mnaddq addq f100 5100 t, mnaddq subq
12 f000 6000 t, mnbcc b f100 7000 t, mnmoveq moveq
13 f1f0 8100 t, mnabcd sbcd f1c0 81c0 t, mnchk divs
14 f1c0 80c0 t, mnchk divu f000 8000 t, mnadd or
15
Screen 18 not modified
0 \ mask- and opcode-table 18jan86ma
1
2 f0c0 90c0 t, mnadda suba f130 9100 t, mnaddx subx
3 f000 9000 t, mnadd sub f000 a000 t, mnimp ?ext0a
4 f0c0 b0c0 t, mnadda cmpa f138 b108 t, mncmpm cmpm
5 f100 b100 t, mnadd eor f100 b000 t, mnadd cmp
6 f1f0 c100 t, mnabcd abcd f1c0 c1c0 t, mnchk muls
7 f1c0 c0c0 t, mnchk mulu f130 c100 t, mnexg exg
8 f000 c000 t, mnadd and f0c0 d0c0 t, mnadda adda
9 f130 d100 t, mnaddx addx f000 d000 t, mnadd add
10 fec0 e0c0 t, mnshft2 as fec0 e2c0 t, mnshft2 ls
11 fec0 e4c0 t, mnshft2 rox fec0 e6c0 t, mnshft2 ro
12 f018 e000 t, mnshft as f018 e008 t, mnshft ls
13 f018 e010 t, mnshft rox f018 e018 t, mnshft ro
14 f000 f000 t, mnimp ?ext0f 0000 0000 t, mnimp ???
15 base !
Screen 19 not modified
0 \ search mne and dis a line 05dec86we
1
2 : searchmne ( -- )
3 mntbl 0 sr ! 0 predec !
4 BEGIN dup @ opcode @ and over 2+ @ =
5 IF dup 6 + count type 4+ @ execute exit THEN
6 $0E + REPEAT ;
7
8 : disline ( -- ) base push hex
9 cr dispaddr 2@ .lformat mnefld tab
10 addr 2@ 2dup saveaddr 2! l@ opcode !
11 searchmne 2 addr l+! bytfld tab
12 addr 2@ saveaddr 2@ d- drop dup >r dispaddr l+!
13 saveaddr 2@ swap r> .lb drop ;
14
15
Screen 20 not modified
0 \ addr! dis ldis disw 14oct86we
1
2 : addr! 2dup addr 2! dispaddr 2! ;
3
4 : disassline addr! disline ;
5
6 : ldis addr! BEGIN disline stop? UNTIL cr ;
7
8 : dis >absaddr ldis ;
9
10 : disw ' 2+ dup ." Adresse : " u. cr >absaddr addr!
11 BEGIN
12 BEGIN disline opcode @ $4EF3 = stop? or UNTIL
13 key $FF and #esc = UNTIL
14 cr ;
15

357
sources/AtariST/DISASS.fth Normal file
View File

@ -0,0 +1,357 @@
\ *** Block No. 0 Hexblock 0
\ *** Block No. 1 Hexblock 1
\ 68000 Disassembler loadscreen 05dec86we
Onlyforth
\needs >absaddr : >absaddr 0 forthstart d+ ;
\needs Code .( Load assemble.scr first) abort
1 ?head ! \ alle Disassembler-Worte headerless
1 $12 +thru
0 ?head !
$13 +load \ Benutzer-Worte mit Header
\ *** Block No. 2 Hexblock 2
\ long words and presigns 14oct86we
: l+ ( n -- ) extend d+ ;
: l- ( n -- ) extend d- ;
: l+! ( n addr -- ) >absaddr ln+! ;
: .# Ascii # emit ;
: .$ Ascii $ emit ;
: ., Ascii , emit ;
: .- Ascii - emit ;
: .. Ascii . emit ;
: .0r ( n width --) over abs swap
<# 0 DO # LOOP swap sign #> type space ;
\ *** Block No. 3 Hexblock 3
\ signed / unsigned byte, word and long output 28jan86ma
: .lformat ( laddr --) <# #s #> dup 8 swap - spaces type ;
: .lu ( d -- ) <# #s #> type ;
: .$lu ( d -- ) .$ .lu ;
: .wo ( n -- ) 0 <# # # # # #> type ;
: .$wu ( n -- ) .$ .wo ;
: .$ws ( n -- ) dup $7FFF u>
IF .- 1.0000 rot d- THEN .$ .wo ;
: .by ( 8b -- ) 0 <# # # #> type ;
: .$bu ( 8b -- ) .$ .by ;
: .$bs ( 8b -- ) $FF and dup $7F >
IF .- 100 swap - THEN .$ .by ;
: .lb ( hi lo len -- ) bounds ?DO I over lc@ .by LOOP ;
\ *** Block No. 4 Hexblock 4
\ Variables and tabs 18jan86ma
2Variable addr 2Variable dispaddr 2Variable saveaddr
Variable opcode Variable mne Variable mode
Variable reg Variable length Variable sr
Variable predec
&10 constant bytfld : tab row swap at ;
&32 constant mnefld
&40 constant adrfld : tab1 row adrfld at ;
: getword
addr 2@ 2 l+ 2dup addr 2! l@ ;
: getlong
addr 2@ 4 l+ 2dup addr 2! 2dup 2 l- l@ >r l@ r> ;
\ *** Block No. 5 Hexblock 5
\ print registernumber, dump 18jan86ma
: .reg ( n -- ) 7 and Ascii 0 + emit ;
: .(areg) ( n -- ) Ascii A emit .reg ;
: .(dreg) ( n -- ) Ascii D emit .reg ;
: .areg reg @ .(areg) ;
: .dreg reg @ .(dreg) ;
: .aind Ascii ( emit .areg Ascii ) emit ;
: .apost .aind Ascii + emit ;
: .apre .- .aind ;
: dumpws getword .$ws ;
: dumpw getword .$wu ;
: dumpl getlong .$lu ;
\ *** Block No. 6 Hexblock 6
\ print length , bitmasking 04mar86we
: len. length @
0 case? IF ." .b" tab1 exit THEN
1 case? IF ." .w" tab1 exit THEN
2 case? IF ." .l" tab1 exit THEN
tab1 drop ;
Code shift ( n -- ) SP )+ D0 move SP ) D1 move
D0 D1 lsr D1 SP ) move Next end-code
: 4shft 4 shift ; : 8shft 8 shift ;
: cshft $0C shift ;
: bitce $0C shift 7 and ; : bit5 5 shift 1 and ;
: bit6 6 shift 1 and ; : bit7 7 shift 1 and ;
: bit10 $0A shift 1 and ; : bit11 $0B shift 1 and ;
: bit8b 8 shift $0F and ;
\ *** Block No. 7 Hexblock 7
\ bitmasking 2 28jan86ma
: bit02 7 and ; : bit8 8 shift 1 and ;
: bit35 3 shift 7 and ; : bit3 3 shift 1 and ;
: bit68 6 shift 7 and ; : bit9b 9 shift 7 and ;
: bit67 6 shift 3 and ; : bit37 3 shift $1F and ;
: len!. length ! len. ;
: length6 opcode @ bit6 1+ len!. ;
: length67 opcode @ bit67 len!. ;
: reg02! opcode @ bit02 reg ! ;
: reg9b! opcode @ bit9b reg ! ;
: bit9b. .# opcode @ bit9b dup 0=
IF drop 8 THEN .$bu ;
\ *** Block No. 8 Hexblock 8
\ list register 26jan86ma
: reglist
getword 10 0 DO
dup 2/ swap 1 and
IF I predec @
IF $0F swap - THEN dup 7 >
IF .(areg) ELSE .(dreg) THEN dup
IF ." /" THEN
THEN LOOP drop ;
: mnext length6 reg02! .dreg ;
\ *** Block No. 9 Hexblock 9
\ print adressing mode bp 28Aug86
: .a/pcreg mode @ 7 =
IF ." PC" ELSE .areg THEN ;
: l? ( ext.word -- ) $800 and IF ." .L" exit THEN ." .W" ;
: i8bit
getword dup .$bs
Ascii ( emit .a/pcreg ., dup $7FFF >
IF Ascii A emit ELSE Ascii D emit THEN
dup bitce .reg l? Ascii ) emit ;
: imm
.# length @
0 case? IF getword .$bu exit THEN
1 case? IF dumpw exit THEN
2 case? IF dumpl exit THEN drop ;
\ *** Block No. 10 Hexblock A
\ print adressing mode 28jan86ma
: mode7 reg @
0 case? IF dumpws exit THEN
1 case? IF dumpl exit THEN
2 case? IF dumpws ." (PC)" exit THEN
3 case? IF i8bit exit THEN
4 case? IF sr @ IF ." SR" ELSE imm THEN exit THEN
drop ." ???" ;
: effadr mode @
0 case? IF .dreg exit THEN 1 case? IF .areg exit THEN
2 case? IF .aind exit THEN 3 case? IF .apost exit THEN
4 case? IF .apre exit THEN 5 case? IF dumpws .aind exit THEN
6 case? IF i8bit exit THEN 7 case? IF mode7 exit THEN
drop ;
\ *** Block No. 11 Hexblock B
\ find register and mode 28jan86ma
: .ea opcode @ dup bit02 reg ! bit35 mode ! effadr ;
: .eadest opcode @ dup bit68 mode ! bit9b reg ! effadr ;
: mnabcd
tab1 opcode @ bit3
IF reg02! .apre ., reg9b! .apre
ELSE reg02! .dreg ., reg9b! .dreg THEN ;
: mnaddx length67 mnabcd ;
: mncmpm length67 reg02! .apost ., reg9b! .apost ;
: mnexg
tab1 reg9b! opcode @ bit37
dup 9 = IF .areg ELSE .dreg THEN ., reg02!
8 = IF .dreg ELSE .areg THEN ;
: mnadd length67 opcode @
bit8 IF reg9b! .dreg ., .ea
ELSE .ea ., reg9b! .dreg THEN ;
\ *** Block No. 12 Hexblock C
\ find register and mode 26jan86ma
: mnadda opcode @ bit8 1+ len!. .ea ., reg9b! .areg ;
: mnaddi length67 imm ., 1 sr ! .ea ;
: mnaddq length67 bit9b. ., .ea ;
: mnmoveq tab1 .# opcode @ .$bs ., reg9b! .dreg ;
: mnswap tab1 reg02! .dreg ;
: mnunlk tab1 reg02! .areg ;
: mnclr length67 .ea ;
: mnjmp tab1 .ea ;
: mnchk mnjmp ., reg9b! .dreg ;
: mnlea tab1 .ea ., reg9b! .areg ;
: mnbchg tab1 opcode @ bit8
IF reg9b! .dreg ELSE .# dumpw THEN ., .ea ;
: mnbchg2 tab1 reg9b! .dreg ., .ea ;
: .dir opcode @ bit8
IF Ascii l emit ELSE Ascii r emit THEN ;
\ *** Block No. 13 Hexblock D
\ find register and mode 23sep86we
: mnshft
.dir length67 opcode @ bit5
IF reg9b! .dreg ELSE bit9b. THEN ., reg02! .dreg ;
: mnshft2 .dir mnjmp ;
: reladr2
getword dup $7FFF >
IF 1.0000 rot d- THEN 2+ dispaddr 2@ rot l+ .$lu ;
: reladr
opcode @ $FF and ?dup
IF dup $7F > IF 100 - THEN 2+ dispaddr 2@ rot l+ .$lu
ELSE reladr2 THEN ;
: quote Create $22 word drop $22 allot Does> 1+ ;
quote ctbl0 t f hilscccsneeqvcvsplmigeltgtle"
quote ctbl1 rasrhilscccsneeqvcvsplmigeltgtle"
\ *** Block No. 14 Hexblock E
\ find register and mode 18jan86ma
: .cond ( ctblflag --> )
IF ctbl1 ELSE ctbl0 THEN
opcode @ bit8b 2* + 2 type tab1 ;
: mnscc 0 .cond .ea ;
: mnbcc 1 .cond reladr ;
: mndbcc 0 .cond reg02! .dreg ., reladr2 ;
: mnlink tab1 reg02! .areg ., .# dumpws ;
: mnmove
4 opcode @ bitce - dup 3 = IF drop 0 THEN
len!. .ea ., .eadest ;
: mnmoveccr mnjmp ." ,ccr" ;
: mnmovesr mnjmp ." ,sr" ;
: mnmovefsr tab1 ." sr," .ea ;
\ *** Block No. 15 Hexblock F
\ find register and mode 26jan86ma
: mnmoveusp tab1 reg02! opcode @ bit3
IF ." usp," .areg ELSE .areg ." ,usp" THEN ;
: mnmovem
length6 opcode @ dup bit35 4 = predec ! bit10
IF .ea ., reglist ELSE reglist ., .ea THEN ;
: mnmovep
length6 opcode @ bit7
IF reg9b! .dreg ., dumpws reg02! .aind
ELSE dumpws reg02! .aind ., reg9b! .dreg THEN ;
: mnstop tab1 .# dumpw ;
: mntrap tab1 .# opcode @ $0F and .$bu ;
: mnimp ;
: t, swap , , [compile] ' , bl word drop 8 allot ;
\ *** Block No. 16 Hexblock 10
\ mask- and opcode-table 18jan86ma
Create mntbl base @ hex
ff00 0600 t, mnaddi addi ff00 0200 t, mnaddi andi
ff00 0c00 t, mnaddi cmpi ff00 0a00 t, mnaddi eori
ff00 0000 t, mnaddi ori ff00 0400 t, mnaddi subi
ffc0 0840 t, mnbchg bchg ffc0 0880 t, mnbchg bclr
ffc0 08c0 t, mnbchg bset ffc0 0800 t, mnbchg btst
e1c0 2040 t, mnmove movea c000 0000 t, mnmove move
ffff 4afc t, mnimp illegal ffff 4e71 t, mnimp nop
ffff 4e70 t, mnimp reset ffff 4e73 t, mnimp rte
ffff 4e77 t, mnimp rtr ffff 4e75 t, mnimp rts
ffff 4e76 t, mnimp trapv ffff 4e72 t, mnstop stop
fff0 4e40 t, mntrap trap fff8 4840 t, mnswap swap
fff8 4e58 t, mnunlk unlk fff8 4e50 t, mnlink link
ffb8 4880 t, mnext ext ffc0 44c0 t, mnmoveccr move
\ *** Block No. 17 Hexblock 11
\ mask- and opcode-table 18jan86ma
ffc0 46c0 t, mnmovesr move ffc0 40c0 t, mnmovefsr move
fff0 4e60 t, mnmoveusp move ffc0 4ac0 t, mnjmp tas
ff00 4200 t, mnclr clr ff00 4400 t, mnclr neg
ff00 4000 t, mnclr negx ff00 4600 t, mnclr not
ff00 4a00 t, mnclr tst ffc0 4ec0 t, mnjmp jmp
ffc0 4e80 t, mnjmp jsr ffc0 4800 t, mnjmp nbcd
ffc0 4840 t, mnjmp pea f1c0 41c0 t, mnlea lea
f1c0 4180 t, mnchk chk fb80 4880 t, mnmovem movem
f0f8 50c8 t, mndbcc db f0c0 50c0 t, mnscc s
f100 5000 t, mnaddq addq f100 5100 t, mnaddq subq
f000 6000 t, mnbcc b f100 7000 t, mnmoveq moveq
f1f0 8100 t, mnabcd sbcd f1c0 81c0 t, mnchk divs
f1c0 80c0 t, mnchk divu f000 8000 t, mnadd or
\ *** Block No. 18 Hexblock 12
\ mask- and opcode-table 18jan86ma
f0c0 90c0 t, mnadda suba f130 9100 t, mnaddx subx
f000 9000 t, mnadd sub f000 a000 t, mnimp ?ext0a
f0c0 b0c0 t, mnadda cmpa f138 b108 t, mncmpm cmpm
f100 b100 t, mnadd eor f100 b000 t, mnadd cmp
f1f0 c100 t, mnabcd abcd f1c0 c1c0 t, mnchk muls
f1c0 c0c0 t, mnchk mulu f130 c100 t, mnexg exg
f000 c000 t, mnadd and f0c0 d0c0 t, mnadda adda
f130 d100 t, mnaddx addx f000 d000 t, mnadd add
fec0 e0c0 t, mnshft2 as fec0 e2c0 t, mnshft2 ls
fec0 e4c0 t, mnshft2 rox fec0 e6c0 t, mnshft2 ro
f018 e000 t, mnshft as f018 e008 t, mnshft ls
f018 e010 t, mnshft rox f018 e018 t, mnshft ro
f000 f000 t, mnimp ?ext0f 0000 0000 t, mnimp ???
base !
\ *** Block No. 19 Hexblock 13
\ search mne and dis a line 05dec86we
: searchmne ( -- )
mntbl 0 sr ! 0 predec !
BEGIN dup @ opcode @ and over 2+ @ =
IF dup 6 + count type 4+ @ execute exit THEN
$0E + REPEAT ;
: disline ( -- ) base push hex
cr dispaddr 2@ .lformat mnefld tab
addr 2@ 2dup saveaddr 2! l@ opcode !
searchmne 2 addr l+! bytfld tab
addr 2@ saveaddr 2@ d- drop dup >r dispaddr l+!
saveaddr 2@ swap r> .lb drop ;
\ *** Block No. 20 Hexblock 14
\ addr! dis ldis disw 14oct86we
: addr! 2dup addr 2! dispaddr 2! ;
: disassline addr! disline ;
: ldis addr! BEGIN disline stop? UNTIL cr ;
: dis >absaddr ldis ;
: disw ' 2+ dup ." Adresse : " u. cr >absaddr addr!
BEGIN
BEGIN disline opcode @ $4EF3 = stop? or UNTIL
key $FF and #esc = UNTIL
cr ;

136
sources/AtariST/DRAGON1.FB.src
View File

@ -1,136 +0,0 @@
Screen 0 not modified
0 \\ documentation for dargon demo tcas20130106
1 start the dragon with : <pos int> DRAG
2 or with : <1 or -1> <pos int> DRAGON
3
4 DRAG clears the screen, defines the starting point and executes
5 DRAGON.
6 The variable STEPSIZE defines the size of steps between 1 and 3
7 (larger values will produce grabage)
8
9 odd numbers as input values do not work
10
11 DDEMO is a loop executing the DRAGON demo which can be stopped
12 with a keypress once the 2nd dragon is fully painted (it is
13 recommended to press a key a little in advance)
14
15
Screen 1 not modified
0 \ dragon-loadscreen cas20130106
1
2 Onlyforth
3
4 \needs Graphics include line_a.fb
5
6 Onlyforth GEM also Graphics also
7
8 decimal
9
10 1 5 +thru
11
12
13
14
15
Screen 2 not modified
0 \ dragon s.2 03oct86we
1
2 Variable angle
3 Variable stepsize 1 stepsize !
4 Variable color 1 color !
5 Variable xcood Variable ycood
6
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ set_pixel 03oct86we
1
2 Label ?step
3 stepsize pcrel) D2 move D1 tst 0<> IF D2 neg THEN rts
4
5 Code set_pixel
6 xcood pcrel) D3 move ycood pcrel) D4 move
7 angle pcrel) D0 move 1 # D0 asr D0 D1 move 1 D0 andi
8 1 # D1 asr 1 D1 andi
9 D0 tst 0= IF ?step bsr D2 D3 add D3 xcood R#) move THEN
10 D0 tst 0<> IF ?step bsr D2 D4 add D4 ycood R#) move THEN
11 D3 SP -) move D4 SP -) move color pcrel) SP -) move
12 ;c: put_pixel ;
13
14
15
Screen 4 not modified
0 \ dragon s.3 03oct86we
1
2 Code turn ( n -- )
3 angle pcrel) D0 move SP )+ D0 add D0 angle R#) move
4 Next end-code
5
6 : dragon recursive ( stepw rec_tiefe -- )
7 dup 0= IF 2drop set_pixel
8 ELSE
9 over turn
10 1 over 1- dragon
11 over 2* negate turn
12 -1 over 1- dragon
13 drop turn
14 THEN ;
15
Screen 5 not modified
0 \ dragon s.4 03oct86we
1
2 : drachen
3 2 stepsize !
4 100 xcood ! 200 ycood ! 1 14 dragon
5 101 xcood ! 200 ycood ! 1 14 dragon
6 100 xcood ! 201 ycood ! 1 14 dragon
7 101 xcood ! 201 ycood ! 1 14 dragon
8 1 stepsize ! ;
9
10 : schubs
11 100 0 DO I 112 over - 400 272 2over >r 1+ r> 1-
12 scr>scr LOOP ;
13
14
15
Screen 6 not modified
0 \ dragon s.5 03oct86we
1
2 : drag ( n -- ) page
3 angle off 100 xcood ! 200 ycood !
4 1 swap dragon ;
5
6 : ddemo
7 16 drag schubs
8 0 color ! 199 xcood ! 100 ycood ! 1 16 dragon
9 1 color ! drachen ;
10
11
12
13
14
15
Screen 7 not modified
0 \ 03oct86we
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

136
sources/AtariST/DRAGON1.fth Normal file
View File

@ -0,0 +1,136 @@
\ *** Block No. 0 Hexblock 0
\\ documentation for dargon demo tcas20130106
start the dragon with : <pos int> DRAG
or with : <1 or -1> <pos int> DRAGON
DRAG clears the screen, defines the starting point and executes
DRAGON.
The variable STEPSIZE defines the size of steps between 1 and 3
(larger values will produce grabage)
odd numbers as input values do not work
DDEMO is a loop executing the DRAGON demo which can be stopped
with a keypress once the 2nd dragon is fully painted (it is
recommended to press a key a little in advance)
\ *** Block No. 1 Hexblock 1
\ dragon-loadscreen cas20130106
Onlyforth
\needs Graphics include line_a.fb
Onlyforth GEM also Graphics also
decimal
1 5 +thru
\ *** Block No. 2 Hexblock 2
\ dragon s.2 03oct86we
Variable angle
Variable stepsize 1 stepsize !
Variable color 1 color !
Variable xcood Variable ycood
\ *** Block No. 3 Hexblock 3
\ set_pixel 03oct86we
Label ?step
stepsize pcrel) D2 move D1 tst 0<> IF D2 neg THEN rts
Code set_pixel
xcood pcrel) D3 move ycood pcrel) D4 move
angle pcrel) D0 move 1 # D0 asr D0 D1 move 1 D0 andi
1 # D1 asr 1 D1 andi
D0 tst 0= IF ?step bsr D2 D3 add D3 xcood R#) move THEN
D0 tst 0<> IF ?step bsr D2 D4 add D4 ycood R#) move THEN
D3 SP -) move D4 SP -) move color pcrel) SP -) move
;c: put_pixel ;
\ *** Block No. 4 Hexblock 4
\ dragon s.3 03oct86we
Code turn ( n -- )
angle pcrel) D0 move SP )+ D0 add D0 angle R#) move
Next end-code
: dragon recursive ( stepw rec_tiefe -- )
dup 0= IF 2drop set_pixel
ELSE
over turn
1 over 1- dragon
over 2* negate turn
-1 over 1- dragon
drop turn
THEN ;
\ *** Block No. 5 Hexblock 5
\ dragon s.4 03oct86we
: drachen
2 stepsize !
100 xcood ! 200 ycood ! 1 14 dragon
101 xcood ! 200 ycood ! 1 14 dragon
100 xcood ! 201 ycood ! 1 14 dragon
101 xcood ! 201 ycood ! 1 14 dragon
1 stepsize ! ;
: schubs
100 0 DO I 112 over - 400 272 2over >r 1+ r> 1-
scr>scr LOOP ;
\ *** Block No. 6 Hexblock 6
\ dragon s.5 03oct86we
: drag ( n -- ) page
angle off 100 xcood ! 200 ycood !
1 swap dragon ;
: ddemo
16 drag schubs
0 color ! 199 xcood ! 100 ycood ! 1 16 dragon
1 color ! drachen ;
\ *** Block No. 7 Hexblock 7
\ 03oct86we

102
sources/AtariST/EDIICON.FB.src
View File

@ -1,102 +0,0 @@
Screen 0 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15 -->
Screen 1 not modified
0 \ Definitionen aus EDIICON.H
1
2 &0 >label :EDIMENU &3 >label :ATARI
3 &4 >label :EXITS &5 >label :SCREENS
4 &6 >label :LINES &7 >label :CHARS
5 &8 >label :CURSOR &9 >label :SPECIALS
6 &10 >label :HELP &13 >label :VOLKS4TH
7 &24 >label :UPDATED &25 >label :FLUSHED
8 &26 >label :LOADING &28 >label :UNDO
9 &30 >label :NEXT &31 >label :BACK
10 &32 >label :SHADOW &33 >label :ALTERNAT
11 &35 >label :MARK &40 >label :BACKLINE
12 &41 >label :DELLINE &42 >label :INSLINE
13 &44 >label :CUTLINE &45 >label :PASTELIN
14 &47 >label :COPYLINE &48 >label :ERASELIN
15 &49 >label :ERASREST &52 >label :CUTCHAR -->
Screen 2 not modified
0 \ Definitionen aus EDIICON.H
1
2 &53 >label :PASTECHA &55 >label :COPYCHAR
3 &58 >label :HOME &59 >label :TOEND
4 &60 >label :TAB &61 >label :BACKTAB
5 &64 >label :SEARCH &65 >label :REPEAT
6 &67 >label :IMODE &68 >label :OMODE
7 &72 >label :MENUHELP &73 >label :HMOUSE
8 &74 >label :HFUNCTS &1 >label :COPYR
9 &70 >label :GETID &2 >label :SFIND
10 &0 >label :HEXCANCL &1 >label :HEXUPDAT
11 &2 >label :HEXSAVE &3 >label :HEXLOAD
12 &4 >label :HEXUNDO &5 >label :HSCNEXT
13 &6 >label :HSCBACK &7 >label :HSCSHADO
14 &8 >label :HSCALTER &9 >label :HSCMARK
15 &10 >label :HLIBACK &11 >label :HLIDEL -->
Screen 3 not modified
0 \ Definitionen aus EDIICON.H
1
2 &12 >label :HLIINS &14 >label :HLICUT
3 &15 >label :HLIPASTE &16 >label :HLICOPY
4 &17 >label :HLIERASE &18 >label :HLIREST
5 &19 >label :HCHCUT &20 >label :HCHPASTE
6 &21 >label :HCHCOPY &22 >label :HCUHOME
7 &23 >label :HCUEND &24 >label :HCUTABR
8 &25 >label :HCUTABL &26 >label :HSPFIND
9 &3 >label :FBOX &8 >label :DFMATCH
10 &9 >label :DFIGNORE &2 >label :DF1ST
11 &1 >label :DFLAST &12 >label :DFCANCEL
12 &14 >label :DFFIND &13 >label :DFREPLAC
13 &15 >label :DFFSTRIN &16 >label :DFRSTRIN
14 &27 >label :HSPREPEA &28 >label :HSPINS
15 &29 >label :HSPOVER &30 >label :HSPGETID -->
Screen 4 not modified
0 \ Definitionen aus EDIICON.H
1
2 &31 >label :HHEMENU &4 >label :SGETID
3 &13 >label :HLISPLIT &32 >label :HHEMOUSE
4 &33 >label :HHEF1F10 &2 >label :FBOXYES
5 &3 >label :FBOXNO &4 >label :FBOXCANC
6 &1 >label :IDTEXT &5 >label :IDOK
7 &4 >label :NOID &3 >label :IDCANCEL
8 &4 >label :DFLEFT &5 >label :DFRIGHT
9 &5 >label :SGETSCR &1 >label :SCRNR
10 &2 >label :SGOK &3 >label :SGCANCEL
11 &36 >label :JUMP &23 >label :CANCELED
12 &43 >label :SPLIT &37 >label :VIEW
13 &6 >label :SVIEW &2 >label :SVOK
14 &3 >label :SVCANCEL &1 >label :SVWORD
15 &34 >label :HJUMP &35 >label :HVIEW -->
Screen 5 not modified
0 \ Definitionen aus EDIICON.H
1
2 &4 >label :SVMARK &15 >label :DESKACC1
3 &20 >label :DESKACC6
4
5
6
7
8
9
10
11
12
13
14
15

102
sources/AtariST/EDIICON.fth Normal file
View File

@ -0,0 +1,102 @@
\ *** Block No. 0 Hexblock 0
-->
\ *** Block No. 1 Hexblock 1
\ Definitionen aus EDIICON.H
&0 >label :EDIMENU &3 >label :ATARI
&4 >label :EXITS &5 >label :SCREENS
&6 >label :LINES &7 >label :CHARS
&8 >label :CURSOR &9 >label :SPECIALS
&10 >label :HELP &13 >label :VOLKS4TH
&24 >label :UPDATED &25 >label :FLUSHED
&26 >label :LOADING &28 >label :UNDO
&30 >label :NEXT &31 >label :BACK
&32 >label :SHADOW &33 >label :ALTERNAT
&35 >label :MARK &40 >label :BACKLINE
&41 >label :DELLINE &42 >label :INSLINE
&44 >label :CUTLINE &45 >label :PASTELIN
&47 >label :COPYLINE &48 >label :ERASELIN
&49 >label :ERASREST &52 >label :CUTCHAR -->
\ *** Block No. 2 Hexblock 2
\ Definitionen aus EDIICON.H
&53 >label :PASTECHA &55 >label :COPYCHAR
&58 >label :HOME &59 >label :TOEND
&60 >label :TAB &61 >label :BACKTAB
&64 >label :SEARCH &65 >label :REPEAT
&67 >label :IMODE &68 >label :OMODE
&72 >label :MENUHELP &73 >label :HMOUSE
&74 >label :HFUNCTS &1 >label :COPYR
&70 >label :GETID &2 >label :SFIND
&0 >label :HEXCANCL &1 >label :HEXUPDAT
&2 >label :HEXSAVE &3 >label :HEXLOAD
&4 >label :HEXUNDO &5 >label :HSCNEXT
&6 >label :HSCBACK &7 >label :HSCSHADO
&8 >label :HSCALTER &9 >label :HSCMARK
&10 >label :HLIBACK &11 >label :HLIDEL -->
\ *** Block No. 3 Hexblock 3
\ Definitionen aus EDIICON.H
&12 >label :HLIINS &14 >label :HLICUT
&15 >label :HLIPASTE &16 >label :HLICOPY
&17 >label :HLIERASE &18 >label :HLIREST
&19 >label :HCHCUT &20 >label :HCHPASTE
&21 >label :HCHCOPY &22 >label :HCUHOME
&23 >label :HCUEND &24 >label :HCUTABR
&25 >label :HCUTABL &26 >label :HSPFIND
&3 >label :FBOX &8 >label :DFMATCH
&9 >label :DFIGNORE &2 >label :DF1ST
&1 >label :DFLAST &12 >label :DFCANCEL
&14 >label :DFFIND &13 >label :DFREPLAC
&15 >label :DFFSTRIN &16 >label :DFRSTRIN
&27 >label :HSPREPEA &28 >label :HSPINS
&29 >label :HSPOVER &30 >label :HSPGETID -->
\ *** Block No. 4 Hexblock 4
\ Definitionen aus EDIICON.H
&31 >label :HHEMENU &4 >label :SGETID
&13 >label :HLISPLIT &32 >label :HHEMOUSE
&33 >label :HHEF1F10 &2 >label :FBOXYES
&3 >label :FBOXNO &4 >label :FBOXCANC
&1 >label :IDTEXT &5 >label :IDOK
&4 >label :NOID &3 >label :IDCANCEL
&4 >label :DFLEFT &5 >label :DFRIGHT
&5 >label :SGETSCR &1 >label :SCRNR
&2 >label :SGOK &3 >label :SGCANCEL
&36 >label :JUMP &23 >label :CANCELED
&43 >label :SPLIT &37 >label :VIEW
&6 >label :SVIEW &2 >label :SVOK
&3 >label :SVCANCEL &1 >label :SVWORD
&34 >label :HJUMP &35 >label :HVIEW -->
\ *** Block No. 5 Hexblock 5
\ Definitionen aus EDIICON.H
&4 >label :SVMARK &15 >label :DESKACC1
&20 >label :DESKACC6

1598
sources/AtariST/EDITOR.FB.src
View File

File diff suppressed because it is too large Load Diff

1598
sources/AtariST/EDITOR.fth Normal file
View File

File diff suppressed because it is too large Load Diff

306
sources/AtariST/EDWINDOW.FB.src
View File

@ -1,306 +0,0 @@
Screen 0 not modified
0 \\ *** EDWINDOW.SCR *** 14sep86we
1
2 Dieses File enth„lt das Editorfenster. Es kann als Beispiel f<>r
3 die Programmierung eines eigenen Fensters benutzt werden.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Window-Handling Loadscreen 30oct86we
1
2 Onlyforth Gem also definitions
3
4 1 7 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ VDI-Functions for window 24aug86we
1
2 : bar ( x1 y1 x2 y2 -- )
3 ptsin 4 array! 1 function ! &11 2 0 VDI ;
4
5 : swr_mode ( mode -- ) intin ! &32 0 1 VDI ;
6
7 : sf_interior ( style -- ) intin ! &23 0 1 VDI ;
8 : sf_style ( styleindex -- ) intin ! &24 0 1 VDI ;
9 : sf_color ( color -- ) intin ! &25 0 1 VDI ;
10 : sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ;
11
12 : fbox ( x1 y1 x2 y2 -- )
13 1 swr_mode 1 sf_interior 0 sf_color 0 sf_perimeter bar ;
14
15
Screen 3 not modified
0 \ save and restore the screen 10sep86we
1
2 ?head @ 1 ?head !
3
4 Create memMFDB2 7 , 0 , &640 , &400 , &40 , 0 , 1 ,
5 0 , 0 , 0 ,
6
7 memMFDB2 scr>mem scr>mem2 ( Xleft Ytop Width Heigth -- )
8 memMFDB2 mem>scr mem2>scr ( Xleft Ytop Width Heigth -- )
9
10 : save_screen 0 0 cwidth &80 * cheight &25 *
11 scr>mem2 ;
12 : restore_screen 0 0 cwidth &80 * cheight &25 *
13 mem2>scr ;
14
15
Screen 4 not modified
0 \ Windowcomponents and Windowsize 30aug86we
1
2 :name :move + :info + :uparrow + :dnarrow + :vslide +
3 Constant wi_components
4
5 : wi_x ( -- n ) dx cwidth * ;
6 : wi_y ( -- n ) dy cheight * ;
7 : wi_width ( -- n ) c/l cwidth * ;
8 : wi_height ( -- n ) l/s cheight * ;
9
10 : wi_size ( -- wx wy wwidth wheight )
11 0 wi_components
12 wi_x 1- wi_y 1- wi_width 2+ wi_height 2+ wind_calc
13 intout 2+ 4@ ;
14
15
Screen 5 not modified
0 \ Window's title and sliders 25sep86we
1
2 Variable wi_handle
3
4 : wi_string ( 0string function# -- ) swap >r
5 wi_handle @ swap r> >absaddr swap 0 0 wind_set ;
6
7 : wi_title ( 0string -- ) :wf_name wi_string ;
8 : wi_status ( 0string -- ) :wf_info wi_string ;
9
10 : vslide_size
11 wi_handle @ :wf_vslize &1000 capacity / 0 0 0 wind_set ;
12
13 : vslide ( scr# -- ) wi_handle @ :wf_vslide
14 rot &1000 capacity dup 1- IF 1- THEN */
15 0 0 0 wind_set ;
Screen 6 not modified
0 \ Draw window on screen 30aug86we
1
2 : small_big ( -- sx sy sw sh bx by bw bh )
3 little 4@ wi_size ;
4
5 : growbox small_big graf_growbox ;
6 : shrinkbox small_big graf_shrinkbox ;
7
8 : wi_clear wi_x 1- wi_y 1-
9 over wi_width 1+ + over wi_height 1+ + fbox ;
10
11
12
13
14
15
Screen 7 not modified
0 \ Open and close window 30aug86we
1
2 : wi_open ( -- ) save_screen growbox
3 wi_components wi_size wind_create dup wi_handle !
4 pad dup off dup wi_title wi_status
5 wi_size wind_open wi_clear ;
6
7 : wi_close ( -- )
8 wi_handle @ dup wind_close wind_delete
9 shrinkbox restore_screen ;
10
11
12
13
14
15
Screen 8 not modified
0 \ redrawing the rest of screen 10sep86we
1
2 : restore_rect ( x y w h -- ) 1- >r 1- r> mem2>scr ;
3
4 : rect_update ( function# -- x y w h )
5 0 swap wind_get intout 2+ 4@ ;
6
7 : redraw_screen :wf_firstxywh rect_update
8 BEGIN 2dup or
9 WHILE restore_rect :wf_nextxywh rect_update REPEAT
10 2drop 2drop ;
11
12 ?head !
13
14
15
Screen 9 not modified
0 14sep86we
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ Window-Handling Loadscreen 14sep86we
1
2 Suchreihenfolge: Zuerst GEM, dann FORTH
3
4 Gebraucht werden die Definitionen aus GEMDEFS.SCR
5
6 Dieses Vokabular wird als erstes durchsucht.
7
8
9
10
11
12
13
14
15
Screen 11 not modified
0 \ VDI-Functions for window 14sep86we
1
2 F<>r das Fenster werden einige Funktionen aus VDI gebraucht,
3 die auf diesem Screen zusammengestellt sind. Beschreibung siehe
4 Beschreibung VDI (hoffentlich haben wir die schon!)
5
6 Im Grunde wird nur eine Routine benutzt, mit der man ein weižes
7 Rechteck zum L”schen des Fensterinhaltes erzeugen kann. Dies
8 erledigt fbox
9
10
11
12
13
14
15
Screen 12 not modified
0 \ save and restore the screen 14sep86we
1
2 alle folgenden Funktionen sollen headerless kompiliert werden.
3
4 Ein zweiter Speicherbereich wird gebraucht, um den Bildschirm
5 beim Verlassen des Editors zu restaurieren. Dieses Verfahren
6 ren ist erheblich schneller als die Neuausgabe des Bildschirms,
7 braucht aber Speicherplatz (Wir hams ja!)
8
9
10 Der gesamte Bildschirm wird in den daf<61>r vorgesehenen Speicher-
11 bereich gerettet (aužerhalb des FORTH-Systems, versteht sich)
12 Das Ganze umgekehrt stellt den Bildschirm wieder her. Diese
13 Funktionen sind recht n<>tzlich, weil man Werte noch sehen kann,
14 die z.B. bei LIST weggescrollt w<>rden.
15
Screen 13 not modified
0 \ Windowcomponents and Windowsize 14sep86we
1
2 Die Bestandteile des Fensters werden einfach aufaddiert und
3 als Konstante zur Verf<72>gung gestellt.
4
5 linke obere Ecke des Fensters in Bildschirmkoordinaten
6
7 Breite des Fensters in Bildschirmkoordinaten
8 H”he des Fensters in Bildschirmkoordinaten
9
10 berechnet die Ausmaže des Fensters f<>r alle weiteren Funktionen
11 unter Zuhilfenahme von WIND-CALC. Leider liefert diese Funktion
12 bei Breite und H”he ein Pixel zu wenig. Digital Research allein
13 mag wissen, warum ...
14
15
Screen 14 not modified
0 \ Window's title and sliders 14sep86we
1
2 Window-Handle des Fensters
3
4 zur Ausgabe eines Textes in Titel- oder Infozeile
5 Der String muž mit einer Null abgeschlossen sein.
6
7 gibt 0string in der Titelzeile aus.
8 gibt 0string in der Infozeile aus.
9
10 Die Gr”že des vertikalen Sliders wird aus der Gesamtgr”že des
11 Files, das editiert wird, berechnet.
12
13 Die Position des vertikalen Sliders wird relativ zur Gesamtgr”že
14 des Files eingestellt.
15
Screen 15 not modified
0 \ Draw window on screen 14sep86we
1
2 gibt die Gr”že eines kleinen Rechtecks sowie des ganzen Fensters
3
4
5 zeichnet ein wachsendes Rechteck (nur f<>rs Auge ...)
6 zeichnet ein schrumpfendes Rechteck ( s.o.)
7
8 l”scht den Innenraum des Fenster durch šberschreiben mit einem
9 weižen Rechteck.
10
11
12
13
14
15
Screen 16 not modified
0 \ Open and close window 14sep86we
1
2 ”ffnet das Editorfenster: Bildschirminhalt merken
3 Fenster erzeugen mit entsprechender Gr”že und Attributen
4 Titel- und Infozeile l”schen
5 Fenster auf dem Bildschirm ausgeben und Inhalt l”schen
6
7 schliežt das Editorfenster:
8 Fenster vom Bildschirm und <20>berhaupt entfernen
9 Bildschirm restaurieren.
10
11
12
13
14
15
Screen 17 not modified
0 \ redrawing the rest of screen 14sep86we
1
2 Rechteck per Pixelmove restaurieren
3
4 liefert die Koordinaten eines neu zu zeichnenden Rechtecks.
5
6 Der Screenmanager stellt eine Liste von Rechtecken zurVerf<72>gung,
7 die nach einer Aktion ge„ndert worden sind.
8 Durch diese Liste hangelt sich die Routine hindurch und
9 erzeugt die Rechtecke per Pixelmove (schnell) neu.
10
11
12
13
14
15

306
sources/AtariST/EDWINDOW.fth Normal file
View File

@ -0,0 +1,306 @@
\ *** Block No. 0 Hexblock 0
\\ *** EDWINDOW.SCR *** 14sep86we
Dieses File enth„lt das Editorfenster. Es kann als Beispiel f<EFBFBD>r
die Programmierung eines eigenen Fensters benutzt werden.
\ *** Block No. 1 Hexblock 1
\ Window-Handling Loadscreen 30oct86we
Onlyforth Gem also definitions
1 7 +thru
\ *** Block No. 2 Hexblock 2
\ VDI-Functions for window 24aug86we
: bar ( x1 y1 x2 y2 -- )
ptsin 4 array! 1 function ! &11 2 0 VDI ;
: swr_mode ( mode -- ) intin ! &32 0 1 VDI ;
: sf_interior ( style -- ) intin ! &23 0 1 VDI ;
: sf_style ( styleindex -- ) intin ! &24 0 1 VDI ;
: sf_color ( color -- ) intin ! &25 0 1 VDI ;
: sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ;
: fbox ( x1 y1 x2 y2 -- )
1 swr_mode 1 sf_interior 0 sf_color 0 sf_perimeter bar ;
\ *** Block No. 3 Hexblock 3
\ save and restore the screen 10sep86we
?head @ 1 ?head !
Create memMFDB2 7 , 0 , &640 , &400 , &40 , 0 , 1 ,
0 , 0 , 0 ,
memMFDB2 scr>mem scr>mem2 ( Xleft Ytop Width Heigth -- )
memMFDB2 mem>scr mem2>scr ( Xleft Ytop Width Heigth -- )
: save_screen 0 0 cwidth &80 * cheight &25 *
scr>mem2 ;
: restore_screen 0 0 cwidth &80 * cheight &25 *
mem2>scr ;
\ *** Block No. 4 Hexblock 4
\ Windowcomponents and Windowsize 30aug86we
:name :move + :info + :uparrow + :dnarrow + :vslide +
Constant wi_components
: wi_x ( -- n ) dx cwidth * ;
: wi_y ( -- n ) dy cheight * ;
: wi_width ( -- n ) c/l cwidth * ;
: wi_height ( -- n ) l/s cheight * ;
: wi_size ( -- wx wy wwidth wheight )
0 wi_components
wi_x 1- wi_y 1- wi_width 2+ wi_height 2+ wind_calc
intout 2+ 4@ ;
\ *** Block No. 5 Hexblock 5
\ Window's title and sliders 25sep86we
Variable wi_handle
: wi_string ( 0string function# -- ) swap >r
wi_handle @ swap r> >absaddr swap 0 0 wind_set ;
: wi_title ( 0string -- ) :wf_name wi_string ;
: wi_status ( 0string -- ) :wf_info wi_string ;
: vslide_size
wi_handle @ :wf_vslize &1000 capacity / 0 0 0 wind_set ;
: vslide ( scr# -- ) wi_handle @ :wf_vslide
rot &1000 capacity dup 1- IF 1- THEN */
0 0 0 wind_set ;
\ *** Block No. 6 Hexblock 6
\ Draw window on screen 30aug86we
: small_big ( -- sx sy sw sh bx by bw bh )
little 4@ wi_size ;
: growbox small_big graf_growbox ;
: shrinkbox small_big graf_shrinkbox ;
: wi_clear wi_x 1- wi_y 1-
over wi_width 1+ + over wi_height 1+ + fbox ;
\ *** Block No. 7 Hexblock 7
\ Open and close window 30aug86we
: wi_open ( -- ) save_screen growbox
wi_components wi_size wind_create dup wi_handle !
pad dup off dup wi_title wi_status
wi_size wind_open wi_clear ;
: wi_close ( -- )
wi_handle @ dup wind_close wind_delete
shrinkbox restore_screen ;
\ *** Block No. 8 Hexblock 8
\ redrawing the rest of screen 10sep86we
: restore_rect ( x y w h -- ) 1- >r 1- r> mem2>scr ;
: rect_update ( function# -- x y w h )
0 swap wind_get intout 2+ 4@ ;
: redraw_screen :wf_firstxywh rect_update
BEGIN 2dup or
WHILE restore_rect :wf_nextxywh rect_update REPEAT
2drop 2drop ;
?head !
\ *** Block No. 9 Hexblock 9
14sep86we
\ *** Block No. 10 Hexblock A
\ Window-Handling Loadscreen 14sep86we
Suchreihenfolge: Zuerst GEM, dann FORTH
Gebraucht werden die Definitionen aus GEMDEFS.SCR
Dieses Vokabular wird als erstes durchsucht.
\ *** Block No. 11 Hexblock B
\ VDI-Functions for window 14sep86we
F<EFBFBD>r das Fenster werden einige Funktionen aus VDI gebraucht,
die auf diesem Screen zusammengestellt sind. Beschreibung siehe
Beschreibung VDI (hoffentlich haben wir die schon!)
Im Grunde wird nur eine Routine benutzt, mit der man ein weižes
Rechteck zum L”schen des Fensterinhaltes erzeugen kann. Dies
erledigt fbox
\ *** Block No. 12 Hexblock C
\ save and restore the screen 14sep86we
alle folgenden Funktionen sollen headerless kompiliert werden.
Ein zweiter Speicherbereich wird gebraucht, um den Bildschirm
beim Verlassen des Editors zu restaurieren. Dieses Verfahren
ren ist erheblich schneller als die Neuausgabe des Bildschirms,
braucht aber Speicherplatz (Wir hams ja!)
Der gesamte Bildschirm wird in den daf<EFBFBD>r vorgesehenen Speicher-
bereich gerettet (aužerhalb des FORTH-Systems, versteht sich)
Das Ganze umgekehrt stellt den Bildschirm wieder her. Diese
Funktionen sind recht n<EFBFBD>tzlich, weil man Werte noch sehen kann,
die z.B. bei LIST weggescrollt w<EFBFBD>rden.
\ *** Block No. 13 Hexblock D
\ Windowcomponents and Windowsize 14sep86we
Die Bestandteile des Fensters werden einfach aufaddiert und
als Konstante zur Verf<EFBFBD>gung gestellt.
linke obere Ecke des Fensters in Bildschirmkoordinaten
Breite des Fensters in Bildschirmkoordinaten
H”he des Fensters in Bildschirmkoordinaten
berechnet die Ausmaže des Fensters f<EFBFBD>r alle weiteren Funktionen
unter Zuhilfenahme von WIND-CALC. Leider liefert diese Funktion
bei Breite und H”he ein Pixel zu wenig. Digital Research allein
mag wissen, warum ...
\ *** Block No. 14 Hexblock E
\ Window's title and sliders 14sep86we
Window-Handle des Fensters
zur Ausgabe eines Textes in Titel- oder Infozeile
Der String muž mit einer Null abgeschlossen sein.
gibt 0string in der Titelzeile aus.
gibt 0string in der Infozeile aus.
Die Gr”že des vertikalen Sliders wird aus der Gesamtgr”že des
Files, das editiert wird, berechnet.
Die Position des vertikalen Sliders wird relativ zur Gesamtgr”že
des Files eingestellt.
\ *** Block No. 15 Hexblock F
\ Draw window on screen 14sep86we
gibt die Gr”že eines kleinen Rechtecks sowie des ganzen Fensters
zeichnet ein wachsendes Rechteck (nur f<EFBFBD>rs Auge ...)
zeichnet ein schrumpfendes Rechteck ( s.o.)
l”scht den Innenraum des Fenster durch šberschreiben mit einem
weižen Rechteck.
\ *** Block No. 16 Hexblock 10
\ Open and close window 14sep86we
”ffnet das Editorfenster: Bildschirminhalt merken
Fenster erzeugen mit entsprechender Gr”že und Attributen
Titel- und Infozeile l”schen
Fenster auf dem Bildschirm ausgeben und Inhalt l”schen
schliežt das Editorfenster:
Fenster vom Bildschirm und <EFBFBD>berhaupt entfernen
Bildschirm restaurieren.
\ *** Block No. 17 Hexblock 11
\ redrawing the rest of screen 14sep86we
Rechteck per Pixelmove restaurieren
liefert die Koordinaten eines neu zu zeichnenden Rechtecks.
Der Screenmanager stellt eine Liste von Rechtecken zurVerf<EFBFBD>gung,
die nach einer Aktion ge„ndert worden sind.
Durch diese Liste hangelt sich die Routine hindurch und
erzeugt die Rechtecke per Pixelmove (schnell) neu.

102
sources/AtariST/ERRORBOX.FB.src
View File

@ -1,102 +0,0 @@
Screen 0 not modified
0 ERRORBOX.SCR 26oct86we
1
2 Dieses File gibt ABORT"-Fehlermeldungen in ALERT-Boxen aus.
3
4 Diese Box enth„lt die Buttons "Cancel" und "Editor", falls der
5 Fehler beim Laden eines Files auftrat. Der Button "Editor"
6 verzweigt in den Editor, "Cancel" zum Kommandointerpreter.
7 "Editor" ist der Defaultwert, der bei Dr<44>cken von <Return>
8 ausgel”st wird.
9 Trat der Fehler bei Ausf<73>hrung von Tastatureingaben auf, gibt
10 es nur den OK-Button.
11
12
13
14
15
Screen 1 not modified
0 \ Loadscreen for errorbox 26oct86we
1
2 Onlyforth Gem also definitions
3
4 0 list
5
6 1 +load
7
8 ' boxhandler errorhandler !
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Display all errors in an ALERT-Box 26oct86we
1
2 | : addstring ( string -- ) \ add a string to pad
3 count $add ;
4
5 : boxhandler ( string -- )
6 show_c pad dup off $sum !
7 " [3][" addstring
8 here addstring
9 " |" addstring addstring
10 blk @ ?dup IF scr ! >in @ r# !
11 2 " ][Cancel|Editor]"
12 ELSE 1 " ][Ok]" THEN addstring
13 pad c>0" pad form_alert hide_c
14 2 = IF v THEN quit ;
15
Screen 3 not modified
0 ERRORBOX.SCR 26oct86we
1
2 Zugleich wollen wir zeigen, wie einfach unter volksFORTH Alert-
3 Boxen programmiert werden k”nnen. Bei unserem Beispiel handelt
4 es sich sogar um einen komplizierten Fall, weil der auszu-
5 gebende String erst in PAD zusammengestellt werden muž.
6
7 Ansonsten k”nnte eine Alert-Box z.B. so programmiert werden.
8 (Das folgende Beispiel k”nnen Sie ausprobieren, indem Sie den
9 Cursor in die n„chste Zeile setzen und CTRL-L eingeben.
10
11 Create boxtext ," [3][Dies ist eine Alert-Box][Seh ich selbst]"
12 boxtext c>0"
13
14 : test 1 boxtext form_alert drop ;
15
Screen 4 not modified
0 \ Loadscreen for errorbox 26oct86we
1
2 setzt Searchorder auf GEM GEM FORTH ONLY GEM
3
4 gibt Screen 0 mit der Anleitung aus.
5
6 kompiliert den folgenden Screen.
7
8 setzt BOXHANDLER als neuen errorhandler. Alle Fehlermeldungen,
9 die <20>ber abort" laufen, erscheinen jetzt in Boxen.
10
11
12
13
14
15
Screen 5 not modified
0 \ Display all errors in an ALERT-Box 26oct86we
1
2 ADDSTRING h„ngt den String bei Adresse string an den String
3 bei $SUM an. Benutzt $ADD aus dem File STRINGS.SCR
4
5 BOXHANDLER gibt den String von ABORT" in einer Alert-Box aus.
6 Maus einschalten und PAD als Ziel f<>r ADDSTRING vorbereiten.
7 Die 3 sorgt f<>r das STOP-Icon in der Box.
8 Bei HERE steht das Wort, das den Fehler verursacht hat.
9 In die n„chste Zeile kommt die Fehlermeldung von ABORT"
10 Wenn der Fehler beim Kompilieren auftrat, werden Screen und
11 Cursorposition gemerkt und zwei Buttons ausgegeben.
12 Sonst kann man den Fehler nur quittieren.
13 Bei PAD ist jetzt der gesamte Boxtext zusammengestellt.
14 Falls 'EDITOR' angeklickt wurde, wird der Editor mit dem
15 fehlerhaften Screen aufgerufen.

102
sources/AtariST/ERRORBOX.fth Normal file
View File

@ -0,0 +1,102 @@
\ *** Block No. 0 Hexblock 0
ERRORBOX.SCR 26oct86we
Dieses File gibt ABORT"-Fehlermeldungen in ALERT-Boxen aus.
Diese Box enth„lt die Buttons "Cancel" und "Editor", falls der
Fehler beim Laden eines Files auftrat. Der Button "Editor"
verzweigt in den Editor, "Cancel" zum Kommandointerpreter.
"Editor" ist der Defaultwert, der bei Dr<EFBFBD>cken von <Return>
ausgel”st wird.
Trat der Fehler bei Ausf<EFBFBD>hrung von Tastatureingaben auf, gibt
es nur den OK-Button.
\ *** Block No. 1 Hexblock 1
\ Loadscreen for errorbox 26oct86we
Onlyforth Gem also definitions
0 list
1 +load
' boxhandler errorhandler !
\ *** Block No. 2 Hexblock 2
\ Display all errors in an ALERT-Box 26oct86we
| : addstring ( string -- ) \ add a string to pad
count $add ;
: boxhandler ( string -- )
show_c pad dup off $sum !
" [3][" addstring
here addstring
" |" addstring addstring
blk @ ?dup IF scr ! >in @ r# !
2 " ][Cancel|Editor]"
ELSE 1 " ][Ok]" THEN addstring
pad c>0" pad form_alert hide_c
2 = IF v THEN quit ;
\ *** Block No. 3 Hexblock 3
ERRORBOX.SCR 26oct86we
Zugleich wollen wir zeigen, wie einfach unter volksFORTH Alert-
Boxen programmiert werden k”nnen. Bei unserem Beispiel handelt
es sich sogar um einen komplizierten Fall, weil der auszu-
gebende String erst in PAD zusammengestellt werden muž.
Ansonsten k”nnte eine Alert-Box z.B. so programmiert werden.
(Das folgende Beispiel k”nnen Sie ausprobieren, indem Sie den
Cursor in die n„chste Zeile setzen und CTRL-L eingeben.
Create boxtext ," [3][Dies ist eine Alert-Box][Seh ich selbst]"
boxtext c>0"
: test 1 boxtext form_alert drop ;
\ *** Block No. 4 Hexblock 4
\ Loadscreen for errorbox 26oct86we
setzt Searchorder auf GEM GEM FORTH ONLY GEM
gibt Screen 0 mit der Anleitung aus.
kompiliert den folgenden Screen.
setzt BOXHANDLER als neuen errorhandler. Alle Fehlermeldungen,
die <EFBFBD>ber abort" laufen, erscheinen jetzt in Boxen.
\ *** Block No. 5 Hexblock 5
\ Display all errors in an ALERT-Box 26oct86we
ADDSTRING h„ngt den String bei Adresse string an den String
bei $SUM an. Benutzt $ADD aus dem File STRINGS.SCR
BOXHANDLER gibt den String von ABORT" in einer Alert-Box aus.
Maus einschalten und PAD als Ziel f<EFBFBD>r ADDSTRING vorbereiten.
Die 3 sorgt f<EFBFBD>r das STOP-Icon in der Box.
Bei HERE steht das Wort, das den Fehler verursacht hat.
In die n„chste Zeile kommt die Fehlermeldung von ABORT"
Wenn der Fehler beim Kompilieren auftrat, werden Screen und
Cursorposition gemerkt und zwei Buttons ausgegeben.
Sonst kann man den Fehler nur quittieren.
Bei PAD ist jetzt der gesamte Boxtext zusammengestellt.
Falls 'EDITOR' angeklickt wurde, wird der Editor mit dem
fehlerhaften Screen aufgerufen.

1258
sources/AtariST/FILEINT.FB.src
View File

File diff suppressed because it is too large Load Diff

1258
sources/AtariST/FILEINT.fth Normal file
View File

File diff suppressed because it is too large Load Diff

2261
sources/AtariST/FORTH83.FB.src
View File

File diff suppressed because it is too large Load Diff

2261
sources/AtariST/FORTH83.fth Normal file
View File

File diff suppressed because it is too large Load Diff

680
sources/AtariST/GEM/AES.FB.src
View File

@ -1,680 +0,0 @@
Screen 0 not modified
0 \\ *** AES -Funktionen *** 26may86we
1
2 Dieses File enth„lt alle AES-Funktionen.
3
4 Zur genauren Beschreibung verweisen wir auf die Dokumentation
5 von Digital Research.
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ AES Loadscreen cas20130105
1
2 \needs GEM include gem\basics.fb
3 Onlyforth
4 \needs 2over include double.fb
5 Onlyforth GEM also definitions
6 1 +load cr .( Eventwords loaded) cr
7 7 +load cr .( Menuwords loaded) cr
8 $0C +load cr .( Objectwords loaded) cr
9 $10 +load cr .( Formwords loaded) cr
10 $14 +load cr .( Graphicswords loaded) cr
11 $19 +load cr .( Fileselect loaded) cr
12 $1C +load cr .( Windowwords loaded) cr
13 $22 +load cr .( RSRCwords loaded) cr
14
15
Screen 2 not modified
0 \ Event Loadscreen 01feb86we
1
2 Onlyforth GEM also definitions
3
4 1 5 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ event_keybd event_button 06aug86we
1
2 : evnt_keybd ( -- key ) &20 0 1 0 AES ;
3
4 : evnt_button ( #clicks0 bmask bstate -- #clicks1 )
5 intin 3 array! &21 3 5 0 AES ;
6
7 \\ #clicks0 is awaitet # of clicks
8 bmask is a button mask
9 bstate is the awaitet state of mouse-button(s)
10 #clicks1 is the actually entered # of clicks
11 bmask + bstate use the convention:
12 lowest bit is leftmost button etc.
13 bit = 0 is button up
14 bit = 1 is button down
15 more return parameters are in intout-array
Screen 4 not modified
0 \ event_mouse event_mesag 02nov86we
1
2 : evnt_mouse ( f leftX topY widht heigth -- )
3 intin 5 array! &22 5 5 0 AES drop ;
4
5 \ f = 0 is return on entry of mouse in rectangle
6 \ f = 1 is return on exit ...
7 \ more parameters are in intout
8
9 Create message $10 allot
10
11 : evnt_mesag ( -- )
12 message >absaddr addrin 2! &23 0 1 1 AES drop ;
13
14 \ see description of messages in AES documentation
15
Screen 5 not modified
0 \ event_timer 06aug86we
1
2 : evnt_timer ( dtime -- )
3 intin 2 array! &24 2 1 0 AES drop ;
4
5 \ dtime is a double number for timer count down in milliseconds
6
7
8
9
10
11
12
13
14
15
Screen 6 not modified
0 \ evnt_multi bp 12oct86
1
2 \ because there are too much parameters:
3
4 Create events
5 %00110011 , \ timer, message, button + keyboard events on
6 2 , 1 , 1 , \ 2 clicks down on left mouse-button
7 here $14 allot $14 erase \ rectangles unspecified
8 0 , 0 , \ 0 millisecond timer-delay
9
10 : prepare events intin $20 cmove
11 message >absaddr addrin 2! ;
12
13 : evnt_multi ( -- which ) &25 &16 7 1 AES ;
14
15
Screen 7 not modified
0 \ evnt_dclick 06aug86we
1
2 : evnt_dclick ( dnew dgetset -- dspeed )
3 intin 2 array! &26 2 1 0 AES ;
4
5
6
7
8
9
10
11
12
13
14
15
Screen 8 not modified
0 \ Menu Loadscreen 12aug86we
1
2 Onlyforth GEM also definitions
3
4 1 4 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 \ objc_tree menuAES bp 12oct86
1
2 | : ?menuerror ( flag -- ) 0= abort" Menu-Error" ;
3
4 | : menuAES ( opcode #intin #intout #addrin -- intout@ )
5 objc_tree 2@ addrin 2! AES ;
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ menu_bar menu_icheck 09aug86we
1
2 : menu_bar ( showflag -- )
3 intin ! &30 1 1 1 menuAES ?menuerror ;
4
5 \ showflag = 0 is menubar off, = 1 is menubar on
6
7
8 : menu_icheck ( item showflag -- )
9 intin 2 array! &31 2 1 1 menuAES ?menuerror ;
10
11 \ item is the menu item
12 \ showflag = 0 is checkmark off, = 1 is checkmark on
13
14
15
Screen 11 not modified
0 \ menu_ienable menu_tnormal 09aug86we
1
2 : menu_ienable ( item enableflag -- )
3 intin 2 array! &32 2 1 1 menuAES ?menuerror ;
4
5 \ item is the menuitem#
6 \ enableflag = 0 is disable item, = 1 is enable item
7
8
9 : menu_tnormal ( title normalflag -- )
10 intin 2 array! &33 2 1 1 menuAES ?menuerror ;
11
12 \ title is the title#
13 \ normalflag = 0 is title reverse, = 1 is title normal
14
15
Screen 12 not modified
0 \ menu_text menu_register 02nov86we
1
2 : menu_text ( item laddr -- )
3 addrin 4+ 2! intin ! &34 1 1 2 menuAES ?menuerror ;
4
5 \ item is the menuitem#
6 \ laddr is the address of a 0-terminated replace-string
7
8
9 : menu_register ( apid laddr -- menuid )
10 addrin 2! intin ! &35 1 1 1 AES dup 0< not ?menuerror ;
11
12 \ apid is the application-ID from ACC's applinit
13 \ laddr is the address of a 0-terminated string for menutext
14 \ menuid is ACC's menu-identifier (0-5)
15
Screen 13 not modified
0 \ Object Loadscreen 01feb86we
1
2 Onlyforth GEM also definitions
3
4 1 3 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 14 not modified
0 \ objc_tree objcAES objc_add objc_delete 06aug86we
1
2 | : ?objcerror ( flag -- ) 0= abort" Object-Error" ;
3
4 | : objcAES ( opcode #intin #intout #addrin -- intout@ )
5 objc_tree 2@ addrin 2! 1 AES ;
6
7 : objc_add ( parent child -- )
8 intin 2 array! &40 2 1 objcAES ?objcerror ;
9
10 : objc_delete ( object -- )
11 intin ! &41 1 1 objcAES ?objcerror ;
12
13
14
15
Screen 15 not modified
0 \ objc_draw objc_find objc_offset bp 12oct86
1
2 : objc_draw ( startob depth x y width height -- )
3 intin 6 array! &42 6 1 objcAES ?objcerror ;
4
5 : objc_find ( startob depth x y -- obnum )
6 intin 4 array! &43 4 1 objcAES ;
7
8 : objc_offset ( object -- x y )
9 intin ! &44 1 3 objcAES ?objcerror
10 intout 2+ @ intout 4+ @ ;
11
12
13
14
15
Screen 16 not modified
0 \ objc_order objc_edit objc_change 02feb86we
1
2 : objc_order ( object newpos -- )
3 intin 2 array! &45 2 1 objcAES ?objcerror ;
4
5 : objc_edit ( object char index kind -- newindex )
6 intin 4 array! &46 4 2 objcAES ?objcerror intout 2+ @ ;
7
8 : objc_change ( object x y width height newstate redraw -- )
9 intin 4+ 6 array! intin ! intin 2+ off
10 &47 8 1 objcAES ?objcerror ;
11
12
13
14
15
Screen 17 not modified
0 \ Object Loadscreen 09aug86we
1
2 Onlyforth GEM also definitions
3 1 2 +thru
4
5
6
7
8
9
10
11
12
13
14
15
Screen 18 not modified
0 \ form_do form_dial bp 12oct86
1
2 : form_do ( startobj -- objectno )
3 intin ! objc_tree 2@ addrin 2! &50 1 1 1 AES ;
4
5 : form_dial ( diflag lix liy liw lih bix biy biw bih )
6 intin 9 array! &51 9 1 0 AES drop ;
7 \ li means little bi means big
8
9
10
11
12
13
14
15
Screen 19 not modified
0 \ form_alert form_error form_center 07a09sep86we
1
2 : form_alert ( defbttn 0string -- exbttn )
3 >absaddr addrin 2! intin ! &52 1 1 1 AES ;
4
5 : form_error ( enum -- exbttn )
6 intin ! &53 1 1 0 AES ;
7
8 : form_center ( -- x y width height )
9 objc_tree 2@ addrin 2! &54 0 5 1 AES drop intout 2+ 4@ ;
10
11
12
13
14
15
Screen 20 not modified
0 \ form_alert tests bp 12oct86
1
2 : test ( -- button )
3 2 0" [1][Dies ist ein Test!|2.Zeile][OK|JA|NEIN]"
4 form_alert ;
5
6
7
8
9
10
11
12
13
14
15
Screen 21 not modified
0 \ Graphics Loadscreen 02feb86we
1
2 Onlyforth GEM also definitions
3
4 1 4 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 22 not modified
0 \ graf_dragbox graf_movebox 06aug86we
1
2 | : ?graferror ( flag -- ) 0= abort" Graphic-Error" ;
3
4 : graf_dragbox
5 ( startx starty width height boundx boundy boundw boundh --
6 finishx finishy )
7 intin 8 + 4 array! intin 2 array! intin 4+ 2 array!
8 &71 8 3 0 AES ?graferror intout 2+ @ intout 4+ @ ;
9
10 : graf_movebox
11 ( sourcex sourcey width height destx desty -- )
12 intin 8 + 2 array! intin 2 array! intin 4+ 2 array!
13 &72 6 1 0 AES ?graferror ;
14
15
Screen 23 not modified
0 \ graf_growbox graf_shrinkbox 06aug86we
1
2 : graf_growbox ( stx sty stw sth fix fiy fiw fih -- )
3 intin 8 array! &73 8 1 0 AES ?graferror ;
4
5 : graf_shrinkbox ( fix fiy fiw fih stx sty stw sth -- )
6 intin 8 array! &74 8 1 0 AES ?graferror ;
7
8 \ st means start fi means finish
9
10
11
12
13
14
15
Screen 24 not modified
0 \ graf_watchbox graf_slidebox bp 12oct86
1
2 : graf_watchbox ( object instate outstate -- inside/outside )
3 objc_tree 2@ addrin 2! intin 2+ 3 array!
4 &75 4 1 1 AES ;
5
6 : graf_slidebox ( parent object vhflag -- vhpos )
7 objc_tree 2@ addrin 2! intin 3 array!
8 &76 3 1 1 AES ;
9
10
11 \\ graf_handle is defined in BASICS.SCR !
12
13
14
15
Screen 25 not modified
0 \ graf_mouse graf_mkstate bp 12oct86
1
2 2Variable mofaddr 0. mofaddr 2!
3
4 : graf_mouse ( mouseform -- )
5 intin ! mofaddr 2@ addrin 2! &78 1 1 1 AES ?graferror ;
6
7 : graf_mkstate ( -- ) &79 0 5 0 AES drop ;
8
9 \ Werte in intout
10
11
12
13
14
15
Screen 26 not modified
0 \ File Selection Loadscreen bp 11oct86
1
2 Onlyforth
3 GEM also definitions
4
5 1 +load
6
7 \\
8
9 : test ( -- button )
10 show_c inpath &30 erase name count inpath place
11 insel $10 erase name count insel place
12 fs_label &30 erase name count fs_label place
13 fsel_exinput hide_c ;
14
15 test A:\GEM\*.SCR AES.SCR Dies_ist_eine_Textbox!
Screen 27 not modified
0 \ File Selection bp 11oct86
1
2 Create inpath ," \*.SCR" here &30 allot &30 erase
3 Create insel here $10 allot $10 erase
4
5 | : count? ( addr -- )
6 dup 1+ BEGIN count 0= UNTIL over - 2- swap c! ;
7
8 : fsel_input ( -- button )
9 inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2!
10 &90 0 2 2 AES 0= abort" File Error"
11 inpath count? insel count? intout 2+ @ ;
12 -->
13 \\ button = 0 is ABBRUCH, = 1 is OK; the returned strings
14 are in inpath and insel (counted and 0-terminated)
15
Screen 28 not modified
0 \ File selection mit FSEL_EXINPUT 13jan90 m.bitter
1
2 Create fs_label ," May the volks4TH be with you!" 0 c,
3
4 : fsel_exinput ( -- button )
5 inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2!
6 fs_label 1+ >absaddr addrin 8 + 2!
7 &91 0 2 3 AES 0= abort" File Error"
8 inpath count? insel count? intout 2+ @ ;
9
10
11
12
13 \\ button = 0 is ABBRUCH, = 1 is OK; the returned strings
14 are in inpath and insel (counted and 0-terminated)
15
Screen 29 not modified
0 \ Windows Loadscreen 28jan86we
1
2 Onlyforth GEM also definitions
3
4 1 4 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 30 not modified
0 \ windows 21aug86we
1
2 | : ?winderror ( flag -- ) 0= abort" Window-Error" ;
3
4 : wind_create
5 ( components leftX topY maxWidth maxHeight -- handle )
6 intin 5 array! &100 5 1 0 AES dup 0> ?winderror ;
7
8 \\ component bits set mean:
9
10 $0001 title bar $0002 close box
11 $0004 full box $0008 move bar
12 $0010 info line $0020 size box
13 $0040 up arrow $0080 down arrow
14 $0100 vertical slider $0200 left arrow
15 $0400 right arrow $0800 horizontal slider
Screen 31 not modified
0 \ windows 06aug86we
1
2 : wind_open ( W-handle leftX topY width heigth -- )
3 intin 5 array! &101 5 1 0 AES ?winderror ;
4
5
6
7
8
9
10
11
12
13
14
15
Screen 32 not modified
0 \ windows 06aug86we
1
2 : wind_close ( Whandle -- )
3 intin ! &102 1 1 0 AES ?winderror ;
4
5 : wind_delete ( Whandle -- )
6 intin ! &103 1 1 0 AES ?winderror ;
7
8 : wind_get ( Whandle funktion# -- )
9 intin 2 array! &104 2 5 0 AES ?winderror ;
10
11 : wind_set ( Whandle funktion# par0 par1 par2 par3 -- )
12 intin 6 array! &105 6 1 0 AES ?winderror ;
13
14 : wind_find ( mouseX mouseY -- Whandle )
15 intin 2 array! &106 2 1 0 AES ;
Screen 33 not modified
0 \ windows 06aug86we
1
2 : wind_update ( funktion# -- )
3 intin ! &107 1 1 0 AES ?winderror ;
4
5 : wind_calc ( 0/1 components leftX topY width heigth -- )
6 intin 6 array! &108 6 5 0 AES ?winderror ;
7
8
9
10
11
12
13
14
15
Screen 34 not modified
0 \ window test 02feb86we
1
2 $0FEF &0 &20 &600 &300 wind_create Constant wtesthandle
3
4 : windowtest page
5 wtesthandle 1 &20 &500 &300 wind_open
6 $20 0 DO wtesthandle 5 1 &20 &500 I - &300 I - wind_set
7 2 +LOOP
8 ." Hit any key to continue " key drop
9 wtesthandle wind_close ;
10
11 : end wtesthandle wind_delete ;
12
13
14
15
Screen 35 not modified
0 \ RSRC Loadscreen 21nov86we
1
2 Onlyforth GEM also definitions
3
4 \needs 0" include strings.scr
5
6
7 1 4 +thru
8
9
10
11
12
13
14
15
Screen 36 not modified
0 \ RSRC words bp 12oct86
1
2 | : ?rsrcerror ( f -- ) 0= abort" Resource-Error" ;
3
4 : rsrc_load ( 0$ -- ) \ needs address of 0-terminated $
5 >absaddr addrin 2! &110 0 1 1 AES ?rsrcerror ;
6
7 : rsrc_load" [compile] 0" compile rsrc_load ;
8 immediate restrict
9
10
11
12
13
14
15
Screen 37 not modified
0 \ rsrc_gaddr 20aug86mawe
1
2 : rsrc_free ( -- ) &111 0 1 0 AES ?rsrcerror ;
3
4 : rsrc_gaddr ( type index -- laddr )
5 intin 2 array! &112 2 1 0 AES ?rsrcerror addrout 2@ ;
6
7 \\ type is one of the following:
8 0 tree 1 object 2 tedinfo 3 iconblk
9 4 bitblk 5 string 6 imagedata 7 obspec
10 8 te_ptext 9 te_ptmplt $A te_pvalid $B ib_pmask
11 $C ib_pdata $D ib_ptext $E bi_pdata $F ad_frstr
12 $10 ad_frimg
13 index is the index of the data structure
14 laddr is the long (double) address of the data structure
15 specified by type and index
Screen 38 not modified
0 \ rsrc_saddr 06aug86we
1
2 : rsrc_saddr ( type index laddr --)
3 addrin 2! intin 2 array! &113 2 1 1 AES ?rsrcerror ;
4
5 \\ for type index and f see rsrc_gaddr
6 laddr is the address of a data structure
7
8
9
10
11
12
13
14
15
Screen 39 not modified
0 \ rsrc_obfix 06aug86we
1
2 : rsrc_obfix ( index laddr --)
3 addrin 2! intin ! &114 1 1 1 AES drop ;
4
5 \ index is index of object
6 \ laddr is addr of tree that contains object
7
8
9
10
11
12
13
14
15

680
sources/AtariST/GEM/AES.fth Normal file
View File

@ -0,0 +1,680 @@
\ *** Block No. 0 Hexblock 0
\\ *** AES -Funktionen *** 26may86we
Dieses File enth„lt alle AES-Funktionen.
Zur genauren Beschreibung verweisen wir auf die Dokumentation
von Digital Research.
\ *** Block No. 1 Hexblock 1
\ AES Loadscreen cas20130105
\needs GEM include gem\basics.fb
Onlyforth
\needs 2over include double.fb
Onlyforth GEM also definitions
1 +load cr .( Eventwords loaded) cr
7 +load cr .( Menuwords loaded) cr
$0C +load cr .( Objectwords loaded) cr
$10 +load cr .( Formwords loaded) cr
$14 +load cr .( Graphicswords loaded) cr
$19 +load cr .( Fileselect loaded) cr
$1C +load cr .( Windowwords loaded) cr
$22 +load cr .( RSRCwords loaded) cr
\ *** Block No. 2 Hexblock 2
\ Event Loadscreen 01feb86we
Onlyforth GEM also definitions
1 5 +thru
\ *** Block No. 3 Hexblock 3
\ event_keybd event_button 06aug86we
: evnt_keybd ( -- key ) &20 0 1 0 AES ;
: evnt_button ( #clicks0 bmask bstate -- #clicks1 )
intin 3 array! &21 3 5 0 AES ;
\\ #clicks0 is awaitet # of clicks
bmask is a button mask
bstate is the awaitet state of mouse-button(s)
#clicks1 is the actually entered # of clicks
bmask + bstate use the convention:
lowest bit is leftmost button etc.
bit = 0 is button up
bit = 1 is button down
more return parameters are in intout-array
\ *** Block No. 4 Hexblock 4
\ event_mouse event_mesag 02nov86we
: evnt_mouse ( f leftX topY widht heigth -- )
intin 5 array! &22 5 5 0 AES drop ;
\ f = 0 is return on entry of mouse in rectangle
\ f = 1 is return on exit ...
\ more parameters are in intout
Create message $10 allot
: evnt_mesag ( -- )
message >absaddr addrin 2! &23 0 1 1 AES drop ;
\ see description of messages in AES documentation
\ *** Block No. 5 Hexblock 5
\ event_timer 06aug86we
: evnt_timer ( dtime -- )
intin 2 array! &24 2 1 0 AES drop ;
\ dtime is a double number for timer count down in milliseconds
\ *** Block No. 6 Hexblock 6
\ evnt_multi bp 12oct86
\ because there are too much parameters:
Create events
%00110011 , \ timer, message, button + keyboard events on
2 , 1 , 1 , \ 2 clicks down on left mouse-button
here $14 allot $14 erase \ rectangles unspecified
0 , 0 , \ 0 millisecond timer-delay
: prepare events intin $20 cmove
message >absaddr addrin 2! ;
: evnt_multi ( -- which ) &25 &16 7 1 AES ;
\ *** Block No. 7 Hexblock 7
\ evnt_dclick 06aug86we
: evnt_dclick ( dnew dgetset -- dspeed )
intin 2 array! &26 2 1 0 AES ;
\ *** Block No. 8 Hexblock 8
\ Menu Loadscreen 12aug86we
Onlyforth GEM also definitions
1 4 +thru
\ *** Block No. 9 Hexblock 9
\ objc_tree menuAES bp 12oct86
| : ?menuerror ( flag -- ) 0= abort" Menu-Error" ;
| : menuAES ( opcode #intin #intout #addrin -- intout@ )
objc_tree 2@ addrin 2! AES ;
\ *** Block No. 10 Hexblock A
\ menu_bar menu_icheck 09aug86we
: menu_bar ( showflag -- )
intin ! &30 1 1 1 menuAES ?menuerror ;
\ showflag = 0 is menubar off, = 1 is menubar on
: menu_icheck ( item showflag -- )
intin 2 array! &31 2 1 1 menuAES ?menuerror ;
\ item is the menu item
\ showflag = 0 is checkmark off, = 1 is checkmark on
\ *** Block No. 11 Hexblock B
\ menu_ienable menu_tnormal 09aug86we
: menu_ienable ( item enableflag -- )
intin 2 array! &32 2 1 1 menuAES ?menuerror ;
\ item is the menuitem#
\ enableflag = 0 is disable item, = 1 is enable item
: menu_tnormal ( title normalflag -- )
intin 2 array! &33 2 1 1 menuAES ?menuerror ;
\ title is the title#
\ normalflag = 0 is title reverse, = 1 is title normal
\ *** Block No. 12 Hexblock C
\ menu_text menu_register 02nov86we
: menu_text ( item laddr -- )
addrin 4+ 2! intin ! &34 1 1 2 menuAES ?menuerror ;
\ item is the menuitem#
\ laddr is the address of a 0-terminated replace-string
: menu_register ( apid laddr -- menuid )
addrin 2! intin ! &35 1 1 1 AES dup 0< not ?menuerror ;
\ apid is the application-ID from ACC's applinit
\ laddr is the address of a 0-terminated string for menutext
\ menuid is ACC's menu-identifier (0-5)
\ *** Block No. 13 Hexblock D
\ Object Loadscreen 01feb86we
Onlyforth GEM also definitions
1 3 +thru
\ *** Block No. 14 Hexblock E
\ objc_tree objcAES objc_add objc_delete 06aug86we
| : ?objcerror ( flag -- ) 0= abort" Object-Error" ;
| : objcAES ( opcode #intin #intout #addrin -- intout@ )
objc_tree 2@ addrin 2! 1 AES ;
: objc_add ( parent child -- )
intin 2 array! &40 2 1 objcAES ?objcerror ;
: objc_delete ( object -- )
intin ! &41 1 1 objcAES ?objcerror ;
\ *** Block No. 15 Hexblock F
\ objc_draw objc_find objc_offset bp 12oct86
: objc_draw ( startob depth x y width height -- )
intin 6 array! &42 6 1 objcAES ?objcerror ;
: objc_find ( startob depth x y -- obnum )
intin 4 array! &43 4 1 objcAES ;
: objc_offset ( object -- x y )
intin ! &44 1 3 objcAES ?objcerror
intout 2+ @ intout 4+ @ ;
\ *** Block No. 16 Hexblock 10
\ objc_order objc_edit objc_change 02feb86we
: objc_order ( object newpos -- )
intin 2 array! &45 2 1 objcAES ?objcerror ;
: objc_edit ( object char index kind -- newindex )
intin 4 array! &46 4 2 objcAES ?objcerror intout 2+ @ ;
: objc_change ( object x y width height newstate redraw -- )
intin 4+ 6 array! intin ! intin 2+ off
&47 8 1 objcAES ?objcerror ;
\ *** Block No. 17 Hexblock 11
\ Object Loadscreen 09aug86we
Onlyforth GEM also definitions
1 2 +thru
\ *** Block No. 18 Hexblock 12
\ form_do form_dial bp 12oct86
: form_do ( startobj -- objectno )
intin ! objc_tree 2@ addrin 2! &50 1 1 1 AES ;
: form_dial ( diflag lix liy liw lih bix biy biw bih )
intin 9 array! &51 9 1 0 AES drop ;
\ li means little bi means big
\ *** Block No. 19 Hexblock 13
\ form_alert form_error form_center 07a09sep86we
: form_alert ( defbttn 0string -- exbttn )
>absaddr addrin 2! intin ! &52 1 1 1 AES ;
: form_error ( enum -- exbttn )
intin ! &53 1 1 0 AES ;
: form_center ( -- x y width height )
objc_tree 2@ addrin 2! &54 0 5 1 AES drop intout 2+ 4@ ;
\ *** Block No. 20 Hexblock 14
\ form_alert tests bp 12oct86
: test ( -- button )
2 0" [1][Dies ist ein Test!|2.Zeile][OK|JA|NEIN]"
form_alert ;
\ *** Block No. 21 Hexblock 15
\ Graphics Loadscreen 02feb86we
Onlyforth GEM also definitions
1 4 +thru
\ *** Block No. 22 Hexblock 16
\ graf_dragbox graf_movebox 06aug86we
| : ?graferror ( flag -- ) 0= abort" Graphic-Error" ;
: graf_dragbox
( startx starty width height boundx boundy boundw boundh --
finishx finishy )
intin 8 + 4 array! intin 2 array! intin 4+ 2 array!
&71 8 3 0 AES ?graferror intout 2+ @ intout 4+ @ ;
: graf_movebox
( sourcex sourcey width height destx desty -- )
intin 8 + 2 array! intin 2 array! intin 4+ 2 array!
&72 6 1 0 AES ?graferror ;
\ *** Block No. 23 Hexblock 17
\ graf_growbox graf_shrinkbox 06aug86we
: graf_growbox ( stx sty stw sth fix fiy fiw fih -- )
intin 8 array! &73 8 1 0 AES ?graferror ;
: graf_shrinkbox ( fix fiy fiw fih stx sty stw sth -- )
intin 8 array! &74 8 1 0 AES ?graferror ;
\ st means start fi means finish
\ *** Block No. 24 Hexblock 18
\ graf_watchbox graf_slidebox bp 12oct86
: graf_watchbox ( object instate outstate -- inside/outside )
objc_tree 2@ addrin 2! intin 2+ 3 array!
&75 4 1 1 AES ;
: graf_slidebox ( parent object vhflag -- vhpos )
objc_tree 2@ addrin 2! intin 3 array!
&76 3 1 1 AES ;
\\ graf_handle is defined in BASICS.SCR !
\ *** Block No. 25 Hexblock 19
\ graf_mouse graf_mkstate bp 12oct86
2Variable mofaddr 0. mofaddr 2!
: graf_mouse ( mouseform -- )
intin ! mofaddr 2@ addrin 2! &78 1 1 1 AES ?graferror ;
: graf_mkstate ( -- ) &79 0 5 0 AES drop ;
\ Werte in intout
\ *** Block No. 26 Hexblock 1A
\ File Selection Loadscreen bp 11oct86
Onlyforth
GEM also definitions
1 +load
\\
: test ( -- button )
show_c inpath &30 erase name count inpath place
insel $10 erase name count insel place
fs_label &30 erase name count fs_label place
fsel_exinput hide_c ;
test A:\GEM\*.SCR AES.SCR Dies_ist_eine_Textbox!
\ *** Block No. 27 Hexblock 1B
\ File Selection bp 11oct86
Create inpath ," \*.SCR" here &30 allot &30 erase
Create insel here $10 allot $10 erase
| : count? ( addr -- )
dup 1+ BEGIN count 0= UNTIL over - 2- swap c! ;
: fsel_input ( -- button )
inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2!
&90 0 2 2 AES 0= abort" File Error"
inpath count? insel count? intout 2+ @ ;
-->
\\ button = 0 is ABBRUCH, = 1 is OK; the returned strings
are in inpath and insel (counted and 0-terminated)
\ *** Block No. 28 Hexblock 1C
\ File selection mit FSEL_EXINPUT 13jan90 m.bitter
Create fs_label ," May the volks4TH be with you!" 0 c,
: fsel_exinput ( -- button )
inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2!
fs_label 1+ >absaddr addrin 8 + 2!
&91 0 2 3 AES 0= abort" File Error"
inpath count? insel count? intout 2+ @ ;
\\ button = 0 is ABBRUCH, = 1 is OK; the returned strings
are in inpath and insel (counted and 0-terminated)
\ *** Block No. 29 Hexblock 1D
\ Windows Loadscreen 28jan86we
Onlyforth GEM also definitions
1 4 +thru
\ *** Block No. 30 Hexblock 1E
\ windows 21aug86we
| : ?winderror ( flag -- ) 0= abort" Window-Error" ;
: wind_create
( components leftX topY maxWidth maxHeight -- handle )
intin 5 array! &100 5 1 0 AES dup 0> ?winderror ;
\\ component bits set mean:
$0001 title bar $0002 close box
$0004 full box $0008 move bar
$0010 info line $0020 size box
$0040 up arrow $0080 down arrow
$0100 vertical slider $0200 left arrow
$0400 right arrow $0800 horizontal slider
\ *** Block No. 31 Hexblock 1F
\ windows 06aug86we
: wind_open ( W-handle leftX topY width heigth -- )
intin 5 array! &101 5 1 0 AES ?winderror ;
\ *** Block No. 32 Hexblock 20
\ windows 06aug86we
: wind_close ( Whandle -- )
intin ! &102 1 1 0 AES ?winderror ;
: wind_delete ( Whandle -- )
intin ! &103 1 1 0 AES ?winderror ;
: wind_get ( Whandle funktion# -- )
intin 2 array! &104 2 5 0 AES ?winderror ;
: wind_set ( Whandle funktion# par0 par1 par2 par3 -- )
intin 6 array! &105 6 1 0 AES ?winderror ;
: wind_find ( mouseX mouseY -- Whandle )
intin 2 array! &106 2 1 0 AES ;
\ *** Block No. 33 Hexblock 21
\ windows 06aug86we
: wind_update ( funktion# -- )
intin ! &107 1 1 0 AES ?winderror ;
: wind_calc ( 0/1 components leftX topY width heigth -- )
intin 6 array! &108 6 5 0 AES ?winderror ;
\ *** Block No. 34 Hexblock 22
\ window test 02feb86we
$0FEF &0 &20 &600 &300 wind_create Constant wtesthandle
: windowtest page
wtesthandle 1 &20 &500 &300 wind_open
$20 0 DO wtesthandle 5 1 &20 &500 I - &300 I - wind_set
2 +LOOP
." Hit any key to continue " key drop
wtesthandle wind_close ;
: end wtesthandle wind_delete ;
\ *** Block No. 35 Hexblock 23
\ RSRC Loadscreen 21nov86we
Onlyforth GEM also definitions
\needs 0" include strings.scr
1 4 +thru
\ *** Block No. 36 Hexblock 24
\ RSRC words bp 12oct86
| : ?rsrcerror ( f -- ) 0= abort" Resource-Error" ;
: rsrc_load ( 0$ -- ) \ needs address of 0-terminated $
>absaddr addrin 2! &110 0 1 1 AES ?rsrcerror ;
: rsrc_load" [compile] 0" compile rsrc_load ;
immediate restrict
\ *** Block No. 37 Hexblock 25
\ rsrc_gaddr 20aug86mawe
: rsrc_free ( -- ) &111 0 1 0 AES ?rsrcerror ;
: rsrc_gaddr ( type index -- laddr )
intin 2 array! &112 2 1 0 AES ?rsrcerror addrout 2@ ;
\\ type is one of the following:
0 tree 1 object 2 tedinfo 3 iconblk
4 bitblk 5 string 6 imagedata 7 obspec
8 te_ptext 9 te_ptmplt $A te_pvalid $B ib_pmask
$C ib_pdata $D ib_ptext $E bi_pdata $F ad_frstr
$10 ad_frimg
index is the index of the data structure
laddr is the long (double) address of the data structure
specified by type and index
\ *** Block No. 38 Hexblock 26
\ rsrc_saddr 06aug86we
: rsrc_saddr ( type index laddr --)
addrin 2! intin 2 array! &113 2 1 1 AES ?rsrcerror ;
\\ for type index and f see rsrc_gaddr
laddr is the address of a data structure
\ *** Block No. 39 Hexblock 27
\ rsrc_obfix 06aug86we
: rsrc_obfix ( index laddr --)
addrin 2! intin ! &114 1 1 1 AES drop ;
\ index is index of object
\ laddr is addr of tree that contains object

170
sources/AtariST/GEM/BASICS.FB.src
View File

@ -1,170 +0,0 @@
Screen 0 not modified
0 \\ *** GEM - Basics *** 26may86we
1
2 Die Routinen in dieser Library entsprechen dem, was auch dem
3 Pascal-, C- oder Modula-Programmierer zur Verf<72>gung steht.
4 F<>r eine genaue Beschreibung der einzelnen Routinen verweisen
5 wir auf die GEM-Dokumentation des ST-Entwicklungspaketes bzw.
6 entsprechende Literatur.
7
8 Aus diesem Grunde wurden die - teilweise kryptischen - Namen
9 von Digital Research beibehalten; auch die šbergabeparameter
10 der einzelnen Funktionen sind unver„ndert geblieben.
11 Der Aufbau einer FORTH-Library mit 'Super-Befehlen' ist in
12 Arbeit.
13
14 Die Worte in diesem File werden sowohl f<>r VDI- als auch f<>r
15 AES-Funktionen ben”tigt.
Screen 1 not modified
0 \ VDI GEM Arrays and Controls Loadscreen 02nov86we
1
2 Onlyforth
3
4 \needs >absaddr : >absaddr 0 forthstart d+ ;
5 \needs Code 2 loadfrom assemble.scr
6
7 Vocabulary GEM GEM definitions also
8
9 1 8 +thru
10
11
12
13
14
15
Screen 2 not modified
0 \ VDI GEM Arrays 05aug86we
1
2 Create intin &60 allot Create ptsin &256 allot
3 Create intout &90 allot Create ptsout &24 allot
4 Create addrin 8 allot Create addrout 4 allot
5 Variable grhandle
6
7 | : gemconstant ( addr n -- addr+n) over Constant + ;
8
9 Create contrl $16 allot
10 contrl 2 gemconstant opcode
11 2 gemconstant #intin
12 2 gemconstant #intout ' #intout Alias #ptsout
13 2 gemconstant #addrin
14 2 gemconstant #addrout
15 2 gemconstant function drop
Screen 3 not modified
0 \ global array, Parameter blocks 02nov86we
1
2 Create global $20 allot
3 global &10 + Constant ap_ptree
4
5 | : gemarray ( n0 ... nk-1 k --) Create 0 ?DO , LOOP ;
6
7 addrout addrin intout intin global contrl 6 gemarray (AESpb
8 ptsout intout ptsin intin contrl 5 gemarray (VDIpb
9
10 Create AESpb &24 allot Create VDIpb &20 allot
11
12 : setarrays
13 6 0 DO (AESpb I 2* + @ >absaddr AESpb I 2* 2* + 2! LOOP
14 5 0 DO (VDIpb I 2* + @ >absaddr VDIpb I 2* 2* + 2! LOOP ;
15
Screen 4 not modified
0 \ Array-Handling 09sep86we
1
2 Code array! ( n0 ... nk-1 adr k --)
3 SP )+ D0 move SP )+ D6 move D6 reg) A0 lea
4 D0 A0 adda D0 A0 adda 1 D0 subq
5 D0 DO SP )+ A0 -) move LOOP Next end-code
6
7 Code 4! ( n1 .. n4 addr -- )
8 SP )+ D6 move 8 D6 addq D6 reg) A0 lea 3 # D0 move
9 D0 DO SP )+ A0 -) move LOOP Next end-code
10
11 Code 4@ ( addr -- n1 .. n4 )
12 SP )+ D6 move D6 reg) A0 lea 3 # D0 move
13 D0 DO A0 )+ SP -) move LOOP Next end-code
14
15
Screen 5 not modified
0 \ AES-Aufruf 09sep86we
1
2 Code AES ( opcode #intin #intout #addrin -- intout@ )
3 SP )+ contrl 6 + R#) move \ #addrin
4 SP )+ contrl 4 + R#) move \ #intout
5 SP )+ contrl 2+ R#) move \ #intin
6 SP ) D0 move SP )+ contrl R#) move \ opcode
7 contrl 8 + R#) clr \ #addrout
8 &112 D0 cmpi \ Funktions-Nr. von rsrc_gaddr
9 0= IF 1 # contrl 8 + R#) move THEN
10 AESpb # D6 move D6 reg) A0 lea A0 D1 lmove
11 .w $C8 # D0 move 2 trap
12 intout R#) SP -) move Next end-code
13
14
15
Screen 6 not modified
0 \ VDI-Aufruf 09sep86we
1
2 Code VDI ( opcode #ptsin #intin --)
3 SP )+ contrl 6 + R#) move
4 SP )+ contrl 2+ R#) move SP )+ contrl R#) move
5 grhandle R#) contrl &12 + R#) move
6 VDIpb # D6 move D6 reg) A0 lea A0 D1 lmove
7 $73 D0 moveq 2 trap
8 Next end-code
9
10
11
12
13
14
15
Screen 7 not modified
0 \ appl_init appl_exit graf_handle bp 12oct86
1
2 : appl_init global &14 + $10 erase &10 0 1 0 AES drop ;
3 : appl_exit &19 0 1 0 AES drop ;
4
5
6 | : sizeconstant ( addr n -- addr+n@ )
7 over Create , + Does> @ @ ;
8
9 Create sizes 8 allot $08 $10 $13 $13 sizes 4!
10 sizes 2 sizeconstant cwidth 2 sizeconstant cheight
11 2 sizeconstant bwidth 2 sizeconstant bheight drop
12
13 : graf_handle &77 0 5 0 AES grhandle !
14 intout 2+ sizes 8 cmove ;
15
Screen 8 not modified
0 \ opnvwk clrwk clsvwk updwk 02nov86we
1
2 : opnvwk
3 intin &10 0 DO 1 over I 2* + ! LOOP drop
4 2 intin &20 + ! &100 0 &11 VDI
5 contrl &12 + @ grhandle ! ;
6
7 : clrwk 3 0 0 VDI ;
8 : clsvwk &101 0 0 VDI ;
9
10 : updwk 4 0 0 VDI ;
11
12
13
14
15
Screen 9 not modified
0 \ s_clip grinit grexit show_c hide_c 02nov86we
1
2 : s_clip ( x1 y1 x2 y2 clipflag -- )
3 intin ! ptsin 4 array! &129 2 1 VDI ;
4
5 : grinit setarrays appl_init graf_handle opnvwk ;
6 : grexit clsvwk appl_exit ;
7
8 2Variable objc_tree 0. objc_tree 2!
9
10 Variable c_flag c_flag off
11 : show_c ( -- ) c_flag @ intin ! &122 0 1 VDI ;
12 : hide_c ( -- ) &123 0 0 VDI ;
13
14 \\ st_load_fonts st_unload_fonts
15 w„r auch ganz h<>bsch, hamse aber nich!

170
sources/AtariST/GEM/BASICS.fth Normal file
View File

@ -0,0 +1,170 @@
\ *** Block No. 0 Hexblock 0
\\ *** GEM - Basics *** 26may86we
Die Routinen in dieser Library entsprechen dem, was auch dem
Pascal-, C- oder Modula-Programmierer zur Verf<EFBFBD>gung steht.
F<EFBFBD>r eine genaue Beschreibung der einzelnen Routinen verweisen
wir auf die GEM-Dokumentation des ST-Entwicklungspaketes bzw.
entsprechende Literatur.
Aus diesem Grunde wurden die - teilweise kryptischen - Namen
von Digital Research beibehalten; auch die šbergabeparameter
der einzelnen Funktionen sind unver„ndert geblieben.
Der Aufbau einer FORTH-Library mit 'Super-Befehlen' ist in
Arbeit.
Die Worte in diesem File werden sowohl f<EFBFBD>r VDI- als auch f<EFBFBD>r
AES-Funktionen ben”tigt.
\ *** Block No. 1 Hexblock 1
\ VDI GEM Arrays and Controls Loadscreen 02nov86we
Onlyforth
\needs >absaddr : >absaddr 0 forthstart d+ ;
\needs Code 2 loadfrom assemble.scr
Vocabulary GEM GEM definitions also
1 8 +thru
\ *** Block No. 2 Hexblock 2
\ VDI GEM Arrays 05aug86we
Create intin &60 allot Create ptsin &256 allot
Create intout &90 allot Create ptsout &24 allot
Create addrin 8 allot Create addrout 4 allot
Variable grhandle
| : gemconstant ( addr n -- addr+n) over Constant + ;
Create contrl $16 allot
contrl 2 gemconstant opcode
2 gemconstant #intin
2 gemconstant #intout ' #intout Alias #ptsout
2 gemconstant #addrin
2 gemconstant #addrout
2 gemconstant function drop
\ *** Block No. 3 Hexblock 3
\ global array, Parameter blocks 02nov86we
Create global $20 allot
global &10 + Constant ap_ptree
| : gemarray ( n0 ... nk-1 k --) Create 0 ?DO , LOOP ;
addrout addrin intout intin global contrl 6 gemarray (AESpb
ptsout intout ptsin intin contrl 5 gemarray (VDIpb
Create AESpb &24 allot Create VDIpb &20 allot
: setarrays
6 0 DO (AESpb I 2* + @ >absaddr AESpb I 2* 2* + 2! LOOP
5 0 DO (VDIpb I 2* + @ >absaddr VDIpb I 2* 2* + 2! LOOP ;
\ *** Block No. 4 Hexblock 4
\ Array-Handling 09sep86we
Code array! ( n0 ... nk-1 adr k --)
SP )+ D0 move SP )+ D6 move D6 reg) A0 lea
D0 A0 adda D0 A0 adda 1 D0 subq
D0 DO SP )+ A0 -) move LOOP Next end-code
Code 4! ( n1 .. n4 addr -- )
SP )+ D6 move 8 D6 addq D6 reg) A0 lea 3 # D0 move
D0 DO SP )+ A0 -) move LOOP Next end-code
Code 4@ ( addr -- n1 .. n4 )
SP )+ D6 move D6 reg) A0 lea 3 # D0 move
D0 DO A0 )+ SP -) move LOOP Next end-code
\ *** Block No. 5 Hexblock 5
\ AES-Aufruf 09sep86we
Code AES ( opcode #intin #intout #addrin -- intout@ )
SP )+ contrl 6 + R#) move \ #addrin
SP )+ contrl 4 + R#) move \ #intout
SP )+ contrl 2+ R#) move \ #intin
SP ) D0 move SP )+ contrl R#) move \ opcode
contrl 8 + R#) clr \ #addrout
&112 D0 cmpi \ Funktions-Nr. von rsrc_gaddr
0= IF 1 # contrl 8 + R#) move THEN
AESpb # D6 move D6 reg) A0 lea A0 D1 lmove
.w $C8 # D0 move 2 trap
intout R#) SP -) move Next end-code
\ *** Block No. 6 Hexblock 6
\ VDI-Aufruf 09sep86we
Code VDI ( opcode #ptsin #intin --)
SP )+ contrl 6 + R#) move
SP )+ contrl 2+ R#) move SP )+ contrl R#) move
grhandle R#) contrl &12 + R#) move
VDIpb # D6 move D6 reg) A0 lea A0 D1 lmove
$73 D0 moveq 2 trap
Next end-code
\ *** Block No. 7 Hexblock 7
\ appl_init appl_exit graf_handle bp 12oct86
: appl_init global &14 + $10 erase &10 0 1 0 AES drop ;
: appl_exit &19 0 1 0 AES drop ;
| : sizeconstant ( addr n -- addr+n@ )
over Create , + Does> @ @ ;
Create sizes 8 allot $08 $10 $13 $13 sizes 4!
sizes 2 sizeconstant cwidth 2 sizeconstant cheight
2 sizeconstant bwidth 2 sizeconstant bheight drop
: graf_handle &77 0 5 0 AES grhandle !
intout 2+ sizes 8 cmove ;
\ *** Block No. 8 Hexblock 8
\ opnvwk clrwk clsvwk updwk 02nov86we
: opnvwk
intin &10 0 DO 1 over I 2* + ! LOOP drop
2 intin &20 + ! &100 0 &11 VDI
contrl &12 + @ grhandle ! ;
: clrwk 3 0 0 VDI ;
: clsvwk &101 0 0 VDI ;
: updwk 4 0 0 VDI ;
\ *** Block No. 9 Hexblock 9
\ s_clip grinit grexit show_c hide_c 02nov86we
: s_clip ( x1 y1 x2 y2 clipflag -- )
intin ! ptsin 4 array! &129 2 1 VDI ;
: grinit setarrays appl_init graf_handle opnvwk ;
: grexit clsvwk appl_exit ;
2Variable objc_tree 0. objc_tree 2!
Variable c_flag c_flag off
: show_c ( -- ) c_flag @ intin ! &122 0 1 VDI ;
: hide_c ( -- ) &123 0 0 VDI ;
\\ st_load_fonts st_unload_fonts
w„r auch ganz h<EFBFBD>bsch, hamse aber nich!

BIN
sources/AtariST/GEM/GEMDEFS.FB.src
View File

Binary file not shown.

BIN
sources/AtariST/GEM/GEMDEFS.fth Normal file
View File

Binary file not shown.

272
sources/AtariST/GEM/SUPERGEM.FB.src
View File

@ -1,272 +0,0 @@
Screen 0 not modified
0 \\ *** SUPERGEM.SCR *** 16sep86we
1
2 In diesem File soll eine GEM-Library aufgebaut werden, die
3 komfortablere Routinen als die Standardbefehle mit Ihren un-
4 <20>bersehbaren Parametern zur Verf<72>gung stellt.
5
6 Bei der Entwicklung des Editors sind bereits einige solche
7 Routinen entstanden.
8
9 F<>r Anregungen gerade in diesem Bereich sind wir dankbar....
10
11
12
13
14
15
Screen 1 not modified
0 \ GEM-Library Loadscreen cas20130105
1
2 Onlyforth GEM also
3
4 \needs scr>mem $10 loadfrom gem\vdi.fb
5
6 Onlyforth GEM also definitions
7
8 1 4 +thru
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Resource Trees and objects 02sep86we
1
2 : tree! ( tree -- )
3 0 swap rsrc_gaddr objc_tree 2! ;
4
5 : objc_gaddr ( object# -- laddr )
6 &24 * extend objc_tree 2@ d+ ;
7
8 : text_gaddr ( object# -- laddr )
9 objc_gaddr &12 extend d+ l2@ l2@ ;
10
11 : alert ( n -- button )
12 show_c
13 5 swap rsrc_gaddr addrin 2! 1 intin ! &52 1 1 1 AES
14 hide_c ;
15
Screen 3 not modified
0 \ Move text to Objects and back 02nov86we
1
2 : putstring ( addr object# -- ) >r
3 count under >r >absaddr r> r@ text_gaddr rot lcmove
4 0 swap extend r> text_gaddr d+ lc! ;
5
6 : getstring ( object# addr -- ) >r text_gaddr
7 0 BEGIN >r 2dup r@ extend d+ lc@ WHILE r> 1+ REPEAT r>
8 r> 2dup c! 1+ >absaddr rot lcmove ;
9
10 : getnumber ( object# -- d )
11 pad getstring pad count bl skip swap 1- dup >r c!
12 r@ capitalize c@ IF r> number ELSE rdrop 0 0 THEN ;
13
14 : putnumber ( d object# -- ) >r
15 <# #s #> over 1- c! 1- r> putstring ;
Screen 4 not modified
0 \ init_object select deselect 02nov86we
1
2 Create little &320 , &200 , &10 , &10 ,
3 Create big 8 allot
4
5 : init_object ( -- )
6 &320 &200 &10 &10 little 4! form_center big 4! ;
7
8 : state_gaddr ( object -- laddr ) objc_gaddr &10. d+ ;
9
10 : select ( object -- ) 1 swap state_gaddr l! ;
11 : deselect ( object -- ) 0 swap state_gaddr l! ;
12
13
14
15
Screen 5 not modified
0 \ show_object hide_object objc_setpos objc_getwh 12aug86we
1
2 : show_object ( -- ) init_object
3 big 4@ scr>mem1 1 little 4@ big 4@ form_dial
4 0 ( install) 3 ( depth) big 4@ objc_draw show_c ;
5
6 : hide_object ( -- ) hide_c
7 2 little 4@ big 4@ form_dial big 4@ mem1>scr ;
8
9 : objc_setpos ( x y object# -- )
10 dup >r objc_gaddr $0.12 d+ l! r> objc_gaddr $0.10 d+ l! ;
11
12 : objc_getwh ( object# -- width height )
13 dup objc_gaddr $0.14 d+ l@ swap objc_gaddr $0.16 d+ l@ ;
14
15
Screen 6 not modified
0 \
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 7 not modified
0 \
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 8 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 \ GEM-Library Loadscreen 16sep86we
1
2 nimmt GEM in die Suchordnung auf (Fehlermeldung, falls nicht
3 vorhanden)
4 wird f<>r die Rasteroperationen gebraucht, die den Bildschirm-
5 inhalt schnell restaurieren.
6 Alle folgenden Definitionen werden Bestandteil des Vokabulars
7 GEM
8 falls die Mausroutinen noch nicht vorhanden sind.
9
10
11
12
13
14
15
Screen 10 not modified
0 \ Resource Trees and objects 16sep86we
1
2 speichert die Kennummer eines Trees in der FORTH-internen
3 Variablen objc_tree ab. Muž immer vor der weiteren Arbeit mit
4 Objekten geschehen.
5 liefert die 32-Bit-Adresse des Objekts mit der Nummer object#.
6 tree! muž vorher aufgerufen worden sein.
7
8 laddr ist die 32-Bit-Adresse des 0-terminated Strings mit der
9 Objektnummer object#.
10
11 n ist die Objektnummer der Alertbox, button ist der vom Benutzer
12 bet„tigte Knopf. Die Maus wird vorher eingeschaltet und hinter-
13 her gl”scht.
14
15
Screen 11 not modified
0 \ Move text to Objects and back 16sep86we
1
2 addr ist die Adresse eines 0-terminated Strings innerhalb des
3 FORTH-Systems. Dieser wird in das Objekt object# transportiert.
4
5
6 Der Text im Objekt object# wird nach addr transportiert.
7
8
9
10 wie oben, jedoch wir der String in eine doppelt genaue Zahl
11 gewandelt. Ist der String leer wird 0.0 zur<75>ckgegeben. Ein
12 Abbruch erfolgt, wenn der String nicht gewandelt werden kann.
13
14 wandelt die doppelt genaue Zahl d in einen 0-terminated String
15 und transportiert ihn in das Objekt object#.
Screen 12 not modified
0 \ init_object select deselect 16sep86we
1
2 little beschreibt ein kleines Rechteck in Bildschirmmitte.
3 big beschreibt ein Rechteck in der Gr”že des Objekts.
4
5 initialisiert little und big auf die Gr”žen des darzustellenden
6 Objekts. Die Koordinaten des Objekts werden in der Resource (!)
7 so ge„ndert, daž es auf dem Bildschirm zentriert erscheint.
8 laddr ist die Langadresse des Statuswortes des Objekts object#.
9 setzt den Status des Objekts object# auf selected (revers).
10 setzt den Status des Objekts object# auf deselected (normal).
11
12
13
14
15
Screen 13 not modified
0 \ show_object hide_object objc_setpos objc_getwh 16sep86we
1
2 zeichnet das Objekt auf dem Bildschirm und rettet den Hinter-
3 grund. Die Treenummer des Objekts muž mit tree! gesetzt sein.
4 Das Objekt wird mit (bis zu) drei Unterebenen gezeichnet.
5 Die Maus wird eingeschaltet.
6 entfernt das Objekt vom Bildschirm und restauriert den Hinter-
7 grund.
8
9 x und y sind die Koordinaten der oberen rechten Ecke, an der
10 das Objekt object# auf dem Bildschirm erscheinen soll.
11
12 width und height sind Breite und H”he des Objekts object#.
13
14
15
Screen 14 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

272
sources/AtariST/GEM/SUPERGEM.fth Normal file
View File

@ -0,0 +1,272 @@
\ *** Block No. 0 Hexblock 0
\\ *** SUPERGEM.SCR *** 16sep86we
In diesem File soll eine GEM-Library aufgebaut werden, die
komfortablere Routinen als die Standardbefehle mit Ihren un-
<EFBFBD>bersehbaren Parametern zur Verf<EFBFBD>gung stellt.
Bei der Entwicklung des Editors sind bereits einige solche
Routinen entstanden.
F<EFBFBD>r Anregungen gerade in diesem Bereich sind wir dankbar....
\ *** Block No. 1 Hexblock 1
\ GEM-Library Loadscreen cas20130105
Onlyforth GEM also
\needs scr>mem $10 loadfrom gem\vdi.fb
Onlyforth GEM also definitions
1 4 +thru
\ *** Block No. 2 Hexblock 2
\ Resource Trees and objects 02sep86we
: tree! ( tree -- )
0 swap rsrc_gaddr objc_tree 2! ;
: objc_gaddr ( object# -- laddr )
&24 * extend objc_tree 2@ d+ ;
: text_gaddr ( object# -- laddr )
objc_gaddr &12 extend d+ l2@ l2@ ;
: alert ( n -- button )
show_c
5 swap rsrc_gaddr addrin 2! 1 intin ! &52 1 1 1 AES
hide_c ;
\ *** Block No. 3 Hexblock 3
\ Move text to Objects and back 02nov86we
: putstring ( addr object# -- ) >r
count under >r >absaddr r> r@ text_gaddr rot lcmove
0 swap extend r> text_gaddr d+ lc! ;
: getstring ( object# addr -- ) >r text_gaddr
0 BEGIN >r 2dup r@ extend d+ lc@ WHILE r> 1+ REPEAT r>
r> 2dup c! 1+ >absaddr rot lcmove ;
: getnumber ( object# -- d )
pad getstring pad count bl skip swap 1- dup >r c!
r@ capitalize c@ IF r> number ELSE rdrop 0 0 THEN ;
: putnumber ( d object# -- ) >r
<# #s #> over 1- c! 1- r> putstring ;
\ *** Block No. 4 Hexblock 4
\ init_object select deselect 02nov86we
Create little &320 , &200 , &10 , &10 ,
Create big 8 allot
: init_object ( -- )
&320 &200 &10 &10 little 4! form_center big 4! ;
: state_gaddr ( object -- laddr ) objc_gaddr &10. d+ ;
: select ( object -- ) 1 swap state_gaddr l! ;
: deselect ( object -- ) 0 swap state_gaddr l! ;
\ *** Block No. 5 Hexblock 5
\ show_object hide_object objc_setpos objc_getwh 12aug86we
: show_object ( -- ) init_object
big 4@ scr>mem1 1 little 4@ big 4@ form_dial
0 ( install) 3 ( depth) big 4@ objc_draw show_c ;
: hide_object ( -- ) hide_c
2 little 4@ big 4@ form_dial big 4@ mem1>scr ;
: objc_setpos ( x y object# -- )
dup >r objc_gaddr $0.12 d+ l! r> objc_gaddr $0.10 d+ l! ;
: objc_getwh ( object# -- width height )
dup objc_gaddr $0.14 d+ l@ swap objc_gaddr $0.16 d+ l@ ;
\ *** Block No. 6 Hexblock 6
\
\ *** Block No. 7 Hexblock 7
\
\ *** Block No. 8 Hexblock 8
\ *** Block No. 9 Hexblock 9
\ GEM-Library Loadscreen 16sep86we
nimmt GEM in die Suchordnung auf (Fehlermeldung, falls nicht
vorhanden)
wird f<EFBFBD>r die Rasteroperationen gebraucht, die den Bildschirm-
inhalt schnell restaurieren.
Alle folgenden Definitionen werden Bestandteil des Vokabulars
GEM
falls die Mausroutinen noch nicht vorhanden sind.
\ *** Block No. 10 Hexblock A
\ Resource Trees and objects 16sep86we
speichert die Kennummer eines Trees in der FORTH-internen
Variablen objc_tree ab. Muž immer vor der weiteren Arbeit mit
Objekten geschehen.
liefert die 32-Bit-Adresse des Objekts mit der Nummer object#.
tree! muž vorher aufgerufen worden sein.
laddr ist die 32-Bit-Adresse des 0-terminated Strings mit der
Objektnummer object#.
n ist die Objektnummer der Alertbox, button ist der vom Benutzer
bet„tigte Knopf. Die Maus wird vorher eingeschaltet und hinter-
her gl”scht.
\ *** Block No. 11 Hexblock B
\ Move text to Objects and back 16sep86we
addr ist die Adresse eines 0-terminated Strings innerhalb des
FORTH-Systems. Dieser wird in das Objekt object# transportiert.
Der Text im Objekt object# wird nach addr transportiert.
wie oben, jedoch wir der String in eine doppelt genaue Zahl
gewandelt. Ist der String leer wird 0.0 zur<EFBFBD>ckgegeben. Ein
Abbruch erfolgt, wenn der String nicht gewandelt werden kann.
wandelt die doppelt genaue Zahl d in einen 0-terminated String
und transportiert ihn in das Objekt object#.
\ *** Block No. 12 Hexblock C
\ init_object select deselect 16sep86we
little beschreibt ein kleines Rechteck in Bildschirmmitte.
big beschreibt ein Rechteck in der Gr”že des Objekts.
initialisiert little und big auf die Gr”žen des darzustellenden
Objekts. Die Koordinaten des Objekts werden in der Resource (!)
so ge„ndert, daž es auf dem Bildschirm zentriert erscheint.
laddr ist die Langadresse des Statuswortes des Objekts object#.
setzt den Status des Objekts object# auf selected (revers).
setzt den Status des Objekts object# auf deselected (normal).
\ *** Block No. 13 Hexblock D
\ show_object hide_object objc_setpos objc_getwh 16sep86we
zeichnet das Objekt auf dem Bildschirm und rettet den Hinter-
grund. Die Treenummer des Objekts muž mit tree! gesetzt sein.
Das Objekt wird mit (bis zu) drei Unterebenen gezeichnet.
Die Maus wird eingeschaltet.
entfernt das Objekt vom Bildschirm und restauriert den Hinter-
grund.
x und y sind die Koordinaten der oberen rechten Ecke, an der
das Objekt object# auf dem Bildschirm erscheinen soll.
width und height sind Breite und H”he des Objekts object#.
\ *** Block No. 14 Hexblock E
\ *** Block No. 15 Hexblock F

714
sources/AtariST/GEM/VDI.FB.src
View File

@ -1,714 +0,0 @@
Screen 0 not modified
0 \\ *** VDI -Funktionen *** 12aug86we
1
2 Dieses File enth„lt alle VDI-Funktionen.
3
4 Zur genaueren Beschreibung verweisen wir auf die Dokumentation
5 von Digital Research.
6 Dieser Hinweis ist nicht zynisch gemeint, aber wir sind nicht
7 in der Lage, das, was ATARI nicht zu leisten vermag, hier
8 nachzuholen. Mit geeigneten Unterlagen (wo gibts die ??) sollte
9 es aber m”glich sein, die Funktionen zu nutzen.
10 Beispiele findet man im Editor.
11
12
13
14
15
Screen 1 not modified
0 \ VDI Loadscreen 09sep86we
1
2 Onlyforth
3 \needs GEM include gem\basics.scr
4 Onlyforth
5 \needs 2over include double.scr
6
7 Onlyforth GEM also definitions
8
9 1 +load cr .( Output Functions loaded) cr
10 7 +load cr .( Attribute Functions loaded) cr
11 $0F +load cr .( Raster Operations loaded) cr
12 $15 +load cr .( Input Functions loaded) cr
13 $1B +load cr .( Inquire Functions loaded) cr
14 $1F +load cr .( Escapes loaded) cr
15
Screen 2 not modified
0 \ Output Functions Loadscreen 27jan86we
1
2 Onlyforth GEM also definitions
3
4 01 05 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ pline pmarker gtext 26f09sep86we
1
2 : pline ( x1 y1 x2 y2 ... xn yn count -- )
3 >r ptsin r@ 2* array! 6 r> 0 VDI ;
4
5 : pmarker ( x1 y1 x2 y2 ... xn yn count -- )
6 >r ptsin r@ 2* array! 7 r> 0 VDI ;
7
8 | Code 1:2move ( from to count -- ) SP )+ D0 move
9 SP )+ D6 move D6 reg) A0 lea
10 SP )+ D6 move D6 reg) A1 lea
11 D0 tst 0<> IF 1 D0 subq D1 clr D0 DO
12 .b A1 )+ D1 move .w D1 A0 )+ move LOOP THEN Next end-code
13
14 : gtext ( addr count x y -- )
15 ptsin 2 array! >r intin r@ 1:2move 8 1 r> VDI ;
Screen 4 not modified
0 \ fillarea contourfill 01feb86we
1
2 : fillarea ( x1 y1 x2 y2 ... xn yn count -- )
3 >r ptsin r@ 2* array! 9 r> 0 VDI ;
4
5 : contourfill ( color x y -- )
6 ptsin 2 array! intin ! &103 1 1 VDI ;
7
8 : r_recfl ( x1 y1 x2 y2 -- )
9 ptsin 4 array! &114 2 0 VDI ;
10
11
12 \\ cellarray
13
14
15
Screen 5 not modified
0 \ GDP bar arc pie 03aug86we
1
2 : GDP ( #ptsin #intin functionno -- )
3 function ! &11 -rot VDI ;
4
5 : bar ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 1 GDP ;
6
7 : arc ( startwinkel endwinkel x y radius -- )
8 ptsin under &12 + ! 2 array! intin 2 array! 4 2 2 GDP ;
9
10 : pie ( startwinkel endwinkel x y radius -- )
11 ptsin under &12 + ! 2 array! intin 2 array! 4 2 3 GDP ;
12
13
14
15
Screen 6 not modified
0 \ circle ellpie ellarc ellipse 01feb86we
1
2 : circle ( x y radius -- )
3 ptsin under 8 + ! 2 array! 3 0 4 GDP ;
4
5 : ellarc ( startwinkel endwinkel x y xradius yradius -- )
6 ptsin 4 array! intin 2 array! 2 2 6 GDP ;
7
8 : ellpie ( startwinkel endwinkel x y xradius yradius -- )
9 ptsin 4 array! intin 2 array! 2 2 7 GDP ;
10
11 : ellipse ( x y xradius yradius -- )
12 ptsin 4 array! 2 0 5 GDP ;
13
14
15
Screen 7 not modified
0 \ rbox rfbox justified 01feb86we
1
2 : rbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 8 GDP ;
3
4 : rfbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 9 GDP ;
5
6 : justified ( string x y length wordspace charspace -- )
7 intin 2 array! ptsin 3 array! 4 swap count dup >r
8 bounds DO I c@ over intin + ! 2+ LOOP drop
9 2 r> 2+ &10 GDP ;
10
11
12
13
14
15
Screen 8 not modified
0 \ Attribute Functions Loadscreen 27jan86we
1
2 Onlyforth GEM also definitions
3
4 01 07 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 \ swr_mode Setmode 12aug86we
1
2 : swr_mode ( mode -- ) intin ! &32 0 1 VDI ;
3
4
5 | : Setmode ( n -- ) Create , Does> @ swr_mode ;
6
7 1 Setmode overwrite 2 Setmode transparent
8 3 Setmode exor 4 Setmode revtransparent
9
10
11 \\
12 : scolor
13
14
15
Screen 10 not modified
0 \ sl_type Settype sl_udsty 31jan86we
1
2 : sl_type ( style -- ) intin ! &15 0 1 VDI ;
3
4 | : Settype ( n -- ) Create , Does> @ sl_type ;
5
6 1 Settype solid 2 Settype longdash
7 3 Settype dot 4 Settype dashdot
8 5 Settype dash 6 Settype dashdotdot
9 7 Settype userdef
10
11 : sl_udsty ( pattern -- ) intin ! &113 0 1 VDI ;
12
13
14
15
Screen 11 not modified
0 \ sl_width sl_color sl_ends 01feb86we
1
2 : sl_width ( width -- ) ptsin ! &16 1 0 VDI ;
3
4 : sl_color ( color -- ) intin ! &17 0 1 VDI ;
5
6 : sl_ends ( begstyle endstyle -- )
7 intin 2 array! &108 0 2 VDI ;
8
9
10
11
12
13
14
15
Screen 12 not modified
0 \ sm_type sm_height sm_color 01feb86we
1
2 : sm_type ( symbol -- ) intin ! &18 0 1 VDI ;
3
4 | : Setmtype ( n -- ) Create , Does> @ sm_type ;
5
6 1 Setmtype point 2 Setmtype plus
7 3 Setmtype asterisk 4 Setmtype square
8 5 Setmtype cross 6 Setmtype diamond
9
10 : sm_height ( height -- )
11 0 ptsin 2! &19 1 0 VDI ;
12
13 : sm_color ( color -- ) intin ! &20 0 1 VDI ;
14
15
Screen 13 not modified
0 \ st_height st_point st_rotation st_color 01feb86we
1
2 : st_height ( height -- )
3 0 ptsin 2! &12 1 0 VDI ;
4
5 : st_point ( point -- ) intin ! &107 0 1 VDI ;
6
7 : st_rotation ( winkel -- ) intin ! &13 0 1 VDI ;
8
9 : st_font ( font -- ) intin ! &21 0 1 VDI ;
10
11 : st_color ( color -- ) intin ! &22 0 1 VDI ;
12
13
14
15
Screen 14 not modified
0 \ st_effects st_alignement 01feb86we
1
2 : st_effects ( effect -- ) intin ! &106 0 1 VDI ;
3
4 : st_alignement ( horin vertin -- )
5 intin 2 array! &39 0 2 VDI ;
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ sf_interior sf_style sf_color sf_perimeter 31jan86we
1
2 : sf_interior ( style -- ) intin ! &23 0 1 VDI ;
3
4 : sf_style ( styleindex -- ) intin ! &24 0 1 VDI ;
5
6 : sf_color ( color -- ) intin ! &25 0 1 VDI ;
7
8 : sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ;
9
10
11 \\ sf_udpat
12
13
14
15
Screen 16 not modified
0 \ Raster Operations Loadscreen 21nov86we
1
2 Onlyforth GEM also definitions
3
4 \needs malloc include allocate.scr
5
6
7 Create scrMFDB 0 , 0 ,
8
9 Variable >memMFDB
10
11 | $4711 Constant magic
12
13 1 5 +thru
14
15
Screen 17 not modified
0 \ ?allocate onscreen 11sep86we
1
2 | Code ?allocate >memMFDB R#) D6 move D6 reg) A0 lea
3 .l A0 ) A0 move .w magic A0 -) cmpi
4 0= IF Next Assembler THEN ;c:
5 $0.8004 malloc swap even swap
6 2dup magic -rot l! 2 extend d+ >memMFDB @ 2! ;
7
8 | Code onscreen
9 scrMFDB # D6 move D6 reg) A0 lea
10 .l A0 contrl &14 + R#) move A0 contrl &18 + R#) move
11 Next end-code
12
13
14
15
Screen 18 not modified
0 \ onscreen >screen screen> 09sep86we
1
2 | Code >screen
3 >memMFDB R#) D6 move D6 reg) A0 lea
4 .l A0 contrl &14 + R#) move
5 .w scrMFDB # D6 move D6 reg) A0 lea
6 .l A0 contrl &18 + R#) move ;c: ?allocate ;
7
8 | Code screen>
9 >memMFDB R#) D6 move D6 reg) A0 lea
10 .l A0 contrl &18 + R#) move
11 .w scrMFDB # D6 move D6 reg) A0 lea
12 .l A0 contrl &14 + R#) move ;c: ?allocate ;
13
14
15
Screen 19 not modified
0 \ copyraster 23aug86we
1
2 : copyopaque ( Xfr Yfr width height Xto Yto mode --)
3 intin ! 2over 2over d+ ptsin 8 + 4 array!
4 2over d+ ptsin 4 array! &109 4 1 VDI ;
5
6 : scr>mem ( addr_of_memMFDB -- )
7 Create , Does> @ >memMFDB ! screen> 2over 3 copyopaque ;
8
9 : mem>scr ( addr_of_memMFDB -- )
10 Create , Does> @ >memMFDB ! >screen 2over 3 copyopaque ;
11
12
13 \\ scr>mem und mem>scr sind Defining-Words f<>r Rasteroperationen
14 Um mit verschiedenen memMDFBs arbeiten zu k”nnen, m<>ssen jeweils
15 eigene Worte definiert werden. Beispiel: s. n„chster Screen
Screen 20 not modified
0 \ r_trnfm get_pixel 09sep86we
1
2 : scr>scr ( Xfr Yfr width heigth Xto Yto --)
3 onscreen 3 copyopaque ;
4
5 Create memMFDB1 7 , 0 , &640 , &400 , &40 , 0 , 1 ,
6 0 , 0 , 0 ,
7
8 memMFDB1 scr>mem scr>mem1 ( Xleft Ytop Width Heigth -- )
9
10 memMFDB1 mem>scr mem1>scr ( Xleft Ytop Width Heigth -- )
11
12
13
14
15
Screen 21 not modified
0 \ r_trnfm get_pixel 26feb86re
1
2 : r_trnfm ( -- ) >screen &110 0 0 VDI ;
3
4 : get_pixel ( x y -- color flag )
5 ptsin 2 array! &105 1 0 VDI intout 2@ swap ;
6
7
8
9
10
11
12
13
14
15
Screen 22 not modified
0 \ Input Functions Loadscreen 12aug86we
1
2 Onlyforth GEM also definitions
3
4 1 5 +thru
5
6 \\
7 Alle Input-Funktionen sollten von FORTH aus grunds„tzlich im
8 Sample-Mode arbeiten, da sonst kein Multitasking m”glich ist.
9 Daher sind nur die Sample-Funktionen implementiert. Die Opcodes
10 der Request-Funktionen sind aber dieselben, sodaž durch Aufruf
11 von sin_mode auch Request-Funktionen erreichbar sind.
12 Zu Beginn eines Programms sollten ansonsten alle Device-Typen
13 einmal mit sin_mode auf Sample geschaltet werden.
14 Werden mehrere Werte zur<75>ckgegeben, m<>ssen dies aus den diversen
15 Arrays geholt werden.
Screen 23 not modified
0 \ sm_locater sm_valuator sm_choice 12aug86we
1
2 : sin_mode ( devtype mode -- ) intin 2 array! &33 0 2 VDI ;
3
4 : sm_locater ( x y -- status )
5 ptsin 2 array! &28 1 0 VDI #ptsout @ #addrout @ 2* + ;
6 \ status: 0 -> no input 1 -> pos changed
7 \ 2 -> key pressed 3 -> key pressed and pos changed
8
9 : sm_valuator ( val_in -- status )
10 intin ! &29 0 1 VDI #addrout @ ;
11 \ status: 0 -> no action;1 -> valuator changed;2 -> key pressed
12
13 : sm_choice ( -- status )
14 &30 0 0 VDI #addrout @ ;
15 \ status: 0 -> no action 1 -> key pressed
Screen 24 not modified
0 \ sm_string sc_form 01feb86we
1
2 : sm_string ( addr max_len echomode x y -- status )
3 ptsin 2 array! intin 2 array! &31 1 2 VDI
4 #addrout @ over c!
5 #addrout @ 0 ?DO intout I 2* + 1+ c@ over I + 1+ c! LOOP
6 drop #addrout @ ;
7 \ status: 0 -> function aborted n -> count of string
8 \ string wird als counted string bei addr abgelegt
9
10 : sc_form ( addr -- )
11 intin &74 cmove &111 0 &37 VDI ;
12 \ addr is the adress of a data structure.
13 \ See description in VDI-Manual.
14
15
Screen 25 not modified
0 \ ex_time show_c hide_c 02nov86we
1
2 | : exchange_vecs ( pusrcode functionno -- long_psavcode )
3 swap >absaddr contrl &14 + 2! 0 0 VDI
4 contrl &18 + 2@ ;
5
6 : ex_time ( tim_addr -- long_otim_addr )
7 &118 exchange_vecs ;
8
9
10
11
12
13
14
15
Screen 26 not modified
0 \ q_mouse ex_butv ex_motv ex_curv 09sep86we
1
2 : q_mouse ( -- x y status )
3 &124 0 0 VDI ptsout 2@ intout @ ;
4
5 : ex_butv ( pusrcode -- long_psavcode )
6 &125 exchange_vecs ;
7
8 : ex_motv ( pusrcode -- long_psavcode )
9 &126 exchange_vecs ;
10
11 : ex_curv ( pusrcode -- long_psavcode )
12 &127 exchange_vecs ;
13
14
15
Screen 27 not modified
0 \ q_key_s 31jan86we
1
2 : q_key_s ( -- status )
3 &128 0 0 VDI intout @ ;
4 \ status: Bit 0 -> Right Shift Key Bit 1 -> Left Shift Key
5 \ Bit 2 -> Control Key Bit 3 -> Alt Key
6
7
8
9
10
11
12
13
14
15
Screen 28 not modified
0 \ Inquire Functions Loadscreen 31jan86we
1
2 Onlyforth GEM also definitions
3
4 01 03 +thru
5
6 \\
7 Die Werte, die die Inquire-Funktionen zur<75>ckliefern, m<>ssen aus
8 den entsprechenden Arrays ausgelesen werden.
9
10
11
12
13
14
15
Screen 29 not modified
0 \ q_extnd q_color q_attributes 01feb86we
1
2 : q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ;
3
4 : q_color ( color_index info_flag )
5 intin 2 array! &26 0 2 VDI ;
6
7
8 | : q_attributes ( n -- ) 0 0 VDI ;
9
10 : ql_attributes ( -- ) &35 q_attributes ;
11 : qm_attributes ( -- ) &36 q_attributes ;
12 : qf_attributes ( -- ) &37 q_attributes ;
13 : qt_attributes ( -- ) &38 q_attributes ;
14
15
Screen 30 not modified
0 \ qt_extent qt_width qt_name 31jan86we
1
2 : qt_extent ( string -- )
3 0 swap count dup >r bounds
4 DO I c@ over intin + ! 2+ LOOP drop
5 &116 0 r> VDI ;
6
7 : qt_width ( char -- status )
8 intin ! &117 0 1 VDI intout @ ;
9 \ status: -1 -> char invalid n -> ADE-Value of char
10
11 : qt_name ( element_num -- )
12 intin ! &130 0 1 VDI ;
13
14
15
Screen 31 not modified
0 \ q_cellarray qin_mode qt_fontinfo 01feb86we
1
2 : q_cellarray ( cols rows x1 y1 x2 y2 -- )
3 ptsin 4 array! contrl &14 + 2 array! &27 2 0 VDI ;
4
5 : qin_mode ( dev_type -- mode )
6 intin ! &115 0 1 VDI intout @ ;
7
8 : qt_fontinfo ( -- ) &131 0 0 VDI ;
9
10
11
12
13
14
15
Screen 32 not modified
0 \ Escapes Loadscreen 31jan86we
1
2 Onlyforth GEM also definitions
3
4 01 07 +thru
5
6
7
8
9
10
11
12
13
14
15
Screen 33 not modified
0 \ ESC normal_ESC 31jan86we
1
2 | : ESC ( #intin #ptsin functionno -- )
3 function ! 5 -rot VDI ;
4
5 | : normal_ESC ( functionno -- )
6 0 0 rot ESC ;
7
8
9
10
11
12
13
14
15
Screen 34 not modified
0 \ q_chcells exit_cur enter_cur cur_primitives 31jan86we
1
2 : q_chcells ( -- rows cols ) 1 normal_ESC intout 2@ ;
3
4 : exit_cur ( -- ) 2 normal_ESC ;
5 : enter_cur ( -- ) 3 normal_ESC ;
6
7 : curup ( -- ) 4 normal_ESC ;
8 : curdown ( -- ) 5 normal_ESC ;
9 : curright ( -- ) 6 normal_ESC ;
10 : curleft ( -- ) 7 normal_ESC ;
11 : curhome ( -- ) 8 normal_ESC ;
12
13 : eeos ( -- ) 9 normal_ESC ;
14 : eeol ( -- ) &10 normal_ESC ;
15
Screen 35 not modified
0 \ s_curaddress curtext rvon rvoff 26feb86we/re
1
2 : s_curaddress ( row col -- )
3 intin 2 array! 0 2 &11 ESC ;
4
5 : curtext ( addr count -- )
6 >r intin r@ 1:2move 0 r> &12 ESC ;
7
8 : rvon ( -- ) &13 normal_ESC ;
9
10 : rvoff ( -- ) &14 normal_ESC ;
11
12 : q_curaddress ( -- row col )
13 &15 normal_ESC intout 2@ ;
14
15
Screen 36 not modified
0 \ q_tabstatus hardcopy dspcur rmcur form_adv 01feb86we
1
2 : q_tabstatus ( -- status ) &16 normal_ESC intout @ ;
3
4 : hardcopy ( -- ) &17 normal_ESC ;
5
6 : dspcur ( x y -- ) ptsin 2 array! 1 0 &18 ESC ;
7
8 : rmcur ( -- ) &19 normal_ESC ;
9
10 : form_adv ( -- ) &20 normal_ESC ;
11
12
13
14
15
Screen 37 not modified
0 \ output_window clear_disp_list bit_image s_palette 01feb86we
1
2 : output_window ( x1 y1 x2 y2 -- )
3 ptsin 4 array! 2 0 &21 ESC ;
4
5 : clear_disp_list ( -- ) &22 normal_ESC ;
6
7 : bit_image ( string aspect scaling num_pts x1 y1 x2 y2 -- )
8 ptsin 4 array! >r intin 2 array! 4 swap count dup >r
9 bounds DO I c@ over intin + ! 2+ LOOP drop
10 r> r> 2+ &23 VDI ;
11
12 : s_palette ( palette -- selected )
13 intin ! 0 1 &60 ESC intout @ ;
14
15
Screen 38 not modified
0 \ s_palette qp_films qp_state sp_state sp_save etc. 31jan86we
1
2 : qp_films ( -- ) &91 normal_ESC ;
3 : qp_state ( -- ) &92 normal_ESC ;
4
5 : sp_state ( addr -- )
6 intin &40 cmove 0 &20 &93 ESC ;
7 \ adr is the adress of a data structure
8
9 : sp_save ( -- ) &94 normal_ESC ;
10
11 : sp_message ( -- ) &95 normal_ESC ;
12
13 : qp_error ( -- ) &96 normal_ESC ;
14
15
Screen 39 not modified
0 \ meta_extents write_meta m_filename 31jan86we
1
2 : meta_extents ( x1 y1 x2 y2 -- )
3 ptsin 4 array! 2 0 &98 ESC ;
4
5 : write_meta ( intin num_intin ptsin num_ptsin -- )
6 dup 2/ >r ptsin swap cmove dup >r intin swap cmove
7 r> r> swap &99 ESC ;
8
9 : m_filename ( string -- )
10 0 swap count dup >r
11 bounds DO I c@ over intin + ! 2+ LOOP 0 swap intin + !
12 0 r> &100 ESC ;
13
14
15
Screen 40 not modified
0 \ Demo fuer VDI 02feb86we
1
2 Onlyforth GEM also definitions
3
4 Create logo ," volksFORTH 83"
5
6 : textdemo clrwk exor 1 st_font 1 st_color
7 &0 st_rotation &13 st_effects
8 80 0 DO 2 0 DO J 4 / st_height
9 logo $80 20 J + 80 J 2* + 1 1 justified LOOP
10 4 +LOOP logo $80 $A0 180 1 1 justified ;
11
12 : rahmen 0 0 sl_ends 10 sl_width
13 60 70 210 70 210 $C0 60 $C0 60 70 5 pline ;
14 -->
15
Screen 41 not modified
0 \ Kreis mit Mustern 02feb86we
1
2 : torte
3 2 sf_interior 1 sf_perimeter 1 sf_color
4 9 sf_style 0 &450 &100 &300 &80 pie
5 &07 sf_style &450 &1000 &100 &300 &80 pie
6 &12 sf_style &1000 &2400 &100 &300 &80 pie
7 &19 sf_style &2400 &3600 &100 &300 &80 pie ;
8
9
10
11
12
13
14 : tdemo grinit page textdemo rahmen torte grexit ;
15

714
sources/AtariST/GEM/VDI.fth Normal file
View File

@ -0,0 +1,714 @@
\ *** Block No. 0 Hexblock 0
\\ *** VDI -Funktionen *** 12aug86we
Dieses File enth„lt alle VDI-Funktionen.
Zur genaueren Beschreibung verweisen wir auf die Dokumentation
von Digital Research.
Dieser Hinweis ist nicht zynisch gemeint, aber wir sind nicht
in der Lage, das, was ATARI nicht zu leisten vermag, hier
nachzuholen. Mit geeigneten Unterlagen (wo gibts die ??) sollte
es aber m”glich sein, die Funktionen zu nutzen.
Beispiele findet man im Editor.
\ *** Block No. 1 Hexblock 1
\ VDI Loadscreen 09sep86we
Onlyforth
\needs GEM include gem\basics.scr
Onlyforth
\needs 2over include double.scr
Onlyforth GEM also definitions
1 +load cr .( Output Functions loaded) cr
7 +load cr .( Attribute Functions loaded) cr
$0F +load cr .( Raster Operations loaded) cr
$15 +load cr .( Input Functions loaded) cr
$1B +load cr .( Inquire Functions loaded) cr
$1F +load cr .( Escapes loaded) cr
\ *** Block No. 2 Hexblock 2
\ Output Functions Loadscreen 27jan86we
Onlyforth GEM also definitions
01 05 +thru
\ *** Block No. 3 Hexblock 3
\ pline pmarker gtext 26f09sep86we
: pline ( x1 y1 x2 y2 ... xn yn count -- )
>r ptsin r@ 2* array! 6 r> 0 VDI ;
: pmarker ( x1 y1 x2 y2 ... xn yn count -- )
>r ptsin r@ 2* array! 7 r> 0 VDI ;
| Code 1:2move ( from to count -- ) SP )+ D0 move
SP )+ D6 move D6 reg) A0 lea
SP )+ D6 move D6 reg) A1 lea
D0 tst 0<> IF 1 D0 subq D1 clr D0 DO
.b A1 )+ D1 move .w D1 A0 )+ move LOOP THEN Next end-code
: gtext ( addr count x y -- )
ptsin 2 array! >r intin r@ 1:2move 8 1 r> VDI ;
\ *** Block No. 4 Hexblock 4
\ fillarea contourfill 01feb86we
: fillarea ( x1 y1 x2 y2 ... xn yn count -- )
>r ptsin r@ 2* array! 9 r> 0 VDI ;
: contourfill ( color x y -- )
ptsin 2 array! intin ! &103 1 1 VDI ;
: r_recfl ( x1 y1 x2 y2 -- )
ptsin 4 array! &114 2 0 VDI ;
\\ cellarray
\ *** Block No. 5 Hexblock 5
\ GDP bar arc pie 03aug86we
: GDP ( #ptsin #intin functionno -- )
function ! &11 -rot VDI ;
: bar ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 1 GDP ;
: arc ( startwinkel endwinkel x y radius -- )
ptsin under &12 + ! 2 array! intin 2 array! 4 2 2 GDP ;
: pie ( startwinkel endwinkel x y radius -- )
ptsin under &12 + ! 2 array! intin 2 array! 4 2 3 GDP ;
\ *** Block No. 6 Hexblock 6
\ circle ellpie ellarc ellipse 01feb86we
: circle ( x y radius -- )
ptsin under 8 + ! 2 array! 3 0 4 GDP ;
: ellarc ( startwinkel endwinkel x y xradius yradius -- )
ptsin 4 array! intin 2 array! 2 2 6 GDP ;
: ellpie ( startwinkel endwinkel x y xradius yradius -- )
ptsin 4 array! intin 2 array! 2 2 7 GDP ;
: ellipse ( x y xradius yradius -- )
ptsin 4 array! 2 0 5 GDP ;
\ *** Block No. 7 Hexblock 7
\ rbox rfbox justified 01feb86we
: rbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 8 GDP ;
: rfbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 9 GDP ;
: justified ( string x y length wordspace charspace -- )
intin 2 array! ptsin 3 array! 4 swap count dup >r
bounds DO I c@ over intin + ! 2+ LOOP drop
2 r> 2+ &10 GDP ;
\ *** Block No. 8 Hexblock 8
\ Attribute Functions Loadscreen 27jan86we
Onlyforth GEM also definitions
01 07 +thru
\ *** Block No. 9 Hexblock 9
\ swr_mode Setmode 12aug86we
: swr_mode ( mode -- ) intin ! &32 0 1 VDI ;
| : Setmode ( n -- ) Create , Does> @ swr_mode ;
1 Setmode overwrite 2 Setmode transparent
3 Setmode exor 4 Setmode revtransparent
\\
: scolor
\ *** Block No. 10 Hexblock A
\ sl_type Settype sl_udsty 31jan86we
: sl_type ( style -- ) intin ! &15 0 1 VDI ;
| : Settype ( n -- ) Create , Does> @ sl_type ;
1 Settype solid 2 Settype longdash
3 Settype dot 4 Settype dashdot
5 Settype dash 6 Settype dashdotdot
7 Settype userdef
: sl_udsty ( pattern -- ) intin ! &113 0 1 VDI ;
\ *** Block No. 11 Hexblock B
\ sl_width sl_color sl_ends 01feb86we
: sl_width ( width -- ) ptsin ! &16 1 0 VDI ;
: sl_color ( color -- ) intin ! &17 0 1 VDI ;
: sl_ends ( begstyle endstyle -- )
intin 2 array! &108 0 2 VDI ;
\ *** Block No. 12 Hexblock C
\ sm_type sm_height sm_color 01feb86we
: sm_type ( symbol -- ) intin ! &18 0 1 VDI ;
| : Setmtype ( n -- ) Create , Does> @ sm_type ;
1 Setmtype point 2 Setmtype plus
3 Setmtype asterisk 4 Setmtype square
5 Setmtype cross 6 Setmtype diamond
: sm_height ( height -- )
0 ptsin 2! &19 1 0 VDI ;
: sm_color ( color -- ) intin ! &20 0 1 VDI ;
\ *** Block No. 13 Hexblock D
\ st_height st_point st_rotation st_color 01feb86we
: st_height ( height -- )
0 ptsin 2! &12 1 0 VDI ;
: st_point ( point -- ) intin ! &107 0 1 VDI ;
: st_rotation ( winkel -- ) intin ! &13 0 1 VDI ;
: st_font ( font -- ) intin ! &21 0 1 VDI ;
: st_color ( color -- ) intin ! &22 0 1 VDI ;
\ *** Block No. 14 Hexblock E
\ st_effects st_alignement 01feb86we
: st_effects ( effect -- ) intin ! &106 0 1 VDI ;
: st_alignement ( horin vertin -- )
intin 2 array! &39 0 2 VDI ;
\ *** Block No. 15 Hexblock F
\ sf_interior sf_style sf_color sf_perimeter 31jan86we
: sf_interior ( style -- ) intin ! &23 0 1 VDI ;
: sf_style ( styleindex -- ) intin ! &24 0 1 VDI ;
: sf_color ( color -- ) intin ! &25 0 1 VDI ;
: sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ;
\\ sf_udpat
\ *** Block No. 16 Hexblock 10
\ Raster Operations Loadscreen 21nov86we
Onlyforth GEM also definitions
\needs malloc include allocate.scr
Create scrMFDB 0 , 0 ,
Variable >memMFDB
| $4711 Constant magic
1 5 +thru
\ *** Block No. 17 Hexblock 11
\ ?allocate onscreen 11sep86we
| Code ?allocate >memMFDB R#) D6 move D6 reg) A0 lea
.l A0 ) A0 move .w magic A0 -) cmpi
0= IF Next Assembler THEN ;c:
$0.8004 malloc swap even swap
2dup magic -rot l! 2 extend d+ >memMFDB @ 2! ;
| Code onscreen
scrMFDB # D6 move D6 reg) A0 lea
.l A0 contrl &14 + R#) move A0 contrl &18 + R#) move
Next end-code
\ *** Block No. 18 Hexblock 12
\ onscreen >screen screen> 09sep86we
| Code >screen
>memMFDB R#) D6 move D6 reg) A0 lea
.l A0 contrl &14 + R#) move
.w scrMFDB # D6 move D6 reg) A0 lea
.l A0 contrl &18 + R#) move ;c: ?allocate ;
| Code screen>
>memMFDB R#) D6 move D6 reg) A0 lea
.l A0 contrl &18 + R#) move
.w scrMFDB # D6 move D6 reg) A0 lea
.l A0 contrl &14 + R#) move ;c: ?allocate ;
\ *** Block No. 19 Hexblock 13
\ copyraster 23aug86we
: copyopaque ( Xfr Yfr width height Xto Yto mode --)
intin ! 2over 2over d+ ptsin 8 + 4 array!
2over d+ ptsin 4 array! &109 4 1 VDI ;
: scr>mem ( addr_of_memMFDB -- )
Create , Does> @ >memMFDB ! screen> 2over 3 copyopaque ;
: mem>scr ( addr_of_memMFDB -- )
Create , Does> @ >memMFDB ! >screen 2over 3 copyopaque ;
\\ scr>mem und mem>scr sind Defining-Words f<EFBFBD>r Rasteroperationen
Um mit verschiedenen memMDFBs arbeiten zu k”nnen, m<EFBFBD>ssen jeweils
eigene Worte definiert werden. Beispiel: s. n„chster Screen
\ *** Block No. 20 Hexblock 14
\ r_trnfm get_pixel 09sep86we
: scr>scr ( Xfr Yfr width heigth Xto Yto --)
onscreen 3 copyopaque ;
Create memMFDB1 7 , 0 , &640 , &400 , &40 , 0 , 1 ,
0 , 0 , 0 ,
memMFDB1 scr>mem scr>mem1 ( Xleft Ytop Width Heigth -- )
memMFDB1 mem>scr mem1>scr ( Xleft Ytop Width Heigth -- )
\ *** Block No. 21 Hexblock 15
\ r_trnfm get_pixel 26feb86re
: r_trnfm ( -- ) >screen &110 0 0 VDI ;
: get_pixel ( x y -- color flag )
ptsin 2 array! &105 1 0 VDI intout 2@ swap ;
\ *** Block No. 22 Hexblock 16
\ Input Functions Loadscreen 12aug86we
Onlyforth GEM also definitions
1 5 +thru
\\
Alle Input-Funktionen sollten von FORTH aus grunds„tzlich im
Sample-Mode arbeiten, da sonst kein Multitasking m”glich ist.
Daher sind nur die Sample-Funktionen implementiert. Die Opcodes
der Request-Funktionen sind aber dieselben, sodaž durch Aufruf
von sin_mode auch Request-Funktionen erreichbar sind.
Zu Beginn eines Programms sollten ansonsten alle Device-Typen
einmal mit sin_mode auf Sample geschaltet werden.
Werden mehrere Werte zur<EFBFBD>ckgegeben, m<EFBFBD>ssen dies aus den diversen
Arrays geholt werden.
\ *** Block No. 23 Hexblock 17
\ sm_locater sm_valuator sm_choice 12aug86we
: sin_mode ( devtype mode -- ) intin 2 array! &33 0 2 VDI ;
: sm_locater ( x y -- status )
ptsin 2 array! &28 1 0 VDI #ptsout @ #addrout @ 2* + ;
\ status: 0 -> no input 1 -> pos changed
\ 2 -> key pressed 3 -> key pressed and pos changed
: sm_valuator ( val_in -- status )
intin ! &29 0 1 VDI #addrout @ ;
\ status: 0 -> no action;1 -> valuator changed;2 -> key pressed
: sm_choice ( -- status )
&30 0 0 VDI #addrout @ ;
\ status: 0 -> no action 1 -> key pressed
\ *** Block No. 24 Hexblock 18
\ sm_string sc_form 01feb86we
: sm_string ( addr max_len echomode x y -- status )
ptsin 2 array! intin 2 array! &31 1 2 VDI
#addrout @ over c!
#addrout @ 0 ?DO intout I 2* + 1+ c@ over I + 1+ c! LOOP
drop #addrout @ ;
\ status: 0 -> function aborted n -> count of string
\ string wird als counted string bei addr abgelegt
: sc_form ( addr -- )
intin &74 cmove &111 0 &37 VDI ;
\ addr is the adress of a data structure.
\ See description in VDI-Manual.
\ *** Block No. 25 Hexblock 19
\ ex_time show_c hide_c 02nov86we
| : exchange_vecs ( pusrcode functionno -- long_psavcode )
swap >absaddr contrl &14 + 2! 0 0 VDI
contrl &18 + 2@ ;
: ex_time ( tim_addr -- long_otim_addr )
&118 exchange_vecs ;
\ *** Block No. 26 Hexblock 1A
\ q_mouse ex_butv ex_motv ex_curv 09sep86we
: q_mouse ( -- x y status )
&124 0 0 VDI ptsout 2@ intout @ ;
: ex_butv ( pusrcode -- long_psavcode )
&125 exchange_vecs ;
: ex_motv ( pusrcode -- long_psavcode )
&126 exchange_vecs ;
: ex_curv ( pusrcode -- long_psavcode )
&127 exchange_vecs ;
\ *** Block No. 27 Hexblock 1B
\ q_key_s 31jan86we
: q_key_s ( -- status )
&128 0 0 VDI intout @ ;
\ status: Bit 0 -> Right Shift Key Bit 1 -> Left Shift Key
\ Bit 2 -> Control Key Bit 3 -> Alt Key
\ *** Block No. 28 Hexblock 1C
\ Inquire Functions Loadscreen 31jan86we
Onlyforth GEM also definitions
01 03 +thru
\\
Die Werte, die die Inquire-Funktionen zur<EFBFBD>ckliefern, m<EFBFBD>ssen aus
den entsprechenden Arrays ausgelesen werden.
\ *** Block No. 29 Hexblock 1D
\ q_extnd q_color q_attributes 01feb86we
: q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ;
: q_color ( color_index info_flag )
intin 2 array! &26 0 2 VDI ;
| : q_attributes ( n -- ) 0 0 VDI ;
: ql_attributes ( -- ) &35 q_attributes ;
: qm_attributes ( -- ) &36 q_attributes ;
: qf_attributes ( -- ) &37 q_attributes ;
: qt_attributes ( -- ) &38 q_attributes ;
\ *** Block No. 30 Hexblock 1E
\ qt_extent qt_width qt_name 31jan86we
: qt_extent ( string -- )
0 swap count dup >r bounds
DO I c@ over intin + ! 2+ LOOP drop
&116 0 r> VDI ;
: qt_width ( char -- status )
intin ! &117 0 1 VDI intout @ ;
\ status: -1 -> char invalid n -> ADE-Value of char
: qt_name ( element_num -- )
intin ! &130 0 1 VDI ;
\ *** Block No. 31 Hexblock 1F
\ q_cellarray qin_mode qt_fontinfo 01feb86we
: q_cellarray ( cols rows x1 y1 x2 y2 -- )
ptsin 4 array! contrl &14 + 2 array! &27 2 0 VDI ;
: qin_mode ( dev_type -- mode )
intin ! &115 0 1 VDI intout @ ;
: qt_fontinfo ( -- ) &131 0 0 VDI ;
\ *** Block No. 32 Hexblock 20
\ Escapes Loadscreen 31jan86we
Onlyforth GEM also definitions
01 07 +thru
\ *** Block No. 33 Hexblock 21
\ ESC normal_ESC 31jan86we
| : ESC ( #intin #ptsin functionno -- )
function ! 5 -rot VDI ;
| : normal_ESC ( functionno -- )
0 0 rot ESC ;
\ *** Block No. 34 Hexblock 22
\ q_chcells exit_cur enter_cur cur_primitives 31jan86we
: q_chcells ( -- rows cols ) 1 normal_ESC intout 2@ ;
: exit_cur ( -- ) 2 normal_ESC ;
: enter_cur ( -- ) 3 normal_ESC ;
: curup ( -- ) 4 normal_ESC ;
: curdown ( -- ) 5 normal_ESC ;
: curright ( -- ) 6 normal_ESC ;
: curleft ( -- ) 7 normal_ESC ;
: curhome ( -- ) 8 normal_ESC ;
: eeos ( -- ) 9 normal_ESC ;
: eeol ( -- ) &10 normal_ESC ;
\ *** Block No. 35 Hexblock 23
\ s_curaddress curtext rvon rvoff 26feb86we/re
: s_curaddress ( row col -- )
intin 2 array! 0 2 &11 ESC ;
: curtext ( addr count -- )
>r intin r@ 1:2move 0 r> &12 ESC ;
: rvon ( -- ) &13 normal_ESC ;
: rvoff ( -- ) &14 normal_ESC ;
: q_curaddress ( -- row col )
&15 normal_ESC intout 2@ ;
\ *** Block No. 36 Hexblock 24
\ q_tabstatus hardcopy dspcur rmcur form_adv 01feb86we
: q_tabstatus ( -- status ) &16 normal_ESC intout @ ;
: hardcopy ( -- ) &17 normal_ESC ;
: dspcur ( x y -- ) ptsin 2 array! 1 0 &18 ESC ;
: rmcur ( -- ) &19 normal_ESC ;
: form_adv ( -- ) &20 normal_ESC ;
\ *** Block No. 37 Hexblock 25
\ output_window clear_disp_list bit_image s_palette 01feb86we
: output_window ( x1 y1 x2 y2 -- )
ptsin 4 array! 2 0 &21 ESC ;
: clear_disp_list ( -- ) &22 normal_ESC ;
: bit_image ( string aspect scaling num_pts x1 y1 x2 y2 -- )
ptsin 4 array! >r intin 2 array! 4 swap count dup >r
bounds DO I c@ over intin + ! 2+ LOOP drop
r> r> 2+ &23 VDI ;
: s_palette ( palette -- selected )
intin ! 0 1 &60 ESC intout @ ;
\ *** Block No. 38 Hexblock 26
\ s_palette qp_films qp_state sp_state sp_save etc. 31jan86we
: qp_films ( -- ) &91 normal_ESC ;
: qp_state ( -- ) &92 normal_ESC ;
: sp_state ( addr -- )
intin &40 cmove 0 &20 &93 ESC ;
\ adr is the adress of a data structure
: sp_save ( -- ) &94 normal_ESC ;
: sp_message ( -- ) &95 normal_ESC ;
: qp_error ( -- ) &96 normal_ESC ;
\ *** Block No. 39 Hexblock 27
\ meta_extents write_meta m_filename 31jan86we
: meta_extents ( x1 y1 x2 y2 -- )
ptsin 4 array! 2 0 &98 ESC ;
: write_meta ( intin num_intin ptsin num_ptsin -- )
dup 2/ >r ptsin swap cmove dup >r intin swap cmove
r> r> swap &99 ESC ;
: m_filename ( string -- )
0 swap count dup >r
bounds DO I c@ over intin + ! 2+ LOOP 0 swap intin + !
0 r> &100 ESC ;
\ *** Block No. 40 Hexblock 28
\ Demo fuer VDI 02feb86we
Onlyforth GEM also definitions
Create logo ," volksFORTH 83"
: textdemo clrwk exor 1 st_font 1 st_color
&0 st_rotation &13 st_effects
80 0 DO 2 0 DO J 4 / st_height
logo $80 20 J + 80 J 2* + 1 1 justified LOOP
4 +LOOP logo $80 $A0 180 1 1 justified ;
: rahmen 0 0 sl_ends 10 sl_width
60 70 210 70 210 $C0 60 $C0 60 70 5 pline ;
-->
\ *** Block No. 41 Hexblock 29
\ Kreis mit Mustern 02feb86we
: torte
2 sf_interior 1 sf_perimeter 1 sf_color
9 sf_style 0 &450 &100 &300 &80 pie
&07 sf_style &450 &1000 &100 &300 &80 pie
&12 sf_style &1000 &2400 &100 &300 &80 pie
&19 sf_style &2400 &3600 &100 &300 &80 pie ;
: tdemo grinit page textdemo rahmen torte grexit ;

34
sources/AtariST/INDEX.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \\ *** Index *** 26may86we
1
2 Diese File enth„lt nur das Wort INDEX , das fr<66>her zum System-
3 kern geh”rt hat. INDEX arbeitet aber jetzt auch auf Files
4 und mužte deshalb 'nach hinten' verlegt werden.
5
6 INDEX ( from to -- )
7 liest die BLOCKs from bis to einschliesslich und gibt deren
8 erste Zeilen aus. INDEX kann mit einer beliebigen Taste unter-
9 brochen und mit ESC oder CTRL-C abgebrochen werden.
10 Die ersten Zeilen von Screens enthalten typisch Kommentare, die
11 den Inhalt charakterisieren.
12
13
14
15
Screen 1 not modified
0 \ index findex 05dec85we
1
2 \needs capacity ' blk/drv Alias capacity
3
4 | : range ( from to -- to+1 from )
5 capacity 1- umin swap capacity 1- umin
6 2dup > IF swap THEN 1+ swap ;
7
8 : index ( from to --)
9 range DO cr I 4 .r I space block c/l type
10 stop? IF LEAVE THEN LOOP ;
11
12
13
14
15

34
sources/AtariST/INDEX.fth Normal file
View File

@ -0,0 +1,34 @@
\ *** Block No. 0 Hexblock 0
\\ *** Index *** 26may86we
Diese File enth„lt nur das Wort INDEX , das fr<EFBFBD>her zum System-
kern geh”rt hat. INDEX arbeitet aber jetzt auch auf Files
und mužte deshalb 'nach hinten' verlegt werden.
INDEX ( from to -- )
liest die BLOCKs from bis to einschliesslich und gibt deren
erste Zeilen aus. INDEX kann mit einer beliebigen Taste unter-
brochen und mit ESC oder CTRL-C abgebrochen werden.
Die ersten Zeilen von Screens enthalten typisch Kommentare, die
den Inhalt charakterisieren.
\ *** Block No. 1 Hexblock 1
\ index findex 05dec85we
\needs capacity ' blk/drv Alias capacity
| : range ( from to -- to+1 from )
capacity 1- umin swap capacity 1- umin
2dup > IF swap THEN 1+ swap ;
: index ( from to --)
range DO cr I 4 .r I space block c/l type
stop? IF LEAVE THEN LOOP ;

629
sources/AtariST/LINE_A.FB.src
View File

@ -1,629 +0,0 @@
Screen 0 not modified
0 \\ *** Line-A Graphic *** cas20130106
1
2 This file contains the LINE-A graphic routines. While being
3 sometimes faster than VDI Routines, LINE-A Functions are not
4 supported on some newer Atari ST machines.
5
6 It is recommended to only use VDI functions in new programs.
7 This library is provided for compatibility reasons to be able
8 to compile old source code. the programs will probablt not work
9 on newer Atari machines.
10
11
12 Examples for the use of LINE-A routines can be found in the file
13 DEMO.FB
14
15
Screen 1 not modified
0 \ Line A - Graphics Loadscreen cas20130106
1
2 Onlyforth
3 \needs Code include assemble.fb
4
5 .( use of LINE-A is deprecated and will not work on newer )
6 .( Atari machines. Please use VDI routines instead! )
7
8 Vocabulary Graphics Graphics also definitions
9
10 1 $10 +thru
11
12
13
14
15
Screen 2 not modified
0 \ Table offsets 26oct86we
1
2 base @ decimal
3 0 >label v_planes 2 >label v_lin_wr
4 4 >label _cntrl
5 8 >label _intin 12 >label _ptsin
6 16 >label _intout 20 >label _ptsout
7 24 >label _fg_bp_1 26 >label _fg_bp_2
8 28 >label _fg_bp_3 30 >label _fg_bp_4
9 32 >label _lstlin 34 >label _ln_mask
10 36 >label _wrt_mode 38 >label _x1
11 40 >label _y1 42 >label _x2
12 44 >label _y2 46 >label _patptr
13 50 >label _patmsk 52 >label _multifill
14 54 >label _clip 56 >label _xmn_clip
15 58 >label _ymn_clip 60 >label _xmx_clip
Screen 3 not modified
0 \ Table offsets 26oct86we
1
2 62 >label _ymx_clip 64 >label _xacc_dda
3 66 >label _dda_inc 68 >label _t_sclsts
4 70 >label _mono_status 72 >label _sourcex
5 74 >label _sourcey 76 >label _destx
6 78 >label _desty 80 >label _delx
7 82 >label _dely 84 >label _fbase
8 86 >label _fwidth 90 >label _style
9 92 >label _litemask 94 >label _skewmask
10 96 >label _weight 98 >label _r_off
11 100 >label _l_off 102 >label _scale
12 104 >label _chup 106 >label _text_fg
13 108 >label _scrtchp 112 >label _scrpt2
14 114 >label _text_bg 116 >label _copytran
15 base !
Screen 4 not modified
0 \ Variable cas20130106
1
2 Variable xmin_clip Variable xmax_clip
3 Variable ymin_clip Variable ymax_clip
4 Variable multi_fill 0 multi_fill !
5 Variable linemask $FFFF linemask ! \ solid line
6 Variable plane1 1 plane1 ! \ black
7 Variable plane2 1 plane2 ! \ on
8 Variable plane3 0 plane3 ! \ white
9 Variable plane4 0 plane4 !
10 Variable cur_x 0 cur_x !
11 Variable cur_y 0 cur_y !
12 Variable wr_mode 0 wr_mode ! \ overwrite
13 Variable scr_res 2 scr_res ! \ Hires
14
15
Screen 5 not modified
0 \ arrays 17sep86we
1
2 Variable pat_mask 1 pat_mask !
3 Variable pattern
4
5 Create nopattern 0 , 0 ,
6 Create fullpattern $FFFF , $FFFF , fullpattern pattern !
7
8 Variable checking checking on
9 Variable clipping clipping off
10
11 Create a_fonts 4 allot
12 Create a_base 4 allot
13
14
15
Screen 6 not modified
0 \ Initialization 17sep86we
1
2 Create a_setup Assembler
3 $A000 , .l A0 a_base R#) move A1 a_fonts R#) move
4 .w wr_mode R#) _wrt_mode A0 D) move
5 plane1 R#) _fg_bp_1 A0 D) move
6 plane2 R#) _fg_bp_2 A0 D) move
7 plane3 R#) _fg_bp_2 A0 D) move
8 plane4 R#) _fg_bp_4 A0 D) move
9 rts end-code
10
11
12
13
14
15
Screen 7 not modified
0 \ line 17sep86we
1
2 Code line ( x1 y1 x2 y2 -- )
3 a_setup bsr
4 -1 # _lstlin A0 D) move linemask R#) _ln_mask A0 D) move
5 SP ) _y2 A0 D) move SP )+ cur_y R#) move
6 SP ) _x2 A0 D) move SP )+ cur_x R#) move
7 SP )+ _y1 A0 D) move
8 SP )+ _x1 A0 D) move
9 $A003 , Next end-code
10
11
12
13
14
15
Screen 8 not modified
0 \ rectangle 17sep86we
1
2 Code rectangle ( x1 y1 width heigth -- )
3 a_setup bsr clipping R#) _clip A0 D) move
4 SP )+ D0 move 2 SP D) D0 add D0 _y2 A0 D) move
5 SP )+ D0 move 2 SP D) D0 add D0 _x2 A0 D) move
6 SP )+ _y1 A0 D) move SP )+ _x1 A0 D) move
7 pattern R#) D6 move D6 reg) A1 lea
8 .l A1 _patptr A0 D) move .w
9 pat_mask R#) _patmsk A0 D) move
10 multi_fill R#) _multifill A0 D) move
11 xmin_clip R#) _xmn_clip A0 D) move
12 ymin_clip R#) _ymn_clip A0 D) move
13 xmax_clip R#) _xmx_clip A0 D) move
14 ymax_clip R#) _ymx_clip A0 D) move
15 $A005 , Next end-code
Screen 9 not modified
0 \ Maus-Functions 17sep86we
1
2 Code show_mouse
3 a_setup bsr .l _cntrl A0 D) A1 move
4 .w 2 A1 D) clr 1 # 6 A1 D) move
5 .l _intin A0 D) A1 move A1 ) clr $A009 , Next end-code
6
7 Code hide_mouse $A00A , Next end-code
8
9 Code form_mouse ( addr -- )
10 a_setup bsr .l _intin A0 D) A1 move
11 .w SP )+ D6 move D6 reg) A0 lea
12 A0 )+ A1 )+ move A0 )+ A1 )+ move 1 # A1 )+ move
13 0 # A1 )+ move 1 # A1 )+ move
14 $10 D0 moveq D0 DO .l A0 )+ A1 )+ move LOOP
15 $A00B , Next end-code
Screen 10 not modified
0 \ copyraster bp 12oct86
1
2 cr .( For copyraster use VDI-Functions !!) cr
3
4
5
6
7
8
9 \\
10
11 $10 loadfrom gem\vdi.scr
12
13
14
15
Screen 11 not modified
0 \ Checking cas20130106
1
2 | Create g_limits &320 , &200 , &640 , &200 , &640 , &400 ,
3
4 Code get_res ( -- flag )
5 4 # A7 -) move $0E trap 2 A7 addq D0 SP -) move
6 Next end-code
7
8 | : (check \ checking @ 0= ?exit
9 dup g_limits scr_res @ 4 * 2+ + @ > abort" Y-Value too big"
10 over g_limits scr_res @ 4 * + @ > abort" X-Value too big" ;
11
12 Code check ( x y -- x y )
13 checking R#) tst 0= IF NEXT THEN ;c: (check ;
14
15
Screen 12 not modified
0 \ relative set draw clipping 18sep86we
1
2 Code relative ( dx dy -- x y )
3 SP )+ D0 move cur_y R#) D0 add
4 SP )+ D1 move cur_x R#) D1 add
5 D1 SP -) move D0 SP -) move Next end-code
6
7 : set ( x y -- ) check cur_y ! cur_x ! ;
8 : draw ( x y -- ) check cur_x @ cur_y @ 2swap line ;
9
10 : clip_window ( x1 y1 x2 y2 -- )
11 clipping on
12 ymax_clip ! xmax_clip ! ymin_clip ! xmin_clip ! ;
13
14
15
Screen 13 not modified
0 \ box 18sep86we
1
2 Code box ( width heigth -- )
3 cur_y R#) D4 move D4 D7 move SP )+ D7 add
4 cur_x R#) D3 move D3 D5 move SP )+ D5 add
5 a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move
6 D5 _x2 A0 D) move D4 _y2 A0 D) move $A003 ,
7 a_setup bsr D5 _x1 A0 D) move D4 _y1 A0 D) move
8 D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
9 a_setup bsr D3 _x1 A0 D) move D7 _y1 A0 D) move
10 D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
11 a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move
12 D3 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
13 Next end-code
14
15
Screen 14 not modified
0 \ +sprite -sprite 11dec86we
1
2 Code +sprite ( sprt_def_blk sprt_sav_blk x y -- )
3 SP )+ D1 move SP )+ D0 move
4 SP )+ D6 move D6 reg) A2 lea
5 SP )+ D6 move D6 reg) A0 lea
6 .l $1E A7 -) movem> $A00D , $7800 A7 )+ movem<
7 Next end-code
8
9 Code -sprite ( sprt_sav_blk -- )
10 SP )+ D6 move D6 reg) A2 lea
11 .l $1E A7 -) movem> $A00C , $7800 A7 )+ movem<
12 Next end-code
13
14
15
Screen 15 not modified
0 \ put_pixel get_pixel 17sep86we
1
2 Code put_pixel ( x y color -- )
3 a_setup bsr .l a_base R#) A0 move
4 _intin A0 D) A1 move .w SP )+ A1 ) move
5 .l _ptsin A0 D) A1 move .w SP )+ 2 A1 D) move
6 SP )+ A1 ) move
7 $A001 , Next end-code
8
9 Code get_pixel ( x y -- color )
10 a_setup bsr
11 .l a_base R#) A0 move _ptsin A0 D) A1 move
12 .w SP )+ 2 A1 D) move SP )+ A1 ) move
13 $A002 , D0 SP -) move Next end-code
14
15
Screen 16 not modified
0 \ polygon 17sep86we
1
2 Code polygon ( x1 y1 ... xn yn n )
3 a_setup bsr
4 clipping R#) _clip A0 D) move
5 pattern R#) D6 move D6 reg) A1 lea
6 .l A1 _patptr A0 D) move .w
7 pat_mask R#) _patmsk A0 D) move
8 multi_fill R#) _multifill A0 D) move
9 xmin_clip R#) _xmn_clip A0 D) move
10 ymin_clip R#) _ymn_clip A0 D) move
11 xmax_clip R#) _xmx_clip A0 D) move
12 ymax_clip R#) _ymx_clip A0 D) move
13 .l _cntrl A0 D) A1 move .w SP ) 2 A1 D) move
14 SP )+ D0 move 2 # D0 asl 2 D0 subq D0 D5 move
15 $7FFF # D3 move 0 D4 moveq
Screen 17 not modified
0 \ polygon forts. 17sep86we
1
2 .l _ptsin A0 D) A1 move
3 BEGIN .w 0 D0 SP DI) D1 move D1 A1 )+ move D0 1 # btst
4 0= IF D1 D3 cmp CC IF D1 D3 move THEN
5 D1 D4 cmp CS IF D1 D4 move THEN THEN
6 D0 tst 0<> WHILE 2 D0 subq REPEAT
7 0 D5 SP DI) A1 )+ move 2 D5 subq 0 D5 SP DI) A1 ) move
8 4 D5 addq D5 SP adda
9 .l A0 D5 move
10 BEGIN D5 A0 move .w D3 _y1 A0 D) move $A006 ,
11 1 D3 addq D3 D4 cmp 0= UNTIL
12 Next end-code
13
14
15
Screen 18 not modified
0 \
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 19 not modified
0 \ Line A - Graphics Loadscreen
1
2
3 Line-A Routinen erhalten ein eigenes Vocabular.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 20 not modified
0 \ Table offsets 01jan86we
1
2 Die Definitionen auf diesem Screen enthalten die sogenannten
3 Line_A Variablen. Der Aufruf <20>ber $A000 liefert unter anderem
4 die Basisadresse dieser Variablen zur<75>ck.
5
6 Wenn diese Definitionen in anderen Programmen mitgenutzt werden
7 sollen, m<>ssen diese beiden Screens mit
8
9 2 LOADFROM LINE_A.SCR
10 und 3 LOADFROM LINE_A.SCR
11
12 eingebunden werden.
13
14
15
Screen 21 not modified
0 \ Table offsets 01jan86we
1
2 Die Beschreibung der Line_A Variablen findet man in der ent-
3 sprechenden Literatur (hoffentlich bald!!).
4
5 Bei jeder Line_A Routine l„žt sich am Quelltext sehen, welche
6 Variablen gerade benutzt werden. Allerdings sind unsere Unter-
7 lagen (ATARI-Entwicklungspaket) auch nicht besonders aussage-
8 f„hig....
9
10
11
12
13
14
15
Screen 22 not modified
0 \ Variable bp 12oct86
1
2 Diese vier Variablen beschreiben das 'Clipping-Window'. Damit
3 lassen sich alle Ausgaben auf dieses Window beschr„nken.
4 Anzahl der Planes f<>r F<>llmuster
5 Bitmuster f<>r Linien ($FFFF = durchgezogen)
6 Mit diesen vier Variablen werden die Farben der Planes fest-
7 gelegt.
8
9
10 Hilfsvariable zur Vereinfachung bei Draw. Enth„lt die Endkoordi-
11 naten der zuletzt gezeichneten Linie.
12 Schreibmodus: 0=over, 1= trans, 2=exor, 3=invtrans
13 Bildschirmaufl”sung: 0=320x200, 1=320x400, 2=640x400
14
15
Screen 23 not modified
0 \ arrays 17sep86we
1
2 Enth„lt die Anzahl - 1 der Worte in Arrays f<>r F<>llmuster.
3 Enth„lt die Adresse des aktuellen F<>llmusters.
4
5 Zwei wichtige F<>llmuster: Leer
6 und voll
7
8 Flag, ob die Koordinaten <20>berpr<70>ft werden sollen (Geschwindigk.)
9 Flag, ob mit Clipping gearbeitet wird.
10
11 speichert die lange Adresse der Zeichs„tze.
12 speichert die lange Basis-Adresse der Line_A Variablen
13
14
15
Screen 24 not modified
0 \ Initialization 17sep86we
1
2 Wird bei vielen Routinen zu Beginn benutzt.
3 $A000 <20>bergibt in A0 a_base, in A1 a_fonts
4 Schreibmodus
5 und die Farben der Planes <20>bergeben
6 Alle diese Werte werden aus den FORTH-Variablen in die ent-
7 sprechenden Line_A Variablen geschrieben.
8
9
10
11
12
13
14
15
Screen 25 not modified
0 \ line 17sep86we
1
2 zeichnet eine Gerade von (x1,y1) nach (x2,y2).
3 Initialisierung
4 Original-Ton ATARI: Set it to -1 and forget it !
5 Die Werte f<>r x2,y2 werden auch in cur_x und cur_y gemerkt.
6
7
8
9
10
11
12
13
14
15
Screen 26 not modified
0 \ rectangle 17sep86we
1
2 zeichnet ein gef<65>lltes Rechteck mit x1,y1 als oberer linker Ecke
3 und width und height als Breite und H”he.
4 Umrechnung von Breite und H”he in Koordinaten
5
6
7 Adresse des F<>llmusters <20>bergeben.
8
9 Anzahl der Worte im F<>llmuster
10 Anzahl der Planes f<>r F<>llmuster
11 Koordinaten des Clipping-Rechtecks
12
13
14
15
Screen 27 not modified
0 \ Maus-Functions 17sep86we
1
2 schaltet Maus-Cursor ein
3 CONTRL(1) wird gel”scht und CONTRL(3) auf 1 gesetzt (???)
4 INTIN(0) wird gel”scht, sonst wird die Anzahl der hide-Aufrufe
5 ber<65>cksichtigt (s.a. c-flag beim entsprechenden VDI-Aufruf)
6
7 schaltet Maus-Cursor aus.
8
9 Damit kann eine eigene Mausform entwickelt werden.
10 Adresse enth„lt ein Array mit folgendem Aufbau:
11 Maskenfarbe, Datenfarbe
12 16 Worte Maske
13 16 Worte Daten
14
15
Screen 28 not modified
0 \ copyraster bp 12oct86
1
2 Die Copyrasterfunktionen verlangen eine sehr komplexe Parameter-
3 <20>bergabe. Diese ist im File VDI.SCR an der entsprechenden
4 Stelle enthalten. Da diese Funktion gegen<65>ber der VDI-Funktion
5 kaum Geschwindigkeitsvorteile bringt, wurde auf die nochmalige
6 Definition hier verzichtet.
7
8 Wen's interessiert, m”ge im File VDI.SCR unter Rasterfunctions
9 nachlesen.
10
11 So l„dt man den entsprechenden Teil der VDI-Bibliothek !
12 Dieser Teil wird schon vom Editor ben”tigt und ist daher im
13 System normalerweise schon vorhanden.
14
15
Screen 29 not modified
0 \ Checking 18sep86we
1
2 Array mit den Grenzen f<>r die drei Aufl”sungsstufen.
3
4 flag=0 bei 320x200, flag=1 bei 320x400, flag=2 bei 640x400
5
6
7
8 <20>berpr<70>ft, ob x und y innerhalb des Bildschirms liegen.
9 Ansonsten erfolgt Abbruch. Diese Pr<50>fung kostet Zeit, erspart
10 aber Systemabst<73>rze bei falschen Parametern.
11
12 pr<70>ft x und y, wenn checking eingeschaltet ist.
13
14
15
Screen 30 not modified
0 \ relative set draw clipping 18sep86we
1
2 berechnet aus den Offsets dx und dy und den in cur_y und cur_y
3 gespeicherten Werten die neuen Koordinaten x und y.
4
5
6
7 setzt cur_x und cur_y
8 zeichnet eine Linie von (cur_x,cur_y) nach (x,y).
9
10 setzt das Clipping-Window und schaltet clipping ein.
11
12
13
14
15
Screen 31 not modified
0 \ box 18sep86we
1
2 zeichnet ein ungef<65>lltes Rechteck mit der Breite width und H”he
3 height. Die Koordinaten der linken oberen Ecke werden aus
4 cur_x und cur_y entnommen.
5 Das ganze besteht aus vier einzelnen Geraden.
6
7
8
9
10
11
12
13
14
15
Screen 32 not modified
0 \ +sprite -sprite 17sep86we
1
2 zeichnet ein Sprite und speichert den Bildschirm
3 sprt_def_blk enth„lt die Sprite-Daten
4 sprt_sav_blk ist die Adresse des Zwischenspeichers f<>r den Bild-
5 schirm. Es werden pro Plane 64 Byte ben”tigt.
6 (x,y) ist der 'Hotspot' des Sprites.
7
8 l”scht das Sprite und restauriert den Bildschirm.
9
10 Der sprt_def_blk hat folgenden Aufbau:
11 x-offset zum Hotspot, y-offset zum Hotspot
12 Format-Flag, Hintergrundfarbe, Zeichenfarbe
13 32 Worte mit Muster:
14 Hintergrund 1.Zeile, Vordergrund 1.Zeile
15 Hintergrund 2.Zeile, Vordergrund 2.Zeile usw.
Screen 33 not modified
0 \ put_pixel get_pixel 17sep86we
1
2 zeichnet ein Pixel am Punkt (x,y) mit Farbe color.
3
4 Man kann definieren:
5 : plot ( x y -- ) 1 putpixel ;
6 : unplot ( x y -- ) 0 putpixel ;
7
8
9 color ist die Farbe des Punktes (x,y).
10
11
12
13
14
15
Screen 34 not modified
0 \ polygon 17sep86we
1
2 zeichnet ein n-Eck mit den Eckpunkten (x1,y1) ... (xn,yn).
3
4 Clipping auswerten
5 F<>llmuster <20>bergeben
6
7 F<>llmustermaske
8 und Anzahl der Planes <20>bergeben
9 Clipping-Window setzen
10
11
12
13 Anzahl der Ecken
14 Eckpunkte ins ptsin-Array <20>bernehmen
15 D3 und D4 enthalten die Koordianten des gr”žten Punktes
Screen 35 not modified
0 \ polygon forts. 17sep86we
1
2 f<>r die F<>llfunktion
3 Werte <20>bergeben und D3,D4 ggf updaten.
4
5
6
7 ersten Punkt wiederholen, vereinfacht die šbergabe
8
9 $A006 so oft aufrufen, bis das n-Eck vollst„ndig gef<65>llt ist.
10
11
12
13
14
15
Screen 36 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

629
sources/AtariST/LINE_A.fth Normal file
View File

@ -0,0 +1,629 @@
\ *** Block No. 0 Hexblock 0
\\ *** Line-A Graphic *** cas20130106
This file contains the LINE-A graphic routines. While being
sometimes faster than VDI Routines, LINE-A Functions are not
supported on some newer Atari ST machines.
It is recommended to only use VDI functions in new programs.
This library is provided for compatibility reasons to be able
to compile old source code. the programs will probablt not work
on newer Atari machines.
Examples for the use of LINE-A routines can be found in the file
DEMO.FB
\ *** Block No. 1 Hexblock 1
\ Line A - Graphics Loadscreen cas20130106
Onlyforth
\needs Code include assemble.fb
.( use of LINE-A is deprecated and will not work on newer )
.( Atari machines. Please use VDI routines instead! )
Vocabulary Graphics Graphics also definitions
1 $10 +thru
\ *** Block No. 2 Hexblock 2
\ Table offsets 26oct86we
base @ decimal
0 >label v_planes 2 >label v_lin_wr
4 >label _cntrl
8 >label _intin 12 >label _ptsin
16 >label _intout 20 >label _ptsout
24 >label _fg_bp_1 26 >label _fg_bp_2
28 >label _fg_bp_3 30 >label _fg_bp_4
32 >label _lstlin 34 >label _ln_mask
36 >label _wrt_mode 38 >label _x1
40 >label _y1 42 >label _x2
44 >label _y2 46 >label _patptr
50 >label _patmsk 52 >label _multifill
54 >label _clip 56 >label _xmn_clip
58 >label _ymn_clip 60 >label _xmx_clip
\ *** Block No. 3 Hexblock 3
\ Table offsets 26oct86we
62 >label _ymx_clip 64 >label _xacc_dda
66 >label _dda_inc 68 >label _t_sclsts
70 >label _mono_status 72 >label _sourcex
74 >label _sourcey 76 >label _destx
78 >label _desty 80 >label _delx
82 >label _dely 84 >label _fbase
86 >label _fwidth 90 >label _style
92 >label _litemask 94 >label _skewmask
96 >label _weight 98 >label _r_off
100 >label _l_off 102 >label _scale
104 >label _chup 106 >label _text_fg
108 >label _scrtchp 112 >label _scrpt2
114 >label _text_bg 116 >label _copytran
base !
\ *** Block No. 4 Hexblock 4
\ Variable cas20130106
Variable xmin_clip Variable xmax_clip
Variable ymin_clip Variable ymax_clip
Variable multi_fill 0 multi_fill !
Variable linemask $FFFF linemask ! \ solid line
Variable plane1 1 plane1 ! \ black
Variable plane2 1 plane2 ! \ on
Variable plane3 0 plane3 ! \ white
Variable plane4 0 plane4 !
Variable cur_x 0 cur_x !
Variable cur_y 0 cur_y !
Variable wr_mode 0 wr_mode ! \ overwrite
Variable scr_res 2 scr_res ! \ Hires
\ *** Block No. 5 Hexblock 5
\ arrays 17sep86we
Variable pat_mask 1 pat_mask !
Variable pattern
Create nopattern 0 , 0 ,
Create fullpattern $FFFF , $FFFF , fullpattern pattern !
Variable checking checking on
Variable clipping clipping off
Create a_fonts 4 allot
Create a_base 4 allot
\ *** Block No. 6 Hexblock 6
\ Initialization 17sep86we
Create a_setup Assembler
$A000 , .l A0 a_base R#) move A1 a_fonts R#) move
.w wr_mode R#) _wrt_mode A0 D) move
plane1 R#) _fg_bp_1 A0 D) move
plane2 R#) _fg_bp_2 A0 D) move
plane3 R#) _fg_bp_2 A0 D) move
plane4 R#) _fg_bp_4 A0 D) move
rts end-code
\ *** Block No. 7 Hexblock 7
\ line 17sep86we
Code line ( x1 y1 x2 y2 -- )
a_setup bsr
-1 # _lstlin A0 D) move linemask R#) _ln_mask A0 D) move
SP ) _y2 A0 D) move SP )+ cur_y R#) move
SP ) _x2 A0 D) move SP )+ cur_x R#) move
SP )+ _y1 A0 D) move
SP )+ _x1 A0 D) move
$A003 , Next end-code
\ *** Block No. 8 Hexblock 8
\ rectangle 17sep86we
Code rectangle ( x1 y1 width heigth -- )
a_setup bsr clipping R#) _clip A0 D) move
SP )+ D0 move 2 SP D) D0 add D0 _y2 A0 D) move
SP )+ D0 move 2 SP D) D0 add D0 _x2 A0 D) move
SP )+ _y1 A0 D) move SP )+ _x1 A0 D) move
pattern R#) D6 move D6 reg) A1 lea
.l A1 _patptr A0 D) move .w
pat_mask R#) _patmsk A0 D) move
multi_fill R#) _multifill A0 D) move
xmin_clip R#) _xmn_clip A0 D) move
ymin_clip R#) _ymn_clip A0 D) move
xmax_clip R#) _xmx_clip A0 D) move
ymax_clip R#) _ymx_clip A0 D) move
$A005 , Next end-code
\ *** Block No. 9 Hexblock 9
\ Maus-Functions 17sep86we
Code show_mouse
a_setup bsr .l _cntrl A0 D) A1 move
.w 2 A1 D) clr 1 # 6 A1 D) move
.l _intin A0 D) A1 move A1 ) clr $A009 , Next end-code
Code hide_mouse $A00A , Next end-code
Code form_mouse ( addr -- )
a_setup bsr .l _intin A0 D) A1 move
.w SP )+ D6 move D6 reg) A0 lea
A0 )+ A1 )+ move A0 )+ A1 )+ move 1 # A1 )+ move
0 # A1 )+ move 1 # A1 )+ move
$10 D0 moveq D0 DO .l A0 )+ A1 )+ move LOOP
$A00B , Next end-code
\ *** Block No. 10 Hexblock A
\ copyraster bp 12oct86
cr .( For copyraster use VDI-Functions !!) cr
\\
$10 loadfrom gem\vdi.scr
\ *** Block No. 11 Hexblock B
\ Checking cas20130106
| Create g_limits &320 , &200 , &640 , &200 , &640 , &400 ,
Code get_res ( -- flag )
4 # A7 -) move $0E trap 2 A7 addq D0 SP -) move
Next end-code
| : (check \ checking @ 0= ?exit
dup g_limits scr_res @ 4 * 2+ + @ > abort" Y-Value too big"
over g_limits scr_res @ 4 * + @ > abort" X-Value too big" ;
Code check ( x y -- x y )
checking R#) tst 0= IF NEXT THEN ;c: (check ;
\ *** Block No. 12 Hexblock C
\ relative set draw clipping 18sep86we
Code relative ( dx dy -- x y )
SP )+ D0 move cur_y R#) D0 add
SP )+ D1 move cur_x R#) D1 add
D1 SP -) move D0 SP -) move Next end-code
: set ( x y -- ) check cur_y ! cur_x ! ;
: draw ( x y -- ) check cur_x @ cur_y @ 2swap line ;
: clip_window ( x1 y1 x2 y2 -- )
clipping on
ymax_clip ! xmax_clip ! ymin_clip ! xmin_clip ! ;
\ *** Block No. 13 Hexblock D
\ box 18sep86we
Code box ( width heigth -- )
cur_y R#) D4 move D4 D7 move SP )+ D7 add
cur_x R#) D3 move D3 D5 move SP )+ D5 add
a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move
D5 _x2 A0 D) move D4 _y2 A0 D) move $A003 ,
a_setup bsr D5 _x1 A0 D) move D4 _y1 A0 D) move
D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
a_setup bsr D3 _x1 A0 D) move D7 _y1 A0 D) move
D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move
D3 _x2 A0 D) move D7 _y2 A0 D) move $A003 ,
Next end-code
\ *** Block No. 14 Hexblock E
\ +sprite -sprite 11dec86we
Code +sprite ( sprt_def_blk sprt_sav_blk x y -- )
SP )+ D1 move SP )+ D0 move
SP )+ D6 move D6 reg) A2 lea
SP )+ D6 move D6 reg) A0 lea
.l $1E A7 -) movem> $A00D , $7800 A7 )+ movem<
Next end-code
Code -sprite ( sprt_sav_blk -- )
SP )+ D6 move D6 reg) A2 lea
.l $1E A7 -) movem> $A00C , $7800 A7 )+ movem<
Next end-code
\ *** Block No. 15 Hexblock F
\ put_pixel get_pixel 17sep86we
Code put_pixel ( x y color -- )
a_setup bsr .l a_base R#) A0 move
_intin A0 D) A1 move .w SP )+ A1 ) move
.l _ptsin A0 D) A1 move .w SP )+ 2 A1 D) move
SP )+ A1 ) move
$A001 , Next end-code
Code get_pixel ( x y -- color )
a_setup bsr
.l a_base R#) A0 move _ptsin A0 D) A1 move
.w SP )+ 2 A1 D) move SP )+ A1 ) move
$A002 , D0 SP -) move Next end-code
\ *** Block No. 16 Hexblock 10
\ polygon 17sep86we
Code polygon ( x1 y1 ... xn yn n )
a_setup bsr
clipping R#) _clip A0 D) move
pattern R#) D6 move D6 reg) A1 lea
.l A1 _patptr A0 D) move .w
pat_mask R#) _patmsk A0 D) move
multi_fill R#) _multifill A0 D) move
xmin_clip R#) _xmn_clip A0 D) move
ymin_clip R#) _ymn_clip A0 D) move
xmax_clip R#) _xmx_clip A0 D) move
ymax_clip R#) _ymx_clip A0 D) move
.l _cntrl A0 D) A1 move .w SP ) 2 A1 D) move
SP )+ D0 move 2 # D0 asl 2 D0 subq D0 D5 move
$7FFF # D3 move 0 D4 moveq
\ *** Block No. 17 Hexblock 11
\ polygon forts. 17sep86we
.l _ptsin A0 D) A1 move
BEGIN .w 0 D0 SP DI) D1 move D1 A1 )+ move D0 1 # btst
0= IF D1 D3 cmp CC IF D1 D3 move THEN
D1 D4 cmp CS IF D1 D4 move THEN THEN
D0 tst 0<> WHILE 2 D0 subq REPEAT
0 D5 SP DI) A1 )+ move 2 D5 subq 0 D5 SP DI) A1 ) move
4 D5 addq D5 SP adda
.l A0 D5 move
BEGIN D5 A0 move .w D3 _y1 A0 D) move $A006 ,
1 D3 addq D3 D4 cmp 0= UNTIL
Next end-code
\ *** Block No. 18 Hexblock 12
\
\ *** Block No. 19 Hexblock 13
\ Line A - Graphics Loadscreen
Line-A Routinen erhalten ein eigenes Vocabular.
\ *** Block No. 20 Hexblock 14
\ Table offsets 01jan86we
Die Definitionen auf diesem Screen enthalten die sogenannten
Line_A Variablen. Der Aufruf <EFBFBD>ber $A000 liefert unter anderem
die Basisadresse dieser Variablen zur<EFBFBD>ck.
Wenn diese Definitionen in anderen Programmen mitgenutzt werden
sollen, m<EFBFBD>ssen diese beiden Screens mit
2 LOADFROM LINE_A.SCR
und 3 LOADFROM LINE_A.SCR
eingebunden werden.
\ *** Block No. 21 Hexblock 15
\ Table offsets 01jan86we
Die Beschreibung der Line_A Variablen findet man in der ent-
sprechenden Literatur (hoffentlich bald!!).
Bei jeder Line_A Routine l„žt sich am Quelltext sehen, welche
Variablen gerade benutzt werden. Allerdings sind unsere Unter-
lagen (ATARI-Entwicklungspaket) auch nicht besonders aussage-
f„hig....
\ *** Block No. 22 Hexblock 16
\ Variable bp 12oct86
Diese vier Variablen beschreiben das 'Clipping-Window'. Damit
lassen sich alle Ausgaben auf dieses Window beschr„nken.
Anzahl der Planes f<EFBFBD>r F<EFBFBD>llmuster
Bitmuster f<EFBFBD>r Linien ($FFFF = durchgezogen)
Mit diesen vier Variablen werden die Farben der Planes fest-
gelegt.
Hilfsvariable zur Vereinfachung bei Draw. Enth„lt die Endkoordi-
naten der zuletzt gezeichneten Linie.
Schreibmodus: 0=over, 1= trans, 2=exor, 3=invtrans
Bildschirmaufl”sung: 0=320x200, 1=320x400, 2=640x400
\ *** Block No. 23 Hexblock 17
\ arrays 17sep86we
Enth„lt die Anzahl - 1 der Worte in Arrays f<EFBFBD>r F<EFBFBD>llmuster.
Enth„lt die Adresse des aktuellen F<EFBFBD>llmusters.
Zwei wichtige F<EFBFBD>llmuster: Leer
und voll
Flag, ob die Koordinaten <EFBFBD>berpr<EFBFBD>ft werden sollen (Geschwindigk.)
Flag, ob mit Clipping gearbeitet wird.
speichert die lange Adresse der Zeichs„tze.
speichert die lange Basis-Adresse der Line_A Variablen
\ *** Block No. 24 Hexblock 18
\ Initialization 17sep86we
Wird bei vielen Routinen zu Beginn benutzt.
$A000 <EFBFBD>bergibt in A0 a_base, in A1 a_fonts
Schreibmodus
und die Farben der Planes <EFBFBD>bergeben
Alle diese Werte werden aus den FORTH-Variablen in die ent-
sprechenden Line_A Variablen geschrieben.
\ *** Block No. 25 Hexblock 19
\ line 17sep86we
zeichnet eine Gerade von (x1,y1) nach (x2,y2).
Initialisierung
Original-Ton ATARI: Set it to -1 and forget it !
Die Werte f<EFBFBD>r x2,y2 werden auch in cur_x und cur_y gemerkt.
\ *** Block No. 26 Hexblock 1A
\ rectangle 17sep86we
zeichnet ein gef<EFBFBD>lltes Rechteck mit x1,y1 als oberer linker Ecke
und width und height als Breite und H”he.
Umrechnung von Breite und H”he in Koordinaten
Adresse des F<EFBFBD>llmusters <EFBFBD>bergeben.
Anzahl der Worte im F<EFBFBD>llmuster
Anzahl der Planes f<EFBFBD>r F<EFBFBD>llmuster
Koordinaten des Clipping-Rechtecks
\ *** Block No. 27 Hexblock 1B
\ Maus-Functions 17sep86we
schaltet Maus-Cursor ein
CONTRL(1) wird gel”scht und CONTRL(3) auf 1 gesetzt (???)
INTIN(0) wird gel”scht, sonst wird die Anzahl der hide-Aufrufe
ber<EFBFBD>cksichtigt (s.a. c-flag beim entsprechenden VDI-Aufruf)
schaltet Maus-Cursor aus.
Damit kann eine eigene Mausform entwickelt werden.
Adresse enth„lt ein Array mit folgendem Aufbau:
Maskenfarbe, Datenfarbe
16 Worte Maske
16 Worte Daten
\ *** Block No. 28 Hexblock 1C
\ copyraster bp 12oct86
Die Copyrasterfunktionen verlangen eine sehr komplexe Parameter-
<EFBFBD>bergabe. Diese ist im File VDI.SCR an der entsprechenden
Stelle enthalten. Da diese Funktion gegen<EFBFBD>ber der VDI-Funktion
kaum Geschwindigkeitsvorteile bringt, wurde auf die nochmalige
Definition hier verzichtet.
Wen's interessiert, m”ge im File VDI.SCR unter Rasterfunctions
nachlesen.
So l„dt man den entsprechenden Teil der VDI-Bibliothek !
Dieser Teil wird schon vom Editor ben”tigt und ist daher im
System normalerweise schon vorhanden.
\ *** Block No. 29 Hexblock 1D
\ Checking 18sep86we
Array mit den Grenzen f<EFBFBD>r die drei Aufl”sungsstufen.
flag=0 bei 320x200, flag=1 bei 320x400, flag=2 bei 640x400
<EFBFBD>berpr<EFBFBD>ft, ob x und y innerhalb des Bildschirms liegen.
Ansonsten erfolgt Abbruch. Diese Pr<EFBFBD>fung kostet Zeit, erspart
aber Systemabst<EFBFBD>rze bei falschen Parametern.
pr<EFBFBD>ft x und y, wenn checking eingeschaltet ist.
\ *** Block No. 30 Hexblock 1E
\ relative set draw clipping 18sep86we
berechnet aus den Offsets dx und dy und den in cur_y und cur_y
gespeicherten Werten die neuen Koordinaten x und y.
setzt cur_x und cur_y
zeichnet eine Linie von (cur_x,cur_y) nach (x,y).
setzt das Clipping-Window und schaltet clipping ein.
\ *** Block No. 31 Hexblock 1F
\ box 18sep86we
zeichnet ein ungef<EFBFBD>lltes Rechteck mit der Breite width und H”he
height. Die Koordinaten der linken oberen Ecke werden aus
cur_x und cur_y entnommen.
Das ganze besteht aus vier einzelnen Geraden.
\ *** Block No. 32 Hexblock 20
\ +sprite -sprite 17sep86we
zeichnet ein Sprite und speichert den Bildschirm
sprt_def_blk enth„lt die Sprite-Daten
sprt_sav_blk ist die Adresse des Zwischenspeichers f<EFBFBD>r den Bild-
schirm. Es werden pro Plane 64 Byte ben”tigt.
(x,y) ist der 'Hotspot' des Sprites.
l”scht das Sprite und restauriert den Bildschirm.
Der sprt_def_blk hat folgenden Aufbau:
x-offset zum Hotspot, y-offset zum Hotspot
Format-Flag, Hintergrundfarbe, Zeichenfarbe
32 Worte mit Muster:
Hintergrund 1.Zeile, Vordergrund 1.Zeile
Hintergrund 2.Zeile, Vordergrund 2.Zeile usw.
\ *** Block No. 33 Hexblock 21
\ put_pixel get_pixel 17sep86we
zeichnet ein Pixel am Punkt (x,y) mit Farbe color.
Man kann definieren:
: plot ( x y -- ) 1 putpixel ;
: unplot ( x y -- ) 0 putpixel ;
color ist die Farbe des Punktes (x,y).
\ *** Block No. 34 Hexblock 22
\ polygon 17sep86we
zeichnet ein n-Eck mit den Eckpunkten (x1,y1) ... (xn,yn).
Clipping auswerten
F<EFBFBD>llmuster <EFBFBD>bergeben
F<EFBFBD>llmustermaske
und Anzahl der Planes <EFBFBD>bergeben
Clipping-Window setzen
Anzahl der Ecken
Eckpunkte ins ptsin-Array <EFBFBD>bernehmen
D3 und D4 enthalten die Koordianten des gr”žten Punktes
\ *** Block No. 35 Hexblock 23
\ polygon forts. 17sep86we
f<EFBFBD>r die F<EFBFBD>llfunktion
Werte <EFBFBD>bergeben und D3,D4 ggf updaten.
ersten Punkt wiederholen, vereinfacht die šbergabe
$A006 so oft aufrufen, bis das n-Eck vollst„ndig gef<EFBFBD>llt ist.
\ *** Block No. 36 Hexblock 24

170
sources/AtariST/MISC.FB.src
View File

@ -1,170 +0,0 @@
Screen 0 not modified
0 \\ *** Diverses *** 26oct86we
1
2 In diesem File haben wir Worte untergebracht, die zwar h„ufig
3 gebraucht werden, aber nicht bestimmten Files zugeordnet werden
4 k”nnen.
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Loadscreen f<>r Diverses 26oct86we
1
2 Onlyforth
3
4 1 2 +thru
5
6 ' .blk Is .status
7
8
9 \ 3 +load setvec
10
11
12
13
14
15
Screen 2 not modified
0 \ H„ufig benutzte Definitionen 26oct86we
1
2 : >absaddr ( addr -- abs_laddr ) 0 forthstart d+ ;
3
4 : .blk ( -- ) blk @ ?dup 0= ?exit
5 dup 1 = IF cr file? THEN ." Blk " . ?cr ;
6
7 : abort( ( f -- )
8 IF [compile] .( true abort" !" THEN [compile] ( ;
9
10 \needs arguments abort( use definition in FILEINT.SCR)
11
12
13
14
15
Screen 3 not modified
0 \ H„ufig benutzte Definitionen II 26oct86we
1
2 | Create: cpull
3 rp@ count 2dup + even rp! r> swap cmove ;
4
5 : cpush ( addr len --) r> -rot over >r
6 rp@ over 2+ - even dup rp! place cpull >r >r ;
7
8
9 : bell 7 con! ;
10 : blank ( addr count -- ) bl fill ;
11
12
13
14
15
Screen 4 not modified
0 \ TOS-Alerts abschalten 16oct86we
1
2 Create oldvec 4 allot
3
4 Label newvector
5 -8 D1 cmpi 0<> IF -&13 D1 cmpi 0<> IF
6 .l oldvec pcrel) A2 move A2 ) jmp THEN THEN
7 .l D1 D0 move rts end-code
8
9 : setvec $0.0404 l2@ oldvec 2!
10 newvector >absaddr $0.0404 l2! ;
11
12 : restvec oldvec 2@ $0.0404 l2! ;
13
14 : bye restvec bye ;
15
Screen 5 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 6 not modified
0 \ Loadscreen f<>r Diverses 26oct86we
1
2 setzt Searchorder auf FORTH FORTH ONLY FORTH
3
4 kompiliert die n„chsten 2 Screens.
5
6 .STATUS ist ein 'deferred word', das jeweils beim Kompilieren
7 eines Quelltextscreens aufgerufen wird.
8
9 Screen 4 wird nicht mitkompiliert, denn SETVEC muž nach jedem
10 Neustart wieder aufgerufen werden. Falls Sie diese Funktion
11 nutzen wollen, m<>ssen Sie nach jedem Laden SETVEC eingeben.
12 (Dazu muž nat<61>rlich Screen 4 kompiliert worden sein.)
13
14
15
Screen 7 not modified
0 \ H„ufig benutzte Definitionen 26oct86we
1
2 >ABSADDR rechnet eine - relative- Adresse im FORTH-System in
3 eine absolute 32-Bit-Adresse um.
4 .BLK gibt die Nummer des gerade kompilierten Screens aus,
5 bei Screen 1 auch den Filenamen.
6
7 ABORT( bewirkt das gleiche wie ABORT", ist aber im Direkt-
8 modus zul„ssig.
9
10 ARGUMENTS pr<70>ft, ob eine bestimmte (Mindest-)Anzahl von Werten
11 auf dem Stack liegt. Dieses Wort ist bereits im
12 FORTHKER.PRG vorhanden, da es vom File-Interface
13 gebraucht wird.
14
15
Screen 8 not modified
0 \ H„ufig benutzte Definitionen II 26oct86we
1
2 CPUSH sorgt im Zusammenspiel mit CPULL daf<61>r, daž ein
3 String (bzw. ein beliebiger Speicherbereich, z.B.
4 ein Array) nach dem Aufruf einer Funktion wieder
5 die alten Werte erh„lt. Entspricht dem Wort PUSH,
6 aber f<>r Strings anstelle von Variablen.
7
8
9 BELL Dieses Wort ist selbsterkl„rend !!!
10 BLANK f<>llt ab addr count Speicherstellen mit Leerzeichen.
11
12
13
14
15
Screen 9 not modified
0 \ TOS-Alerts abschalten 26oct86we
1
2 Vielleicht haben Sie es schon einmal bemerkt. Wenn Sie auf eine
3 Diskette schreiben wollen, bei der der Schreibschutz gesetzt
4 ist, erscheint eine Alert-Box, aber ohne Maus, sodaž Sie den
5 ABBRUCH-Knopf nur durch geduldiges Experimentieren mit der Maus
6 erreichen k”nnen. Diese Box wird vom Betriebssystem ohne unser
7 Zutun und ohne Einwirkungsm”glichkeit erzeugt.
8 NEWVECTOR „ndert den zugeh”rigen Vector (critical error handler)
9 so, daž diese Boxen nicht mehr erscheinen, wohl aber die, in
10 denen z.B. zum Diskettenwechsel aufgefordert wird.
11 SETVEC und RESTVEC dienen zum Umschalten zwischen altem und
12 neuen Vector.
13 Insbesondere muž BYE den alten Vector wiederherstellen, sonst
14 st<73>rzt das System gnadenlos ab.
15 Noch keine besonders elegante L”sung, aber besser als keine !!

170
sources/AtariST/MISC.fth Normal file
View File

@ -0,0 +1,170 @@
\ *** Block No. 0 Hexblock 0
\\ *** Diverses *** 26oct86we
In diesem File haben wir Worte untergebracht, die zwar h„ufig
gebraucht werden, aber nicht bestimmten Files zugeordnet werden
k”nnen.
\ *** Block No. 1 Hexblock 1
\ Loadscreen f<EFBFBD>r Diverses 26oct86we
Onlyforth
1 2 +thru
' .blk Is .status
\ 3 +load setvec
\ *** Block No. 2 Hexblock 2
\ H„ufig benutzte Definitionen 26oct86we
: >absaddr ( addr -- abs_laddr ) 0 forthstart d+ ;
: .blk ( -- ) blk @ ?dup 0= ?exit
dup 1 = IF cr file? THEN ." Blk " . ?cr ;
: abort( ( f -- )
IF [compile] .( true abort" !" THEN [compile] ( ;
\needs arguments abort( use definition in FILEINT.SCR)
\ *** Block No. 3 Hexblock 3
\ H„ufig benutzte Definitionen II 26oct86we
| Create: cpull
rp@ count 2dup + even rp! r> swap cmove ;
: cpush ( addr len --) r> -rot over >r
rp@ over 2+ - even dup rp! place cpull >r >r ;
: bell 7 con! ;
: blank ( addr count -- ) bl fill ;
\ *** Block No. 4 Hexblock 4
\ TOS-Alerts abschalten 16oct86we
Create oldvec 4 allot
Label newvector
-8 D1 cmpi 0<> IF -&13 D1 cmpi 0<> IF
.l oldvec pcrel) A2 move A2 ) jmp THEN THEN
.l D1 D0 move rts end-code
: setvec $0.0404 l2@ oldvec 2!
newvector >absaddr $0.0404 l2! ;
: restvec oldvec 2@ $0.0404 l2! ;
: bye restvec bye ;
\ *** Block No. 5 Hexblock 5
\ *** Block No. 6 Hexblock 6
\ Loadscreen f<EFBFBD>r Diverses 26oct86we
setzt Searchorder auf FORTH FORTH ONLY FORTH
kompiliert die n„chsten 2 Screens.
.STATUS ist ein 'deferred word', das jeweils beim Kompilieren
eines Quelltextscreens aufgerufen wird.
Screen 4 wird nicht mitkompiliert, denn SETVEC muž nach jedem
Neustart wieder aufgerufen werden. Falls Sie diese Funktion
nutzen wollen, m<EFBFBD>ssen Sie nach jedem Laden SETVEC eingeben.
(Dazu muž nat<EFBFBD>rlich Screen 4 kompiliert worden sein.)
\ *** Block No. 7 Hexblock 7
\ H„ufig benutzte Definitionen 26oct86we
>ABSADDR rechnet eine - relative- Adresse im FORTH-System in
eine absolute 32-Bit-Adresse um.
.BLK gibt die Nummer des gerade kompilierten Screens aus,
bei Screen 1 auch den Filenamen.
ABORT( bewirkt das gleiche wie ABORT", ist aber im Direkt-
modus zul„ssig.
ARGUMENTS pr<EFBFBD>ft, ob eine bestimmte (Mindest-)Anzahl von Werten
auf dem Stack liegt. Dieses Wort ist bereits im
FORTHKER.PRG vorhanden, da es vom File-Interface
gebraucht wird.
\ *** Block No. 8 Hexblock 8
\ H„ufig benutzte Definitionen II 26oct86we
CPUSH sorgt im Zusammenspiel mit CPULL daf<EFBFBD>r, daž ein
String (bzw. ein beliebiger Speicherbereich, z.B.
ein Array) nach dem Aufruf einer Funktion wieder
die alten Werte erh„lt. Entspricht dem Wort PUSH,
aber f<EFBFBD>r Strings anstelle von Variablen.
BELL Dieses Wort ist selbsterkl„rend !!!
BLANK f<EFBFBD>llt ab addr count Speicherstellen mit Leerzeichen.
\ *** Block No. 9 Hexblock 9
\ TOS-Alerts abschalten 26oct86we
Vielleicht haben Sie es schon einmal bemerkt. Wenn Sie auf eine
Diskette schreiben wollen, bei der der Schreibschutz gesetzt
ist, erscheint eine Alert-Box, aber ohne Maus, sodaž Sie den
ABBRUCH-Knopf nur durch geduldiges Experimentieren mit der Maus
erreichen k”nnen. Diese Box wird vom Betriebssystem ohne unser
Zutun und ohne Einwirkungsm”glichkeit erzeugt.
NEWVECTOR „ndert den zugeh”rigen Vector (critical error handler)
so, daž diese Boxen nicht mehr erscheinen, wohl aber die, in
denen z.B. zum Diskettenwechsel aufgefordert wird.
SETVEC und RESTVEC dienen zum Umschalten zwischen altem und
neuen Vector.
Insbesondere muž BYE den alten Vector wiederherstellen, sonst
st<EFBFBD>rzt das System gnadenlos ab.
Noch keine besonders elegante L”sung, aber besser als keine !!

68
sources/AtariST/PATCH.FB.src
View File

@ -1,68 +0,0 @@
Screen 0 not modified
0 \\ *** Loadscreen f<>r Arbeitssystem *** 03oct86we
1
2 Die folgenden Screens werden benutzt, um von FORTHKER.PRG aus
3 ein Arbeitssystem hochzuziehen.
4
5 Da der Kernal noch kein Filesystem enth„lt, muž dieses zun„chst
6 im Direktzugriff geladen werden. Assembler und Fileinterface
7 m<>ssen daher unbedingt am Anfang auf der Diskette liegen, damit
8 die absoluten Blocknummern stimmen ($16 und $18).
9
10 Anschliežend werden die Files FORTH_83.SCR und FILEINT.SCR er-
11 zeugt und die View-Felder der Worte auf diese Files gepatched.
12 Dazu m<>ssen diese Files auf Diskette vorhanden sein.
13
14 Schliežlich werden mit INCLUDE die Files geladen, die man in
15 seinem System haben m”chte.
Screen 1 not modified
0
1
2 6 load cr .( Internal Assembler loaded ) cr
3 $18 load cr .( File-Interface loaded) cr
4 1 +load cr .( now patch that stuff ... ) cr
5
6 path A:\;B:\
7
8 use forth83.fb 0 0 patchviewfields
9 use fileint.fb ' arguments >name 4- -$17 patchviewfields
10
11 flush save
12
13
14
15
Screen 2 not modified
0 \ patch view-fields bp 25May86
1
2 here 300 hallot heap dp !
3 Variable blockoffset
4 : patch ( viewadr -- ) \ patch view field
5 viewoffset blockoffset @ + swap +! ;
6
7 : patchthread ( thread adr -- )
8 >r BEGIN @ dup WHILE dup 1- r@ u>
9 WHILE dup 2- patch REPEAT drop rdrop ;
10
11 : patchviewfields ( n adr -- ) \ adr is bottom of patch area
12 blockoffset ! voc-link
13 BEGIN @ ?dup WHILE 2dup 4- swap patchthread REPEAT
14 drop ;
15 dp !
Screen 3 not modified
0 \ 05oct86we
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

68
sources/AtariST/PATCH.fth Normal file
View File

@ -0,0 +1,68 @@
\ *** Block No. 0 Hexblock 0
\\ *** Loadscreen f<EFBFBD>r Arbeitssystem *** 03oct86we
Die folgenden Screens werden benutzt, um von FORTHKER.PRG aus
ein Arbeitssystem hochzuziehen.
Da der Kernal noch kein Filesystem enth„lt, muž dieses zun„chst
im Direktzugriff geladen werden. Assembler und Fileinterface
m<EFBFBD>ssen daher unbedingt am Anfang auf der Diskette liegen, damit
die absoluten Blocknummern stimmen ($16 und $18).
Anschliežend werden die Files FORTH_83.SCR und FILEINT.SCR er-
zeugt und die View-Felder der Worte auf diese Files gepatched.
Dazu m<EFBFBD>ssen diese Files auf Diskette vorhanden sein.
Schliežlich werden mit INCLUDE die Files geladen, die man in
seinem System haben m”chte.
\ *** Block No. 1 Hexblock 1
6 load cr .( Internal Assembler loaded ) cr
$18 load cr .( File-Interface loaded) cr
1 +load cr .( now patch that stuff ... ) cr
path A:\;B:\
use forth83.fb 0 0 patchviewfields
use fileint.fb ' arguments >name 4- -$17 patchviewfields
flush save
\ *** Block No. 2 Hexblock 2
\ patch view-fields bp 25May86
here 300 hallot heap dp !
Variable blockoffset
: patch ( viewadr -- ) \ patch view field
viewoffset blockoffset @ + swap +! ;
: patchthread ( thread adr -- )
>r BEGIN @ dup WHILE dup 1- r@ u>
WHILE dup 2- patch REPEAT drop rdrop ;
: patchviewfields ( n adr -- ) \ adr is bottom of patch area
blockoffset ! voc-link
BEGIN @ ?dup WHILE 2dup 4- swap patchthread REPEAT
drop ;
dp !
\ *** Block No. 3 Hexblock 3
\ 05oct86we

510
sources/AtariST/PRINTER.FB.src
View File

@ -1,510 +0,0 @@
Screen 0 not modified
0 \\ *** Printer-Interface *** 10oct86we
1
2 Dieses File enth„lt das Printer-Interface. Die Definitionen f<>r
3 die Druckersteuerung m<>ssen ggf. an Ihren Drucker angepažt wer-
4 den.
5
6 PRINT lenkt alle Ausgabeworte auf den Drucker um, mit DISPLAY
7 wird wieder auf dem Bildschirm ausgegeben.
8
9 Zum Ausdrucken der Quelltexte gibt es die Worte
10
11 pthru ( from to -- ) druckt Screen from bis to
12 document ( from to -- ) wie pthru, aber mit Shadow-Screens
13 printall ( -- ) wie pthru, aber druckt das ganze File
14 listing ( -- ) wie document, aber f<>r das ganze File
15
Screen 1 not modified
0 \ Printer Interface Epson RX80\FX80 21oct86we
1
2 Onlyforth
3
4 \needs file? ' noop | Alias file?
5 \needs capacity ' blk/drv Alias capacity
6
7 Vocabulary Printer Printer definitions also
8
9 1 &13 +thru
10
11 Onlyforth \ clear
12
13
14
15
Screen 2 not modified
0 \ Printer p! and controls 18nov86we
1
2 ' bcostat | Alias ready? ' 0 | Alias printer
3
4 : p! ( n -- )
5 BEGIN pause printer ready? UNTIL printer bconout ;
6
7
8 | : ctrl: ( 8b -- ) Create c, does> ( -- ) c@ p! ;
9
10 07 ctrl: BEL $7F | ctrl: DEL $0D | ctrl: RET
11 $1B | ctrl: ESC $0A ctrl: LF $0C ctrl: FF
12
13
14
15
Screen 3 not modified
0 \ Printer controls 09sep86re
1
2 | : esc: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! ;
3
4 | : esc2 ( 8b0 8b1 -- ) ESC p! p! ;
5
6 | : on: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 1 p! ;
7
8 | : off: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 0 p! ;
9
10
11
12
13
14
15
Screen 4 not modified
0 \ Printer Escapes Epson RX-80/FX-80 12sep86re
1
2 $0F | ctrl: (+17cpi $12 | ctrl: (-17cpi
3
4 Ascii P | esc: (+10cpi Ascii M | esc: (+12cpi
5 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
6 Ascii 2 esc: 1/6" Ascii T esc: suoff
7 Ascii N esc: +jump Ascii O esc: -jump
8 Ascii G esc: +dark Ascii H esc: -dark
9 \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive
10
11 Ascii W on: +wide Ascii W off: -wide
12 Ascii - on: +under Ascii - off: -under
13 Ascii S on: sub Ascii S off: super
14
15
Screen 5 not modified
0 \ Printer Escapes Epson RX-80/FX-80 12sep86re
1
2 : 10cpi (-17cpi (+10cpi ; ' 10cpi Alias pica
3 : 12cpi (-17cpi (+12cpi ; ' 12cpi Alias elite
4 : 17cpi (+10cpi (+17cpi ; ' 17cpi Alias small
5
6 : lines ( #.of.lines -- ) Ascii C esc2 ;
7
8 : "long ( inches -- ) 0 lines p! ;
9
10 : american 0 Ascii R esc2 ;
11
12 : german 2 Ascii R esc2 ;
13
14 : normal 10cpi american suoff 1/6" &12 "long RET ;
15
Screen 6 not modified
0 \ Umlaute 14oct86we
1
2 | Create DIN
3 Ascii „ c, Ascii ” c, Ascii <20> c, Ascii ž c,
4 Ascii Ž c, Ascii ™ c, Ascii š c, Ascii Ý c,
5
6 | Create AMI
7 Ascii { c, Ascii | c, Ascii } c, Ascii ~ c,
8 Ascii [ c, Ascii \ c, Ascii ] c, Ascii @ c,
9
10 here AMI - | Constant tablen
11
12 | : p! ( char -- ) dup $80 < IF p! exit THEN
13 tablen 0 DO dup I DIN + c@ =
14 IF drop I AMI + c@ LEAVE THEN LOOP
15 german p! american ;
Screen 7 not modified
0 \ Printer Output 12sep86re
1
2 | Variable pcol pcol off | Variable prow prow off
3
4 | : pemit ( 8b -- ) p! 1 pcol +! ;
5 | : pcr ( -- ) RET LF 1 prow +! pcol off ;
6 | : pdel ( -- ) DEL pcol @ 1- 0 max pcol ! ;
7 | : ppage ( -- ) FF prow off pcol off ;
8 | : pat ( row col -- ) over prow @ < IF ppage THEN
9 swap prow @ - 0 ?DO pcr LOOP
10 dup pcol @ < IF RET pcol off THEN pcol @ - spaces ;
11 | : pat? ( -- row col ) prow @ pcol @ ;
12 | : ptype ( adr len -- )
13 dup pcol +! bounds ?DO I c@ p! LOOP ;
14
15
Screen 8 not modified
0 \ Printer output 18nov86we
1
2 Output: >printer pemit pcr ptype pdel ppage pat pat? ;
3
4 Forth definitions
5
6 : print >printer normal ;
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Variables and Setup bp 12oct86
1
2 Printer definitions
3
4 ' 0 | Alias logo
5
6 | : header ( pageno -- )
7 12cpi +dark ." volksFORTH-83 FORTH-Gesellschaft eV "
8 -dark 17cpi ." (c) 1985/86 we/bp/re/ks " 12cpi +dark
9 file? -dark 17cpi ." Seite " . ;
10
11
12
13
14
15
Screen 10 not modified
0 \ Print 2 screens across on a page 26oct86we
1
2 | : 2lines ( scr#1 scr#2 line# -- )
3 cr dup 2 .r space c/l * >r
4 pad c/l 2* 1+ bl fill swap
5 block r@ + pad c/l cmove
6 block r> + pad c/l + 1+ c/l cmove
7 pad c/l 2* 1+ -trailing type ;
8
9 | : 2screens ( scr#1 scr#2 -- )
10 cr cr &30 spaces
11 +wide +dark over 4 .r &28 spaces dup 4 .r -wide -dark
12 cr l/s 0 DO 2dup I 2lines LOOP 2drop ;
13
14
15
Screen 11 not modified
0 \ print 6 screens on a page 18sep86we
1
2 | : pageprint ( last+1 first pageno -- )
3 header 2dup - 1+ 2/ dup 0
4 ?DO >r 2dup under r@ + >
5 IF dup r@ + ELSE logo THEN 2screens 1+ r> LOOP
6 drop 2drop page ;
7
8 | : >shadow ( n1 -- n2 )
9 capacity 2/ 2dup < IF + ELSE - THEN ;
10
11 | : shadowprint ( last+1 first pageno -- )
12 header 2dup - 0
13 ?DO dup dup >shadow 2screens 1+ LOOP
14 2drop page ;
15
Screen 12 not modified
0 \ Printing without Shadows b11nov86we
1
2 Forth definitions also
3
4 | Variable printersem 0 printersem ! \ for multitasking
5
6 : pthru ( first last -- ) 2 arguments
7 printersem lock output push print
8 1+ capacity umin swap 2dup - 6 /mod swap 0<> - 0
9 ?DO 2dup 6 + min over I 1+ pageprint 6 + LOOP
10 2drop printersem unlock ;
11
12 : printall ( -- ) 0 capacity 1- pthru ;
13
14
15
Screen 13 not modified
0 \ Printing with Shadows bp 12oct86
1
2 : document ( first last -- )
3 printersem lock output push print
4 1+ capacity 2/ umin swap 2dup - 3 /mod swap 0<> - 0
5 ?DO 2dup 3+ min over I 1+ shadowprint 3+ LOOP
6 2drop printersem unlock ;
7
8 : listing ( -- ) 0 capacity 2/ 1- document ;
9
10
11
12
13
14
15
Screen 14 not modified
0 \ Printerspool 14oct86we
1
2 \needs Task \\
3
4 $100 $200 Task spooler
5
6 : spool' ( -- ) \ reads word
7 ' isfile@ offset @ base @ spooler depth 1- 6 min pass
8 base ! offset ! isfile ! execute
9 true abort" SPOOL' ready for next job!" stop ;
10
11
12
13
14
15
Screen 15 not modified
0 \\ *** Printer-Interface *** 13oct86we
1
2 Eingestellt ist das Druckerinterface auf Epson und kompatible
3 Drucker. Die Steuersequenzen auf den Screens 2, 4 und 5 m<>ssen
4 gegebenenfalls auf Ihren Drucker angepažt werden. Bei uns gab
5 es mit verschiedenen Druckern allerdings keine Probleme, da
6 sich inzwischen die meisten Druckerhersteller an die Epson-
7 Steuercodes halten.
8
9 Arbeiten Sie mit einem IBM-kompatiblen Drucker, muž die Umlaut-
10 wandlung auf Screen 6 wegkommentiert werden.
11
12 Zus„tzliche 'exotische' Steuersequenzen k”nnen nach dem Muster
13 auf den Screens 4 und 5 jederzeit eingebaut werden.
14
15
Screen 16 not modified
0 \ Printer Interface Epson RX80 13oct86we
1
2 setzt order auf FORTH FORTH ONLY FORTH
3
4 falls das Fileinterface nicht im System ist, werden die ent-
5 sprechenden Worte ersetzt.
6
7 Printer-Worte erhalten ein eigenes Vocabulary.
8
9
10
11
12
13
14
15
Screen 17 not modified
0 \ Printer p! and controls 10oct86we
1
2 nur aus stilistischen Gr<47>nden. Das Folgende liest sich besser.
3
4 Hauptausgabewort; gibt ein Zeichen auf den Drucker aus. Es wird
5 gewartet, bis der Drucker bereit ist. (PAUSE f<>r Multitasking)
6
7
8 gibt Steuerzeichen an Drucker
9
10 Steuerzeichen f<>r Drucker. Gegebenenfalls anpassen!
11
12
13
14
15
Screen 18 not modified
0 \ Printer controls 10oct86we
1
2 gibt Escape-Sequenzen an den Drucker aus.
3
4 gibt Escape und zwei Zeichen aus.
5
6 gibt Escape, ein Zeichen und eine 1 an den Drucker aus.
7
8 gibt Escape, ein Zeichen und eine 0 an den Drucker aus.
9
10
11
12
13
14
15
Screen 19 not modified
0 \ Printer Escapes Epson RX-80/FX-80 10oct86we
1
2 setzt bzw. l”scht Ausgabe komprimierter Schrift.
3
4 setzt Zeichenbreite auf 10 bzw. 12 cpi.
5 Zeilenabstand in Zoll.
6 schaltet Super- und Subscript ab
7 Perforation <20>berspringen ein- und ausschalten.
8 Es folgen die Steuercodes f<>r Fettdruck, Kursivschrift, Breit-
9 schrift, Unterstreichen, Subscript und Superscript.
10 Diese m<>ssen ggf. an Ihren Drucker angepažt werden.
11 Selbstverst„ndlich k”nnen auch weitere F„higkeiten Ihres Druk-
12 kers genutzt werden wie Proportionalschrift, NLQ etc.
13
14
15
Screen 20 not modified
0 \ Printer Escapes Epson RX-80/FX-80 13oct86we
1
2 Hier wird die Zeichenbreite eingestellt. Dazu kann man sowohl
3 Worte mit der Anzahl der characters per inch (cpi) als auch
4 pica, elite und small benutzen.
5
6 setzt Anzahl der Zeilen pro Seite; Einstellung:
7 &66 lines oder &12 "long
8
9
10 schaltet auf amerikanischen Zeichensatz.
11
12 schaltet auf deutschen Zeichensatz.
13
14 Voreinstellung des Druckers auf 'normale' Werte; wird beim
15 Einschalten mit PRINT ausgef<65>hrt.
Screen 21 not modified
0 \ Umlaute bp 12oct86
1
2 Auf diesem Screen werden die Umlaute aus dem IBM-(ATARI)-Zeichen
3 satz in DIN-Umlaute aus dem deutschen Zeichensatz gewandelt.
4
5 Wenn Sie einen IBM-kompatiblen Drucker benutzen, kann dieser
6 Screen mit \\ in der ersten Zeile wegkommentiert werden.
7
8
9
10
11
12 p! wird neu definiert. Daher brauchen die folgenden Worte p!
13 nicht zu „ndern, egal, ob mit oder ohne Umlautwandlung gearbei-
14 tet wird.
15
Screen 22 not modified
0 \ Printer Output 10oct86we
1
2 aktuelle Druckerzeile und -spalte.
3 Routinen zur Druckerausgabe entspricht Befehl
4 ein Zeichen auf Drucker emit
5 CR und LF auf Drucker cr
6 ein Zeichen l”schen (?!) del
7 neue Seite page
8 Drucker auf Zeile und Spalte at
9 positionieren; wenn n”tig,
10 neue Seite.
11 Position feststellen at?
12 Zeichenkette ausgeben type
13
14 Damit sind die Worte f<>r eine eigene Output-Struktur vorhanden.
15
Screen 23 not modified
0 \ Printer output 10oct86we
1
2 erzeugt die Output-Tabelle >printer.
3
4 Die folgenden Worte sind von FORTH aus zug„nglich.
5
6 schaltet Ausgabe auf Printer um. (Zur<75>ckschalten mit DISPLAY)
7
8
9
10
11
12
13
14
15
Screen 24 not modified
0 \ Variables and Setup 10oct86we
1
2 Diese Worte sind nur im Printer-Vokabular enthalten.
3
4 Dieser Screen wird gedruckt, wenn es nichts besseres gibt.
5
6 Druckt die šberschrift der Seite pageno.
7
8
9
10
11
12
13
14
15
Screen 25 not modified
0 \ Print 2 screens across on a page 10oct86we
1
2 druckt nebeneinander die Zeilen line# der beiden Screens.
3 Die komplette Druck-Zeile wird erst in PAD aufbereitet.
4
5
6
7
8
9 formatierte Ausgabe der beiden Screens nebeneinander
10 mit fettgedruckten Screennummern. Druck erfolgt mit 17cpi, also
11 in komprimierter Schrift.
12
13
14
15
Screen 26 not modified
0 \ print 6 screens on a page 10oct86we
1
2 gibt eine Seite aus. Anordnung der Screens auf der Seite: 1 4
3 Wenn weniger als 6 Screens vorhanden sind, werden 2 5
4 L<>cken auf der rechten Seite mit dem Logo-Screen (0) 3 6
5 aufgef<65>llt.
6
7
8 berechnet zu Screen n1 den Shadowscreen n2 (Kommentarscreen wie
9 dieser hier).
10
11 wie pageprint, aber anstelle der Screens 4, 5 und 6 werden die
12 Shadowscreens zu 1, 2 und 3 gedruckt.
13
14
15
Screen 27 not modified
0 \ Printing without Shadows b22oct86we
1
2 Die folgenden Definitionen stellen das Benutzer-Interface dar.
3 Daher sollen sie in FORTH gefunden werden.
4
5 PRINTERSEM ist ein Semaphor f<>r das Multitasking, der den Zugang
6 auf den Drucker f<>r die einzelnen Tasks regelt.
7
8 PTHRU gibt die Screens von from bis to aus.
9 Ausgabeger„t merken und Drucker einschalten. Multitasking wird,
10 sofern es den Drucker betrifft, gesperrt.
11 Die Screens werden mit pageprint ausgegeben.
12
13
14 wie oben, jedoch wird das komplette File gedruckt.
15
Screen 28 not modified
0 \ Printing with Shadows 10oct86we
1
2 wie pthru, aber mit Shadowscreens.
3
4
5
6
7
8 wie printall, aber mit Shadowscreens.
9
10
11
12
13
14
15
Screen 29 not modified
0 \ Printerspool 10oct86we
1
2 Falls der Multitasker nicht vorhanden ist, wird abgebrochen.
3
4 Der Arbeitsbereich der Task wird erzeugt.
5
6 Mit diesem Wort wird das Drucken im Hintergrund gestartet.
7 Aufruf mit :
8 spool' listing
9 spool' printall
10 from to spool' pthru
11 from to spool' document
12 Vor (oder auch nach) dem Aufruf von spool' muž der Multitasker
13 mit multitask eingeschaltet werden.
14
15

510
sources/AtariST/PRINTER.fth Normal file
View File

@ -0,0 +1,510 @@
\ *** Block No. 0 Hexblock 0
\\ *** Printer-Interface *** 10oct86we
Dieses File enth„lt das Printer-Interface. Die Definitionen f<EFBFBD>r
die Druckersteuerung m<EFBFBD>ssen ggf. an Ihren Drucker angepažt wer-
den.
PRINT lenkt alle Ausgabeworte auf den Drucker um, mit DISPLAY
wird wieder auf dem Bildschirm ausgegeben.
Zum Ausdrucken der Quelltexte gibt es die Worte
pthru ( from to -- ) druckt Screen from bis to
document ( from to -- ) wie pthru, aber mit Shadow-Screens
printall ( -- ) wie pthru, aber druckt das ganze File
listing ( -- ) wie document, aber f<EFBFBD>r das ganze File
\ *** Block No. 1 Hexblock 1
\ Printer Interface Epson RX80\FX80 21oct86we
Onlyforth
\needs file? ' noop | Alias file?
\needs capacity ' blk/drv Alias capacity
Vocabulary Printer Printer definitions also
1 &13 +thru
Onlyforth \ clear
\ *** Block No. 2 Hexblock 2
\ Printer p! and controls 18nov86we
' bcostat | Alias ready? ' 0 | Alias printer
: p! ( n -- )
BEGIN pause printer ready? UNTIL printer bconout ;
| : ctrl: ( 8b -- ) Create c, does> ( -- ) c@ p! ;
07 ctrl: BEL $7F | ctrl: DEL $0D | ctrl: RET
$1B | ctrl: ESC $0A ctrl: LF $0C ctrl: FF
\ *** Block No. 3 Hexblock 3
\ Printer controls 09sep86re
| : esc: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! ;
| : esc2 ( 8b0 8b1 -- ) ESC p! p! ;
| : on: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 1 p! ;
| : off: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 0 p! ;
\ *** Block No. 4 Hexblock 4
\ Printer Escapes Epson RX-80/FX-80 12sep86re
$0F | ctrl: (+17cpi $12 | ctrl: (-17cpi
Ascii P | esc: (+10cpi Ascii M | esc: (+12cpi
Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
Ascii 2 esc: 1/6" Ascii T esc: suoff
Ascii N esc: +jump Ascii O esc: -jump
Ascii G esc: +dark Ascii H esc: -dark
\ Ascii 4 esc: +cursive Ascii 5 esc: -cursive
Ascii W on: +wide Ascii W off: -wide
Ascii - on: +under Ascii - off: -under
Ascii S on: sub Ascii S off: super
\ *** Block No. 5 Hexblock 5
\ Printer Escapes Epson RX-80/FX-80 12sep86re
: 10cpi (-17cpi (+10cpi ; ' 10cpi Alias pica
: 12cpi (-17cpi (+12cpi ; ' 12cpi Alias elite
: 17cpi (+10cpi (+17cpi ; ' 17cpi Alias small
: lines ( #.of.lines -- ) Ascii C esc2 ;
: "long ( inches -- ) 0 lines p! ;
: american 0 Ascii R esc2 ;
: german 2 Ascii R esc2 ;
: normal 10cpi american suoff 1/6" &12 "long RET ;
\ *** Block No. 6 Hexblock 6
\ Umlaute 14oct86we
| Create DIN
Ascii „ c, Ascii ” c, Ascii <EFBFBD> c, Ascii ž c,
Ascii Ž c, Ascii ™ c, Ascii š c, Ascii Ý c,
| Create AMI
Ascii { c, Ascii | c, Ascii } c, Ascii ~ c,
Ascii [ c, Ascii \ c, Ascii ] c, Ascii @ c,
here AMI - | Constant tablen
| : p! ( char -- ) dup $80 < IF p! exit THEN
tablen 0 DO dup I DIN + c@ =
IF drop I AMI + c@ LEAVE THEN LOOP
german p! american ;
\ *** Block No. 7 Hexblock 7
\ Printer Output 12sep86re
| Variable pcol pcol off | Variable prow prow off
| : pemit ( 8b -- ) p! 1 pcol +! ;
| : pcr ( -- ) RET LF 1 prow +! pcol off ;
| : pdel ( -- ) DEL pcol @ 1- 0 max pcol ! ;
| : ppage ( -- ) FF prow off pcol off ;
| : pat ( row col -- ) over prow @ < IF ppage THEN
swap prow @ - 0 ?DO pcr LOOP
dup pcol @ < IF RET pcol off THEN pcol @ - spaces ;
| : pat? ( -- row col ) prow @ pcol @ ;
| : ptype ( adr len -- )
dup pcol +! bounds ?DO I c@ p! LOOP ;
\ *** Block No. 8 Hexblock 8
\ Printer output 18nov86we
Output: >printer pemit pcr ptype pdel ppage pat pat? ;
Forth definitions
: print >printer normal ;
\ *** Block No. 9 Hexblock 9
\ Variables and Setup bp 12oct86
Printer definitions
' 0 | Alias logo
| : header ( pageno -- )
12cpi +dark ." volksFORTH-83 FORTH-Gesellschaft eV "
-dark 17cpi ." (c) 1985/86 we/bp/re/ks " 12cpi +dark
file? -dark 17cpi ." Seite " . ;
\ *** Block No. 10 Hexblock A
\ Print 2 screens across on a page 26oct86we
| : 2lines ( scr#1 scr#2 line# -- )
cr dup 2 .r space c/l * >r
pad c/l 2* 1+ bl fill swap
block r@ + pad c/l cmove
block r> + pad c/l + 1+ c/l cmove
pad c/l 2* 1+ -trailing type ;
| : 2screens ( scr#1 scr#2 -- )
cr cr &30 spaces
+wide +dark over 4 .r &28 spaces dup 4 .r -wide -dark
cr l/s 0 DO 2dup I 2lines LOOP 2drop ;
\ *** Block No. 11 Hexblock B
\ print 6 screens on a page 18sep86we
| : pageprint ( last+1 first pageno -- )
header 2dup - 1+ 2/ dup 0
?DO >r 2dup under r@ + >
IF dup r@ + ELSE logo THEN 2screens 1+ r> LOOP
drop 2drop page ;
| : >shadow ( n1 -- n2 )
capacity 2/ 2dup < IF + ELSE - THEN ;
| : shadowprint ( last+1 first pageno -- )
header 2dup - 0
?DO dup dup >shadow 2screens 1+ LOOP
2drop page ;
\ *** Block No. 12 Hexblock C
\ Printing without Shadows b11nov86we
Forth definitions also
| Variable printersem 0 printersem ! \ for multitasking
: pthru ( first last -- ) 2 arguments
printersem lock output push print
1+ capacity umin swap 2dup - 6 /mod swap 0<> - 0
?DO 2dup 6 + min over I 1+ pageprint 6 + LOOP
2drop printersem unlock ;
: printall ( -- ) 0 capacity 1- pthru ;
\ *** Block No. 13 Hexblock D
\ Printing with Shadows bp 12oct86
: document ( first last -- )
printersem lock output push print
1+ capacity 2/ umin swap 2dup - 3 /mod swap 0<> - 0
?DO 2dup 3+ min over I 1+ shadowprint 3+ LOOP
2drop printersem unlock ;
: listing ( -- ) 0 capacity 2/ 1- document ;
\ *** Block No. 14 Hexblock E
\ Printerspool 14oct86we
\needs Task \\
$100 $200 Task spooler
: spool' ( -- ) \ reads word
' isfile@ offset @ base @ spooler depth 1- 6 min pass
base ! offset ! isfile ! execute
true abort" SPOOL' ready for next job!" stop ;
\ *** Block No. 15 Hexblock F
\\ *** Printer-Interface *** 13oct86we
Eingestellt ist das Druckerinterface auf Epson und kompatible
Drucker. Die Steuersequenzen auf den Screens 2, 4 und 5 m<EFBFBD>ssen
gegebenenfalls auf Ihren Drucker angepažt werden. Bei uns gab
es mit verschiedenen Druckern allerdings keine Probleme, da
sich inzwischen die meisten Druckerhersteller an die Epson-
Steuercodes halten.
Arbeiten Sie mit einem IBM-kompatiblen Drucker, muž die Umlaut-
wandlung auf Screen 6 wegkommentiert werden.
Zus„tzliche 'exotische' Steuersequenzen k”nnen nach dem Muster
auf den Screens 4 und 5 jederzeit eingebaut werden.
\ *** Block No. 16 Hexblock 10
\ Printer Interface Epson RX80 13oct86we
setzt order auf FORTH FORTH ONLY FORTH
falls das Fileinterface nicht im System ist, werden die ent-
sprechenden Worte ersetzt.
Printer-Worte erhalten ein eigenes Vocabulary.
\ *** Block No. 17 Hexblock 11
\ Printer p! and controls 10oct86we
nur aus stilistischen Gr<EFBFBD>nden. Das Folgende liest sich besser.
Hauptausgabewort; gibt ein Zeichen auf den Drucker aus. Es wird
gewartet, bis der Drucker bereit ist. (PAUSE f<EFBFBD>r Multitasking)
gibt Steuerzeichen an Drucker
Steuerzeichen f<EFBFBD>r Drucker. Gegebenenfalls anpassen!
\ *** Block No. 18 Hexblock 12
\ Printer controls 10oct86we
gibt Escape-Sequenzen an den Drucker aus.
gibt Escape und zwei Zeichen aus.
gibt Escape, ein Zeichen und eine 1 an den Drucker aus.
gibt Escape, ein Zeichen und eine 0 an den Drucker aus.
\ *** Block No. 19 Hexblock 13
\ Printer Escapes Epson RX-80/FX-80 10oct86we
setzt bzw. l”scht Ausgabe komprimierter Schrift.
setzt Zeichenbreite auf 10 bzw. 12 cpi.
Zeilenabstand in Zoll.
schaltet Super- und Subscript ab
Perforation <EFBFBD>berspringen ein- und ausschalten.
Es folgen die Steuercodes f<EFBFBD>r Fettdruck, Kursivschrift, Breit-
schrift, Unterstreichen, Subscript und Superscript.
Diese m<EFBFBD>ssen ggf. an Ihren Drucker angepažt werden.
Selbstverst„ndlich k”nnen auch weitere F„higkeiten Ihres Druk-
kers genutzt werden wie Proportionalschrift, NLQ etc.
\ *** Block No. 20 Hexblock 14
\ Printer Escapes Epson RX-80/FX-80 13oct86we
Hier wird die Zeichenbreite eingestellt. Dazu kann man sowohl
Worte mit der Anzahl der characters per inch (cpi) als auch
pica, elite und small benutzen.
setzt Anzahl der Zeilen pro Seite; Einstellung:
&66 lines oder &12 "long
schaltet auf amerikanischen Zeichensatz.
schaltet auf deutschen Zeichensatz.
Voreinstellung des Druckers auf 'normale' Werte; wird beim
Einschalten mit PRINT ausgef<EFBFBD>hrt.
\ *** Block No. 21 Hexblock 15
\ Umlaute bp 12oct86
Auf diesem Screen werden die Umlaute aus dem IBM-(ATARI)-Zeichen
satz in DIN-Umlaute aus dem deutschen Zeichensatz gewandelt.
Wenn Sie einen IBM-kompatiblen Drucker benutzen, kann dieser
Screen mit \\ in der ersten Zeile wegkommentiert werden.
p! wird neu definiert. Daher brauchen die folgenden Worte p!
nicht zu „ndern, egal, ob mit oder ohne Umlautwandlung gearbei-
tet wird.
\ *** Block No. 22 Hexblock 16
\ Printer Output 10oct86we
aktuelle Druckerzeile und -spalte.
Routinen zur Druckerausgabe entspricht Befehl
ein Zeichen auf Drucker emit
CR und LF auf Drucker cr
ein Zeichen l”schen (?!) del
neue Seite page
Drucker auf Zeile und Spalte at
positionieren; wenn n”tig,
neue Seite.
Position feststellen at?
Zeichenkette ausgeben type
Damit sind die Worte f<EFBFBD>r eine eigene Output-Struktur vorhanden.
\ *** Block No. 23 Hexblock 17
\ Printer output 10oct86we
erzeugt die Output-Tabelle >printer.
Die folgenden Worte sind von FORTH aus zug„nglich.
schaltet Ausgabe auf Printer um. (Zur<75>ckschalten mit DISPLAY)
\ *** Block No. 24 Hexblock 18
\ Variables and Setup 10oct86we
Diese Worte sind nur im Printer-Vokabular enthalten.
Dieser Screen wird gedruckt, wenn es nichts besseres gibt.
Druckt die šberschrift der Seite pageno.
\ *** Block No. 25 Hexblock 19
\ Print 2 screens across on a page 10oct86we
druckt nebeneinander die Zeilen line# der beiden Screens.
Die komplette Druck-Zeile wird erst in PAD aufbereitet.
formatierte Ausgabe der beiden Screens nebeneinander
mit fettgedruckten Screennummern. Druck erfolgt mit 17cpi, also
in komprimierter Schrift.
\ *** Block No. 26 Hexblock 1A
\ print 6 screens on a page 10oct86we
gibt eine Seite aus. Anordnung der Screens auf der Seite: 1 4
Wenn weniger als 6 Screens vorhanden sind, werden 2 5
L<EFBFBD>cken auf der rechten Seite mit dem Logo-Screen (0) 3 6
aufgef<EFBFBD>llt.
berechnet zu Screen n1 den Shadowscreen n2 (Kommentarscreen wie
dieser hier).
wie pageprint, aber anstelle der Screens 4, 5 und 6 werden die
Shadowscreens zu 1, 2 und 3 gedruckt.
\ *** Block No. 27 Hexblock 1B
\ Printing without Shadows b22oct86we
Die folgenden Definitionen stellen das Benutzer-Interface dar.
Daher sollen sie in FORTH gefunden werden.
PRINTERSEM ist ein Semaphor f<EFBFBD>r das Multitasking, der den Zugang
auf den Drucker f<EFBFBD>r die einzelnen Tasks regelt.
PTHRU gibt die Screens von from bis to aus.
Ausgabeger„t merken und Drucker einschalten. Multitasking wird,
sofern es den Drucker betrifft, gesperrt.
Die Screens werden mit pageprint ausgegeben.
wie oben, jedoch wird das komplette File gedruckt.
\ *** Block No. 28 Hexblock 1C
\ Printing with Shadows 10oct86we
wie pthru, aber mit Shadowscreens.
wie printall, aber mit Shadowscreens.
\ *** Block No. 29 Hexblock 1D
\ Printerspool 10oct86we
Falls der Multitasker nicht vorhanden ist, wird abgebrochen.
Der Arbeitsbereich der Task wird erzeugt.
Mit diesem Wort wird das Drucken im Hintergrund gestartet.
Aufruf mit :
spool' listing
spool' printall
from to spool' pthru
from to spool' document
Vor (oder auch nach) dem Aufruf von spool' muž der Multitasker
mit multitask eingeschaltet werden.

442
sources/AtariST/RAMDISK.FB.src
View File

@ -1,442 +0,0 @@
Screen 0 not modified
0 HOW TO USE THE RAMDISK bp 17Aug86
1
2 Die Ramdisk ist im Prinzip ein erweiterter Buffermechanismus,
3 der Buffer aužerhalb des Forth-Systems verwaltet. Die Organi-
4 sation ist analog, mit der Ausnahme, daž es kein Updateflag
5 gibt, ge„nderte Bl”cke also sofort auf die Diskette zur<75>ckge-
6 schrieben werden. Die Benutzung ist v”llig transparent, am
7 Anfang muž nur einmal INITRAMDISK aufgerufen werden.
8
9 Die Struktur der Buffer wird auf Screen 3 dargestellt.
10
11 Die Ramdisk allokiert ihren Speicher mit MALLOC.
12
13
14
15
Screen 1 not modified
0 \ loadscreen for more buffers bp 17Aug86
1
2 \needs 2over include double.scr
3
4 Onlyforth
5
6 \needs 4dup : 4dup 2over 2over ;
7 \needs 4drop : 4drop 2drop 2drop ;
8 \needs user' : user' ' >body c@ ;
9 \needs d> : d> 2swap d< ;
10
11 2 $B +thru
12
13 1 +load \ patch ramdisk into system
14
15
Screen 2 not modified
0 \ patch ramdisk into System bp 17Aug86
1
2 | : ((close ( fcb -- fcb ...) \ word for patch (CLOSE !!
3 dup flushramfile [ Dos ' (close >body @ , ] ;
4
5 | : (empty-buffers ( -- ...) \ word for patching EMPTY-BUFFE
6 emptyramdisk [ ' empty-buffers >body @ , ] ;
7
8
9 ' ramdiskr/w is r/w
10 ' ((close Dos ' (close >body !
11 ' (empty-buffers ' empty-buffers >body !
12
13 save
14 initramdisk
15
Screen 3 not modified
0 \ Variables and Constants bp 10Aug86
1
2 2Variable ramprev 0. ramprev 2! \ points to first buffer
3 2Variable ramfirst 0. ramfirst 2! \ start of buffer area
4 2Variable ramsize 0. ramsize 2! \ length of buffer area
5
6 $408 Constant b/rambuf
7
8 | Code link>file ( d1 -- d2 ) .l 4 SP ) addq
9 Label >next Next end-code
10 | Code link>block .l 6 SP ) addq >next bra end-code
11 | Code link>data .l 8 SP ) addq >next bra end-code
12 \\
13 structure of a buffer:
14 | link to next buffer | file | block | data .... |
15 +0 +4 +6 +8 +1032
Screen 4 not modified
0 \ search for a buffer bp 24Aug86
1 \ D0:blk D1:file A0:bufadr A1:Vorgaenger
2 Label thisbuffer?
3 4 A0 D) D1 cmp 0= IF 6 A0 D) D0 cmp THEN rts
4
5 Code rambuf? ( blk file -- dadr tf \ blk file )
6 2 SP D) D0 move SP ) D1 move
7 .l ramprev r#) A0 move .w thisbuffer? bsr
8 0= IF Label blockfound .l 8. # A0 adda A0 SP ) move .w
9 true # SP -) move Next THEN
10 BEGIN .l A0 A1 move A1 ) A0 move 0. # A0 cmpa .w
11 0= IF false # SP -) move Next THEN
12 thisbuffer? bsr 0= UNTIL
13 .l A0 ) A1 ) move
14 ramprev r#) A0 ) move A0 ramprev r#) move .w
15 blockfound bra end-code
Screen 5 not modified
0 \ read and write buffers b28sep86we
1
2 | : readrambuf ( adr daddr -- ) \ copy from daddr to adr
3 rot >absaddr b/blk lcmove ;
4
5 | : writerambuf ( adr daddr --) \ copy from adr to daddr
6 rot >absaddr 2swap b/blk lcmove ;
7
8
9
10
11
12
13
14
15
Screen 6 not modified
0 \ search for empty buffer bp 10Aug86
1
2 \ : takerambuf ( -- daddr ) \ get last buffer
3 \ ramprev 2@
4 \ BEGIN 2dup link>file l@ 1+ ( empty buffer ? )
5 \ WHILE 2dup l2@ or ( last buffer ? )
6 \ WHILE l2@ REPEAT ;
7
8 | Code takerambuf ( -- daddr )
9 .l ramprev r#) A0 move
10 Label takeloop .w -1 4 A0 D) cmpi
11 0<> IF .l A0 ) tst 0<>
12 IF A0 ) A0 move takeloop bra THEN THEN
13 A0 SP -) move Next end-code
14
15
Screen 7 not modified
0 \ allocate a buffer bp 24Aug86
1
2 | 2Variable (daddr
3
4 \ | : markrambuf ( blk file daddr -- daddr )
5 \ 2dup (daddr 2! link>file l! (daddr 2@ link>block l!
6 \ (daddr 2@ ;
7
8 | Code markrambuf ( blk file daddr -- daddr ) .l
9 SP )+ A0 move .w SP )+ 4 A0 D) move
10 SP )+ 6 A0 D) move .l A0 SP -) move Next end-code
11
12 | : makerambuf ( adr blk file -- ) \ create a buffer
13 BEGIN rambuf? 0= WHILE 2dup takerambuf markrambuf
14 2drop REPEAT writerambuf ;
15
Screen 8 not modified
0 \ clear buffers bp 10Aug86
1
2 : clearrambuf ( laddr -- ) \ clear a buffer
3 link>file -1 -rot l! ;
4
5 : flushramfile ( fcb -- ) \ clear all buffers of a file
6 >r ramprev 2@
7 BEGIN 2dup or
8 WHILE 2dup link>file l@ r@ = IF 2dup clearrambuf THEN
9 l2@ REPEAT 2drop rdrop ;
10
11
12
13
14
15
Screen 9 not modified
0 \ allocate all buffers bp 10Aug86
1
2 | : nextbuf ( d1 -- d2) \ adr of next buffer
3 b/rambuf extend d+ ;
4
5 | : ramfull? ( daddr -- f) \ true if more buffers
6 nextbuf ramsize 2@ ramfirst 2@ d+ d> 0= ;
7
8 : emptyramdisk ( -- ) \ initialize ramdisk
9 0. ramprev 2! ramfirst 2@
10 BEGIN 2dup ramfull?
11 WHILE 2dup clearrambuf ( clear buffer )
12 ramprev 2@ 2over l2! ( chain to list )
13 2dup ramprev 2! ( store last buffer )
14 nextbuf REPEAT 2drop ;
15
Screen 10 not modified
0 \ Interactive memory allocation bp 17Aug86
1
2 : #in ( -- n) query name number drop ;
3
4 : initramdisk ( -- )
5 [ Dos ] 0. ramprev 2!
6 ramfirst 2@ or IF ramfirst 2@ mfree
7 drop ?diskabort 0. ramfirst 2! THEN
8 cr ." Wie viele Kilos sollen es sein ? " #in
9 b/rambuf um* 2. d+ 2dup malloc ( 2 Angstbytes zus.)
10 dup 0< IF drop ?diskabort THEN ( Fehler !)
11 dup 0= abort" Speicher voll !!" ( DR sei Dank gesagt !)
12 ramfirst 2! ramsize 2!
13 emptyramdisk ;
14
15
Screen 11 not modified
0 \ new r/w bp 10Aug86
1
2 ' r/w >body @ Alias oldr/w
3
4 : ramdiskr/w ( adr blk file rw/f -- f )
5 ramprev 2@ or 0= IF oldr/w exit THEN
6 dup >r
7 IF rambuf? IF readrambuf rdrop false exit THEN THEN
8 r> 4dup oldr/w
9 IF 4drop true exit THEN \ disk error !
10 drop makerambuf false ; \ create or overwrite buffer
11
12
13
14
15
Screen 12 not modified
0 \ print a list of ram buffers bp 10Aug86
1
2 : .rambufs ( -- )
3 ramprev 2@
4 BEGIN 2dup or
5 WHILE cr 2dup 8 d.r 5 spaces \ adress
6 2dup link>file l@
7 dup 1+ IF [ Dos ] .file 4 spaces
8 2dup link>block l@ 5 .r
9 ELSE drop ." empty" THEN
10 l2@ stop? UNTIL 2drop ;
11
12
13
14
15
Screen 13 not modified
0 \ Wichtige Worte sind bp 17Aug86
1
2 INITRAMDISK ( -- ) fragt nach der Zahl der Anzahl der
3 anzulegenden Buffer und erzeugt sie.
4
5 EMPTYRAMDISK ( -- ) l”scht den Inhalt aller Buffer.
6
7 RAMBUF? ( blk file -- dadr tf \ blk file ff )
8 sucht den Buffer blk im File file in der Ramdisk.
9
10 CLEARRAMBUF? ( laddr -- )
11 markiert den Ramdiskbuffer bei Adr. laddr als leer.
12
13
14 ..
15
Screen 14 not modified
0 bp 17Aug86
1
2
3
4
5
6 Wird in RAMDISKR\W benutzt
7
8 Gibt Offset einer Uservariablen in der Userarea. Dieses
9 Wort geh”rt eigentlich in den Assembler !
10
11
12
13
14
15
Screen 15 not modified
0 bp 17Aug86
1
2 Dieses Wort wird in (CLOSE gepatched. FCB ist die Adresse des
3 zu schlieženden Files. Alle Blockpuffer dieses Files werden
4 gel”scht.
5 Dieses Wort wird in EMPTY-BUFFERS gepatched. Es l”scht alle
6 Ramdiskpuffer
7
8
9 Neues R/W
10 Patche (CLOSE
11 Patche EMPTY-BUFFERS
12
13
14 Frage nach der Gr”že der Ramdisk
15
Screen 16 not modified
0 bp 17Aug86
1
2 Zeiger auf den ersten Buffer in der Ramdisk.
3 Beginn des f<>r die Ramdisk allokierten Speicherbereichs
4 L„nge " " " " " "
5
6 L„nge eines Buffers der Ramdisk
7
8 Diese Worte erlauben den Zugriff auf die Felder eines
9 Ramdiskbuffers.
10
11
12
13 Dies ist die Struktur eines Ramdiskbuffers. Alle Buffer befinden
14 sich in einer gelinkten Liste, analog zum volksFORTH83-Block=
15 =buffermechanismus.
Screen 17 not modified
0 bp 17Aug86
1
2
3
4
5 Sucht einen Buffer in der Ramdisk. Gesucht wird der Buffer
6 mit der Nummer BLK aus dem File mit der Nummer FCB.
7 Zun„chst wird der erste Eintrag untersucht (weniger Rechenzeit).
8 Ist es nicht der oberste, so werden die restlichen Buffer
9 verglichen. Wurde er gefunden, so wird der betreffende Buffer
10 an den Anfang der Liste geh„ngt, so daž die Buffer immer in
11 der Reihenfolge des Zugriffs geordnet sind. Dadurch wird die
12 Zugriffsgeschwindigkeit erh”ht.
13
14
15
Screen 18 not modified
0 bp 17Aug86
1
2 Kopiert den Inhalt des Ramdiskbuffers in den Blockbuffer des
3 volksFORTH-Systems
4
5 Kopiert den Inhalt des Blockbuffers im System in den Ramdisk=
6 =buffer.
7
8 Diese beiden Worte k”nnen noch optimiert werden, da LCMOVE
9 byteweise <20>bertr„gt, aber auch langwortweise <20>bertragen
10 werden kann.
11
12
13
14
15
Screen 19 not modified
0 bp 17Aug86
1
2 Dieses Wort sucht einen leeren Ramdiskbuffer. Ist keiner leer,
3 so wird der letzte Buffer in der Liste genommen.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 20 not modified
0 bp 24Aug86
1
2 Hilfsvariable
3
4 Markiert den Ramdiskbuffer DADDR als Buffer f<>r den Block BLK
5 im File FILE.
6
7
8
9
10
11
12 Erzeugt einen Buffer f<>r den Blockl BLK des Files FILE in der
13 Ramdisk. Der Inhalt des Buffers steht ab Adresse ADR im System.
14 RAMBUF? wird benutzt, um den allokierten Buffer an die erste
15 Stelle zu h„ngen. Der WHILE-Teil wird max. einmal durchlaufen !
Screen 21 not modified
0 bp 17Aug86
1
2 L”scht den Buffer LADDR.
3
4
5 L”scht alle Ramdiskbuffer, die zum File FCB geh”ren.
6
7
8
9
10
11
12
13
14
15
Screen 22 not modified
0 bp 17Aug86
1
2 Berechnet die Adresse D2 des Ramdiskbuffers, der auf den Buffer
3 mit der Adresse D1 folgt.
4
5 F ist wahr, falls noch weitere Buffer in der Ramdisk allokiert
6 werden k”nnen.
7
8 Initialisiert die Ramdisk. Es werden soviele Buffer angelegt,
9 wie in den durch RAMFIRST und RAMSIZE angegebenen Speicher=
10 =bereich passen. Alle allokierten Buffer werden als leer
11 markiert.
12
13
14
15
Screen 23 not modified
0 bp 17Aug86
1
2 Liest eine Zahl von der Tastatur ein
3
4 Erzeugt die Ramdisk. Zun„chst wird der alte Speicherbereich
5 freigegeben, falls einer allokiert war. Dann wird nach der
6 gew<65>nschten Zahl von Buffern gefragt. Es wird ein Speicher=
7 =bereich vom GEM-Dos angeordert und mit leeren Buffern
8 gef<65>llt.
9
10
11
12
13
14
15
Screen 24 not modified
0 bp 17Aug86
1
2 Die alte R/W-Routine wird nat<61>rlich auch ben”tigt.
3
4 Kommuniziert mit den Massenspeichern.
5 RW/F ist wahr, falls ein Lesezugriff erfolgen soll.
6 Ist die Ramdisk leer, so darf sie nicht angesprochen werden !
7 Sonst wird gepr<70>ft, ob es sich um einen Lesezugriff handelt
8 und ob der Buffer in der Ramdisk vorliegt. Ist das der Fall,
9 so wird einfach dessen Inhalt kopiert. Andernfalls muž, falls
10 noch nicht vorhanden, ein Buffer allokiert werden. Der Inhalt
11 des Systembuffers wird dann in die Ramdisk kopiert und steht
12 beim n„chsten Lesezugriff zur Verf<72>gung.
13
14
15
Screen 25 not modified
0 bp 17Aug86
1
2 Es wird eine Liste mit dem Inhalt aller Ramdiskbuffer ausgegeben
3
4
5
6
7
8
9
10
11
12
13
14
15

442
sources/AtariST/RAMDISK.fth Normal file
View File

@ -0,0 +1,442 @@
\ *** Block No. 0 Hexblock 0
HOW TO USE THE RAMDISK bp 17Aug86
Die Ramdisk ist im Prinzip ein erweiterter Buffermechanismus,
der Buffer aužerhalb des Forth-Systems verwaltet. Die Organi-
sation ist analog, mit der Ausnahme, daž es kein Updateflag
gibt, ge„nderte Bl”cke also sofort auf die Diskette zur<EFBFBD>ckge-
schrieben werden. Die Benutzung ist v”llig transparent, am
Anfang muž nur einmal INITRAMDISK aufgerufen werden.
Die Struktur der Buffer wird auf Screen 3 dargestellt.
Die Ramdisk allokiert ihren Speicher mit MALLOC.
\ *** Block No. 1 Hexblock 1
\ loadscreen for more buffers bp 17Aug86
\needs 2over include double.scr
Onlyforth
\needs 4dup : 4dup 2over 2over ;
\needs 4drop : 4drop 2drop 2drop ;
\needs user' : user' ' >body c@ ;
\needs d> : d> 2swap d< ;
2 $B +thru
1 +load \ patch ramdisk into system
\ *** Block No. 2 Hexblock 2
\ patch ramdisk into System bp 17Aug86
| : ((close ( fcb -- fcb ...) \ word for patch (CLOSE !!
dup flushramfile [ Dos ' (close >body @ , ] ;
| : (empty-buffers ( -- ...) \ word for patching EMPTY-BUFFE
emptyramdisk [ ' empty-buffers >body @ , ] ;
' ramdiskr/w is r/w
' ((close Dos ' (close >body !
' (empty-buffers ' empty-buffers >body !
save
initramdisk
\ *** Block No. 3 Hexblock 3
\ Variables and Constants bp 10Aug86
2Variable ramprev 0. ramprev 2! \ points to first buffer
2Variable ramfirst 0. ramfirst 2! \ start of buffer area
2Variable ramsize 0. ramsize 2! \ length of buffer area
$408 Constant b/rambuf
| Code link>file ( d1 -- d2 ) .l 4 SP ) addq
Label >next Next end-code
| Code link>block .l 6 SP ) addq >next bra end-code
| Code link>data .l 8 SP ) addq >next bra end-code
\\
structure of a buffer:
| link to next buffer | file | block | data .... |
+0 +4 +6 +8 +1032
\ *** Block No. 4 Hexblock 4
\ search for a buffer bp 24Aug86
\ D0:blk D1:file A0:bufadr A1:Vorgaenger
Label thisbuffer?
4 A0 D) D1 cmp 0= IF 6 A0 D) D0 cmp THEN rts
Code rambuf? ( blk file -- dadr tf \ blk file )
2 SP D) D0 move SP ) D1 move
.l ramprev r#) A0 move .w thisbuffer? bsr
0= IF Label blockfound .l 8. # A0 adda A0 SP ) move .w
true # SP -) move Next THEN
BEGIN .l A0 A1 move A1 ) A0 move 0. # A0 cmpa .w
0= IF false # SP -) move Next THEN
thisbuffer? bsr 0= UNTIL
.l A0 ) A1 ) move
ramprev r#) A0 ) move A0 ramprev r#) move .w
blockfound bra end-code
\ *** Block No. 5 Hexblock 5
\ read and write buffers b28sep86we
| : readrambuf ( adr daddr -- ) \ copy from daddr to adr
rot >absaddr b/blk lcmove ;
| : writerambuf ( adr daddr --) \ copy from adr to daddr
rot >absaddr 2swap b/blk lcmove ;
\ *** Block No. 6 Hexblock 6
\ search for empty buffer bp 10Aug86
\ : takerambuf ( -- daddr ) \ get last buffer
\ ramprev 2@
\ BEGIN 2dup link>file l@ 1+ ( empty buffer ? )
\ WHILE 2dup l2@ or ( last buffer ? )
\ WHILE l2@ REPEAT ;
| Code takerambuf ( -- daddr )
.l ramprev r#) A0 move
Label takeloop .w -1 4 A0 D) cmpi
0<> IF .l A0 ) tst 0<>
IF A0 ) A0 move takeloop bra THEN THEN
A0 SP -) move Next end-code
\ *** Block No. 7 Hexblock 7
\ allocate a buffer bp 24Aug86
| 2Variable (daddr
\ | : markrambuf ( blk file daddr -- daddr )
\ 2dup (daddr 2! link>file l! (daddr 2@ link>block l!
\ (daddr 2@ ;
| Code markrambuf ( blk file daddr -- daddr ) .l
SP )+ A0 move .w SP )+ 4 A0 D) move
SP )+ 6 A0 D) move .l A0 SP -) move Next end-code
| : makerambuf ( adr blk file -- ) \ create a buffer
BEGIN rambuf? 0= WHILE 2dup takerambuf markrambuf
2drop REPEAT writerambuf ;
\ *** Block No. 8 Hexblock 8
\ clear buffers bp 10Aug86
: clearrambuf ( laddr -- ) \ clear a buffer
link>file -1 -rot l! ;
: flushramfile ( fcb -- ) \ clear all buffers of a file
>r ramprev 2@
BEGIN 2dup or
WHILE 2dup link>file l@ r@ = IF 2dup clearrambuf THEN
l2@ REPEAT 2drop rdrop ;
\ *** Block No. 9 Hexblock 9
\ allocate all buffers bp 10Aug86
| : nextbuf ( d1 -- d2) \ adr of next buffer
b/rambuf extend d+ ;
| : ramfull? ( daddr -- f) \ true if more buffers
nextbuf ramsize 2@ ramfirst 2@ d+ d> 0= ;
: emptyramdisk ( -- ) \ initialize ramdisk
0. ramprev 2! ramfirst 2@
BEGIN 2dup ramfull?
WHILE 2dup clearrambuf ( clear buffer )
ramprev 2@ 2over l2! ( chain to list )
2dup ramprev 2! ( store last buffer )
nextbuf REPEAT 2drop ;
\ *** Block No. 10 Hexblock A
\ Interactive memory allocation bp 17Aug86
: #in ( -- n) query name number drop ;
: initramdisk ( -- )
[ Dos ] 0. ramprev 2!
ramfirst 2@ or IF ramfirst 2@ mfree
drop ?diskabort 0. ramfirst 2! THEN
cr ." Wie viele Kilos sollen es sein ? " #in
b/rambuf um* 2. d+ 2dup malloc ( 2 Angstbytes zus.)
dup 0< IF drop ?diskabort THEN ( Fehler !)
dup 0= abort" Speicher voll !!" ( DR sei Dank gesagt !)
ramfirst 2! ramsize 2!
emptyramdisk ;
\ *** Block No. 11 Hexblock B
\ new r/w bp 10Aug86
' r/w >body @ Alias oldr/w
: ramdiskr/w ( adr blk file rw/f -- f )
ramprev 2@ or 0= IF oldr/w exit THEN
dup >r
IF rambuf? IF readrambuf rdrop false exit THEN THEN
r> 4dup oldr/w
IF 4drop true exit THEN \ disk error !
drop makerambuf false ; \ create or overwrite buffer
\ *** Block No. 12 Hexblock C
\ print a list of ram buffers bp 10Aug86
: .rambufs ( -- )
ramprev 2@
BEGIN 2dup or
WHILE cr 2dup 8 d.r 5 spaces \ adress
2dup link>file l@
dup 1+ IF [ Dos ] .file 4 spaces
2dup link>block l@ 5 .r
ELSE drop ." empty" THEN
l2@ stop? UNTIL 2drop ;
\ *** Block No. 13 Hexblock D
\ Wichtige Worte sind bp 17Aug86
INITRAMDISK ( -- ) fragt nach der Zahl der Anzahl der
anzulegenden Buffer und erzeugt sie.
EMPTYRAMDISK ( -- ) l”scht den Inhalt aller Buffer.
RAMBUF? ( blk file -- dadr tf \ blk file ff )
sucht den Buffer blk im File file in der Ramdisk.
CLEARRAMBUF? ( laddr -- )
markiert den Ramdiskbuffer bei Adr. laddr als leer.
..
\ *** Block No. 14 Hexblock E
bp 17Aug86
Wird in RAMDISKR\W benutzt
Gibt Offset einer Uservariablen in der Userarea. Dieses
Wort geh”rt eigentlich in den Assembler !
\ *** Block No. 15 Hexblock F
bp 17Aug86
Dieses Wort wird in (CLOSE gepatched. FCB ist die Adresse des
zu schlieženden Files. Alle Blockpuffer dieses Files werden
gel”scht.
Dieses Wort wird in EMPTY-BUFFERS gepatched. Es l”scht alle
Ramdiskpuffer
Neues R/W
Patche (CLOSE
Patche EMPTY-BUFFERS
Frage nach der Gr”že der Ramdisk
\ *** Block No. 16 Hexblock 10
bp 17Aug86
Zeiger auf den ersten Buffer in der Ramdisk.
Beginn des f<EFBFBD>r die Ramdisk allokierten Speicherbereichs
L„nge " " " " " "
L„nge eines Buffers der Ramdisk
Diese Worte erlauben den Zugriff auf die Felder eines
Ramdiskbuffers.
Dies ist die Struktur eines Ramdiskbuffers. Alle Buffer befinden
sich in einer gelinkten Liste, analog zum volksFORTH83-Block=
=buffermechanismus.
\ *** Block No. 17 Hexblock 11
bp 17Aug86
Sucht einen Buffer in der Ramdisk. Gesucht wird der Buffer
mit der Nummer BLK aus dem File mit der Nummer FCB.
Zun„chst wird der erste Eintrag untersucht (weniger Rechenzeit).
Ist es nicht der oberste, so werden die restlichen Buffer
verglichen. Wurde er gefunden, so wird der betreffende Buffer
an den Anfang der Liste geh„ngt, so daž die Buffer immer in
der Reihenfolge des Zugriffs geordnet sind. Dadurch wird die
Zugriffsgeschwindigkeit erh”ht.
\ *** Block No. 18 Hexblock 12
bp 17Aug86
Kopiert den Inhalt des Ramdiskbuffers in den Blockbuffer des
volksFORTH-Systems
Kopiert den Inhalt des Blockbuffers im System in den Ramdisk=
=buffer.
Diese beiden Worte k”nnen noch optimiert werden, da LCMOVE
byteweise <EFBFBD>bertr„gt, aber auch langwortweise <EFBFBD>bertragen
werden kann.
\ *** Block No. 19 Hexblock 13
bp 17Aug86
Dieses Wort sucht einen leeren Ramdiskbuffer. Ist keiner leer,
so wird der letzte Buffer in der Liste genommen.
\ *** Block No. 20 Hexblock 14
bp 24Aug86
Hilfsvariable
Markiert den Ramdiskbuffer DADDR als Buffer f<EFBFBD>r den Block BLK
im File FILE.
Erzeugt einen Buffer f<EFBFBD>r den Blockl BLK des Files FILE in der
Ramdisk. Der Inhalt des Buffers steht ab Adresse ADR im System.
RAMBUF? wird benutzt, um den allokierten Buffer an die erste
Stelle zu h„ngen. Der WHILE-Teil wird max. einmal durchlaufen !
\ *** Block No. 21 Hexblock 15
bp 17Aug86
L”scht den Buffer LADDR.
L”scht alle Ramdiskbuffer, die zum File FCB geh”ren.
\ *** Block No. 22 Hexblock 16
bp 17Aug86
Berechnet die Adresse D2 des Ramdiskbuffers, der auf den Buffer
mit der Adresse D1 folgt.
F ist wahr, falls noch weitere Buffer in der Ramdisk allokiert
werden k”nnen.
Initialisiert die Ramdisk. Es werden soviele Buffer angelegt,
wie in den durch RAMFIRST und RAMSIZE angegebenen Speicher=
=bereich passen. Alle allokierten Buffer werden als leer
markiert.
\ *** Block No. 23 Hexblock 17
bp 17Aug86
Liest eine Zahl von der Tastatur ein
Erzeugt die Ramdisk. Zun„chst wird der alte Speicherbereich
freigegeben, falls einer allokiert war. Dann wird nach der
gew<EFBFBD>nschten Zahl von Buffern gefragt. Es wird ein Speicher=
=bereich vom GEM-Dos angeordert und mit leeren Buffern
gef<EFBFBD>llt.
\ *** Block No. 24 Hexblock 18
bp 17Aug86
Die alte R/W-Routine wird nat<EFBFBD>rlich auch ben”tigt.
Kommuniziert mit den Massenspeichern.
RW/F ist wahr, falls ein Lesezugriff erfolgen soll.
Ist die Ramdisk leer, so darf sie nicht angesprochen werden !
Sonst wird gepr<EFBFBD>ft, ob es sich um einen Lesezugriff handelt
und ob der Buffer in der Ramdisk vorliegt. Ist das der Fall,
so wird einfach dessen Inhalt kopiert. Andernfalls muž, falls
noch nicht vorhanden, ein Buffer allokiert werden. Der Inhalt
des Systembuffers wird dann in die Ramdisk kopiert und steht
beim n„chsten Lesezugriff zur Verf<EFBFBD>gung.
\ *** Block No. 25 Hexblock 19
bp 17Aug86
Es wird eine Liste mit dem Inhalt aller Ramdiskbuffer ausgegeben

51
sources/AtariST/RELOCATE.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ 26oct86we
1
2 Diese File enth„lt Worte, mit denen die Speicheraufteilung
3 des volksFORTH ver„ndert werden kann.
4
5 RELOCATE setzt R0 und S0 neu, beachten Sie dazu auch die
6 Ausf<73>hrungen im Handbuch.
7
8 Mit BUFFERS kann man die Anzahl der Diskbuffer ver„ndern.
9 Standardm„žig ist das System auf &10 Buffer eingestellt. Reicht
10 der Platz im Dictionary bei sehr grožen Programmen nicht aus,
11 kann man hier am ehesten Speicherplatz einsparen.
12 Umgekehrt erh”ht sich der Arbeitskomfort beim Editieren, wenn
13 m”glichst viele Diskbuffer vorhanden sind, um Diskettenzugriffe
14 zu minimieren.
15
Screen 1 not modified
0 \ Relocate a system 26oct86we
1
2 | : relocate-tasks ( mainup -- ) up@ dup
3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop !
4 up@ 2+ @ origin 2+ ! ;
5
6 : relocate ( stacklen rstacklen -- )
7 2dup + limit origin - b/buf - 2-
8 u> abort" kills all buffers"
9 over pad $100 + origin - u< abort" cuts the dictionary"
10 dup udp @ $40 +
11 u< abort" kills returnstack"
12 flush empty over + origin + origin &12 + ! \ r0
13 origin + dup relocate-tasks \ multitasking
14 6 - origin &10 + ! \ s0
15 cold ; -->
Screen 2 not modified
0 \ bytes.more buffers 15sep86we
1
2 | : bytes.more ( n+- -- )
3 up@ origin - + r0 @ up@ - relocate ;
4
5 : buffers ( +n -- )
6 b/buf * 4+ limit r0 @ - swap - bytes.more ;
7
8
9
10
11
12
13
14
15

51
sources/AtariST/RELOCATE.fth Normal file
View File

@ -0,0 +1,51 @@
\ *** Block No. 0 Hexblock 0
\\ 26oct86we
Diese File enth„lt Worte, mit denen die Speicheraufteilung
des volksFORTH ver„ndert werden kann.
RELOCATE setzt R0 und S0 neu, beachten Sie dazu auch die
Ausf<EFBFBD>hrungen im Handbuch.
Mit BUFFERS kann man die Anzahl der Diskbuffer ver„ndern.
Standardm„žig ist das System auf &10 Buffer eingestellt. Reicht
der Platz im Dictionary bei sehr grožen Programmen nicht aus,
kann man hier am ehesten Speicherplatz einsparen.
Umgekehrt erh”ht sich der Arbeitskomfort beim Editieren, wenn
m”glichst viele Diskbuffer vorhanden sind, um Diskettenzugriffe
zu minimieren.
\ *** Block No. 1 Hexblock 1
\ Relocate a system 26oct86we
| : relocate-tasks ( mainup -- ) up@ dup
BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop !
up@ 2+ @ origin 2+ ! ;
: relocate ( stacklen rstacklen -- )
2dup + limit origin - b/buf - 2-
u> abort" kills all buffers"
over pad $100 + origin - u< abort" cuts the dictionary"
dup udp @ $40 +
u< abort" kills returnstack"
flush empty over + origin + origin &12 + ! \ r0
origin + dup relocate-tasks \ multitasking
6 - origin &10 + ! \ s0
cold ; -->
\ *** Block No. 2 Hexblock 2
\ bytes.more buffers 15sep86we
| : bytes.more ( n+- -- )
up@ origin - + r0 @ up@ - relocate ;
: buffers ( +n -- )
b/buf * 4+ limit r0 @ - swap - bytes.more ;

51
sources/AtariST/RFEDIT.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ Retro Forth Editor cas20130106
1
2 This is a port of the Retro Forth Editor from
3 http://retroforth.org
4
5 Functions:
6 <b> s Select a new block <b>
7 p Previous block
8 n Next block
9 <l> i ... Insert ... into line <l>
10 <c> <l> ia ... Insert ... into line <l> at column <c>
11 x Clear (erase) the current block
12 <l> Clear line <l>
13 v Display current block
14 e Evaluate (load) current block
15
Screen 1 not modified
0 .( Retro Forth block editor volksForth Atari ST) \ cas20130106
1 $10 constant l/b cr
2 : (block) scr @ block ; : (line) c/l * (block) + ;
3 : row dup c/l type c/l + cr ; : .rows l/b 0 do i . row loop ;
4 : .block ." Block: " scr @ dup . updated? abs $2A + emit space ;
5 : +--- ." +---" ; : :--- ." :---" ;
6 : x--- +--- :--- +--- :--- ;
7 : --- space space x--- x--- x--- x--- cr ;
8 : vb --- scr @ block .rows drop --- ;
9 : .stack ." Stack: " .s ; : status .block .stack ;
10 : v cr vb status ; : v* update v ; : s dup scr ! block drop v ;
11 : ia (line) + >r &10 parse r> swap move v* ;
12 : i 0 swap ia ; : d (line) c/l bl fill v* ;
13 : x (block) l/b c/l * bl fill v* ; : p -1 scr +! v ;
14 : n 1 scr +! v ; : e scr @ load ;
15 cr .( editor loaded ) cr
Screen 2 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

51
sources/AtariST/RFEDIT.fth Normal file
View File

@ -0,0 +1,51 @@
\ *** Block No. 0 Hexblock 0
\\ Retro Forth Editor cas20130106
This is a port of the Retro Forth Editor from
http://retroforth.org
Functions:
<b> s Select a new block <b>
p Previous block
n Next block
<l> i ... Insert ... into line <l>
<c> <l> ia ... Insert ... into line <l> at column <c>
x Clear (erase) the current block
<l> Clear line <l>
v Display current block
e Evaluate (load) current block
\ *** Block No. 1 Hexblock 1
.( Retro Forth block editor volksForth Atari ST) \ cas20130106
$10 constant l/b cr
: (block) scr @ block ; : (line) c/l * (block) + ;
: row dup c/l type c/l + cr ; : .rows l/b 0 do i . row loop ;
: .block ." Block: " scr @ dup . updated? abs $2A + emit space ;
: +--- ." +---" ; : :--- ." :---" ;
: x--- +--- :--- +--- :--- ;
: --- space space x--- x--- x--- x--- cr ;
: vb --- scr @ block .rows drop --- ;
: .stack ." Stack: " .s ; : status .block .stack ;
: v cr vb status ; : v* update v ; : s dup scr ! block drop v ;
: ia (line) + >r &10 parse r> swap move v* ;
: i 0 swap ia ; : d (line) c/l bl fill v* ;
: x (block) l/b c/l * bl fill v* ; : p -1 scr +! v ;
: n 1 scr +! v ; : e scr @ load ;
cr .( editor loaded ) cr
\ *** Block No. 2 Hexblock 2

34
sources/AtariST/STARTUP.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \\ *** Loadscreen f<>r Arbeitssystem *** bp 12oct86
1
2 Der folgenden Screens wird benutzt, um aus FORTHKER.PRG
3 ein Arbeitssystem zusammenzustellen.
4
5 Alle Files, die zum Standardsystem geh”ren sollen, werden mit
6 INCLUDE dazugeladen. Nicht ben”tigte Teile k”nnen mit \
7 weggelassen werden. Nat<61>rlich kann man auch die entsprechenden
8 Zeilen ganz l”schen. Beachten Sie aber, daž bestimmte Files
9 Grundlage f<>r andere sind. So wird zum Beispiel der Assembler
10 sehr h„ufig gebraucht, der hier "Intern" geladen wird.
11
12 F<>r eigene Applikationen erstellen Sie sich einen Loadscreen
13 nach dem Muster, der dann das oder die Files beinhaltet, die
14 zu Ihrer Applikation geh”ren.
15
Screen 1 not modified
0 \ Loadscreen for Standard System cas20130105
1
2 Onlyforth include misc.fb
3 Onlyforth 2 loadfrom assemble.fb
4 \ Onlyforth include assemble.fb
5 Onlyforth include strings.fb
6 Onlyforth include allocate.fb
7 Onlyforth include gem\aes.fb
8 Onlyforth include editor.fb
9 Onlyforth include index.fb
10 Onlyforth include tools.fb
11 Onlyforth include relocate.fb
12 \ Onlyforth include printer.fb
13 \ Onlyforth include line_a.fb
14 \ Onlyforth include demo.fb
15 Onlyforth cr cr .( May the volksFORTH be with you ...) cr

34
sources/AtariST/STARTUP.fth Normal file
View File

@ -0,0 +1,34 @@
\ *** Block No. 0 Hexblock 0
\\ *** Loadscreen f<EFBFBD>r Arbeitssystem *** bp 12oct86
Der folgenden Screens wird benutzt, um aus FORTHKER.PRG
ein Arbeitssystem zusammenzustellen.
Alle Files, die zum Standardsystem geh”ren sollen, werden mit
INCLUDE dazugeladen. Nicht ben”tigte Teile k”nnen mit \
weggelassen werden. Nat<EFBFBD>rlich kann man auch die entsprechenden
Zeilen ganz l”schen. Beachten Sie aber, daž bestimmte Files
Grundlage f<EFBFBD>r andere sind. So wird zum Beispiel der Assembler
sehr h„ufig gebraucht, der hier "Intern" geladen wird.
F<EFBFBD>r eigene Applikationen erstellen Sie sich einen Loadscreen
nach dem Muster, der dann das oder die Files beinhaltet, die
zu Ihrer Applikation geh”ren.
\ *** Block No. 1 Hexblock 1
\ Loadscreen for Standard System cas20130105
Onlyforth include misc.fb
Onlyforth 2 loadfrom assemble.fb
\ Onlyforth include assemble.fb
Onlyforth include strings.fb
Onlyforth include allocate.fb
Onlyforth include gem\aes.fb
Onlyforth include editor.fb
Onlyforth include index.fb
Onlyforth include tools.fb
Onlyforth include relocate.fb
\ Onlyforth include printer.fb
\ Onlyforth include line_a.fb
\ Onlyforth include demo.fb
Onlyforth cr cr .( May the volksFORTH be with you ...) cr

204
sources/AtariST/STRINGS.FB.src
View File

@ -1,204 +0,0 @@
Screen 0 not modified
0 \\ *** Strings *** 13oct86we
1
2 Dieses File enth„lt einige Grundworte zur Stringverarbeitung,
3 vor allem ein SEARCH f<>r den Editor. Ebenfalls sind Worte
4 zur Umwandlung von counted Strings (Forth) in 0-terminated
5 Strings, wie sie z.B. vom Betriebssystem oft benutzt werden,
6 vorhanden.
7
8 Beim SEARCH entscheidet die Variable CAPS , ob Grož- und
9 Kleinschreibung unterschieden wird oder nicht. Ist CAPS ON,
10 so werden grože und kleine Buchstaben gefunden, die Suche dau-
11 ert allerdings l„nger.
12
13 c>0" wandelt einen String mit f<>hrendem Countbyte in einen
14 mit 0 abgschlossenen, wie er vom Betriebssystem oft gebraucht
15 wird. 0>c" arbeitet umgekehrt.
Screen 1 not modified
0 \ String Functions Loadscreen 25may86we
1
2 1 4 +thru
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ -text 13oct86we
1
2 Variable caps caps off
3
4 Code -text ( addr0 len addr1 -- n )
5 SP )+ D6 move D6 reg) A1 lea
6 SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq
7 SP )+ D6 move D6 reg) A0 lea
8 Label comp
9 .b A0 )+ A1 )+ cmpm comp D0 dbne
10 .w D0 clr .b A0 -) D0 move A1 -) D0 sub .w D0 ext
11 D0 SP -) move Next end-code
12
13 Label >upper ( D3 -> D3 ) .b Ascii a D3 cmpi
14 >= IF Ascii z D3 cmpi <= IF bl D3 subi THEN THEN rts
15
Screen 3 not modified
0 \ -capstext compare 13oct86we
1
2 | Code -capstext ( addr0 len addr1 -- n )
3 SP )+ D6 move D6 reg) A1 lea
4 SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq
5 SP )+ D6 move D6 reg) A0 lea
6 Label capscomp
7 .b A0 )+ D3 move >upper bsr D3 D1 move
8 A1 )+ D3 move >upper bsr D3 D2 move
9 D1 D2 cmp capscomp D0 dbne .w D1 clr
10 .b A0 -) D3 move >upper bsr D3 D1 move
11 A1 -) D3 move >upper bsr D3 D2 move
12 .b D2 D1 sub .w D1 SP -) move Next end-code
13
14 : compare ( addr0 len addr1 -- n )
15 caps @ IF -capstext ELSE -text THEN ;
Screen 4 not modified
0 \ search delete insert 10aug86we
1
2 : search ( text textlen buf buflen -- offset flag )
3 over >r 2 pick - 3 pick c@ >r
4 BEGIN caps @ 0= IF r@ scan THEN ?dup
5 WHILE >r >r 2dup r@ compare
6 0= IF 2drop r> rdrop rdrop r> - true exit THEN
7 r> r> 1 /string REPEAT -rot 2drop rdrop r> - false ;
8
9 : delete ( buffer size count -- )
10 over min >r r@ - ( left over ) dup 0>
11 IF 2dup swap dup r@ + -rot swap cmove THEN
12 + r> bl fill ;
13
14 : insert ( string length buffer size -- )
15 rot over min >r r@ - over dup r@ + rot cmove> r> cmove ;
Screen 5 not modified
0 \ String operators 13oct86we
1
2 Variable $sum \ pointer to stringsum
3 : $add ( addr len -- ) dup >r
4 $sum @ count + swap move $sum @ dup c@ r> + swap c! ;
5
6 : c>0" ( addr -- )
7 count >r dup 1- under r@ cmove r> + 0 swap c! ;
8 : 0>c" ( addr -- )
9 dup >r true false scan nip negate 1-
10 r@ dup 1+ 2 pick cmove> r> c! ;
11
12 : ,0" Ascii " parse 1+ here over allot place
13 0 c, align ; restrict
14 : 0" state @ IF compile (" ,0" compile 1+ exit THEN
15 here 1+ ,0" ; immediate
Screen 6 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 7 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 8 not modified
0 \ -text 13oct86we
1
2 ist CAPS on, wird beim Suchen nicht auf Grož- Kleinschreibung
3 geachtet.
4 addr0 und addr1 sind die Adressen von zwei counted strings, len
5 die Anzahl der Zeichen, die verglichen werden sollen. n liefert
6 die Differenz der beiden ersten nicht <20>bereinstimmenden Zeichen
7 Ist n=0, sind beide Strings gleich.
8
9
10
11
12
13 wandelt das Zeichen im Register D3 in den entsprechenden Grož-
14 buchstaben.
15
Screen 9 not modified
0 \ -capstext compare 13oct86we
1
2 wie -text, jedoch wird beim Vergleich nicht nach Grož- und Klein
3 schreibung unterschieden. Dieser Vergleich erfordert erheblich
4 mehr Zeit und sollte daher nur in Sonderf„llen benutzt werden.
5
6
7
8
9
10
11
12
13
14 wie -text, in Abh„ngigkeit von der Variablen caps wird -text
15 oder -capstext ausgef<65>hrt.
Screen 10 not modified
0 \ search delete insert 13oct86we
1
2 Im Text ab Adresse text wird in der L„nge textlen nach dem
3 String buf mit L„nge buflen gesucht.
4 Zur<75>ckgeliefert wird ein Offset in den durchsuchten Text an die
5 Stelle, an der der String gefunden wurde sowie ein Flag. Ist
6 flag wahr, wurde der String gefunden, sonst nicht.
7 search ber<65>cksichtigt die Variable caps bei der Suche.
8
9 Im Buffer der L„nge size werden count Zeichen entfernt. Der Rest
10 des Buffers wird 'heruntergezogen'.
11
12
13
14 Der string ab Adresse string und der L„nge length wird in den
15 Buffer mit der Gr”že size eingef<65>gt.
Screen 11 not modified
0 \ String operators 13oct86we
1
2 Ein pointer auf die Adresse des Strings, zu dem ein anderer
3 hinzugef<65>gt werden soll.
4 $ADD h„ngt den String ab addr und der L„nge len an den String
5 in $sum an. Der Count wird dabei addiert.
6 wandelt den counted String ab addr in einen 0-terminated String.
7
8 wandelt den 0-terminated String ab addr in einen counted String.
9 Die L„nge der Strings bleibt gleich (Countbyte statt 0).
10
11
12 legt einen counted und mit 0 abgeschlossenen String im
13 Dictionary ab.
14 aufrufendes Wort f<>r ,0"; kompiliert zus„tzlich (".
15 0" ist statesmart.

204
sources/AtariST/STRINGS.fth Normal file
View File

@ -0,0 +1,204 @@
\ *** Block No. 0 Hexblock 0
\\ *** Strings *** 13oct86we
Dieses File enth„lt einige Grundworte zur Stringverarbeitung,
vor allem ein SEARCH f<EFBFBD>r den Editor. Ebenfalls sind Worte
zur Umwandlung von counted Strings (Forth) in 0-terminated
Strings, wie sie z.B. vom Betriebssystem oft benutzt werden,
vorhanden.
Beim SEARCH entscheidet die Variable CAPS , ob Grož- und
Kleinschreibung unterschieden wird oder nicht. Ist CAPS ON,
so werden grože und kleine Buchstaben gefunden, die Suche dau-
ert allerdings l„nger.
c>0" wandelt einen String mit f<EFBFBD>hrendem Countbyte in einen
mit 0 abgschlossenen, wie er vom Betriebssystem oft gebraucht
wird. 0>c" arbeitet umgekehrt.
\ *** Block No. 1 Hexblock 1
\ String Functions Loadscreen 25may86we
1 4 +thru
\ *** Block No. 2 Hexblock 2
\ -text 13oct86we
Variable caps caps off
Code -text ( addr0 len addr1 -- n )
SP )+ D6 move D6 reg) A1 lea
SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq
SP )+ D6 move D6 reg) A0 lea
Label comp
.b A0 )+ A1 )+ cmpm comp D0 dbne
.w D0 clr .b A0 -) D0 move A1 -) D0 sub .w D0 ext
D0 SP -) move Next end-code
Label >upper ( D3 -> D3 ) .b Ascii a D3 cmpi
>= IF Ascii z D3 cmpi <= IF bl D3 subi THEN THEN rts
\ *** Block No. 3 Hexblock 3
\ -capstext compare 13oct86we
| Code -capstext ( addr0 len addr1 -- n )
SP )+ D6 move D6 reg) A1 lea
SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq
SP )+ D6 move D6 reg) A0 lea
Label capscomp
.b A0 )+ D3 move >upper bsr D3 D1 move
A1 )+ D3 move >upper bsr D3 D2 move
D1 D2 cmp capscomp D0 dbne .w D1 clr
.b A0 -) D3 move >upper bsr D3 D1 move
A1 -) D3 move >upper bsr D3 D2 move
.b D2 D1 sub .w D1 SP -) move Next end-code
: compare ( addr0 len addr1 -- n )
caps @ IF -capstext ELSE -text THEN ;
\ *** Block No. 4 Hexblock 4
\ search delete insert 10aug86we
: search ( text textlen buf buflen -- offset flag )
over >r 2 pick - 3 pick c@ >r
BEGIN caps @ 0= IF r@ scan THEN ?dup
WHILE >r >r 2dup r@ compare
0= IF 2drop r> rdrop rdrop r> - true exit THEN
r> r> 1 /string REPEAT -rot 2drop rdrop r> - false ;
: delete ( buffer size count -- )
over min >r r@ - ( left over ) dup 0>
IF 2dup swap dup r@ + -rot swap cmove THEN
+ r> bl fill ;
: insert ( string length buffer size -- )
rot over min >r r@ - over dup r@ + rot cmove> r> cmove ;
\ *** Block No. 5 Hexblock 5
\ String operators 13oct86we
Variable $sum \ pointer to stringsum
: $add ( addr len -- ) dup >r
$sum @ count + swap move $sum @ dup c@ r> + swap c! ;
: c>0" ( addr -- )
count >r dup 1- under r@ cmove r> + 0 swap c! ;
: 0>c" ( addr -- )
dup >r true false scan nip negate 1-
r@ dup 1+ 2 pick cmove> r> c! ;
: ,0" Ascii " parse 1+ here over allot place
0 c, align ; restrict
: 0" state @ IF compile (" ,0" compile 1+ exit THEN
here 1+ ,0" ; immediate
\ *** Block No. 6 Hexblock 6
\ *** Block No. 7 Hexblock 7
\ *** Block No. 8 Hexblock 8
\ -text 13oct86we
ist CAPS on, wird beim Suchen nicht auf Grož- Kleinschreibung
geachtet.
addr0 und addr1 sind die Adressen von zwei counted strings, len
die Anzahl der Zeichen, die verglichen werden sollen. n liefert
die Differenz der beiden ersten nicht <EFBFBD>bereinstimmenden Zeichen
Ist n=0, sind beide Strings gleich.
wandelt das Zeichen im Register D3 in den entsprechenden Grož-
buchstaben.
\ *** Block No. 9 Hexblock 9
\ -capstext compare 13oct86we
wie -text, jedoch wird beim Vergleich nicht nach Grož- und Klein
schreibung unterschieden. Dieser Vergleich erfordert erheblich
mehr Zeit und sollte daher nur in Sonderf„llen benutzt werden.
wie -text, in Abh„ngigkeit von der Variablen caps wird -text
oder -capstext ausgef<EFBFBD>hrt.
\ *** Block No. 10 Hexblock A
\ search delete insert 13oct86we
Im Text ab Adresse text wird in der L„nge textlen nach dem
String buf mit L„nge buflen gesucht.
Zur<EFBFBD>ckgeliefert wird ein Offset in den durchsuchten Text an die
Stelle, an der der String gefunden wurde sowie ein Flag. Ist
flag wahr, wurde der String gefunden, sonst nicht.
search ber<EFBFBD>cksichtigt die Variable caps bei der Suche.
Im Buffer der L„nge size werden count Zeichen entfernt. Der Rest
des Buffers wird 'heruntergezogen'.
Der string ab Adresse string und der L„nge length wird in den
Buffer mit der Gr”že size eingef<EFBFBD>gt.
\ *** Block No. 11 Hexblock B
\ String operators 13oct86we
Ein pointer auf die Adresse des Strings, zu dem ein anderer
hinzugef<EFBFBD>gt werden soll.
$ADD h„ngt den String ab addr und der L„nge len an den String
in $sum an. Der Count wird dabei addiert.
wandelt den counted String ab addr in einen 0-terminated String.
wandelt den 0-terminated String ab addr in einen counted String.
Die L„nge der Strings bleibt gleich (Countbyte statt 0).
legt einen counted und mit 0 abgeschlossenen String im
Dictionary ab.
aufrufendes Wort f<EFBFBD>r ,0"; kompiliert zus„tzlich (".
0" ist statesmart.

680
sources/AtariST/TARGET.FB.src
View File

@ -1,680 +0,0 @@
Screen 0 not modified
0 \\ *** volksFORTH-84 Target-Compiler ***
1
2 Mit dem Target-Compiler l„žt sich ein neues System aus dem
3 Quelltext FORTH_83.SCR 'hochziehen'.
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Target compiler loadscr 09sep86we
1 \ Idea and first Implementation by ks/bp
2 \ Implemented on 6502 by ks/bp
3 \ ultraFORTH83-Version by bp/we
4 \ Atari 520 ST - Version by we
5
6 Onlyforth Assembler nonrelocate
7 07 Constant imagepage \ Virtual memory bank
8 Vocabulary Ttools
9 Vocabulary Defining
10 : .stat .blk .s ; ' .stat Is .status
11
12 1 $12 +thru \ Target compiler
13 $13 $15 +thru \ Target Tools
14 $16 $18 +thru \ Redefinitions
15 save $19 $22 +thru \ Predefinitions
Screen 2 not modified
0 \ Target header pointers bp05mar86we
1
2 Variable tdp : there tdp @ ;
3 Variable displace
4 Variable ?thead 0 ?thead !
5 Variable tlast 0 tlast !
6 Variable glast' 0 glast' !
7 Variable tdoes>
8 Variable >in:
9 Variable tvoc 0 tvoc !
10 Variable tvoc-link 0 tvoc-link !
11 Variable tnext-link 0 tnext-link !
12
13 : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
14
15
Screen 3 not modified
0 \ Image and byteorder 15sep86we
1
2 : >image ( addr1 - addr2 ) displace @ - ;
3
4 : >heap ( from quan - )
5 heap over - 1 and + \ 68000-align
6 dup hallot heap swap cmove ;
7 \\
8 : >ascii 2drop ; ' noop Alias C64>ascii
9
10 Code Lc@ ( laddr -- 8b )
11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move
12 .w D0 SP -) move Next end-code
13 Code Lc! ( 8b addr -- )
14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
15 Next end-code
Screen 4 not modified
0 \ Ghost-creating 05mar86we
1
2 0 | Constant <forw> 0 | Constant <res>
3
4 | : Make.ghost ( - cfa.ghost )
5 here dup 1 and allot here
6 state @ IF context @ ELSE current THEN @
7 dup @ , name
8 dup c@ 1 $1F uwithin not abort" inval.Gname"
9 dup c@ 1+ over c!
10 c@ dup 1+ allot 1 and 0= IF bl c, THEN
11 here 2 pick - -rot
12 <forw> , 0 , 0 ,
13 swap here over - >heap
14 heap swap ! swap dp !
15 heap + ;
Screen 5 not modified
0 \ ghost words 05mar86we
1
2 : gfind ( string - cfa tf / string ff )
3 dup count + 1+ bl swap c!
4 dup >r 1 over c+! find -1 r> c+! ;
5
6 : ghost ( - cfa )
7 >in @ name gfind IF nip exit THEN
8 drop >in ! Make.ghost ;
9
10 : Word, ghost execute ;
11
12 : gdoes> ( cfa.ghost - cfa.does )
13 4+ dup @ IF @ exit THEN
14 here dup <forw> , 0 , 4 >heap
15 dp ! heap dup rot ! ;
Screen 6 not modified
0 \ ghost utilities 04dec85we
1
2 : g' name gfind 0= abort" ?" ;
3
4 : '.
5 g' dup @ <forw> case?
6 IF ." forw" ELSE <res> - abort" ??" ." res" THEN
7 2+ dup @ 5 u.r
8 2+ @ ?dup
9 IF dup @ <forw> case?
10 IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
11 2+ @ 5 u.r THEN ;
12
13 ' ' Alias h'
14
15
Screen 7 not modified
0 \ .unresolved 05mar86we
1
2 | : forward? ( cfa - cfa / exit&true )
3 dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
4
5 | : unresolved? ( addr - f )
6 2+ dup c@ $1F and over + c@ BL =
7 IF name> forward? 4+ @ dup IF forward? THEN
8 THEN drop false ;
9
10 | : unresolved-words
11 BEGIN @ ?dup WHILE dup unresolved?
12 IF dup 2+ .name ?cr THEN REPEAT ;
13
14 : .unresolved voc-link @
15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
Screen 8 not modified
0 \ Extending Vocabularys for Target-Compilation 05mar86we
1
2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
3
4 Vocabulary Transient 0 tvoc !
5
6 Only definitions Forth also
7
8 : T Transient ; immediate
9 : H Forth ; immediate
10
11 definitions
12
13
14
15
Screen 9 not modified
0 \ Transient primitives 05mar86we
1
2 Code byte> ( 8bh 8bl -- 16b )
3 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
4 .w D0 SP ) move Next end-code
5 Code >byte ( 16b -- 8bl 8bh )
6 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
7 D0 SP -) move D1 SP -) move Next end-code
8
9 Transient definitions
10 : c@ H >image imagepage lc@ ;
11 : c! H >image imagepage lc! ;
12 : @ T dup c@ swap 1+ c@ byte> ;
13 : ! >r >byte r@ T c! r> 1+ c! ;
14 : cmove ( from.mem to.target quan -)
15 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
Screen 10 not modified
0 \ Transient primitives bp05mar86we
1
2 : here there ;
3 : allot Tdp +! ;
4 : c, T here c! 1 allot H ;
5 : , T here ! 2 allot H ;
6
7 : ," Ascii " parse dup T c,
8 under there swap cmove
9 dup 1 and 0= IF 1+ THEN allot H ;
10
11 : fill ( addr quan 8b -)
12 -rot bounds ?DO dup I T c! H LOOP drop ;
13 : erase 0 T fill ;
14 : blank bl T fill ;
15 : here! H Tdp ! ;
Screen 11 not modified
0 \ Resolving 08dec85we
1 Forth definitions
2 : resolve ( cfa.ghost cfa.target -)
3 over dup @ <res> =
4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
5 >r >r 2+ @ ?dup
6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
7 H ?dup 0= UNTIL
8 THEN r> r> <res> over ! 2+ ! ;
9
10 : resdoes> ( cfa.ghost cfa.target -)
11 swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
13 ' <forw> >body !
14 ] Does> [ here 4- 0 ] @ T , H ;
15 ' <res> >body !
Screen 12 not modified
0 \ move-threads 68000-align 13jun86we
1
2 : move-threads Tvoc @ Tvoc-link @
3 BEGIN over ?dup
4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
5 error" some undef. Target-Vocs left" drop ;
6
7 | : tlatest ( - addr) current @ 6 + ;
8 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
9
10
11
12
13
14
15
Screen 13 not modified
0 \ save-target 09sep86we
1
2 Dos definitions
3
4 Code (filewrite ( buff len handle -- n)
5 SP )+ D0 move .l D2 clr .w SP )+ D2 move
6 .l 0 imagepage # D1 move .w SP )+ D1 move
7 .l D1 A7 -) move \ buffer adress
8 .l D2 A7 -) move \ buffer length
9 .w D0 A7 -) move \ handle
10 $40 # A7 -) move \ call WRITE
11 1 trap $0C # A7 adda
12 .w D0 SP -) move Next end-code Forth definitions
13
14
15
Screen 14 not modified
0 \ save Target-System 09sep86we
1
2 : save-target [ Dos ]
3 bl word count dup 0= abort" missing filename"
4 over + off (createfile dup >r 0< abort" no device "
5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
6 0 there r@ (filewrite there - abort" write error"
7 r> (closefile 0< abort" close error" ;
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ compiling names into targ. 05mar86we
1
2 : (theader
3 there 68000-talign
4 ?thead @ IF 1 ?thead +! exit THEN
5 >in @ name swap >in !
6 dup c@ 1 $20 uwithin not
7 abort" inval. Tname"
8 blk @ T , H there tlatest dup @ T , H ! there dup tlast !
9 over c@ 1+ even dup T allot cmove H ;
10
11 : Theader tlast off
12 (theader Ghost dup glast' !
13 there resolve ;
14
15
Screen 16 not modified
0 \ prebuild defining words bp27jun85we
1
2 | : executable? ( adr - adr f ) dup ;
3 | : tpfa, there , ;
4 | : (prebuild ( cfa.adr -- )
5 >in @ Create >in ! here 2- ! ;
6
7 : prebuild ( adr 0.from.: - 0 )
8 0 ?pairs executable? dup >r
9 IF [compile] Literal compile (prebuild ELSE drop THEN
10 compile Theader Ghost gdoes> ,
11 r> IF compile tpfa, THEN 0 ; immediate restrict
12
13
14
15
Screen 17 not modified
0 \ code portion of def.words bp11sep86we
1
2 : dummy 0 ;
3
4 : DO> ( - adr.of.jmp.dodoes> 0 )
5 [compile] Does> here 4- compile @ 0 ] ;
6
7
8
9
10
11
12
13
14
15
Screen 18 not modified
0 \ the 68000 Assembler 11sep86we
1
2 Forth definitions
3 | Create relocate ] T c, , c@ here allot ! c! H [
4
5 Transient definitions
6
7 : Assembler H [ Assembler ] relocate >codes ! Assembler ;
8 : >label ( 16b -) H >in @ name gfind rot >in !
9 IF over resolve dup THEN drop Constant ;
10 : Label T here 1 and allot here >label Assembler H ;
11 : Code H Theader there 2+ T , Assembler H ;
12
13
14
15
Screen 19 not modified
0 \ immed. restr. ' \ compile bp05mar86we
1
2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
3 : >mark ( - addr ) H there T 0 , H ;
4 : >resolve ( addr - ) H there over - swap T ! H ;
5 : <mark ( - addr ) H there ;
6 : <resolve ( addr - ) H there - T , H ;
7 : immediate H Tlast @ ?dup
8 IF dup T c@ $40 or swap c! H THEN ;
9 : restrict H Tlast @ ?dup
10 IF dup T c@ $80 or swap c! H THEN ;
11 : ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
12 : | H ?thead @ ?exit ?thead on ;
13 : compile H Ghost , ; immediate restrict
14
15
Screen 20 not modified
0 \ Target tools ks05mar86we
1
2 Onlyforth Ttools also definitions
3
4 | : ttype ( adr n -) bounds ?DO I T c@ H dup
5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
7 ELSE ." ??? " THEN space ?cr ;
8 | : nfa? ( cfa lfa - nfa / cfa ff)
9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ even =
10 IF 2+ nip exit THEN
11 T @ H REPEAT ;
12 : >name ( cfa - nfa / ff)
13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
14 IF nip exit THEN
15 swap REPEAT nip ;
Screen 21 not modified
0 \ Ttools for decompiling ks05mar86we
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup T @ H 6 u.r ;
4 | : c? dup T c@ H 3 .r ;
5
6 : s ( addr - addr+ ) ?: space c? 3 spaces
7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
8
9 : n ( addr - addr+2 ) ?: @? 2 spaces
10 dup T @ H [ Ttools ] >name .name H 2+ ;
11
12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
13 2 spaces -rot ttype ;
14
15
Screen 22 not modified
0 \ Tools for decompiling bp05mar86we
1
2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
3
4 : c ( addr -- addr+1 ) 1 d ;
5
6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
7
8 : dump ( adr n -) bounds ?DO cr I $10 d drop
9 stop? IF LEAVE THEN $10 +LOOP ;
10
11 : view T ' H [ Ttools ] >name ?dup
12 IF 4- T @ H l THEN ;
13
14
15
Screen 23 not modified
0 \ reinterpretation def.-words 05mar86we
1
2 Onlyforth
3
4 : redefinition
5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push
6 state push context push >in: @ >in !
7 name [ ' Transient 2+ ] Literal (find nip 0=
8 IF cr ." Redefinition: " here .name
9 >in: @ >in ! : Defining interpret THEN
10 THEN 0 tdoes> ! ;
11
12
13
14
15
Screen 24 not modified
0 \ Create..does> structure bp05mar86we
1
2 | : (;tcode Tlast @ dup T c@ dup 1 and - 2+ + ! H rdrop ;
3
4 | : changecfa compile lit tdoes> @ , compile (;tcode ;
5
6 Defining definitions
7
8 : ;code 0 ?pairs changecfa reveal rdrop ;
9 immediate restrict
10
11 Defining ' ;code Alias does> immediate restrict
12
13 : ; [compile] ; rdrop ; immediate restrict
14
15
Screen 25 not modified
0 \ redefinition conditionals bp27jun85we
1
2 ' DO Alias DO immediate restrict
3 ' ?DO Alias ?DO immediate restrict
4 ' LOOP Alias LOOP immediate restrict
5 ' IF Alias IF immediate restrict
6 ' THEN Alias THEN immediate restrict
7 ' ELSE Alias ELSE immediate restrict
8 ' BEGIN Alias BEGIN immediate restrict
9 ' UNTIL Alias UNTIL immediate restrict
10 ' WHILE Alias WHILE immediate restrict
11 ' REPEAT Alias REPEAT immediate restrict
12
13
14
15
Screen 26 not modified
0 \ clear Liter. Ascii ['] ." bp05mar86we
1
2 Onlyforth Transient definitions
3
4 : clear true abort" There are ghosts" ;
5 : Literal ( n -) T compile lit , H ; immediate
6 : Ascii H bl word 1+ c@ state @
7 IF T [compile] Literal H THEN ; immediate
8 : ['] T ' [compile] Literal H ; immediate restrict
9 : " T compile (" ," H ; immediate restrict
10 : ." T compile (." ," H ; immediate restrict
11
12
13
14
15
Screen 27 not modified
0 \ Target compilation ] [ bp05mar86we
1
2 Forth definitions
3
4 : tcompile
5 ?stack >in @ name find ?dup
6 IF 0> IF nip execute >interpret THEN
7 drop dup >in ! name
8 THEN gfind IF nip execute >interpret THEN
9 nullstring? IF drop exit THEN
10 number? ?dup IF 0> IF swap T [compile] Literal THEN
11 [compile] Literal H drop >interpret THEN
12 drop >in ! Word, >interpret ;
13
14 Transient definitions
15 : ] H state on ['] tcompile is >interpret ;
Screen 28 not modified
0 \ Target conditionals bp05mar86we
1
2 : IF T compile ?branch >mark H 1 ; immediate restrict
3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict
4 : ELSE T 1 ?pairs compile branch >mark swap >resolve
5 H -1 ; immediate restrict
6 : BEGIN T <mark H 2 ; immediate restrict
7 : WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
8 immediate restrict
9 | : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
10 WHILE drop T >resolve H REPEAT ;
11 : UNTIL T compile ?branch (repeat H ; immediate restrict
12 : REPEAT T compile branch (repeat H ; immediate restrict
13
14
15
Screen 29 not modified
0 \ Target conditionals bp27jun85we
1
2 : DO T compile (do >mark H 3 ; immediate restrict
3 : ?DO T compile (?do >mark H 3 ; immediate restrict
4 : LOOP T 3 ?pairs compile (loop compile endloop
5 >resolve H ; immediate restrict
6 : +LOOP T 3 ?pairs compile (+loop compile endloop
7 >resolve H ; immediate restrict
8
9
10
11
12
13
14
15
Screen 30 not modified
0 \ predefinitions bp05mar86we
1
2 : abort" T compile (abort" ," H ; immediate
3 : error" T compile (err" ," H ; immediate
4
5 Forth definitions
6
7 Variable torigin
8 Variable tudp 0 Tudp !
9
10 : >user T c@ H torigin @ + ;
11
12
13
14
15
Screen 31 not modified
0 \ Datatypes bp05mar86we
1
2 Transient definitions
3 : origin! H torigin ! ;
4 : user' ( -- n ) T ' >body c@ H ;
5 : uallot ( n -- ) H tudp @ swap tudp +! ;
6
7 DO> >user ;
8 : User prebuild User 2 T uallot c, ;
9
10 DO> ;
11 : Create prebuild Create ;
12
13 DO> T @ H ;
14 : Constant prebuild Constant T , ;
15 : Variable Create 2 T allot ;
Screen 32 not modified
0 \ Datatypes bp05mar86we
1
2 dummy
3 : Vocabulary
4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
5 here H tvoc-link @ T , H tvoc-link ! ;
6
7
8
9
10
11
12
13
14
15
Screen 33 not modified
0 \ target defining words bp08sep86we
1
2 Do> ;
3 : Defer prebuild Defer 2 T allot ;
4 : Is T ' H >body state @ IF T compile (is , H
5 ELSE T ! H THEN ; immediate
6 | : dodoes> T compile (;code H Glast' @
7 there resdoes> there tdoes> ! ;
8
9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [
10 redefinition ; immediate restrict
11 : does> T dodoes> $4EAB , \ FP D) JSR
12 compile (dodoes> H ; immediate restrict
13
14
15
Screen 34 not modified
0 \ : Alias ; bp25mar86we
1
2 : Create: T Create H current @ context ! T ] H 0 ;
3
4 dummy
5 : : H tdoes> off >in @ >in: ! T prebuild :
6 H current @ context ! T ] H 0 ;
7
8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve
9 tlast @ T c@ H $20 or tlast @ T c! , H ;
10
11 : ; T 0 ?pairs compile unnest [compile] [ H redefinition ;
12 immediate restrict
13
14
15
Screen 35 not modified
0 \ predefinitions bp11sep86we
1
2 : compile T compile compile H ; immediate restrict
3 : Host H Onlyforth Ttools also ;
4 : Compiler T Host H Transient also definitions ;
5 : [compile] H Word, ; immediate restrict
6 : Onlypatch H there 4- 0 tdoes> ! 0 ;
7
8 Onlyforth
9 : Target Onlyforth Transient also definitions ;
10
11 Transient definitions
12 Ghost c, drop
13
14
15
Screen 36 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 37 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 38 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 39 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

680
sources/AtariST/TARGET.fth Normal file
View File

@ -0,0 +1,680 @@
\ *** Block No. 0 Hexblock 0
\\ *** volksFORTH-84 Target-Compiler ***
Mit dem Target-Compiler l„žt sich ein neues System aus dem
Quelltext FORTH_83.SCR 'hochziehen'.
\ *** Block No. 1 Hexblock 1
\ Target compiler loadscr 09sep86we
\ Idea and first Implementation by ks/bp
\ Implemented on 6502 by ks/bp
\ ultraFORTH83-Version by bp/we
\ Atari 520 ST - Version by we
Onlyforth Assembler nonrelocate
07 Constant imagepage \ Virtual memory bank
Vocabulary Ttools
Vocabulary Defining
: .stat .blk .s ; ' .stat Is .status
1 $12 +thru \ Target compiler
$13 $15 +thru \ Target Tools
$16 $18 +thru \ Redefinitions
save $19 $22 +thru \ Predefinitions
\ *** Block No. 2 Hexblock 2
\ Target header pointers bp05mar86we
Variable tdp : there tdp @ ;
Variable displace
Variable ?thead 0 ?thead !
Variable tlast 0 tlast !
Variable glast' 0 glast' !
Variable tdoes>
Variable >in:
Variable tvoc 0 tvoc !
Variable tvoc-link 0 tvoc-link !
Variable tnext-link 0 tnext-link !
: c+! ( 8b addr -- ) dup c@ rot + swap c! ;
\ *** Block No. 3 Hexblock 3
\ Image and byteorder 15sep86we
: >image ( addr1 - addr2 ) displace @ - ;
: >heap ( from quan - )
heap over - 1 and + \ 68000-align
dup hallot heap swap cmove ;
\\
: >ascii 2drop ; ' noop Alias C64>ascii
Code Lc@ ( laddr -- 8b )
.l SP )+ A0 move .w D0 clr .b A0 ) D0 move
.w D0 SP -) move Next end-code
Code Lc! ( 8b addr -- )
.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move
Next end-code
\ *** Block No. 4 Hexblock 4
\ Ghost-creating 05mar86we
0 | Constant <forw> 0 | Constant <res>
| : Make.ghost ( - cfa.ghost )
here dup 1 and allot here
state @ IF context @ ELSE current THEN @
dup @ , name
dup c@ 1 $1F uwithin not abort" inval.Gname"
dup c@ 1+ over c!
c@ dup 1+ allot 1 and 0= IF bl c, THEN
here 2 pick - -rot
<forw> , 0 , 0 ,
swap here over - >heap
heap swap ! swap dp !
heap + ;
\ *** Block No. 5 Hexblock 5
\ ghost words 05mar86we
: gfind ( string - cfa tf / string ff )
dup count + 1+ bl swap c!
dup >r 1 over c+! find -1 r> c+! ;
: ghost ( - cfa )
>in @ name gfind IF nip exit THEN
drop >in ! Make.ghost ;
: Word, ghost execute ;
: gdoes> ( cfa.ghost - cfa.does )
4+ dup @ IF @ exit THEN
here dup <forw> , 0 , 4 >heap
dp ! heap dup rot ! ;
\ *** Block No. 6 Hexblock 6
\ ghost utilities 04dec85we
: g' name gfind 0= abort" ?" ;
: '.
g' dup @ <forw> case?
IF ." forw" ELSE <res> - abort" ??" ." res" THEN
2+ dup @ 5 u.r
2+ @ ?dup
IF dup @ <forw> case?
IF ." fdef" ELSE <res> - abort" ??" ." rdef" THEN
2+ @ 5 u.r THEN ;
' ' Alias h'
\ *** Block No. 7 Hexblock 7
\ .unresolved 05mar86we
| : forward? ( cfa - cfa / exit&true )
dup @ <forw> = over 2+ @ and IF drop true rdrop exit THEN ;
| : unresolved? ( addr - f )
2+ dup c@ $1F and over + c@ BL =
IF name> forward? 4+ @ dup IF forward? THEN
THEN drop false ;
| : unresolved-words
BEGIN @ ?dup WHILE dup unresolved?
IF dup 2+ .name ?cr THEN REPEAT ;
: .unresolved voc-link @
BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
\ *** Block No. 8 Hexblock 8
\ Extending Vocabularys for Target-Compilation 05mar86we
: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
Vocabulary Transient 0 tvoc !
Only definitions Forth also
: T Transient ; immediate
: H Forth ; immediate
definitions
\ *** Block No. 9 Hexblock 9
\ Transient primitives 05mar86we
Code byte> ( 8bh 8bl -- 16b )
SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move
.w D0 SP ) move Next end-code
Code >byte ( 16b -- 8bl 8bh )
SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr
D0 SP -) move D1 SP -) move Next end-code
Transient definitions
: c@ H >image imagepage lc@ ;
: c! H >image imagepage lc! ;
: @ T dup c@ swap 1+ c@ byte> ;
: ! >r >byte r@ T c! r> 1+ c! ;
: cmove ( from.mem to.target quan -)
bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
\ *** Block No. 10 Hexblock A
\ Transient primitives bp05mar86we
: here there ;
: allot Tdp +! ;
: c, T here c! 1 allot H ;
: , T here ! 2 allot H ;
: ," Ascii " parse dup T c,
under there swap cmove
dup 1 and 0= IF 1+ THEN allot H ;
: fill ( addr quan 8b -)
-rot bounds ?DO dup I T c! H LOOP drop ;
: erase 0 T fill ;
: blank bl T fill ;
: here! H Tdp ! ;
\ *** Block No. 11 Hexblock B
\ Resolving 08dec85we
Forth definitions
: resolve ( cfa.ghost cfa.target -)
over dup @ <res> =
IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN
>r >r 2+ @ ?dup
IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T !
H ?dup 0= UNTIL
THEN r> r> <res> over ! 2+ ! ;
: resdoes> ( cfa.ghost cfa.target -)
swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
] Does> [ here 4- 0 ] dup @ there rot ! T , H ;
' <forw> >body !
] Does> [ here 4- 0 ] @ T , H ;
' <res> >body !
\ *** Block No. 12 Hexblock C
\ move-threads 68000-align 13jun86we
: move-threads Tvoc @ Tvoc-link @
BEGIN over ?dup
WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
error" some undef. Target-Vocs left" drop ;
| : tlatest ( - addr) current @ 6 + ;
| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ;
\ *** Block No. 13 Hexblock D
\ save-target 09sep86we
Dos definitions
Code (filewrite ( buff len handle -- n)
SP )+ D0 move .l D2 clr .w SP )+ D2 move
.l 0 imagepage # D1 move .w SP )+ D1 move
.l D1 A7 -) move \ buffer adress
.l D2 A7 -) move \ buffer length
.w D0 A7 -) move \ handle
$40 # A7 -) move \ call WRITE
1 trap $0C # A7 adda
.w D0 SP -) move Next end-code Forth definitions
\ *** Block No. 14 Hexblock E
\ save Target-System 09sep86we
: save-target [ Dos ]
bl word count dup 0= abort" missing filename"
over + off (createfile dup >r 0< abort" no device "
T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header
0 there r@ (filewrite there - abort" write error"
r> (closefile 0< abort" close error" ;
\ *** Block No. 15 Hexblock F
\ compiling names into targ. 05mar86we
: (theader
there 68000-talign
?thead @ IF 1 ?thead +! exit THEN
>in @ name swap >in !
dup c@ 1 $20 uwithin not
abort" inval. Tname"
blk @ T , H there tlatest dup @ T , H ! there dup tlast !
over c@ 1+ even dup T allot cmove H ;
: Theader tlast off
(theader Ghost dup glast' !
there resolve ;
\ *** Block No. 16 Hexblock 10
\ prebuild defining words bp27jun85we
| : executable? ( adr - adr f ) dup ;
| : tpfa, there , ;
| : (prebuild ( cfa.adr -- )
>in @ Create >in ! here 2- ! ;
: prebuild ( adr 0.from.: - 0 )
0 ?pairs executable? dup >r
IF [compile] Literal compile (prebuild ELSE drop THEN
compile Theader Ghost gdoes> ,
r> IF compile tpfa, THEN 0 ; immediate restrict
\ *** Block No. 17 Hexblock 11
\ code portion of def.words bp11sep86we
: dummy 0 ;
: DO> ( - adr.of.jmp.dodoes> 0 )
[compile] Does> here 4- compile @ 0 ] ;
\ *** Block No. 18 Hexblock 12
\ the 68000 Assembler 11sep86we
Forth definitions
| Create relocate ] T c, , c@ here allot ! c! H [
Transient definitions
: Assembler H [ Assembler ] relocate >codes ! Assembler ;
: >label ( 16b -) H >in @ name gfind rot >in !
IF over resolve dup THEN drop Constant ;
: Label T here 1 and allot here >label Assembler H ;
: Code H Theader there 2+ T , Assembler H ;
\ *** Block No. 19 Hexblock 13
\ immed. restr. ' \ compile bp05mar86we
: ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
: >mark ( - addr ) H there T 0 , H ;
: >resolve ( addr - ) H there over - swap T ! H ;
: <mark ( - addr ) H there ;
: <resolve ( addr - ) H there - T , H ;
: immediate H Tlast @ ?dup
IF dup T c@ $40 or swap c! H THEN ;
: restrict H Tlast @ ?dup
IF dup T c@ $80 or swap c! H THEN ;
: ' ( <name> - cfa ) H g' dup @ <res> - abort" ?" 2+ @ ;
: | H ?thead @ ?exit ?thead on ;
: compile H Ghost , ; immediate restrict
\ *** Block No. 20 Hexblock 14
\ Target tools ks05mar86we
Onlyforth Ttools also definitions
| : ttype ( adr n -) bounds ?DO I T c@ H dup
bl > IF emit ELSE drop Ascii . emit THEN LOOP ;
: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
ELSE ." ??? " THEN space ?cr ;
| : nfa? ( cfa lfa - nfa / cfa ff)
BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ even =
IF 2+ nip exit THEN
T @ H REPEAT ;
: >name ( cfa - nfa / ff)
Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
IF nip exit THEN
swap REPEAT nip ;
\ *** Block No. 21 Hexblock 15
\ Ttools for decompiling ks05mar86we
| : ?: dup 4 u.r ." :" ;
| : @? dup T @ H 6 u.r ;
| : c? dup T c@ H 3 .r ;
: s ( addr - addr+ ) ?: space c? 3 spaces
dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
: n ( addr - addr+2 ) ?: @? 2 spaces
dup T @ H [ Ttools ] >name .name H 2+ ;
: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP
2 spaces -rot ttype ;
\ *** Block No. 22 Hexblock 16
\ Tools for decompiling bp05mar86we
: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ;
: c ( addr -- addr+1 ) 1 d ;
: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ;
: dump ( adr n -) bounds ?DO cr I $10 d drop
stop? IF LEAVE THEN $10 +LOOP ;
: view T ' H [ Ttools ] >name ?dup
IF 4- T @ H l THEN ;
\ *** Block No. 23 Hexblock 17
\ reinterpretation def.-words 05mar86we
Onlyforth
: redefinition
tdoes> @ IF >in push [ ' >interpret >body ] Literal push
state push context push >in: @ >in !
name [ ' Transient 2+ ] Literal (find nip 0=
IF cr ." Redefinition: " here .name
>in: @ >in ! : Defining interpret THEN
THEN 0 tdoes> ! ;
\ *** Block No. 24 Hexblock 18
\ Create..does> structure bp05mar86we
| : (;tcode Tlast @ dup T c@ dup 1 and - 2+ + ! H rdrop ;
| : changecfa compile lit tdoes> @ , compile (;tcode ;
Defining definitions
: ;code 0 ?pairs changecfa reveal rdrop ;
immediate restrict
Defining ' ;code Alias does> immediate restrict
: ; [compile] ; rdrop ; immediate restrict
\ *** Block No. 25 Hexblock 19
\ redefinition conditionals bp27jun85we
' DO Alias DO immediate restrict
' ?DO Alias ?DO immediate restrict
' LOOP Alias LOOP immediate restrict
' IF Alias IF immediate restrict
' THEN Alias THEN immediate restrict
' ELSE Alias ELSE immediate restrict
' BEGIN Alias BEGIN immediate restrict
' UNTIL Alias UNTIL immediate restrict
' WHILE Alias WHILE immediate restrict
' REPEAT Alias REPEAT immediate restrict
\ *** Block No. 26 Hexblock 1A
\ clear Liter. Ascii ['] ." bp05mar86we
Onlyforth Transient definitions
: clear true abort" There are ghosts" ;
: Literal ( n -) T compile lit , H ; immediate
: Ascii H bl word 1+ c@ state @
IF T [compile] Literal H THEN ; immediate
: ['] T ' [compile] Literal H ; immediate restrict
: " T compile (" ," H ; immediate restrict
: ." T compile (." ," H ; immediate restrict
\ *** Block No. 27 Hexblock 1B
\ Target compilation ] [ bp05mar86we
Forth definitions
: tcompile
?stack >in @ name find ?dup
IF 0> IF nip execute >interpret THEN
drop dup >in ! name
THEN gfind IF nip execute >interpret THEN
nullstring? IF drop exit THEN
number? ?dup IF 0> IF swap T [compile] Literal THEN
[compile] Literal H drop >interpret THEN
drop >in ! Word, >interpret ;
Transient definitions
: ] H state on ['] tcompile is >interpret ;
\ *** Block No. 28 Hexblock 1C
\ Target conditionals bp05mar86we
: IF T compile ?branch >mark H 1 ; immediate restrict
: THEN abs 1 T ?pairs >resolve H ; immediate restrict
: ELSE T 1 ?pairs compile branch >mark swap >resolve
H -1 ; immediate restrict
: BEGIN T <mark H 2 ; immediate restrict
: WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
immediate restrict
| : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
WHILE drop T >resolve H REPEAT ;
: UNTIL T compile ?branch (repeat H ; immediate restrict
: REPEAT T compile branch (repeat H ; immediate restrict
\ *** Block No. 29 Hexblock 1D
\ Target conditionals bp27jun85we
: DO T compile (do >mark H 3 ; immediate restrict
: ?DO T compile (?do >mark H 3 ; immediate restrict
: LOOP T 3 ?pairs compile (loop compile endloop
>resolve H ; immediate restrict
: +LOOP T 3 ?pairs compile (+loop compile endloop
>resolve H ; immediate restrict
\ *** Block No. 30 Hexblock 1E
\ predefinitions bp05mar86we
: abort" T compile (abort" ," H ; immediate
: error" T compile (err" ," H ; immediate
Forth definitions
Variable torigin
Variable tudp 0 Tudp !
: >user T c@ H torigin @ + ;
\ *** Block No. 31 Hexblock 1F
\ Datatypes bp05mar86we
Transient definitions
: origin! H torigin ! ;
: user' ( -- n ) T ' >body c@ H ;
: uallot ( n -- ) H tudp @ swap tudp +! ;
DO> >user ;
: User prebuild User 2 T uallot c, ;
DO> ;
: Create prebuild Create ;
DO> T @ H ;
: Constant prebuild Constant T , ;
: Variable Create 2 T allot ;
\ *** Block No. 32 Hexblock 20
\ Datatypes bp05mar86we
dummy
: Vocabulary
H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
here H tvoc-link @ T , H tvoc-link ! ;
\ *** Block No. 33 Hexblock 21
\ target defining words bp08sep86we
Do> ;
: Defer prebuild Defer 2 T allot ;
: Is T ' H >body state @ IF T compile (is , H
ELSE T ! H THEN ; immediate
| : dodoes> T compile (;code H Glast' @
there resdoes> there tdoes> ! ;
: ;code 0 T ?pairs dodoes> Assembler H [compile] [
redefinition ; immediate restrict
: does> T dodoes> $4EAB , \ FP D) JSR
compile (dodoes> H ; immediate restrict
\ *** Block No. 34 Hexblock 22
\ : Alias ; bp25mar86we
: Create: T Create H current @ context ! T ] H 0 ;
dummy
: : H tdoes> off >in @ >in: ! T prebuild :
H current @ context ! T ] H 0 ;
: Alias ( n -- ) H Tlast off (theader Ghost over resolve
tlast @ T c@ H $20 or tlast @ T c! , H ;
: ; T 0 ?pairs compile unnest [compile] [ H redefinition ;
immediate restrict
\ *** Block No. 35 Hexblock 23
\ predefinitions bp11sep86we
: compile T compile compile H ; immediate restrict
: Host H Onlyforth Ttools also ;
: Compiler T Host H Transient also definitions ;
: [compile] H Word, ; immediate restrict
: Onlypatch H there 4- 0 tdoes> ! 0 ;
Onlyforth
: Target Onlyforth Transient also definitions ;
Transient definitions
Ghost c, drop
\ *** Block No. 36 Hexblock 24
\ *** Block No. 37 Hexblock 25
\ *** Block No. 38 Hexblock 26
\ *** Block No. 39 Hexblock 27

136
sources/AtariST/TASKER.FB.src
View File

@ -1,136 +0,0 @@
Screen 0 not modified
0 \\ *** Multitasker *** bp 12oct86
1
2 Dieses File enth„lt die Worte f<>r das Multitasking.
3
4 Mit TASK werden Tasks eingerichtet. Jede Task hat ihren eige-
5 nen Daten- und Returnstack, deren Gr”že beim Einrichten der
6 Task angegeben werden muž.
7
8 Mit MULTITASK wird der Tasker eingeschaltet, mit SINGLETASK
9 abgeschaltet. Mit TASKS kann man die Tasks im System und
10 ihren Zustand anzeigen.
11
12 N„heres zur Funktionsweise des Taskers findet man im Handbuch,
13 ebenso wie ein ausf<73>hrliches Glossar !
14
15
Screen 1 not modified
0 \ Multitasker Loadscreen 22nov86bp
1
2 Onlyforth
3
4 \needs Code 2 loadfrom assemble.scr
5 \needs multitask 1 +load
6
7 02 05 +thru \ Tasker
8 06 +load \ Spooler
9
10
11
12
13
14
15
Screen 2 not modified
0 \ stop singletask multitask 14sep86we
1
2 Code stop
3 .l FP IP suba .w IP SP -) move
4 .l FP RP suba .w RP SP -) move
5 UP R#) D6 move D6 reg) A0 lea
6 .l FP SP suba .w SP 8 A0 D) move
7 2 A0 D) D6 move D6 reg) jmp end-code
8
9 Label taskpause
10 UP R#) D6 move D6 reg) A0 lea $4E43 # A0 ) move
11 Forth ' stop @ Assembler bra end-code
12
13 : singletask [ ' pause @ ] Literal ['] pause ! ;
14
15 : multitask taskpause ['] pause ! ;
Screen 3 not modified
0 \ pass activate bp 12oct86
1
2 | : (pass ( n0 ... nm-1 Taskaddr m -- )
3 rdrop swap \ delete IP of ACTIVATE or PASS
4 $4E43 over ! \ awake Task
5 r> -rot \ get the IP; Stack: IP m Taskaddr
6 &10 + >r \ push s0 of Task
7 r@ 2+ @ swap \ Stack-Top: IP r0 m
8 2+ 2* \ bytes on Taskstack incl. r0 & IP
9 r@ @ over - \ new SP
10 dup r> 2- ! \ into Ssave
11 swap bounds ?DO I ! 2 +LOOP ;
12
13 : activate ( Taddr -- ) 0 (pass ; restrict
14
15 : pass ( n0 ... nm-1 Taskaddr m ) (pass ; restrict
Screen 4 not modified
0 \ sleep wake taskerror bp 12oct86
1
2 : sleep ( Taddr -- ) $3C3C swap ! ; \ # D6 move opcode
3 : wake ( Taddr -- ) $4E43 swap ! ; \ Trap 3 opcode
4
5 | : taskerror ( string -- )
6 standardi/o singletask bell
7 at? &24 0 at ." Task error : " rot count type at
8 multitask stop ;
9
10
11
12
13
14
15
Screen 5 not modified
0 \ Task 14sep86we
1
2 : Task ( rlen slen -- )
3 2 arguments
4 0 Constant here >r \ Task-dp
5 even dup r@ + r@ 2- ! allot even \ 68000 align
6 up@ here 100 cmove \ init user area
7 here $3C3C , up@ 2+ @ , \ JMP opcode to sleep task
8 $4EF3 , $6800 ,
9 dup up@ 2+ ! \ link task
10 dup 6 - dup , , \ ssave and s0
11 2dup + , \ here + rlen = r0
12 r@ , \ dp
13 under + here - allot 0 ,
14 ['] taskerror swap [ ' errorhandler >body c@ ] Literal + !
15 r> 2- 2- , ;
Screen 6 not modified
0 \ rendezvous 's tasks 22nov86bp
1
2 : rendezvous ( semaphoraddr -- )
3 dup unlock pause lock ;
4
5 | : statesmart state @ IF [compile] Literal THEN ;
6
7 : 's ( Taddr -- adr ) \ adr is adress of the foll. uservar
8 ' >body c@ + statesmart ; immediate
9
10 : tasks ( -- )
11 cr ." Main " up@ dup 2+ @
12 BEGIN 2dup - WHILE cr dup [ ' r0 >body c@ ] Literal + @
13 2+ @ >name .name
14 dup @ $3C3C = IF ." sleeping" THEN
15 2+ @ REPEAT 2drop ;
Screen 7 not modified
0 \ Printerspool 21oct86we
1
2 $100 $200 Task spooler
3
4 : spool' ( -- ) \ reads word
5 ' isfile@ offset @ base @ spooler depth 1- 6 min pass
6 base ! offset ! isfile ! execute
7 true abort" SPOOL' ready for next job!" stop ;
8
9 \\ syntax:
10 spool' listing
11 spool' printall
12 from to spool' pthru
13 from to spool' document
14
15

136
sources/AtariST/TASKER.fth Normal file
View File

@ -0,0 +1,136 @@
\ *** Block No. 0 Hexblock 0
\\ *** Multitasker *** bp 12oct86
Dieses File enth„lt die Worte f<EFBFBD>r das Multitasking.
Mit TASK werden Tasks eingerichtet. Jede Task hat ihren eige-
nen Daten- und Returnstack, deren Gr”že beim Einrichten der
Task angegeben werden muž.
Mit MULTITASK wird der Tasker eingeschaltet, mit SINGLETASK
abgeschaltet. Mit TASKS kann man die Tasks im System und
ihren Zustand anzeigen.
N„heres zur Funktionsweise des Taskers findet man im Handbuch,
ebenso wie ein ausf<EFBFBD>hrliches Glossar !
\ *** Block No. 1 Hexblock 1
\ Multitasker Loadscreen 22nov86bp
Onlyforth
\needs Code 2 loadfrom assemble.scr
\needs multitask 1 +load
02 05 +thru \ Tasker
06 +load \ Spooler
\ *** Block No. 2 Hexblock 2
\ stop singletask multitask 14sep86we
Code stop
.l FP IP suba .w IP SP -) move
.l FP RP suba .w RP SP -) move
UP R#) D6 move D6 reg) A0 lea
.l FP SP suba .w SP 8 A0 D) move
2 A0 D) D6 move D6 reg) jmp end-code
Label taskpause
UP R#) D6 move D6 reg) A0 lea $4E43 # A0 ) move
Forth ' stop @ Assembler bra end-code
: singletask [ ' pause @ ] Literal ['] pause ! ;
: multitask taskpause ['] pause ! ;
\ *** Block No. 3 Hexblock 3
\ pass activate bp 12oct86
| : (pass ( n0 ... nm-1 Taskaddr m -- )
rdrop swap \ delete IP of ACTIVATE or PASS
$4E43 over ! \ awake Task
r> -rot \ get the IP; Stack: IP m Taskaddr
&10 + >r \ push s0 of Task
r@ 2+ @ swap \ Stack-Top: IP r0 m
2+ 2* \ bytes on Taskstack incl. r0 & IP
r@ @ over - \ new SP
dup r> 2- ! \ into Ssave
swap bounds ?DO I ! 2 +LOOP ;
: activate ( Taddr -- ) 0 (pass ; restrict
: pass ( n0 ... nm-1 Taskaddr m ) (pass ; restrict
\ *** Block No. 4 Hexblock 4
\ sleep wake taskerror bp 12oct86
: sleep ( Taddr -- ) $3C3C swap ! ; \ # D6 move opcode
: wake ( Taddr -- ) $4E43 swap ! ; \ Trap 3 opcode
| : taskerror ( string -- )
standardi/o singletask bell
at? &24 0 at ." Task error : " rot count type at
multitask stop ;
\ *** Block No. 5 Hexblock 5
\ Task 14sep86we
: Task ( rlen slen -- )
2 arguments
0 Constant here >r \ Task-dp
even dup r@ + r@ 2- ! allot even \ 68000 align
up@ here 100 cmove \ init user area
here $3C3C , up@ 2+ @ , \ JMP opcode to sleep task
$4EF3 , $6800 ,
dup up@ 2+ ! \ link task
dup 6 - dup , , \ ssave and s0
2dup + , \ here + rlen = r0
r@ , \ dp
under + here - allot 0 ,
['] taskerror swap [ ' errorhandler >body c@ ] Literal + !
r> 2- 2- , ;
\ *** Block No. 6 Hexblock 6
\ rendezvous 's tasks 22nov86bp
: rendezvous ( semaphoraddr -- )
dup unlock pause lock ;
| : statesmart state @ IF [compile] Literal THEN ;
: 's ( Taddr -- adr ) \ adr is adress of the foll. uservar
' >body c@ + statesmart ; immediate
: tasks ( -- )
cr ." Main " up@ dup 2+ @
BEGIN 2dup - WHILE cr dup [ ' r0 >body c@ ] Literal + @
2+ @ >name .name
dup @ $3C3C = IF ." sleeping" THEN
2+ @ REPEAT 2drop ;
\ *** Block No. 7 Hexblock 7
\ Printerspool 21oct86we
$100 $200 Task spooler
: spool' ( -- ) \ reads word
' isfile@ offset @ base @ spooler depth 1- 6 min pass
base ! offset ! isfile ! execute
true abort" SPOOL' ready for next job!" stop ;
\\ syntax:
spool' listing
spool' printall
from to spool' pthru
from to spool' document

272
sources/AtariST/TOOLS.FB.src
View File

@ -1,272 +0,0 @@
Screen 0 not modified
0 \\ *** Tools *** 25may86we
1
2 In diesem File sind die wichtigsten Debugging-Tools enthalten.
3
4 Dazu geh”ren ein einfacher Decompiler, ein Speicherdump und
5 der Tracer (s. Kapitel im Handbuch)
6 Vor allem der Tracer hat sich als sehr sinnvolles Werkzeug bei
7 der Fehlerbek„mpfung entwickelt. Normalerweise sind Fehlerquel-
8 len beim Tracen sofort auffindbar, manchmal allerdings auch
9 nicht ganz so schnell ...
10
11
12
13
14
15
Screen 1 not modified
0 \ Loadscreen for simple decompiler 26oct86we
1
2 Onlyforth Vocabulary Tools Tools also definitions
3
4 1 5 +thru
5 6 +load \ Tracer
6
7 Onlyforth
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Tools for decompiling 26oct86we
1
2 | : ?: dup 4 u.r ." :" ;
3 | : @? dup @ 6 u.r ;
4 | : c? dup c@ 3 .r ;
5
6 : s ( adr - adr+ )
7 ?: space c? 3 spaces dup 1+ over c@ type
8 dup c@ + 1+ even ;
9
10 : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ;
11 : k ( adr - adr+2 ) ?: 5 spaces @? 2+ ;
12 : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ;
13
14
15
Screen 3 not modified
0 \ Tools for decompiling 26oct86we
1
2 : d ( adr n - adr+n)
3 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ;
4
5 : c ( adr - adr+1) 1 d ;
6
7
8 \\
9 : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE
10 THEN 10 +LOOP ;
11
12
13
14 \ dekompiliere String Name Konstant Char Branch Dump
15 \ = = = = = =
Screen 4 not modified
0 \ General Dump Utility - Output 26oct86we
1
2 | : .2 ( n -- ) 0 <# # # #> type space ;
3 | : .6 ( d -- ) <# # # # # # # #> type ;
4 | : d.2 ( addr len -- ) bounds ?DO I c@ .2 LOOP ;
5 | : emit. ( char -- ) $7F and
6 dup bl $7E uwithin not IF drop Ascii . THEN emit ;
7
8 | : dln ( addr --- )
9 cr dup 6 u.r 2 spaces 8 2dup d.2 space
10 over + 8 d.2 space $10 bounds ?DO I c@ EMIT. LOOP ;
11 | : ?.n ( n1 n2 -- n1 )
12 2dup = IF ." \/" drop ELSE 2 .r THEN space ;
13 | : ?.a ( n1 n2 -- n1 )
14 2dup = IF ." v" drop ELSE 1 .r THEN ;
15
Screen 5 not modified
0 \ Longdump basics 24aug86we
1
2 | : ld.2 ( hiaddr loaddr len -- hiaddr )
3 bounds ?DO I over lc@ .2 LOOP ;
4
5 | : ldln ( hiaddr loaddr -- )
6 cr dup >r over .6 2 spaces
7 r@ 8 ld.2 space r@ 8 + 8 ld.2 space
8 r> $10 bounds ?DO I over lc@ emit. LOOP drop ;
9
10 | : .head ( addr len -- addr' len' )
11 swap dup -$10 and swap $0F and cr 8 spaces
12 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP
13 space $10 0 DO I ?.a LOOP rot + ;
14
15
Screen 6 not modified
0 \ Dump and Fill Memory Utility 10sep86we
1
2 Forth definitions
3
4 : ldump ( laddr len -- )
5 base push hex >r swap r> .head
6 bounds ?DO dup I ldln stop? IF LEAVE THEN
7 I $FFF0 = IF 1+ THEN $10 +LOOP drop ;
8
9 : dump ( addr len -- )
10 base push hex .head
11 bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ;
12
13
14
15
Screen 7 not modified
0 \ Trace Loadscreen 26oct86we
1
2 Onlyforth \needs Tools Vocabulary Tools
3 Tools also definitions
4
5 \needs cpush 1 +load
6 \needs >absaddr : >absaddr 0 forthstart d+ ;
7
8 2 8 +thru
9
10 Onlyforth
11
12
13
14
15
Screen 8 not modified
0 \ throw status on Return-Stack 26oct86we
1
2 | Create: cpull
3 rp@ count 2dup + even rp! r> swap cmove ;
4
5 : cpush ( addr len --) r> -rot over >r
6 rp@ over 2+ - even dup rp! place cpull >r >r ;
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Variables do-trace 10sep86we
1
2 | Variable (W \ Variable for saving W
3 | Variable <ip \ start of trace trap range
4 | Variable ip> \ end of trace trap range
5 | Variable nest? \ True if NEST shall performed
6 | Variable newnext \ Address of new Next for tracing
7 | Variable last' \ holds adr of position in traced word
8 | Variable #spaces \ for indenting nested trace
9 | Variable trap? \ True if trace is allowed
10
11
12
13
14
15
Screen 10 not modified
0 \ install Tracer 11sep86we
1
2 Label trnext 0 # D6 move .l 0 D6 FP DI) jmp end-code
3
4 Label (do-trace newnext R#) D0 move D0 trnext 2+ R#) move
5 .w trnext # D6 move .l D6 reg) A0 lea A0 D5 move
6 .w UP R#) D6 move
7 .l ' next-link >body c@ D6 FP DI) D6 .w move
8 BEGIN .l D6 reg) A1 lea .w D6 tst 0<>
9 WHILE .w &10 # A1 suba .l D5 A0 move
10 A0 )+ A1 )+ move A0 )+ A1 )+ move
11 .w 2 A1 addq A1 ) D6 move
12 REPEAT rts end-code
13
14 Code do-trace \ opposite of end-trace
15 (do-trace bsr Next end-code
Screen 11 not modified
0 \ reenter tracer 04sep86we
1
2 | : oneline .status space query interpret -&82 allot
3 rdrop ( delete quit from tracenext ) ;
4
5 | Code (step
6 RP )+ D7 move .l D7 IP lmove FP IP adda
7 .w (W R#) D7 move -1 # trap? R#) move
8 Label fnext
9 D7 reg) D6 move D6 reg) jmp end-code
10
11 | Create: nextstep (step ;
12
13 : (debug ( addr -- ) \ start tracing at addr
14 dup <ip ! BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
15
Screen 12 not modified
0 \ check trace conditions 10sep86we
1
2 Label tracenext tracenext newnext !
3 IP )+ D7 move
4 trap? R#) tst fnext beq
5 .b nest? R#) D0 move \ byte order!!
6 0= IF .l IP D0 move FP D0 sub
7 .w <ip R#) D0 cmp fnext bcs
8 ip> R#) D0 cmp fnext bhi
9 ELSE .b 0 # nest? R#) move THEN \ low byte still set
10
11 \ one trace condition satisfied
12 .w D7 (W R#) move trap? R#) clr
13
14
15
Screen 13 not modified
0 \ tracer display 26oct86we
1
2 ;c: nest? @
3 IF nest? off r> ip> push <ip push dup 2- (debug
4 #spaces push 1 #spaces +! >r THEN
5 r@ nextstep >r input push output push standardi/o
6 2- dup last' !
7 cr #spaces @ spaces dup 5 u.r @ dup 6 u.r 2 spaces
8 >name .name $1C col - 0 max spaces .s
9 state push blk push >in push ['] 'quit >body push
10 [ ' >interpret >body ] Literal push
11 #tib push tib #tib @ cpush r0 push rp@ r0 !
12 &82 allot ['] oneline Is 'quit quit ;
13
14
15
Screen 14 not modified
0 \ DEBUG with errorchecking 11sep86we
1
2 | : traceable ( cfa -- adr)
3 recursive dup @
4 ['] : @ case? ?exit
5 ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN
6 ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN
7 ['] r/w @ case? IF >body @ traceable exit THEN
8 drop dup @ @ $4EAB = IF @ 4+ exit THEN \ 68000 voodoo code
9 >name .name ." can't be DEBUGged" quit ;
10
11 : nest \ trace next high-level word executed
12 last' @ @ traceable drop nest? on ;
13
14 : unnest \ ends tracing of actual word
15 <ip on ip> off ; \ clears trap range
Screen 15 not modified
0 \ misc. words for tracing bp 9Mar86
1
2 : endloop \ sets trap range next current word
3 last' @ 4+ <ip ! ; \ used to skip LOOPs, REPEATs, ...
4
5 ' end-trace Alias unbug
6
7 Forth definitions
8
9 : debug ( --) \ reads a word
10 ' traceable Tools (debug
11 nest? off trap? on #spaces off do-trace ;
12
13 : trace' ( --) \ traces fol. word
14 debug <ip perform end-trace ;
15

272
sources/AtariST/TOOLS.fth Normal file
View File

@ -0,0 +1,272 @@
\ *** Block No. 0 Hexblock 0
\\ *** Tools *** 25may86we
In diesem File sind die wichtigsten Debugging-Tools enthalten.
Dazu geh”ren ein einfacher Decompiler, ein Speicherdump und
der Tracer (s. Kapitel im Handbuch)
Vor allem der Tracer hat sich als sehr sinnvolles Werkzeug bei
der Fehlerbek„mpfung entwickelt. Normalerweise sind Fehlerquel-
len beim Tracen sofort auffindbar, manchmal allerdings auch
nicht ganz so schnell ...
\ *** Block No. 1 Hexblock 1
\ Loadscreen for simple decompiler 26oct86we
Onlyforth Vocabulary Tools Tools also definitions
1 5 +thru
6 +load \ Tracer
Onlyforth
\ *** Block No. 2 Hexblock 2
\ Tools for decompiling 26oct86we
| : ?: dup 4 u.r ." :" ;
| : @? dup @ 6 u.r ;
| : c? dup c@ 3 .r ;
: s ( adr - adr+ )
?: space c? 3 spaces dup 1+ over c@ type
dup c@ + 1+ even ;
: n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ;
: k ( adr - adr+2 ) ?: 5 spaces @? 2+ ;
: b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ;
\ *** Block No. 3 Hexblock 3
\ Tools for decompiling 26oct86we
: d ( adr n - adr+n)
2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ;
: c ( adr - adr+1) 1 d ;
\\
: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE
THEN 10 +LOOP ;
\ dekompiliere String Name Konstant Char Branch Dump
\ = = = = = =
\ *** Block No. 4 Hexblock 4
\ General Dump Utility - Output 26oct86we
| : .2 ( n -- ) 0 <# # # #> type space ;
| : .6 ( d -- ) <# # # # # # # #> type ;
| : d.2 ( addr len -- ) bounds ?DO I c@ .2 LOOP ;
| : emit. ( char -- ) $7F and
dup bl $7E uwithin not IF drop Ascii . THEN emit ;
| : dln ( addr --- )
cr dup 6 u.r 2 spaces 8 2dup d.2 space
over + 8 d.2 space $10 bounds ?DO I c@ EMIT. LOOP ;
| : ?.n ( n1 n2 -- n1 )
2dup = IF ." \/" drop ELSE 2 .r THEN space ;
| : ?.a ( n1 n2 -- n1 )
2dup = IF ." v" drop ELSE 1 .r THEN ;
\ *** Block No. 5 Hexblock 5
\ Longdump basics 24aug86we
| : ld.2 ( hiaddr loaddr len -- hiaddr )
bounds ?DO I over lc@ .2 LOOP ;
| : ldln ( hiaddr loaddr -- )
cr dup >r over .6 2 spaces
r@ 8 ld.2 space r@ 8 + 8 ld.2 space
r> $10 bounds ?DO I over lc@ emit. LOOP drop ;
| : .head ( addr len -- addr' len' )
swap dup -$10 and swap $0F and cr 8 spaces
8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP
space $10 0 DO I ?.a LOOP rot + ;
\ *** Block No. 6 Hexblock 6
\ Dump and Fill Memory Utility 10sep86we
Forth definitions
: ldump ( laddr len -- )
base push hex >r swap r> .head
bounds ?DO dup I ldln stop? IF LEAVE THEN
I $FFF0 = IF 1+ THEN $10 +LOOP drop ;
: dump ( addr len -- )
base push hex .head
bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ;
\ *** Block No. 7 Hexblock 7
\ Trace Loadscreen 26oct86we
Onlyforth \needs Tools Vocabulary Tools
Tools also definitions
\needs cpush 1 +load
\needs >absaddr : >absaddr 0 forthstart d+ ;
2 8 +thru
Onlyforth
\ *** Block No. 8 Hexblock 8
\ throw status on Return-Stack 26oct86we
| Create: cpull
rp@ count 2dup + even rp! r> swap cmove ;
: cpush ( addr len --) r> -rot over >r
rp@ over 2+ - even dup rp! place cpull >r >r ;
\ *** Block No. 9 Hexblock 9
\ Variables do-trace 10sep86we
| Variable (W \ Variable for saving W
| Variable <ip \ start of trace trap range
| Variable ip> \ end of trace trap range
| Variable nest? \ True if NEST shall performed
| Variable newnext \ Address of new Next for tracing
| Variable last' \ holds adr of position in traced word
| Variable #spaces \ for indenting nested trace
| Variable trap? \ True if trace is allowed
\ *** Block No. 10 Hexblock A
\ install Tracer 11sep86we
Label trnext 0 # D6 move .l 0 D6 FP DI) jmp end-code
Label (do-trace newnext R#) D0 move D0 trnext 2+ R#) move
.w trnext # D6 move .l D6 reg) A0 lea A0 D5 move
.w UP R#) D6 move
.l ' next-link >body c@ D6 FP DI) D6 .w move
BEGIN .l D6 reg) A1 lea .w D6 tst 0<>
WHILE .w &10 # A1 suba .l D5 A0 move
A0 )+ A1 )+ move A0 )+ A1 )+ move
.w 2 A1 addq A1 ) D6 move
REPEAT rts end-code
Code do-trace \ opposite of end-trace
(do-trace bsr Next end-code
\ *** Block No. 11 Hexblock B
\ reenter tracer 04sep86we
| : oneline .status space query interpret -&82 allot
rdrop ( delete quit from tracenext ) ;
| Code (step
RP )+ D7 move .l D7 IP lmove FP IP adda
.w (W R#) D7 move -1 # trap? R#) move
Label fnext
D7 reg) D6 move D6 reg) jmp end-code
| Create: nextstep (step ;
: (debug ( addr -- ) \ start tracing at addr
dup <ip ! BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
\ *** Block No. 12 Hexblock C
\ check trace conditions 10sep86we
Label tracenext tracenext newnext !
IP )+ D7 move
trap? R#) tst fnext beq
.b nest? R#) D0 move \ byte order!!
0= IF .l IP D0 move FP D0 sub
.w <ip R#) D0 cmp fnext bcs
ip> R#) D0 cmp fnext bhi
ELSE .b 0 # nest? R#) move THEN \ low byte still set
\ one trace condition satisfied
.w D7 (W R#) move trap? R#) clr
\ *** Block No. 13 Hexblock D
\ tracer display 26oct86we
;c: nest? @
IF nest? off r> ip> push <ip push dup 2- (debug
#spaces push 1 #spaces +! >r THEN
r@ nextstep >r input push output push standardi/o
2- dup last' !
cr #spaces @ spaces dup 5 u.r @ dup 6 u.r 2 spaces
>name .name $1C col - 0 max spaces .s
state push blk push >in push ['] 'quit >body push
[ ' >interpret >body ] Literal push
#tib push tib #tib @ cpush r0 push rp@ r0 !
&82 allot ['] oneline Is 'quit quit ;
\ *** Block No. 14 Hexblock E
\ DEBUG with errorchecking 11sep86we
| : traceable ( cfa -- adr)
recursive dup @
['] : @ case? ?exit
['] key @ case? IF >body c@ Input @ + @ traceable exit THEN
['] type @ case? IF >body c@ Output @ + @ traceable exit THEN
['] r/w @ case? IF >body @ traceable exit THEN
drop dup @ @ $4EAB = IF @ 4+ exit THEN \ 68000 voodoo code
>name .name ." can't be DEBUGged" quit ;
: nest \ trace next high-level word executed
last' @ @ traceable drop nest? on ;
: unnest \ ends tracing of actual word
<ip on ip> off ; \ clears trap range
\ *** Block No. 15 Hexblock F
\ misc. words for tracing bp 9Mar86
: endloop \ sets trap range next current word
last' @ 4+ <ip ! ; \ used to skip LOOPs, REPEATs, ...
' end-trace Alias unbug
Forth definitions
: debug ( --) \ reads a word
' traceable Tools (debug
nest? off trap? on #spaces off do-trace ;
: trace' ( --) \ traces fol. word
debug <ip perform end-trace ;

85
sources/AtariST/TUTORIAL.FB.src
View File

@ -1,85 +0,0 @@
Screen 0 not modified
0 bp 27Aug86
1 W i l l k o m m e n
2 i m
3 v o l k s F O R T H 8 3 - E d i t o r
4
5 Dieses File soll eine kurze Einf<6E>hrung in das volksFORTH83
6 geben. Schalten Sie bitte den Schreibschutz der Disketten an.
7 Probieren Sie ruhig den Editor etwas aus. Er befindet sich im
8 Auto-Hilfe-Modus, den Sie sicherlich von 1ST_WORD kennen...
9
10 Verlassen Sie dann bitte den Editor mit der Esc-Taste, tippen
11 Sie EMPTY-BUFFERS BYE ein und dr<64>cken Sie die Return-Taste.
12
13 Danach sollten Sie Ihre Disketten kopieren und die 1ST_WORD-
14 Files ausdrucken, die Ihnen noch mehr Dinge erkl„ren.
15
Screen 1 not modified
0 bp 27Aug86
1 Einiges sollten Sie zu diesem Editor noch wissen:
2
3 Einige Files auf dieser Diskette enthalten sog. Shadow Screens.
4 Das sind Screens mit Kommentaren. Jeder Screen mit Programmtext
5 hat dann einen Shadow Screen. Enth„lt ein File Shadows, so
6 sind sie alle in der zweiten H„lfte des Files abgespeichert.
7 Mit SHADOW SCR k”nnen Sie dann bequem zwischen Programm-
8 und Shadow-Screen hin und herschalten.
9
10 Mit VIEW k”nnen Sie sofort die Stelle finden, an der ein
11 Forth-Wort gespeichert ist. Geben Sie einfach ein Wort ein,
12 dr<64>cken Sie die Return-Taste und schon sind Sie am Ort.... ,
13 falls es das Wort gibt und Sie die richtige Diskette eingelegt
14 haben.
15
Screen 2 not modified
0 bp 27Aug86
1
2 Aužerdem unterst<73>tzt der Editor einen Zeilen- und Zeichenstack.
3 Falls Sie einen Screen umbauen wollen, k”nnen Sie Zeilen auf
4 den Stack bewegen und an anderer Stelle wieder hervorholen.
5 Probieren Sie es ruhig aus. Versuchen Sie z.B. , die oberste
6 Zeile nach unten zu kopieren.
7
8 Wenn Sie diesen Screen ruiniert haben, dr<64>cken Sie einfach
9 die UNDO-Taste und schon ist alles wieder in Ordnung.
10 Ge„nderte Screens werden n„mlich nicht sofort auf die Diskette
11 geschrieben, sondern solange in Puffern aufbewahrt, bis kein
12 Puffer mehr frei ist. Solange sich ein Block in einem Puffer
13 befindet, k”nnen Sie Ihre Žnderungen mit UNDO r<>ckg„ngig machen
14 Das volksFORTH hat ca. 8 solche Puffer, diese Zahl k”nnen Sie
15 aber auch „ndern. Wie, steht im Kapitel 'Getting started'.
Screen 3 not modified
0 bp 27Aug86
1
2 Darum sollten Sie sich also nicht wundern, wenn ihre Diskette
3 ruhig ist, obwohl Sie auf einen anderen Screen gehen. Er wahr
4 dann noch im Puffer.
5 Links oben im Fenster wird angezeigt, ob der Screen im Puffer
6 ge„ndert wurde, d.h. anders als sein Original auf der Diskette
7 aussieht.
8
9 Rechts oben auf diesem Screen sehen Sie meine ID. Sie besteht
10 aus meinen Initialen und dem Tag, an dem ich diesen Text
11 getippt habe. Wenn Sie Ihre ID in GET ID... eintragen, wird
12 sie automatisch auf jeden Screen kopiert, den Sie modifiziert
13 haben. Nach UNDO steht dort nat<61>rlich wieder meine ID und
14 nicht mehr Ihre.
15
Screen 4 not modified
0 bp 27Aug86
1 Schliežlich gibt es noch eine F<>lle von M”glichkeiten, den
2 aktuellen Screen zu wechseln, Zeichen zu l”schen oder
3 einzuf<75>gen, Zeilen zu manipulieren und den Cursor zu bewegen.
4 Sie sollten sich mit diesen M”glichkeiten vertraut machen, denn
5 sie werden Ihr Programmiererdasein erleichtern.
6
7 Damit <20>berlasse ich Sie Ihrer Neugier und bin gespannt, was
8 sie mit unserem Forth machen...
9
10 Bernd Pennemann
11
12 P.S. Dieses File k”nnen Sie mit USE TUTORIAL.SCR 0 4 PTHRU
13 ausdrucken lassen ...
14
15

85
sources/AtariST/TUTORIAL.fth Normal file
View File

@ -0,0 +1,85 @@
\ *** Block No. 0 Hexblock 0
bp 27Aug86
W i l l k o m m e n
i m
v o l k s F O R T H 8 3 - E d i t o r
Dieses File soll eine kurze Einf<EFBFBD>hrung in das volksFORTH83
geben. Schalten Sie bitte den Schreibschutz der Disketten an.
Probieren Sie ruhig den Editor etwas aus. Er befindet sich im
Auto-Hilfe-Modus, den Sie sicherlich von 1ST_WORD kennen...
Verlassen Sie dann bitte den Editor mit der Esc-Taste, tippen
Sie EMPTY-BUFFERS BYE ein und dr<EFBFBD>cken Sie die Return-Taste.
Danach sollten Sie Ihre Disketten kopieren und die 1ST_WORD-
Files ausdrucken, die Ihnen noch mehr Dinge erkl„ren.
\ *** Block No. 1 Hexblock 1
bp 27Aug86
Einiges sollten Sie zu diesem Editor noch wissen:
Einige Files auf dieser Diskette enthalten sog. Shadow Screens.
Das sind Screens mit Kommentaren. Jeder Screen mit Programmtext
hat dann einen Shadow Screen. Enth„lt ein File Shadows, so
sind sie alle in der zweiten H„lfte des Files abgespeichert.
Mit SHADOW SCR k”nnen Sie dann bequem zwischen Programm-
und Shadow-Screen hin und herschalten.
Mit VIEW k”nnen Sie sofort die Stelle finden, an der ein
Forth-Wort gespeichert ist. Geben Sie einfach ein Wort ein,
dr<EFBFBD>cken Sie die Return-Taste und schon sind Sie am Ort.... ,
falls es das Wort gibt und Sie die richtige Diskette eingelegt
haben.
\ *** Block No. 2 Hexblock 2
bp 27Aug86
Aužerdem unterst<EFBFBD>tzt der Editor einen Zeilen- und Zeichenstack.
Falls Sie einen Screen umbauen wollen, k”nnen Sie Zeilen auf
den Stack bewegen und an anderer Stelle wieder hervorholen.
Probieren Sie es ruhig aus. Versuchen Sie z.B. , die oberste
Zeile nach unten zu kopieren.
Wenn Sie diesen Screen ruiniert haben, dr<EFBFBD>cken Sie einfach
die UNDO-Taste und schon ist alles wieder in Ordnung.
Ge„nderte Screens werden n„mlich nicht sofort auf die Diskette
geschrieben, sondern solange in Puffern aufbewahrt, bis kein
Puffer mehr frei ist. Solange sich ein Block in einem Puffer
befindet, k”nnen Sie Ihre Žnderungen mit UNDO r<EFBFBD>ckg„ngig machen
Das volksFORTH hat ca. 8 solche Puffer, diese Zahl k”nnen Sie
aber auch „ndern. Wie, steht im Kapitel 'Getting started'.
\ *** Block No. 3 Hexblock 3
bp 27Aug86
Darum sollten Sie sich also nicht wundern, wenn ihre Diskette
ruhig ist, obwohl Sie auf einen anderen Screen gehen. Er wahr
dann noch im Puffer.
Links oben im Fenster wird angezeigt, ob der Screen im Puffer
ge„ndert wurde, d.h. anders als sein Original auf der Diskette
aussieht.
Rechts oben auf diesem Screen sehen Sie meine ID. Sie besteht
aus meinen Initialen und dem Tag, an dem ich diesen Text
getippt habe. Wenn Sie Ihre ID in GET ID... eintragen, wird
sie automatisch auf jeden Screen kopiert, den Sie modifiziert
haben. Nach UNDO steht dort nat<EFBFBD>rlich wieder meine ID und
nicht mehr Ihre.
\ *** Block No. 4 Hexblock 4
bp 27Aug86
Schliežlich gibt es noch eine F<EFBFBD>lle von M”glichkeiten, den
aktuellen Screen zu wechseln, Zeichen zu l”schen oder
einzuf<EFBFBD>gen, Zeilen zu manipulieren und den Cursor zu bewegen.
Sie sollten sich mit diesen M”glichkeiten vertraut machen, denn
sie werden Ihr Programmiererdasein erleichtern.
Damit <EFBFBD>berlasse ich Sie Ihrer Neugier und bin gespannt, was
sie mit unserem Forth machen...
Bernd Pennemann
P.S. Dieses File k”nnen Sie mit USE TUTORIAL.SCR 0 4 PTHRU
ausdrucken lassen ...

51
sources/AtariST/UNDO.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ Undo for the VolksForth command line cas2013apr05
1
2 The tool extends the VolksForth "decode" function
3 with an UNDO. If there was a typo in the previous line
4 pressing the UNDO key will re-fetch the last entered line so
5 that it can be edited
6
7 Published in VD 3/87 by Bernd Pennemann
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Undo for Atari ST cas2013apr05
1 Onlyforth
2
3 | $6100 Constant #undo
4
5 : undoSTdecode ( addr pos1 key -- addr pos2 )
6 over 0= if
7 #undo case? if at? >r >r
8 over #tib @ dup span ! type
9 r> r> at exit then then
10 STdecode ;
11
12 Input: keyboard STkey STkey? undoSTdecode STexpect ;
13
14 keyboard save
15
Screen 2 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

51
sources/AtariST/UNDO.fth Normal file
View File

@ -0,0 +1,51 @@
\ *** Block No. 0 Hexblock 0
\\ Undo for the VolksForth command line cas2013apr05
The tool extends the VolksForth "decode" function
with an UNDO. If there was a typo in the previous line
pressing the UNDO key will re-fetch the last entered line so
that it can be edited
Published in VD 3/87 by Bernd Pennemann
\ *** Block No. 1 Hexblock 1
\ Undo for Atari ST cas2013apr05
Onlyforth
| $6100 Constant #undo
: undoSTdecode ( addr pos1 key -- addr pos2 )
over 0= if
#undo case? if at? >r >r
over #tib @ dup span ! type
r> r> at exit then then
STdecode ;
Input: keyboard STkey STkey? undoSTdecode STexpect ;
keyboard save
\ *** Block No. 2 Hexblock 2

306
sources/cpm/ASS8080.FB.src
View File

@ -1,306 +0,0 @@
Screen 0 not modified
0 \ VolksForth 8080 Assembler UH 09Mar86
1
2 Ideen lieferten:
3 John Cassady
4 Mike Perry
5 Klaus Schleisiek
6 Bernd Pennemann
7 Dietrich Weineck
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ VolksForth 8080 Assembler Load Screen UH 03Jun86
1 Onlyforth Assembler also definitions hex
2
3 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr
4
5 OnlyForth
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ Vektorisierte Erzeugung UH 03Jun86
1 Variable >codes
2
3 | Create nrc ] c, , c@ here allot ! c! [
4
5 : nonrelocate ( -- ) nrc >codes ! ; nonrelocate
6
7 | : >exec ( n -- n+2 )
8 Create dup c, 2+ does> c@ >codes @ + perform ;
9
10 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here
11 | >exec >allot | >exec >! | >exec >c!
12 drop
13
14
15
Screen 3 not modified
0 \ Register und Definierende Worte UH 09Mar86
1
2 7 Constant A
3 0 Constant B 1 Constant C 2 Constant D 3 Constant E
4 0 Constant I 1 Constant I' 2 Constant W 3 Constant W'
5 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L
6 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S
7
8 | : 1MI Create >c, does> C@ >c, ;
9 | : 2MI Create >c, does> C@ + >c, ;
10 | : 3MI Create >c, does> C@ swap 8 * + >c, ;
11 | : 4MI Create >c, does> C@ >c, >c, ;
12 | : 5MI Create >c, does> C@ >c, >, ;
13
14
15
Screen 4 not modified
0 \ Mnemonics UH 09Mar86
1 00 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc
2 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg
3 C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc
4 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl
5 E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa
6 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana
7 A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr
8 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push
9 C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in
10 C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani
11 EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call
12 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp
13 C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo
14 EA 5MI jpe F2 5MI jp FA 5MI jm
15
Screen 5 not modified
0 \ Spezial Mnemonics und Spruenge UH 09Mar86
1 DA Constant C0= D2 Constant C0<> D2 Constant CS
2 C2 Constant 0= CA Constant 0<> E2 Constant PE
3 F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ;
4
5 : mov 8 * 40 + + >c, ;
6 : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ;
7
8 : [[ ( -- addr ) >here ; \ BEGIN
9 : ?] ( addr opcode -- ) >c, >, ; \ UNTIL
10 : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF
11 : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE
12 : ]? ( addr -- ) >here swap >! ; \ THEN
13 : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE
14 : ]] ( addr -- ) jmp ; \ AGAIN
15 : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT
Screen 6 not modified
0 \ Macros UH 14May86
1 : end-code context 2- @ context ! ;
2
3 : ;c: 0 recover call end-code ] ;
4
5 : Next >next jmp ;
6
7 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high )
8 H dcx 1+ M mov ( low ) RP shld ;
9
10 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx
11 M swap mov ( high ) H inx RP shld ;
12 \ rpush und rpop gehen nicht mit HL
13
14 : mvx ( src dest -- )
15 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ;
Screen 7 not modified
0 \ Definierende Worte UH 06Aug86
1 Forth definitions
2 : Code ( -- ) Create here dup 2- ! Assembler ;
3
4 : ;Code ( -- ) 0 ?pairs
5 compile [ ' does> >body 2+ @ , ]
6 reveal [compile] [ Assembler ; immediate
7
8 : >label ( adr -- )
9 here | Create swap , 4 hallot >here 4 - heap 4 cmove
10 heap last @ (name> ! dp !
11 does> ( -- adr ) @ State @ IF [compile] Literal THEN ;
12
13 : Label [ Assembler ] >here >label Assembler ;
14
15
Screen 8 not modified
0 UH 14May86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 9 not modified
0 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 % VolksForth 8080 Assembler UH 03Jun86
1
2 Der 8080 Assembler wurde von John Cassady, in den Forth
3 Dimensions veroeffentlicht und von Mike Perry im F83
4 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat
5 und auch Befehle zur strukturierten Assemblerprogrammierung.
6 Um ein Wort in Assembler zu definieren wird das definierende
7 Wort Code benutzt, es kann, muss aber nicht mit end-code beendet
8 werden. Wie der Assembler arbeitet ist ein interessantes
9 Beispiel fuer die Maechtigkeit von Create does>.
10 Am Anfang werden die Befehle in Klassen eingeteilt und fuer
11 jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic
12 des Befehls spaeter interpretiert wird, kompiliert er den
13 entsprechenden Opcode.
14
15
Screen 11 not modified
0 % Vektorisierte Erzeugung UH 09Mar86
1 Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren.
2
3 Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler
4
5 Schaltet Assembler in den In-Line Modus.
6
7 Definierendes Wort fuer Erzeugungs-Operator-Namen.
8
9
10 Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden
11 aktuellen Erzeugungsoperator aus.
12
13 Mit diesen Erweiterungen kann der Assembler auch fuer den
14 Target-Compiler benutzt werden.
15
Screen 12 not modified
0 % Register und Definierende Worte UH 09Mar86
1
2 Die 8080 Register werden definiert. Es sind einfach Konstanten
3 die Information fuer die Mnemonics hinterlassen.
4 Einige Register der Forth-Maschine:
5 IP ist BC, W ist DE
6
7
8 Definierende Worte fuer die Mnemonics.
9 Fast alle 8080 Befehle fallen in diese 5 Klassen.
10
11
12
13
14
15
Screen 13 not modified
0 % Mnemonics UH 09Mar86
1 Die 8080 Mnemonics werden definiert.
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 14 not modified
0 % Spezial Mnemonics und Spruenge UH 09Mar86
1 Vergleiche des 8080
2
3 not folgt einem Vergleich, wenn er invertiert werden soll.
4
5 die Mnemonics, die sich nicht in die Klassen MI1 bis MI5
6 einteilen lassen.
7
8 Die strukturierten Assembler-Anweisungen.
9 Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungen
10 zu den strukturierten Anweisungen in Forth entstehen.
11 Es findet keine Absicherung der Kontrollstrukturen statt, sodass
12 sie auch beliebig missbraucht, werden koennen.
13 Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig.
14
15
Screen 15 not modified
0 % Macros UH 17May86
1 end-code beendet eine Code-Definition
2
3 ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten.
4
5 Next Assembliert einen Sprung zum Adress-Interpretierer.
6
7 rpush Das angegebene Register wird auf den Return-Stack gelegt.
8
9
10 rpop Das angegebene Register wird vom Return-Stack genommen.
11
12 rpush und rpop benutzen das HL Register.
13
14 mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register
15 Bewegt Registerpaare HL BC DE
Screen 16 not modified
0 % Definierende Worte UH 17May86
1 Code leitet eine Code-Definition ein.
2
3 ;code ist das Low-Level-Aequivalent von does>
4
5
6 >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert
7
8
9
10
11 Label erzeugt ein Label auf dem Heap, mit dem Wert von here
12
13
14
15
Screen 17 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

34
sources/cpm/ASSTRAN.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \\ Transinient Assembler 11Nov86
1
2 Dieses File enthaelt Befehle, die den Assembler vollstaendig in
3 den Heap laden, so dass er schliesslich mit clear wieder
4 vergessen werden kann.
5
6 Dadurch ist es nicht notwendig in einer Anwendung den ganzen
7 Assembler im Speicher lassen zu muessen, nur weil einige
8 primitive Worte in Assembler geschrieben sind.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Internal Assembler UH 22Oct86
1
2 Onlyforth
3
4 here
5 $C00 hallot heap dp ! include ass8080.scr
6 dp !
7
8
9
10
11
12
13
14
15

34
sources/cpm/COPY.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \ Copy und Convey 19Nov87
1
2 Dieses File enthaelt Definitionen, die urspruenglich im Kern
3 enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern
4 klein zu halten.
5
6 copy kopiert einen Screen
7
8 convey kopiert einen Bereich von Screens
9
10
11
12
13
14
15
Screen 1 not modified
0 \ moving blocks 20Oct86 19Nov87
1 | : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
2 | : fromblock ( blk -- adr ) fromfile @ (block ;
3 | : (copy ( from to -- )
4 dup isfile@ core? IF prev @ emptybuf THEN
5 full? IF save-buffers THEN
6 offset @ + isfile@ rot fromblock 6 - 2! update ;
7 | : blkmove ( from to quan --) save-buffers >r
8 over r@ + over u> >r 2dup u< r> and
9 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
10 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN
11 save-buffers 2drop ;
12
13 : copy ( from to --) 1 blkmove ;
14 : convey ( [blk1 blk2] [to.blk --)
15 swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ;

306
sources/cpm/DISASS.FB.src
View File

@ -1,306 +0,0 @@
Screen 0 not modified
0 \\ Z80-Disassembler 08Nov86
1
2 Dieses File enthaelt einen Z80-Disassembler, der assemblierten
3 Code in Standard Zilog-Z80 Mnemonics umsetzt.
4
5 Benutzung:
6
7 TOOLS ALSO \ Schalte Disassembler-Vokabular an
8
9 addr DIS \ Disassembliere ab Adresse addr
10
11 xxxx displace ! \ Beruecksichte bei allen Adressen einen
12 \ Versatz von xxxx.
13 \ Wird gebraucht, wenn ein Assemblerstueck
14 \ nicht an dem Platz disassembliert wird,
15 \ an dem es ablaeuft.
Screen 1 not modified
0 \ Z80-Disassembler Load Screen 08Nov86
1
2 Onlyforth Tools also definitions hex
3
4 ' Forth | Alias F: immediate
5 ' Tools | Alias T: immediate
6
7 1 $10 +THRU cr .( Disassembler geladen. ) cr
8
9 OnlyForth
10
11
12 \\ Fragen Anregungen & Kritik an:
13 U. Hoffmann
14 Harmsstrasse 71
15 2300 Kiel 1
Screen 2 not modified
0 \ Speicherzugriff und Ausgabe 07Jul86
1 internal
2 \needs Case: : Case: Create: Does> swap 2* + perform ;
3
4 Variable index Variable address Variable offset
5 Variable oldoutput
6 external Variable displace displace off internal
7
8 ' pad Alias str1 ( -- addr )
9 : str2 ( -- addr ) str1 $40 + ;
10
11 : byte ( -- b ) address @ displace @ + c@ ;
12 : word ( -- w ) address @ displace @ + @ ;
13
14 : .byte ( byte -- ) 0 <# # #s #> type ;
15 : .word ( addr -- ) 0 <# # # # #s #> type ;
Screen 3 not modified
0 \ neue Bytes lesen Byte-Fraktionen 07Jul86
1
2 : next-byte output push oldoutput @ output !
3 byte .byte space 1 address +! ;
4
5 : next-word next-byte next-byte ;
6
7 : f ( -- b ) byte $40 / ;
8 : g ( -- b ) byte 8 / 7 and ;
9 : h ( -- b ) byte 7 and ;
10 : j ( -- b ) g 2/ ;
11 : k ( -- b ) g 1 and ;
12
13 \\ 76543210
14 ffggghhh
15 jjk
Screen 4 not modified
0 \ Select" 08Nov86
1
2 : scan/ ( limit start -- limit start' ) over swap
3 DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ;
4
5 : select ( n addr len -- addr' len' )
6 bounds rot
7 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN
8 LOOP under scan/ nip over - ;
9
10 : (select" ( n -- ) "lit count select type ;
11
12 : select" ( -- ) compile (select" ," ; immediate
13
14 : append ( c str -- )
15 under count + c! dup c@ 1+ swap c! ;
Screen 5 not modified
0 \ StringOutput 07Jul86
1
2 Variable $
3
4 : $emit ( c -- ) $ @ append pause ;
5
6 : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ;
7
8 : $cr ( -- ) $ @ off ;
9
10 : $at? ( -- row col ) 0 $ @ c@ ;
11
12 Output: $output
13 $emit $cr $type noop $cr 2drop $at? ;
14
15
Screen 6 not modified
0 \ Register 07Jul86
1
2 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN
3 select" B/C/D/E/H/L/$/A" ;
4
5 : double-reg ( n -- ) select" BC/DE/%/SP" ;
6
7 : double-reg2 ( n -- ) select" BC/DE/%/AF" ;
8
9 : num ( n -- ) select" 0/1/2/3/4/5/6/7" ;
10
11 : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ;
12
13 : arith ( n -- )
14 select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ;
15
Screen 7 not modified
0 \ no-prefix Einteilung der Befehle in Klassen 07Jul86
1
2 : 00xxx000
3 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN
4 select" nop/ex AF,AF'/djnz ?/jr ?" ;
5
6 : 00xxx001
7 k IF ." add %," j double-reg exit THEN
8 ." ld " j double-reg ." ,&" ;
9
10 : 00xxx010 ." ld " g
11 select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)"
12 ;
13
14 : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ;
15
Screen 8 not modified
0 \ no-prefix 07Jul86
1
2 : 00xxx100 ." inc " g reg ;
3
4 : 00xxx101 ." dec " g reg ;
5
6 : 00xxx110 ." ld " g reg ." ,#" ;
7
8 : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ;
9
10 : 01xxxxxx ." ld " g reg ." ," h reg ;
11
12 : 10xxxxxx g arith h reg ;
13
14
15
Screen 9 not modified
0 \ no-prefix 07Jul86
1
2 : 11xxx000 ." ret " g cond ;
3
4 : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN
5 ." pop " j double-reg2 ;
6
7 : 11xxx010 ." JP " g cond ." ,&" ;
8
9 : 11xxx011 g
10 select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ;
11
12 : 11xxx100 ." call " g cond ;
13 : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ;
14 : 11xxx110 g arith ." #" ;
15 : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ;
Screen 10 not modified
0 \ no-prefix 07Jul86
1
2 Case: 00xxxhhh
3 00xxx000 00xxx001 00xxx010 00xxx011
4 00xxx100 00xxx101 00xxx110 00xxx111 ;
5
6 Case: 11xxxhhh
7 11xxx000 11xxx001 11xxx010 11xxx011
8 11xxx100 11xxx101 11xxx110 11xxx111 ;
9
10 : 00xxxxxx h 00xxxhhh ;
11 : 11xxxxxx h 11xxxhhh ;
12
13 Case: ffxxxxxx
14 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ;
15
Screen 11 not modified
0 \ no-prefix 07Jul86
1
2 : get-offset index @ 0> IF byte offset ! next-byte THEN ;
3
4 : no-prefix f ffxxxxxx next-byte get-offset ;
5
6
7
8
9
10
11
12
13
14
15
Screen 12 not modified
0 \ CB-Prefix 07Jul86
1
2 : CB-00xxxxxx
3 g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ;
4
5 : CB-01xxxxxx ." bit " g num ." ," h reg ;
6
7 : CB-10xxxxxx ." res " g num ." ," h reg ;
8
9 : CB-11xxxxxx ." set " g num ." ," h reg ;
10
11 case: singlebit
12 CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ;
13
14 : CB-prefix get-offset f singlebit next-byte ;
15
Screen 13 not modified
0 \ ED-Prefix 30Sep86
1 : ED-01xxx000 ." in (C)," g reg ;
2 : ED-01xxx001 ." out (C)," g reg ;
3 : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN
4 ." HL," j double-reg ;
5 : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN
6 ." (&)," j double-reg ;
7 : ED-01xxx100 ." neg" ;
8 : ED-01xxx101 k IF ." reti" exit THEN ." retn" ;
9 : ED-01xxx110 g select" im 0/-/im 1/im 2" ;
10 : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ;
11 : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ;
12 Case: ED-01xxxhhh
13 ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011
14 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ;
15 : ED-01xxxxxx h ED-01xxxhhh ;
Screen 14 not modified
0 \ ED-Prefix 07Jul86
1
2 Case: extended
3 noop ED-01xxxxxx ED-10xxxxxx noop ;
4
5 : ED-prefix get-offset f extended next-byte ;
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ Disassassemblieren eines einzelnen Befehls 30Sep86
1
2 : index-register ( n -- ) index ! next-byte ;
3
4 : get-instruction ( -- )
5 index off str1 $ ! cr
6 byte $DD = IF 1 index-register ELSE
7 byte $FD = IF 2 index-register THEN THEN
8 byte $76 case? IF next-byte ." halt" exit THEN
9 $CB case? IF next-byte CB-prefix exit THEN
10 $ED case? IF next-byte ED-prefix exit THEN
11 drop no-prefix ;
12
13
14
15
Screen 16 not modified
0 \ Adressierungsarten ausgeben 07Jul86 27Nov87
1 : .index-register ( -- ) index @ abs select" HL/IX/IY" ;
2
3 : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ;
4 : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ;
5
6 : .offset ( -- ) offset @ offset-sign
7 extend under dabs <# # #s rot +- #> type ;
8 : .index-register-offset
9 index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ;
10
11 : .inline-byte ( -- ) byte .byte next-byte ;
12 : .inline-word ( -- ) word .word next-word ;
13
14 : .displace ( -- )
15 byte offset-sign address @ + 1+ .word next-byte ;
Screen 17 not modified
0 \ Hauptebene: dis 07Jul86
1 : .char ( c -- )
2 Ascii % case? IF .index-register exit THEN
3 Ascii $ case? IF .index-register-offset exit THEN
4 Ascii # case? IF .inline-byte exit THEN
5 Ascii & case? IF .inline-word exit THEN
6 Ascii ? case? IF .displace exit THEN emit ;
7
8 : instruction ( -- ) cr address @ .word 2 spaces
9 output @ oldoutput ! $output get-instruction
10 str2 $ ! cr str1 count 0 ?DO count .char LOOP drop
11 oldoutput @ output ! $20 col - 0 max spaces str2 count type ;
12
13 external
14 : dis ( addr -- ) address !
15 BEGIN instruction stop? UNTIL ;

51
sources/cpm/DOUBLE.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ Double words 11Nov86
1
2 Dieses File enthaelt Worte fuer 32-Bit Objekte.
3
4 Im Kern bereits enthalten sind:
5
6 2@ 2! 2dup 2drop 2swap dnegate d+
7
8 Hier werden definiert:
9
10 2Variable 2Constant 2over d*
11
12
13
14
15
Screen 1 not modified
0 \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86
1
2 : 2Variable Variable 2 allot ;
3 : 2Constant Create , , does> 2@ ;
4
5 Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi
6 SP dad M D mov H dcx M E mov D push
7 H dcx M D mov H dcx M E mov D push Next end-code
8 --> \\
9 Code 2@ ( addr -- 32b ) H pop H push
10 H inx H inx M E mov H inx M D mov H pop D push
11 M E mov H inx M D mov D push Next end-code
12
13 Code 2! ( 32b addr -- ) H pop
14 D pop E M mov H inx D M mov H inx
15 D pop E M mov H inx D M mov Next end-code
Screen 2 not modified
0 \ d* d- 29Jun86
1
2 : d* ( d1 d2 -- d1*d2 )
3 rot 2over rot um* 2swap um* d+ 2swap um* d+ ;
4
5 : d- ( d1 d2 -- d1-d2 ) dnegate d+ ;
6
7
8
9
10
11
12
13
14
15

544
sources/cpm/EDITOR.FB.src
View File

@ -1,544 +0,0 @@
Screen 0 not modified
0 \ Full-Screen Editor UH 02Nov86
1
2 Dieses File enthaelt den Full-Screen Editor fuer die CP/M -
3 volksFORTH-Version.
4
5 Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion
6 sowie Unterstuetzung des Shadow-Screen-Konzepts, der view-
7 Funktion und des sichtbaren Laden von Screens (showload).
8
9 Durch die integrierte Tastaturtabelle (keytable) laesst sich die
10 Kommandobelegung der Tasten auf einfache Art und Weise aendern.
11
12 Anregungen, Kritik und Verbesserungsvorschlaege bitte an:
13 U. Hoffmann
14 Harmsstrasse 71
15 2300 Kiel
Screen 1 not modified
0 \ Load Screen for the Editor UH 03Nov86 UH 27Nov87
1
2 Onlyforth cr
3
4 1 $1E +thru
5
6 Onlyforth
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 \ String primitves 27Nov87
1
2 : delete ( buffer size count -- )
3 over umin dup >r - 2dup over r@ + -rot cmove
4 + r> bl fill ;
5
6 : insert ( string length buffer size -- )
7 rot over umin dup >r -
8 over dup r@ + rot cmove> r> cmove ;
9
10 : replace ( string length buffer size -- ) rot umin cmove ;
11
12
13
14
15
Screen 3 not modified
0 \ usefull definitions and Editor vocabulary UH 27Nov87
1
2 : blank ( addr len -- ) bl fill ;
3
4 : ?enough ( n --) depth 1- > abort" Not enough Parameters" ;
5
6 : ?abort( ( f -- )
7 IF [compile] .( true abort" !" THEN [compile] ( ;
8
9 Vocabulary Editor
10
11 ' Forth | Alias F: immediate
12 ' Editor | Alias E: immediate
13
14 Editor also definitions
15
Screen 4 not modified
0 \ move cursor with position-checking 23Nov86
1
2 | : c ( n --) \ checks the cursor position
3 r# @ + dup 0 b/blk uwithin not
4 Abort" There is a border!" r# ! ;
5
6 \\
7
8 : c ( n --) \ goes thru the screens
9 r# @ + dup b/blk 1- > IF 1 scr +! THEN
10 dup 0< IF -1 scr +! THEN b/blk mod r# ! ;
11
12 : c ( n --) \ moves cyclic thru the screen
13 r# @ + b/blk mod r# ! ;
14
15
Screen 5 not modified
0 \ calculate addresses UH 31Oct86
1
2 | Code *line ( l -- adr )
3 H pop H dad H dad H dad
4 H dad H dad H dad Hpush jmp end-code
5
6 | Code /line ( n -- c l )
7 H pop L A mov $3F ani A E mov 0 D mvi
8 L A mov ral A L mov H A mov ral A H mov
9 L A mov ral A L mov H A mov ral A H mov
10 L A mov ral 3 ani H L mov A H mov
11 dpush jmp end-code
12
13 \\
14 | : *line ( l -- adr ) c/l * ;
15 | : /line ( n -- c l ) c/l /mod ;
Screen 6 not modified
0 \ calculate addresses UH 01Nov86
1
2 | : top ( -- ) r# off ;
3 | : cursor ( -- n ) r# @ ;
4 | : 'start ( -- adr ) scr @ block ;
5 | : 'end ( -- adr ) 'start b/blk + ;
6 | : 'cursor ( -- adr ) 'start cursor + ;
7 | : position ( -- c l ) cursor /line ;
8 | : line# ( -- l ) position nip ;
9 | : col# ( -- c ) position drop ;
10 | : 'line ( -- adr ) 'start line# *line + ;
11 | : 'line-end ( -- adr ) 'line c/l + 1- ;
12 | : #after ( -- n ) c/l col# - ;
13 | : #remaining ( -- n ) b/blk cursor - ;
14 | : #end ( -- n ) b/blk line# *line - ;
15
Screen 7 not modified
0 \ move cursor directed UH 01Nov86
1
2 | : curup c/l negate c ;
3 | : curdown c/l c ;
4 | : curleft -1 c ;
5 | : curright 1 c ;
6
7 | : +tab \ 1/4 line forth
8 cursor $10 / 1+ $10 * cursor - c ;
9
10 | : -tab \ 1/8 line back
11 cursor 8 mod negate dup 0= 8 * + c ;
12
13 | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ;
14 | : <cr> #after c ;
15
Screen 8 not modified
0 \ show border UH 27Nov87
1 &15 | Constant dx 1 | Constant dy
2
3 | : horizontal ( row -- row' )
4 dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ;
5
6 | : vertical ( row -- row' )
7 l/s 0 DO dup dx 1- at Ascii | emit
8 row dx c/l + at Ascii | emit 1+ LOOP ;
9
10 | : border dy 1- horizontal vertical horizontal drop ;
11
12 | : edit-at ( -- ) position swap dy dx d+ at ;
13
14 Forth definitions
15 : updated? ( -- f) scr @ block 2- @ 0< ;
Screen 9 not modified
0 \ display screen UH 02Nov86 UH 27Nouho
1 Editor definitions | Variable isfile' | Variable imode
2
3 | : .updated ( -- ) 7 0 at
4 updated? IF 4 spaces ELSE ." not " THEN ." updated" ;
5
6 | : redisplay ( line# -- )
7 dup dy + dx at *line 'start + c/l type ;
8
9 | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ;
10 | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file
11 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at
12 imode @ IF ." insert " exit THEN ." overwrite" ;
13
14 | : .screen l/s 0 DO I redisplay LOOP ;
15 | : .all .title .screen ;
Screen 10 not modified
0 \ check errors UH 02Nov86
1
2 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip
3 Abort" You would lose a line" ;
4
5 | : ?fit ( n -- ) 'line c/l -trailing nip + c/l >
6 IF line# redisplay
7 true Abort" You would lose a char" THEN ;
8
9 | : ?end 1 ?fit ;
10
11
12
13
14
15
Screen 11 not modified
0 \ programmer's id UH 02Nov86
1
2 $12 | Constant id-len
3 Create id id-len allot id id-len erase
4
5 | : stamp ( -- )
6 id 1+ count 'start c/l + over - swap cmove ;
7
8 | : ?stamp ( -- ) updated? IF stamp THEN ;
9
10 | : get-id ( -- )
11 id c@ ?exit id on
12 cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at
13 id id-len 2 /string expect rvsoff span @ id 1+ c! ;
14
15
Screen 12 not modified
0 \ update screen-display UH 02Dec86
1
2 | : emptybuf prev @ 2+ dup on 4+ off ;
3
4 | : undo emptybuf .all ;
5
6 | : modified updated? ?exit update .updated ;
7
8 | : linemodified modified line# redisplay ;
9
10 | : screenmodified modified
11 l/s line# ?DO I redisplay LOOP ;
12
13 | : .modified ( -- ) dy l/s + 4+ 0 at scr @ .
14 updated? not IF ." un" THEN ." modified" ?stamp ;
15
Screen 13 not modified
0 \ leave editor UH 02Dec86 UH 23Feb88
1 | Variable (pad (pad off
2 | : memtop ( -- adr) sp@ $100 - ;
3
4 | Create char 1 allot
5
6 ( | Variable imode ) imode off
7 | : setimode imode on .title ;
8 | : clrimode imode off .title ;
9 | : flipimode ( -- ) imode @ 0= imode ! .title ;
10
11 | : done ( -- )
12 ['] (quit is 'quit ['] (error errorhandler ! quit ;
13
14 | : update-exit ( -- ) .modified done ;
15 | : flushed-exit ( -- ) .modified save-buffers done ;
Screen 14 not modified
0 \ handle lines UH 01Nov86
1
2 | : (clear-line 'line c/l blank ;
3 | : clear-line (clear-line linemodified ;
4
5 | : clear> 'cursor #after blank linemodified ;
6
7 | : delete-line 'line #end c/l delete screenmodified ;
8
9 | : backline curup delete-line ;
10
11 | : (insert-line
12 ?bottom 'line c/l over #end insert (clear-line ;
13
14 | : insert-line (insert-line screenmodified ;
15
Screen 15 not modified
0 \ handle characters UH 01Nov86
1
2 | : delete-char 'cursor #after 1 delete linemodified ;
3
4 | : backspace curleft delete-char ;
5
6 | : (insert-char ?end 'cursor 1 over #after insert ;
7
8
9 | : insert-char (insert-char bl 'cursor c! linemodified ;
10
11 | : putchar ( --) char c@
12 imode @ IF (insert-char THEN
13 'cursor c! linemodified curright ;
14
15
Screen 16 not modified
0 \ stack lines UH 31Oct86
1
2 | Create lines 4 allot \ { 2+pointer | 2base }
3 | : 'lines ( -- adr) lines 2@ + ;
4
5 | : @line 'lines memtop u> Abort" line buffer full"
6 'line 'lines c/l cmove c/l lines +! ;
7
8 | : copyline @line curdown ;
9 | : line>buf @line delete-line ;
10
11 | : !line c/l negate lines +! 'lines 'line c/l cmove ;
12
13 | : buf>line lines @ 0= Abort" line buffer empty"
14 ?bottom (insert-line !line screenmodified ;
15
Screen 17 not modified
0 \ stack characters UH 01Nov86
1
2 | Create chars 4 allot \ { 2+pointer | 2base }
3 | : 'chars ( -- adr) chars 2@ + ;
4
5 | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full"
6 'cursor c@ 'chars c! 1 chars +! ;
7
8 | : copychar @char curright ;
9 | : char>buf @char delete-char ;
10
11 | : !char -1 chars +! 'chars c@ 'cursor c! ;
12
13 | : buf>char chars @ 0= Abort" char buffer empty"
14 ?end (insert-char !char linemodified ;
15
Screen 18 not modified
0 \ switch screens UH 03Nov86 UH 27Nov87
1
2 | Variable r#' r#' off
3 | Variable scr' scr' off
4 ( | Variable isfile' ) isfile@ isfile' !
5
6 | : associate \ switch to alternate screen
7 isfile' @ isfile@ isfile' ! isfile !
8 scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ;
9
10 | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ;
11 | : n ?stamp 1 scr +! .all ;
12 | : b ?stamp -1 scr +! .all ;
13 | : a ?stamp associate .all ;
14
15
Screen 19 not modified
0 \ shadow screens UH 03Nov86
1
2 Variable shadow shadow off
3
4 | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ;
5
6 | : >shadow ?stamp \ switch to shadow screen
7 (shadow dup scr @ u> not IF negate THEN scr +! .all ;
8
9
10
11
12
13
14
15
Screen 20 not modified
0 \ load and show screens UH 06Mar88
1
2 ' name >body &10 + | Constant 'name
3
4 | : showoff ['] exit 'name ! curoff rvsoff ;
5
6 | : show ( -- ) blk @ 0= IF showoff exit THEN
7 >in @ 1- r# ! curoff edit-at curon
8 stop? IF showoff true Abort" Break! " THEN
9 blk @ scr @ -
10 IF blk @ scr ! rvsoff curoff .all rvson curon THEN ;
11
12 | : showload ( -- ) ?stamp save-buffers
13 ['] show 'name ! curon rvson
14 ['] .status >body push ['] noop is .status
15 scr @ scr push scr off r# push r# @ (load showoff ;
Screen 21 not modified
0 \ find strings UH 01Nov86
1
2 | Variable insert-buffer
3 | Variable find-buffer
4 | : 'insert ( -- addr ) insert-buffer @ ;
5 | : 'find ( -- addr ) find-buffer @ ;
6
7 | : .buf ( addr -- ) count type ." |" &80 col - spaces ;
8
9 | : get ( addr -- ) >r at? r@ .buf
10 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN
11 at r> .buf ;
12
13 | : get-buffers dy l/s + 2+ dx 1- 2dup at
14 ." find: |" 'find get swap 1+ swap 2- at
15 ." ? replace: |" 'insert get ;
Screen 22 not modified
0 \ search for string UH 02Nov86 UH 27Nov87
1
2 | : skip ( addr -- addr' ) 'find c@ + ;
3
4 | : find? ( -- addr T | F )
5 'find count 'cursor #remaining "search ;
6
7 | : "find ( -- r# scr )
8 find? IF skip 'start - scr @ exit THEN ?stamp
9 capacity scr @ 1+
10 ?DO 'find count
11 I dup 5 5 at 4 .r block b/blk "search
12 IF skip I block - I endloop exit THEN
13 stop? Abort" Break! "
14 LOOP true Abort" not found!" ;
15
Screen 23 not modified
0 \ replace strings UH 03Nov86 UH 27Nov87
1 | : replace? ( -- f ) dy l/s + 3+ dx 3 - at
2 key dup #cr = IF line# redisplay true Abort" Break!" THEN
3 capital Ascii R = ;
4
5 | : "mark ( -- ) r# push
6 'find count dup negate c edit-at rvson type rvsoff ;
7
8 | : (replace 'insert c@ 'find c@ - ?fit
9 'find c@ negate c 'cursor #after 'find c@ delete
10 'insert count 'cursor #after insert
11 'insert c@ c modified ;
12
13 | : "replace get-buffers
14 BEGIN "find dup scr @ - swap scr ! IF .all THEN r# !
15 "mark replace? IF (replace THEN line# redisplay REPEAT ;
Screen 24 not modified
0 \ Control-Characters 'normal' CP/M uho 08May2005
1
2 Forth definitions
3
4 : Ctrl ( -- c )
5 name 1+ c@ $1F and state @ IF [compile] Literal THEN ;
6 immediate
7
8 $7F Constant #del
9
10 Editor definitions
11
12 \ | : flipimode imode @ 0= imode ! ;
13
14
15
Screen 25 not modified
0 \ Try a Screen-Editor 'normal' CP/M UH 29Nov86
1
2 Create keytable
3 Ctrl E c, Ctrl S c, Ctrl X c, Ctrl D c,
4 Ctrl I c, Ctrl J c, Ctrl O c, Ctrl K c,
5 Ctrl P c, Ctrl L c,
6 Ctrl H c, Ctrl H c, #del c, Ctrl G c,
7 Ctrl T c, Ctrl Y c, Ctrl N c,
8 Ctrl V c, Ctrl Z c,
9 #cr c, Ctrl F c, Ctrl A c,
10 Ctrl \ c, Ctrl U c,
11 Ctrl Q c, #esc c, Ctrl W c,
12 Ctrl C c, Ctrl R c, Ctrl ] c, Ctrl B c,
13
14
15 here keytable - Constant #keys
Screen 26 not modified
0 \ Try a screen Editor UH 29Nov86
1
2 Create: actiontable
3 curup curleft curdown curright
4 line>buf char>buf buf>line buf>char
5 copyline copychar
6 backspace backspace backspace delete-char
7 insert-char delete-line insert-line
8 flipimode ( clear-line ) clear>
9 <cr> +tab -tab
10 ( top >""end ) "replace undo
11 update-exit flushed-exit ( showload ) >shadow
12 n b a mark ;
13
14
15 here actiontable - 2/ 1- #keys - ?abort( # of actions)
Screen 27 not modified
0 \ find keys UH 01Nov86
1
2 | Code findkey ( key -- addr/default )
3 H pop L A mov keytable H lxi #keys $100 * D lxi
4 [[ M cmp 0=
5 ?[ actiontable H lxi 0 D mvi D dad D dad
6 M E mov H inx M D mov D push next ]?
7 H inx E inr D dcr 0= ?]
8 ' putchar H lxi hpush jmp
9 end-code
10
11 \\
12 | : findkey ( key -- adr/default )
13 #keys 0 DO dup keytable F: I + c@ =
14 IF drop E: actiontable F: I 2* + @ endloop exit THEN
15 LOOP drop ['] putchar ;
Screen 28 not modified
0 \ allocate buffers UH 01Nov86
1
2 c/l 2* | Constant cstack-size
3
4 | : nextbuf ( adr -- adr' ) cstack-size + ;
5
6 | : ?clearbuffer pad (pad @ = ?exit
7 pad dup (pad !
8 nextbuf dup find-buffer ! 'find off
9 nextbuf dup insert-buffer ! 'insert off
10 nextbuf dup 0 chars 2!
11 nextbuf 0 lines 2! ;
12
13
14
15
Screen 29 not modified
0 \ enter and exit the editor, editor's loop UH 02Nov86
1 | Variable jingle jingle on | : bell 07 con! jingle off ;
2
3 | : clear-error
4 jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ;
5
6 | : fullquit BEGIN ?clearbuffer edit-at key dup char c!
7 findkey execute clear-error REPEAT ;
8
9 | : fullerror ( string --) jingle @ IF bell THEN
10 dy l/s + 1+ dx $16 + at rvson count type rvsoff
11 &80 col - spaces scr @ capacity 1- min 0 max scr !
12 .title quit ;
13
14 | : install ( -- )
15 ['] fullquit Is 'quit ['] fullerror errorhandler ! ;
Screen 30 not modified
0 \ enter and exit the Editor UH 02Nov86
1
2 Forth definitions
3
4 : v ( -- ) E: 'start drop get-id install ?clearbuffer
5 page curoff border .all quit ;
6
7 : l ( scr -- ) 1 ?enough scr ! E: top F: v ;
8
9
10
11
12
13
14
15
Screen 31 not modified
0 \ savesystem uho 09May2uho
1
2 : savesystem \ save image
3 E: id off (pad off savesystem ;
4
5 | : >find ?clearbuffer >in push
6 bl word count 'find 1+ place
7 bl 'find 1+ dup >r count dup >r + c!
8 r> 2+ 'find c! bl r> c! ;
9 | : %view ( -- ) >find ' >name 4- @ (view
10 ?dup 0= Abort" hand made" scr !
11 E: top curdown find? 0=
12 IF ." From Scr # " scr @ u. true Abort" wrong file" THEN
13 skip 'start - 1- r# ! ;
14 : view ( -- ) %view scr @ list ;
15 : fix ( -- ) %view v ;

544
sources/cpm/FILEINT.FB.src
View File

@ -1,544 +0,0 @@
Screen 0 not modified
0 \ CP/M 2.2 File-Interface (3.80a) UH 05Oct87
1
2 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
3 Damit ist Zugriff auf normale CP/M-Files moeglich.
4 Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
5 die mit dem Massenspeicher arbeiten, auf dieses File.
6
7 Benutzung:
8 USE <name> \ benutze ein schon existierendes File
9 FILE <name> \ erzeuge ein Forthfile mit dem Namen <name>.
10 MAKE <name> \ Erzeuge ein File mit <name> und ordne
11 \ es dem aktuellen Forthfile zu.
12 MAKEFILE <name> \ Erzeuge ein File mit CP/M und FORTH-Namen
13 <name>.
14 INCLUDE <name> \ Lade File mit Forthnamen <name> ab Screen 1
15 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M)
Screen 1 not modified
0 \ CP/M 2.2 File-Interface load-Screen UH 18Feb88
1 OnlyForth
2
3 2 load \ view numbers for this file
4 3 4 thru \ DOS File Functions
5 5 $11 thru \ Forth File Functions
6 $12 $16 thru \ User Interface
7
8 File source.fb \ Define already existing Files
9 File fileint.fb File startup.fbr
10
11 ' (makeview Is makeview
12 ' remove-files Is custom-remove
13 ' file-r/w Is r/w
14 ' noop Is drvinit
15 \ include startup.fb \ load Standard System
Screen 2 not modified
0 \ Build correct view-numbers for this file UUH 19Nov87
1
2 | : fileintview ( -- ) $400 blk @ + ;
3
4 ' fileintview Is makeview
5
6
7
8
9
10
11
12
13
14
15
Screen 3 not modified
0 \ File Control Blocks UH 18Feb88
1 Dos definitions also
2 | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ;
3 &11 Constant filenamelen
4 0 2 | Fcbyte nextfile immediate
5 1 Fcbyte drive ' drive | Alias >dosfcb
6 filenamelen 3 - Fcbyte filename
7 3 Fcbyte extension
8 &21 + \ ex, s1, s2, rc, d0, ... dn, cr
9 2 Fcbyte record \ r0, r1
10 1+ \ r2
11 2 Fcbyte opened
12 2 Fcbyte fileno
13 2 Fcbyte filesize \ in 128-Byte-Records
14 4 Fcbyte position
15 Constant b/fcb
Screen 4 not modified
0 \ dos primitives UH 10Oct87
1
2 ' 2- | Alias body> ' 2- | Alias dosfcb>
3
4 : drive! ( drv -- ) $0E bdos ;
5 : search0 ( dosfcb -- dir ) $11 bdosa ;
6 : searchnext ( dosfcb -- dir ) $12 bdosa ;
7 : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ;
8 : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ;
9 : createfile ( dosfcb -- f ) $16 bdosa dos-error? ;
10 : size ( dos -- size ) dup $23 bdos dosfcb> record @ ;
11 : drive@ ( -- drv ) 0 $19 bdosa ;
12 : killfile ( dosfcb -- ) $13 bdos ;
13
14
15
Screen 5 not modified
0 \ File sizes UH 05Oct87
1
2 : (capacity ( fcb -- n ) \ filecapacity in blocks
3 filesize @ rec/blk u/mod swap 0= ?exit 1+ ;
4
5 : in-range ( block fcb -- )
6 (capacity u< not Abort" beyond capacity!" ;
7
8 Forth definitions
9
10 : capacity ( -- n ) isfile@ (capacity ;
11
12 Dos definitions
13
14
15
Screen 6 not modified
0 \ (open UH 18Feb88
1
2 : (open ( fcb -- )
3 dup opened @ IF drop exit THEN dup position 0. rot 2!
4 dup >dosfcb openfile Abort" not found!" dup opened on
5 dup >dosfcb size swap filesize ! ;
6
7 : (make ( fcb -- )
8 dup >dosfcb killfile
9 dup >dosfcb createfile Abort" directory full!"
10 dup position 0. rot 2!
11 dup filesize off opened on offset off ;
12
13 : file-r/w ( buffer block fcb f -- f )
14 over 0= Abort" no Direct Disk IO supported! "
15 >r dup (open 2dup in-range r> (r/w ;
Screen 7 not modified
0 \ Print Filenames UH 10Oct87
1
2 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN
3 fcb dosfcb> case? IF ." DEFAULT" exit THEN
4 body> >name .name ;
5
6 : .drive ( fcb -- ) drive c@ ?dup 0=exit
7 [ Ascii A 1- ] Literal + emit Ascii : emit ;
8
9 : .dosfile ( fcb -- ) dup filename 8 -trailing type
10 Ascii . emit extension 3 type ;
11
12
13
14
15
Screen 8 not modified
0 \ Print Filenames UH 10Oct87
1
2 : tab ( -- ) col &59 > IF cr exit THEN
3 &20 col &20 mod - 0 max spaces ;
4
5 : .fcb ( fcb -- ) dup fileno @ 3 u.r tab
6 dup .file tab dup .drive dup .dosfile
7 tab dup opened @ IF ." opened" ELSE ." closed" THEN
8 3 spaces base push decimal (capacity 3 u.r ." kB" ;
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Filenames UH 05Oct87
1
2 : !name ( addr len fcb -- )
3 dup >r filename filenamelen bl fill
4 over 1+ c@ Ascii : =
5 IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
6 ELSE 0 THEN r@ drive c! r> dup filename 2swap
7 filenamelen 1+ min bounds
8 ?DO I c@ Ascii . =
9 IF drop dup extension ELSE I c@ over c! 1+ THEN
10 LOOP 2drop ;
11
12 : !fcb ( fcb -- ) dup opened off name count rot !name ;
13
14
15
Screen 10 not modified
0 \ Print Directory UH 18Nov87
1
2 | Create dirbuf b/rec allot dirbuf b/rec erase
3 | Create fcb0 b/fcb allot fcb0 b/fcb erase
4
5 | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ;
6 | : (expand ( addr len -- ) false -rot bounds
7 ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ;
8 | : expand ( fcb -- ) \ expand * to ???
9 dup filename 8 (expand extension 3 (expand ;
10
11 : (dir ( addr len -- )
12 fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0
13 BEGIN dup dos-error? not
14 WHILE $20 * dirbuf + dosfcb> tab .dosfile
15 fcb0 >dosfcb searchnext stop? UNTIL drop ;
Screen 11 not modified
0 \ File List UH 10Oct87
1
2 User file-link file-link off
3
4 | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ;
5
6
7 Forth definitions
8
9 : forthfiles ( -- )
10 file-link @
11 BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ;
12
13 Dos definitions
14
15
Screen 12 not modified
0 \ Close a file UH 10Oct87
1
2 ' save-buffers >body $0C + @ | Alias backup
3
4 | : filebuffer? ( fcb -- fcb bufaddr/flag )
5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ;
6
7 | : flushfile ( fcb -- ) \ flush file buffers
8 BEGIN filebuffer? ?dup WHILE
9 dup backup emptybuf REPEAT drop ;
10
11 : (close ( fcb -- ) \ close file in fcb
12 dup flushfile
13 dup opened dup @ 0= IF 2drop exit THEN off
14 >dosfcb closefile Abort" not found!" ;
15
Screen 13 not modified
0 \ Create fcbs UH 10Oct87
1
2 : !files ( fcb -- ) dup isfile ! fromfile ! ;
3
4 ' r@ | Alias newfcb
5
6 Forth definitions
7
8 : File ( -- )
9 Create here >r b/fcb allot newfcb b/fcb erase
10 last @ count $1F and newfcb !name
11 #file newfcb fileno !
12 file-link @ newfcb nextfile ! r> file-link !
13 Does> !files ;
14
15 : direct 0 !files ;
Screen 14 not modified
0 \ flush buffers & misc. UH 10Oct87 UH 28Nov87
1 Dos definitions
2
3 : save-files ( -- ) file-link BEGIN @ ?dup WHILE
4 dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ;
5
6 ' save-files Is save-dos-buffers
7
8 \ : close-files ( -- ) file-link
9 \ BEGIN @ ?dup WHILE dup (close REPEAT ;
10
11 Forth definitions
12
13 : file? isfile@ .file ; \ print current file
14
15 : list ( n -- ) 3 spaces file? list ;
Screen 15 not modified
0 \ words for viewing UH 10Oct87
1
2 Forth definitions
3
4 | $200 Constant viewoffset \ max. %512 kB files
5
6 : (makeview ( -- n ) \ calc. view filed for a name
7 blk @ dup 0= ?exit
8 loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
9
10 : (view ( blk -- blk' ) \ select file and leave block
11 dup 0=exit
12 viewoffset u/mod file-link
13 BEGIN @ dup WHILE 2dup fileno @ = UNTIL
14 !files drop ; \ not found: direct access
15
Screen 16 not modified
0 \ FORGETing files UH 10Oct87
1
2 | : remove? ( dic symb addr -- dic symb addr f )
3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ;
4
5
6 | : remove-files ( dic symb -- dic symb ) \ flush files !
7 isfile@ remove? nip IF direct THEN
8 fromfile @ remove? nip IF fromfile off THEN
9 file-link
10 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
11 file-link remove ;
12
13
14
15
Screen 17 not modified
0 \ print a list of all buffers UH 20Oct86
1
2 : .buffers
3 prev BEGIN @ ?dup WHILE stop? abort" stopped"
4 cr dup u. dup 2+ @ dup 1+
5 IF ." Block: " over 4+ @ 5 .r
6 ." File : " [ Dos ] .file
7 dup 6 + @ 0< IF ." updated" THEN
8 ELSE ." Buffer empty" drop THEN REPEAT ;
9
10
11
12
13
14
15
Screen 18 not modified
0 \ File Interface User words UH 11Oct87
1
2 | : same ( addr -- ) >in ! ;
3 : open isfile@ (open offset off ;
4 : close isfile@ (close ;
5 : assign close isfile@ !fcb open ;
6 : make isfile@ dup !fcb (make ;
7
8 | : isfile? ( addr -- addr f ) \ is adr a fcb?
9 file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ;
10
11 : use >in @ name find \ create a fcb if not present
12 IF isfile? IF execute drop exit THEN THEN drop
13 dup same File same ' execute open ;
14
15
Screen 19 not modified
0 \ File Interface User words UH 25May88
1
2 : makefile >in @ File dup same ' execute same make ;
3 : emptyfile isfile@ >dosfcb createfile ;
4
5 : from isfile push use ;
6 : loadfrom ( n -- )
7 isfile push fromfile push use load close ;
8 : include 1 loadfrom ;
9
10 : eof ( -- f ) isfile@ dup filesize @ swap record @ = ;
11
12 : files " *.*" count (dir ;
13 : files" Ascii " word count 2dup upper (dir ;
14
15 ' files Alias dir ' files" Alias dir"
Screen 20 not modified
0 \ extend Files UH 20Nov87
1
2 | : >fileend isfile@ >dosfcb size drop ;
3
4 | : addblock ( n -- ) \ add block n to file
5 dup buffer under b/blk bl fill
6 isfile@ rec/blk over filesize +! false file-r/w
7 IF close Abort" disk full!" THEN ;
8
9 : more ( n -- ) open >fileend
10 capacity swap bounds ?DO I addblock LOOP close
11 open close ;
12
13 : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
14 0 Drive: a: Drive: b: Drive: c: Drive: d:
15 5 + Drive: j: drop
Screen 21 not modified
0 \ save memory-image as disk-file UH 29Nov86
1
2 Forth definitions
3
4 : savefile ( from count -- ) \ filename
5 isfile push makefile bounds
6 ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!"
7 b/rec +LOOP close ;
8
9
10
11
12
13
14
15
Screen 22 not modified
0 \ Status UH 10OCt87
1
2
3 : .blk ( -- ) blk @ ?dup 0=exit
4 dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ;
5
6 ' .blk Is .status
7
8
9
10
11
12
13
14
15
Screen 23 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 24 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 25 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 26 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 27 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 28 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 29 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 30 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 31 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

85
sources/cpm/HASHCASH.FB.src
View File

@ -1,85 +0,0 @@
Screen 0 not modified
0 \ HashCash Suchalgorithmus UH 11Nov86
1
2 Ein Algorithmus, der die Dictionarysuche beschleunigt:
3 Zuerst wird uebr das gesucht Wort gehasht und in in einer
4 Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal
5 gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen
6 herunter.
7
8 Hinzu kommen die Worte:
9 cash, hash-thread, erase-cash, 'cash, und found?
10
11 Im Kernal neudefiniert oder gepatched werden muessen:
12 (find, hide, reveal, forget-words
13
14 (find und (forget benutzen jejweils die alten Worte. Sie muessen
15 umbenannt oder in die neuen Worte eingebettet werden.
Screen 1 not modified
0 \ Hash Cash fuer volksFORTH UH 11Nov86
1
2 Create cash $200 allot
3
4 ' Forth >body Constant hash-thread
5 : erase-cash ( -- ) cash $200 erase ; erase-cash
6
7 1 3 +thru
8
9 patch (find
10 ( patch forget-words ) ' forget-words \ forget-words
11 dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen
12 dup ' (forget >body $12 + ! \ Adresse, sodass das automa-
13 dup ' empty >body 8 + ! \ tische Patchen nicht klappt.
14 ' save >body 4+ !
15 patch hide patch reveal forget (patch save
Screen 2 not modified
0 \ 'cash found? hfind UH 23Oct86
1
2 : 'cash ( nfa -- 'cash )
3 count $1F and under bounds
4 ?DO I c@ + LOOP $FF and 2* cash + ;
5
6 : found? ( str nfa -- f )
7 count rot count rot over = IF swap -text 0= exit THEN
8 drop 2drop false ;
9
10 : (find ( str thread -- str false | nfa true )
11 dup hash-thread - IF (find exit THEN
12 drop dup 'cash @ 2dup found? IF nip true exit THEN
13 drop hash-thread (find dup 0= ?exit over dup 'cash ! ;
14
15
Screen 3 not modified
0 \ Kernal changes UH 23Oct86
1
2 ' hide >body @ | Alias last?
3
4 : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ;
5
6 : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ;
7
8 ' clear >body 6 + @ | Alias forget-words
9
10 | : forget-words erase-cash forget-words ;
11
12 : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ;
13
14
15
Screen 4 not modified
0 \ patching UH 23Oct86
1
2 : (patch ( new old -- )
3 ['] cash 0 DO
4 i @ over = IF cr I u. over I ! THEN LOOP 2drop ;
5
6 : patch \ name
7 >in @ ' swap >in ! dup >name 2- context push context ! '
8 (patch ;
9
10
11
12
13
14
15

85
sources/cpm/INSTALL.FB.src
View File

@ -1,85 +0,0 @@
Screen 0 not modified
0 \\ Install Editor
1
2 Dieses File enthaelt einen Installer fuer den Editor.
3
4 Es werden nacheinander die Tasten erfragt, die einen bestimmten
5 Befehl ausloesen sollen.
6
7 Damit ist es moeglich, die Tastatur an die individuellen
8 Beduerfnisse anzupassen.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ install Editor UH 17Nov86
1
2 Onlyforth Editor also save warning on
3
4 : tab &20 col &20 mod - spaces ;
5 : .key ( c -- )
6 dup $7E > IF ." $" u. exit THEN
7 dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ;
8
9 : install \ install editor's keyboard
10 page ." Entsprechende Tasten druecken. (Blank uebernimmt.)"
11 #keys 0 ?DO cr I 2* actiontable + @ >name .name
12 tab ." : " I keytable + dup c@ .key tab ." -> "
13 key dup bl = IF drop dup c@ THEN dup .key swap c!
14 LOOP ;
15 -->
Screen 2 not modified
0 \ define action-names UH 29Nov86
1 : :a ( addr -- adr' ) dup @ Alias 2+ ;
2 actiontable
3 :a up :a left :a down :a right
4 :a push-line :a push-char :a pull-line :a pull-char
5 :a copy-line :a copy-char
6 :a backspace :a backspace :a backspace :a delete-char
7 :a insert-char :a delete-line :a insert-line
8 :a flipimode ( :a erase-line) :a clear-to-right
9 :a new-line :a +tab :a -tab
10 ( :a home :a to-end ) :a search :a undo
11 :a update-exit :a flushed-exit ( :a showload ):a shadow-screen
12 :a next-Screen :a back-Screen :a alter-Screen :a mark-screen
13 drop
14
15 warning off install empty
Screen 3 not modified
0 UH 17Nov86
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 4 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

34
sources/cpm/PORT8080.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \ 8080-Portzugriff UH 11Nov86
1
2 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit
3 Adressen anzusprechen.
4
5 Der Code ist leider selbstmodifizierend, da beim 8080 die
6 Portadresse im Code ausdruecklich angegeben werden muss.
7
8 Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen,
9 kann auch das File portz80.scr benutzt werden, indem die
10 Z80-IO-Befehle (16Bit-Adressen) benutzt werden.
11
12
13
14
15
Screen 1 not modified
0 \ 8080-Portzugriff pc@, pc! 15Jul86
1
2 ' 0 | Alias patch
3
4 Code pc@ ( addr -- c )
5 H pop L A mov here 4 + sta patch in
6 0 H mvi A L mov Hpush jmp end-code
7
8 Code pc! ( c addr -- )
9 H pop L A Mov here 6 + sta H pop L A mov patch out
10 Next end-code
11
12
13
14
15

51
sources/cpm/PORTZ80.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \ Z80-Portzugriff UH 05Nov86
1
2 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit
3 Adressen anzusprechen.
4
5 Einige Komputer, so die der Schneider Serie dekodieren ihre
6 Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit
7 Adressen angesprochen werden muessen.
8 Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86
1
2 Assembler definitions
3
4 | : Z80-io ( base -- ) \ define special Z80-io instruction
5 Create c,
6 Does> ( reg -- ) $ED c, c@ swap 8 * + c, ;
7
8 $40 Z80-io (c)in
9 $41 Z80-io (c)out
10
11 Forth definitions
12
13 -->
14
15
Screen 2 not modified
0 \ store and fetch values with 16-bit port-adresses UH 05Nov86
1
2 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr
3 H pop IP push H B mvx L (c)in 0 H mvi
4 IP pop hpush jmp
5 end-code
6
7 Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr
8 H pop D pop IP push H B mvx E (c)out
9 IP pop Next
10 end-code
11
12
13
14
15

51
sources/cpm/PRIMED.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ Primitivst Editor zur Installation UH 17Nov86
1
2 Da zur Installationszeit der Full-Screen Editor noch nicht
3 funtionsfaehig ist, muessen die zu aendernden Screens auf eine
4 andere Weise ge{nder werden: mit dem primitivst Editor PRIMED,
5 der nur ein Benutzer wort enthaelt:
6
7 Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen,
8 dann mit "ll NEW" den Screen aendern. Es koennen immer nur
9 ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher
10 Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe
11 einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW.
12 Nach jeder Eingabe von RETURN wird die eingegebene Zeile in
13 den Screen uebernommen, und der ganze Screen zur Kontrolle
14 nocheinmal ausgegeben.
15
Screen 1 not modified
0 \ primitivst Editor PRIMED UH 17Nov86
1
2 | : !line ( adr count line# -- )
3 scr @ block swap c/l * + dup c/l bl fill
4 swap cmove update ;
5
6 : new ( n -- )
7 l/s 1+ swap
8 ?DO cr I .
9 pad c/l expect span @ 0= IF leave THEN
10 pad span @ I !line cr scr @ list LOOP ;
11
12
13
14
15
Screen 2 not modified
0 \ PRIMED Demo-Screen
1
2
3
4 Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender
5 Eingabe dieses Textes
6 Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new
7 durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit
8 "0 NEW" erzeugt.
9 Ulrich Hoffmann
10
11
12
13
14
15

272
sources/cpm/PRINTER.FB.src
View File

@ -1,272 +0,0 @@
Screen 0 not modified
0 \\ Printer Interface 08Nov86
1
2 Dieses File enthaelt das Printer Interface zwischen volksFORTH
3 und dem Drucker.
4
5 Damit ist es moeglich Source-Texte auf bequeme Art und Weise
6 in uebersichtlicher Form auszudrucken (6 auf eine Seite).
7
8 In Verbindung mit dem Multitasker ist es moeglich, auch Texte im
9 Hintergrund drucken zu lassen und trotztdem weiterzuarbeiten.
10
11
12
13
14
15
Screen 1 not modified
0 \ Printer Interface Epson RX80 18Aug86
1 \ angepasst auf M 130i 07dec85we
2
3 Onlyforth
4
5 Variable shadow capacity 2/ shadow ! \ s. Editor
6
7 Vocabulary Printer Printer definitions also
8 | Variable printsem printsem off
9
10 01 +load 04 0C +thru \ M 130i - Printer
11 \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer
12
13 Onlyforth
14
15
Screen 2 not modified
0 \ Printer p! and controls UH 02Nov87
1
2 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ;
3
4 : p! ( n --) BEGIN pause
5 stop? IF printsem unlock true abort" stopped! " THEN
6 ready? UNTIL [ Dos ] 5 bios ;
7
8 | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ;
9
10 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET
11 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF
12 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi
13
14
15
Screen 3 not modified
0 \ Printer Escapes 24dec85
1
2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ;
3
4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
5 Ascii 2 esc: 1/6" Ascii T esc: suoff
6 Ascii N esc: +jump Ascii O esc: -jump
7 Ascii G esc: +dark Ascii H esc: -dark
8 \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive
9
10
11 | : ESC2 ( 8b0 8b1 --) ESC p! p! ;
12
13 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ;
14 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ;
15
Screen 4 not modified
0 \ Printer Escapes 29jan86
1
2 Ascii W on: +wide Ascii W off: -wide
3 Ascii - on: +under Ascii - off: -under
4 Ascii S on: sub Ascii S off: super
5 Ascii P on: (10cpi Ascii P off: (12cpi
6
7 : 10cpi (-17cpi (10cpi ;
8 : 12cpi (-17cpi (12cpi ;
9 : 17cpi (10cpi (+17cpi ;
10
11 : lines ( #.of.lines --) Ascii C ESC2 ;
12 : "long ( inches --) 0 lines p! ;
13 : american 0 Ascii R ESC2 ;
14 : german 2 Ascii R ESC2 ;
15 : normal 12cpi american suoff 1/6" 0C "long RET ;
Screen 5 not modified
0 \ Printer Escapes 16Jul86
1
2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ;
3
4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10"
5 Ascii 2 esc: 1/6" Ascii T esc: suoff
6 Ascii N esc: +jump Ascii O esc: -jump
7 Ascii G esc: +dark Ascii H esc: -dark
8 Ascii 4 esc: +cursive Ascii 5 esc: -cursive
9 Ascii M esc: 12cpi Ascii P | esc: (-12cpi
10
11 : 10cpi (-12cpi (-17cpi ;
12 : 17cpi (-12cpi (+17cpi ;
13
14 ' 10cpi Alias pica ' 12cpi Alias elite
15
Screen 6 not modified
0 \ Printer Escapes 16Jul86
1
2 | : ESC2 ( 8b0 8b1 --) ESC p! p! ;
3
4 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ;
5 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ;
6
7 Ascii W on: +wide Ascii W off: -wide
8 Ascii - on: +under Ascii - off: -under
9 Ascii S on: sub Ascii S off: super
10 Ascii p on: +prop Ascii p off: -prop
11 : lines ( #.of.lines --) Ascii C ESC2 ;
12 : "long ( inches --) 0 lines p! ;
13 : american 0 Ascii R ESC2 ;
14 : german 2 Ascii R ESC2 ;
15 : normal 12cpi american suoff 1/6" 0C "long RET ;
Screen 7 not modified
0 \ Printer Output 04Jul86
1
2 : prinit ; \ initializing Printer
3
4 | Variable pcol pcol off | Variable prow prow off
5 | : pemit ( 8b --) p! 1 pcol +! ;
6 | : pcr ( --) RET LF 1 prow +! pcol off ;
7 | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ;
8 | : ppage ( --) FF prow off pcol off ;
9 | : pat ( row col --) over prow @ < IF ppage THEN
10 swap prow @ - 0 ?DO pcr LOOP
11 dup pcol @ < IF RET pcol off THEN pcol @ - spaces ;
12 | : pat? ( -- row col) prow @ pcol @ ;
13 | : ptype ( adr len --)
14 dup pcol +! bounds ?DO I c@ p! LOOP ;
15
Screen 8 not modified
0 \ Printer output 28Jun86
1
2 | Output: >printer pemit pcr ptype pdel ppage pat pat? ;
3
4 Forth definitions
5
6 : print >printer normal ;
7
8 : printable? ( char -- f) bl Ascii ~ uwithin ;
9
10
11
12
13
14
15
Screen 9 not modified
0 \ Variables and Setup 23Oct86
1
2 Printer definitions
3
4 $00 | Constant logo | Variable pageno
5 | Create scr#s $0E allot \ enough room for 6 screens
6
7 | : header ( -- )
8 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r
9 $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV "
10 5 spaces file? -dark 1 pageno +! 17cpi ;
11
12
13
14
15
Screen 10 not modified
0 \ Print 2 screens across on a page 03dec85
1
2 | : text? ( scr# -- f) block dup c@ printable?
3 IF b/blk -trailing nip 0= THEN 0= ;
4
5 | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN
6 1 scr#s +! scr#s dup @ 2* + ! ;
7
8 | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r
9 pad $101 bl fill swap block r@ + pad c/l cmove
10 block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ;
11
12 | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces
13 +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark
14 cr l/s 0 DO 2dup I 2pr LOOP 2drop ;
15
Screen 11 not modified
0 \ Printer 6 screens on a page 03dec85
1
2 | : pr-start ( --) scr#s off 1 pageno ! ;
3
4 | : pagepr ( --) header scr#s off scr#s 2+
5 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ;
6
7 | : shadowpr ( --) header scr#s off scr#s 2+
8 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ;
9
10 | : pr-flush ( -- f) scr#s @ dup \ any screens left over?
11 IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN
12 0<> ;
13
14
15
Screen 12 not modified
0 \ Printer 6 screens on a page 23Nov86
1 Forth definitions
2
3 : pthru ( first last --)
4 printsem lock output push print pr-start 1+ swap
5 ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN
6 LOOP pr-flush IF pagepr THEN printsem unlock ;
7
8 : document ( first last --)
9 isfile@ IF capacity 2/ shadow ! THEN
10 printsem lock output push print pr-start 1+ swap
11 ?DO I text? IF I pr I shadow @ + pr THEN
12 scr#s @ 6 = IF shadowpr THEN LOOP
13 pr-flush IF shadowpr THEN printsem unlock ;
14
15 : listing ( --) 0 capacity 2/ 1- document ;
Screen 13 not modified
0 \ Printerspool 03Nov86
1
2 \needs Task \\
3
4 | Input: noinput 0 false drop 2drop ;
5
6
7 $100 $200 noinput Task spooler
8
9 keyboard
10
11 : spool ( from to -- )
12 isfile@ spooler 3 pass isfile ! pthru stop ;
13
14
15
Screen 14 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

51
sources/cpm/RELOCATE.FB.src
View File

@ -1,51 +0,0 @@
Screen 0 not modified
0 \\ Relocate System 11Nov86
1
2 Dieses File enthaelt das Utility-Wort BUFFERS.
3 Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen,
4 die volksFORTH benutzt. Voreingestellt sind 4 Buffer.
5
6 Benutzung: nn BUFFERS
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Relocate a system 16Jul86
1
2 | : relocate-tasks ( mainup -- ) up@ dup
3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ;
4
5 | : relocate ( stacklen rstacklen -- )
6 2dup + b/buf + 2+ limit origin -
7 u> abort" kills all buffers"
8 over pad $100 + origin - u< abort" cuts the dictionary"
9 dup udp @ $40 +
10 u< abort" a ticket to the moon with no return ..."
11 flush empty over + origin +
12 origin $0A + ! \ r0
13 origin + dup relocate-tasks \ multitasking link
14 6 - origin 8 + ! \ s0
15 cold ; -->
Screen 2 not modified
0 \ bytes.more buffers 29Jun86
1
2 | : bytes.more ( n+- -- )
3 up@ origin - + r0 @ up@ - relocate ;
4
5 : buffers ( +n -- )
6 b/buf * 4+ limit r0 @ - swap - bytes.more ;
7
8
9
10
11
12
13
14
15

34
sources/cpm/SAVESYS.FB.src
View File

@ -1,34 +0,0 @@
Screen 0 not modified
0 \\ savesystem 11Nov86
1
2 Dieses File enthaelt das Utility-Wort SAVESYSTEM.
3
4 Mit ihm kann man das gesamte System als File auf Disk schreiben.
5
6 Achtung:
7 Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM
8 der Heap geloescht!
9
10 Benutzung: SAVESYSTEM <filename>
11
12
13
14
15
Screen 1 not modified
0 \ savsystem 05Nov86
1
2 : savesystem \ filename
3 save $100 here over - savefile ;
4
5
6 \\ Einfaches savesystem 18Aug86
7
8 | : message ( -- )
9 base push decimal
10 cr ." ready for SAVE " here 1- $100 / u.
11 ." VOLKS4TH.COM" cr ;
12
13 : savesystem ( -- ) save message bye ;
14
15

408
sources/cpm/SEE.FB.src
View File

@ -1,408 +0,0 @@
Screen 0 not modified
0 \ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86
1
2 Dieses File enthaelt einen Decompiler, der bereits kompilierte
3 Worte wieder in Sourcetextform bringt.
4 Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL
5 und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang
6 erkannt und umgeformt.
7 Ein Decompiler kann aber keine (Stack-) Kommentare wieder
8 herzaubern, die Benutzung der Screens und dann view, wird
9 daher staerkstens empfohlen.
10
11 Denn: Es ist immernoch ein Fehler drin!
12 Und um den zu korrigieren, ist der Sourcetext dem Objektkode
13 doch vorzuziehen.
14
15 Benutzung: see <name>
Screen 1 not modified
0 \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86
1
2 Onlyforth Tools also definitions
3
4 1 13 +thru
5
6 \\
7 Produces compilable Forth source from normal compiled Forth.
8
9 These source blocks are based on the works of
10
11 Henry Laxen, Mike Perry and Wil Baden
12
13 volksFORTH version: U. Hoffmann
14
15
Screen 2 not modified
0 \ detacting does> 01Jul86
1
2 internal
3
4 ' does> 4+ @ Alias (;code
5 ' Forth @ 1+ @ Constant (dodoes>
6
7 : does? ( IP - f )
8 dup c@ $CD ( call ) = swap
9 1+ @ (dodoes> = and ;
10
11
12
13
14
15
Screen 3 not modified
0 \ indentation. 04Jul86
1 Variable #spaces #spaces off
2
3 : +in ( -- ) 3 #spaces +! ;
4
5 : -in ( -- ) -3 #spaces +! ;
6
7 : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ;
8
9 : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ;
10
11
12
13
14
15
Screen 4 not modified
0 \ case defining words 01Jul86
1
2 : Case: ( -- )
3 Create: Does> swap 2* + perform ;
4
5 : Associative: ( n -- )
6 Constant Does> ( n - index )
7 dup @ -rot dup @ 0
8 DO 2+ 2dup @ =
9 IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ;
10
11
12
13
14
15
Screen 5 not modified
0 \ branching 04Jul86
1
2 Variable #branches Variable #branch
3
4 : branch-type ( n -- a ) 6 * pad + ;
5 : branch-from ( n -- a ) branch-type 2+ ;
6 : branch-to ( n -- a ) branch-type 4+ ;
7
8 : branched ( adr type -- ) \ Make entry in branch-table.
9 #branches @ branch-type ! dup #branches @ branch-from !
10 2+ dup @ + #branches @ branch-to ! 1 #branches +! ;
11
12 \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... }
13
14
15
Screen 6 not modified
0 \ branching 01Jul86
1
2 : branch-back ( adr type -- )
3 \ : make entry in branch-table & reclassify branch-type.)
4 over swap branched
5 2+ dup dup @ + swap 2+ ( loop-start,-end.)
6 0 #branches @ 1-
7 ?DO
8 over I branch-from @ u> IF LEAVE THEN
9 dup I branch-to @ = IF ['] while I branch-type ! THEN
10 -1 +LOOP 2drop ;
11
12
13
14
15
Screen 7 not modified
0 \ branching 01Jul86
1 : forward? ( ip -- f ) 2+ @ 0> ;
2
3 : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward?
4 IF ['] if branched exit THEN ['] until branch-back ;
5
6 : branch+ ( ip -- ip' ) dup 4+ swap dup forward?
7 IF ['] else branched exit THEN ['] repeat branch-back ;
8
9 : (loop)+ ( ip -- ip' )
10 dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ;
11
12 : string+ ( ip -- ip' ) 2+ count + even ;
13
14 : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ;
15
Screen 8 not modified
0 \ classify each word 25Aug86
1 Forth
2
3 &15 Associative: execution-class
4 ] clit lit ?branch branch
5 (do (." (abort" (;code
6 (" (?do (loop
7 (+loop unnest (is compile [
8
9 Case: execution-class+
10 3+ 4+ ?branch+ branch+
11 2+ string+ string+ (;code+
12 string+ 2+ 4+
13 4+ 0= 4+ 4+ 2+ ;
14
15 Tools
Screen 9 not modified
0 \ first pass 01Jul86
1
2 : pass1 ( cfa -- ) #branches off >body
3 BEGIN dup @ execution-class execution-class+
4 dup 0= stop? or
5 UNTIL drop ;
6
7
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ identify branch destinations. 04Jul86
1 : thru.branchtable ( -- limit start ) #branches @ 0 ;
2 : ?.then ( ip -- ) thru.branchtable
3 ?DO I branch-to @ over =
4 IF I branch-from @ over u<
5 IF I branch-type @ dup ['] else = swap ['] if = or
6 IF -in ." THEN " ind-cr LEAVE THEN THEN THEN
7 LOOP ;
8 : ?.begin ( ip -- ) thru.branchtable
9 ?DO I branch-to @ over =
10 IF I branch-from @ over u< not
11 IF I branch-type @ dup
12 ['] repeat = swap ['] until = or
13 IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN
14 LOOP ;
15 ( put "BEGIN" and "THEN" where used.)
Screen 11 not modified
0 \ decompile each type of word 01Jul86
1
2 : .word ( ip -- ip' ) dup @ >name .name 2+ ;
3
4 : .(word ( ip -- ip' ) dup @ >name
5 ?dup 0= IF ." ??? " ELSE
6 count $1f and swap 1+ swap 1- type space THEN 2+ ;
7 : .inline ( val16b -- )
8 dup >name ?dup IF ." ['] " .name drop exit THEN . ;
9
10 : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ;
11 : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ;
12 : .string ( ip -- ip' )
13 .(word count 2dup type Ascii " emit space + even ?.then ;
14
15 : .unnest ( ip -- 0 ) ." ; " 0= ;
Screen 12 not modified
0 \ decompile each type of word 01Jul86
1
2 : .default ( ip -- ip' ) dup @ >name ?dup IF
3 c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ;
4
5 : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ;
6
7 : .compile ( ip -- ip' ) .word .word ?.then ;
8
9
10
11
12
13
14
15
Screen 13 not modified
0 \ decompiling conditionals 04Jul86
1
2 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ;
3 : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ;
4 : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ;
5 : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ;
6 : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ;
7
8 5 Associative: branch-class
9 ' if , ' while , ' else , ' repeat , ' until ,
10 Case: .branch-class
11 .if .else .else .repeat .repeat ;
12
13 : .branch ( ip -- ip' )
14 #branch @ branch-type @ 1 #branch +!
15 dup >name swap branch-class .branch-class ;
Screen 14 not modified
0 \ decompile Does> ;code 04Jul86
1
2 : .(;code ( IP - IP' f)
3 2+ dup does?
4 IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ;
5
6
7
8
9
10
11
12
13
14
15
Screen 15 not modified
0 \ classify word's output 01Jul86
1
2 Case: .execution-class
3 .clit .lit .branch .branch
4 .do .string .string .(;code
5 .string .do .loop
6 .loop .unnest .['] .compile
7 .default ;
8
9
10
11
12
13
14
15
Screen 16 not modified
0 \ decompile colon-definitions 04Jul86
1
2 : pass2 ( cfa -- ) #branch off >body
3 BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class
4 dup 0= stop? or
5 UNTIL drop ;
6
7 : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ;
8
9 : .immediate ( cfa - ) >name c@ dup
10 ?ind-cr 40 and IF ." IMMEDIATE " THEN
11 ?ind-cr 80 and IF ." RESTRICT" THEN ;
12
13 : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ;
14
15
Screen 17 not modified
0 \ display category of word 01Jul86
1 external Defer (see internal
2
3 : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ;
4
5 : .user-variable ( cfa - ) ." USER " dup >name dup .name
6 3 spaces swap execute @ u. .name ." ! " ;
7
8 : .defer ( cfa - )
9 ." deferred " dup >name .name ." Is " >body @ (see ;
10
11 : .other ( cfa - ) dup >name .name
12 dup @ over >body = IF drop ." is Code " exit THEN
13 dup @ does? IF .does> exit THEN
14 drop ." is unknown " ;
15
Screen 18 not modified
0 \ decompiling variables and constants 01Jul86
1
2 : .constant ( cfa - )
3 dup >body @ u. ." CONSTANT " >name .name ;
4
5 : .variable ( cfa - ) ." VARIABLE "
6 dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ;
7
8
9
10
11
12
13
14
15
Screen 19 not modified
0 \ classify a word UH 25Jan88
1
2 5 Associative: definition-class
3 ' quit @ , ' 0 @ , ' scr @ , ' base @ ,
4 ' 'cold @ ,
5
6 Case: .definition-class
7 .: .constant .variable .user-variable
8 .defer .other ;
9
10
11
12
13
14
15
Screen 20 not modified
0 \ Top level of Decompiler 04Jul86
1
2 external
3
4 : ((see ( cfa -)
5 #spaces off cr
6 dup dup @
7 definition-class .definition-class .immediate ;
8
9 ' ((see Is (see
10
11 Forth definitions
12 : see ' (see ;
13
14
15
Screen 21 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 22 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 23 not modified
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

Some files were not shown because too many files have changed in this diff Show More