mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-09-07 04:54:30 +00:00
2262 lines
145 KiB
Plaintext
2262 lines
145 KiB
Plaintext
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
|