mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-28 14:50:35 +00:00
Atari ST source files
This commit is contained in:
Carsten Strotmann
parent
3dd6197fbf
commit
12972a5590
34
sources/AtariST/ALLOCATE.FB.src
Normal file
34
sources/AtariST/ALLOCATE.FB.src
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
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
|
||||||
323
sources/AtariST/ASSEMBLE.FB.src
Normal file
323
sources/AtariST/ASSEMBLE.FB.src
Normal file
@ -0,0 +1,323 @@
|
|||||||
|
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
|
||||||
34
sources/AtariST/C.FB.src
Normal file
34
sources/AtariST/C.FB.src
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
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
|
||||||
680
sources/AtariST/CROSTARG.FB.src
Normal file
680
sources/AtariST/CROSTARG.FB.src
Normal file
@ -0,0 +1,680 @@
|
|||||||
|
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
|
||||||
255
sources/AtariST/DEMO.FB.src
Normal file
255
sources/AtariST/DEMO.FB.src
Normal file
@ -0,0 +1,255 @@
|
|||||||
|
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
|
||||||
357
sources/AtariST/DISASS.FB.src
Normal file
357
sources/AtariST/DISASS.FB.src
Normal file
@ -0,0 +1,357 @@
|
|||||||
|
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
|
||||||
136
sources/AtariST/DRAGON1.FB.src
Normal file
136
sources/AtariST/DRAGON1.FB.src
Normal file
@ -0,0 +1,136 @@
|
|||||||
|
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
|
||||||
102
sources/AtariST/EDIICON.FB.src
Normal file
102
sources/AtariST/EDIICON.FB.src
Normal file
@ -0,0 +1,102 @@
|
|||||||
|
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
|
||||||
1598
sources/AtariST/EDITOR.FB.src
Normal file
1598
sources/AtariST/EDITOR.FB.src
Normal file
File diff suppressed because it is too large
Load Diff
306
sources/AtariST/EDWINDOW.FB.src
Normal file
306
sources/AtariST/EDWINDOW.FB.src
Normal file
@ -0,0 +1,306 @@
|
|||||||
|
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
|
||||||
102
sources/AtariST/ERRORBOX.FB.src
Normal file
102
sources/AtariST/ERRORBOX.FB.src
Normal file
@ -0,0 +1,102 @@
|
|||||||
|
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.
|
||||||
1258
sources/AtariST/FILEINT.FB.src
Normal file
1258
sources/AtariST/FILEINT.FB.src
Normal file
File diff suppressed because it is too large
Load Diff
2261
sources/AtariST/FORTH83.FB.src
Normal file
2261
sources/AtariST/FORTH83.FB.src
Normal file
File diff suppressed because it is too large
Load Diff
680
sources/AtariST/GEM/AES.FB.src
Normal file
680
sources/AtariST/GEM/AES.FB.src
Normal file
@ -0,0 +1,680 @@
|
|||||||
|
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
|
||||||
170
sources/AtariST/GEM/BASICS.FB.src
Normal file
170
sources/AtariST/GEM/BASICS.FB.src
Normal file
@ -0,0 +1,170 @@
|
|||||||
|
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!
|
||||||
BIN
sources/AtariST/GEM/GEMDEFS.FB.src
Normal file
BIN
sources/AtariST/GEM/GEMDEFS.FB.src
Normal file
Binary file not shown.
272
sources/AtariST/GEM/SUPERGEM.FB.src
Normal file
272
sources/AtariST/GEM/SUPERGEM.FB.src
Normal file
@ -0,0 +1,272 @@
|
|||||||
|
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
|
||||||
714
sources/AtariST/GEM/VDI.FB.src
Normal file
714
sources/AtariST/GEM/VDI.FB.src
Normal file
@ -0,0 +1,714 @@
|
|||||||
|
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
|
||||||
34
sources/AtariST/INDEX.FB.src
Normal file
34
sources/AtariST/INDEX.FB.src
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
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
|
||||||
629
sources/AtariST/LINE_A.FB.src
Normal file
629
sources/AtariST/LINE_A.FB.src
Normal file
@ -0,0 +1,629 @@
|
|||||||
|
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
|
||||||
170
sources/AtariST/MISC.FB.src
Normal file
170
sources/AtariST/MISC.FB.src
Normal file
@ -0,0 +1,170 @@
|
|||||||
|
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 !!
|
||||||
68
sources/AtariST/PATCH.FB.src
Normal file
68
sources/AtariST/PATCH.FB.src
Normal file
@ -0,0 +1,68 @@
|
|||||||
|
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
|
||||||
510
sources/AtariST/PRINTER.FB.src
Normal file
510
sources/AtariST/PRINTER.FB.src
Normal file
@ -0,0 +1,510 @@
|
|||||||
|
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
|
||||||
442
sources/AtariST/RAMDISK.FB.src
Normal file
442
sources/AtariST/RAMDISK.FB.src
Normal file
@ -0,0 +1,442 @@
|
|||||||
|
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
|
||||||
51
sources/AtariST/RELOCATE.FB.src
Normal file
51
sources/AtariST/RELOCATE.FB.src
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
Screen 0 not modified
|
||||||
|
0 \\ 26oct86we
|
||||||
|
1
|
||||||
|
2 Diese File enth„lt Worte, mit denen die Speicheraufteilung
|
||||||
|
3 des volksFORTH ver„ndert werden kann.
|
||||||
|
4
|
||||||
|
5 RELOCATE setzt R0 und S0 neu, beachten Sie dazu auch die
|
||||||
|
6 Ausf<73>hrungen im Handbuch.
|
||||||
|
7
|
||||||
|
8 Mit BUFFERS kann man die Anzahl der Diskbuffer ver„ndern.
|
||||||
|
9 Standardm„žig ist das System auf &10 Buffer eingestellt. Reicht
|
||||||
|
10 der Platz im Dictionary bei sehr grožen Programmen nicht aus,
|
||||||
|
11 kann man hier am ehesten Speicherplatz einsparen.
|
||||||
|
12 Umgekehrt erh”ht sich der Arbeitskomfort beim Editieren, wenn
|
||||||
|
13 m”glichst viele Diskbuffer vorhanden sind, um Diskettenzugriffe
|
||||||
|
14 zu minimieren.
|
||||||
|
15
|
||||||
|
Screen 1 not modified
|
||||||
|
0 \ Relocate a system 26oct86we
|
||||||
|
1
|
||||||
|
2 | : relocate-tasks ( mainup -- ) up@ dup
|
||||||
|
3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop !
|
||||||
|
4 up@ 2+ @ origin 2+ ! ;
|
||||||
|
5
|
||||||
|
6 : relocate ( stacklen rstacklen -- )
|
||||||
|
7 2dup + limit origin - b/buf - 2-
|
||||||
|
8 u> abort" kills all buffers"
|
||||||
|
9 over pad $100 + origin - u< abort" cuts the dictionary"
|
||||||
|
10 dup udp @ $40 +
|
||||||
|
11 u< abort" kills returnstack"
|
||||||
|
12 flush empty over + origin + origin &12 + ! \ r0
|
||||||
|
13 origin + dup relocate-tasks \ multitasking
|
||||||
|
14 6 - origin &10 + ! \ s0
|
||||||
|
15 cold ; -->
|
||||||
|
Screen 2 not modified
|
||||||
|
0 \ bytes.more buffers 15sep86we
|
||||||
|
1
|
||||||
|
2 | : bytes.more ( n+- -- )
|
||||||
|
3 up@ origin - + r0 @ up@ - relocate ;
|
||||||
|
4
|
||||||
|
5 : buffers ( +n -- )
|
||||||
|
6 b/buf * 4+ limit r0 @ - swap - bytes.more ;
|
||||||
|
7
|
||||||
|
8
|
||||||
|
9
|
||||||
|
10
|
||||||
|
11
|
||||||
|
12
|
||||||
|
13
|
||||||
|
14
|
||||||
|
15
|
||||||
51
sources/AtariST/RFEDIT.FB.src
Normal file
51
sources/AtariST/RFEDIT.FB.src
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
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
|
||||||
34
sources/AtariST/STARTUP.FB.src
Normal file
34
sources/AtariST/STARTUP.FB.src
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
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
|
||||||
204
sources/AtariST/STRINGS.FB.src
Normal file
204
sources/AtariST/STRINGS.FB.src
Normal file
@ -0,0 +1,204 @@
|
|||||||
|
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.
|
||||||
680
sources/AtariST/TARGET.FB.src
Normal file
680
sources/AtariST/TARGET.FB.src
Normal file
@ -0,0 +1,680 @@
|
|||||||
|
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
|
||||||
136
sources/AtariST/TASKER.FB.src
Normal file
136
sources/AtariST/TASKER.FB.src
Normal file
@ -0,0 +1,136 @@
|
|||||||
|
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
|
||||||
272
sources/AtariST/TOOLS.FB.src
Normal file
272
sources/AtariST/TOOLS.FB.src
Normal file
@ -0,0 +1,272 @@
|
|||||||
|
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
|
||||||
85
sources/AtariST/TUTORIAL.FB.src
Normal file
85
sources/AtariST/TUTORIAL.FB.src
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
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
|
||||||
51
sources/AtariST/UNDO.FB.src
Normal file
51
sources/AtariST/UNDO.FB.src
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
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
|
||||||
Loading…
Reference in New Issue
Block a user