mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-07-09 14:29:01 +00:00
2177 lines
140 KiB
Plaintext
2177 lines
140 KiB
Plaintext
Screen 0 not modified
|
|
0 \\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87
|
|
1
|
|
2 Entwicklung des volksFORTH-83 von
|
|
3 K. Schleisiek, B. Pennemann,
|
|
4 G. Rehfeld, D. Weineck, U. Hoffmann
|
|
5
|
|
6 Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann
|
|
7
|
|
8 Dieses File enthaelt den kompletten Sourcetext des Kern-Systems
|
|
9 fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.
|
|
10 Mit Hilfe eines Target-Compilers wird daraus das volksFORTH-
|
|
11 System erzeugt, daher finden sich an einigen Stellen Anweisungen
|
|
12 an den Target-Compiler, die fuer das Verstaendnis des Systems
|
|
13 nicht wichtig sind.
|
|
14 Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins-
|
|
15 besondere die Bdos-Schnittstelle fuer Disk-IO im Kern.
|
|
Screen 1 not modified
|
|
0 \ CP/M 2.2 volksForth Load Screen 27Nov87
|
|
1
|
|
2 Onlyforth
|
|
3 $9000 displace !
|
|
4 Target definitions $100 here!
|
|
5
|
|
6
|
|
7 1 $74 +thru \ Standard 8080-System
|
|
8
|
|
9 cr .( unresolved: ) .unresolved ( ' .blk is .status )
|
|
10
|
|
11 save-target KERNEL.COM
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 2 not modified
|
|
0 \ FORTH Preamble and ID uho 19May2005
|
|
1
|
|
2 Assembler
|
|
3
|
|
4 nop 0 jmp here 2- >label >boot
|
|
5 nop 0 jmp here 2- >label >cold
|
|
6 nop 0 jmp here 2- >label >restart
|
|
7
|
|
8 here dup origin!
|
|
9 \ Hier beginnen die Kaltstartwerte der Benutzervariablen
|
|
10
|
|
11 6 rst 0 jmp end-code \ for multitasker
|
|
12
|
|
13 $100 allot
|
|
14
|
|
15 | Create logo ," volksFORTH-83 rev. 3.80a"
|
|
Screen 3 not modified
|
|
0 \ Assembler Labels Next Forth-Register 29Jun86
|
|
1
|
|
2 Label dpush D push Label hpush H push
|
|
3 Label >next
|
|
4 IP ldax IP inx A L mov IP ldax IP inx A H mov
|
|
5 Label >next1
|
|
6 M E mov H inx M D mov xchg pchl
|
|
7 end-code
|
|
8
|
|
9 Variable RP
|
|
10 Variable UP
|
|
11 \ IP in BC
|
|
12 \ W in DE
|
|
13 \ SP in SP
|
|
14 Variable IPsave
|
|
15
|
|
Screen 4 not modified
|
|
0 \ Assembler Macros 20Oct86
|
|
1 Compiler Assembler also definitions Forth
|
|
2 : Next T >next jmp [ Forth ] ;
|
|
3 T hpush Forth Constant hpush T dpush Forth Constant dpush
|
|
4 T >next Forth Constant >next
|
|
5
|
|
6 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high )
|
|
7 H dcx 1+ M mov ( low ) RP shld [ Forth ] ;
|
|
8
|
|
9 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx
|
|
10 M swap mov ( high ) H inx RP shld [ Forth ] ;
|
|
11 \ rpush und rpop gehen nicht mit HL
|
|
12
|
|
13 : mvx ( src dest -- )
|
|
14 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ;
|
|
15 Target
|
|
Screen 5 not modified
|
|
0 \ recover ;c: noop 20Oct86
|
|
1
|
|
2 Create recover Assembler
|
|
3 W pop IP rpush W IP mvx
|
|
4 Next end-code
|
|
5
|
|
6 Compiler Assembler also definitions Forth
|
|
7
|
|
8 : ;c: 0 T recover call end-code ] [ Forth ] ;
|
|
9
|
|
10 Target
|
|
11
|
|
12 | Code di di Next end-code
|
|
13 | Code ei ei Next end-code
|
|
14
|
|
15 Code noop >next here 2- ! end-code
|
|
Screen 6 not modified
|
|
0 \ User variables 04Oct87
|
|
1
|
|
2 Constant origin 8 uallot drop \ Multitasker
|
|
3 \ Felder: entry link spare SPsave
|
|
4 \ Laenge kompatibel zum 68000 und 6502 volksFORTH
|
|
5 User s0
|
|
6 User r0
|
|
7 User dp
|
|
8 User offset 0 offset !
|
|
9 User base $0A base !
|
|
10 User output
|
|
11 User input
|
|
12 User errorhandler \ pointer for Abort" -code
|
|
13 User voc-link
|
|
14 User udp \ points to next free addr in User
|
|
15
|
|
Screen 7 not modified
|
|
0 \ manipulate system pointers 11Jun86
|
|
1
|
|
2 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code
|
|
3
|
|
4 Code sp! ( addr --) H pop sphl Next end-code
|
|
5
|
|
6
|
|
7 Code up@ ( -- addr) UP lhld hpush jmp end-code
|
|
8
|
|
9 Code up! ( addr --) H pop UP shld Next end-code
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 8 not modified
|
|
0 \ manipulate returnstack 11Jun86
|
|
1
|
|
2 Code rp@ ( -- addr ) RP lhld hpush jmp end-code
|
|
3
|
|
4 Code rp! ( addr -- ) H pop RP shld Next end-code
|
|
5
|
|
6
|
|
7 Code >r ( 16b -- ) D pop D rpush Next end-code restrict
|
|
8
|
|
9 Code r> ( -- 16b ) D rpop D push Next end-code restrict
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 9 not modified
|
|
0 \ r@ rdrop exit unnest ?exit 07Oct87
|
|
1 Code r@ ( -- 16b )
|
|
2 RP lhld M E mov H inx M D mov D push Next end-code
|
|
3
|
|
4 Code rdrop
|
|
5 RP lhld H inx H inx RP shld Next end-code restrict
|
|
6
|
|
7 Code exit Label >exit IP rpop Next end-code
|
|
8 Code unnest >exit here 2- !
|
|
9
|
|
10 Code ?exit ( flag -- )
|
|
11 H pop H A mov L ora >exit jnz Next end-code
|
|
12
|
|
13 Code 0=exit ( flag -- )
|
|
14 H pop H A mov L ora >exit jz Next end-code
|
|
15 \ : ?exit ( flag -- ) IF rdrop THEN ;
|
|
Screen 10 not modified
|
|
0 \ execute perform 11Jun86 18Nov87
|
|
1
|
|
2 Code execute ( cfa -- )
|
|
3 H pop >Next1 jmp end-code
|
|
4
|
|
5 Code perform ( 'cfa -- )
|
|
6 H pop M A mov H inx M H mov A L mov >Next1 jmp
|
|
7 end-code
|
|
8
|
|
9
|
|
10 \\
|
|
11 : perform ( addr -- ) @ execute ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 11 not modified
|
|
0 \ c@ c! ctoggle 07Oct87
|
|
1
|
|
2 Code c@ ( addr -- 8b )
|
|
3 H pop M L mov 0 H mvi hpush jmp end-code
|
|
4
|
|
5 Code c! ( 16b addr -- )
|
|
6 H pop D pop E M mov Next end-code
|
|
7
|
|
8 Code flip ( 16b1 -- 16b2 )
|
|
9 H pop H A mov L H mov A L mov Hpush jmp end-code
|
|
10
|
|
11 Code ctoggle ( 8b addr -- )
|
|
12 H pop D pop M A mov E xra A M mov Next end-code
|
|
13
|
|
14 \\
|
|
15 : ctoggle ( 8b addr --) under c@ xor swap c! ;
|
|
Screen 12 not modified
|
|
0 \ @ ! 2@ 2! 11Jun86 18Nov87
|
|
1
|
|
2 Code @ ( addr -- 16b ) H pop Label fetch
|
|
3 M E mov H inx M D mov D push Next end-code
|
|
4
|
|
5 Code ! ( 16b addr -- )
|
|
6 H pop D pop E M mov H inx D M mov Next end-code
|
|
7
|
|
8 Code 2@ ( addr -- 32b ) H pop H push
|
|
9 H inx H inx M E mov H inx M D mov H pop D push
|
|
10 M E mov H inx M D mov D push Next end-code
|
|
11
|
|
12 Code 2! ( 32b addr -- ) H pop
|
|
13 D pop E M mov H inx D M mov H inx
|
|
14 D pop E M mov H inx D M mov Next end-code
|
|
15
|
|
Screen 13 not modified
|
|
0 \ +! drop swap 11Jun86 18Nov87
|
|
1
|
|
2 Code +! ( 16b addr -- ) H pop
|
|
3 Label +store D pop
|
|
4 M A mov E add A M mov H inx
|
|
5 M A mov D adc A M mov Next end-code
|
|
6
|
|
7 \ : +! ( n addr -- ) under @ + swap ! ;
|
|
8
|
|
9
|
|
10 Code drop ( 16b -- ) H pop Next end-code
|
|
11
|
|
12 Code swap ( 16b1 16b2 -- 16b2 16b1 )
|
|
13 H pop xthl hpush jmp end-code
|
|
14
|
|
15
|
|
Screen 14 not modified
|
|
0 \ dup ?dup 16May86
|
|
1
|
|
2 Code dup ( 16b -- 16b 16b )
|
|
3 H pop H push hpush jmp end-code
|
|
4
|
|
5 Code ?dup ( 16b -- 16b 16b / false)
|
|
6 H pop H A mov L ora 0<> ?[ H push ]?
|
|
7 hpush jmp end-code
|
|
8
|
|
9 \\
|
|
10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ;
|
|
11
|
|
12 : dup ( 16b -- 16b 16b ) sp@ @ ;
|
|
13
|
|
14
|
|
15
|
|
Screen 15 not modified
|
|
0 \ over rot nip under 11Jun86
|
|
1
|
|
2 Code over ( 16b1 16b2 - 16b1 16b2 16b1 )
|
|
3 D pop H pop H push dpush jmp end-code
|
|
4 Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 )
|
|
5 D pop H pop xthl dpush jmp end-code
|
|
6 Code nip ( 16b1 16b2 -- 16b2)
|
|
7 H pop D pop hpush jmp end-code
|
|
8 Code under ( 16b1 16b2 -- 16b2 16b1 16b2)
|
|
9 H pop D pop H push dpush jmp end-code
|
|
10
|
|
11 \\
|
|
12 : over >r swap r> swap ;
|
|
13 : rot >r dup r> swap ;
|
|
14 : nip swap drop ;
|
|
15 : under swap over ;
|
|
Screen 16 not modified
|
|
0 \ -rot pick roll -roll 11Jun86
|
|
1 Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )
|
|
2 H pop D pop xthl H push D push Next end-code
|
|
3
|
|
4 Code pick ( n -- 16b.n )
|
|
5 H pop H dad SP dad
|
|
6 M E mov H inx M D mov D push Next end-code
|
|
7
|
|
8 : roll ( n -- )
|
|
9 dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ;
|
|
10
|
|
11 : -roll ( n -- ) >r dup sp@ dup 2+
|
|
12 dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ;
|
|
13 \\
|
|
14 : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ;
|
|
15 : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ;
|
|
Screen 17 not modified
|
|
0 \ double word stack manipulation 09May86
|
|
1 Code 2swap ( 32b1 32b2 -- 32b2 32b1)
|
|
2 H pop D pop xthl H push
|
|
3 5 H lxi SP dad M A mov D M mov A D mov
|
|
4 H dcx M A mov E M mov A E mov H pop dpush jmp
|
|
5 end-code
|
|
6
|
|
7 Code 2drop ( 32b -- ) H pop H pop Next end-code
|
|
8
|
|
9 Code 2dup ( 32b -- 32b 32b)
|
|
10 H pop D pop D push H push dpush jmp end-code
|
|
11
|
|
12 \\
|
|
13 : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ;
|
|
14 : 2drop ( 32b -- ) drop drop ;
|
|
15 : 2dup ( 32b -- 32b 32b) over over ;
|
|
Screen 18 not modified
|
|
0 \ + and or xor not 09May86
|
|
1 Code + ( n1 n2 -- n3 )
|
|
2 H pop D pop D dad hpush jmp end-code
|
|
3 Code or ( 16b1 16b2 -- 16b3 )
|
|
4 H pop D pop H A mov D ora A H mov
|
|
5 L A mov E ora A L mov hpush jmp end-code
|
|
6 Code and ( 16b1 16b2 -- 16b3 )
|
|
7 H pop D pop H A mov D ana A H mov
|
|
8 L A mov E ana A L mov hpush jmp end-code
|
|
9 Code xor ( 16b1 16b2 -- 16b3 )
|
|
10 H pop D pop H A mov D xra A H mov
|
|
11 L A mov E xra A L mov hpush jmp end-code
|
|
12 Code not ( 16b1 -- 16b2 ) H pop Label >not
|
|
13 H A mov cma A H mov L A mov cma A L mov
|
|
14 hpush jmp end-code
|
|
15
|
|
Screen 19 not modified
|
|
0 \ - negate 16May86
|
|
1
|
|
2 Code - ( n1 n2 -- n3 )
|
|
3 D pop H pop
|
|
4 L A mov E sub A L mov
|
|
5 H A mov D sbb A H mov hpush jmp end-code
|
|
6
|
|
7 Code negate ( n1 -- n2 )
|
|
8 H pop H dcx >not jmp end-code
|
|
9
|
|
10 \\
|
|
11 : - ( n1 n2 -- n3 ) negate + ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 20 not modified
|
|
0 \ dnegate d+ 10Mar86 18Nov87
|
|
1
|
|
2 Code dnegate ( d1 -- -d1 ) H pop
|
|
3 Label >dnegate
|
|
4 D pop A sub E sub A E mov 0 A mvi D sbb
|
|
5 A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb
|
|
6 A H mov dpush jmp end-code
|
|
7
|
|
8 Code d+ ( d1 d2 -- d3)
|
|
9 6 H lxi SP dad M E mov C M mov H inx
|
|
10 M D mov B M mov B pop H pop D dad xchg
|
|
11 H pop L A mov C adc A L mov H A mov B adc
|
|
12 A H mov B pop dpush jmp end-code
|
|
13
|
|
14
|
|
15
|
|
Screen 21 not modified
|
|
0 \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86
|
|
1 Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code
|
|
2 Code 2+ ( n1 -- n2 )
|
|
3 H pop H inx H inx hpush jmp end-code
|
|
4 Code 3+ ( n1 -- n2 )
|
|
5 H pop H inx H inx H inx hpush jmp end-code
|
|
6 Code 4+ ( n1 -- n2 )
|
|
7 H pop 4 D lxi D dad hpush jmp end-code
|
|
8 | Code 6+ ( n1 -- n2 )
|
|
9 H pop 6 D lxi D dad hpush jmp end-code
|
|
10 Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code
|
|
11 Code 2- ( n1 -- n2 )
|
|
12 H pop H dcx H dcx hpush jmp end-code
|
|
13 Code 4- ( n1 -- n2 )
|
|
14 H pop -4 D lxi D dad hpush jmp end-code
|
|
15
|
|
Screen 22 not modified
|
|
0 \ number Constants 07Oct87
|
|
1 -1 Constant true 0 Constant false
|
|
2
|
|
3 0 ( -- 0 ) Constant 0
|
|
4 1 ( -- 1 ) Constant 1
|
|
5 2 ( -- 2 ) Constant 2
|
|
6 3 ( -- 3 ) Constant 3
|
|
7 4 ( -- 4 ) Constant 4
|
|
8 -1 ( -- -1 ) Constant -1
|
|
9
|
|
10 Code on ( addr -- ) H pop $FF A mvi
|
|
11 Label set A M mov H inx A M mov Next
|
|
12 Code off ( addr -- ) H pop A xra set jmp end-code
|
|
13
|
|
14 \ : on ( addr -- ) true swap ! ;
|
|
15 \ : off ( addr -- ) false swap ! ;
|
|
Screen 23 not modified
|
|
0 \ words for number literals 16May86
|
|
1
|
|
2 Code lit ( -- 16b )
|
|
3 IP ldax A L mov IP inx IP ldax A H mov IP inx
|
|
4 hpush jmp end-code
|
|
5
|
|
6 Code clit ( -- 8b )
|
|
7 IP ldax A L mov 0 H mvi IP inx hpush jmp
|
|
8 end-code
|
|
9
|
|
10 : Literal ( 16b -- )
|
|
11 dup $FF00 and IF compile lit , exit THEN
|
|
12 compile clit c, ; immediate restrict
|
|
13
|
|
14
|
|
15
|
|
Screen 24 not modified
|
|
0 \ comparision words 18Nov87
|
|
1 Label (u< ( HL,DE -> HL u< DE c,z )
|
|
2 H A mov D cmp rnz L A mov E cmp ret
|
|
3 Label (< ( HL,DE -> HL < DE c,z )
|
|
4 H A mov D xra (u< jp D A mov H cmp ret
|
|
5
|
|
6 Label yes true H lxi hpush jmp
|
|
7 Code u< ( u1 u2 -- flag ) D pop H pop
|
|
8 Label uless (u< call yes jc
|
|
9 Label no false H lxi hpush jmp
|
|
10
|
|
11 Code < ( n1 n2 -- flag ) D pop H pop
|
|
12 Label less (< call yes jc no jmp end-code
|
|
13
|
|
14 Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code
|
|
15 Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code
|
|
Screen 25 not modified
|
|
0 \ comparision words 18Nov87
|
|
1 Code 0< ( n1 n2 -- flag ) H pop
|
|
2 Label negative H dad yes jc no jmp end-code
|
|
3
|
|
4 Code 0> ( n -- flag ) H pop H A mov A ora no jm
|
|
5 L ora yes jnz no jmp end-code
|
|
6
|
|
7 Code 0= ( n -- flag ) H pop
|
|
8 Label zero= H A mov L ora yes jz no jmp end-code
|
|
9
|
|
10 Code 0<> ( n -- flag )
|
|
11 H pop H A mov L ora yes jnz no jmp end-code
|
|
12
|
|
13 Code = ( n1 n2 -- flag ) H pop D pop
|
|
14 L A mov E cmp no jnz
|
|
15 H A mov D cmp no jnz yes jmp end-code
|
|
Screen 26 not modified
|
|
0 \\ comparision words high level 18Nov87
|
|
1 : 0< ( n1 -- flag ) 8000 and 0<> ;
|
|
2 : > ( n1 n2 -- flag ) swap < ;
|
|
3 : 0> ( n -- flag ) negate 0< ;
|
|
4 : 0<> ( n -- flag ) 0= not ;
|
|
5 : u> ( u1 u2 -- flag ) swap u< ;
|
|
6 : = ( n1 n2 -- flag ) - 0= ;
|
|
7 : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ;
|
|
8 | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ;
|
|
9 : min ( n1 n2 -- n3 ) 2dup > minimax ;
|
|
10 : max ( n1 n2 -- n3 ) 2dup < minimax ;
|
|
11 : umax ( u1 u2 -- u3 ) 2dup u< minimax ;
|
|
12 : umin ( u1 u2 -- u3 ) 2dup u> minimax ;
|
|
13 : extend ( n -- d ) dup 0< ;
|
|
14 : dabs ( d -- ud ) extend IF dnegate THEN ;
|
|
15 : abs ( n -- u) extend IF negate THEN ;
|
|
Screen 27 not modified
|
|
0 \ uwthin double number comparison words 18Nov87
|
|
1
|
|
2 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl
|
|
3 (u< call cs ?[ H pop no jmp ]?
|
|
4 D pop (u< call yes jc no jmp end-code
|
|
5
|
|
6 Code d0= ( d -- flag ) H pop
|
|
7 H A mov L ora H pop no jnz zero= jmp end-code
|
|
8
|
|
9 : d= ( d1 d2 -- flag ) rot = -rot = and ;
|
|
10 : d< ( d1 d2 -- flag )
|
|
11 rot 2dup = IF 2drop u< exit THEN > nip nip ;
|
|
12
|
|
13
|
|
14 \\
|
|
15 : d0= ( d -- flag ) or 0= ;
|
|
Screen 28 not modified
|
|
0 \ minimum maximum 18Nov87
|
|
1
|
|
2 Code umax ( u1 u2 -- u3 )
|
|
3 H pop D pop (u< call
|
|
4 Label minimax cs ?[ xchg ]? hpush jmp end-code
|
|
5
|
|
6 Code umin ( u1 u2 -- u3 )
|
|
7 H pop D pop (u< call cmc minimax jmp end-code
|
|
8
|
|
9 Code max ( n1 n2 -- n3 )
|
|
10 H pop D pop (< call minimax jmp end-code
|
|
11
|
|
12 Code min ( n1 n2 -- n3 )
|
|
13 H pop D pop (< call cmc minimax jmp end-code
|
|
14
|
|
15
|
|
Screen 29 not modified
|
|
0 \ sign extension absolute values 18Nov87
|
|
1
|
|
2 Code extend ( n -- d ) H pop H push negative jmp end-code
|
|
3
|
|
4 Code abs ( a -- u ) H pop H A mov A ora
|
|
5 hpush jp H dcx >not jmp end-code
|
|
6
|
|
7 Code dabs ( d -- ud ) H pop H A mov A ora
|
|
8 hpush jp >dnegate jmp end-code
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 30 not modified
|
|
0 \ branch ?branch 20Nov87
|
|
1
|
|
2 Code branch ( -- ) Label >branch
|
|
3 IP H mvx M E mov H inx M D mov H dcx
|
|
4 D dad H IP mvx Next end-code
|
|
5
|
|
6 Code ?branch ( fl -- )
|
|
7 H pop H A mov L ora >branch jz
|
|
8 IP inx IP inx Next end-code
|
|
9
|
|
10
|
|
11 \\
|
|
12 : branch r> dup @ + >r ;
|
|
13
|
|
14
|
|
15
|
|
Screen 31 not modified
|
|
0 \ loop primitives 11Jun86 20Nov87
|
|
1
|
|
2 Code bounds ( start count -- limit start )
|
|
3 H pop D pop D dad H push D push Next end-code
|
|
4
|
|
5 Code endloop
|
|
6 RP lhld 6 D lxi D dad RP shld next end-code restrict
|
|
7
|
|
8 \\ dodo puts "index | limit | adr.of.DO" on return-stack
|
|
9 : bounds ( start count -- limit start ) over + swap ;
|
|
10
|
|
11 | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ;
|
|
12
|
|
13 : (do ( limit start -- ) over - dodo ; restrict
|
|
14 : (?do ( limit start -- ) over - ?dup IF dodo THEN
|
|
15 r> dup @ + >r drop ; restrict
|
|
Screen 32 not modified
|
|
0 \ loop primitives 20Nov87
|
|
1
|
|
2 Code (do ( limit start -- ) H pop D pop
|
|
3 Label >do
|
|
4 L A mov E sub A L mov
|
|
5 H A mov D sbb A H mov
|
|
6 H push IP inx IP inx
|
|
7 RP lhld H dcx IP M mov H dcx IP' M mov
|
|
8 H dcx D M mov H dcx E M mov
|
|
9 D pop H dcx D M mov H dcx E M mov RP shld
|
|
10 Next end-code restrict
|
|
11
|
|
12 Code (?do ( limit start -- ) H pop D pop
|
|
13 H A mov D cmp >do jnz
|
|
14 L A mov E cmp >do jnz >branch jmp
|
|
15 end-code restrict
|
|
Screen 33 not modified
|
|
0 \ (loop (+loop 14May86 20Nov87
|
|
1
|
|
2 Code (loop
|
|
3 RP lhld M inr 0= ?[ H inx M inr >next jz ]?
|
|
4 Label doloop RP lhld 4 D lxi D dad
|
|
5 M IP' mov H inx M IP mov Next
|
|
6 end-code restrict
|
|
7
|
|
8 Code (+loop
|
|
9 RP lhld D pop
|
|
10 M A mov E add A M mov H inx
|
|
11 M A mov D adc A M mov
|
|
12 rar D xra doloop jp Next
|
|
13 end-code restrict
|
|
14
|
|
15
|
|
Screen 34 not modified
|
|
0 \ loop indices 06May86 20Nov87
|
|
1
|
|
2 Code I ( -- n )
|
|
3 RP lhld
|
|
4 Label >I M E mov H inx M D mov D push
|
|
5 H inx M E mov H inx M D mov H pop D dad
|
|
6 hpush jmp
|
|
7 end-code
|
|
8
|
|
9 Code J ( -- n )
|
|
10 RP lhld 6 D lxi D dad >I jmp end-code
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 35 not modified
|
|
0 \ interpretive conditionals UH 25Jan88
|
|
1
|
|
2 | Create: remove>> r> rp! ;
|
|
3 | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp!
|
|
4 swap >r remove>> >r swap >r dup >r swap cmove r> ;
|
|
5
|
|
6 | Variable saved-dp 0 saved-dp !
|
|
7
|
|
8 | Variable level 0 level !
|
|
9
|
|
10 | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit
|
|
11 1 level ! here saved-dp ! ] ;
|
|
12
|
|
13 | : -level ( -- ) state @ 0= Abort" unstructured"
|
|
14 level @ 0=exit -1 level +! level @ ?exit compile unnest
|
|
15 [compile] [ saved-dp @ here over dp ! over - >>r >r ;
|
|
Screen 36 not modified
|
|
0 \ resolve loops and branches UH 25Jan88
|
|
1
|
|
2 : >mark ( -- addr ) here 0 , ;
|
|
3
|
|
4 : +>mark ( acf -- addr ) +level , >mark ;
|
|
5
|
|
6 : >resolve ( addr -- ) here over - swap ! -level ;
|
|
7
|
|
8 : <mark ( -- addr ) +level here ;
|
|
9
|
|
10 : <resolve ( addr -- ) here - , -level ;
|
|
11
|
|
12 : ?pairs ( n1 n2 -- ) - Abort" unstructured" ;
|
|
13
|
|
14
|
|
15
|
|
Screen 37 not modified
|
|
0 \ case? 14May86
|
|
1
|
|
2 Code case? ( 16b1 16b2 -- 16b1 false / true )
|
|
3 H pop D pop
|
|
4 H A mov D cmp 0= ?[ L A mov E cmp yes jz ]?
|
|
5 D push no jmp end-code
|
|
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 UH 25Jan88
|
|
1
|
|
2 : IF ['] ?branch +>mark 1 ; immediate
|
|
3 : THEN abs 1 ?pairs >resolve ; immediate
|
|
4 : ELSE 1 ?pairs ['] branch +>mark swap
|
|
5 >resolve -1 ; immediate
|
|
6 : BEGIN <mark 2 ; immediate
|
|
7 : WHILE 2 ?pairs 2 ['] ?branch +>mark
|
|
8 -2 2swap ; immediate
|
|
9
|
|
10 | : (reptil <resolve
|
|
11 BEGIN dup -2 = WHILE drop >resolve REPEAT ;
|
|
12
|
|
13 : REPEAT 2 ?pairs compile branch (reptil ; immediate
|
|
14 : UNTIL 2 ?pairs compile ?branch (reptil ; immediate
|
|
15
|
|
Screen 39 not modified
|
|
0 \ Loops UH 25Jan88
|
|
1
|
|
2 : DO ['] (do +>mark 3 ; immediate
|
|
3 : ?DO ['] (?do +>mark 3 ; immediate
|
|
4 : LOOP 3 ?pairs compile (loop compile endloop >resolve ;
|
|
5 immediate
|
|
6 : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ;
|
|
7 immediate
|
|
8
|
|
9 Code LEAVE
|
|
10 RP lhld 4 D lxi D dad M E mov H inx M D mov
|
|
11 H inx RP shld xchg H dcx M D mov H dcx M E mov
|
|
12 D dad H IP mvx Next end-code restrict
|
|
13
|
|
14 \\ Returnstack: calladr | index limit | adr of DO
|
|
15 : LEAVE endloop r> 2- dup @ + >r ; restrict
|
|
Screen 40 not modified
|
|
0 \ um* 16May86
|
|
1 Label (um* 0 H lxi ( 0=Teil-Produkt )
|
|
2 4 C mvi ( Schleifen-Zaehler )
|
|
3 [[ H dad ( Schiebe HL 24 bits nach links )
|
|
4 ral cs ?[ D dad 0 aci ]?
|
|
5 H dad ral cs ?[ D dad 0 aci ]?
|
|
6 C dcr 0= ?] ret
|
|
7
|
|
8 Code um* ( u1 u2 -- ud )
|
|
9 D pop H pop B push H B mov L A mov (um* call
|
|
10 H push A H mov B A mov H B mov (um* call
|
|
11 D pop D C mov B dad 0 aci L D mov H L mov
|
|
12 A H mov B pop dpush jmp end-code
|
|
13
|
|
14
|
|
15
|
|
Screen 41 not modified
|
|
0 \ m* * 2* 2/ 16May86
|
|
1
|
|
2 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN
|
|
3 swap dup 0< IF negate r> not >r THEN
|
|
4 um* r> IF dnegate THEN ;
|
|
5
|
|
6 : * ( n1 n2 - prod ) um* drop ;
|
|
7
|
|
8 Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code
|
|
9
|
|
10 Code 2/ ( n -- n/2 )
|
|
11 H pop H A mov rlc rrc rar A H mov
|
|
12 L A mov rar A L mov hpush jmp end-code
|
|
13 \\
|
|
14 : 2* ( n -- 2*n ) 2 * ;
|
|
15 : 2/ ( n -- n/2 ) 2 / ;
|
|
Screen 42 not modified
|
|
0 \ um/mod 14May86
|
|
1 Label usl0
|
|
2 A E mov H A mov C sub A H mov E A mov B sbb
|
|
3 cs ?[ H A mov C add A H mov E A mov D dcr rz
|
|
4 Label usla
|
|
5 H dad ral usl0 jnc
|
|
6 A E mov H A mov C sub A H mov E A mov B sbb
|
|
7 ]? L inr D dcr usla jnz ret
|
|
8 Label usbad -1 H lxi B pop H push hpush jmp
|
|
9 Code um/mod ( d1 n1 -- rem quot )
|
|
10 IP H mvx B pop D pop xthl xchg
|
|
11 L A mov C sub H A mov B sbb usbad jnc
|
|
12 H A mov L H mov D L mov 8 D mvi D push
|
|
13 usla call D pop H push E L mov usla call
|
|
14 A D mov H E mov B pop C H mov B pop
|
|
15 D push hpush jmp end-code
|
|
Screen 43 not modified
|
|
0 \ m/mod 16May86
|
|
1
|
|
2 : m/mod ( d n -- mod quot)
|
|
3 dup >r abs over 0< IF under + swap THEN
|
|
4 um/mod r@ 0< IF negate over IF swap r@ + swap 1-
|
|
5 THEN THEN rdrop ;
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 44 not modified
|
|
0 \ /mod / mod */mod */ u/mod ud/mod 16May86
|
|
1
|
|
2 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ;
|
|
3
|
|
4 : / ( n1 n2 -- quot ) /mod nip ;
|
|
5
|
|
6 : mod ( n1 n2 -- rem ) /mod drop ;
|
|
7
|
|
8 : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ;
|
|
9
|
|
10 : */ ( n1 n2 n3 -- quot ) */mod nip ;
|
|
11
|
|
12 : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ;
|
|
13
|
|
14 : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
|
|
15 um/mod r> ;
|
|
Screen 45 not modified
|
|
0 \ cmove cmove> 16May86 18Nov87
|
|
1
|
|
2 Code cmove ( from to count -- ) IP H mvx IPsave shld
|
|
3 B pop D pop H pop
|
|
4 Label (cmove
|
|
5 [[ B A mov C ora 0= not ?[[
|
|
6 M A mov H INX D stax D inx B dcx
|
|
7 ]]? IPsave lhld H IP mvx Next end-code
|
|
8
|
|
9 Code cmove> ( from to count -- ) IP H mvx IPsave shld
|
|
10 B pop D pop H pop
|
|
11 Label (cmove>
|
|
12 B dad H dcx xchg B dad H dcx xchg
|
|
13 [[ B A mov C ora 0= not ?[[
|
|
14 M A mov H dcx D stax D dcx B dcx
|
|
15 ]]? IPsave lhld H IP mvx Next end-code
|
|
Screen 46 not modified
|
|
0 \ move place count 17Oct86 18Nov87
|
|
1
|
|
2 Code move ( from to quan -- )
|
|
3 IP H mvx Ipsave shld B pop D pop H pop
|
|
4 Label domove (u< call (cmove jnc (cmove> jmp end-code
|
|
5
|
|
6 | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld
|
|
7 D pop B pop H pop
|
|
8 B push D push D inx domove jmp end-code
|
|
9
|
|
10 : place ( addr len to -- ) (place c! ;
|
|
11
|
|
12 Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi
|
|
13 H inx H push D push Next end-code
|
|
14
|
|
15
|
|
Screen 47 not modified
|
|
0 \ fill erase 18Nov87
|
|
1
|
|
2 Code fill ( addr quan 8b -- )
|
|
3 IP H mvx IPsave shld D pop B pop H pop
|
|
4 [[ B A mov C ora 0<> ?[[
|
|
5 E M mov H inx B dcx
|
|
6 ]]? IPsave lhld H IP mvx Next end-code
|
|
7
|
|
8 : erase ( addr quan --) 0 fill ;
|
|
9
|
|
10 \\ : fill ( addr quan 8b -- )
|
|
11 swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ;
|
|
12 : count ( adr -- adr+1 len ) dup 1+ swap c@ ;
|
|
13 : move ( from to quan -- )
|
|
14 >r 2dup u< IF r> cmove> exit THEN r> cmove ;
|
|
15 : place ( addr len to --) over >r rot over 1+ r> move c! ;
|
|
Screen 48 not modified
|
|
0 \ here allot , c, pad compile 11Jun86 18Nov87
|
|
1
|
|
2 Code here ( -- addr ) user' dp D lxi
|
|
3 UP lhld D dad fetch jmp end-code
|
|
4
|
|
5 Code allot ( n -- ) user' dp D lxi
|
|
6 UP lhld D dad +store jmp end-code
|
|
7
|
|
8 : , ( 16b -- ) here ! 2 allot ;
|
|
9 : c, ( 8b -- ) here c! 1 allot ;
|
|
10
|
|
11 : pad ( -- addr ) here $42 + ;
|
|
12 : compile r> dup 2+ >r @ , ; restrict
|
|
13
|
|
14 \ : here ( -- addr ) dp @ ;
|
|
15 \ : allot ( n -- ) dp +! ;
|
|
Screen 49 not modified
|
|
0 \ input strings 11Jun86
|
|
1
|
|
2 Variable #tib 0 #tib !
|
|
3 Variable >tib here >tib ! $50 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 $50 expect span @ #tib ! >in off blk off ;
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 50 not modified
|
|
0 \\ scan skip /string 16May86 18Nov87
|
|
1
|
|
2 : scan ( addr0 len0 char -- addr1 len1 ) >r
|
|
3 BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT
|
|
4 rdrop ;
|
|
5
|
|
6 : skip ( addr len del -- addr1 len1 ) >r
|
|
7 BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT
|
|
8 rdrop ;
|
|
9
|
|
10 : /string ( addr0 len0 +n - addr1 len1 )
|
|
11 over umin rot over + -rot - ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 51 not modified
|
|
0 \ skip scan 18Nov87
|
|
1 Label done H push B push IPsave lhld H IP mvx Next
|
|
2 Code skip ( addr len del -- addr1 len1 )
|
|
3 IP H mvx IPsave shld D pop B pop H pop
|
|
4 [[ B A mov C ora done jz
|
|
5 M A mov E cmp done jnz H inx B dcx ]] end-code
|
|
6
|
|
7 Code scan ( addr len chr -- addr1 len1 )
|
|
8 IP H mvx IPsave shld D pop B pop H pop
|
|
9 [[ B A mov C ora done jz
|
|
10 M A mov E cmp done jz H inx B dcx ]] end-code
|
|
11
|
|
12 Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop
|
|
13 D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl
|
|
14 L A mov E sub A L mov H A mov D sbb A H mov
|
|
15 Hpush jmp end-code
|
|
Screen 52 not modified
|
|
0 \ capitalize ohne Umlaute !! 16May86UH 25Jan88
|
|
1 Variable caps 0 caps !
|
|
2 Label ?capital caps lda A ana rz
|
|
3 Label (capital ( e --> A,E ) E A mov Ascii a cpi rc
|
|
4 Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret
|
|
5
|
|
6 Code capital ( char -- char') D pop
|
|
7 (capital call D push Next end-code
|
|
8 Code upper ( addr len -- ) D pop E D mov H pop D inr
|
|
9 [[ D dcr >next jz M E mov (capital call E M mov H inx ]]
|
|
10 end-code
|
|
11
|
|
12 \\ : capital ( char -- char')
|
|
13 dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit
|
|
14 [ Ascii a Ascii A - ] Literal - ;
|
|
15 : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ;
|
|
Screen 53 not modified
|
|
0 \ (word 16May86
|
|
1
|
|
2 Code (word ( char adr0 len0 -- addr )
|
|
3 IP H mvx IPsave shld B pop B dcx D pop
|
|
4 >in lhld D dad xchg xthl xchg H push >in lhld
|
|
5 C A mov L sub A L mov B A mov H sbb A H mov
|
|
6 cs ?[ B inx C A mov >in sta B A mov >in 1+ sta
|
|
7 D pop H pop D push
|
|
8 ][ H inx H B mvx H pop
|
|
9 [[ B A mov C ora 0<>
|
|
10 ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]?
|
|
11 H push
|
|
12 [[ B A mov C ora 0<>
|
|
13 ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]?
|
|
14 xchg H pop xthl
|
|
15 E A mov L sub A L mov D A mov H sbb A H mov
|
|
Screen 54 not modified
|
|
0 \ (word Part2 16May86
|
|
1
|
|
2 B A mov C ora 0<> ?[ H inx ]? >in shld ]?
|
|
3 H pop E A mov L sub A C mov D A mov H sbb A B mov
|
|
4 H push user' dp D lxi UP lhld D dad
|
|
5 M A mov H inx M H mov A L mov D pop H push
|
|
6 C M mov H inx
|
|
7 [[ B A mov C ora 0<>
|
|
8 ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi
|
|
9 IPsave lhld H IP mvx Next end-code
|
|
10 \\
|
|
11 : (word ( char adr0 len0 -- addr )
|
|
12 rot >r over swap >in @ /string
|
|
13 r@ skip over swap r> scan >r rot over swap - r> 0<> -
|
|
14 >in ! over - here dup >r place bl r@ count + c! r> ;
|
|
15
|
|
Screen 55 not modified
|
|
0 \ source word parse name 20Oct86UH 25Jan88
|
|
1
|
|
2 Variable loadfile
|
|
3
|
|
4 : source ( -- addr len ) blk @ ?dup
|
|
5 IF loadfile @ (block b/blk exit THEN tib #tib @ ;
|
|
6
|
|
7 : word ( char -- addr ) source (word ;
|
|
8
|
|
9 : parse ( char -- addr len )
|
|
10 >r source >in @ /string over swap r> scan >r
|
|
11 over - dup r> 0<> - >in +! ;
|
|
12
|
|
13 : name ( -- addr ) bl word dup count upper exit ;
|
|
14
|
|
15
|
|
Screen 56 not modified
|
|
0 \ state Ascii ," "lit (" " 18Nov87
|
|
1
|
|
2 Variable state 0 state !
|
|
3
|
|
4 : Ascii ( char -- n )
|
|
5 bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate
|
|
6
|
|
7 Code "lit RP lhld M E mov H inx M D mov H dcx
|
|
8 D push D ldax D inx E add A M mov H inx
|
|
9 D A mov 0 aci A M mov Next end-code
|
|
10
|
|
11 : ," Ascii " parse here over 1+ allot place ;
|
|
12 : (" "lit ; restrict
|
|
13 : " compile (" ," align ; immediate restrict
|
|
14
|
|
15 \ : "lit r> r> under count + even >r >r ; restrict
|
|
Screen 57 not modified
|
|
0 \ ." ( .( \ \\ hex decimal 07Oct87
|
|
1
|
|
2 : (." "lit count type ; restrict
|
|
3 : ." compile (." ," align ; immediate restrict
|
|
4
|
|
5 : ( ascii ) parse 2drop ; immediate
|
|
6 : .( ascii ) parse type ; immediate
|
|
7
|
|
8 : \ >in @ negate c/l mod >in +! ; immediate
|
|
9 : \\ b/blk >in ! ; immediate
|
|
10 : \needs name find nip 0=exit [compile] \ ;
|
|
11
|
|
12 : hex $10 base ! ;
|
|
13 : decimal $0A base ! ;
|
|
14
|
|
15
|
|
Screen 58 not modified
|
|
0 \ number conversion: digit? 16May86 18Nov87
|
|
1
|
|
2 Code digit? ( char -- n true : false )
|
|
3 user' base D lxi UP lhld D dad
|
|
4 D pop E A mov Ascii 0 sui no jc
|
|
5 $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc
|
|
6 Ascii A Ascii 9 - 1- sui ]?
|
|
7 M cmp no jnc
|
|
8 0 H mvi A L mov H push yes jmp end-code
|
|
9
|
|
10 \\
|
|
11 : digit? ( char -- digit true/ false ) dup Ascii 9 >
|
|
12 IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN
|
|
13 Ascii 0 - dup base @ u< dup ?exit nip ;
|
|
14
|
|
15
|
|
Screen 59 not modified
|
|
0 \ number conversion: accumulate convert 11Jun86
|
|
1
|
|
2 | : end? ( -- flag ) >in @ 0= ;
|
|
3 | : char ( addr0 -- addr1 char ) count -1 >in +! ;
|
|
4 | : previous ( addr0 -- addr0 char ) 1- count ;
|
|
5
|
|
6 : accumulate ( +d0 adr digit - +d1 adr )
|
|
7 swap >r swap base @ um* drop rot base @ um* d+ r> ;
|
|
8
|
|
9 : convert ( +d1 addr0 -- +d2 addr2 )
|
|
10 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ;
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 60 not modified
|
|
0 \ number conversion: ?nonum punctuation? 07Oct87
|
|
1
|
|
2 | : ?nonum ( flag -- exit if true ) 0=exit
|
|
3 rdrop 2drop drop rdrop false ;
|
|
4
|
|
5 | : punctuation? ( char -- flag )
|
|
6 Ascii , over = swap Ascii . = or ;
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 61 not modified
|
|
0 \ number conversion: fixbase? 07Oct87
|
|
1
|
|
2 | : fixbase? ( char - char false / newbase true ) capital
|
|
3 Ascii & case? IF $0A 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 62 not modified
|
|
0 \ number conversion: ?num ?dpl 07Oct87
|
|
1
|
|
2 Variable dpl -1 dpl !
|
|
3
|
|
4 | : ?num ( flag -- exit if true ) 0=exit
|
|
5 rdrop drop r> IF dnegate THEN
|
|
6 rot drop dpl @ 1+ ?dup ?exit drop true ;
|
|
7
|
|
8 | : ?dpl dpl @ -1 = ?exit 1 dpl +! ;
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 63 not modified
|
|
0 \ number conversion: number? number 11Jun86
|
|
1
|
|
2 : number? ( string - string false / n 0< / d 0> )
|
|
3 base push >in push dup count >in ! 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 64 not modified
|
|
0 \ hide reveal immediate restrict 11Jun86
|
|
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 65 not modified
|
|
0 \ clearstack hallot heap heap? 04Sep86
|
|
1
|
|
2 Code clearstack
|
|
3 user' s0 D lxi UP lhld D dad M E mov H inx M D mov
|
|
4 xchg sphl Next end-code
|
|
5
|
|
6 : hallot ( quan -- )
|
|
7 s0 @ over - swap sp@ 2+ dup rot - dup s0 !
|
|
8 2 pick over - di move clearstack ei 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 66 not modified
|
|
0 \ Does> ; 11Jun86 20Nov87
|
|
1
|
|
2 Label (dodoes>
|
|
3 IP rpush IP pop W inx W push Next end-code
|
|
4
|
|
5 : (;code r> last @ name> ! ;
|
|
6
|
|
7 : Does>
|
|
8 compile (;code $CD ( 8080-Call ) c,
|
|
9 compile (dodoes> ; immediate restrict
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 67 not modified
|
|
0 \ ?head | alignments 20Oct86 18Nov87
|
|
1
|
|
2 Variable ?head 0 ?head !
|
|
3
|
|
4 : | ?head @ ?exit -1 ?head ! ;
|
|
5
|
|
6 \ machen nichts beim 8080:
|
|
7 : even ( addr -- addr1 ) ; immediate
|
|
8 : align ( -- ) ; immediate
|
|
9 : halign ( -- ) ; immediate
|
|
10
|
|
11 Variable warning 0 warning !
|
|
12
|
|
13 | : exists? warning @ ?exit last @ current @
|
|
14 (find nip 0=exit space last @ .name ." exists " ?cr ;
|
|
15
|
|
Screen 68 not modified
|
|
0 \ warning Create 20Oct86 18Nov87
|
|
1
|
|
2 Defer makeview ' 0 Is makeview
|
|
3
|
|
4 : (create ( string -- ) align here
|
|
5 swap count $1F and here 4+ place makeview , current @ @ ,
|
|
6 here last ! here c@ 1+ allot align exists?
|
|
7 ?head @ IF 1 ?head +! dup , \ Pointer to Code
|
|
8 halign heapmove $20 flag! dup dp !
|
|
9 THEN drop reveal 0 ,
|
|
10 ;Code W inx W push Next end-code
|
|
11
|
|
12 : Create name count 1 $20 uwithin not
|
|
13 Abort" invalid name" 1- (create ;
|
|
14
|
|
15
|
|
Screen 69 not modified
|
|
0 \ nfa? 30Jun86
|
|
1
|
|
2 Code nfa? ( thread cfa -- nfa / false )
|
|
3 D pop H pop
|
|
4 [[ M A mov H inx M H mov A L mov
|
|
5 H ora Hpush jz H push H inx H inx H push D push
|
|
6 M A mov H inx $1F ani A E mov 0 D mvi D dad
|
|
7 D pop xthl M A mov H pop $20 ani
|
|
8 0<> ?[ M A mov H inx M H mov A L mov ]?
|
|
9 H A mov D cmp 0= ?[ L A mov E cmp ]?
|
|
10 H pop 0= ?] H inx H inx Hpush jmp
|
|
11 end-code
|
|
12 \\
|
|
13 : nfa? ( thread cfa -- nfa / false)
|
|
14 >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ =
|
|
15 UNTIL 2+ rdrop ;
|
|
Screen 70 not modified
|
|
0 \ >name name> >body .name 30Jun86 07Oct87
|
|
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 Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani
|
|
7 A E mov 0 D mvi D dad hpush jmp end-code
|
|
8 \ : (name> ( nfa -- cfa ) count $1F and + ;
|
|
9
|
|
10 : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ;
|
|
11
|
|
12 : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ;
|
|
13
|
|
14 : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN
|
|
15 count $1F and type ELSE ." ???" THEN space ;
|
|
Screen 71 not modified
|
|
0 \ : ; Constant Variable 07Nov87
|
|
1
|
|
2 : Create: Create hide current @ context ! 0 ] ;
|
|
3
|
|
4 : : Create: ;Code IP rpush W inx W IP mvx Next end-code
|
|
5
|
|
6 : ; 0 ?pairs compile unnest [compile] [ reveal ;
|
|
7 immediate restrict
|
|
8
|
|
9 : Constant ( n -- ) Create , ;Code
|
|
10 W inx xchg M E mov H inx M D mov D push Next
|
|
11 end-code
|
|
12
|
|
13 : Variable Create 0 , ;
|
|
14
|
|
15
|
|
Screen 72 not modified
|
|
0 \ uallot User Alias Defer 11Jun86 18Nov87
|
|
1 : uallot ( quan -- offset ) even dup udp @ +
|
|
2 $FF u> Abort" Userarea full" udp @ swap udp +! ;
|
|
3
|
|
4 : User Create 2 uallot c,
|
|
5 ;Code W inx W ldax A E mov 0 D mvi
|
|
6 UP lhld D dad hpush jmp end-code
|
|
7
|
|
8 : Alias ( cfa -- ) Create last @ dup c@ $20 and
|
|
9 IF -2 allot ELSE $20 flag! THEN (name> ! ;
|
|
10
|
|
11 | : crash true Abort" crash" ;
|
|
12
|
|
13 : Defer Create ['] crash ,
|
|
14 ;Code W inx xchg M E mov H inx M D mov
|
|
15 xchg >next1 jmp end-code
|
|
Screen 73 not modified
|
|
0 \ vp current context also toss 11Jun86
|
|
1
|
|
2 Create vp $10 allot Variable current
|
|
3
|
|
4 : context ( -- adr ) 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 @ $0A > Error" Vocabulary stack full"
|
|
11 context @ 2 vp +! context ! ;
|
|
12 : toss vp @ IF -2 vp +! THEN ;
|
|
13
|
|
14
|
|
15
|
|
Screen 74 not modified
|
|
0 \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87
|
|
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 Root
|
|
9
|
|
10 : Only vp off Root also ;
|
|
11
|
|
12 : Onlyforth Only Forth also definitions ;
|
|
13
|
|
14
|
|
15
|
|
Screen 75 not modified
|
|
0 \ definitions order words 10Oct87 20Nov87
|
|
1
|
|
2 | : init-vocabularys voc-link @
|
|
3 BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ;
|
|
4
|
|
5 : definitions context @ current ! ;
|
|
6
|
|
7 | : .voc ( adr -- ) @ 2- >name .name ;
|
|
8
|
|
9 : order vp 4+ context DO I .voc -2 +LOOP
|
|
10 2 spaces current .voc ;
|
|
11
|
|
12 : words context @
|
|
13 BEGIN @ dup stop? 0= and
|
|
14 WHILE ?cr dup 2+ .name space
|
|
15 REPEAT drop ;
|
|
Screen 76 not modified
|
|
0 \ found -text 11Jun86
|
|
1 | : found ( nfa -- cfa n )
|
|
2 dup c@ >r (name> r@ $20 and IF @ THEN
|
|
3 -1 r@ $80 and IF 1- THEN
|
|
4 r> $40 and IF negate THEN ;
|
|
5
|
|
6 \\
|
|
7 : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1<str2)
|
|
8 over bounds DO drop 1+ dup 1- c@ I c@ - dup
|
|
9 IF dup abs / LEAVE THEN LOOP nip ;
|
|
10 | Variable string | Variable strlen
|
|
11 : (find ( string thread -- str false/NFA true )
|
|
12 >r count $1F and strlen ! string !
|
|
13 BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ =
|
|
14 IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN
|
|
15 THEN drop REPEAT string @ 1- false ;
|
|
Screen 77 not modified
|
|
0 \ (find 11Jun86
|
|
1
|
|
2 Code (find ( str thr - str false/ NFA true )
|
|
3 H pop D pop IP push D ldax $1F ani A C mov D inx
|
|
4 Label findloop
|
|
5 M A mov H inx M H mov A L mov
|
|
6 H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]?
|
|
7 H push H inx H inx M A mov $1F ani C cmp
|
|
8 0<> ?[ H pop findloop jmp ]?
|
|
9 D push H inx C B mov B inr
|
|
10 [[ B dcr 0<> ?[[
|
|
11 D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]?
|
|
12 H inx D inx ]]?
|
|
13 D pop H pop H inx H inx IP pop H push yes jmp
|
|
14 end-code
|
|
15 \\ HL: thread, nfa DE: string C: strlen B: counter
|
|
Screen 78 not modified
|
|
0 \ find ' [compile] ['] nullstring? 18Nov87
|
|
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 ?exit Error" ?" ;
|
|
8
|
|
9 : [compile] ' , ; immediate restrict
|
|
10
|
|
11 : ['] ' [compile] Literal ; immediate restrict
|
|
12
|
|
13 : nullstring? ( string -- string false / true )
|
|
14 dup c@ 0= dup 0=exit nip ;
|
|
15
|
|
Screen 79 not modified
|
|
0 \ notfound 17Oct86UH 25Jan88
|
|
1
|
|
2 : no.extensions ( string -- )
|
|
3 state @ IF Abort" ?" THEN Error" ?" ;
|
|
4
|
|
5 Defer notfound ' no.extensions Is notfound
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 80 not modified
|
|
0 \ interpret interpreter compiler parser UH 25Jan88
|
|
1 Defer parser
|
|
2
|
|
3 : interpret ( -- )
|
|
4 BEGIN ?stack name nullstring? ?exit parser REPEAT ;
|
|
5
|
|
6 | : interpreter ( str -- ) find ?dup
|
|
7 IF 1 and IF execute exit THEN Error" compile only" THEN
|
|
8 number? ?exit notfound ;
|
|
9
|
|
10 ' interpreter Is parser
|
|
11
|
|
12 | : compiler ( str -- ) find ?dup
|
|
13 IF 0> IF execute exit THEN , exit THEN
|
|
14 number? ?dup IF 0> IF swap [compile] Literal THEN
|
|
15 [compile] Literal exit THEN notfound ;
|
|
Screen 81 not modified
|
|
0 \ [ ] UH 25Jan88
|
|
1
|
|
2 : [ ['] interpreter Is Parser state off ; immediate
|
|
3
|
|
4 : ] ['] compiler Is Parser state on ;
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 82 not modified
|
|
0 \ Is 09May86UH 25Jan88
|
|
1
|
|
2 : (is r> dup 2+ >r @ ! ;
|
|
3
|
|
4 | : def? ( cfa -- )
|
|
5 @ [ ' notfound @ ] Literal - Abort" not deferred" ;
|
|
6
|
|
7 : Is ( adr -- ) ' dup def? >body
|
|
8 state @ IF compile (is , exit THEN ! ; immediate
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 83 not modified
|
|
0 \ ?stack 30Jun86
|
|
1 | : stackfull ( -- ) depth $20 > Abort" tight stack"
|
|
2 reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN
|
|
3 true Abort" Dictionary full" ;
|
|
4
|
|
5 Code ?stack
|
|
6 UP lhld user' dp D lxi D dad M E mov H inx M D mov
|
|
7 0 H lxi SP dad L A mov E sub H A mov D sbb
|
|
8 0= ?[ ;c: stackfull ; Assembler ]? H push
|
|
9 UP lhld user' s0 D lxi D dad M E mov H inx M D mov
|
|
10 H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]?
|
|
11 >next jnc ;c: true abort" Stack empty" ;
|
|
12 \\
|
|
13 : ?stack sp@ here - 100 u< IF stackfull THEN
|
|
14 sp@ s0 @ u> Abort" Stack empty" ;
|
|
15
|
|
Screen 84 not modified
|
|
0 \ .status push load 20Oct86
|
|
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 : (load ( blk offset -- )
|
|
10 isfile push loadfile push fromfile push blk push >in push
|
|
11 >in ! blk ! isfile@ loadfile ! .status interpret ;
|
|
12
|
|
13 : load ( blk --) ?dup 0=exit 0 (load ;
|
|
14
|
|
15
|
|
Screen 85 not modified
|
|
0 \ +load thru +thru --> rdepth depth 20Oct86
|
|
1
|
|
2 : +load ( offset --) blk @ + load ;
|
|
3
|
|
4 : thru ( from to --) 1+ swap DO I load LOOP ;
|
|
5 : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ;
|
|
6
|
|
7 : --> 1 blk +! >in off .status ; immediate
|
|
8
|
|
9 : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ;
|
|
10 : depth ( -- +n) sp@ s0 @ swap - 2/ ;
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 86 not modified
|
|
0 \ quit (quit abort UH 25Jan88
|
|
1
|
|
2 : (prompt ( -- )
|
|
3 state @ IF cr ." ] " ELSE ." ok" cr THEN .status ;
|
|
4
|
|
5 Defer prompt ' (prompt Is prompt
|
|
6
|
|
7 : (quit BEGIN prompt query interpret REPEAT ;
|
|
8
|
|
9 Defer 'quit ' (quit Is 'quit
|
|
10 : quit r0 @ rp! level off [compile] [ 'quit ;
|
|
11
|
|
12 : standardi/o [ output ] Literal output 4 cmove ;
|
|
13
|
|
14 Defer 'abort ' noop Is 'abort
|
|
15 : abort end-trace clearstack 'abort standardi/o quit ;
|
|
Screen 87 not modified
|
|
0 \ (error Abort" Error" 20Oct86 18Nov87
|
|
1
|
|
2 Variable scr 1 scr ! Variable r# 0 r# !
|
|
3
|
|
4 : (error ( string -- ) standardi/o space here .name
|
|
5 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 88 not modified
|
|
0 \ -trailing 30Jun86 18Nov87
|
|
1
|
|
2 Code -trailing ( addr n1 -- addr n2 )
|
|
3 D pop H pop H push
|
|
4 D dad xchg D dcx
|
|
5 Label -trail H A mov L ora hpush jz
|
|
6 D ldax BL cpi hpush jnz
|
|
7 H dcx D dcx -trail jmp end-code
|
|
8
|
|
9 \\
|
|
10 : -trailing ( addr n1 -- addr n2)
|
|
11 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 89 not modified
|
|
0 \ space spaces 30Jun86
|
|
1
|
|
2 $20 Constant bl
|
|
3
|
|
4 : space bl emit ;
|
|
5 : spaces ( u --) 0 ?DO space LOOP ;
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 90 not modified
|
|
0 \ hold <# #> sign # #s 17Oct86
|
|
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 91 not modified
|
|
0 \ print numbers 24Dec83
|
|
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 92 not modified
|
|
0 \ .s list c/l l/s 05Oct87
|
|
1
|
|
2 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ;
|
|
3
|
|
4 $40 Constant c/l \ Screen line length
|
|
5 $10 Constant l/s \ lines per screen
|
|
6
|
|
7 : list ( blk -- )
|
|
8 scr ! ." Scr " scr @ u.
|
|
9 l/s 0 DO
|
|
10 cr I 2 .r space scr @ block I c/l * + c/l -trailing type
|
|
11 LOOP cr ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 93 not modified
|
|
0 \ multitasker primitives 20Nov87
|
|
1
|
|
2 Code end-trace \ patch Next to its original state
|
|
3 $0A A mvi ( IP ldax ) >next sta
|
|
4 $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code
|
|
5
|
|
6 Code pause >next here 2- ! end-code
|
|
7
|
|
8 : lock ( addr -- ) dup @ up@ = IF drop exit THEN
|
|
9 BEGIN dup @ WHILE pause REPEAT up@ swap ! ;
|
|
10
|
|
11 : unlock ( addr -- ) dup lock off ;
|
|
12
|
|
13 Label wake H pop H dcx UP shld
|
|
14 6 D lxi D dad M A mov H inx M H mov A L mov sphl
|
|
15 H pop RP shld IP pop Next end-code
|
|
Screen 94 not modified
|
|
0 \ buffer mechanism 20Oct86 07Oct87
|
|
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 ! \ Semaphor
|
|
6 $408 Constant b/buf \ physikalische Groesse
|
|
7 $400 Constant b/blk
|
|
8 \\ Struktur eines Buffers: 0 : link
|
|
9 2 : file
|
|
10 4 : blocknummer
|
|
11 6 : statusflags
|
|
12 8 : Data ... 1 Kb ...
|
|
13 Statusflag bits : 15 1 -> updated
|
|
14 file : -1 -> empty buffer, 0 -> no fcb, direct access
|
|
15 else addr of fcb ( system dependent )
|
|
Screen 95 not modified
|
|
0 \ search for blocks in memory 30Jun86
|
|
1 | Variable pred
|
|
2 \ DE:blk BC:file HL:bufadr
|
|
3
|
|
4 Label thisbuffer? ( Zero = this buffer )
|
|
5 H push H inx H inx M A mov C cmp 0=
|
|
6 ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp
|
|
7 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret
|
|
8
|
|
9 Code (core? ( blk file -- adr\blk file )
|
|
10 IP H mvx Ipsave shld
|
|
11 user' offset D lxi UP lhld D dad
|
|
12 M E mov H inx M D mov
|
|
13 B pop H pop H push B push D dad xchg
|
|
14 prev lhld
|
|
15 thisbuffer? call 0= ?[
|
|
Screen 96 not modified
|
|
0 \ search for blocks in memory 30Jun86
|
|
1
|
|
2 Label blockfound
|
|
3 D pop D pop 8 D lxi D dad H push ' exit @ jmp ]?
|
|
4 [[ pred shld
|
|
5 M A mov H inx M H mov A L mov
|
|
6 H ora 0= ?[ IPsave lhld H IP mvx Next ]?
|
|
7 thisbuffer? call 0= ?]
|
|
8 xchg pred lhld D ldax A M mov
|
|
9 H inx D inx D ldax A M mov D dcx
|
|
10 prev lhld xchg E M mov H inx D M mov
|
|
11 H dcx prev shld
|
|
12 blockfound jmp end-code
|
|
13
|
|
14
|
|
15
|
|
Screen 97 not modified
|
|
0 \ (core? 29Jun86
|
|
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 98 not modified
|
|
0 \ (diskerr 29Jul86 07Oct87
|
|
1
|
|
2 : (diskerr
|
|
3 ." error! r to retry " key $FF and
|
|
4 capital Ascii R = not Abort" aborted" ;
|
|
5
|
|
6 Defer diskerr
|
|
7 ' (diskerr Is diskerr
|
|
8
|
|
9 Defer r/w
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 99 not modified
|
|
0 \ backup emptybuf readblk 20Oct86
|
|
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 BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
|
|
6 WHILE ." write " diskerr
|
|
7 REPEAT 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 BEGIN over offset @ + over r@ 8 + -rot 1 r/w
|
|
15 WHILE ." read " diskerr REPEAT r> ;
|
|
Screen 100 not modified
|
|
0 \ take mark updates? core? 10Mar86 19Nov87
|
|
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
|
|
13 : core? ( blk file -- addr /false ) (core? 2drop false ;
|
|
14
|
|
15
|
|
Screen 101 not modified
|
|
0 \ block & buffer manipulation 20Oct86 18Nov87
|
|
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 ) user' isfile D lxi
|
|
9 UP lhld D dad fetch jmp end-code
|
|
10
|
|
11 : buffer ( blk -- addr ) isfile@ (buffer ;
|
|
12
|
|
13 : block ( blk -- addr ) isfile@ (block ;
|
|
14
|
|
15 \ : isfile@ ( -- addr ) isfile @ ;
|
|
Screen 102 not modified
|
|
0 \ block & buffer manipulation 05Oct87
|
|
1
|
|
2 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ;
|
|
3
|
|
4 Defer save-dos-buffers
|
|
5
|
|
6 : save-buffers ( -- ) buffers lock
|
|
7 BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers
|
|
8 buffers unlock ;
|
|
9
|
|
10 : empty-buffers ( -- ) buffers lock prev
|
|
11 BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ;
|
|
12
|
|
13 : flush save-buffers empty-buffers ;
|
|
14
|
|
15
|
|
Screen 103 not modified
|
|
0 \ Allocating buffers 10Oct87
|
|
1 $10000 Constant limit Variable first
|
|
2
|
|
3 : allotbuffer ( -- )
|
|
4 first @ r0 @ - b/buf 2+ u< ?exit
|
|
5 b/buf negate first +! first @ dup emptybuf
|
|
6 prev @ over ! prev ! ;
|
|
7
|
|
8 : freebuffer ( -- ) first @ limit b/buf - u<
|
|
9 IF first @ backup prev
|
|
10 BEGIN dup @ first @ - WHILE @ REPEAT
|
|
11 first @ @ swap ! b/buf first +! THEN ;
|
|
12
|
|
13 : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ;
|
|
14
|
|
15 | : init-buffers prev off limit first ! all-buffers ;
|
|
Screen 104 not modified
|
|
0 \ endpoints of forget 01Jul86
|
|
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 105 not modified
|
|
0 \ remove, -words, -tasks 20Oct86
|
|
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 106 not modified
|
|
0 \ remove-vocs trim 20Oct86 07Oct87
|
|
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 Defer custom-remove ' noop Is custom-remove
|
|
10
|
|
11 | : trim ( dic symb -- )
|
|
12 over remove-tasks remove-vocs remove-words
|
|
13 custom-remove heap swap - hallot dp ! 0 last ! ;
|
|
14
|
|
15
|
|
Screen 107 not modified
|
|
0 \ deleting words from dict. 01Jul86 18Nov87
|
|
1
|
|
2 : clear here dup up@ trim dp ! ;
|
|
3
|
|
4 : (forget ( adr --) dup heap? Abort" is symbol"
|
|
5 endpoints trim ;
|
|
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@ trim
|
|
12 [ udp ] Literal @ udp ! ;
|
|
13
|
|
14
|
|
15
|
|
Screen 108 not modified
|
|
0 \ save bye stop? ?cr 18Nov87
|
|
1
|
|
2 : save here up@ trim
|
|
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 #cr = IF true rdrop THEN ;
|
|
9
|
|
10 : stop? ( -- flag ) key? IF end? end? THEN false ;
|
|
11
|
|
12 : ?cr col c/l u> 0=exit cr ;
|
|
13
|
|
14
|
|
15
|
|
Screen 109 not modified
|
|
0 \ in/output structure 07Jun86
|
|
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 110 not modified
|
|
0 \ Alias only definitionen 18Nov87
|
|
1
|
|
2 Root definitions Forth
|
|
3
|
|
4 : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab.
|
|
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 111 not modified
|
|
0 \ 'restart 'cold 22Oct86 10Oct87
|
|
1
|
|
2 Defer 'restart ' noop Is 'restart
|
|
3
|
|
4 | : (restart ['] (quit Is 'quit drvinit 'restart
|
|
5 [ errorhandler ] Literal @ errorhandler !
|
|
6 ['] noop Is 'abort clearstack
|
|
7 standardi/o interpret quit ;
|
|
8
|
|
9 Defer 'cold ' noop Is 'cold
|
|
10
|
|
11 | : (cold origin up@ $100 cmove $80 count
|
|
12 $50 umin >r tib r@ move r> #tib ! >in off blk off
|
|
13 init-vocabularys init-buffers flush 'cold
|
|
14 Onlyforth page &24 spaces logo count type cr (restart ;
|
|
15
|
|
Screen 112 not modified
|
|
0 \ cold bootsystem 20Oct86
|
|
1
|
|
2 Code cold here >cold !
|
|
3 s0 lhld 6 D lxi D dad origin D lxi $3F C mvi
|
|
4 [[ D ldax A M mov H inx D inx C dcr 0= ?]
|
|
5 ' (cold >body IP lxi
|
|
6 Label bootsystem
|
|
7 s0 lhld 6 D lxi D dad UP shld
|
|
8 user' s0 D lxi D dad
|
|
9 M E mov H inx M D mov xchg sphl
|
|
10 user' r0 D lxi UP lhld D dad
|
|
11 M E mov H inx M D mov xchg RP shld
|
|
12 $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker )
|
|
13 Next
|
|
14 end-code
|
|
15
|
|
Screen 113 not modified
|
|
0 \ restart boot 20Oct86
|
|
1
|
|
2 Code restart here >restart !
|
|
3 ' (restart >body IP lxi bootsystem jmp end-code
|
|
4
|
|
5 Label boot here >boot ! \ find link to Main:
|
|
6 s0 lhld 6 D lxi D dad H B mvx origin D lxi
|
|
7 [[ [[ xchg H inx H inx M E mov H inx M D mov
|
|
8 D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx
|
|
9 6 lhld 0 L mvi ' limit >body shld
|
|
10 -$1100 D lxi D dad r0 shld \ set initial RP
|
|
11 -$400 D lxi D dad s0 shld \ set initial SP
|
|
12 6 D lxi D dad xchg B H mvx
|
|
13 D M mov H dcx E M mov \ set link to Maintask
|
|
14 >cold 2- jmp
|
|
15 end-code
|
|
Screen 114 not modified
|
|
0 \ "search 05Mar88
|
|
1
|
|
2 Label notfound H pop H pop
|
|
3 IPsave lhld H IP mvx False H lxi hpush jmp
|
|
4
|
|
5 Code "search ( text tlen buf blen -- addr tf / ff )
|
|
6 IP H mvx IPsave shld D pop H pop xthl
|
|
7 H A mov L ora notfound jz
|
|
8 E A mov L sub A C mov D A mov H sbb A B mov notfound jc
|
|
9 B inx D pop xthl M A mov xthl H push xchg
|
|
10 Label scanfirst
|
|
11 A E mov ?capital call E D mov
|
|
12 [[ M E mov H inx B A mov C ora notfound jz B dcx
|
|
13 ?capital call E A mov D cmp 0= ?]
|
|
14 B D mvx B pop xchg xthl xchg H push B push D push
|
|
15
|
|
Screen 115 not modified
|
|
0 \ "search part 2 27Nov87
|
|
1
|
|
2 Label match
|
|
3 B dcx B A mov C ora 0<> ?[
|
|
4 D inx D ldax D push A E mov ?capital call E D mov
|
|
5 M E mov H inx ?capital call E A mov D cmp D pop
|
|
6 match jz H pop B pop D pop
|
|
7 M A mov xthl B push H B mvx xchg scanfirst jmp ]?
|
|
8 D pop D pop H pop D pop H dcx H push
|
|
9 IPsave lhld H IP mvx True H lxi hpush jmp
|
|
10 end-code
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 116 not modified
|
|
0 \ Rest of Standard-System 04Oct87 07Oct87
|
|
1
|
|
2 2 +load \ Operating System
|
|
3
|
|
4 Host ' Transient 8 + @ Transient Forth Context @ 6 + !
|
|
5
|
|
6 Target Forth also definitions
|
|
7
|
|
8 Vocabulary Assembler Assembler definitions
|
|
9 Transient Assembler
|
|
10 >Next Constant >Next
|
|
11 hpush Constant hpush
|
|
12 dpush Constant dpush
|
|
13
|
|
14 Target Forth also definitions
|
|
15 : forth-83 ; \ last word in Dictionary
|
|
Screen 117 not modified
|
|
0 \ System patchup 04Oct87
|
|
1
|
|
2 $EF00 r0 !
|
|
3 $EB00 s0 !
|
|
4 s0 @ 6 + origin 2+ ! \ link Maintask to itself
|
|
5
|
|
6 \ s0 und r0 werden beim Booten neu an die Speichergroesse
|
|
7 \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask
|
|
8
|
|
9 here dp !
|
|
10
|
|
11 Host Tudp @ Target udp !
|
|
12 Host Tvoc-link @ Target voc-link !
|
|
13 Host move-threads
|
|
14
|
|
15
|
|
Screen 118 not modified
|
|
0 \ System dependent Load-Screen 20Nov87
|
|
1
|
|
2 1 +load \ CP/M interface
|
|
3
|
|
4 2 4 +thru \ Character IO
|
|
5
|
|
6 5 7 +thru \ Default Disk IO
|
|
7
|
|
8 8 +load \ Postlude
|
|
9
|
|
10 \ 9 +load \ Index
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 119 not modified
|
|
0 \ CP/M-Interface 05Oct87
|
|
1 Vocabulary Dos Dos definitions also
|
|
2 Label >bios pchl
|
|
3 Code biosa ( arg fun -- res )
|
|
4 1 lhld D pop D dcx D dad D dad D dad
|
|
5 D pop IP push D IP mvx >bios call
|
|
6 Label back
|
|
7 IP pop 0 H mvi A L mov Hpush jmp end-code
|
|
8
|
|
9 Code bdosa ( arg fun -- res )
|
|
10 H pop D pop IP push L C mov 5 call back jmp
|
|
11 end-code
|
|
12
|
|
13 : bios ( arg fun -- ) biosa drop ;
|
|
14 : bdos ( arg fun -- ) bdosa drop ;
|
|
15
|
|
Screen 120 not modified
|
|
0 \ Character-IO Constants Character input 05Oct87
|
|
1
|
|
2 Target Dos also
|
|
3
|
|
4 $08 Constant #bs $0D Constant #cr
|
|
5 $0A Constant #lf $1B Constant #esc
|
|
6 $09 Constant #tab $7F Constant #del
|
|
7 $07 Constant #bel $0C Constant #ff
|
|
8
|
|
9 : con! ( c -- ) 4 bios ;
|
|
10 : (key? ( -- ? ) 0 2 biosa 0= not ;
|
|
11 : getkey ( -- c ) 0 3 biosa ;
|
|
12
|
|
13 : (key ( -- c ) BEGIN pause (key? UNTIL getkey ;
|
|
14
|
|
15
|
|
Screen 121 not modified
|
|
0 \ Character output 07Oct87 UH 27Feb88
|
|
1
|
|
2 | Code ?ctrl ( c -- c' ) H pop L A mov
|
|
3 $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code
|
|
4
|
|
5 : (emit ( c -- ) ?ctrl con! pause ;
|
|
6
|
|
7 : (cr #cr con! #lf con! ;
|
|
8 : (del #bs con! bl con! #bs con! ;
|
|
9 : (at? ( -- row col ) 0 0 ;
|
|
10
|
|
11 : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ;
|
|
12
|
|
13 Output: display [ here output ! ]
|
|
14 (emit (cr tipp (del noop 2drop (at? ;
|
|
15
|
|
Screen 122 not modified
|
|
0 \ Line input 04Oct87
|
|
1
|
|
2 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ;
|
|
3
|
|
4 : (decode ( addr pos1 key -- addr pos2 )
|
|
5 #bs case? IF backspace exit THEN
|
|
6 #del case? IF backspace exit THEN
|
|
7 #cr case? IF dup span ! space exit THEN
|
|
8 dup emit >r 2dup + r> swap c! 1+ ;
|
|
9
|
|
10 : (expect ( addr len -- ) span ! 0
|
|
11 BEGIN span @ over u> WHILE key decode REPEAT 2drop ;
|
|
12
|
|
13 Input: keyboard [ here input ! ]
|
|
14 (key (key? (decode (expect ;
|
|
15
|
|
Screen 123 not modified
|
|
0 \ Default Disk Interface: Constants and Primitives 18Nov87
|
|
1
|
|
2 $80 Constant b/rec b/blk b/rec / Constant rec/blk
|
|
3
|
|
4 Dos definitions
|
|
5 ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb
|
|
6
|
|
7 : dos-error? ( n -- f ) $FF = ;
|
|
8
|
|
9 $5C Constant fcb
|
|
10 : reset ( -- ) 0 &13 bdos ;
|
|
11 : openfile ( fcb -- f ) &15 bdosa dos-error? ;
|
|
12 : closefile ( fcb -- f ) &16 bdosa dos-error? ;
|
|
13 : dma! ( dma -- ) &26 bdos ;
|
|
14 : rec@ ( fcb -- f ) &33 bdosa ;
|
|
15 : rec! ( fcb -- f ) &34 bdosa ;
|
|
Screen 124 not modified
|
|
0 \ Default Disk Interface: open and close 20Nov87
|
|
1
|
|
2 Target Dos also Defer drvinit Dos definitions
|
|
3
|
|
4 | Variable opened
|
|
5 : default ( -- ) opened off
|
|
6 fcb 1+ c@ bl = ?exit $80 count here place #tib off
|
|
7 fcb dup dosfcb> dup isfile ! fromfile !
|
|
8 openfile Abort" default file not found!" opened on ;
|
|
9 ' default Is drvinit
|
|
10
|
|
11 : close-default ( -- ) opened @ not ?exit
|
|
12 fcb closefile Abort" can't close default-file!" ;
|
|
13 ' close-default Is save-dos-buffers
|
|
14
|
|
15
|
|
Screen 125 not modified
|
|
0 \ Default Disk Interface: read/write 14Feb88
|
|
1
|
|
2 Target Dos also
|
|
3
|
|
4 | : rec# ( 'dosfcb -- 'rec# ) &33 + ;
|
|
5
|
|
6 : (r/w ( adr blk file r/wf -- flag ) >r
|
|
7 dup 0= Abort" no Direct Disk IO supported! " >dosfcb
|
|
8 swap rec/blk * over rec# 0 over 2+ c! !
|
|
9 r> rot b/blk bounds
|
|
10 DO I dma! 2dup IF rec@ drop
|
|
11 ELSE rec! IF 2drop true endloop exit THEN THEN
|
|
12 over rec# 0 over 2+ c! 1 swap +!
|
|
13 b/rec +LOOP 2drop false ;
|
|
14
|
|
15 ' (r/w Is r/w
|
|
Screen 126 not modified
|
|
0 \ Postlude 20Nov87
|
|
1
|
|
2 Defer postlude
|
|
3
|
|
4 | : (bye ( -- ) postlude 0 0 bdos ;
|
|
5
|
|
6 | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ;
|
|
7
|
|
8 : .size ( -- ) base push decimal
|
|
9 cr ." Size: &" #pages u. ." Pages" ;
|
|
10
|
|
11 ' .size Is postlude
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 127 not modified
|
|
0 \ index findex 20Nov87
|
|
1
|
|
2 | : range ( from to -- to+1 from )
|
|
3 2dup > IF swap THEN 1+ swap ;
|
|
4
|
|
5 : index ( from to --)
|
|
6 range DO cr I 4 .r I space block c/l type
|
|
7 stop? IF LEAVE THEN LOOP ;
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|