From 12972a5590c79019550117531d94ad062cffbcbf Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sat, 20 Jun 2020 18:59:55 +0200 Subject: [PATCH] Atari ST source files --- sources/AtariST/ALLOCATE.FB.src | 34 + sources/AtariST/ASSEMBLE.FB.src | 323 ++++ sources/AtariST/C.FB.src | 34 + sources/AtariST/CROSTARG.FB.src | 680 ++++++++ sources/AtariST/DEMO.FB.src | 255 +++ sources/AtariST/DISASS.FB.src | 357 +++++ sources/AtariST/DRAGON1.FB.src | 136 ++ sources/AtariST/EDIICON.FB.src | 102 ++ sources/AtariST/EDITOR.FB.src | 1598 +++++++++++++++++++ sources/AtariST/EDWINDOW.FB.src | 306 ++++ sources/AtariST/ERRORBOX.FB.src | 102 ++ sources/AtariST/FILEINT.FB.src | 1258 +++++++++++++++ sources/AtariST/FORTH83.FB.src | 2261 +++++++++++++++++++++++++++ sources/AtariST/GEM/AES.FB.src | 680 ++++++++ sources/AtariST/GEM/BASICS.FB.src | 170 ++ sources/AtariST/GEM/GEMDEFS.FB.src | Bin 0 -> 6690 bytes sources/AtariST/GEM/SUPERGEM.FB.src | 272 ++++ sources/AtariST/GEM/VDI.FB.src | 714 +++++++++ sources/AtariST/INDEX.FB.src | 34 + sources/AtariST/LINE_A.FB.src | 629 ++++++++ sources/AtariST/MISC.FB.src | 170 ++ sources/AtariST/PATCH.FB.src | 68 + sources/AtariST/PRINTER.FB.src | 510 ++++++ sources/AtariST/RAMDISK.FB.src | 442 ++++++ sources/AtariST/RELOCATE.FB.src | 51 + sources/AtariST/RFEDIT.FB.src | 51 + sources/AtariST/STARTUP.FB.src | 34 + sources/AtariST/STRINGS.FB.src | 204 +++ sources/AtariST/TARGET.FB.src | 680 ++++++++ sources/AtariST/TASKER.FB.src | 136 ++ sources/AtariST/TOOLS.FB.src | 272 ++++ sources/AtariST/TUTORIAL.FB.src | 85 + sources/AtariST/UNDO.FB.src | 51 + 33 files changed, 12699 insertions(+) create mode 100644 sources/AtariST/ALLOCATE.FB.src create mode 100644 sources/AtariST/ASSEMBLE.FB.src create mode 100644 sources/AtariST/C.FB.src create mode 100644 sources/AtariST/CROSTARG.FB.src create mode 100644 sources/AtariST/DEMO.FB.src create mode 100644 sources/AtariST/DISASS.FB.src create mode 100644 sources/AtariST/DRAGON1.FB.src create mode 100644 sources/AtariST/EDIICON.FB.src create mode 100644 sources/AtariST/EDITOR.FB.src create mode 100644 sources/AtariST/EDWINDOW.FB.src create mode 100644 sources/AtariST/ERRORBOX.FB.src create mode 100644 sources/AtariST/FILEINT.FB.src create mode 100644 sources/AtariST/FORTH83.FB.src create mode 100644 sources/AtariST/GEM/AES.FB.src create mode 100644 sources/AtariST/GEM/BASICS.FB.src create mode 100644 sources/AtariST/GEM/GEMDEFS.FB.src create mode 100644 sources/AtariST/GEM/SUPERGEM.FB.src create mode 100644 sources/AtariST/GEM/VDI.FB.src create mode 100644 sources/AtariST/INDEX.FB.src create mode 100644 sources/AtariST/LINE_A.FB.src create mode 100644 sources/AtariST/MISC.FB.src create mode 100644 sources/AtariST/PATCH.FB.src create mode 100644 sources/AtariST/PRINTER.FB.src create mode 100644 sources/AtariST/RAMDISK.FB.src create mode 100644 sources/AtariST/RELOCATE.FB.src create mode 100644 sources/AtariST/RFEDIT.FB.src create mode 100644 sources/AtariST/STARTUP.FB.src create mode 100644 sources/AtariST/STRINGS.FB.src create mode 100644 sources/AtariST/TARGET.FB.src create mode 100644 sources/AtariST/TASKER.FB.src create mode 100644 sources/AtariST/TOOLS.FB.src create mode 100644 sources/AtariST/TUTORIAL.FB.src create mode 100644 sources/AtariST/UNDO.FB.src diff --git a/sources/AtariST/ALLOCATE.FB.src b/sources/AtariST/ALLOCATE.FB.src new file mode 100644 index 0000000..9de5a9b --- /dev/null +++ b/sources/AtariST/ALLOCATE.FB.src @@ -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 zurck. Wenn nicht genug Speicherplatz zur Verfgung + 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 diff --git a/sources/AtariST/ASSEMBLE.FB.src b/sources/AtariST/ASSEMBLE.FB.src new file mode 100644 index 0000000..cbb4b67 --- /dev/null +++ b/sources/AtariST/ASSEMBLE.FB.src @@ -0,0 +1,323 @@ +Screen 0 not modified + 0 \\ *** Assembler *** 25may86we + 1 + 2 Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. + 3 Der Assembler basiert auf dem von Michael Perry fr 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 Geschwindigkeitsgrnden enth„lt der Assembler + 7 kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner + 8 Tat die Code-Worte mit einem Disassembler zu berprfen. + 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 Verfgung 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, ; ( 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 movesr + 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 diff --git a/sources/AtariST/C.FB.src b/sources/AtariST/C.FB.src new file mode 100644 index 0000000..ab798bf --- /dev/null +++ b/sources/AtariST/C.FB.src @@ -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 diff --git a/sources/AtariST/CROSTARG.FB.src b/sources/AtariST/CROSTARG.FB.src new file mode 100644 index 0000000..7f88377 --- /dev/null +++ b/sources/AtariST/CROSTARG.FB.src @@ -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 0 | Constant + 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 , 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 , 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 @ case? + 6 IF ." forw" ELSE - abort" ??" ." res" THEN + 7 2+ dup @ 5 u.r + 8 2+ @ ?dup + 9 IF dup @ case? +10 IF ." fdef" ELSE - 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 @ = 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 @ = + 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> over ! 2+ ! ; + 9 +10 : resdoes> ( cfa.ghost cfa.target -) +11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +13 ' >body ! +14 ] Does> [ here 4- 0 ] @ T , H ; +15 ' >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 : - cfa ) H g' dup @ - 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 -2 H 2swap ; + 8 immediate restrict + 9 | : (repeat T 2 ?pairs 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 diff --git a/sources/AtariST/DEMO.FB.src b/sources/AtariST/DEMO.FB.src new file mode 100644 index 0000000..8280ffa --- /dev/null +++ b/sources/AtariST/DEMO.FB.src @@ -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 fr 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 diff --git a/sources/AtariST/DISASS.FB.src b/sources/AtariST/DISASS.FB.src new file mode 100644 index 0000000..075582b --- /dev/null +++ b/sources/AtariST/DISASS.FB.src @@ -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 diff --git a/sources/AtariST/DRAGON1.FB.src b/sources/AtariST/DRAGON1.FB.src new file mode 100644 index 0000000..81642e0 --- /dev/null +++ b/sources/AtariST/DRAGON1.FB.src @@ -0,0 +1,136 @@ +Screen 0 not modified + 0 \\ documentation for dargon demo tcas20130106 + 1 start the dragon with : DRAG + 2 or with : <1 or -1> 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 diff --git a/sources/AtariST/EDIICON.FB.src b/sources/AtariST/EDIICON.FB.src new file mode 100644 index 0000000..e4beaf1 --- /dev/null +++ b/sources/AtariST/EDIICON.FB.src @@ -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 diff --git a/sources/AtariST/EDITOR.FB.src b/sources/AtariST/EDITOR.FB.src new file mode 100644 index 0000000..a2d9fe0 --- /dev/null +++ b/sources/AtariST/EDITOR.FB.src @@ -0,0 +1,1598 @@ +Screen 0 not modified + 0 \\ *** Screen-Editor *** 10aug86we + 1 + 2 Dieses File enth„lt den volksFORTH - Editor. + 3 Er basiert auf dem Editor im F83 von Laxen/Perry, besitzt aber + 4 erheblich erweiterte Funktionen (Zeichen- und Zeilenstack) und + 5 ist ein vollst„ndig in GEM integrierter Fullscreen-Editor. + 6 + 7 Obwohl die Steuerung mit Maus und Menuzeile erfolgt, k”nnen + 8 ihn die 'Profis' auch vollst„ndig ber Controltasten bedienen, + 9 +10 Die Dauerhilfe-Funktion macht eine Funktionsbeschreibung ber- +11 flssig. Solange im HILFE-Menu Dauerhilfe gew„hlt ist, erscheint +12 vor der Ausfhrumg jeder Editor-Funktion ein erl„uternder Text +13 mit der M”glichkeit zum Abbruch. Dies gilt jedoch nicht, wenn +14 die Funktion per Tastendruck aufgerufen wurde. +15 +Screen 1 not modified + 0 \ Load Screen for the Editor cas20130105 + 1 + 2 Onlyforth GEM also + 3 include ediicon.fb + 4 + 5 | Variable (dx 2 (dx ! | Variable (dy 4 (dy ! + 6 | : dx (dx @ ; | : dy (dy @ ; + 7 + 8 \needs -text .( strings needed !!) abort + 9 \needs file? .( Filesystem needed !!) abort +10 include gem\supergem.fb +11 include gem\gemdefs.fb +12 include edwindow.fb +13 +14 Forth definitions +15 1 $2C +thru +Screen 2 not modified + 0 \ Editor Variable 10sep86we + 1 + 2 Variable 'scr 1 'scr ! Variable 'r# 'r# off + 3 Variable 'edifile + 4 + 5 ?head @ 1 ?head ! + 6 + 7 Variable changed Variable edistate + 8 Variable edifile + 9 Variable ycur +10 +11 +12 +13 +14 +15 +Screen 3 not modified + 0 \ Edi move cursor with position-checking or cyclic 30aug86we + 1 + 2 : c ( n -- ) \ checks the cursor position + 3 r# @ + dup 0 b/blk uwithin 0= abort" Border!" r# ! ; + 4 + 5 \ : c ( n -- ) \ moves cyclic thru the screen + 6 \ r# @ + b/blk mod r# ! ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 4 not modified + 0 \ Move the Editor's cursor around 08aug86we + 1 + 2 : top ( -- ) r# off ; + 3 : cursor ( -- n ) r# @ ; + 4 : t ( n -- ) c/l * cursor - c ; + 5 : line# ( -- n ) cursor c/l / ; + 6 : col# ( -- n ) cursor c/l mod ; + 7 : +t ( n -- ) line# + t ; + 8 : 'start ( -- addr ) scr @ block ; + 9 : 'cursor ( -- addr ) 'start cursor + ; +10 : 'line ( -- addr ) 'cursor col# - ; +11 : #after ( -- n ) c/l col# - ; +12 : #remaining ( -- n ) b/blk cursor - ; +13 : #end ( -- n ) #remaining col# + ; +14 +15 +Screen 5 not modified + 0 \ Move the Editors cursor 08aug86we + 1 + 2 : curup c/l negate c ; + 3 : curdown c/l c ; + 4 : curleft -1 c ; + 5 : curright 1 c ; + 6 : +tab cursor $10 / 1+ $10 * cursor - c ; + 7 : -tab cursor 8 mod negate dup 0= 8 * + c ; + 8 : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; + 9 : line# t curdown ; +10 +11 +12 +13 +14 +15 +Screen 6 not modified + 0 \ buffers 14sep86we + 1 + 2 : modified ( -- ) scr @ block drop update + 3 changed @ ?exit edistate off changed on ; + 4 + 5 &84 Constant c/pad + 6 &42 Constant c/buf + 7 + 8 : 'work ( -- work-buf ) pad c/pad + ; + 9 : 'insert ( -- ins-buf ) 'work c/pad + ; +10 : 'find ( -- find-buf ) 'insert c/buf + ; +11 +12 : 'find+ ( n1 -- n2 ) 'find c@ + ; +13 +14 +15 +Screen 7 not modified + 0 \ Errorchecking 09sep86we + 1 + 2 : ?bottom ( -- ) 'start b/blk + c/l - c/l -trailing nip + 3 abort" You would lose a line" ; + 4 + 5 : ?end ( -- ) 'line c/l + 1- c@ bl - + 6 abort" You would lose a char" ; + 7 + 8 : ?range ( n -- n ) dup 0 capacity uwithin not + 9 abort" Out of range!" ; +10 +11 +12 +13 +14 +15 +Screen 8 not modified + 0 \ Graphics for display 23aug86we + 1 + 2 : lineclr ( line# -- ) + 3 wi_x swap cheight * wi_y + + 4 over wi_width + over cheight + fbox ; + 5 + 6 : lineinsert ( line# -- ) + 7 wi_x over cheight * wi_y + + 8 wi_width over l/s 1- cheight * wi_y + swap - + 9 2over cheight + scr>scr lineclr ; +10 +11 : linedelete ( line# -- ) +12 wi_x swap 1+ cheight * wi_y + +13 wi_width over l/s cheight * wi_y + swap - +14 2over cheight - scr>scr l/s 1- lineclr ; +15 +Screen 9 not modified + 0 \ Editor-Window Title and Status-Line cas20130105 + 1 + 2 : 'workblank + 3 'work dup $sum ! dup off dup 1+ c/l blank c/l + off ; + 4 + 5 + 6 : update$ ( -- string ) + 7 scr @ updated? not IF " not updated" exit THEN " updated" ; + 8 + 9 : .edistate edistate @ ?exit edistate on 'workblank +10 " Scr # " count $add scr @ extend <# # # # #> $add +11 'work c@ 2+ 'work c! update$ count $add +12 'work 1+ wi_status ; +13 +14 +15 +Screen 10 not modified + 0 \ screen display 30aug86we + 1 + 2 : .edifile 'workblank 1 'work c! + 3 isfile@ ?dup 0= IF " DIRECT" ELSE 2- >name THEN + 4 count $add 'work count + 1+ c/l min off + 5 'work 1+ wi_title ; + 6 + 7 : 'line# ( line# -- addr count ) + 8 dup dy + dx at c/l * 'start + c/l ; + 9 +10 : .line ( line# -- ) dup lineclr 'line# -trailing type ; +11 : redisplay ( line# -- ) 'line# type ; +12 +13 +14 +15 +Screen 11 not modified + 0 \ screen display 14sep86we + 1 + 2 &18 Constant id-len + 3 Create id id-len allot id id-len erase + 4 + 5 : stamp id 1+ count 'start c/l + over - swap cmove ; + 6 : ?stamp changed @ IF stamp THEN ; + 7 + 8 + 9 : edilist edistate off changed off +10 vslide_size scr @ vslide +11 .edifile .edistate l/s 0 DO I .line LOOP ; +12 +13 : undo scr @ block drop prev @ emptybuf edilist ; +14 +15 : do_redraw hide_c wi_clear redraw_screen edilist ; +Screen 12 not modified + 0 \ Edi Variables, 23aug86we + 1 + 2 Variable (pad (pad off + 3 : memtop ( -- addr ) sp@ $100 - ; + 4 + 5 Variable chars Variable #chars + 6 : 'chars ( -- addr ) chars @ #chars @ + ; + 7 + 8 Variable lines Variable #lines + 9 : 'lines ( -- addr ) lines @ #lines @ + ; +10 +11 Variable (key +12 +13 Variable imode imode off +14 +15 +Screen 13 not modified + 0 \ Edi line handling 09aug86we + 1 + 2 : linemodified modified line# redisplay ; + 3 + 4 : clrline 'line c/l blank linemodified ; + 5 : clrright 'cursor #after blank linemodified ; + 6 + 7 : delline 'line #end c/l delete + 8 line# linedelete modified ; + 9 : backline curup delline ; +10 +11 : instline ?bottom 'line c/l over #end insert +12 line# lineinsert clrline ; +13 +14 +15 +Screen 14 not modified + 0 \ Edi line handling 09aug86we + 1 + 2 : @line 'lines memtop u> abort" line buffer full" + 3 'line 'lines c/l cmove c/l #lines +! ; + 4 + 5 : copyline @line curdown ; + 6 : line>buf @line delline ; + 7 + 8 : !line c/l negate #lines +! 'lines 'line c/l cmove + 9 linemodified ; +10 +11 : buf>line #lines @ 0= abort" line buffer empty" +12 ?bottom instline !line ; +13 +14 +15 +Screen 15 not modified + 0 \ Edi char handling 09aug86we + 1 + 2 : delchar 'cursor #after 1 delete linemodified ; + 3 : backspace curleft delchar ; + 4 + 5 : inst1 ?end 'cursor 1 over #after insert ; + 6 : instchar inst1 bl 'cursor c! linemodified ; + 7 + 8 : @char 'chars 1- lines @ u> abort" char buffer full" + 9 'cursor c@ 'chars c! 1 #chars +! ; +10 : copychar @char curright ; +11 : char>buf @char delchar ; +12 +13 : !char -1 #chars +! 'chars c@ 'cursor c! ; +14 : buf>char #chars @ 0= abort" char buffer empty" +15 inst1 !char linemodified ; +Screen 16 not modified + 0 \ from Screen to Screen ... 22oct86we + 1 + 2 : setscreen ( n -- ) ?stamp ?range scr ! edilist ; + 3 : n scr @ 1+ setscreen ; + 4 : b scr @ 1- setscreen ; + 5 + 6 : >shadow ( n1 -- n2 ) capacity 2/ 2dup < IF + ELSE - THEN ; + 7 : w scr @ >shadow setscreen ; + 8 + 9 : (mark scr @ 'scr ! r# @ 'r# ! isfile@ 'edifile ! ; +10 : mark (mark true abort" marked !" ; +11 +12 : a ?stamp 'edifile @ [ Dos ] dup searchfile drop +13 isfile@ 'edifile ! !files +14 'r# @ r# @ 'r# ! r# ! +15 'scr @ scr @ 'scr ! ?range scr ! edilist ; +Screen 17 not modified + 0 \ splitting a line, replace 17aug86we + 1 + 2 : split ?bottom pad c/l 2dup blank + 3 'cursor #remaining insert linemodified + 4 col# line# lineinsert + 5 'start cursor + c/l rot delete linemodified ; + 6 + 7 : ins 'insert count under 'cursor #after insert c ; + 8 + 9 : r +10 c/l 'line over -trailing nip - +11 'insert c@ 'find c@ - < abort" not enough room" +12 'find c@ dup negate c 'cursor #after rot delete ins +13 linemodified ; +14 +15 +Screen 18 not modified + 0 \ find und search 30aug86we + 1 + 2 : >last? ( -- f ) :dfright state_gaddr l@ 1 and ; + 3 : >last :dfright select :dfleft deselect ; + 4 : >1st :dfleft select :dfright deselect ; + 5 + 6 Variable fscreen + 7 + 8 : find? ( - n f ) 'find count 'cursor #remaining search ; + 9 +10 : s BEGIN find? IF 'find+ c edilist exit THEN drop +11 fscreen @ scr @ - ?dup stop? 0= and +12 WHILE 0< IF -1 ELSE 1 THEN scr +! top scr @ vslide +13 REPEAT :sfind tree! +14 >last? IF >1st :df1st ELSE >last :dflast THEN +15 getnumber drop fscreen ! edilist true abort" not found" ; +Screen 19 not modified + 0 \ Search-Findbox auswerten 24aug86we + 1 + 2 : initfind ( -- ) + 3 :dfmatch select :dfignore deselect >last + 4 1 extend :df1st putnumber + 5 capacity 1- extend :dflast putnumber ; + 6 + 7 : getfind ( -- n ) + 8 :dfignore state_gaddr l@ 1 and caps ! + 9 >last? IF :dflast ELSE :df1st THEN getnumber drop +10 capacity 1- min +11 :dffstrin 'find getstring :dfrstrin 'insert getstring ; +12 +13 : do_fbox ( -- button ) :sfind tree! +14 edifile @ isfile@ - IF isfile@ edifile ! initfind THEN +15 show_object :dffstrin form_do dup deselect hide_object ; +Screen 20 not modified + 0 \ Replacing ... 24aug86we + 1 + 2 Variable ?replace + 3 + 4 : show_replace ( -- ) + 5 &320 &200 &10 &10 little 4! + 6 col# dx + 2- cwidth * line# dy + 1+ cheight * + 7 2dup 0 objc_setpos 0 objc_getwh big 4! + 8 big 4@ scr>mem1 1 little 4@ big 4@ form_dial + 9 0 ( install) 3 ( depth) big 4@ objc_draw show_c ; +10 +11 : replace ( -- ) +12 :fbox tree! BEGIN +13 show_replace 0 form_do dup deselect hide_object +14 dup :fboxcanc - WHILE :fboxyes = IF r THEN s +15 REPEAT drop ; +Screen 21 not modified + 0 \ Editor's find and replace 24aug86we + 1 + 2 Variable (findbox (findbox off + 3 + 4 : repfind ( -- ) + 5 (findbox @ 'find c@ and 0= abort" use find first" + 6 ?stamp fscreen @ capacity 1- min fscreen ! + 7 s ?replace @ IF replace THEN ; + 8 + 9 : edifind ( -- ) +10 do_fbox :dfcancel case? ?exit +11 :dfreplac = ?replace swap IF on ELSE off THEN +12 :edimenu tree! :repeat 1 menu_ienable (findbox on +13 :sfind tree! getfind fscreen ! repfind ; +14 +15 +Screen 22 not modified + 0 \ exiting the Editor 30aug86we + 1 + 2 Defer resetmouse + 3 + 4 : done ( ff addr -- tf ) + 5 :edimenu tree! 0 menu_bar resetmouse hide_c + 6 wi_close ycur @ 0 at cr ." Scr #" scr @ 3 .r 2 spaces + 7 count type true ; + 8 + 9 : cdone ( ff -- tf ) prev @ emptybuf " canceled" done ; +10 : sdone ( ff -- tf ) ?stamp save-buffers " saved" done ; +11 : xdone ( ff -- tf ) ?stamp update$ done ; +12 : ldone ( ff -- tf ) drop true +13 ?stamp save-buffers " loading" done ; +14 +15 +Screen 23 not modified + 0 \ get User's ID, jump to screen 24aug86we + 1 + 2 : do_getid + 3 :sgetid tree! id 1+ :idtext putstring + 4 show_object :idtext form_do dup deselect hide_object + 5 :idcancel case? ?exit + 6 :noid = IF id off exit THEN + 7 :idtext id 1+ getstring ; + 8 + 9 : get-id +10 id c@ ?exit 1 id c! do_getid ; +11 +12 : jumpscreen :sgetscr tree! +13 pad dup off :scrnr putstring +14 show_object :scrnr form_do dup deselect hide_object +15 :sgcancel = ?exit :scrnr getnumber drop setscreen ; +Screen 24 not modified + 0 \ insert- and overwrite-mode 24aug86we + 1 + 2 : mark_item ( item# -- ) 1 menu_icheck ; + 3 : clr_item ( item# -- ) 0 menu_icheck ; + 4 + 5 : setimode imode on :edimenu tree! + 6 :imode mark_item :omode clr_item ; + 7 : clrimode imode off :edimenu tree! + 8 :omode mark_item :imode clr_item ; + 9 +10 +11 +12 +13 +14 +15 +Screen 25 not modified + 0 \ viewing words 24aug86we + 1 + 2 : >view ( -- ) + 3 'find count pad place pad capitalize bl pad count + c! + 4 find 0= abort" Haeh?" + 5 >name ?dup 0= abort" no view-field" + 6 4- @ ?dup 0= abort" hand made" + 7 (view scr ! top curdown find? 0= IF drop exit THEN + 8 'find+ c ; + 9 +10 : do_view ( -- ) +11 :sview tree! pad dup off :svword putstring +12 show_object :svword form_do dup deselect hide_object +13 :idcancel case? ?exit +14 :svword 'find getstring :svmark = IF (mark THEN +15 >view edilist ; +Screen 26 not modified + 0 \ Table of keystrokes 10aug86we + 1 + 2 Create keytable + 3 $4800 0 , , $4B00 0 , , $5000 0 , , $4D00 0 , , + 4 $4838 1 , , $4B34 1 , , $5032 1 , , $4D36 1 , , + 5 $5000 2 , , $7400 2 , , + 6 $0E08 0 , , $537F 0 , , $5200 0 , , $240A 2 , , + 7 $0E08 1 , , $537F 1 , , $5230 1 , , $6100 0 , , + 8 $1709 2 , , $180F 2 , , $1205 2 , , $531F 2 , , + 9 $1C0D 0 , , $1C0D 1 , , $0F09 0 , , $0F09 1 , , +10 $4700 0 , , $4737 1 , , $2207 2 , , $2F16 2 , , +11 $2106 2 , , $1312 2 , , $320D 2 , , +12 $011B 0 , , $1F13 2 , , $2D18 2 , , $260C 2 , , +13 $310E 2 , , $3002 2 , , $1E01 2 , , $1117 2 , , +14 +15 here keytable - 2/ 2/ Constant #keys +Screen 27 not modified + 0 \ Table of actions 11aug86we + 1 + 2 Create actiontable ] + 3 curup curleft curdown curright + 4 line>buf char>buf buf>line buf>char + 5 copyline copychar + 6 backspace delchar instchar jumpscreen + 7 backline delline instline undo + 8 setimode clrimode clrline clrright + 9 split +tab -tab +10 top >""end do_getid do_view +11 edifind repfind mark +12 cdone sdone xdone ldone +13 n b a w +14 +15 [ here actiontable - 2/ #keys - abort( # of actions) +Screen 28 not modified + 0 \ Table of Menuevents 24aug86we + 1 + 2 Create menutable + 3 $FF c, $FF c, $FF c, $FF c, + 4 :cutline c, :cutchar c, :pastelin c, :pastecha c, + 5 :copyline c, :copychar c, + 6 $FF c, $FF c, $FF c, :jump c, + 7 :backline c, :delline c, :insline c, :undo c, + 8 :imode c, :omode c, :eraselin c, :erasrest c, + 9 $FF c, :split c, :tab c, :backtab c, +10 :home c, :toend c, :getid c, :view c, +11 :search c, :repeat c, :mark c, +12 :canceled c, :flushed c, :updated c, :loading c, +13 :next c, :back c, :alternat c, :shadow c, +14 +15 here menutable - #keys - abort( # of menuitems) +Screen 29 not modified + 0 \ Table of Help-Boxes 24aug86we + 1 + 2 Create helptable + 3 $FF c, $FF c, $FF c, $FF c, + 4 :hlicut c, :hchcut c, :hlipaste c, :hchpaste c, + 5 :hlicopy c, :hchcopy c, + 6 $FF c, $FF c, $FF c, :hjump c, + 7 :hliback c, :hlidel c, :hliins c, :hexundo c, + 8 :hspins c, :hspover c, :hlierase c, :hlirest c, + 9 $FF c, :hlisplit c, :hcutabr c, :hcutabl c, +10 :hcuhome c, :hcuend c, :hspgetid c, :hview c, +11 :hspfind c, :hsprepea c, :hscmark c, +12 :hexcancl c, :hexsave c, :hexupdat c, :hexload c, +13 :hscnext c, :hscback c, :hscalter c, :hscshado c, +14 +15 here helptable - #keys - abort( # of menuitems) +Screen 30 not modified + 0 \ Prepare multi-event 09sep86we + 1 + 2 Variable mflag mflag off + 3 + 4 : ediprepare + 5 %00110111 + 6 1 1 1 + 7 mflag @ + 8 dx cwidth * dy cheight * c/l cwidth * l/s cheight * + 9 0 0 0 0 0 +10 0 0 +11 intin $10 array! message >absaddr addrin 2! ; +12 +13 ' pause | Alias ev-timer +14 : ev-r1 1 mflag 1+ ctoggle ; +15 +Screen 31 not modified + 0 \ Button Event 24aug86we + 1 + 2 Variable ?cursor ?cursor off + 3 + 4 : curon ?cursor @ ?exit ?cursor on + 5 3 swr_mode 1 sf_color 1 sf_interior 0 sf_perimeter + 6 at? cwidth * swap cheight * + 7 over cwidth 1- + over cheight + 1- bar ; + 8 + 9 : curoff ?cursor off curon ?cursor off ; +10 +11 : ev-button mflag @ 0= ?exit +12 intout 4+ @ cheight / dy - c/l * +13 intout 2+ @ cwidth / dx - + r# ! hide_c curoff ; +14 +15 +Screen 32 not modified + 0 \ Key event 17aug86we + 1 + 2 : visible? ( key -- f ) $FF and ; + 3 + 4 : putchar ( -- ) + 5 (key @ dup visible? 0= abort" What?" + 6 imode @ IF inst1 THEN 'cursor c! linemodified curright ; + 7 + 8 : findkey ( d_key -- addr ) + 9 ['] putchar -rot +10 #keys 0 DO 2dup keytable I 2* 2* + 2@ d= +11 IF rot drop actiontable I 2* + @ -rot LEAVE THEN +12 LOOP 2drop ; +13 +14 +15 +Screen 33 not modified + 0 \ Key event 23aug86we + 1 + 2 Variable jingle jingle on + 3 Variable ?mouse + 4 + 5 : edit-at cursor c/l /mod dy + swap dx + at ; + 6 + 7 : ev-key ?mouse off + 8 intout &10 + dup @ dup (key ! hide_c edit-at curoff + 9 swap 2- @ dup 1 and + 2/ findkey execute +10 jingle on .edistate BEGIN getkey 0= UNTIL ; +11 +12 +13 +14 +15 +Screen 34 not modified + 0 \ Message events for window 30aug86we + 1 + 2 : getmessage ( n -- n' ) 2* message + @ ; + 3 + 4 : wm_arrowed + 5 4 getmessage 1 and IF n exit THEN b ; + 6 + 7 : wm_vslide + 8 4 getmessage capacity 1- &1000 */ setscreen ; + 9 +10 : wm_moved +11 4 getmessage cwidth / 1 max &14 min (dx ! +12 5 getmessage cheight / 1 max 5 min 3 + (dy ! +13 wi_handle @ 5 wi_size wind_set redraw_screen ; +14 +15 +Screen 35 not modified + 0 \ Message events (the menuline) 02sep86we + 1 + 2 Variable ?help ?help on + 3 + 4 : do_help ( n -- ) + 5 helptable + c@ alert 1 = ?exit + 6 true abort" Dann eben nicht !!" ; + 7 + 8 : do_copyr :copyr tree! + 9 show_object 0 form_do deselect hide_object ; +10 +11 : do_menuhelp show_c :hhemenu alert hide_c +12 :edimenu tree! 1 and :menuhelp over menu_icheck +13 ?help ! ; +14 +15 +Screen 36 not modified + 0 \ Message events from menuline 02sep86we + 1 + 2 : do_other ( -- ) 4 getmessage + 3 :menuhelp case? IF do_menuhelp exit THEN + 4 :hmouse case? IF :hhemouse alert drop exit THEN + 5 :hfuncts case? IF :hhef1f10 alert drop exit THEN + 6 drop do_copyr ; + 7 + 8 : menu-message ( -- ) message @ :mn_selected - ?exit + 9 :edimenu tree! 3 getmessage 1 menu_tnormal +10 ['] do_other 4 getmessage +11 #keys 0 DO dup menutable I + c@ = +12 IF ?help @ IF I do_help THEN +13 nip actiontable I 2* + @ swap LEAVE THEN +14 LOOP drop execute jingle on .edistate ; +15 +Screen 37 not modified + 0 \ Handle message-event 24aug86we + 1 + 2 : ev-message hide_c edit-at curoff + 3 message @ :mn_selected case? IF menu-message exit THEN + 4 :wm_arrowed case? IF wm_arrowed exit THEN + 5 :wm_vslid case? IF wm_vslide exit THEN + 6 :wm_moved case? IF wm_moved exit THEN + 7 :wm_redraw case? IF do_redraw exit THEN + 8 drop ; + 9 +10 +11 +12 +13 +14 +15 +Screen 38 not modified + 0 \ Handle all events 30aug86we + 1 + 2 Create ev-flag + 3 :mu_mesag c, :mu_m1 c, :mu_button c, + 4 :mu_keybd c, :mu_timer c, + 5 + 6 Create: event-actions + 7 ev-message ev-r1 ev-button ev-key ev-timer ; + 8 + 9 : handle-events ( which -- ) +10 5 0 DO ev-flag I + c@ over and IF drop I LEAVE THEN LOOP +11 2* event-actions + perform ; +12 +13 +14 +15 +Screen 39 not modified + 0 \ Change mouse-movement Vector 10sep86we + 1 + 2 2Variable savevec + 3 + 4 Create newvector Assembler + 5 ?mouse pcrel) A0 lea true # A0 ) move + 6 .l savevec pcrel) A0 move A0 ) jmp end-code + 7 + 8 Code ?show_c ?mouse R#) tst 0= IF Next THEN ;c: show_c ; + 9 +10 : ex_motv ( pusrcode -- ) +11 contrl &14 + 2! &126 0 0 VDI contrl &18 + 2@ savevec 2! ; +12 +13 : setmousevec newvector >absaddr ex_motv ; +14 : resetmousevec savevec 2@ ex_motv ; +15 ' resetmousevec Is resetmouse +Screen 40 not modified + 0 \ The Editor's LOOP 02sep86we + 1 + 2 : ediloop r0 @ rp! + 3 BEGIN edit-at curon ?show_c false + 4 ediprepare evnt_multi handle-events UNTIL ; + 5 + 6 : alarm bell jingle off ; + 7 + 8 : edierror ( string -- ) + 9 jingle @ 0= IF drop ediloop THEN alarm +10 'workblank c/l 2/ 'work c! count c/l 2/ min $add +11 'work 1+ wi_status edistate off ediloop ; +12 +13 +14 +15 +Screen 41 not modified + 0 \ Installing the Editor 20nov86we + 1 + 2 Create ediresource &12 allot + 3 Variable edihandle + 4 + 5 : setediresource ediresource ap_ptree &12 cmove ; + 6 + 7 : ?clearbuffer + 8 pad (pad @ = ?exit pad (pad ! + 9 'find b/blk + dup chars ! c/l 2* + lines ! +10 #chars off #lines off 'find off 'insert off (findbox off ; +11 +12 +13 +14 +15 +Screen 42 not modified + 0 \ Installing the Editor 20nov86we + 1 + 2 : finstall ( -- ) + 3 pad memtop u> abort" No room for buffers!" + 4 get-id changed off row ycur ! setmousevec + 5 ?clearbuffer ?cursor off + 6 ap_ptree &12 cpush setediresource + 7 grhandle push edihandle @ grhandle ! + 8 wi_open :edimenu tree! 1 menu_bar + 9 errorhandler push ['] edierror errorhandler ! +10 r0 push rp@ r0 ! ediloop ; +11 +12 +13 +14 +15 +Screen 43 not modified + 0 \ Entering the Editor 11sep86we + 1 + 2 Forth definitions ?head ! + 3 + 4 | : ?load 0= ?exit scr @ r# @ (load ; + 5 + 6 : v ( -- ) scr @ ?range drop finstall ?load ; + 7 + 8 : l ( scr -- ) 1 arguments ?range scr ! top v ; + 9 +10 | : >find bl word count 'find place ; +11 +12 : view ( -- ) >find >view v ; +13 +14 +15 +Screen 44 not modified + 0 \ Init the Editor for different resolutions 18sep86we + 1 + 2 | : q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ; + 3 + 4 | : setMFDB ( addr_of_MFDB -- ) >r + 5 0 q_extnd intout 2@ r@ 4+ 2! intout @ $10 / r@ 6 + ! + 6 1 q_extnd intout 8 + @ r> &12 + ! ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 45 not modified + 0 \ save-system for Editor cas20130105 + 1 + 2 | : edistart grinit rsrc_load" ediicon.rsc" 0 graf_mouse + 3 grhandle @ edihandle ! ap_ptree ediresource &12 cmove + 4 memMFDB1 setMFDB memMFDB2 setMFDB + 5 ['] noop [ ' drvinit >body ] Literal ! ; + 6 + 7 : bye grexit bye ; grinit + 8 + 9 : save-system id off r# off 1 scr ! 'r# off 1 'scr ! +10 (findbox off (pad off +11 ['] edistart [ ' drvinit >body ] Literal ! +12 [ ' forth83.fb >body ] Literal 'edifile ! +13 flush save-system bye ; +14 +15 +Screen 46 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 47 not modified + 0 \\ *** Screen-Editor *** 17aug86we + 1 + 2 In den Editor gelangt man mit l ( Screen-Nr. -- ), mit v oder + 3 view. view verlangt als weitere Eingabe ein FORTH-Wort und + 4 sucht dann den Screen, auf dem das Wort definiert wurde. + 5 + 6 Alle Eingaben werden unmittelbar in den Blockbuffer geschrieben, + 7 der den aktuellen Screen enth„lt. + 8 + 9 Die Position des Cursors h„ngt von 2 Variablen ab: +10 scr enth„lt die Nummer des aktuellen Screens; +11 r# bestimmt die Position des Cursors. +12 Beides sind Systemvariable, die auch beim Compilieren benutzt +13 werden. Bei Abbruch wegen eines Fehlers ruft man den Editor mit +14 v auf. Der Cursor steht hinter dem Wort, das den Abbruch +15 ausgel”st hat. +Screen 48 not modified + 0 \ Load Screen for the Editor 24aug86we + 1 + 2 bindet Vocabulary GEM mit in die Suchreihenfolge ein. + 3 Labels fr Editor-Resource + 4 + 5 (dx und (dy sind Variable, die die Lage des Editorfensters + 6 relativ zur linken oberen Ecke des Bildschirms angeben. + 7 Der Editor ben”tigt einige Definitionen aus anderen Files. + 8 - fr die Suchfunktionen. + 9 - falls kein File-Interface vorhanden ist. +10 - fr das Fenster +11 Labels fr Gem-Aufrufe +12 +13 +14 +15 +Screen 49 not modified + 0 \ Editor Variable 26oct86we + 1 + 2 Screen-Nr. und Cursorposition vom markierten Screen + 3 File fr markierten Screen + 4 + 5 Alle folgenden Definitionen werden headerless compiliert. + 6 + 7 Flag fr Žnderungen am Screen; Flag, ob Statuszeile neu ge- + 8 File, das editiert wird schrieben werden muž + 9 ycur ist die Cursorposition beim Aufruf des Editors +10 +11 +12 +13 +14 +15 +Screen 50 not modified + 0 \ Edi move cursor with position-checking or cyclic 30aug86we + 1 + 2 bewegt den Cursor um n Stellen vor- bzw. rckw„rts. + 3 Wird der Cursor ber Anfang oder Ende des Screens hinausbewegt, + 4 stehen zwei M”glichkeiten zur Wahl: + 5 - Kommando wird nicht ausgefhrt. + 6 - Der Screen wird zyklisch durchlaufen. + 7 + 8 W„hlen Sie durch 'Wegkommentieren' und Neucompilieren des + 9 Editors. +10 +11 +12 +13 +14 +15 +Screen 51 not modified + 0 \ Move the Editor's cursor around 05aug86we + 1 + 2 setzt Cursor in die obere linke Ecke (Home). + 3 n ist die aktuelle Position des Cursors (Offset von Home) + 4 setzt Cursor auf Beginn der Zeile n. + 5 n ist die Zeile, in der der Cursor steht. + 6 n ist die Spalte, in der der Cursor steht. + 7 bewegt Cursor um n Zeilen vor- bzw. rckw„rts auf Zeilenanfang. + 8 addr ist die Anfangsadresse des aktuellen Blocks im Speicher. + 9 addr ist die der Cursorposition entsprechende Speicheradresse. +10 addr ist die Speicheradresse des Beginns der Cursorzeile. +11 n ist die Stellenanzahl zwischen Cursorposition und Zeilenende. +12 n ist die Stellenanzahl zwischen Cursorposition und Blockende. +13 n ist die Stellenanzahl zwischen Cursorzeile und Blockende. +14 +15 +Screen 52 not modified + 0 \ Move the Editors cursor 07aug86we + 1 + 2 setzt Cursor um eine Zeile nach oben. + 3 setzt Cursor um eine Zeile nach unten. + 4 setzt Cursor um ein Zeichen nach links. + 5 setzt Cursor um ein Zeichen nach rechts. + 6 setzt Cursor um eine Tabulatorposition nach vorn (s.unten). + 7 setzt Cursor um eine Tabulatorposition zurck (s.unten). + 8 setzt Cursor auf das letzte Zeichen des Screens. + 9 setzt Cursor auf Beginn der n„chsten Zeile. +10 +11 +12 Vorw„rtstabs: +13 + + + + +14 Rckw„rtstabs: +15 - - - - - - - - +Screen 53 not modified + 0 \ buffers 24aug86we + 1 + 2 markiert einen ge„nderten Block zum Zurckschreiben auf Disk + 3 setzt Flag fr ?stamp und l”scht Flag fr .edistate + 4 + 5 Byteanzahl in PAD (min. &84 nach 83-Standard!). + 6 Byteanzahl in einem Buffer (&40 durch Resource vorgegeben). + 7 + 8 'work, 'insert und 'find sind Buffer, die beim Aufruf des + 9 Editors oberhalb von PAD eingerichtet werden. +10 'work dient zur Aufbreitung von Strings fr die Statuszeile +11 'find enth„lt den Suchstring und 'insert den Replacestring. +12 n2 ist n1 zuzglich der L„nge des Findbuffers. +13 +14 +15 +Screen 54 not modified + 0 \ Errorchecking 17aug86we + 1 + 2 bricht ab, wenn beim Einfgen einer Zeile kein Platz mehr ist. + 3 + 4 + 5 bricht ab, wenn beim Einfgen eines Zeichens kein Platz mehr ist + 6 + 7 + 8 bricht ab, wenn ein Screen aužerhalb des aktuellen Files edi- + 9 tiert werden soll. +10 +11 +12 +13 +14 +15 +Screen 55 not modified + 0 \ Graphics for display 23aug86we + 1 + 2 l”scht Zeile n durch šberschreiben mit einem weižen Rechteck + 3 x - und y - Koordinate der linken oberen Ecke + 4 x - und y - Koordinate der rechten unteren Ecke + 5 + 6 fgt auf dem Bildschirm an der Cursorposition eine Leerzeile ein + 7 x - und y - Koordinate des zu verschiebenden Rechtecks + 8 Breite setzen und H”he berechnen + 9 x - und y - Koordinate des Zielrechtecks ( 1 Zeile tiefer ) +10 das ganze mit Pixelmove (schnell) verschieben und Zeile l”schen +11 l”scht auf dem Bildschirm die Cursorzeile +12 x - und y - Koordinate des zu verschiebenden Rechtecks +13 Breite setzen und H”he berechnen +14 x - und y - Koordinate des Zielrechtecks ( 1 Zeile h”her ) +15 das ganze mit Pixelmove verschieben und unterste Zeile l”schen +Screen 56 not modified + 0 \ Editor-Window Title and Status-Line 30aug86we + 1 + 2 setzt 'work als Arbeitsspeicher und l”scht ihn; 0 als Abschluž + 3 + 4 + 5 f ist true, wenn der aktuelle Screen als updated markiert ist. + 6 + 7 bergibt in Abh„ngigkeit vom Updatezustand den richtigen String. + 8 + 9 +10 Statuszeile wird nur beschrieben, wenn sich etwas ver„ndert hat. +11 Screennummer wird in 'work zusammengestellt, +12 2 Leerzeichen und dann die Updatemeldung. +13 das Ganze wird an .wi_state als 0-terminated String bergeben. +14 +15 +Screen 57 not modified + 0 \ screen display 30aug86we + 1 + 2 gibt den Filenamen in der Titelzeile aus; 'work l”schen + 3 Adresse des Strings, der den Filenamen enth„lt, ermitteln + 4 und nach 'work bringen, maximal eine Zeile, Leerzeichen am Ende + 5 als 0-terminated String an wi_title bergeben. + 6 + 7 berechnet die Speicheradresse von Zeile line#, + 8 setzt Cursor und bereitet die Parameter fr type auf. + 9 +10 l”scht Zeile line# und gibt sie dann aus (schnell!!). +11 gibt Zeile line# neu aus (langsam, aber ohne Flackern). +12 +13 +14 +15 +Screen 58 not modified + 0 \ screen display 14sep86we + 1 + 2 maximale L„nge der User-ID, die automatisch in die obere rechte + 3 Ecke des Screens gesetzt wird, wenn dieser ge„ndert wurde. + 4 + 5 setzt ID rechtsbndig (!) in die erste Zeile. + 6 setzt ID, wenn der aktuelle Screen ver„ndert wurde. + 7 + 8 + 9 gibt einen Screen im Editorfenster aus. Flags fr ?stamp und +10 vertikaler Slider wird auf richtige Gr”že und Position gesetzt +11 .edistate werden zurckgesetzt. +12 +13 l”scht den aktuellen Buffer und erzwingt so Neueinlesen von Disk +14 Der Blockzugriff ist fr Multitasking n”tig. +15 zeichnet den gesamten Bildschirm neu (nach Accessory-Aufruf). +Screen 59 not modified + 0 \ Edi Variables, putchar 17aug86we + 1 + 2 Adresse von PAD beim Editieren fr ?clearbuffer. + 3 Obergrenze fr Zeichen- (128 Zeichen) und Zeilenbuffer, der + 4 oberhalb von PAD bis zur Speichergrenze reicht + 5 Adresse des Zeichenbuffers Anzahl der Zeichen im Buffer + 6 liefert die n„chste freie Adresse im Zeichenbuffer. + 7 + 8 Adresse des Zeilenbuffers Anzahl der Zeilen im Buffer + 9 liefert die n„chste freie Adresse im Zeilenbuffer. +10 +11 speichert das zuletzt eingegebene Zeichen. +12 +13 Insertmodus, voreingestellt aus +14 +15 +Screen 60 not modified + 0 \ Edi line handling 17aug86we + 1 + 2 erneuert gerade bearbeitete Zeile auf dem Bildschirm; setzt Flag + 3 fr ?stamp. + 4 l”scht die Cursorzeile. + 5 l”scht vom Cursor bis zum Zeilenende. + 6 + 7 l”scht Cursorzeile und zieht Rest des Bildschirms nach oben. + 8 + 9 l”scht Zeile ber dem Cursor und zieht Rest des Bildschirms nach +10 oben. +11 fgt an der Cursorposition eine Leerzeile ein; Rest des Bild- +12 schirms wird nach unten geschoben. +13 +14 +15 +Screen 61 not modified + 0 \ Edi line handling 17aug86we + 1 + 2 prft, ob Platz im Zeilenbuffer vorhanden ist, und kopiert + 3 eine Zeile in den Zeilenbuffer. + 4 + 5 kopiert eine Zeile in den Buffer, setzt Cursor auf die n„chste. + 6 kopiert eine Zeile in den Buffer und l”scht sie. + 7 + 8 setzt aus dem Zeilenbuffer eine Zeile in der Cursorzeile ein. + 9 +10 +11 benutzt !line, prft vorher, ob Zeilen im Buffer sind. +12 Fr die neue Zeile wird zuerst eine Leerzeile eingefgt. +13 +14 +15 +Screen 62 not modified + 0 \ Edi char handling 17aug86we + 1 + 2 l”scht Zeichen unter dem Cursor. + 3 l”scht Zeichen links neben dem Cursor. + 4 + 5 fgt an der Cursorposition ein Zeichen im Buffer ein. + 6 benutzt inst1, um ein Leerzeichen einzufgen. + 7 + 8 analog zu @line, kopiert ein Zeichen in den Zeichenbuffer. + 9 +10 kopiert ein Zeichen in den Buffer, setzt Cursor auf das n„chste. +11 kopiert ein Zeichen in den Buffer und l”scht es. +12 +13 analog zu !line, setzt ein Zeichen aus dem Buffer bei Cursor ein +14 benutzt !char, prft vorher, ob Zeichen im Buffer sind. +15 Fr das neue Zeichen wird zuerst ein Leerzeichen eingefgt. +Screen 63 not modified + 0 \ from Screen to Screen ... 24aug86we + 1 + 2 prft, ob der angeforderte Screen vorhanden ist und gibt ihn aus + 3 geht auf den n„chsten Screen. + 4 geht auf den vorherigen Screen. + 5 + 6 berechnet zu Screen n1 den Shadow-Screen n2 oder umgekehrt. + 7 schaltet zwischen Original und Shadow hin und her. + 8 + 9 markiert den aktuellen Screen mit File und Cursorposition. +10 s.o., jedoch mit Meldung. +11 +12 vertauscht aktuellen und markierten Screen. Dabei wird auch das +13 File mitbercksichtigt. Dies erlaubt es, nach VIEW einen mar- +14 kierten Screen wieder zu benutzen. +15 +Screen 64 not modified + 0 \ splitting a line, replace 17aug86we + 1 + 2 setzt den Rest der Zeile ab Cursor auf den Anfang einer neu + 3 eingefgten Zeile. Dazu wird erst eine komplette leere Zeile + 4 eingefgt und dann von Cursorspalte bis Anfang der neuen + 5 Zeile gel”scht. + 6 + 7 fgt den Insert-Buffer an der Cursorposition ein. + 8 + 9 ersetzt den gefundenen String durch den Insert-Buffer. +10 berechnet Anzahl der Leerzeichen am Ende der Zeile. +11 Abbruch, wenn weniger als Differenz zwischen Find und Insert, +12 sonst Findstring l”schen und Insert-Buffer einfgen +13 +14 +15 +Screen 65 not modified + 0 \ find und search 30aug86we + 1 + 2 f ist 1, wenn in Richtung last Screen gesucht wird, sonst 1. + 3 schaltet Button in der Findbox auf Suche Richtung last screen. + 4 schaltet Button in der Findbox auf Suche Richtung 1st screen. + 5 + 6 Der Screen, bis zu dem gesucht werden soll + 7 + 8 sucht von Cursor bis Screenende; n ist Offset zu Cursorposition. + 9 +10 sucht von Cursor bis Screen fscreen vorw„rts oder rckw„rts. +11 solange bis fscreen erreicht ist oder Esc oder CTRL-C gedrckt, +12 wird der n„chste Screen aufgerufen. +13 Abbruch, falls nicht gefunden und Umschalten der Suchrichtung +14 in der Box und in fscreen. +15 Screen auflisten und Abbruchmeldung ausgeben. +Screen 66 not modified + 0 \ Search-Findbox auswerten 17aug86we + 1 + 2 Vorbelegung der Buttons und Screennummern in der Find-box: + 3 Grož-Kleinschreibung unterscheiden. + 4 Aufsteigend suchen bis Fileende. + 5 1 fr 1st Screen, letzten Screen im File als Last Screen + 6 + 7 Filebox auswerten: + 8 Variable caps entsprechend setzen. + 9 Suchrichtung bestimmt, ob der erste oder letzte Screen +10 als Endscreen benutzt wird. +11 Strings in die entsprechenden Buffer bernehmen. +12 +13 Falls das File gewechselt wurde, neu initialisieren, geschieht +14 auch automatisch, wenn sich PAD und damit Find- und Insert- +15 buffer ver„ndert haben. +Screen 67 not modified + 0 \ Replacing ... 17aug86we + 1 + 2 Flag fr Ersetzen des Find-Strings durch den Insert-String + 3 + 4 O Schreck und Graus !!! + 5 Die Replace-Box soll natrlich nicht den gefundenen String + 6 verdecken; die von form_center gelieferten Werte sind also + 7 unbrauchbar. X- und Y-Position mssen von Hand berechnet werden + 8 und zwar so, daž die linke obere Ecke der Box auf den Such- + 9 string zeigt; zeichnen des Objects wie in show_object. +10 +11 ersetzt solange den Suchstring durch den Insertstring, bis +12 CANCEL gedrckt oder der Suchstring nicht gefunden wird. +13 Abbruch auch, wenn der Insertstring sich nicht einsetzen l„žt. +14 Sonst wie bei Find Abbruch mit Esc. oder CTRL-C m”glich. +15 +Screen 68 not modified + 0 \ Editor's find and replace 17aug86we + 1 + 2 Flag fr repfind, ob bereits eine Suche stattgefunden hat. + 3 + 4 fhrt erneute Suche (und Ersetzen) durch ohne Find-Box. + 5 Abbruch, wenn noch kein Aufruf der Find-Box oder Findbuffer + 6 leer; sonst sicherstellen, daž fscreen innerhalb des Files + 7 liegt und s bzw replace ausfhren. + 8 + 9 Das ist das aufrufende Wort; im CANCEL-Fall abbrechen, +10 sonst Flag fr replace setzen, wenn :dfreplac gew„hlt wurde +11 Im Menubalken Repeatfind enable'n +12 Screennummer merken; suchen und ggf. ersetzen mit repfind. +13 +14 +15 +Screen 69 not modified + 0 \ exiting the Editor 30aug86we + 1 + 2 Setzt Mausvector zurck, wird erst sp„ter definiert. + 3 + 4 gemeinsame Routine fr alle Exits + 5 l”scht (und restauriert) das Fenster, setzt Mausvector zurck + 6 gibt an der alten Cursorpositione eine Meldung aus + 7 und setzt Flag zum Verlassen von ediloop. + 8 + 9 wirft alle Žnderungen weg, falls man sich 'vereditiert' hat. +10 speichert den Screen auf Disk, falls er ver„ndert wurde. +11 markiert den Screen, ohne ihn direkt zurckzuschreiben. +12 speichert den Screen auf Disk, falls er ver„ndert wurde +13 und compiliert ab Cursorposition. +14 +15 +Screen 70 not modified + 0 \ get User's ID, jump to screen 17aug86we + 1 + 2 User-ID holen + 3 bisherige ID im Fenster ausgeben + 4 das bliche form-handling + 5 bei Cancel nichts wie raus! + 6 bei NO-ID wird sie gel”scht; die Box erscheint dann bei n„ch- + 7 ster Gelegenheit wieder; sonst ID bernehmen (auch Leerstring) + 8 + 9 User-ID nur holen, wenn noch keine vorhanden ist. +10 Wird beim Eintritt in den Editor benutzt. +11 +12 springt auf beliebigen Screen im File. +13 Leerstring in die Box setzen. +14 das bliche form-handling +15 Screen-Nr. fr setscreen bernehmen und Screen ausgeben +Screen 71 not modified + 0 \ insert- and overwrite-mode 11aug86we + 1 + 2 setzt im Pulldownmenu ein H„kchen. + 3 wie oben, nur umgekehrt. + 4 + 5 Insert-Modus setzen und Pulldownmenu entsprechend „ndern. + 6 + 7 Overwrite-Modus setzen und Pulldownmenu entsprechend „ndern. + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 72 not modified + 0 \ viewing words 17aug86we + 1 + 2 Hilfswort fr do_view + 3 Findbuffer wird nach PAD gebracht und fr find aufbereitet. + 4 sucht CFA des Wortes im Findbuffer, um + 5 das zugeh”rige Name- und damit das View-Feld zu finden. + 6 setzt File und Screen-Nr. und sucht auf dem Screen nach dem + 7 Wort; falls gefunden, wird der Cursor dahinter positioniert. + 8 + 9 +10 l”scht den String in der Box; das bliche form-handling +11 String in Findbuffer bernehmen, falls nicht Cancel gew„hlt; +12 aktuellen Screen markieren, wenn MARK +13 angeklickt wurde, und gesuchten Screen aufrufen +14 Danach kann mit CTRL-A wieder auf den anderen Screen gewechselt +15 werden. Sehr ntzlich, um Zeilen aus anderen Files zu 'klauen'. +Screen 73 not modified + 0 \ Table of keystrokes 17aug86we + 1 + 2 Diese Tabelle enth„lt alle Tasten, die irgendwelche Sonder- + 3 funktionen haben. Das jeweils erste Wort ist der Scancode der + 4 Taste, das zweite die zus„tzlich gedrckten Tasten: + 5 1 = linke oder rechte SHIFT-Taste + 6 2 = CONTROL-Taste + 7 4 = ALTERNATE-Taste ( wird nicht benutzt ) + 8 Auf die Funktionstasten wurde bewužt verzichtet, weil man damit + 9 nicht vernnftig umgehen kann. +10 +11 +12 Zusatzvorschlag: +13 Alternate-Shift-Control bei gleichzeitig gedrckter Enter- und +14 F10-Taste ---> l”scht den Bildschirm. +15 +Screen 74 not modified + 0 \ Table of actions 17aug86we + 1 + 2 Tabelle aller Editorfunktionen + 3 Die Position eines Tabelleneintrags stimmt mit der des + 4 zugeh”rigen Tastendrucks berein, um die šbersicht zu behalten. + 5 Dies gilt auch fr die folgenden Screens. + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 prft, ob Anzahl der Funktionen mit Anzahl der Tasten berein- +15 stimmt. Wird nur w„hrend der Compilation gebraucht. +Screen 75 not modified + 0 \ Table of Menuevents 17aug86we + 1 + 2 Tabelle der Menueintr„ge. + 3 Alle Editorfunktionen sind sowohl ber die Menleiste als auch + 4 ber Tastendruck zu erreichen. + 5 Bei allen Worten mit : am Anfang handelt es sich um 'kopflose' + 6 Konstanten aus dem Resource-Definitionen-File (EDIICON.SCR), + 7 das mit dem Programm CONVH.SCR aus EDIICON.H erzeugt wurde. + 8 EDIICON.H wird vom 'Resource Construction Set' ausgegeben. + 9 An dieser Stelle unser herzlicher Dank an Digital Research fr +10 dieses hervorragende Produkt. Nur ca. 80 Systemabstrze gab es +11 bei der Entwicklung, weil Icons bisweilen auf ungeraden Spei- +12 cheradressen abgelegt werden. Aužerdem war bei knapp 10 kByte +13 L„nge der Resource mein Speicher (1024 kByte!!!) grunds„tzlich +14 voll bis absturzvoll. Dann bleibt das Programm stehen, nicht +15 ohne vorher die letzte lauff„hige Resource zu l”schen.... +Screen 76 not modified + 0 \ Table of Help-Boxes 17aug86we + 1 + 2 Tabelle der Help-Boxen. + 3 Zu jeder Editorfunktion gibt es eine Box, die die Funktion + 4 beschreibt. W„hlt man Dauerhilfe, erscheinen solche Boxen + 5 immer, wenn ein Befehl aus der Menuleiste abgerufen wird. + 6 Soll beim Einarbeiten in den Editor Hilfe leisten. Die Idee + 7 dazu stammt aus 1st Word. + 8 Gibt es zu einer Funktion keine Box (z.B. Cursortasten), ist + 9 der entsprechende Eintrag mit $FF gekennzeichnet. +10 +11 +12 +13 +14 +15 +Screen 77 not modified + 0 \ Prepare multi-event 24aug86we + 1 + 2 Flag, ob Maus innerhalb oder aužerhalb von Rechteck1 + 3 + 4 Fr den Multi-Event mssen 17 (!) Parameter bergeben werden. + 5 timer, message, mouse, button + keyboard events zulassen. + 6 1 Tastendruck auf linke Maustaste, event bei gedrckter Taste + 7 1, wenn Maus im Fensterbereich + 8 Rechteck 1 (Žnderung der Mausfunktion) umfažt Editor-Fenster + 9 Rechteck 2 gibts nicht +10 Timer auf 0 Millisekunden (sonst kommt der Multi-Event nicht +11 zurck) +12 +13 Wenn nichts anderes zu tun ist, kann eine andere Task ran. +14 schaltet Flag um. +15 +Screen 78 not modified + 0 \ Button Event 17aug86we + 1 + 2 Flag, das anzeigt, ob der Cursor sichtbar ist (1 = sichtbar) + 3 + 4 schaltet Cursor ein, wenn er noch nicht eingeschaltet ist; + 5 die Funktion arbeitet im EXOR-Modus, daher dieser Aufwand. + 6 baut an der aktuellen Cursorposition ein schwarzes Rechteck + 7 in der Gr”že eines Zeichens. + 8 + 9 kann curon benutzen wegen EXOR-Modus, muž aber das Flag setzen. +10 +11 Mausknopfereignis dann, wenn die Maus im Editorfenster steht. +12 die Position der Maus (in Pixel) wird in Zeile und Spalte umge- +13 rechnet und nach r# gespeichert. Maus abschalten und alten +14 Cursor l”schen (in dieser Reihenfolge!) +15 +Screen 79 not modified + 0 \ Key event 17aug86we + 1 + 2 Steuertasten erzeugen keinen ASCII-Code, sondern eine Null. + 3 + 4 gibt ein Zeichen auf dem Bildschirm aus und schreibt es in den + 5 Blockbuffer. Abbruch, wenn kein druckbares Zeichen vorliegt. + 6 Auf Insert-Modus prfen und Zeichen ausgeben. + 7 + 8 ermittelt die Adresse der zu einer Taste geh”renden Funktion. + 9 d_key enth„lt im oberen Wort den Status von Shift, Control usw. +10 putchar ist voreingestellt, keytable wird auf d_key abgesucht +11 wenn gefunden, wird die Adresse von putchar entfernt und statt- +12 dessen die zugeh”rige Adresse aus actiontable hinterlegt. +13 +14 +15 +Screen 80 not modified + 0 \ Key event 17aug86we + 1 + 2 Flag fr Fehlerpiep + 3 Flag, ob die Maus sichtbar ist + 4 + 5 positioniert den Cursor auf die Position in r#. + 6 + 7 Tasten-Event schaltet Mausflag ab + 8 Tastencode holen und Maus und Cursor abschalten. + 9 Status der Sondertasten aufbereiten und Tastenfunktion ausfh- +10 ren, Fehlerpiep erm”glichen, Status ausgeben +11 und - darauf bin ich ganz stolz - alle weiteren Tastendrcke +12 l”schen!! Dadurch l„uft auch bei schnellem Tastenrepeat keine +13 Funktion 'nach', wird aber trotzdem schnellstm”lich ausgefhrt. +14 Funktioniert allerdings dann nicht, wenn das lahme GEM was zu +15 tun hat, also beim Screenwechsel (CTRL-B und CTRL-N) +Screen 81 not modified + 0 \ Message events for window 30aug86we + 1 + 2 holt Wort n aus dem AES-message Buffer. + 3 + 4 bei Anklicken des Sliders oder der Pfeile + 5 wird der n„chste oder vorherige Screen aufgerufen. + 6 + 7 beim Verschieben des Sliders + 8 wird aus der Position die Screennummer berechnet. + 9 +10 beim Verschieben des ganzen Fensters +11 wird die vom User gewnschte Position berechnet +12 und in ganze Zeile bzw. Spalten umgewandelt; aužerhalb des +13 Screens kann nicht positioniert werden, sonst k”nnte man +14 ohne Sichtkontrolle weiter editieren. šber den Sinn dieser +15 Funktion kann man streiten, aber ich wollte zeigen, daž es geht +Screen 82 not modified + 0 \ Message events (the menuline) 17aug86we + 1 + 2 Flag fr Dauerhilfe bei jeder Menfunktion + 3 + 4 Hilfsbox Nr. n ausgeben + 5 passende Hilfsbox aus Tabelle suchen und anzeigen, bei OK Ende. + 6 sonst Funktion abbrechen. + 7 Es folgen die Funktionen, die nicht in der helptable auftauchen. + 8 Info-, Werbe- und Prunk-Box + 9 braucht nur angezeigt zu werden, spricht fr sich selbst. +10 +11 Dauerhilfe-Box anzeigen; je nach gew„hltem Knopf +12 H„kchen bei Menu Help setzen oder l”schen +13 dito fr Flag +14 +15 +Screen 83 not modified + 0 \ Message events from menuline 24aug86we + 1 + 2 Funktion, die nicht in actiontable steht, ausfhren + 3 mit case? die passende Funktion ausw„hlen + 4 Tabelle lohnt hier nicht. + 5 + 6 + 7 + 8 Menauswahl verarbeiten + 9 Mentitel von revers auf normal schalten +10 voreingestellt ist do_other, Nummer des angeklickten Items +11 holen, menutable wird auf Item-Nr. abgesucht +12 wenn gefunden, wird die Adresse von do_other entfernt und +13 stattdessen die zugeh”rige Adresse aus actiontable hinterlegt. +14 Funktion ausfhren, Fehlerpiep erm”glichen und Status ausgeben. +15 +Screen 84 not modified + 0 \ Handle message-event 24aug86we + 1 + 2 hier werden die Messages ausgewertet, die AES zurckgibt. + 3 wenn ein Menpunkt angeklickt wird, menu-message ausfhren. + 4 alle anderen Messages betreffen die Window-Attribute und + 5 werden entsprechend ausgefhrt. + 6 + 7 Wenn ein Desk-Accessory ausgefhrt wurde, erh„lt man lediglich + 8 die Meldung, daž neu gezeichnet werden muž, und dies auch nur + 9 dann, wenn ein Fenster aktiv ist. +10 +11 +12 +13 +14 +15 +Screen 85 not modified + 0 \ Handle all events 24aug86we + 1 + 2 Tabelle der m”glichen Events (werden als gesetztes Bit gemeldet) + 3 in der Reihenfolge ihrer Priorit„t, sonst kommt z.B. der Timer + 4 immer + 5 + 6 und der zugeh”rigen Funktionen + 7 + 8 + 9 Das ist der Event-Handler +10 gemeldeter Event wird mit Liste verglichen (Priorit„t !!) +11 und die entsprechende Event-Aktion ausgefhrt. +12 +13 +14 +15 +Screen 86 not modified + 0 \ Change mouse-movement Vector 17aug86we + 1 + 2 Variable, um den alten Mausvektor zu speichern. + 3 + 4 Die neue Mausroutine soll zus„tzlich das Flag ?mouse setzen, + 5 wenn die Maus bewegt wurde. So wird die Maus bei jedem Tasten- + 6 druck ausgeschaltet und erst wieder eingeschaltet bei Bewegung. + 7 Schick, gell?! + 8 Aus Geschwindigkeitsgrnden in Assembler + 9 +10 „ndert den Mausvektor. +11 +12 Mausvektor auf neuen Wert, alter Wert nach savevec. +13 Mausvektor auf alten Wert (muž unbedingt ausgefhrt werden, das +14 Betriebssystem erledigt das beim Verlassen von FORTH nicht !! +15 resetmousevec l”st das deffered word in done auf. +Screen 87 not modified + 0 \ The Editor's LOOP 30aug86we + 1 + 2 ediloop r„umt den Returnstack auf, falls mit abort" abgebrochen. + 3 Das ist die Endlos-Schleife, die erst verlassen wird, wenn + 4 das Flag fr UNTIL durch done gesetzt wird. + 5 + 6 Fehlerpiep, nur einmal ausfhren, sonst klingelts dauernd. + 7 + 8 Errorhandler fr Editor + 9 falls Fehlermeldung bereits erfolgt, sofort nach ediloop +10 piepen, 'work vorbereiten +11 in der Statuszeile rechts Fehlertext ausgeben, soweit Platz ist +12 und Rcksprung in ediloop ; +13 +14 +15 +Screen 88 not modified + 0 \ Installing the Editor 26oct86we + 1 + 2 Alle Routinen in der GEM-Library sind so geschrieben, daž sie + 3 implizit auf eine Variable grhandle zurckgreifen. Dies + 4 vereinfacht die Parameterbergabe erheblich. + 5 Sollen verschiedene Grafik-Applikationen aktiviert werden, darf + 6 trotzdem nur eine Appliktion angemeldet werden. Dies geschieht + 7 bereits beim Laden des FORTH-Systems. + 8 Beim Laden eines Resource-Files mit rsrc_load wird die Adresse + 9 der zugeh”rigen Baumstruktur im Global-Array unter ap_ptree +10 abgelegt. Diese Adresse kann man zum Umschalten auf verschie- +11 dene Resources benutzen. +12 Wenn PAD sich ver„ndert hat (durch neue Worte oder forget) +13 sind Find- und Insert-Buffer verschoben und mssen neu initia- +14 lisiert werden. Ebenso Zeichen und Zeilenbuffer. +15 (findbox wird gel”scht, damit die Findbox initialisiert wird. +Screen 89 not modified + 0 \ Installing the Editor 26oct86we + 1 + 2 initialisiert den Editor beim Aufruf. + 3 Abbruch, wenn kein Platz fr die Editor-Buffer ist (s.u...) + 4 aktuelle Cursorposition merken, Mausvector initialisieren + 5 Buffer bei Bedarf initialisieren + 6 Editor-Resource und Grafik-Handle installieren. + 7 Fenster ”ffnen und Menzeile ausgeben + 8 Errorhandler auf Editor umschalten, alten merken. + 9 +10 +11 ...das Dictionary ist zu voll. Entweder man 'vergižt' einige +12 Worte oder schafft mit z.B. 'save 4 buffers' mehr Raum. Mit +13 BUFFERS l„žt sich die Anzahl der Diskbuffer festlegen. Dabei +14 steht mehr Platz im Dictionary gegen Arbeitskomfort beim Edi- +15 tieren. Beachten Sie auch, daž BUFFERS ein COLD ausfhrt. +Screen 90 not modified + 0 \ Entering the Editor 17aug86we + 1 + 2 Es folgen die Forth-Worte zum Aufruf des Editors. + 3 + 4 Flag entscheidet, ob compiliert werden soll (ldone). + 5 + 6 Screen mit Nummer in scr und Cursor in r# wird aufgerufen. + 7 Diese Systemvariablen werden auch bei Fehlern gesetzt, also + 8 kann man bei einem Compilationsfehler auf den richtigen Screen + 9 gelangen; Cursor steht dann hinter dem Wort, das den Fehler +10 ausgel”st hat. +11 l editiert Screen-Nr. n +12 view erwartet ein Wort und editiert den Screen, auf dem das +13 Wort definiert wurde (s.a. >view) +14 +15 +Screen 91 not modified + 0 \ savesystem for Editor 17aug86we + 1 + 2 Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, + 3 mssen die entsprechenden Parameter ermittelt und in die + 4 beiden Arrays, die fr die Zwischenspeicherung des Bildschirms + 5 verantwortlich sind, gepatched werden. + 6 Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- + 7 halb des Systems liegen. Nur dadurch kann der Bildschirminhalt + 8 so schnell restauriert werden, wenn Alertboxen oder andere + 9 aufgerufen wurden. +10 +11 +12 +13 +14 +15 +Screen 92 not modified + 0 \ savesystem for Editor 30aug86we + 1 + 2 Diese Routine muž beim Start des Systems (!) ausgefhrt werden, + 3 setzt die Variablen fr die GEM-Routinen des Editors + 4 und fr die beiden Speicherdefinitions-Arrays + 5 wird daher nach drvinit gepatched, klinkt sich selbst aus. + 6 + 7 savesystem muž eine Reihe von Variablen zurcksetzen, damit + 8 das System mit 'vernnftigen' Werten hochkommt. + 9 drvinit wird mit edistart gepatched. +10 FORTH-83.SCR als File fr markierten Screen. +11 ge„nderte Bl”cke auf Diskette zurckschreiben +12 und altes savesystem ausfhren. +13 Neues bye muž zus„tzlich ein GREXIT ausfhren. GRINIT bei +14 Neukompilation n”tig wegen GREXIT in BYE . +15 +Screen 93 not modified + 0 \ savesystem for Editor 17aug86we + 1 + 2 Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, + 3 mssen die entsprechenden Parameter ermittelt und in die + 4 beiden Arrays, die fr die Zwischenspeicherung des Bildschirms + 5 verantwortlich sind, gepatched werden. + 6 Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- + 7 halb des Systems liegen. Nur dadurch kann der Bildschirminhalt + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/AtariST/EDWINDOW.FB.src b/sources/AtariST/EDWINDOW.FB.src new file mode 100644 index 0000000..cacb8d9 --- /dev/null +++ b/sources/AtariST/EDWINDOW.FB.src @@ -0,0 +1,306 @@ +Screen 0 not modified + 0 \\ *** EDWINDOW.SCR *** 14sep86we + 1 + 2 Dieses File enth„lt das Editorfenster. Es kann als Beispiel fr + 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 Fr 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 dafr 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 ntzlich, weil man Werte noch sehen kann, +14 die z.B. bei LIST weggescrollt wrden. +15 +Screen 13 not modified + 0 \ Windowcomponents and Windowsize 14sep86we + 1 + 2 Die Bestandteile des Fensters werden einfach aufaddiert und + 3 als Konstante zur Verfgung 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 fr 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 frs 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 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 zurVerfgung, + 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 diff --git a/sources/AtariST/ERRORBOX.FB.src b/sources/AtariST/ERRORBOX.FB.src new file mode 100644 index 0000000..fb89892 --- /dev/null +++ b/sources/AtariST/ERRORBOX.FB.src @@ -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 Drcken von + 8 ausgel”st wird. + 9 Trat der Fehler bei Ausfhrung 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 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 fr ADDSTRING vorbereiten. + 7 Die 3 sorgt fr 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. diff --git a/sources/AtariST/FILEINT.FB.src b/sources/AtariST/FILEINT.FB.src new file mode 100644 index 0000000..23c0828 --- /dev/null +++ b/sources/AtariST/FILEINT.FB.src @@ -0,0 +1,1258 @@ +Screen 0 not modified + 0 \\ *** File-Interface *** 25may86we + 1 + 2 Dieses File enth„lt das File-Interface. + 3 Damit wird der Zugriff auf normale GEM-Dos Files m”glich. Wenn + 4 ein File mit USE benutzt wird, beziehen sich alle Worte, die + 5 mit dem Massenspeicher arbeiten, auf dieses File. Ebenfalls un- + 6 tersttzt das File-Interface Subdirectories, sogar mit mehr + 7 M”glichkeiten als unter GEM-Dos. + 8 + 9 Da es normalerweise im Direktzugriff geladen wird, mssen die +10 View-Felder der Worte anschliežend gepatched werden +11 (s. STARTUP.SCR) +12 +13 +14 +15 +Screen 1 not modified + 0 \ File interface load and patch block 13oct86we + 1 + 2 Onlyforth + 3 + 4 1 3 +thru \ savesystem, always needed + 5 4 $21 +thru \ Fileinterface + 6 + 7 ' (makeview Is makeview + 8 ' remove-files Is custom-remove + 9 ' filer/w Is r/w +10 +11 +12 +13 +14 +15 +Screen 2 not modified + 0 \ File functions for save-system cas20130105 + 1 + 2 : arguments ( n -- ) + 3 depth 1- > abort" not enough Parameters" ; + 4 + 5 | Code (createfile ( C$ -- handle ) + 6 0 # A7 -) move \ normal file, no protection + 7 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + 8 .w $3C # A7 -) move 1 trap 8 A7 addq + 9 D0 SP -) move Next end-code +10 +11 | Code (closefile ( handle -- f ) +12 SP )+ A7 -) move +13 $3E # A7 -) move 1 trap 4 A7 addq +14 D0 SP -) move Next end-code +15 +Screen 3 not modified + 0 \ write into file cas20130105 + 1 + 2 | Code (filewrite ( buff len handle -- n ) + 3 SP )+ D0 move .l D2 clr .w SP )+ D2 move + 4 SP )+ D6 move D6 reg) A0 lea + 5 .l A0 A7 -) move \ buffer adress + 6 D2 A7 -) move \ buffer length + 7 .w D0 A7 -) move \ handle + 8 $40 # A7 -) move \ call WRITE + 9 1 trap $0C # A7 adda +10 D0 SP -) move \ errorflag, num written Bytes +11 Next end-code +12 +13 +14 +15 +Screen 4 not modified + 0 \ save-system cas20130105 + 1 + 2 : save-system save flush \ Filename follows + 3 bl word count dup 0= abort" missing filename" + 4 over + off (createfile dup >r 0< abort" no device " + 5 $601A 0 ! align here $1C - $04 ! 0 , 0 , + 6 0 here r@ (filewrite here - abort" write error" + 7 r> (closefile 0< abort" close error" ; + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 5 not modified + 0 \ disk errors 13oct86we + 1 + 2 Vocabulary Dos Dos also definitions + 3 + 4 | ' 2- Alias body> \ just for style + 5 + 6 + 7 + 8 + 9 +10 | : 2digits ( n -- adr len ) +11 base push decimal extend <# # # #> ; +12 +13 | 0 Constant #adr +14 \ will hold the adr of "00" in following abort" ..." +15 +Screen 6 not modified + 0 \ disk errors cas20130105 + 1 + 2 : .diskerror ( -n -- ) negate + 3 &13 case? abort" disk is proteced" + 4 &33 case? abort" file not found" + 5 &34 case? abort" path not found" + 6 &36 case? abort" access denied" + 7 &37 case? abort" illegal handle#" + 8 &46 case? abort" illegal drive num" + 9 2digits #adr swap cmove +10 true [ here 2+ ( adress of counted string ) ] +11 abort" Dos-Error #00" +12 [ count + 2- ' #adr >body ! ( adr of "00") ] ; +13 +14 : ?diskabort ( -n -- ) dup 0< IF .diskerror THEN drop ; +15 +Screen 7 not modified + 0 \ File control block structure 09sep86we + 1 + 2 | : Fcbyte ( n len -- n' ) \ defining word for fcb contents + 3 Create over c, + does> c@ + ; + 4 + 5 &25 Constant filenamelen \ only SHORT pathes will fit ! + 6 | 0 2 Fcbyte nextfile \ link to next file + 7 filenamelen Fcbyte filename \ name of file + 8 4 Fcbyte filesize \ size in Bytes , low..high + 9 2 Fcbyte filehandle \ handle from GEMdos +10 2 Fcbyte fileno \ fileno. for VIEW +11 Constant b/fcb \ bytes per file +12 +13 : handle ( -- n ) isfile@ filehandle @ ; +14 +15 \ *** nextfile must be the first field ! +Screen 8 not modified + 0 \ position into block 13oct86we + 1 + 2 Code lseek ( d handle n -- d' ) + 3 SP )+ A7 -) move SP )+ A7 -) move .l SP )+ A7 -) move + 4 .w $42 # A7 -) move 1 trap $0A # A7 adda + 5 .l D0 SP -) move Next end-code + 6 + 7 : position ( d handle -- f ) + 8 0 lseek 0< ?exit drop false ; + 9 +10 : position? ( handle -- d ) +11 0 0 rot 1 lseek dup 0< IF ?diskabort THEN ; +12 +13 +14 +15 +Screen 9 not modified + 0 \ read and write a memory area cas20130105 + 1 + 2 Code (fileread ( buff len handle -- n ) + 3 SP )+ D0 move .l D2 clr .w SP )+ D2 move + 4 SP )+ D6 move D6 reg) A0 lea + 5 .l A0 A7 -) move \ buffer adress + 6 D2 A7 -) move \ buffer length + 7 .w D0 A7 -) move \ handle + 8 $3F # A7 -) move \ call READ + 9 1 trap $0C # A7 adda +10 D0 SP -) move \ errorflag or bytes read +11 Next end-code +12 +13 ' (filewrite Alias (filewrite +14 +15 +Screen 10 not modified + 0 \ (open-file setdta 26oct86we + 1 + 2 Code (openfile ( C$ -- handle ) + 3 2 # A7 -) move + 4 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + 5 .w $3D # A7 -) move 1 trap 8 A7 addq + 6 D0 SP -) move Next end-code + 7 + 8 Create dta &44 allot + 9 +10 Code setdta ( addr -- ) +11 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move +12 .w $1A # A7 -) move 1 trap 6 A7 addq Next end-code +13 +14 ' (closefile Alias (closefile +15 ' (createfile Alias (createfile +Screen 11 not modified + 0 \ search for files 03oct86we + 1 + 2 Code search0 ( C$ attr -- f ) \ search for first file + 3 SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea + 4 .l A0 A7 -) move .w $4E # A7 -) move 1 trap 8 A7 addq + 5 D0 SP -) move Next end-code + 6 + 7 Code searchnext ( -- f ) \ search for next file + 8 $4F # A7 -) move 1 trap 2 A7 addq + 9 D0 SP -) move Next end-code +10 +11 +12 +13 +14 +15 +Screen 12 not modified + 0 \ Create a subdir bp 11 oct 86 + 1 + 2 Code (makedir ( C$ -- f ) \ Create a subdir + 3 $39 # D1 move + 4 Label long-adr + 5 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + 6 .w D1 A7 -) move 1 trap 6 A7 addq + 7 D0 SP -) move Next end-code + 8 + 9 Code (setdir ( C$ -- f ) +10 $3B # D1 move long-adr bra end-code +11 +12 +13 +14 +15 +Screen 13 not modified + 0 \ select drive 09sep86we + 1 + 2 Code setdrive ( n -- ) + 3 SP )+ A7 -) move + 4 $0E # A7 -) move 1 trap 4 A7 addq Next end-code + 5 + 6 Code getdrive ( -- n ) + 7 $19 # A7 -) move 1 trap 2 A7 addq + 8 D0 SP -) move Next end-code + 9 +10 Code getdir ( addr n -- f ) \ n is drive, string in addr +11 SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea +12 .l A0 A7 -) move .w $47 # A7 -) move 1 trap 8 A7 addq +13 D0 SP -) move Next end-code +14 +15 +Screen 14 not modified + 0 \ file sizes b30aug86we + 1 + 2 : (capacity ( fcb -- n) \ calculates size in blocks + 3 filesize 2@ 2dup or 0= IF drop exit THEN + 4 b/blk um/mod swap IF 1+ THEN ; \ add 1 block for rest + 5 + 6 | : in-range ( block fcb -- f) \ makes sure, block is in file + 7 (capacity u< not &36 * ; \ Errorcode -&36 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 15 not modified + 0 \ read and write into files bp 11 oct 86 + 1 + 2 | : set-pos ( block handle -- f) + 3 >r b/blk um* r> position ; + 4 + 5 | : fileaccess ( buff block fcb -- buff len handle/ errorcode) + 6 2dup in-range ?dup IF >r 2drop drop r> rdrop exit THEN + 7 filehandle @ under set-pos + 8 ?dup IF >r 2drop r> rdrop exit THEN + 9 b/blk swap ; +10 +11 | : fileread ( buff block fcb -- ff / errorcode ) +12 fileaccess (fileread dup 0> IF drop false THEN ; +13 +14 | : filewrite ( buff block fcb -- ff / errorcode ) +15 fileaccess (filewrite dup 0> IF drop false THEN ; +Screen 16 not modified + 0 \ twiggling the file variables bp 11 oct 86 + 1 + 2 : scan-name ( C$ -- adr len') \ length of "C"-string + 3 $1000 over swap 0 scan drop over - ; + 4 + 5 : .file ( fcb --) \ print only filename + 6 ?dup 0= IF ." DIRECT ! " exit THEN body> >name .name ; + 7 + 8 : .fcb ( fcb -- ) \ print filename + 9 dup filehandle @ 2 .r dup filesize 2@ 6 d.r 3 spaces +10 dup .file 2 spaces filename scan-name type ; +11 +12 : !files ( fcb -- ) \ set file and isfile +13 dup isfile ! fromfile ! ; +14 +15 +Screen 17 not modified + 0 \ PATHes bp 11 oct 86 + 1 + 2 | &30 Constant pathlen \ max. len of all pathes + 3 + 4 Variable pathes pathlen allot \ counted string of pathes + 5 pathes off + 6 + 7 : pathes? ( -- ) \ print a list of the pathes + 8 cr 3 spaces pathes count type ; + 9 +10 : setpath ( adr len --) \ set's the list of pathes +11 pathlen min pathes place +12 Ascii ; pathes count + c! pathes c@ 1+ pathes c! ; +13 +14 \\ PATH : see elsewhere in this file +15 +Screen 18 not modified + 0 \ search for files bp 11 oct 86 + 1 + 2 Variable workspace &64 allot \ place for c$ + 3 + 4 | : try.path ( adr len fcb attr -- f ) + 5 2swap workspace swap 2dup + >r move + 6 swap filename r> filenamelen cmove + 7 workspace swap search0 0= ; + 8 + 9 | : makec$ ( adr len -- c$ ) \ make adr len to a c$ +10 workspace swap 2dup + >r move +11 r> off ( make a c$ ) workspace ; +12 +13 +14 +15 +Screen 19 not modified + 0 \ " bp 11 oct 86 + 1 + 2 | Variable sfile \ "dirty" variable + 3 | 7 Constant defaultattr \ find all filetypes + 4 + 5 | : path@ ( adr len -- adr len1 adr len2) \ isolate a path + 6 Ascii ; skip 2dup 2dup Ascii ; scan nip - ; + 7 + 8 : (searchfile ( fcb -- ff/ C$ f) \ search for file in path + 9 sfile ! pathes count \ and in act. directory +10 BEGIN path@ sfile @ defaultattr try.path +11 IF 2drop workspace true exit THEN +12 Ascii ; scan dup 0= UNTIL nip ; +13 +14 : searchfile ( fcb -- C$ ) \ file was found in path +15 (searchfile ?exit -&33 ?diskabort ; +Screen 20 not modified + 0 \ open a file, filer/w b26oct86we + 1 + 2 | : @length ( -- d) dta &26 + 2@ ; + 3 | : copylength ( fcb --) @length rot filesize 2! ; + 4 + 5 : (open ( fcb --) \ open file + 6 dup filehandle @ IF drop exit THEN + 7 dta setdta dup searchfile over copylength (openfile + 8 dup ?diskabort swap filehandle ! ; + 9 +10 Forth definitions +11 +12 : capacity ( -- n) +13 isfile@ ?dup IF dup (open (capacity exit THEN blk/drv ; +14 +15 Dos definitions +Screen 21 not modified + 0 \ filer/w, Create a file bp 11 oct 86 + 1 + 2 : filer/w ( buff block fcb f -- f) + 3 over 0= IF STr/w exit THEN + 4 over (open + 5 IF fileread ELSE filewrite THEN dup ?diskabort ; + 6 + 7 : createfile ( fcb --) \ create a file in fcb + 8 dup filename (createfile dup ?diskabort + 9 over filehandle ! 0 0 rot filesize 2! +10 offset off ; +11 +12 +13 +14 +15 +Screen 22 not modified + 0 \ store names for files bp 11 oct 86 + 1 + 2 | : !name ( adr len --) \ store name in record + 3 2dup erase >r name count + 4 dup r> < not abort" string too long" + 5 >r swap r> cmove ; + 6 + 7 : !fcb ( fcb --) \ next word is filename + 8 dup filehandle off filename filenamelen !name ; + 9 +10 +11 +12 +13 +14 +15 +Screen 23 not modified + 0 \ print dta and directory 26oct86we + 1 + 2 | : .dtaname ( addr --) \ addr is addr of name + 3 dup BEGIN dup c@ ?dup WHILE emit 1+ REPEAT + 4 - &15 + spaces ; + 5 + 6 : .dta ( --) \ print contents of dta + 7 cr dta &21 + c@ $10 and + 8 IF Ascii D ELSE bl THEN emit space + 9 dta &30 + .dtaname @length &10 d.r ; +10 +11 : (dir ( attr adr len --) \ given a match string +12 makec$ swap dta setdta search0 +13 BEGIN 0= WHILE stop? 0= WHILE .dta searchnext REPEAT ; +14 +15 +Screen 24 not modified + 0 \ primitives for fcb's bp 18May86 + 1 + 2 User file-link file-link off \ list thru files + 3 + 4 | : #file ( -- n) \ View number of next file + 5 file-link @ dup IF fileno @ THEN 1+ ; + 6 + 7 + 8 : forthfiles ( --) \ print a list of : + 9 file-link @ \ forthword,filename,handle,len +10 BEGIN dup WHILE +11 cr dup .fcb @ stop? UNTIL drop ; +12 +13 +14 +15 +Screen 25 not modified + 0 \ Close a file bp 18May86 + 1 + 2 | ' save-buffers >body $C + @ Alias backup + 3 + 4 | : filebuffer? ( fcb -- fcb bufaddr/flag) + 5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + 6 + 7 | : flushfile ( fcb -- ) \ flush file buffers + 8 BEGIN filebuffer? ?dup WHILE + 9 dup backup emptybuf REPEAT drop ; +10 +11 : (close ( fcb --) \ close file in fcb +12 dup flushfile +13 filehandle dup @ ?dup 0= IF drop exit THEN swap off +14 (closefile -$41 case? ?exit ?diskabort ; +15 +Screen 26 not modified + 0 \ Create fcb's bp 11 oct 86 + 1 + 2 Forth definitions + 3 + 4 + 5 : File ( -- ) \ Create a fcb + 6 Create here b/fcb allot dup b/fcb erase + 7 #file over fileno ! + 8 file-link @ over file-link ! swap ! + 9 does> !files ; +10 +11 : direct 0 !files ; \ switch to direct access +12 +13 +14 +15 +Screen 27 not modified + 0 \ flush buffers & misc. bp 8jun86 + 1 + 2 : flush ( --) flush file-link + 3 BEGIN @ ?dup WHILE dup (close REPEAT ; + 4 + 5 : file? isfile@ .file ; \ print current file + 6 + 7 : list ( n --) + 8 3 spaces file? list ; + 9 +10 : path ( -- ) \ this is a smart word ! +11 name count +12 dup 0= IF 2drop pathes? exit THEN +13 dup 1 = IF over c@ Ascii ; = +14 IF 2drop pathes off exit THEN THEN +15 setpath ; +Screen 28 not modified + 0 \ File Interface User words 26oct86we + 1 + 2 | : isfile? ( adr -- adr f) \ is adr a fcb ? + 3 file-link BEGIN @ dup 0= ?exit 2dup 2- = UNTIL drop true ; + 4 + 5 | : ?isfile@ isfile@ body> + 6 isfile? 0= abort" not in direct mode" >body ; + 7 + 8 : open ?isfile@ (open offset off ; + 9 : close ?isfile@ (close ; +10 : assign close isfile@ !fcb open ; +11 : make ?isfile@ dup !fcb createfile ; +12 +13 : use >in @ name find \ create a fcb if not present ! +14 IF isfile? IF execute drop exit THEN THEN drop +15 dup >in ! File dup >in ! ' execute >in ! assign ; +Screen 29 not modified + 0 \ File Interface User words bp 11 oct 86 + 1 + 2 : makefile >in @ file dup >in ! ' execute >in ! make ; + 3 + 4 : from isfile push use ; \ sets only fromfile + 5 : loadfrom ( n --) \ load 1 scr from file + 6 isfile push fromfile push use load close ; + 7 : include 1 loadfrom ; + 8 + 9 : eof ( -- f) \ end of file ? +10 isfile@ dup filehandle @ position? +11 rot filesize 2@ d= ; +12 +13 : files $10 " *.*" count (dir ; +14 : files" $10 Ascii " word count (dir ; +15 +Screen 30 not modified + 0 \ extend files bp 11 oct 86 + 1 + 2 | : >fileend isfile@ filesize 2@ handle position + 3 ?diskabort ; + 4 + 5 | : addsize isfile@ filesize dup 2@ b/blk 0 d+ rot 2! ; + 6 + 7 | : addblock ( n --) \ add block n to file + 8 buffer b/blk 2dup bl fill >fileend handle (filewrite + 9 dup ?diskabort b/blk - +10 IF close abort" Disk voll" THEN addsize ; +11 +12 : (more ( n --) +13 capacity swap bounds ?DO I addblock LOOP ; +14 +15 : more ( n --) ?isfile@ (open (more close ; +Screen 31 not modified + 0 \ make,kill and set directories bp 11 oct 86 + 1 + 2 | : dir$ ( -- adr ) name count makec$ ; + 3 + 4 : makedir dir$ (makedir ?diskabort ; + 5 + 6 : dir name count + 7 0 case? IF getdrive 2dup 1+ getdir ?diskabort + 8 cr 3 spaces Ascii A + emit ." :" + 9 scan-name type exit THEN +10 makec$ (setdir ?diskabort ; +11 +12 | : driveset Create c, Does> c@ setdrive ; +13 0 driveset A: 1 driveset B: 2 driveset C: 3 driveset D: +14 +15 +Screen 32 not modified + 0 \ words for VIEWing bcas20130105 + 1 + 2 | $200 Constant viewoffset \ max. &512 kbyte long files + 3 + 4 | : (makeview ( -- n) \ calc. view field for a name + 5 blk @ dup 0= ?exit + 6 loadfile @ ?dup IF fileno @ viewoffset * + THEN ; + 7 + 8 : (view ( blk -- blk') \ select file and leave block + 9 dup 0= ?exit +10 viewoffset u/mod file-link +11 BEGIN @ dup WHILE 2dup fileno @ = UNTIL +12 dup searchfile drop \ file not found : abort +13 !files drop ; +14 +15 +Screen 33 not modified + 0 \ ugly FORGETing of files bp 11 oct 86 + 1 + 2 : remove? ( dic symb addr -- dic symb addr f) + 3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; + 4 + 5 | : remove-files ( dic symb -- dic symb) \ flush files ! + 6 isfile @ remove? nip IF 0 !files THEN + 7 fromfile @ remove? nip IF fromfile off THEN + 8 file-link + 9 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT +10 file-link remove ; +11 +12 +13 +14 +15 +Screen 34 not modified + 0 \ convey for files bp 11 oct 86 + 1 + 2 | : togglefiles ( -- ) \ changes isfile and fromfile + 3 isfile@ fromfile @ isfile ! fromfile ! ; + 4 + 5 : convey ( [blk1 blk2] [to.blk --) + 6 3 arguments >r 2dup swap - >r + 7 togglefiles dup capacity 1- > + 8 togglefiles r> r@ + capacity 1- > + 9 or abort" wrong range!" +10 r> convey ; +11 +12 +13 +14 +15 +Screen 35 not modified + 0 \ print a list of all blocks bp 9Apr86 + 1 + 2 : .blocks + 3 prev BEGIN @ ?dup WHILE stop? abort" stopped" + 4 cr dup u. dup 2+ @ dup 1+ + 5 IF ." Block :" over 4+ @ 5 .r + 6 ." File : " [ Dos ] .file + 7 dup 6 + @ 0< IF ." updated" THEN + 8 ELSE ." Block empty" drop THEN REPEAT ; + 9 +10 +11 +12 +13 +14 +15 +Screen 36 not modified + 0 \ create a file of direct blocks bcas20130105 + 1 + 2 Dos also + 3 + 4 | File outfile + 5 + 6 : blocks>file ( from to -- ) \ name of file follows + 7 ?isfile@ -rot outfile make + 8 1+ swap ?DO I over (block b/blk handle (filewrite + 9 b/blk - abort" write error" +10 LOOP close isfile ! ; +11 +12 +13 +14 +15 +Screen 37 not modified + 0 bp 4oct86 + 1 + 2 + 3 + 4 + 5 + 6 MAKEVIEW erzeugt aus ISFILE und BLK das Viewfeld + 7 CUSTOM-REMOVE erlaubt das FORGETten von eig. Datenstrukturen + 8 R/W setzt Forthbl”cke in Disksektoren um .... + 9 +10 +11 +12 +13 +14 +15 +Screen 38 not modified + 0 13oct86we + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 39 not modified + 0 13oct86we + 1 + 2 ARGUMENTS liefert etwas Sicherheit ... + 3 + 4 + 5 (CREATEFILE erzeugt ein File, dessen Namen in C$ steht, im + 6 aktuellen oder im durch den Pfadnamen angegebenen Directory. + 7 HANDLE ist die Handle des Files oder ein Fehlerflag. + 8 Es wird immer ein "ganz normales" File erzeugt. + 9 +10 (CLOSEFILE Schliežt das File mit der Handle HANDLE. Dabei +11 sollten alle TOS-Buffer zurckgeschrieben und das Directory +12 gesichert werden. F ist ein Fehlerflag. Die Handle ist +13 anschliežend ungltig. +14 +15 +Screen 40 not modified + 0 13oct86we + 1 + 2 (FILEWRITE schreibtLEN Bytes in das File HANDLE. Die Bytes + 3 werden ab Adresse BUFF im Speicher geholt. + 4 N ist die Zahl der geschriebenen Bytes oder eine + 5 Fehlernummer, wenn N zwischen -66 und -1 liegt. + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 41 not modified + 0 cas20130105 + 1 + 2 SAVE-SYSTEM speichert ein FORTH-System im aktuellen Zustand auf + 3 Diskette ab. + 4 + 5 Voodoo-Code fr den GEMDOS-Fileheader; keine Relokatinsinfos + 6 + 7 Mit SAVE-SYSTEM lassen sich eigene Arbeitssysteme oder auch + 8 Applikationen erstellen, denen man ihre FORTH-Herkunft nicht + 9 mehr ansieht. +10 Stellen Sie ein System nach Ihren Wnschen zusammen, und spei- +11 chern Sie es dann mit SAVE-SYSTEM MYPROG.PRG ab. +12 +13 +14 +15 +Screen 42 not modified + 0 13oct86we + 1 + 2 DOS enth„lt die "unwichtigen" Worte des + 3 Fileinterfaces + 4 + 5 BODY> ( cfa -- pfa ) Kompilationsadresse in + 6 Parameterfeldadresse umwandeln ... + 7 + 8 + 9 +10 Diese Worte werden fr die ble Patcherei in .diskabort benutzt. +11 Nur so kann die Dos-Fehlernummer in der abort" -Meldung unter- +12 gebracht werden. Bei einer Ausgabe mit . w„re keine Umleitung +13 ber ERRORHANDLER m”glich. +14 +15 +Screen 43 not modified + 0 13oct86we + 1 + 2 -n ist die Fehlernummer; es wird der zugeh”rige Text ausgedruckt + 3 + 4 + 5 + 6 + 7 + 8 + 9 Ist die Fehlernummer nicht in den CASE-Anweisungen zu finden, +10 wird Dos-Error # ausgegeben. Die Fehlernummer wird dann in +11 den abort" String gepatched. Dieses Verfahren ist zwar „užerst +12 h„žlich, nichtsdestoweniger aber sehr effektiv. +13 +14 Prft, ob ein Fehler vorliegt und druckt ggf. den Text aus und +15 ABORTed anschliežend. +Screen 44 not modified + 0 bp 4oct86 + 1 + 2 Definierendes Wort fr die Benamsung der Felder eines + 3 File control blocks ( FCB bzw. FILE in den Stackkommentaren) + 4 + 5 + 6 Zeiger auf den n„chsten FCB + 7 Platz fr max. 24 Zeichen fr den TOS-Filenamen + 8 L„nge des Files in Bytes + 9 Handlenummer, die das TOS beim ™ffnen eines Files liefert. +10 Eine eigene Nummer, die in das VIEW-Feld eingetragen wird. +11 L„nge eines FCB wird auch berechnet... +12 +13 Liefert die Handle des aktuellen Files. Null, falls das +14 File nicht offen . +15 +Screen 45 not modified + 0 bp 4oct86 + 1 + 2 LSEEK N ist ein Flag, das angibt, ob relativ zum + 3 Fileanfang, zum Fileende oder zur aktuellen Position im File + 4 positioniert werden soll. HANDLE ist die Handle des Files, in + 5 dem positioniert wird und D die neue Position im File. + 6 D' ist die neue Position. + 7 POSITION positioniert auf das Byte d, gez„hlt vom Anfang + 8 des Files mit der Handle HANDLE . + 9 +10 POSITION? liefert die Position des zuletzt gelesenen, +11 geschriebenen oder mit POSITION bzw. LSEEK angew„hlten Bytes. +12 +13 +14 +15 +Screen 46 not modified + 0 13oct86we + 1 + 2 FILEREAD liest LEN Bytes aus dem File HANDLE. Die Bytes + 3 werden ab Adresse BUFF im Speicher abgelegt. + 4 N ist die Zahl der gelesenen Bytes oder eine Fehlernummer, + 5 wenn N zwischen -66 und -1 liegt. + 6 + 7 + 8 + 9 +10 +11 +12 +13 Das headerlose (FILEWRITE bekommt nun einen Header im Vocabulary +14 Dos. +15 +Screen 47 not modified + 0 26oct86we + 1 + 2 OPENFILE ™ffnet ein File. Der Name steht im String C$. + 3 C$ ist durch ein $00-Byte begrenzt. HANDLE ist die diesem + 4 File zugeordnete Handle oder eine Fehlernummer. + 5 + 6 + 7 + 8 DTA ist ein 44 Byte grožer Buffer, in dem einige + 9 Fileinformationen vom GEMDOS gehalten werden. +10 SETDTA ADDR ist die Adresse der 'disk transfer area'. +11 +12 +13 +14 (CLOSEFILE und (CREATEFILE erhalten Header im Vocabulary Dos. +15 +Screen 48 not modified + 0 13oct86we + 1 + 2 SEARCH0 SEARCH0 sucht ein File. C$ ist der Name des File + 3 mit Pfad usw. . C$ wird, wie immer, durch ein $00-Byte + 4 begrenzt. ATTR ist ein Attributwort, das z.B. bestimmt, ob + 5 auch Subdirectories gefunden werden. F ist ein Fehlerflag. + 6 Die DTA enth„lt anschliežend Filenamen, -l„nge usw. + 7 SEARCHNEXT sucht das n„chste File mit dem bei SEARCH0 + 8 angegeben Namen... + 9 +10 +11 +12 +13 +14 +15 +Screen 49 not modified + 0 13oct86we + 1 + 2 (MAKEDIR erzeugt „hnlich (CREATEFILE ein Subdirectory. + 3 C$ ist der Name des Directories, F ist ein Fehlerflag. + 4 + 5 + 6 + 7 + 8 + 9 (SETDIR setzt das durch C$ angegeben Subdirectory als +10 das "Aktuelle", auf das sich alle Such- und "Erzeugungs-" +11 operationen ohne eigenen Pfadnamen beziehen. +12 +13 +14 +15 +Screen 50 not modified + 0 bp 4oct86 + 1 + 2 SETDRIVE N ist die Nummer des aktuellen Laufwerkes, auf + 3 das sich alle Operationen ohne eigenen Pfadnamen beziehen. + 4 Vergleiche (SETDIR. Laufwerk A: hat die Nummer 0 ! + 5 + 6 GETDRIVE N ist die Nummer des bei SETDRIVE genannten + 7 Laufwerks. + 8 + 9 +10 GETDIR Das durch (SETDIR gesetzte Subdirectory wird +11 ab Adresse ADDR als C$ im Speicher abgelegt. N ist die Nummer +12 des Laufwerkes ( Laufwerk A: hat die Nummer 1 !!!! ), denn +13 verschiedene Laufwerke k”nnen verschiedene aktuelle Sub- +14 directories haben. +15 +Screen 51 not modified + 0 bp 4oct86 + 1 + 2 (CAPACITY FCB ist die Adresse des FCB des Files, von + 3 dem die L„nge in Blocks bestimmt werden soll. N ist dann + 4 die Zahl der Bl”cke in diesem File. + 5 + 6 IN-RANGE prft, ob sich ein Block mit der Nummer BLOCK + 7 im File FCB befindet. Ist das nicht der Fall, wird als + 8 Fehlernummer -36 geliefert. Siehe auch ?DISKABORT + 9 +10 +11 +12 +13 +14 +15 +Screen 52 not modified + 0 13oct86we + 1 + 2 SET-POS positioniert im File mit der Handle HANDLE auf + 3 den Anfangs des Blocks BLOCK. F ist ein Fehlerflag. + 4 + 5 FILEACCESS wird in FILEREAD und FILEWRITE ben”tigt. + 6 + 7 + 8 + 9 +10 +11 FILEREAD liest den Block BLOCK an die Adresse BUFF aus +12 dem File FCB. Hinterl„žt eine Fehlernummer. +13 +14 FILEWRITE berschreibt den Block BLOCK mit den Daten ab +15 Adresse BUFF im File FCB. Hinterl„žt eine Fehlernummer. +Screen 53 not modified + 0 bp 4oct86 + 1 + 2 SCAN-NAME 'LEN ist die L„nge eines durch ein $00-Byte + 3 begrenzten C$. + 4 + 5 .FILE druckt den Forthnamen des Files mit der Adresse + 6 FCB. + 7 + 8 .FCB druckt Forthnamen, TOS-Namen, Handle und L„nge + 9 des Files mit der Adresse FCB aus. +10 +11 !FILES setzt die Variable ISFILE und FROMFILE (darin +12 steht das File, aus dem bei COPY und CONVEY gelesen wird) +13 auf das File mit der Adresse FCB. +14 +15 +Screen 54 not modified + 0 bp 4oct86 + 1 + 2 PATHES Hier ist Platz fr den durch SETPATH angegeben + 3 String, der die Namen der zu durchsuchenden Laufwerke und + 4 Directories enth„lt. + 5 PATHES? Druckt den Inhalt von PATHES aus. + 6 + 7 SETPATH Setzt PATHES auf den String ab der Adresse ADR, + 8 dessen L„nge LEN ist. Anschliežend wird noch ein ; angefgt, + 9 um auch den letzten Path korrekt zu beenden. +10 +11 +12 +13 +14 +15 +Screen 55 not modified + 0 bp 4oct86 + 1 + 2 WORKSPACE Hier wird aus File- und Pathnamen ein C$ + 3 zusammengebastelt. + 4 + 5 TRY.PATH ADR und LEN enthalten den Pfadnamen (aus + 6 PATHES mit PATH@ extrahiert), FCB ist die Adresse des Files + 7 und ATTR ein Attribut (siehe SEARCH0). Aus Pfadnamen und FCB + 8 wird in WORKSPACE ein String zusammengebastelt, der dann mit + 9 SEARCH0 gesucht wird. F gibt an, ob wir erfolgreich waren. +10 +11 MAKEC$ konvertiert einen durch ADR und LEN definierten +12 String in einen C$ (durch ein $00-Byte begrenzt) und +13 hinterl„žt dessen Adresse. +14 +15 +Screen 56 not modified + 0 bp 4oct86 + 1 + 2 SFILE enth„lt die Adresse des FCB des gesuchten Files. + 3 DEFAULTATTR enstpricht "Suche alle Files, egal welches ATTR" + 4 + 5 PATH@ extrahiere aus dem noch nicht zum Suchen verwen- + 6 deten Teil von PATHES, der durch ADR und LEN angegeben wird, + 7 den n„chsten zu durchsuchenden Pfad ADR LEN1. + 8 (SEARCHFILE durchsucht alle in PATHES stehenden Pfade nach + 9 dem in FCB stehenden Filenamen. Aufgeh”rt wird, wenn das File +10 gefunden wurde oder alle Pfade durchsucht wurden. +11 Am Schluž wird auch der leere Pfad (L„nge Null) durchsucht, +12 der dem aktuellen Directory (siehe SETDIR) entspricht. +13 +14 SEARCHFILE Sucht das File FCB in allen Pfaden und im akt. +15 Directory. Hinterlassen wird der vollst„ndige Pfad des Files. +Screen 57 not modified + 0 bp 4oct86 + 1 + 2 @LENGTH holt die L„nge des zuletzt gefundenen Files + 3 COPYLENGTH kopiert die L„nge des zuletzt gefundenen Files + 4 in den Fcb FCB. + 5 (OPEN ”ffnet das durch FCB angegebene File + 6 und speichert LEN dort die Handle und L„nge. Dazu muž es + 7 natrlich erst gesucht werden, denn nur dann steht die L„nge + 8 in der DTA. + 9 +10 +11 +12 CAPACITY N ist die Zahl der Bl”cke im aktuellen (durch +13 ISFILE angegeben) File. Ist ISFILE Null, so wird die Kapazit„t +14 der Diskette im Direktzugriff angegeben. +15 +Screen 58 not modified + 0 bp 4oct86 + 1 + 2 FILER/W ist das zentrale Wort fr den Zugriff auf Files. + 3 BUFF ist die Adresse des Blocks BLOCK im Speicher, FCB die + 4 Nummer des Files (0 heižt Direktzugriff) und R/W gibt an, in + 5 welcher Richtung die Daten zu transportieren sind. + 6 F ist true, falls ein Fehler auftrat. + 7 + 8 CREATEFILE erzeugt ein File, dessen Name im Fcb FCB steht. + 9 Handle und Filel„nge werden korrigiert. +10 +11 +12 +13 +14 +15 +Screen 59 not modified + 0 bp 4oct86 + 1 + 2 !NAME speichert einen auf !NAME folgenden String + 3 ab Adresse ADR mit maximaler L„nge LEN im Speicher ab. + 4 Der String wird durch $00-Bytes begrenzt. + 5 + 6 + 7 !FCB speichert einen auf !FCB folgenden String im + 8 Fcb FCB ab. Die Handle wird gel”scht, weil das + 9 so zugewiesene File noch nicht ge”ffnet worden ist. +10 +11 +12 +13 +14 +15 +Screen 60 not modified + 0 13oct86we + 1 + 2 .DTANAME druckt den Filenamen, er ab Adresse d in der DTA + 3 steht, linksbndig in einem Feld der Breite 15 aus. + 4 + 5 + 6 .DTA druckt den Inhalt der DTA formattiert aus. + 7 Zun„chst wird ein "D" ausgegeben, das anzeigt, ob es sich + 8 um ein Subdirectory handelt, anschliežend der Name gefolgt + 9 von der L„nge des Files. +10 +11 (DIR druckt alle Files aus, auf die der String ADR +12 LEN und das Attribut ATTR "passt". Die Ausgabe kann wie +13 blich angehalten und abgebrochen werden. +14 +15 +Screen 61 not modified + 0 bp 4oct86 + 1 + 2 FILE-LINK enth„lt einen Zeiger auf den FCB des + 3 zuletzt definierten Files. + 4 #FILE N ist die Nummer, die in das Viewfeld des + 5 n„chsten zu definierenden Files eingetragen werden soll. + 6 + 7 + 8 FORTHFILES druckt die Forth- und TOS-Namen mit Handle und + 9 L„nge aller definierten Files aus. Dazu wird FILE-LINK +10 benutzt. Die Ausgabe kann wie blich angehalten oder beendet +11 werden. +12 +13 +14 +15 +Screen 62 not modified + 0 bp 4oct86 + 1 + 2 FILEBUFFER? guckt nach, ob zu dem File FCB noch ein Block- + 3 puffer exisitiert. Liefert false, falls keiner vorhanden ist. + 4 + 5 FLUSHFILE sichert alle zum File FCB geh”renden Blockpuffer + 6 auf dem Massenspeicher und l”scht sie anschliežend. + 7 + 8 + 9 (CLOSE sichert alle Blockpuffer, schliežt anschliežend +10 das File, falls es nicht schon geschlossen war und ignoriert +11 den Fehler mit der Nummer -65, weil der so oft auftritt... +12 +13 +14 +15 +Screen 63 not modified + 0 bp 4oct86 + 1 + 2 FILE ist ein definierendes Wort, daž einen FCB + 3 erzeugt. Wird der FCB sp„ter ausgefhrt, so tr„gt er sich + 4 als aktuelles File und als FROMFILE ein. + 5 + 6 + 7 + 8 DIRECT ein "spezieller FCB" fr den Direktzugriff. + 9 Der Direktzugriff ist immer dann interessant, wenn man +10 einen Diskmonitor braucht, ihn aber gerade verliehen hat... +11 +12 +13 +14 +15 +Screen 64 not modified + 0 bp 4oct86 + 1 + 2 FLUSH schliežt zus„tzlich alle Files.. + 3 + 4 + 5 FILE? druckt den Namen des aktuellen Files aus. + 6 + 7 LIST druckt zus„tzlich den Filenamen aus... + 8 + 9 +10 PATH druckt PATHES aus oder +11 l”scht PATHES oder +12 setzt PATHES auf einen anderen String. +13 +14 +15 +Screen 65 not modified + 0 13oct86we + 1 + 2 ISFILE? F ist wahr, falls ADR die Kompilationsadresse + 3 eines FCB ist (also durch FILE erzeugt wurde...). + 4 + 5 ?ISFILE@ steht in ISFILE berhaupt ein File ? + 6 + 7 OPEN ”ffnet das aktuelle File. + 8 CLOSE schliežt es. + 9 ASSIGN Anderer Filename in aktuellen FCB eintragen. +10 MAKE Neu erzeugter Filename in aktuellen FCB.. +11 +12 USE Erzeuge FCB (mit Filenamen !), falls Name nicht +13 schon vorhanden. Wenn Name vorhanden, prfe ob es File ist. +14 Trage dann FCB in ISFILE ein. +15 +Screen 66 not modified + 0 13oct86we + 1 + 2 MAKEFILE erzeugt FCB und File gleichen Namens. + 3 + 4 FROM setzt FROMFILE fr COPY und CONVEY + 5 LOADFROM l„dt den Screen N vom File, dessen Name auf + 6 LOADFROM folgt. z.B. 1 loadfrom forth_83.scr + 7 INCLUDE l„dt den Loadscreen des Files... + 8 + 9 EOF F ist wahr, falls wir am Ende des Files +10 angekommen sind. +11 +12 +13 FILES liefert Inhaltsverzeichnis des akt. Directories. +14 FILES" erlaubt Pfad- und Filenamen +15 +Screen 67 not modified + 0 bp 4oct86 + 1 + 2 >FILEEND springe ans Ende des aktuellen Files + 3 + 4 + 5 ADDSIZE erh”ht die L„ngenangabe im aktuellen FCB um + 6 1024 Bytes. + 7 ADDBLOCK fgt den Block N am Fileende an. + 8 Aužerdem wird ein leerer Buffer mit dieser Nummer angelegt. + 9 +10 +11 +12 (MORE fgt n Bl”cke am Fileende an. +13 +14 MORE Wie (MORE, jedoch etwas Sicherheit.. +15 +Screen 68 not modified + 0 13oct86we + 1 + 2 DIR$ ADR ist die Adresse eines auf DIR$ folgenden C$. + 3 + 4 MAKEDIR erzeugt ein Directory mit dem folgenden Namen.. + 5 + 6 DIR gibt, falls kein Name folgt, das aktuelle Lauf- + 7 werk und Subdirectory aus. Folgt ein Name, so wird er als + 8 das neue aktuelle Directory an das TOS bergeben. + 9 +10 +11 +12 A: B: C: D: Kurzformen fr SETDRIVE. +13 +14 +15 +Screen 69 not modified + 0 13oct86we + 1 + 2 VIEWOFFSET teilt das 16-Bit Viewfeld in ein Feld mit der + 3 Filenummer und ein Feld mit der Blocknummer. Die unteren 9 + 4 Bits sind fr die Blocknummer reserviert. + 5 (MAKEVIEW macht aus BLK und der Nummer des geladenen Files + 6 LOADFILE eine 16-Bit Zahl, die von CREATE dann als Viewfeld + 7 hinterlegt wird. + 8 (VIEW zerlegt den Inhalt BLK eines Viewfeldes in + 9 Filenummer und Blocknummer BLK' . Der zur Filenummer +10 geh”rende FCB wird gesucht, und falls gefunden, in ISFILE +11 und FROMFILE eingetragen. Kann kein FCB gefunden werden, +12 so wird eine Fehlermeldung ausgegeben. +13 +14 +15 +Screen 70 not modified + 0 bp 4oct86 + 1 + 2 REMOVE? DIC (SYMB) ist die Adresse im Dictionary (HEAP), + 3 oberhalb (unterhalb, der Heap w„chst von oben nach unten !) + 4 derer alle Worte vergessen werden mssen. F gibt an, ob + 5 ADDR innerhalb des zu vergessenden Intervalls liegt. + 6 + 7 REMOVE-FILES guckt nach, ob ISFILE oder FROMFILE vergessen + 8 werden. Ist das der Fall, so werden sie auf den Direktzugriff + 9 umgeschaltet. +10 Anschliežend werden alle zu vergessenden Files geschlossen +11 und aus der Liste aller Files FILE-LINK entfernt. +12 +13 +14 +15 +Screen 71 not modified + 0 bp 4oct86 + 1 + 2 TOGGLEFILES vertauscht ISFILE und FROMFILE. + 3 + 4 + 5 CONVEY prft, ob die zu bewegenden Bl”cke vorhanden + 6 sind und bewegt sie ggf. + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 72 not modified + 0 13oct86we + 1 + 2 .BLOCKS listet den Inhalt der Blockpuffer auf. + 3 Angegeben werden Adresse, Blocknummer und Filename sowie, + 4 ob der Block geUPDATEd wurde. + 5 + 6 Bei der Entwicklung des Fileinterfaces war das ein ntzliches + 7 Hilfsmittel. + 8 + 9 +10 Dieser und der n„chste Screen werden normalerweise vom Load- +11 screen nicht mitkompiliert. +12 +13 +14 +15 +Screen 73 not modified + 0 13oct86we + 1 + 2 + 3 + 4 + 5 + 6 Mit BLOCKS>FILE l„žt sich eine Folge von Diskettenbl”cken in + 7 einem File ablegen. Damit k”nnen Disketten, die bisher im + 8 Direktzugriff benutzt worden sind, auf das Fileinterface um- + 9 gestellt werden. +10 +11 +12 +13 +14 +15 diff --git a/sources/AtariST/FORTH83.FB.src b/sources/AtariST/FORTH83.FB.src new file mode 100644 index 0000000..d680041 --- /dev/null +++ b/sources/AtariST/FORTH83.FB.src @@ -0,0 +1,2261 @@ +Screen 0 not modified + 0 \\ *** Volksforth System - Sourcecode *** cas201301 + 1 + 2 This file contains the full sourcecode for the volksFORTH-83 + 3 kernal. + 4 + 5 The source is compiled using the volksForth target compiler. The + 6 source contains instructions for the target compiler that will + 7 not end up in the final Forth system. + 8 + 9 +10 See the documentation on http://fossil.forth-ev.de/volksforth +11 for information on how to compile a new Forth kernel from +12 the source. +13 +14 +15 +Screen 1 not modified + 0 \ Atari 520 ST Forth loadscreen cas201301 + 1 \ volksFORTH-83 was developed by K. Schleisiek, B. Pennemann + 2 \ G. Rehfeld & D. Weineck + 3 \ Atari ST - Version by D. Weineck + 4 \ Atari ST/STE/TT/Falcon/FireBee Version by C. Strotmann + 5 + 6 Onlyforth + 7 + 8 0 dup displace ! + 9 Target definitions here! +10 +11 $82 +load +12 1 $76 +thru +13 +14 cr .unresolved ' .blk is .status +15 +Screen 2 not modified + 0 \ FORTH Preamble and ID cas201301 + 1 + 2 Assembler + 3 0 FP D) jmp here 2- >label >cold + 4 0 FP D) jmp here 2- >label >restart + 5 here dup origin! + 6 \ Initial cold-start values for user variables + 7 + 8 0 # D6 move D6 reg) jmp \ Fr multitasker + 9 $100 allot +10 +11 | Create logo ," volksFORTH-83 rev. 3.85.1" +12 +13 +14 +15 +Screen 3 not modified + 0 \ Assembler Labels & Macros Next cas201301 + 1 + 2 Compiler Assembler also definitions + 3 + 4 H : Next .w IP )+ D7 move \ D7 contains cfa + 5 D7 reg) D6 move \ D6 contains cfa@ + 6 D6 reg) jmp .w \ jump to cfa@ + 7 there Tnext-link H @ T , H Tnext-link ! ; + 8 + 9 Target +10 +11 +12 +13 +14 +15 +Screen 4 not modified + 0 \ recover noop 06sep86we + 1 + 2 Create recover Assembler + 3 .l A7 )+ D7 move FP IP suba .w IP RP -) move + 4 .l D7 IP move 0 D7 moveq Next end-code + 5 + 6 Compiler Assembler also definitions + 7 + 8 H : ;c: 0 T recover R#) jsr end-code ] H ; + 9 +10 Target +11 +12 Code noop Next end-code +13 +14 +15 +Screen 5 not modified + 0 \ User Variables 14sep86we + 1 + 2 Constant origin &10 uallot drop \ For multitasker + 3 User s0 + 4 User r0 + 5 User dp + 6 User offset 0 offset ! + 7 User base $10 base ! + 8 User output + 9 User input +10 User errorhandler \ pointer for abort" -code +11 User voc-link +12 User udp \ points to next free addr in User +13 User next-link \ points to next Next +14 +15 +Screen 6 not modified + 0 \ end-trace 11sep86we + 1 + 2 Variable UP + 3 + 4 Label fnext IP )+ D7 move D7 reg) D6 move D6 reg) jmp + 5 + 6 Code end-trace + 7 fnext # D6 move .l D6 reg) A0 lea A0 D5 move + 8 .w UP R#) D6 move .l user' next-link D6 FP DI) D6 .w move + 9 BEGIN .l D6 reg) A1 lea .w D6 tst 0<> +10 WHILE .w &10 # A1 suba .l D5 A0 move +11 A0 )+ A1 )+ move A0 )+ A1 )+ move +12 .w 2 A1 addq A1 ) D6 move +13 REPEAT fnext bra end-code +14 +15 +Screen 7 not modified + 0 \ manipulate system pointers 09sep86we + 1 + 2 Code sp@ ( -- addr ) .l SP D6 move FP D6 sub + 3 .w D6 SP -) move Next end-code + 4 + 5 Code sp! ( addr -- ) SP )+ D6 move $FFFE D6 andi + 6 D6 reg) SP lea Next end-code + 7 + 8 Code up@ ( -- addr ) UP R#) SP -) move Next end-code + 9 +10 Code up! ( addr -- ) SP )+ D0 move $FFFE D0 andi +11 D6 UP R#) move Next end-code +12 +13 Code forthstart ( -- laddr ) .l FP SP -) move Next end-code +14 +15 +Screen 8 not modified + 0 \ manipulate returnstack 05sep86we + 1 + 2 Code rp@ ( -- addr ) .l RP D6 move FP D6 sub + 3 .w D6 SP -) move Next end-code + 4 + 5 Code rp! ( addr -- ) SP )+ D6 move $FFFE D6 andi + 6 D6 reg) RP lea Next end-code + 7 + 8 Code >r ( 16b -- ) SP )+ RP -) move + 9 Next end-code restrict +10 +11 Code r> ( -- 16b ) RP )+ SP -) move +12 Next end-code restrict +13 +14 +15 +Screen 9 not modified + 0 \ r@ rdrop exit unnest ?exit 04sep86we + 1 + 2 Code r@ ( -- 16b ) RP ) SP -) move Next end-code + 3 + 4 Code rdrop 2 RP addq Next end-code restrict + 5 + 6 Code exit RP )+ D7 move .l D7 IP move + 7 FP IP adda Next end-code + 8 + 9 Code unnest RP )+ D7 move .l D7 IP move +10 FP IP adda Next end-code +11 +12 Code ?exit ( flag -- ) SP )+ tst 0<> IF RP )+ D7 move +13 .l D7 IP move FP IP adda THEN +14 Next end-code +15 \\ : ?exit ( flag -- ) IF rdrop THEN ; +Screen 10 not modified + 0 \ execute perform 04sep86we + 1 + 2 Code execute ( cfa -- ) + 3 SP )+ D7 move D7 reg) D6 move .l D6 reg) jmp end-code + 4 + 5 : perform ( addr -- ) @ execute ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 11 not modified + 0 \ c@ c! ctoggle 04sep86we + 1 + 2 Code c@ ( addr -- 8b ) + 3 SP )+ D6 move D6 reg) A0 lea 0 D0 moveq + 4 .b A0 ) D0 move .w D0 SP -) move Next end-code + 5 + 6 Code c! ( 16b addr -- ) + 7 SP )+ D6 move D6 reg) A0 lea + 8 SP )+ D0 move .b D0 A0 ) move Next end-code + 9 +10 : ctoggle ( 8b addr --) under c@ xor swap c! ; +11 +12 +13 +14 +15 +Screen 12 not modified + 0 \ @ ! 2@ 2! 04sep86we + 1 + 2 Code @ ( addr -- 16b ) + 3 SP )+ D6 move D6 reg) A0 lea + 4 .b 1 A0 D) SP -) move A0 ) SP -) move + 5 Next end-code + 6 + 7 Code ! ( 16b addr -- ) + 8 SP )+ D6 move D6 reg) A0 lea + 9 .b SP )+ A0 )+ move SP )+ A0 )+ move +10 Next end-code +11 +12 +13 +14 +15 +Screen 13 not modified + 0 \ 2@ 2! 04sep86we + 1 + 2 Code 2@ ( addr -- 32b ) + 3 SP )+ D6 move D6 reg) A0 lea + 4 .b 3 A0 D) SP -) move 2 A0 D) SP -) move + 5 1 A0 D) SP -) move A0 ) SP -) move Next end-code + 6 + 7 Code 2! ( 32b addr -- ) + 8 SP )+ D6 move D6 reg) A0 lea + 9 .b SP )+ A0 )+ move SP )+ A0 )+ move +10 SP )+ A0 )+ move SP )+ A0 )+ move Next end-code +11 +12 \\ +13 : 2@ ( adr -- 32b) dup 2+ @ swap @ ; +14 : 2! ( 32b adr --) rot over 2+ ! ! ; +15 +Screen 14 not modified + 0 \ lc@ lc! l@ l! 24may86we + 1 + 2 Code lc@ ( laddr -- 8b ) + 3 .l SP )+ A0 move 0 D0 moveq .b A0 ) D0 move + 4 .w D0 SP -) move Next end-code + 5 Code lc! ( 8b laddr -- ) + 6 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move + 7 Next end-code + 8 + 9 Code l@ ( laddr -- n ) +10 .l SP )+ A0 move .b A0 )+ D0 move .w 8 # D0 lsl +11 .b A0 ) D0 move .w D0 SP -) move Next end-code +12 Code l! ( n laddr -- ) +13 .l SP )+ A0 move .w SP )+ D0 move .b D0 1 A0 D) move +14 .w 8 # D0 lsr .b D0 A0 ) move Next end-code +15 +Screen 15 not modified + 0 \ lcmove 10sep86we + 1 + 2 Code lcmove ( fromladdr toladdr count -- ) + 3 SP )+ D0 move .l SP )+ A0 move SP )+ A1 move + 4 .w D0 tst 0<> IF 1 D0 subq + 5 D0 DO .b A1 )+ A0 )+ move LOOP THEN Next end-code + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 16 not modified + 0 \ l2@ l2! cas201301 + 1 + 2 Code l2@ ( laddr -- 32bit ) + 3 .l SP )+ A0 move .b A0 )+ D0 move .l 8 # D0 lsl + 4 .b A0 )+ D0 move .l 8 # D0 lsl .b A0 )+ D0 move .l 8 # D0 lsl + 5 .b A0 ) D0 move .l D0 SP -) move Next end-code + 6 + 7 Code l2! ( 32bit laddr -- ) + 8 .l SP )+ A0 move SP )+ D0 move + 9 .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move +10 .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move +11 Next end-code +12 +13 Code ln+! ( n laddr -- ) \ only even addresses allowed +14 .l SP )+ A0 move A0 ) A1 move .w SP )+ A1 adda +15 .l A1 A0 ) move Next end-code +Screen 17 not modified + 0 \ +! drop swap 05sep86we + 1 + 2 Code +! ( n addr -- ) + 3 SP )+ D6 move D6 reg) A0 lea 2 A0 addq 2 SP addq + 4 4 # move>ccr .b SP -) A0 -) addx SP -) A0 -) addx + 5 .w 2 SP addq Next end-code + 6 + 7 + 8 Code drop ( 16b -- ) 2 SP addq Next end-code + 9 +10 Code swap ( 16b1 16b2 -- 16b2 16b1 ) +11 .l SP ) D0 move D0 swap D0 SP ) move Next end-code +12 +13 +14 +15 +Screen 18 not modified + 0 \ dup ?dup 20mar86we + 1 + 2 Code dup ( 16b -- 16b 16b ) SP ) SP -) move Next end-code + 3 + 4 Code ?dup ( 16b -- 16b 16b / false ) + 5 SP ) tst 0<> IF SP ) SP -) move THEN Next end-code + 6 + 7 + 8 + 9 \\ +10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; +11 +12 +13 +14 +15 +Screen 19 not modified + 0 \ over rot nip under bp 11 oct 86 + 1 + 2 Code over ( 16b1 16b2 - 16b1 16b3 16b1 ) + 3 2 SP D) SP -) move Next end-code + 4 Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) + 5 SP )+ D1 move SP )+ D2 move SP ) D0 move + 6 D2 SP ) move D1 SP -) move D0 SP -) move + 7 Next end-code + 8 Code nip ( 16b1 16b2 -- 16b2 ) + 9 SP )+ SP ) move Next end-code +10 Code under ( 16b1 16b2 - 16b2 16b1 16b2 ) +11 .l SP ) D0 move D0 swap D0 SP ) move .w D0 SP -) move +12 Next end-code +13 \\ +14 : nip ( 16b1 16b2 -- 16b2) swap drop ; +15 : under ( 16b1 16b2 -- 16b2 16b1 16b2) swap over ; +Screen 20 not modified + 0 \ -rot nip pick roll bp 11 oct 86 + 1 + 2 Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + 3 SP )+ D2 move SP )+ D0 move SP ) D1 move + 4 D2 SP ) move D1 SP -) move D0 SP -) move + 5 Next end-code + 6 Code pick ( n -- 16b.n ) + 7 .l D0 clr .w SP )+ D0 move D0 D0 add + 8 0 D0 SP DI) SP -) move Next end-code + 9 : roll ( n -- ) +10 dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; +11 : -roll ( n -- ) >r dup sp@ dup 2+ +12 dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +13 \\ +14 : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +15 : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; +Screen 21 not modified + 0 \ double word stack manip. bp 12oct86 + 1 + 2 Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) + 3 .l SP )+ D0 move SP ) D1 move D0 SP ) move + 4 D1 SP -) move Next end-code + 5 Code 2dup ( 32b -- 32b 32b ) + 6 .l SP ) SP -) move Next end-code + 7 Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) + 8 .l 4 SP D) SP -) move Next end-code + 9 +10 Code 2drop ( 32b -- ) 4 SP addq Next end-code +11 +12 \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; +13 : 2drop ( 32b -- ) drop drop ; +14 : 2dup ( 32b -- 32b 32b) over over ; +15 +Screen 22 not modified + 0 \ + and or xor not 19mar86we + 1 + 2 Code + ( n1 n2 -- n3 ) + 3 SP )+ D0 move D0 SP ) add Next end-code + 4 + 5 Code or ( 16b1 16b2 -- 16b3 ) + 6 SP )+ D0 move D0 SP ) or Next end-code + 7 + 8 Code and ( 16b1 16b2 -- 16b3 ) + 9 SP )+ D0 move D0 SP ) and Next end-code +10 +11 Code xor ( 16b1 16b2 -- 16b3 ) +12 SP )+ D0 move D0 SP ) eor Next end-code +13 +14 Code not ( 16b1 -- 16b2 ) SP ) not Next end-code +15 +Screen 23 not modified + 0 \ - negate 19mar86we + 1 + 2 Code - ( n1 n2 -- n3 ) + 3 SP )+ D0 move D0 SP ) sub Next end-code + 4 + 5 Code negate ( n1 -- n2 ) SP ) neg Next end-code + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 24 not modified + 0 \ double arithmetic cas201301 + 1 + 2 Code dnegate ( d1 -- -d1 ) .l SP ) neg Next end-code + 3 + 4 Code d+ ( d1 d2 -- d3 ) + 5 .l SP )+ D0 move D0 SP ) add Next end-code + 6 + 7 Code d- ( d1 d2 -- d1-d2 ) + 8 .l SP )+ D0 move D0 SP ) sub Next end-code + 9 +10 Code d* ( d1 d2 -- d1*d2 ) +11 .l SP )+ D0 move SP )+ D1 move +12 D0 D2 move D0 D3 move D3 swap D1 D4 move D4 swap +13 D1 D0 mulu D3 D1 mulu D4 D2 mulu +14 D0 swap .w D1 D0 add .w D2 D0 add .l D0 swap +15 D0 SP -) move Next end-code +Screen 25 not modified + 0 \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 18nov86we + 1 + 2 Code 1+ ( n1 -- n2 ) 1 SP ) addq Next end-code + 3 Code 2+ ( n1 -- n2 ) 2 SP ) addq Next end-code + 4 Code 3+ ( n1 -- n2 ) 3 SP ) addq Next end-code + 5 Code 4+ ( n1 -- n2 ) 4 SP ) addq Next end-code + 6 | Code 6+ ( n1 -- n2 ) 6 SP ) addq Next end-code + 7 Code 1- ( n1 -- n2 ) 1 SP ) subq Next end-code + 8 Code 2- ( n1 -- n2 ) 2 SP ) subq Next end-code + 9 Code 4- ( n1 -- n2 ) 4 SP ) subq Next end-code +10 +11 +12 : on ( addr -- ) true swap ! ; +13 : off ( addr -- ) false swap ! ; +14 +15 +Screen 26 not modified + 0 \ number Constants bp 18nov86we + 1 + 2 Code true ( -- -1 ) -1 # SP -) move Next end-code + 3 Code false ( -- 0 ) 0 # SP -) move Next end-code + 4 Code 1 ( -- 1 ) 1 # SP -) move Next end-code + 5 Code 2 ( -- 2 ) 2 # SP -) move Next end-code + 6 Code 3 ( -- 3 ) 3 # SP -) move Next end-code + 7 Code 4 ( -- 4 ) 4 # SP -) move Next end-code + 8 + 9 ' true Alias -1 ' false Alias 0 +10 +11 +12 +13 +14 +15 +Screen 27 not modified + 0 \ words for number literals 19mar86we + 1 + 2 Code lit ( -- 16b ) IP )+ SP -) move Next end-code + 3 + 4 : Literal ( 16b -- ) compile lit , ; immediate restrict + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 28 not modified + 0 \ comparision code words 19mar86we + 1 + 2 Label yes true # SP ) move Next Label no SP ) clr Next + 3 + 4 Code 0< ( n -- flag ) SP ) tst yes bmi no bra end-code + 5 + 6 Code 0= ( 16b -- flag ) SP ) tst yes beq no bra end-code + 7 + 8 Code < ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp + 9 yes bgt no bra end-code +10 +11 Code u< ( u1 u2 -- flag ) SP )+ D0 move SP ) D0 cmp +12 yes bhi no bra end-code +13 +14 : uwithin ( u1 [low up[ -- flag ) +15 rot under u> -rot u> not and ; +Screen 29 not modified + 0 \ comparision code words 25mar86we + 1 + 2 Code > ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp + 3 yes blt no bra end-code + 4 + 5 Code 0> ( n -- flag ) SP ) tst yes bgt no bra + 6 end-code + 7 + 8 Code 0<> ( n -- flag ) SP ) tst yes bne no bra + 9 end-code +10 +11 Code u> ( u1 u2 -- flag ) SP )+ D0 move SP ) D1 move +12 D0 D1 cmp yes bhi no bra +13 end-code +14 Code = ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp +15 yes beq no bra end-code +Screen 30 not modified + 0 \ comparision words 20mar86we + 1 + 2 : d0= ( d -- flag ) or 0= ; + 3 : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + 4 : d< ( d1 d2 -- flag ) rot 2dup - IF > nip nip + 5 ELSE 2drop u< THEN ; + 6 + 7 + 8 \\ + 9 : 0< 8000 and 0<> ; +10 : > ( n1 n2 -- flag ) swap < ; +11 : 0> ( n -- flag ) negate 0< ; +12 : 0<> ( n -- flag ) 0= not ; +13 : u> ( u1 u2 -- flag ) swap u< ; +14 : = ( n1 n2 -- flag ) - 0= ; +15 +Screen 31 not modified + 0 \ min max umax umin extend dabs abs 18nov86we + 1 + 2 | Code minimax ( n1 n2 f -- n ) + 3 SP )+ tst 0<> IF SP ) 2 SP D) move THEN 2 SP addq + 4 Next end-code + 5 + 6 : min ( n1 n2 -- n3 ) 2dup > minimax ; + 7 : max ( n1 n2 -- n3 ) 2dup < minimax ; + 8 : umax ( u1 u2 -- u3 ) 2dup u< minimax ; + 9 : umin ( u1 u2 -- u3 ) 2dup u> minimax ; +10 : extend ( n -- d ) dup 0< ; +11 : dabs ( d -- ud ) extend IF dnegate THEN ; +12 : abs ( n -- u) extend IF negate THEN ; +13 \\ +14 : minimax ( n1 n2 flag -- n3 ) +15 rdrop IF swap THEN drop ; +Screen 32 not modified + 0 \ loop primitives 19mar86we + 1 + 2 | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; + 3 + 4 : (do ( limit start -- ) over - dodo ; restrict + 5 : (?do ( limit start -- ) over - ?dup IF dodo THEN + 6 r> dup @ + >r drop ; restrict + 7 + 8 : bounds ( start count -- limit start ) over + swap ; + 9 +10 Code endloop 6 RP addq Next end-code restrict +11 +12 +13 +14 \\ dodo puts "index | limit | adr.of.DO" on return-stack +15 +Screen 33 not modified + 0 \ (loop (+loop 04sep86we + 1 + 2 Code (loop + 3 1 RP ) addq + 4 CC IF 4 RP D) D6 move D6 reg) IP lea THEN + 5 Next end-code restrict + 6 + 7 Code (+loop + 8 SP )+ D0 move D0 D1 move D0 RP ) add + 9 1 # D1 roxr D0 D1 eor +10 0>= IF 4 RP D) D6 move D6 reg) IP lea THEN +11 Next end-code restrict +12 +13 +14 +15 +Screen 34 not modified + 0 \ loop indices 20mar86we + 1 + 2 Code I ( -- n ) + 3 RP ) D0 move 2 RP D) D0 add D0 SP -) move + 4 Next end-code + 5 + 6 Code J ( -- n ) + 7 6 RP D) D0 move 8 RP D) D0 add D0 SP -) move + 8 Next end-code + 9 +10 +11 +12 +13 +14 +15 +Screen 35 not modified + 0 \ branch ?branch 06sep86we + 1 + 2 Code branch + 3 Label bran1 IP ) IP adda Next end-code + 4 + 5 Code ?branch ( fl -- ) SP )+ tst bran1 beq 2 IP addq + 6 Next end-code + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 36 not modified + 0 \ resolve loops and branches 19mar86we + 1 + 2 : >mark ( -- addr ) here 0 , ; + 3 : >resolve ( addr -- ) here over - swap ! ; + 4 : mark 1 ; immediate restrict + 3 : THEN abs 1 ?pairs >resolve ; immediate restrict + 4 : ELSE 1 ?pairs compile branch >mark swap + 5 >resolve -1 ; immediate restrict + 6 : BEGIN mark + 8 -2 2swap ; immediate restrict + 9 | : (reptil resolve REPEAT ; +11 : REPEAT 2 ?pairs compile branch (reptil ; +12 immediate restrict +13 : UNTIL 2 ?pairs compile ?branch (reptil ; +14 immediate restrict +15 +Screen 39 not modified + 0 \ Loops 24nov85we + 1 + 2 : DO compile (do >mark 3 ; immediate restrict + 3 : ?DO compile (?do >mark 3 ; immediate restrict + 4 : LOOP 3 ?pairs compile (loop compile endloop >resolve ; + 5 immediate restrict + 6 : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; + 7 immediate restrict + 8 : LEAVE endloop r> 2- dup @ + >r ; restrict + 9 +10 +11 \\ Returnstack: calladr | index limit | adr of DO +12 +13 +14 +15 +Screen 40 not modified + 0 \ Multiplication 18nov86we + 1 + 2 Code um* ( u1 u2 -- ud ) + 3 SP )+ D0 move SP )+ D0 mulu .l D0 SP -) move + 4 Next end-code + 5 + 6 Code * ( n1 n2 -- n ) + 7 SP )+ D0 move SP )+ D0 mulu D0 SP -) move + 8 Next end-code + 9 +10 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN +11 swap dup 0< IF negate r> not >r THEN +12 um* r> IF dnegate THEN ; +13 +14 Code 2* ( n -- 2*n ) SP ) asl Next end-code +15 Code 2/ ( n -- n/2 ) SP ) asr Next end-code +Screen 41 not modified + 0 \ Division cas201301 + 1 + 2 label divovl ;c: true abort" division overflow" ; + 3 + 4 Label (m/mod \ d(D2) n(D0) -- mod quot + 5 .l A7 )+ A0 move \ get addr from stack + 6 .w D0 D1 move D0 D3 move + 7 .l D1 ext + 8 D2 D1 eor 0< IF D2 neg .w D0 neg THEN + 9 D0 D2 divs divovl bvs +10 .w D2 D0 move D2 swap .l D1 tst +11 0< IF .w D2 tst 0<> IF 1 D0 subq \ quot = quot - 1 +12 D3 D2 sub D2 neg \ rem = n - rem +13 THEN THEN +14 .w D2 SP -) move D0 SP -) move +15 .l A0 ) jmp \ adr. from /0-TRAPS leads to a GEM crash +Screen 42 not modified + 0 \ um/mod m/mod /mod 18nov86we + 1 + 2 Code um/mod ( d1 n1 -- rem quot ) + 3 SP )+ D0 move .l SP )+ D1 move D0 D1 divu + 4 divovl bvs + 5 D1 swap D1 SP -) move Next end-code + 6 + 7 Code m/mod ( d n -- mod quot ) + 8 SP )+ D0 move .l SP )+ D2 move (m/mod bsr Next end-code + 9 +10 Code /mod ( n1 n2 -- mod quot ) +11 SP )+ D0 move SP )+ D2 move .l D2 ext +12 (m/mod bsr Next end-code +13 +14 +15 +Screen 43 not modified + 0 \ / mod 18nov86we + 1 + 2 Code / ( n1 n2 -- quot ) + 3 SP )+ D0 move SP )+ D2 move .l D2 ext + 4 .w D0 D1 move D2 D1 eor \ SHORT way ! + 5 0< IF (m/mod bsr SP )+ SP ) move Next THEN + 6 D0 D2 divs divovl bvs D2 SP -) move Next end-code + 7 + 8 Code mod ( n1 n2 -- mod ) + 9 SP )+ D0 move SP )+ D2 move .l D2 ext +10 .w D0 D1 move D2 D1 eor \ SHORT way ! +11 0< IF (m/mod bsr 2 SP addq Next THEN +12 D0 D2 divs divovl bvs +13 D2 swap D2 SP -) move Next end-code +14 +15 +Screen 44 not modified + 0 \ */mod */ u/mod ud/mod 18nov86we + 1 + 2 : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + 3 : */ ( n1 n2 n3 -- quot ) */mod nip ; + 4 : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + 5 : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r + 6 um/mod r> ; + 7 + 8 \\ + 9 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; +10 : / ( n1 n2 -- quot ) /mod nip ; +11 : mod ( n1 n2 -- rem ) /mod drop ; +12 : m/mod ( d n -- mod quot ) +13 dup >r abs over 0< IF under + swap THEN um/mod r@ 0< +14 IF negate over IF swap r@ + swap 1- THEN THEN +15 rdrop ; +Screen 45 not modified + 0 \ cmove cmove> 04sep86we + 1 + 2 Code cmove ( from to count -- ) + 3 SP )+ D0 move SP )+ D6 move D6 reg) A0 lea + 4 SP )+ D6 move D6 reg) A1 lea + 5 D0 tst 0<> IF 1 D0 subq + 6 D0 DO .b A1 )+ A0 )+ move LOOP THEN + 7 Next end-code + 8 + 9 Code cmove> ( from to count -- ) +10 SP )+ D0 move +11 SP )+ D6 move D0 D6 add D6 reg) A0 lea +12 SP )+ D6 move D0 D6 add D6 reg) A1 lea +13 D0 tst 0<> IF 1 D0 subq +14 D0 DO .b A1 -) A0 -) move LOOP THEN +15 Next end-code +Screen 46 not modified + 0 \ move place count bp 11 oct 86 + 1 + 2 : move ( from to quan -- ) + 3 >r 2dup u< IF r> cmove> exit THEN r> cmove ; + 4 + 5 : place ( addr len to --) + 6 over >r rot over 1+ r> move c! ; + 7 + 8 Code count ( adr -- adr+1 len ) + 9 SP ) D6 move D6 reg) A0 lea +10 D0 clr .b A0 )+ D0 move .w 1 SP ) addq D0 SP -) move +11 Next end-code +12 +13 +14 \\ +15 : count ( adr -- adr+1 len ) dup 1+ swap c@ ; +Screen 47 not modified + 0 \ fill erase bp 11 oct 86 + 1 + 2 Code fill ( addr quan 8b -- ) + 3 SP )+ D0 move SP )+ D1 move + 4 SP )+ D6 move D6 reg) A0 lea + 5 D1 tst 0<> IF + 6 1 D1 subq D1 DO .b D0 A0 )+ move LOOP THEN + 7 Next end-code + 8 + 9 : erase ( addr quan --) 0 fill ; +10 +11 +12 \\ +13 : fill ( addr quan 8b -- ) +14 swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN +15 2drop ; +Screen 48 not modified + 0 \ , c, 08sep86we + 1 + 2 Code , ( 8b -- ) UP R#) D6 move + 3 .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea + 4 .b SP )+ A0 )+ move SP )+ A0 )+ move + 5 .w UP R#) D6 move .l 2 user' dp D6 FP DI) .w addq + 6 Next end-code + 7 + 8 Code c, ( 8b -- ) UP R#) D6 move + 9 .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea +10 SP )+ D0 move .b D0 A0 )+ move +11 .w UP R#) D6 move .l 1 user' dp D6 FP DI) .w addq +12 Next end-code +13 \\ +14 : , ( 16b -- ) here ! 2 allot ; +15 : c, ( 8b -- ) here c! 1 allot ; +Screen 49 not modified + 0 \ allot pad compile 08sep86we + 1 + 2 Code here ( -- addr ) + 3 UP R#) D6 move .l user' dp D6 FP DI) SP -) .w move + 4 Next end-code + 5 + 6 Code allot ( n -- ) UP R#) D6 move SP )+ D0 move + 7 D0 .l user' dp D6 FP DI) .w add Next end-code + 8 + 9 : pad ( -- addr ) here $42 + ; +10 +11 : compile r> dup 2+ >r @ , ; restrict +12 \\ +13 : here ( -- addr ) dp @ ; +14 : allot ( n -- ) +15 dup here + up@ u> abort" Dictionary full" dp +! ; +Screen 50 not modified + 0 \ input strings 25mar86we + 1 + 2 Variable #tib 0 #tib ! + 3 Variable >tib here >tib ! &80 allot + 4 Variable >in 0 >in ! + 5 Variable blk 0 blk ! + 6 Variable span 0 span ! + 7 + 8 : tib ( -- addr ) >tib @ ; + 9 +10 : query tib &80 expect span @ #tib ! +11 >in off blk off ; +12 +13 +14 +15 +Screen 51 not modified + 0 \ scan skip /string 16nov85we + 1 + 2 : /string ( addr0 len0 +n - addr1 len1 ) + 3 over umin rot over + -rot - ; + 4 + 5 + 6 + 7 + 8 \\ + 9 : scan ( addr0 len0 char -- addr1 len1 ) >r +10 BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap +11 REPEAT rdrop ; +12 +13 : skip ( addr len del -- addr1 len1 ) >r +14 BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap +15 REPEAT rdrop ; +Screen 52 not modified + 0 \ skip scan 04sep86we + 1 + 2 Label done .l FP A0 suba .w A0 SP -) move D1 SP -) move Next + 3 Code skip ( addr len del -- addr1 len1 ) + 4 SP )+ D0 move SP )+ D1 move 1 D1 addq + 5 SP )+ D6 move D6 reg) A0 lea + 6 BEGIN 1 D1 subq 0<> + 7 WHILE .b A0 ) D2 move D2 D0 cmp done bne .w 1 A0 addq + 8 REPEAT done bra end-code + 9 +10 Code scan ( addr len chr -- addr1 len1 ) +11 SP )+ D0 move SP )+ D1 move 1 D1 addq +12 SP )+ D6 move D6 reg) A0 lea +13 BEGIN 1 D1 subq 0<> +14 WHILE .b A0 ) D2 move D2 D0 cmp done beq .w 1 A0 addq +15 REPEAT done bra end-code +Screen 53 not modified + 0 \ convert to upper case 04sep86we + 1 + 2 Label umlaut + 3 Ascii „ c, Ascii ” c, Ascii c, + 4 Ascii Ž c, Ascii ™ c, Ascii š c, + 5 + 6 Label (capital ( D1 -> D1 ) + 7 D1 7 # btst 0= IF + 8 .b Ascii a D1 cmpi >= IF Ascii z D1 cmpi + 9 <= IF bl D1 subi THEN THEN rts +10 THEN umlaut R#) A1 lea +11 2 D2 moveq D2 DO .b A1 ) D1 cmp +12 0= IF .w 3 A1 addq .b A1 ) D1 move rts THEN +13 .w 1 A1 addq LOOP rts end-code +14 +15 +Screen 54 not modified + 0 \ capital capitalize bp 11 oct 86 + 1 + 2 Code capital ( char -- char' ) + 3 SP ) D1 move (capital bsr D1 SP ) move Next end-code + 4 + 5 Code capitalize ( string -- string ) + 6 SP ) D6 move D6 reg) A0 lea + 7 D0 clr .b A0 )+ D0 move + 8 0<> IF 1 D0 subq D0 DO + 9 A0 ) D1 move (capital bsr D1 A0 )+ move +10 LOOP THEN Next end-code +11 +12 +13 \\ +14 : capitalize ( string -- string) +15 dup count bounds ?DO I c@ capital I c! LOOP ; +Screen 55 not modified + 0 \ (word bp 11 oct 86 + 1 + 2 Code (word ( char adr0 len0 -- addr ) + 3 D1 clr SP )+ D0 move D0 D4 move + 4 SP )+ D6 move D6 reg) A0 lea SP ) D2 move + 5 >in R#) D3 move D3 A0 adda D3 D0 sub + 6 <= IF D4 >in R#) move + 7 ELSE 1 D0 addq BEGIN 1 D0 subq 0<> + 8 WHILE .b A0 ) D2 cmp 0= + 9 WHILE .l 1 A0 addq REPEAT THEN +10 A0 A1 move .w 1 D0 addq +11 BEGIN .w 1 D0 subq 0<> +12 WHILE .b A0 ) D2 cmp 0<> +13 WHILE .w 1 A0 addq 1 D1 addq REPEAT THEN +14 .w D1 tst 0<> IF 1 A0 addq THEN +15 .l FP A0 suba D6 A0 suba .w A0 >in R#) move THEN +Screen 56 not modified + 0 \ (word Part2 bp 11 oct 86 + 1 + 2 UP R#) D6 move .l user' dp D6 FP DI) D6 .w move + 3 D6 reg) A0 lea D6 SP ) move + 4 .b D1 A0 )+ move .w 1 D1 subq + 5 0>= IF D1 DO .b A1 )+ A0 )+ move LOOP THEN + 6 bl # A0 ) move Next end-code + 7 + 8 + 9 \\ +10 : word ( char -- addr) +11 >r source over swap >in @ /string +12 r@ skip over swap r> scan >r +13 rot over swap - r> 0<> - +14 >in ! over - here dup >r place +15 bl r@ count + c! r> ; +Screen 57 not modified + 0 \ even source word parse name bp 11oct86 + 1 + 2 : even ( addr -- addr1 ) dup 1 and + ; + 3 + 4 Variable loadfile 0 loadfile ! + 5 + 6 : source ( -- addr len ) blk @ ?dup + 7 IF loadfile @ (block b/blk exit THEN tib #tib @ ; + 8 + 9 : word ( char -- addr ) source (word ; +10 +11 : parse ( char -- addr len ) +12 >r source >in @ /string over swap r> scan >r +13 over - dup r> 0<> - >in +! ; +14 +15 : name ( -- addr ) bl word capitalize exit ; +Screen 58 not modified + 0 \ state Ascii ," (" " 15jun86we + 1 + 2 Variable state 0 state ! + 3 + 4 : Ascii ( char -- n ) + 5 bl word 1+ c@ state @ IF [compile] Literal THEN ; + 6 immediate + 7 + 8 : ," Ascii " parse here over 1+ allot place ; + 9 : "lit r> r> under count + even >r >r ; restrict +10 : (" "lit ; restrict +11 : " compile (" ," align ; immediate restrict +12 +13 +14 +15 +Screen 59 not modified + 0 \ ." ( .( \ \\ hex decimal 25mar86we + 1 + 2 : (." "lit count type ; restrict + 3 : ." compile (." ," align ; immediate restrict + 4 : ( ascii ) parse 2drop ; immediate + 5 : .( ascii ) parse type ; immediate + 6 : \ >in @ c/l / 1+ c/l * >in ! ; immediate + 7 : \\ b/blk >in ! ; immediate + 8 : \needs name find nip IF [compile] \ THEN ; + 9 +10 : hex $10 base ! ; +11 : decimal &10 base ! ; +12 +13 +14 +15 +Screen 60 not modified + 0 \ number conversion: digit? cas201301 + 1 + 2 | Variable ptr \ points into string + 3 + 4 Label fail SP ) clr Next + 5 Code digit? ( char -- n true : false ) + 6 UP R#) D6 move .l user' base D6 FP DI) D0 .w move + 7 SP ) D1 move .b Ascii 0 D1 subi fail bmi &10 D1 cmpi + 8 0>= IF $11 D1 cmpi fail bmi 7 D1 subq THEN + 9 D0 D1 cmp fail bpl .w D1 SP ) move true # SP -) move +10 Next end-code +11 \\ +12 : digit? ( char -- digit true/ false ) +13 Ascii 0 - dup 9 u> IF [ Ascii A Ascii 9 - 1- ] Literal - +14 dup 9 u> IF [ 2swap ( unstructured ) ] THEN +15 base @ over u> ?dup ?exit THEN drop false ; +Screen 61 not modified + 0 \ number conversion: accumulate convert 11sep86we + 1 + 2 Code accumulate ( +d0 addr digit -- +d1 addr ) + 3 0 D0 moveq SP )+ D0 move + 4 2 SP D) D1 move 4 SP D) D2 move + 5 UP R#) D6 move .l user' base D6 FP DI) D3 .w move + 6 D3 D2 mulu D3 D1 mulu .l D1 swap .w D1 clr + 7 .l D2 D1 add D0 D1 add D1 2 SP D) move Next end-code + 8 + 9 : convert ( +d1 addr0 -- +d2 addr2 ) +10 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; +11 +12 +13 \\ +14 : accumulate ( +d0 adr digit - +d1 adr ) +15 swap >r swap base @ um* drop rot base @ um* d+ r> ; +Screen 62 not modified + 0 \ number conversion: end? char previous 25mar86we + 1 + 2 | : end? ( -- flag ) ptr @ 0= ; + 3 | : char ( addr0 -- addr1 char ) count -1 ptr +! ; + 4 | : previous ( addr0 -- addr0 char ) 1- count ; + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 63 not modified + 0 \ number conversion: ?nonum punctuation? 25mar86we + 1 + 2 | : ?nonum ( flag -- exit if true ) + 3 IF rdrop 2drop drop rdrop false THEN ; + 4 + 5 | : punctuation? ( char -- flag ) + 6 Ascii , over = swap Ascii . = or ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 64 not modified + 0 \ number conversion: fixbase? 25mar86we + 1 + 2 | : fixbase? ( char - char false / newbase true ) + 3 Ascii & case? IF &10 true exit THEN + 4 Ascii $ case? IF $10 true exit THEN + 5 Ascii H case? IF $10 true exit THEN + 6 Ascii % case? IF 2 true exit THEN false ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 65 not modified + 0 \ number conversion: ?num ?dpl 25mar86we + 1 + 2 Variable dpl -1 dpl ! + 3 + 4 | : ?num ( flag -- exit if true ) + 5 IF rdrop drop r> IF dnegate THEN + 6 rot drop dpl @ 1+ ?dup ?exit drop true THEN ; + 7 + 8 | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + 9 +10 +11 +12 +13 +14 +15 +Screen 66 not modified + 0 \ (number number 11sep86we + 1 + 2 : number? ( string - string false / n 0< / d 0> ) + 3 base push dup count ptr ! dpl on + 4 0 >r ( +sign) 0 0 rot end? ?nonum char + 5 Ascii - case? IF rdrop true >r end? ?nonum char THEN + 6 fixbase? IF base ! end? ?nonum char THEN + 7 BEGIN digit? 0= ?nonum + 8 BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL + 9 previous punctuation? 0= ?nonum dpl off end? ?num char +10 REPEAT ; +11 +12 : number ( string -- d ) +13 number? ?dup 0= abort" ?" 0< IF extend THEN ; +14 +15 +Screen 67 not modified + 0 \ hide reveal immediate restrict 24nov85we + 1 + 2 Variable last 0 last ! + 3 | : last? ( -- false / acf true) last @ ?dup ; + 4 : hide last? IF 2- @ current @ ! THEN ; + 5 : reveal last? IF 2- current @ ! THEN ; + 6 : Recursive reveal ; immediate restrict + 7 + 8 | : flag! ( 8b --) + 9 last? IF under c@ or over c! THEN drop ; +10 +11 : immediate $40 flag! ; +12 : restrict $80 flag! ; +13 +14 +15 +Screen 68 not modified + 0 \ clearstack hallot heap heap? bp 11 oct 86 + 1 + 2 Code clearstack + 3 UP R#) D6 move .l user' s0 D6 FP DI) D6 .w move + 4 $FFFE D6 andi D6 reg) SP lea Next end-code \ muž Code + 5 + 6 : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot + 7 dup 1 and ?dup IF over 0< IF negate THEN + THEN + 8 - dup s0 ! 2 pick over - move clearstack s0 ! ; + 9 +10 : heap ( -- addr ) s0 @ 6 + ; +11 : heap? ( addr -- flag ) heap up@ uwithin ; +12 +13 | : heapmove ( from -- from ) +14 dup here over - dup hallot +15 heap swap cmove heap over - last +! reveal ; +Screen 69 not modified + 0 \ Does> ; 24sep86we + 1 + 2 Label (dodoes> + 3 .l FP IP suba .w IP RP -) move A7 )+ IP lmove + 4 2 D7 addq D7 SP -) move Next end-code + 5 + 6 | : (;code r> last @ name> ! ; + 7 + 8 : Does> + 9 compile (;code $4EAB , compile (dodoes> ; +10 immediate restrict +11 +12 \ Does> compiles (;code and JSR (doedoes> FP D) +13 +14 +15 +Screen 70 not modified + 0 \ ?head | alignments warning exists? 15jun86we + 1 + 2 Variable ?head 0 ?head ! + 3 + 4 : | ?head @ ?exit -1 ?head ! ; + 5 + 6 + 7 : align here 1 and allot ; + 8 : halign heap 1 and hallot ; + 9 +10 Variable warning 0 warning ! +11 | : exists? warning @ ?exit last @ current @ +12 (find nip IF space last @ .name ." exists " ?cr THEN ; +13 +14 +15 +Screen 71 not modified + 0 \ Create 06sep86we + 1 + 2 : blk@ blk @ ; + 3 Defer makeview ' blk@ Is makeview + 4 + 5 : Create + 6 align here makeview , current @ @ , + 7 name c@ dup 1 $20 uwithin not abort" invalid name" + 8 here last ! 1+ allot align + 9 exists? ?head @ +10 IF 1 ?head +! dup , \ Pointer to Code +11 halign heapmove $20 flag! dp ! +12 ELSE drop THEN reveal 0 , +13 ;Code 2 D7 addq D7 SP -) move Next end-code +14 +15 +Screen 72 not modified + 0 \ nfa? 04sep86we + 1 + 2 Code nfa? ( thread cfa -- nfa | false ) + 3 SP )+ D2 move SP )+ D6 move D6 reg) A0 lea .w + 4 BEGIN A0 ) D6 move 0= IF SP -) clr Next THEN + 5 .l D6 reg) A0 lea 2 D6 addq D6 reg) A1 lea + 6 .b A1 ) D0 move .w $1F D0 andi 1 D0 addq + 7 D0 D1 move 1 D1 andi D1 D0 add D0 D6 add + 8 .b A1 ) D0 move .w $20 D0 andi 0<> + 9 IF D6 reg) D6 move THEN +10 D2 D6 cmp 0= UNTIL +11 .l FP A1 suba .w A1 SP -) move Next end-code +12 +13 \\ : nfa? ( thread cfa -- nfa / false) +14 >r BEGIN @ dup 0= IF rdrop exit THEN +15 dup 2+ name> r@ = UNTIL 2+ rdrop ; +Screen 73 not modified + 0 \ >name name> >body .name 14sep86we + 1 + 2 : >name ( cfa -- nfa / false ) voc-link + 3 BEGIN @ dup WHILE 2dup 4- swap nfa? + 4 ?dup IF -rot 2drop exit THEN REPEAT nip ; + 5 + 6 | : (name> ( nfa -- cfa ) count $1F and + even ; + 7 + 8 : name> ( nfa -- cfa ) + 9 dup (name> swap c@ $20 and IF @ THEN ; +10 +11 : >body ( cfa -- pfa ) 2+ ; +12 +13 : .name ( nfa -- ) +14 ?dup IF dup heap? IF ." |" THEN +15 count $1F and type ELSE ." ???" THEN space ; +Screen 74 not modified + 0 \ : ; Constant Variable bp 12oct86 + 1 + 2 : Create: Create hide current @ context ! ] 0 ; + 3 + 4 : : Create: + 5 ;Code .l FP IP suba .w IP RP -) move + 6 .l 2 D7 FP DI) IP lea Next end-code + 7 + 8 : ; 0 ?pairs compile unnest [compile] [ reveal ; + 9 immediate restrict +10 +11 : Constant Create , +12 ;Code .l 2 D7 FP DI) .w SP -) move Next end-code +13 +14 : 2Constant Create , , does> 2@ ; +15 +Screen 75 not modified + 0 \ uallot User Alias bp 12oct86 + 1 + 2 : Variable Create 2 allot ; + 3 : 2Variable Create 4 allot ; + 4 + 5 : uallot ( quan -- offset ) + 6 dup udp @ + $FF u> abort" Userarea full" + 7 udp @ swap udp +! ; + 8 + 9 : User Create udp @ 1 and udp +! 2 uallot c, +10 ;Code UP R#) D0 move 0 D1 moveq .l 2 D7 FP DI) .b D1 move +11 .w D1 D0 add D0 SP -) move Next end-code +12 +13 : Alias ( cfa -- ) +14 Create last @ dup c@ $20 and +15 IF -2 allot ELSE $20 flag! THEN (name> ! ; +Screen 76 not modified + 0 \ vp current context also toss 19mar86we + 1 + 2 Create vp $10 allot Variable current + 3 + 4 : context ( -- addr ) vp dup @ + 2+ ; + 5 + 6 | : thru.vocstack ( -- from to ) vp 2+ context ; + 7 \ "Only Forth also Assembler" gives + 8 \ vp: countword = 6 | Only | Forth | Assembler | + 9 +10 : also vp @ &10 > error" Vocabulary stack full" +11 context @ 2 vp +! context ! ; +12 +13 : toss vp @ IF -2 vp +! THEN ; +14 +15 +Screen 77 not modified + 0 \ Vocabulary Forth Only Onlyforth 24nov85we + 1 + 2 : Vocabulary + 3 Create 0 , 0 , here voc-link @ , voc-link ! + 4 Does> context ! ; + 5 \ | Name | Code | Thread | Coldthread | Voc-link | + 6 + 7 Vocabulary Forth + 8 Vocabulary Only + 9 ] Does> [ Onlypatch ] 0 vp ! context ! also ; ' Only ! +10 +11 : Onlyforth Only Forth also definitions ; +12 +13 +14 +15 +Screen 78 not modified + 0 \ definitions order words 24nov85we + 1 + 2 : definitions context @ current ! ; + 3 | : .voc ( adr -- ) @ 2- >name .name ; + 4 : order thru.vocstack DO I .voc -2 +LOOP + 5 2 spaces current .voc ; + 6 + 7 : words context @ + 8 BEGIN @ dup stop? 0= and + 9 WHILE ?cr dup 2+ .name space REPEAT drop ; +10 +11 +12 +13 +14 +15 +Screen 79 not modified + 0 \ found -text bp 11 oct 86 + 1 + 2 | : found ( nfa -- cfa n ) + 3 dup c@ >r (name> r@ $20 and IF @ THEN + 4 -1 r@ $80 and IF 1- THEN + 5 r> $40 and IF negate THEN ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 80 not modified + 0 \ (find bp 11 oct 86 + 1 \ A0: thread A1: string A2: nfa in thread D0: count + 2 \ D1: act. char D3: act. nfa D4: string + 3 Label notfound SP -) clr Next + 4 + 5 Code (find ( str thr - str false/ NFA true ) + 6 .w SP )+ D6 move D6 reg) A0 lea + 7 SP ) D6 move D6 reg) A1 lea + 8 .b A1 ) D0 move .w $1F D0 andi A1 D4 lmove + 9 D4 0 # btst 0= IF 1 D0 addq +10 Label findloop D4 A1 lmove +11 BEGIN A0 ) D6 move notfound beq D6 reg) A0 lea +12 .w A1 ) D1 move +13 .l 2 D6 FP DI) D1 .w sub $1FFF D1 andi 0= UNTIL +14 .l 2 D6 FP DI) A2 lea A2 D3 move +15 2 A1 addq 2 A2 addq +Screen 81 not modified + 0 \ (find part 2 09sep86we + 1 + 2 .w 0 D2 moveq BEGIN 2 D2 addq D2 D0 cmp > + 3 WHILE A1 )+ A2 )+ cmpm findloop bne REPEAT + 4 ELSE + 5 Label findloop1 A0 ) D6 move notfound beq + 6 .l D6 reg) A0 lea 2 D6 FP DI) A2 lea + 7 A2 D3 move D4 A1 move + 8 .b A1 )+ D1 move A2 )+ D1 sub $1F D1 andi findloop1 bne + 9 D0 D1 move BEGIN 1 D1 subq 0>= +10 WHILE A1 )+ A2 )+ cmpm findloop1 bne REPEAT +11 THEN +12 .l FP D3 sub .w D3 SP ) move +13 true # SP -) move Next end-code +14 +15 +Screen 82 not modified + 0 \ find ' ['] cas201301 + 1 + 2 : find ( string -- cfa n / string false ) + 3 context dup @ over 2- @ = IF 2- THEN + 4 BEGIN under @ (find IF nip found exit THEN + 5 over vp 2+ u> WHILE swap 2- REPEAT nip false ; + 6 + 7 : ' ( -- cfa ) name find 0= abort" ?" ; + 8 + 9 : [compile] ' , ; immediate restrict +10 +11 : ['] ' [compile] Literal ; immediate restrict +12 +13 : nullstring? ( string -- string false / true ) +14 dup c@ 0= dup IF nip THEN ; +15 +Screen 83 not modified + 0 \ >interpret 24sep86we + 1 + 2 Label jump + 3 .l 2 D7 FP DI) .w D6 move D6 reg) IP lea 2 IP addq + 4 Next end-code + 5 + 6 Create >interpret 2 allot jump ' >interpret ! + 7 + 8 \ make >interpret to special Defer + 9 +10 +11 +12 +13 +14 +15 +Screen 84 not modified + 0 \ interpret interactive cas201301 + 1 + 2 Defer notfound + 3 : no.extensions ( string -- ) error" ?" ; \ string not 0 + 4 ' no.extensions Is notfound + 5 + 6 : interpret >interpret ; + 7 + 8 | : interpreter ?stack name find ?dup + 9 IF 1 and IF execute >interpret THEN +10 abort" compile only" THEN +11 nullstring? ?exit +12 number? 0= IF notfound THEN >interpret ; +13 +14 ' interpreter >interpret ! +15 +Screen 85 not modified + 0 \ compiling [ ] 22mar86we + 1 + 2 | : compiler ?stack name find ?dup + 3 IF 0> IF execute >interpret THEN , >interpret THEN + 4 nullstring? ?exit + 5 number? ?dup + 6 IF 0> IF swap [compile] Literal THEN [compile] Literal + 7 >interpret THEN + 8 notfound >interpret ; + 9 +10 : [ ['] interpreter Is >interpret state off ; immediate +11 : ] ['] compiler Is >interpret state on ; +12 +13 +14 +15 +Screen 86 not modified + 0 \ Defer Is 24sep86we + 1 + 2 | : crash true abort" crash" ; + 3 + 4 : Defer Create ['] crash , + 5 ;Code .l 2 D7 FP DI) .w D7 move + 6 D7 reg) D6 move .l D6 reg) jmp end-code + 7 + 8 : (is r> dup 2+ >r @ ! ; + 9 +10 | : def? ( cfa -- ) @ ['] notfound @ over = +11 swap ['] >interpret @ = or +12 not abort" not deferred" ; +13 +14 : Is ( adr -- ) ' dup def? >body +15 state @ IF compile (is , exit THEN ! ; immediate +Screen 87 not modified + 0 \ ?stack 08sep86we + 1 + 2 | : stackfull ( -- ) + 3 depth $20 > abort" tight stack" reveal last? + 4 IF dup heap? IF name> ELSE 4- THEN (forget THEN + 5 true abort" Dictionary full" ; + 6 + 7 Code ?stack + 8 UP R#) D6 move .l user' dp D6 FP DI) D0 .w move + 9 .l SP D1 move FP D1 sub .w D0 D1 sub $100 D1 cmpi +10 $6200 ( u<= ) IF ;c: stackfull ; Assembler THEN +11 .l user' s0 D6 FP DI) D0 .w move .l SP D1 move FP D1 sub +12 .w D1 D0 cmp 0>= IF Next THEN ;c: true abort" Stack empty" ; +13 +14 \\ : ?stack sp@ here - $100 u< IF stackfull THEN +15 sp@ s0 @ u> abort" Stack empty" ; +Screen 88 not modified + 0 \ .status push load 28aug86we + 1 + 2 Defer .status ' noop Is .status + 3 + 4 | Create: pull r> r> ! ; + 5 + 6 : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; + 7 restrict + 8 + 9 +10 : (load ( blk offset -- ) over 0= IF 2drop exit THEN +11 isfile push loadfile push fromfile push blk push >in push +12 >in ! blk ! isfile @ loadfile ! .status interpret ; +13 +14 : load ( blk -- ) 0 (load ; +15 +Screen 89 not modified + 0 \ +load thru +thru --> rdepth depth 19mar86we + 1 + 2 : +load ( offset -- ) blk @ + load ; + 3 + 4 : thru ( from to -- ) 1+ swap DO I load LOOP ; + 5 + 6 : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + 7 + 8 : --> 1 blk +! >in off .status ; + 9 immediate +10 +11 : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; +12 : depth ( -- +n ) sp@ s0 @ swap - 2/ ; +13 +14 +15 +Screen 90 not modified + 0 \ quit (quit abort cas201301 + 1 + 2 | : prompt state @ IF ." [ " exit THEN ." ok" ; + 3 + 4 : (quit BEGIN .status cr query interpret prompt + 5 REPEAT ; + 6 + 7 Defer 'quit ' (quit Is 'quit + 8 : quit r0 @ rp! [compile] [ 'quit ; + 9 +10 : standardi/o [ output ] Literal output 4 cmove ; +11 +12 Defer 'abort ' noop Is 'abort +13 : abort clearstack end-trace +14 'abort standardi/o quit ; +15 +Screen 91 not modified + 0 \ (error abort" error" 29mar86we + 1 + 2 Variable scr 1 scr ! Variable r# 0 r# ! + 3 + 4 : (error ( string -- ) + 5 standardi/o space here .name count type space ?cr + 6 blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + 7 ' (error errorhandler ! + 8 + 9 : (abort" "lit swap IF >r clearstack r> +10 errorhandler perform exit THEN drop ; restrict +11 +12 | : (err" "lit swap IF errorhandler perform exit THEN +13 drop ; restrict +14 : abort" compile (abort" ," align ; immediate restrict +15 : error" compile (err" ," align ; immediate restrict +Screen 92 not modified + 0 \ -trailing bp 11 oct 86 + 1 + 2 Code -trailing ( addr n1 -- addr n2 ) + 3 SP )+ D0 move 0<> IF + 4 SP ) D6 move D6 reg) A0 lea D0 A0 adda + 5 Label -trail .b A0 -) D1 move $20 D1 cmpi -trail D0 dbne + 6 .w -1 D0 cmpi 0= IF D0 clr THEN + 7 THEN D0 SP -) move Next end-code + 8 + 9 +10 +11 +12 \\ +13 : -trailing ( addr n1 -- addr n2) 2dup bounds +14 ?DO 2dup + 1- c@ bl - +15 IF LEAVE THEN 1- LOOP ; +Screen 93 not modified + 0 \ space spaces bp 11 oct 86 + 1 + 2 $20 Constant bl + 3 + 4 : space bl emit ; + 5 + 6 : spaces ( u -- ) 0 ?DO space LOOP ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 94 not modified + 0 \ hold <# #> sign # #s 02may86we + 1 + 2 | : hld ( -- addr ) pad 2- ; + 3 + 4 : hold ( char -- ) -1 hld +! hld @ c! ; + 5 + 6 : <# hld hld ! ; + 7 + 8 : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + 9 +10 : sign ( n -- ) 0< IF Ascii - hold THEN ; +11 +12 : # ( +d1 -- +d2 ) base @ ud/mod rot 9 over < +13 IF [ ascii A ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; +14 +15 : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +Screen 95 not modified + 0 \ print numbers 24dec83ks + 1 + 2 : d.r -rot under dabs <# #s rot sign #> + 3 rot over max over - spaces type ; + 4 + 5 : .r swap extend rot d.r ; + 6 + 7 : u.r 0 swap d.r ; + 8 + 9 : d. 0 d.r space ; +10 +11 : . extend d. ; +12 +13 : u. 0 d. ; +14 +15 +Screen 96 not modified + 0 \ .s list c/l l/s bp 18May86 + 1 + 2 : .s + 3 sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + 4 + 5 $40 Constant c/l \ Screen line length + 6 $10 Constant l/s \ lines per screen + 7 + 8 : list ( blk -- ) + 9 scr ! ." Scr " scr @ dup u. ." Dr " drv? . +10 l/s 0 DO +11 cr I 2 .r space scr @ block I c/l * + c/l -trailing type +12 LOOP cr ; +13 +14 +15 +Screen 97 not modified + 0 \ multitasker primitives 14sep86we + 1 + 2 Code pause Next end-code + 3 + 4 : lock ( addr -- ) + 5 dup @ up@ = IF drop exit THEN + 6 BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + 7 + 8 : unlock ( addr -- ) dup lock off ; + 9 +10 Label wake .l 2 A7 addq A7 )+ A0 move 2 A0 subq +11 A0 A1 move FP A1 suba .w A1 UP R#) move +12 $3C3C ( # D6 move ) # A0 ) move +13 8 A0 D) D6 move D6 reg) SP lea +14 SP )+ D6 move D6 reg) RP lea +15 SP )+ D6 move D6 reg) IP lea Next end-code +Screen 98 not modified + 0 \ buffer mechanism cas201301 + 1 + 2 User isfile 0 isfile ! \ addr of file control block + 3 Variable fromfile 0 fromfile ! + 4 Variable prev 0 prev ! \ Listhead + 5 | Variable buffers 0 buffers ! \ Semaphore + 6 $408 Constant b/buf \ physical size + 7 + 8 \\ Structure of buffer: 0 : link + 9 2 : file +10 4 : blocknumber +11 6 : statusflags +12 8 : Data ... 1 Kb ... +13 Statusflag bits : 15 1 -> updated +14 file : -1 -> empty buffer, 0 -> no fcb, direct acces +15 else addr of fcb ( system dependent ) +Screen 99 not modified + 0 \ search for blocks in memory with (CORE? cas201301 + 1 \ D0:blk D1:file A0:bufadr A1:previous + 2 Label thisbuffer? + 3 2 A0 D) D1 cmp 0= IF 4 A0 D) D0 cmp THEN rts + 4 Code (core? ( blk file -- adr\blk file ) + 5 2 SP D) D0 move SP ) D1 move + 6 UP R#) D6 move .l user' offset D6 FP DI) D0 .w add + 7 prev R#) D6 move D6 reg) A0 lea + 8 thisbuffer? bsr 0= IF .l FP A0 suba + 9 Label blockfound 2 SP addq 8 A0 addq .w A0 SP ) move +10 .l ' exit @ R#) jmp .w THEN +11 BEGIN A0 A1 lmove A1 ) D6 move 0= IF Next THEN +12 D6 reg) A0 lea thisbuffer? bsr 0= UNTIL +13 A0 ) A1 ) move prev R#) A0 ) move +14 .l FP A0 suba .w A0 prev R#) move +15 blockfound bra end-code +Screen 100 not modified + 0 \ (core? 17nov85we + 1 + 2 \\ + 3 | : this? ( blk file bufadr -- flag ) + 4 dup 4+ @ swap 2+ @ d= ; + 5 + 6 | : (core? ( blk file -- dataaddr / blk file ) + 7 BEGIN over offset @ + over prev @ this? + 8 IF rdrop 2drop prev @ 8 + exit THEN + 9 2dup >r offset @ + >r prev @ +10 BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN +11 dup r> r> 2dup >r >r rot this? 0= +12 WHILE nip REPEAT +13 dup @ rot ! prev @ over ! prev ! rdrop rdrop +14 REPEAT ; +15 +Screen 101 not modified + 0 \ r/w 11sep86we + 1 + 2 Defer r/w + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 102 not modified + 0 \ backup emptybuf readblk 11sep86we + 1 + 2 : backup ( bufaddr -- ) dup 6+ @ 0< + 3 IF 2+ dup @ 1+ \ buffer empty if file = -1 + 4 IF input push output push standardi/o + 5 dup 6+ over 2+ @ 2 pick @ 0 r/w + 6 abort" write error" + 7 THEN 4+ dup @ $7FFF and over ! THEN drop ; + 8 + 9 : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; +10 +11 | : readblk ( blk file addr -- blk file addr ) +12 dup emptybuf +13 input push output push standardi/o >r +14 over offset @ + over r@ 8 + -rot 1 r/w +15 abort" read error" r> ; +Screen 103 not modified + 0 \ take mark updated? full? core? cas20130105 + 1 + 2 | : take ( -- bufaddr) prev + 3 BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + 4 buffers lock dup backup ; + 5 + 6 | : mark ( blk file bufaddr -- blk file ) + 7 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off + 8 buffers unlock ; + 9 +10 | : updates? ( -- bufaddr / flag ) +11 prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; +12 : updated? ( blk -- flg ) block 2- @ 0< ; +13 : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ; +14 +15 : core? ( blk file -- addr /false ) (core? 2drop false ; +Screen 104 not modified + 0 \ block & buffer manipulation b08sep86we + 1 + 2 : (buffer ( blk file -- addr ) + 3 BEGIN (core? take mark REPEAT ; + 4 + 5 : (block ( blk file -- addr ) + 6 BEGIN (core? take readblk mark REPEAT ; + 7 + 8 Code isfile@ ( -- addr ) + 9 UP R#) D6 move .l user' isfile D6 FP DI) SP -) .w move +10 Next end-code +11 +12 : buffer ( blk -- addr ) isfile@ (buffer ; +13 +14 : block ( blk -- addr ) isfile@ (block ; +15 +Screen 105 not modified + 0 \ block & buffer manipulation cas20130501 + 1 + 2 : update $80 prev @ 6+ c! ; + 3 + 4 : save-buffers buffers lock + 5 BEGIN updates? ?dup WHILE backup REPEAT + 6 buffers unlock ; + 7 + 8 : empty-buffers buffers lock prev + 9 BEGIN @ ?dup WHILE dup emptybuf REPEAT +10 buffers unlock ; +11 +12 : flush save-buffers empty-buffers ; +13 +14 +15 +Screen 106 not modified + 0 \ moving blocks cas201301 + 1 | : fromblock ( blk -- adr ) fromfile @ (block ; + 2 | : (copy ( from to -- ) + 3 dup isfile@ core? IF prev @ emptybuf THEN + 4 full? IF save-buffers THEN + 5 offset @ + isfile@ rot fromblock 6 - 2! update ; + 6 + 7 | : blkmove ( from to quan --) save-buffers >r + 8 over r@ + over u> >r 2dup u< r> and + 9 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP +10 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP +11 THEN save-buffers 2drop ; +12 +13 : copy ( from to --) 1 blkmove ; +14 : convey ( [blk1 blk2] [to.blk --) +15 swap 1+ 2 pick - dup 0> not abort" No!" blkmove ; +Screen 107 not modified + 0 \ Allocating buffers bp 18May86 + 1 + 2 $FFFE Constant limit Variable first + 3 + 4 : allotbuffer ( -- ) + 5 first @ r0 @ - b/buf 2+ u< ?exit + 6 b/buf negate first +! first @ dup emptybuf + 7 prev @ over ! prev ! ; + 8 + 9 : freebuffer ( -- ) +10 first @ limit b/buf - u< +11 IF first @ backup prev +12 BEGIN dup @ first @ - WHILE @ REPEAT +13 first @ @ swap ! b/buf first +! THEN ; +14 +15 : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; +Screen 108 not modified + 0 \ endpoints of forget 14sep86we + 1 + 2 | : |? ( nfa -- flag ) c@ $20 and ; + 3 | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + 4 name> under 1+ u< swap heap? or ; + 5 + 6 | : endpoints ( addr -- addr symb ) + 7 heap voc-link >r + 8 BEGIN r> @ ?dup \ through all Vocabs + 9 WHILE dup >r 4- >r \ link on returnstack +10 BEGIN r> @ >r over 1- dup r@ u< \ until link or +11 swap r@ 2+ name> u< and \ code under adr +12 WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap +13 r@ 2+ |? IF over r@ 2+ forget? +14 IF r@ 2+ (name> 2+ umax THEN \ then update symb +15 THEN REPEAT rdrop REPEAT ; +Screen 109 not modified + 0 \ remove, -words, -tasks bp/ks14sep86we + 1 + 2 : remove ( dic sym thread - dic sym ) + 3 BEGIN dup @ ?dup \ unlink forg. words + 4 WHILE dup heap? + 5 IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + 6 IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + 7 + 8 | : remove-words ( dic sym -- dic sym ) + 9 voc-link BEGIN @ ?dup +10 WHILE dup >r 4- remove r> REPEAT ; +11 +12 | : remove-tasks ( dic -- ) up@ +13 BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin +14 IF dup @ 2+ @ over ! 2- +15 ELSE @ THEN REPEAT 2drop ; +Screen 110 not modified + 0 \ remove-vocs forget-words bp 11oct86 + 1 + 2 | : remove-vocs ( dic symb -- dic symb ) + 3 voc-link remove thru.vocstack + 4 DO 2dup I @ -rot uwithin + 5 IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 6 2dup current @ -rot uwithin + 7 IF [ ' Forth 2+ ] Literal current ! THEN ; + 8 + 9 | : remove-codes ( dic symb -- dic symb ) +10 next-link remove ; +11 +12 Defer custom-remove ' noop Is custom-remove +13 | : forget-words ( dic symb -- ) +14 over remove-tasks remove-vocs remove-words remove-codes +15 custom-remove heap swap - hallot dp ! last off ; +Screen 111 not modified + 0 \ deleting words from dict. bp 11oct86 + 1 + 2 : clear here dup up@ forget-words dp ! ; + 3 + 4 : (forget ( adr -- ) dup heap? abort" is symbol" + 5 endpoints forget-words ; + 6 + 7 : forget ' dup [ dp ] Literal @ u< abort" protected" + 8 >name dup heap? + 9 IF name> ELSE 4- THEN (forget ; +10 +11 : empty [ dp ] Literal @ up@ forget-words +12 [ udp ] Literal @ udp ! ; +13 +14 +15 +Screen 112 not modified + 0 \ save bye stop? ?cr cas201301 + 1 + 2 : save here up@ forget-words + 3 voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL + 4 up@ origin $100 cmove ; + 5 + 6 : bye flush empty (bye ; + 7 + 8 | : end? key $FF and dup 3 = \ Stop key + 9 swap $1B = or \ Escape key +10 IF true rdrop THEN ; +11 +12 : stop? ( -- flag ) key? IF end? end? THEN false ; +13 +14 : ?cr col c/l u> IF cr THEN ; +15 +Screen 113 not modified + 0 \ in/output structure 25mar86we + 1 + 2 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; + 3 + 4 : Output: Create: Does> output ! ; + 5 0 Out: emit Out: cr Out: type Out: del + 6 Out: page Out: at Out: at? drop + 7 + 8 : row ( -- row ) at? drop ; + 9 : col ( -- col ) at? nip ; +10 +11 | : In: Create dup c, 2+ Does> c@ input @ + perform ; +12 +13 : Input: Create: Does> input ! ; +14 0 In: key In: key? In: decode In: expect drop +15 +Screen 114 not modified + 0 \ Alias only definitionen 29jan85bp + 1 + 2 Only definitions Forth + 3 + 4 : seal 0 ['] Only >body ! ; \ kill all words in Only + 5 + 6 ' Only Alias Only + 7 ' Forth Alias Forth + 8 ' words Alias words + 9 ' also Alias also +10 ' definitions Alias definitions +11 +12 Host Target +13 +14 +15 +Screen 115 not modified + 0 \ 'cold 'restart 19mar86we + 1 + 2 | : init-vocabularys voc-link @ + 3 BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; + 4 | : init-buffers 0 prev ! limit first ! all-buffers ; + 5 + 6 Defer 'cold ' noop Is 'cold + 7 | : (cold origin up@ $100 cmove + 8 init-vocabularys init-buffers 'cold page wrap + 9 Onlyforth cr &27 spaces logo count type cr (restart ; +10 +11 Defer 'restart ' noop Is 'restart +12 | : (restart ['] (quit Is 'quit drvinit 'restart +13 [ errorhandler ] Literal @ errorhandler ! +14 ['] noop Is 'abort abort ; +15 +Screen 116 not modified + 0 \ cold bootsystem restart 16oct86we + 1 + 2 Label buserror &14 # A7 adda ;c: true abort" Bus Error !" ; + 3 Label adrerror &14 # A7 adda ;c: true abort" Adress Error !" ; + 4 Label illegal 6 A7 addq + 5 ;c: true abort" Illegal Instruction !" ; + 6 Label div0 6 A7 addq ;c: true abort" Division by 0 !" ; + 7 + 8 + 9 +10 | Create save_ssp 4 allot +11 +12 Code cold here >cold ! +13 $A00A , \ hide mouse +14 ' (cold >body FP D) IP lea +15 +Screen 117 not modified + 0 \ restart 16oct86we + 1 + 2 Label bootsystem .l 0 D7 moveq + 3 .w user' s0 # D7 move origin D7 FP DI) D6 move + 4 .l D6 reg) SP lea .w 6 D6 addq D6 UP R#) move + 5 .w user' r0 # D7 move origin D7 FP DI) D6 move + 6 .l D6 reg) RP lea RP ) clr 0 D6 moveq + 7 .w D0 movedst) 0= IF + 8 .l A7 -) clr .w $20 # A7 -) move 1 trap + 9 .l D0 save_ssp R#) move 6 A7 addq THEN +10 .w buserror # D6 move .l D6 reg) A0 lea A0 8 #) move +11 .w adrerror # D6 move .l D6 reg) A0 lea A0 $0C #) move +12 .w illegal # D6 move .l D6 reg) A0 lea A0 $10 #) move +13 .w div0 # D6 move .l D6 reg) A0 lea A0 $14 #) move +14 .w wake # D6 move .l D6 reg) A0 lea A0 $8C #) move +15 Next end-code +Screen 118 not modified + 0 \ System dependent load screen bp 11oct86 + 1 + 2 Code restart here >restart ! + 3 ' (restart >body FP D) IP lea bootsystem bra end-code + 4 + 5 2 $0C +thru \ Atari 520 ST Interface + 6 + 7 Host ' Transient 8 + @ Transient Forth context @ 6 + ! + 8 \ Tlatest aus Transient wird Tlatest in Forth + 9 +10 Target Forth also definitions +11 : forth-83 ; \ last word in Dictionary +12 +13 +14 +15 +Screen 119 not modified + 0 \ System patchup 14sep86we + 1 + 2 Forth definitions + 3 + 4 $D3AA s0 ! $D7AA r0 ! \ gives &10 Buffers + 5 s0 @ dup s0 2- ! 6 + s0 8 - ! + 6 here dp ! + 7 + 8 Host Tudp @ Target udp ! + 9 Host Tvoc-link @ Target voc-link ! +10 Host Tnext-link @ Target next-link ! +11 Host move-threads +12 +13 +14 +15 +Screen 120 not modified + 0 \ BIOS - Calls 09sep86we + 1 + 2 Code bconstat ( dev -- fl ) + 3 SP )+ D0 move D0 A7 -) move 1 # A7 -) move $0D trap + 4 4 A7 addq D0 SP -) move Next end-code + 5 Code bcostat ( dev -- fl ) + 6 SP )+ D0 move D0 A7 -) move 8 # A7 -) move $0D trap + 7 4 A7 addq D0 SP -) move Next end-code + 8 + 9 Code bconin ( dev -- char ) +10 SP )+ D0 move D0 A7 -) move 2 # A7 -) move $0D trap +11 4 A7 addq .w D0 D1 move .l 8 # D0 lsr .b D1 D0 move +12 .w D0 SP -) move Next end-code +13 Code bconout ( char dev -- ) +14 SP )+ D0 move SP )+ A7 -) move D0 A7 -) move +15 3 # A7 -) move $0D trap 6 A7 addq Next end-code +Screen 121 not modified + 0 \ STkey? getkey cas201301 + 1 + 2 $08 Constant #bs $0D Constant #cr + 3 $0A Constant #lf $1B Constant #esc + 4 + 5 : con! ( 8b -- ) 2 bconout ; + 6 : curon #esc con! Ascii e con! ; + 7 : curoff #esc con! Ascii f con! ; + 8 : wrap #esc con! Ascii v con! ; + 9 : cur< #esc con! Ascii D con! -1 out +! ; +10 : cur> #esc con! Ascii C con! 1 out +! ; +11 +12 : STkey? ( -- fl ) 2 bconstat ; +13 : getkey ( -- char ) STkey? IF 2 bconin ELSE 0 THEN ; +14 : STkey ( -- char ) curon +15 BEGIN pause STkey? UNTIL curoff getkey ; +Screen 122 not modified + 0 \ (ins (del cas201301 + 1 + 2 | Variable maxchars + 3 + 4 | : (del ( addr pos1 -- addr pos2 ) 2dup cur< + 5 at? >r >r 2dup + over span @ - negate under type space + 6 r> r> at + 7 >r + dup 1- r> cmove -1 span +! 1- ; + 8 + 9 | : (ins ( addr pos1 -- addr pos2 ) 2dup +10 + over span @ - negate >r dup dup 1+ r@ cmove> +11 bl over c! r> 1+ at? >r >r type r> r> at +12 1 span +! ; +13 +14 +15 +Screen 123 not modified + 0 \ decode cas201301 + 1 + 2 : STdecode ( addr pos1 key -- addr pos2 ) + 3 $4D00 case? IF dup span @ < IF cur> 1+ THEN exit THEN + 4 $4B00 case? IF dup IF cur< 1- THEN exit THEN + 5 $5200 case? IF dup span @ - IF (ins THEN exit THEN + 6 $FF and dup 0= IF drop exit THEN + 7 #bs case? IF dup IF (del THEN exit THEN + 8 $7F case? IF span @ 2dup < and + 9 IF cur> 1+ (del THEN exit THEN +10 #cr case? IF span @ maxchars ! +11 dup at? rot span @ - - at exit THEN +12 >r 2dup + r@ swap c! r> emit +13 dup span @ = IF 1 span +! THEN 1+ ; +14 +15 +Screen 124 not modified + 0 \ expect keyboard 25mar86we + 1 + 2 : STexpect ( addr len -- ) maxchars ! + 3 span off 0 + 4 BEGIN span @ maxchars @ u< WHILE key decode REPEAT + 5 2drop space ; + 6 + 7 + 8 Input: keyboard [ here input ! ] + 9 STkey STkey? STdecode STexpect ; +10 +11 +12 +13 +14 +15 +Screen 125 not modified + 0 \ emit cr del page at at? type cas201301 + 1 + 2 | Variable out 0 out ! | &80 Constant c/row + 3 + 4 : STemit ( 8b -- ) 5 bconout 1 out +! pause ; + 5 : STcr #cr con! #lf con! + 6 out @ c/row / 1+ c/row * out ! ; + 7 : STdel #bs con! space #bs con! -2 out +! ; + 8 : STpage #esc con! Ascii E con! out off ; + 9 : STat ( row col -- ) #esc con! Ascii Y con! +10 over $20 + con! dup $20 + con! +11 swap c/row * + out ! ; +12 : STat? ( -- row col ) out @ c/row /mod swap ; +13 +14 \\ +15 : STtype ( addr len --) 0 ?DO count emit LOOP drop ; +Screen 126 not modified + 0 \ Output 16oct86we + 1 + 2 Code STtype ( addr len -- ) + 3 SP )+ D3 move SP )+ D6 move D3 tst 0<> + 4 IF D3 out R#) add 1 D3 subq + 5 D3 DO D6 reg) A0 lea .b A0 ) D1 move FP A7 -) lmove + 6 .w D1 A7 -) move 5 # A7 -) move 3 # A7 -) move + 7 $0D trap 6 A7 addq 1 D6 addq A7 )+ FP lmove LOOP + 8 THEN ;c: pause ; + 9 +10 Output: display [ here output ! ] +11 STemit STcr STtype STdel STpage STat STat? ; +12 +13 | Code term .l save_ssp R#) A7 -) move .w $20 # A7 -) move +14 1 trap 6 A7 addq A7 -) clr 1 trap end-code +15 | : (bye curoff term ; +Screen 127 not modified + 0 \ b/blk drive >drive drvinit 10sep86we + 1 + 2 $400 Constant b/blk + 3 | Variable (drv 0 (drv ! + 4 Create (blk/drv + 5 4 allot $15F (blk/drv ! $15F (blk/drv 2+ ! + 6 + 7 : blk/drv ( -- n ) (blk/drv (drv @ 2* + @ ; + 8 + 9 : drive ( drv# -- ) $1000 * offset ! ; +10 : >drive ( block drv# -- block' ) $1000 * + offset @ - ; +11 : drv? ( block -- drv# ) offset @ + $1000 / ; +12 +13 : drvinit noop ; +14 : drv0 0 drive ; : drv1 1 drive ; +15 +Screen 128 not modified + 0 \ readsector writesector cas201301 + 1 + 2 Code rwabs ( r/wf adr rec# -- flag ) + 3 .l FP A7 -) move + 4 .w SP )+ D0 move SP )+ D6 move D6 reg) A0 lea + 5 SP )+ D1 move 2 D1 addq + 6 (drv R#) A7 -) move \ Drivenumber + 7 D0 A7 -) move \ rec# + 8 2 # A7 -) move \ number sectors + 9 .l A0 A7 -) move \ Address +10 .w D1 A7 -) move \ r/w flag +11 4 # A7 -) move \ function number +12 $0D trap $0E # A7 adda .l A7 )+ FP move +13 .w D0 SP -) move \ error flag +14 Next end-code +15 +Screen 129 not modified + 0 \ diskchange? 09nov86we + 1 + 2 | Code mediach? ( -- flag ) + 3 .w (drv R#) A7 -) move 9 # A7 -) move $0D trap 4 A7 addq + 4 D0 SP -) move Next end-code + 5 + 6 | Code getblocks ( -- n ) + 7 .w (drv R#) A7 -) move 7 # A7 -) move $0D trap 4 A7 addq + 8 D0 A0 move .w $0E # A0 adda A0 ) D0 move D0 SP -) move + 9 Next end-code +10 +11 +12 +13 +14 +15 +Screen 130 not modified + 0 \ STr/w 10sep86we + 1 + 2 : STr/w ( adr blk file r/wf -- flag ) + 3 swap abort" no file" + 4 1 xor -rot $1000 /mod dup (drv ! + 5 1 u> IF . ." beyond capacity" nip exit THEN + 6 mediach? IF getblocks (blk/drv (drv @ 2* + ! THEN + 7 dup blk/drv > IF drop 2drop true + 8 ELSE 9 + 2* rwabs THEN ; + 9 +10 ' STr/w Is r/w +11 +12 +13 +14 +15 +Screen 131 not modified + 0 \ Basepage (TOS PRG Header) cas201301 + 1 + 2 $601A , \ BRA to start of PGM + 3 + 4 here $1A allot $1A erase \ clear basepage info + 5 + 6 Assembler + 7 + 8 .l A7 A5 move 4 A5 D) A5 move \ start basepage + 9 $1.0600 # D0 move D0 D1 move \ store size of forth and +10 A5 D1 add .w $FFFE D1 andi .l D1 A7 move \ stack +11 D0 A7 -) move A5 A7 -) move .w A7 -) clr +12 $4A # A7 -) move 1 trap $0C # A7 adda \ mshrink +13 $100 $1C - # A5 adda A5 FP lmove \ FP to start of Forth +14 +15 +Screen 132 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/AtariST/GEM/AES.FB.src b/sources/AtariST/GEM/AES.FB.src new file mode 100644 index 0000000..3d07562 --- /dev/null +++ b/sources/AtariST/GEM/AES.FB.src @@ -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 diff --git a/sources/AtariST/GEM/BASICS.FB.src b/sources/AtariST/GEM/BASICS.FB.src new file mode 100644 index 0000000..cbccfee --- /dev/null +++ b/sources/AtariST/GEM/BASICS.FB.src @@ -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 Verfgung steht. + 4 Fr 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 fr VDI- als auch fr +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 hbsch, hamse aber nich! diff --git a/sources/AtariST/GEM/GEMDEFS.FB.src b/sources/AtariST/GEM/GEMDEFS.FB.src new file mode 100644 index 0000000000000000000000000000000000000000..b4ad7fb48f4c93a155d26c7835ad7d2c3a15a5f2 GIT binary patch literal 6690 zcmeHLZExE)5Z-6~iW_DGE4CJv^HNs>wib!IWys60X6uJ#5M+stiAbbJQE{_h-#dx4 zDN8|9h5c53F^@+ckH@=55B)Axj0qTnkQxe^@dalYPz!KySevgPeD!;kPmcl!hna9z z1u$`>Vch`shb?qg1#sX}`gb19%mQYFi8Y};N=tG7Rv zsh%FKnJ;L$6#4x^D!puN^LW7*v@DrokKeUB(?ZMWXgr2xlIMu$*p@6=LAHW#yDPdQ zKA|Oo@9=V)J&vU)bs{wIqF@z;qsat)Xrm>&S|8-Eh56`xlc{Xocp_oo*p@$sLtH&?TIB2Bi9{Hvj5G!C0I zi9}NLAjD`qG5R!@WoJUoT1MjoGiOodSS-73G@crLA@4dS&=33?jPNsCS9HY1Lhf2X z{lw}^{(qkhWG$luJEy{{QFue`Hkw*}CVKS5TF?zU=dR3ow!0I$VfFc<*T$6GuyYjF zamNpI!|IoPd-#HuYjf*h(sh#_z{P(R$M3-+Pi~rAX_DpF*_B;`kt1jcVK01HUrc{) zN9#p=i`i!bO|qLv1T8e?UMk6Jsct{quj{WO$!VpOE3Xv0vvPo}h2~Il*)fvc;F0WJ z7|B|$tXp`NgT@9|r8Y)rj$j|GSnCxl@9be3{W@diZEc63g~n)Kn}Q_MzOGz0#ALI# z+X)P7*?$OHHb_FS!tR(rg!xqa63|iu1#aAc$eXiclPnG9SQzR1C2t8@OpdS9crI1O zRJ3ypgFC3FWZ2b`4G%;Up~aQ~0_C}Z=^vqF7~c849cdyB=tTQO%~_7H2yDd`A}(3Z zQf;2GJBNBe^z|UxLlm^Wd^#_>&JeUj>mpVxQ;C5`lCe})_CO@pSa0fpWGX$Yrw0*@ z)yQTBNv_M$Y)Numj*d*YZA*)wh33%rz>bkD*xIey?g5+;pRC0(``KNBmZvtKtmWWA zXyIl0;xj${V$ec$hQ6Htb#`?c&;FiWTv>o=SD+&`t`oFuNlQ`1x9omybI6=-OIlEm zgh=E2&us)PThfAaithW|AuXuyzP*XHY)K2*U`PSoU0l+Fdd&-_+In9Pq7B4ROy5dX zzEN=vucZ}_b6Fv8MM7NkhrouS{x$JH)-uMJJSiT;T6Wl9q>*mKsVYq#L`x~y zeLQD|W=1Q?g^ri>?Wb0=79?rT5JY;(1=^5hb5kUzx7&e8Ryubk5VY(~4iB+xHphuD zA}ZdzpCKw@xiF7u+LvUvVk~Pp?1vUw@|5Q5zm})?Kx=*d*Yb2fJp4WO^>5tPHTZ&- OmeB#iSJu)FTJRBx7l|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 fr 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 zurckgegeben. 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 diff --git a/sources/AtariST/GEM/VDI.FB.src b/sources/AtariST/GEM/VDI.FB.src new file mode 100644 index 0000000..a152e76 --- /dev/null +++ b/sources/AtariST/GEM/VDI.FB.src @@ -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 fr Rasteroperationen +14 Um mit verschiedenen memMDFBs arbeiten zu k”nnen, mssen 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 zurckgegeben, mssen 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 zurckliefern, mssen 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 diff --git a/sources/AtariST/INDEX.FB.src b/sources/AtariST/INDEX.FB.src new file mode 100644 index 0000000..1cbff56 --- /dev/null +++ b/sources/AtariST/INDEX.FB.src @@ -0,0 +1,34 @@ +Screen 0 not modified + 0 \\ *** Index *** 26may86we + 1 + 2 Diese File enth„lt nur das Wort INDEX , das frher 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 diff --git a/sources/AtariST/LINE_A.FB.src b/sources/AtariST/LINE_A.FB.src new file mode 100644 index 0000000..d4d4683 --- /dev/null +++ b/sources/AtariST/LINE_A.FB.src @@ -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 ber $A000 liefert unter anderem + 4 die Basisadresse dieser Variablen zurck. + 5 + 6 Wenn diese Definitionen in anderen Programmen mitgenutzt werden + 7 sollen, mssen 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 fr Fllmuster + 5 Bitmuster fr 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 fr Fllmuster. + 3 Enth„lt die Adresse des aktuellen Fllmusters. + 4 + 5 Zwei wichtige Fllmuster: Leer + 6 und voll + 7 + 8 Flag, ob die Koordinaten berprft 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 bergibt in A0 a_base, in A1 a_fonts + 4 Schreibmodus + 5 und die Farben der Planes 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 fr 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 geflltes 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 Fllmusters bergeben. + 8 + 9 Anzahl der Worte im Fllmuster +10 Anzahl der Planes fr Fllmuster +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 bercksichtigt (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 bergabe. Diese ist im File VDI.SCR an der entsprechenden + 4 Stelle enthalten. Da diese Funktion gegenber 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 fr die drei Aufl”sungsstufen. + 3 + 4 flag=0 bei 320x200, flag=1 bei 320x400, flag=2 bei 640x400 + 5 + 6 + 7 + 8 berprft, ob x und y innerhalb des Bildschirms liegen. + 9 Ansonsten erfolgt Abbruch. Diese Prfung kostet Zeit, erspart +10 aber Systemabstrze bei falschen Parametern. +11 +12 prft 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 ungeflltes 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 fr 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 Fllmuster bergeben + 6 + 7 Fllmustermaske + 8 und Anzahl der Planes bergeben + 9 Clipping-Window setzen +10 +11 +12 +13 Anzahl der Ecken +14 Eckpunkte ins ptsin-Array bernehmen +15 D3 und D4 enthalten die Koordianten des gr”žten Punktes +Screen 35 not modified + 0 \ polygon forts. 17sep86we + 1 + 2 fr die Fllfunktion + 3 Werte 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 gefllt 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 diff --git a/sources/AtariST/MISC.FB.src b/sources/AtariST/MISC.FB.src new file mode 100644 index 0000000..c9751d5 --- /dev/null +++ b/sources/AtariST/MISC.FB.src @@ -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 fr 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 fr 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, mssen Sie nach jedem Laden SETVEC eingeben. +12 (Dazu muž natrlich 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 prft, 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 dafr, 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 fr Strings anstelle von Variablen. + 7 + 8 + 9 BELL Dieses Wort ist selbsterkl„rend !!! +10 BLANK fllt 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 strzt das System gnadenlos ab. +15 Noch keine besonders elegante L”sung, aber besser als keine !! diff --git a/sources/AtariST/PATCH.FB.src b/sources/AtariST/PATCH.FB.src new file mode 100644 index 0000000..b3556fb --- /dev/null +++ b/sources/AtariST/PATCH.FB.src @@ -0,0 +1,68 @@ +Screen 0 not modified + 0 \\ *** Loadscreen fr 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 mssen 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 mssen 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 diff --git a/sources/AtariST/PRINTER.FB.src b/sources/AtariST/PRINTER.FB.src new file mode 100644 index 0000000..a6c89a0 --- /dev/null +++ b/sources/AtariST/PRINTER.FB.src @@ -0,0 +1,510 @@ +Screen 0 not modified + 0 \\ *** Printer-Interface *** 10oct86we + 1 + 2 Dieses File enth„lt das Printer-Interface. Die Definitionen fr + 3 die Druckersteuerung mssen 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 fr 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 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 mssen + 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 Grnden. 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 fr Multitasking) + 6 + 7 + 8 gibt Steuerzeichen an Drucker + 9 +10 Steuerzeichen fr 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 berspringen ein- und ausschalten. + 8 Es folgen die Steuercodes fr Fettdruck, Kursivschrift, Breit- + 9 schrift, Unterstreichen, Subscript und Superscript. +10 Diese mssen 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 ausgefhrt. +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 fr 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. (Zurckschalten 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 Lcken auf der rechten Seite mit dem Logo-Screen (0) 3 6 + 5 aufgefllt. + 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 fr das Multitasking, der den Zugang + 6 auf den Drucker fr 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 diff --git a/sources/AtariST/RAMDISK.FB.src b/sources/AtariST/RAMDISK.FB.src new file mode 100644 index 0000000..f6c0677 --- /dev/null +++ b/sources/AtariST/RAMDISK.FB.src @@ -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 zurckge- + 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 fr 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 bertr„gt, aber auch langwortweise 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 fr den Block BLK + 5 im File FILE. + 6 + 7 + 8 + 9 +10 +11 +12 Erzeugt einen Buffer fr 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 gewnschten Zahl von Buffern gefragt. Es wird ein Speicher= + 7 =bereich vom GEM-Dos angeordert und mit leeren Buffern + 8 gefllt. + 9 +10 +11 +12 +13 +14 +15 +Screen 24 not modified + 0 bp 17Aug86 + 1 + 2 Die alte R/W-Routine wird natrlich 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 geprft, 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 Verfgung. +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 diff --git a/sources/AtariST/RELOCATE.FB.src b/sources/AtariST/RELOCATE.FB.src new file mode 100644 index 0000000..3257a94 --- /dev/null +++ b/sources/AtariST/RELOCATE.FB.src @@ -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 Ausfhrungen 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 diff --git a/sources/AtariST/RFEDIT.FB.src b/sources/AtariST/RFEDIT.FB.src new file mode 100644 index 0000000..86b9c54 --- /dev/null +++ b/sources/AtariST/RFEDIT.FB.src @@ -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 s Select a new block + 7 p Previous block + 8 n Next block + 9 i ... Insert ... into line +10 ia ... Insert ... into line at column +11 x Clear (erase) the current block +12 Clear line +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 diff --git a/sources/AtariST/STARTUP.FB.src b/sources/AtariST/STARTUP.FB.src new file mode 100644 index 0000000..5bac239 --- /dev/null +++ b/sources/AtariST/STARTUP.FB.src @@ -0,0 +1,34 @@ +Screen 0 not modified + 0 \\ *** Loadscreen fr 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. Natrlich kann man auch die entsprechenden + 8 Zeilen ganz l”schen. Beachten Sie aber, daž bestimmte Files + 9 Grundlage fr andere sind. So wird zum Beispiel der Assembler +10 sehr h„ufig gebraucht, der hier "Intern" geladen wird. +11 +12 Fr 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 diff --git a/sources/AtariST/STRINGS.FB.src b/sources/AtariST/STRINGS.FB.src new file mode 100644 index 0000000..e2e6ced --- /dev/null +++ b/sources/AtariST/STRINGS.FB.src @@ -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 fr 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 fhrendem 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 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 ausgefhrt. +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 Zurckgeliefert 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 bercksichtigt 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 eingefgt. +Screen 11 not modified + 0 \ String operators 13oct86we + 1 + 2 Ein pointer auf die Adresse des Strings, zu dem ein anderer + 3 hinzugefgt 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 fr ,0"; kompiliert zus„tzlich (". +15 0" ist statesmart. diff --git a/sources/AtariST/TARGET.FB.src b/sources/AtariST/TARGET.FB.src new file mode 100644 index 0000000..3acdc36 --- /dev/null +++ b/sources/AtariST/TARGET.FB.src @@ -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 0 | Constant + 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 , 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 , 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 @ case? + 6 IF ." forw" ELSE - abort" ??" ." res" THEN + 7 2+ dup @ 5 u.r + 8 2+ @ ?dup + 9 IF dup @ case? +10 IF ." fdef" ELSE - 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 @ = 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 @ = + 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> over ! 2+ ! ; + 9 +10 : resdoes> ( cfa.ghost cfa.target -) +11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +13 ' >body ! +14 ] Does> [ here 4- 0 ] @ T , H ; +15 ' >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 : - cfa ) H g' dup @ - 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 -2 H 2swap ; + 8 immediate restrict + 9 | : (repeat T 2 ?pairs 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 diff --git a/sources/AtariST/TASKER.FB.src b/sources/AtariST/TASKER.FB.src new file mode 100644 index 0000000..fd26c80 --- /dev/null +++ b/sources/AtariST/TASKER.FB.src @@ -0,0 +1,136 @@ +Screen 0 not modified + 0 \\ *** Multitasker *** bp 12oct86 + 1 + 2 Dieses File enth„lt die Worte fr 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 ausfhrliches 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 diff --git a/sources/AtariST/TOOLS.FB.src b/sources/AtariST/TOOLS.FB.src new file mode 100644 index 0000000..eb2cf20 --- /dev/null +++ b/sources/AtariST/TOOLS.FB.src @@ -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 \ 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 ! ; +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 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 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 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+ 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