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