6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2024-11-26 02:49:17 +00:00
Code Issues Projects Releases Wiki Activity
b6786a8df0
VolksForth/sources/AtariST/FORTH83.FB.src

2262 lines
145 KiB
Plaintext
Raw Normal View History

Atari ST source files
2020-06-20 16:59:55 +00:00
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 \ F<>r 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 ( -- addr ) here ;
5 : <resolve ( addr -- ) here - , ;
6 : ?pairs ( n1 n2 -- ) - abort" unstructured" ;
7
8
9
10
11
12
13
14
15
Screen 37 not modified
0 \ case? 19mar86we
1
2 Code case? ( 16b1 16b2 -- 16b1 false / true )
3 SP )+ D0 move SP ) D0 cmp yes beq SP -) clr
4 Next end-code
5
6
7 \\
8 : case? ( 16b1 16b2 -- 16b1 false / true )
9 over = dup IF nip THEN ;
10
11
12
13
14
15
Screen 38 not modified
0 \ Branching 24nov85we
1
2 : IF compile ?branch >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 2 ; immediate restrict
7 : WHILE 2 ?pairs 2 compile ?branch >mark
8 -2 2swap ; immediate restrict
9 | : (reptil <resolve
10 BEGIN dup -2 = WHILE drop >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 <20> c, Ascii <20> c, Ascii <20> c,
4 Ascii <20> c, Ascii <20> c, Ascii <20> 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<6D> 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 move<sr D0 $0D # btst ( src<>dst) 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
Reference in New Issue Copy Permalink