6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2024-11-25 10:30:57 +00:00
Code Issues Projects Releases Wiki Activity

Atari ST source files

Browse Source
This commit is contained in:
Carsten Strotmann 2020-06-20 18:59:55 +02:00
parent 3dd6197fbf
commit 12972a5590
33 changed files with 12699 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
sources/AtariST/ALLOCATE.FB.src Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

File diff suppressed because it is too large Load Diff

306
sources/AtariST/EDWINDOW.FB.src Normal file
View 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
View 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
View File

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

680
sources/AtariST/GEM/AES.FB.src Normal file
View 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
View 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
View File

Binary file not shown.

272
sources/AtariST/GEM/SUPERGEM.FB.src Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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