Tools: fb2fth (Forth-Block to Forth Source) in gforth
This commit is contained in:
parent
a32b5f8901
commit
fabfc21586
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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!" ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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 )
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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
|
|
@ -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.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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.
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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!
|
|
@ -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!
|
Binary file not shown.
Binary file not shown.
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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 !!
|
|
@ -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 !!
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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.
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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.
|
|
@ -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.
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
@ -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
|
|
@ -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 ...
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
Loading…
Reference in New Issue