mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-12-01 19:49:57 +00:00
1609 lines
51 KiB
Forth
1609 lines
51 KiB
Forth
( ----- 000 )
|
|
\ #### volksFORTH #### cas 18jul20
|
|
VolksForth has been developed by
|
|
|
|
K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck
|
|
Ulli Hoffmann, Philip Zembrod, Carsten Strotmann
|
|
6502 version by B.Pennemann and K.Schleisiek
|
|
Port to C64 "ultraFORTH" by G. Rehfeld
|
|
Port to 68000 and Atari ST by D.Weineck and B.Pennemann
|
|
Port to 8080 and CP/M by U.Hoffmann jul 86
|
|
Port to C16 "ultraFORTH" by C.Vogt
|
|
Port to 8088/86 and MS-DOS by K.Schleisiek dez 87
|
|
( ----- 001 )
|
|
\ MS-DOS volksForth Load Screen ks cas 18jul20
|
|
warning off \ disable warnings during compilation
|
|
Onlyforth \needs Transient include meta.fb
|
|
2 loadfrom META.fb
|
|
|
|
new FORTH.COM Onlyforth Target definitions
|
|
|
|
4 &111 thru \ Standard 8088-System
|
|
warning on
|
|
flush \ close FORTH.COM
|
|
|
|
cr .( new kernel as "FORTH.COM" written) cr bell ( bye )
|
|
( ----- 002 )
|
|
\\ The use of the 8088/86 register ks 27 oct 86
|
|
|
|
The assembler uses forth style names for the register
|
|
The assiciation to the Intel register names:
|
|
|
|
A <=> AX A- <=> AL A+ <=> AH
|
|
C <=> CX C- <=> CL C+ <=> CH
|
|
Register A and C are available for general use
|
|
|
|
D <=> DX D- <=> DL D+ <=> DH
|
|
the Top of (Data-) Stack (TOS)
|
|
|
|
R <=> BX R- <=> RL R+ <=> RH
|
|
the Return_stack_pointer
|
|
( ----- 003 )
|
|
\\ The use of the 8088/86 register ks 27 oct 86
|
|
|
|
U <=> BP User_area_pointer
|
|
S <=> SP Daten_stack_pointer
|
|
I <=> SI Instruction_pointer
|
|
W <=> DI Word_pointer, free for general use
|
|
|
|
D: <=> DS E: <=> ES S: <=> SS C: <=> CS
|
|
All segment registers are set to the value of code-segment
|
|
C: and must be restored to the same if changed in the code
|
|
( ----- 004 )
|
|
\ FORTH Preamble and ID ks 11 m„r 89
|
|
Assembler
|
|
|
|
nop 5555 # jmp here 2- >label >cold
|
|
nop 5555 # jmp here 2- >label >restart
|
|
|
|
Create origin here origin! here $100 0 fill
|
|
\ Coldstart valued for user variables
|
|
|
|
$E9 int end-code -4 , $FC allot
|
|
\ this is the multitasker initialization in the user area
|
|
|
|
| Create logo ," volksFORTH-83 Version 3.9.3"
|
|
( ----- 005 )
|
|
\ Next ks 27 oct 86
|
|
|
|
Variable next-link 0 next-link !
|
|
|
|
Host Forth Assembler also definitions
|
|
|
|
: Next lods A W xchg W ) jmp
|
|
there tnext-link @ T , H tnext-link ! ;
|
|
|
|
\ Next is in-line code. All "nexts" are linked into a
|
|
\ list with the anchor NEXT-LINK for the debugger
|
|
|
|
: u' ( -- offset ) T ' 2+ c@ H ;
|
|
|
|
Target
|
|
( ----- 006 )
|
|
\ recover ;c: noop ks 27 oct 86
|
|
|
|
Create recover Assembler
|
|
R dec R dec I R ) mov I pop Next
|
|
end-code
|
|
|
|
Host Forth Assembler also definitions
|
|
|
|
: ;c: 0 T recover # call ] end-code H ;
|
|
|
|
Target
|
|
|
|
| Code di cli Next end-code
|
|
| Code ei sti here Next end-code
|
|
|
|
Code noop here 2- ! end-code
|
|
( ----- 007 )
|
|
\ User variables ks 16 sep 88
|
|
8 uallot drop \ Space for the multitasker
|
|
\ Fields: entry link spare SPsave
|
|
\ Length compatible to 68000, 6502 and 8080 volksFORTH
|
|
User s0
|
|
User r0
|
|
User dp
|
|
User offset 0 offset !
|
|
User base &10 base !
|
|
User output
|
|
User input
|
|
User errorhandler \ pointer for Abort" -code
|
|
User aborted \ code address of latest error
|
|
User voc-link
|
|
User file-link ( TODO: Why is UDP a user variable? )
|
|
User udp \ points to next free addr in User_area
|
|
( ----- 008 )
|
|
\ manipulate system pointers ks 03 aug 87
|
|
|
|
Code sp@ ( -- addr ) D push S D mov Next end-code
|
|
|
|
Code sp! ( addr -- ) D S mov D pop Next end-code
|
|
|
|
|
|
Code up@ ( -- addr ) D push U D mov Next end-code
|
|
|
|
Code up! ( addr -- ) D U mov D pop Next end-code
|
|
|
|
Code ds@ ( -- addr ) D push D: D mov Next end-code
|
|
|
|
$10 Constant b/seg \ bytes per segment
|
|
( ----- 009 )
|
|
\ manipulate returnstack ks 27 oct 86
|
|
|
|
Code rp@ ( -- addr ) D push R D mov Next end-code
|
|
|
|
Code rp! ( addr -- ) D R mov D pop Next end-code
|
|
|
|
|
|
Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next
|
|
end-code restrict
|
|
|
|
Code r> ( -- 16b ) D push R ) D mov R inc R inc Next
|
|
end-code restrict
|
|
( ----- 010 )
|
|
\ r@ rdrop exit unnest ?exit ks 27 oct 86
|
|
Code r@ ( -- 16b ) D push R ) D mov Next end-code
|
|
|
|
Code rdrop R inc R inc Next end-code restrict
|
|
|
|
Code exit
|
|
Label >exit R ) I mov R inc R inc Next end-code
|
|
|
|
Code unnest >exit here 2- ! end-code
|
|
|
|
Code ?exit ( flag -- )
|
|
D D or D pop >exit 0= ?] [[ Next end-code
|
|
|
|
Code 0=exit ( flag -- )
|
|
D D or D pop >exit 0= not ?] ]] end-code
|
|
\ : ?exit ( flag -- ) IF rdrop THEN ;
|
|
( ----- 011 )
|
|
\ execute perform ks 27 oct 86
|
|
|
|
Code execute ( acf -- ) D W mov D pop W ) jmp end-code
|
|
|
|
Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp
|
|
end-code
|
|
|
|
\ : perform ( addr -- ) @ execute ;
|
|
( ----- 012 )
|
|
\ c@ c! ctoggle ks 27 oct 86
|
|
|
|
Code c@ ( addr -- 8b )
|
|
D W mov W ) D- mov 0 # D+ mov Next end-code
|
|
|
|
Code c! ( 16b addr -- )
|
|
D W mov A pop A- W ) mov D pop Next end-code
|
|
|
|
Code ctoggle ( 8b addr -- )
|
|
D W mov A pop A- W ) xor D pop Next end-code
|
|
|
|
\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ;
|
|
|
|
Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code
|
|
( ----- 013 )
|
|
\ @ ! 2@ 2! ks 27 oct 86
|
|
|
|
Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code
|
|
|
|
Code ! ( 16b addr -- ) D W mov W ) pop D pop Next
|
|
end-code
|
|
|
|
: 2@ ( addr -- 32b ) dup 2+ @ swap @ ;
|
|
|
|
: 2! ( 32b addr -- ) under ! 2+ ! ;
|
|
( ----- 014 )
|
|
\ +! drop swap ks 27 oct 86
|
|
|
|
Code +! ( 16b addr -- )
|
|
D W mov A pop A W ) add D pop Next end-code
|
|
|
|
\ : +! ( n addr -- ) under @ + swap ! ;
|
|
|
|
|
|
Code drop ( 16b -- ) D pop Next end-code
|
|
|
|
Code swap ( 16b1 16b2 -- 16b2 16b1 )
|
|
A pop D push A D xchg Next end-code
|
|
( ----- 015 )
|
|
\ dup ?dup ks 27 oct 86
|
|
|
|
Code dup ( 16b -- 16b 16b ) D push Next end-code
|
|
|
|
\ : dup ( 16b -- 16b 16b ) sp@ @ ;
|
|
|
|
Code ?dup ( 16b -- 16b 16b / false )
|
|
D D or 0= not ?[ D push ]? Next end-code
|
|
|
|
\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ;
|
|
( ----- 016 )
|
|
\ over rot nip under ks 27 oct 86
|
|
|
|
Code over ( 16b1 16b2 -- 16b1 16b2 16b1 )
|
|
A D xchg D pop D push A push Next end-code
|
|
\ : over >r dup r> swap ;
|
|
|
|
Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 )
|
|
A D xchg C pop D pop C push A push Next end-code
|
|
\ : rot >r swap r> swap ;
|
|
|
|
Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code
|
|
\ : nip swap drop ;
|
|
|
|
Code under ( 16b1 16b2 -- 16b2 16b1 16b2 )
|
|
A pop D push A push Next end-code
|
|
\ : under swap over ;
|
|
( ----- 017 )
|
|
\ -rot pick ks 27 oct 86
|
|
|
|
Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )
|
|
A D xchg D pop C pop A push C push Next end-code
|
|
|
|
\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ;
|
|
|
|
Code pick ( n -- 16b.n )
|
|
D sal D W mov S W add W ) D mov Next end-code
|
|
|
|
\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ;
|
|
( ----- 018 )
|
|
\ roll -roll ks 27 oct 86
|
|
|
|
Code roll ( n -- )
|
|
A I xchg D sal D C mov D I mov S I add
|
|
I ) D mov I W mov I dec W inc std
|
|
rep byte movs cld A I xchg S inc S inc Next
|
|
end-code
|
|
\ : roll ( n -- )
|
|
\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ;
|
|
|
|
Code -roll ( n -- ) A I xchg D sal D C mov
|
|
S W mov D pop S I mov S dec S dec
|
|
rep byte movs D W ) mov D pop A I xchg Next
|
|
end-code
|
|
\ : -roll ( n -- ) >r dup sp@ dup 2+
|
|
\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ;
|
|
( ----- 019 )
|
|
\ 2swap 2drop 2dup 2over ks 27 oct 86
|
|
Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop
|
|
C push D push W push A D xchg Next end-code
|
|
\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ;
|
|
|
|
Code 2drop ( 32b -- ) S inc S inc D pop Next end-code
|
|
\ : 2drop ( 32b -- ) drop drop ;
|
|
|
|
Code 2dup ( 32b -- 32b 32b )
|
|
S W mov D push W ) push Next end-code
|
|
\ : 2dup ( 32b -- 32b 32b ) over over ;
|
|
|
|
Code 2over ( 1 2 x x -- 1 2 x x 1 2 )
|
|
D push S W mov 6 W D) push 4 W D) D mov Next
|
|
end-code
|
|
\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ;
|
|
( ----- 020 )
|
|
\ and or xor not ks 27 oct 86
|
|
|
|
Code not ( 16b1 -- 16b2 ) D com Next end-code
|
|
|
|
Code and ( 16b1 16b2 -- 16b3 )
|
|
A pop A D and Next end-code
|
|
|
|
Code or ( 16b1 16b2 -- 16b3 )
|
|
A pop A D or Next end-code
|
|
\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ;
|
|
|
|
Code xor ( 16b1 16b2 -- 16b3 )
|
|
A pop A D xor Next end-code
|
|
( ----- 021 )
|
|
\ + - negate ks 27 oct 86
|
|
|
|
Code + ( n1 n2 -- n3 ) A pop A D add Next end-code
|
|
|
|
Code negate ( n1 -- n2 ) D neg Next end-code
|
|
\ : negate ( n1 -- n2 ) not 1+ ;
|
|
|
|
Code - ( n1 n2 -- n3 )
|
|
A pop D A sub A D xchg Next end-code
|
|
\ : - ( n1 n2 -- n3 ) negate + ;
|
|
( ----- 022 )
|
|
\ dnegate d+ ks 27 oct 86
|
|
|
|
Code dnegate ( d1 -- -d1 ) D com A pop A neg
|
|
CS not ?[ D inc ]? A push Next end-code
|
|
|
|
Code d+ ( d1 d2 -- d3 ) A pop C pop W pop
|
|
W A add A push C D adc Next end-code
|
|
( ----- 023 )
|
|
\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86
|
|
|
|
Code 1+ ( n1 -- n2 ) [[ D inc Next
|
|
Code 2+ ( n1 -- n2 ) [[ D inc swap ]]
|
|
Code 3+ ( n1 -- n2 ) [[ D inc swap ]]
|
|
Code 4+ ( n1 -- n2 ) [[ D inc swap ]]
|
|
| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code
|
|
|
|
Code 1- ( n1 -- n2 ) [[ D dec Next
|
|
Code 2- ( n1 -- n2 ) [[ D dec swap ]]
|
|
Code 4- ( n1 -- n2 ) D dec D dec ]] end-code
|
|
( ----- 024 )
|
|
\ number Constants ks 30 jan 88
|
|
-1 Constant true 0 Constant false
|
|
|
|
0 ( -- 0 ) Constant 0
|
|
1 ( -- 1 ) Constant 1
|
|
2 ( -- 2 ) Constant 2
|
|
3 ( -- 3 ) Constant 3
|
|
4 ( -- 4 ) Constant 4
|
|
-1 ( -- -1 ) Constant -1
|
|
|
|
Code on ( addr -- ) -1 # A mov
|
|
[[ D W mov A W ) mov D pop Next
|
|
Code off ( addr -- ) 0 # A mov ]] end-code
|
|
|
|
\ : on ( addr -- ) true swap ! ;
|
|
\ : off ( addr -- ) false swap ! ;
|
|
( ----- 025 )
|
|
\ words for number literals ks 27 oct 86
|
|
|
|
Code lit ( -- 16b ) D push I ) D mov I inc
|
|
[[ I inc Next end-code restrict
|
|
|
|
Code clit ( -- 8b )
|
|
D push I ) D- mov 0 # D+ mov ]] end-code restrict
|
|
|
|
: Literal ( 16b -- )
|
|
dup $FF00 and IF compile lit , exit THEN
|
|
compile clit c, ; immediate restrict
|
|
( ----- 026 )
|
|
\ comparision code words ks 27 oct 86
|
|
|
|
Code 0= ( 16b -- flag )
|
|
D D or 0 # D mov 0= ?[ D dec ]? Next end-code
|
|
|
|
Code 0<> ( n -- flag )
|
|
D D or 0 # D mov 0= not ?[ D dec ]? Next end-code
|
|
\ : 0<> ( n -- flag ) 0= not ;
|
|
|
|
Code u< ( u1 u2 -- flag ) A pop
|
|
[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code
|
|
|
|
Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code
|
|
\ : u> ( u1 u2 -- flag ) swap u< ;
|
|
( ----- 027 )
|
|
\ comparision words ks 13 sep 88
|
|
Code < ( n1 n2 -- flag ) A pop
|
|
[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code
|
|
|
|
Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code
|
|
|
|
Code 0> ( n -- flag ) A A xor ]] end-code
|
|
|
|
\ : < ( n1 n2 -- flag )
|
|
\ 2dup xor 0< IF drop 0< exit THEN - 0< ;
|
|
\ : > ( n1 n2 -- flag ) swap < ;
|
|
\ : 0> ( n -- flag ) negate 0< ;
|
|
|
|
Code 0< ( n1 n2 -- flag )
|
|
D D or 0 # D mov 0< ?[ D dec ]? Next end-code
|
|
\ : 0< ( n1 -- flag ) 8000 and 0<> ;
|
|
( ----- 028 )
|
|
\ comparision words ks 27 oct 86
|
|
|
|
Code = ( n1 n2 -- flag ) A pop A D cmp
|
|
0 # D mov 0= ?[ D dec ]? Next end-code
|
|
\ : = ( n1 n2 -- flag ) - 0= ;
|
|
|
|
Code uwithin ( u1 [low high[ -- flag ) A pop C pop
|
|
A C cmp CS ?[ [[ swap 0 # D mov Next ]?
|
|
D C cmp CS ?] -1 # D mov Next end-code
|
|
\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ;
|
|
|
|
Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub
|
|
0= ?[ D dec ][ A push D D xor ]? Next end-code
|
|
\ : case? ( 16b1 16b2 -- 16b1 false / true )
|
|
\ over = dup 0=exit nip ;
|
|
( ----- 029 )
|
|
\ double number comparisons ks 27 oct 86
|
|
|
|
Code d0= ( d - f) A pop A D or
|
|
0= not ?[ 1 # D mov ]? D dec Next end-code
|
|
\ : d0= ( d -- flag ) or 0= ;
|
|
|
|
: d= ( d1 d2 -- flag ) dnegate d+ d0= ;
|
|
|
|
Code d< ( d1 d2 -- flag ) C pop A pop
|
|
D A sub A pop -1 # D mov < ?[ [[ swap Next ]?
|
|
0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code
|
|
\ : d< ( d1 d2 -- flag )
|
|
\ rot 2dup - IF > nip nip exit THEN 2drop u< ;
|
|
( ----- 030 )
|
|
\ min max umax umin abs dabs extend ks 27 oct 86
|
|
Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]?
|
|
[[ [[ [[ A D xchg Next end-code
|
|
Code max ( n1 n2 -- n3 )
|
|
A pop A D sub dup < not ?] D A add ]] end-code
|
|
Code umin ( u1 u2 -- u3 )
|
|
A pop A D sub dup CS ?] D A add ]] end-code
|
|
Code umax ( u1 u2 -- u3 )
|
|
A pop A D sub dup CS not ?] D A add ]] end-code
|
|
|
|
Code extend ( n -- d )
|
|
A D xchg cwd A push Next end-code
|
|
|
|
Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code
|
|
|
|
: dabs ( d -- ud ) extend 0=exit dnegate ;
|
|
( ----- 031 )
|
|
\\ min max umax umin extend 10Mar8
|
|
|
|
| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ;
|
|
|
|
: min ( n1 n2 -- n3 ) 2dup > minimax ;
|
|
: max ( n1 n2 -- n3 ) 2dup < minimax ;
|
|
: umax ( u1 u2 -- u3 ) 2dup u< minimax ;
|
|
: umin ( u1 u2 -- u3 ) 2dup u> minimax ;
|
|
: extend ( n -- d ) dup 0< ;
|
|
: dabs ( d -- ud ) extend IF dnegate THEN ;
|
|
: abs ( n -- u) extend IF negate THEN ;
|
|
( ----- 032 )
|
|
\ (do (?do endloop bounds ks 30 jan 88
|
|
|
|
Code (do ( limit start -- ) A pop
|
|
[[ $80 # A+ xor R dec R dec I inc I inc
|
|
I R ) mov R dec R dec A R ) mov R dec R dec
|
|
A D sub D R ) mov D pop Next end-code restrict
|
|
|
|
Code (?do ( limit start -- ) A pop A D cmp 0= ?]
|
|
I ) I add D pop Next end-code restrict
|
|
|
|
Code endloop 6 # R add Next end-code restrict
|
|
|
|
Code bounds ( start count -- limit start )
|
|
A pop A D xchg D A add A push Next end-code
|
|
\ : bounds ( start count -- limit start ) over + swap ;
|
|
( ----- 033 )
|
|
\ (loop (+loop ks 27 oct 86
|
|
|
|
Code (loop R ) word inc
|
|
[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict
|
|
|
|
Code (+loop D R ) add D pop ]] end-code restrict
|
|
|
|
\\
|
|
|
|
| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ;
|
|
\ dodo puts "index | limit | adr.of.DO" on return-stack
|
|
|
|
: (do ( limit start -- ) over - dodo ; restrict
|
|
: (?do ( limit start -- ) over - ?dup IF dodo THEN
|
|
r> dup @ + >r drop ; restrict
|
|
( ----- 034 )
|
|
\ loop indices ks 27 oct 86
|
|
|
|
Code I ( -- n ) D push R ) D mov 2 R D) D add Next
|
|
end-code
|
|
\ : I ( -- n ) r> r> dup r@ + -rot >r >r ;
|
|
|
|
Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next
|
|
end-code
|
|
( ----- 035 )
|
|
\ branch ?branch ks 27 oct 86
|
|
|
|
Code branch
|
|
[[ I ) I add Next end-code restrict
|
|
\ : branch r> dup @ + >r ;
|
|
|
|
Code ?branch D D or D pop 0= not ?]
|
|
I inc I inc Next end-code restrict
|
|
( ----- 036 )
|
|
\ resolve loops and branches ks 02 okt 87
|
|
|
|
: >mark ( -- addr ) here 0 , ;
|
|
|
|
: >resolve ( addr -- ) here over - swap ! ;
|
|
|
|
: <mark ( -- addr ) here ;
|
|
|
|
: <resolve ( addr -- ) here - , ;
|
|
|
|
: ?pairs ( n1 n2 -- ) - Abort" unstructured" ;
|
|
( ----- 037 )
|
|
\ Branching ks 17 jul 87
|
|
|
|
: IF compile ?branch >mark 1 ; immediate restrict
|
|
: THEN abs 1 ?pairs >resolve ; immediate restrict
|
|
: ELSE 1 ?pairs compile branch >mark
|
|
swap >resolve -1 ; immediate restrict
|
|
|
|
: BEGIN <mark 2 ; immediate restrict
|
|
: WHILE 2 ?pairs 2 compile ?branch
|
|
>mark -2 2swap ; immediate restrict
|
|
|
|
| : (repeat 2 ?pairs <resolve
|
|
BEGIN dup -2 = WHILE drop >resolve REPEAT ;
|
|
|
|
: REPEAT compile branch (repeat ; immediate restrict
|
|
: UNTIL compile ?branch (repeat ; immediate restrict
|
|
( ----- 038 )
|
|
\ Loops ks 27 oct 86
|
|
|
|
: DO compile (do >mark 3 ; immediate restrict
|
|
: ?DO compile (?do >mark 3 ; immediate restrict
|
|
: LOOP 3 ?pairs compile (loop
|
|
compile endloop >resolve ; immediate restrict
|
|
: +LOOP 3 ?pairs compile (+loop
|
|
compile endloop >resolve ; immediate restrict
|
|
|
|
Code LEAVE 6 # R add -2 R D) I mov
|
|
I dec I dec I ) I add Next end-code restrict
|
|
|
|
\ : LEAVE endloop r> 2- dup @ + >r ; restrict
|
|
\ Returnstack: | calladr | index | limit | adr of DO |
|
|
( ----- 039 )
|
|
\ um* m* * ks 29 jul 87
|
|
|
|
Code um* ( u1 u2 -- ud3 )
|
|
A D xchg C pop C mul A push Next end-code
|
|
|
|
Code m* ( n1 n2 -- d3 )
|
|
A D xchg C pop C imul A push Next end-code
|
|
\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap
|
|
\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ;
|
|
|
|
: * ( n1 n2 - prod ) um* drop ;
|
|
|
|
Code 2* ( u -- 2*u ) D shl Next end-code
|
|
\ : 2* ( u -- 2*u ) dup + ;
|
|
( ----- 040 )
|
|
\ um/mod m/mod ks 27 oct 86
|
|
|
|
Code um/mod ( ud1 u2 -- urem uquot )
|
|
D C mov D pop A pop C div A D xchg A push Next
|
|
end-code
|
|
|
|
Code m/mod ( d1 n2 -- rem quot ) D C mov D pop
|
|
Label divide D+ A+ mov C+ A+ xor A pop 0< not
|
|
?[ C idiv [[ swap A D xchg A push Next ]?
|
|
C idiv D D or dup 0= not ?] A dec C D add ]]
|
|
end-code
|
|
|
|
\ : m/mod ( d n -- mod quot ) dup >r
|
|
\ abs over 0< IF under + swap THEN um/mod r@ 0<
|
|
\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ;
|
|
( ----- 041 )
|
|
\ /mod division trap 2/ ks 13 sep 88
|
|
|
|
Code /mod ( n1 n2 -- rem quot )
|
|
D C mov A pop cwd A push divide ]] end-code
|
|
\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ;
|
|
|
|
0 >label >divINT
|
|
|
|
Label divovl Assembler
|
|
4 # S add popf 1 # D- mov ;c: Abort" / overflow" ;
|
|
|
|
Code 2/ ( n1 -- n/2 ) D sar Next end-code
|
|
\ : 2/ ( n -- n/2 ) 2 / ;
|
|
( ----- 042 )
|
|
\ / mod */mod */ u/mod ud/mod ks 27 oct 86
|
|
|
|
: / ( n1 n2 -- quot ) /mod nip ;
|
|
|
|
: mod ( n1 n2 -- rem ) /mod drop ;
|
|
|
|
: */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ;
|
|
|
|
: */ ( n1 n2 n3 -- quot ) */mod nip ;
|
|
|
|
: u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ;
|
|
|
|
: ud/mod ( ud1 u2 -- urem udquot )
|
|
>r 0 r@ um/mod r> swap >r um/mod r> ;
|
|
( ----- 043 )
|
|
\ cmove cmove> move ks 27 oct 86
|
|
|
|
Code cmove ( from to quan -- ) A I xchg D C mov
|
|
W pop I pop D pop rep byte movs A I xchg Next
|
|
end-code
|
|
|
|
Code cmove> ( from to quan -- )
|
|
A I xchg D C mov W pop I pop D pop
|
|
Label moveup C dec C W add C I add C inc
|
|
std rep byte movs A I xchg cld Next end-code
|
|
|
|
Code move ( from to quan -- )
|
|
A I xchg D C mov W pop I pop D pop
|
|
Label domove I W cmp moveup CS ?]
|
|
rep byte movs A I xchg Next end-code
|
|
( ----- 044 )
|
|
\ place count ks 27 oct 86
|
|
|
|
| Code (place ( addr len to - len to) A I xchg D W mov
|
|
C pop I pop C push W inc domove ]] end-code
|
|
|
|
: place ( addr len to -) (place c! ;
|
|
|
|
Code count ( addr -- addr+1 len ) D W mov
|
|
W ) D- mov 0 # D+ mov W inc W push Next end-code
|
|
|
|
\ : move ( from to quan -- )
|
|
\ >r 2dup u< IF r> cmove> exit THEN r> cmove ;
|
|
\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ;
|
|
\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ;
|
|
( ----- 045 )
|
|
\ fill erase ks 27 oct 86
|
|
|
|
Code fill ( addr quan 8b -- )
|
|
D A xchg C pop W pop D pop rep byte stos Next
|
|
end-code
|
|
|
|
\ : fill ( addr quan 8b -- ) swap ?dup
|
|
\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ;
|
|
|
|
: erase ( addr quan --) 0 fill ;
|
|
( ----- 046 )
|
|
\ here allot , c, pad compile ks 27 oct 86
|
|
|
|
Code here ( -- addr ) D push u' dp U D) D mov Next
|
|
end-code
|
|
\ : here ( -- addr ) dp @ ;
|
|
|
|
Code allot ( n -- ) D u' dp U D) add D pop Next
|
|
end-code
|
|
\ : allot ( n -- ) dp +! ;
|
|
|
|
: , ( 16b -- ) here ! 2 allot ;
|
|
: c, ( 8b -- ) here c! 1 allot ;
|
|
: pad ( -- addr ) here $42 + ;
|
|
: compile r> dup 2+ >r @ , ; restrict
|
|
( ----- 047 )
|
|
\ input strings ks 23 dez 87
|
|
|
|
Variable #tib #tib off
|
|
Variable >tib here >tib ! $50 allot
|
|
Variable >in >in off
|
|
Variable blk blk off
|
|
Variable span span off
|
|
|
|
: tib ( -- addr ) >tib @ ;
|
|
|
|
: query tib $50 expect span @ #tib ! >in off ;
|
|
( ----- 048 )
|
|
\ skip scan /string ks 22 dez 87
|
|
|
|
Code skip ( addr len char -- addr1 len1 )
|
|
A D xchg C pop C0= not
|
|
?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]?
|
|
W push ]? C D mov Next end-code
|
|
|
|
Code scan ( addr0 len0 char -- addr1 len1 )
|
|
A D xchg C pop C0= not
|
|
?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]?
|
|
W push ]? C D mov Next end-code
|
|
|
|
Code /string ( addr0 len0 +n -- addr1 len1 )
|
|
A pop C pop D A sub CS ?[ A D add A A xor ]?
|
|
C D add D push A D xchg Next end-code
|
|
( ----- 049 )
|
|
\\ scan skip /string ks 29 jul 87
|
|
|
|
: skip ( addr0 len0 char -- addr1 len1 ) >r
|
|
BEGIN dup
|
|
WHILE over c@ r@ = WHILE 1- swap 1+ swap
|
|
REPEAT rdrop ;
|
|
|
|
: scan ( addr0 len0 char -- addr1 len1 ) >r
|
|
BEGIN dup
|
|
WHILE over c@ r@ - WHILE 1- swap 1+ swap
|
|
REPEAT rdrop ;
|
|
|
|
: /string ( addr0 len0 +n -- addr1 len1 )
|
|
over umin rot over + -rot - ;
|
|
( ----- 050 )
|
|
\ capital ks 19 dez 87
|
|
|
|
Create (capital Assembler $61 # A- cmp CS not
|
|
?[ $7B # A- cmp CS not
|
|
?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \
|
|
$94 # A- cmp 0= ?[ $99 # A- mov ret ]? \
|
|
$81 # A- cmp 0= ?[ $9A # A- mov ]? ret \
|
|
]? $20 # A- xor
|
|
]? ret end-code
|
|
|
|
Code capital ( char -- char' )
|
|
A D xchg (capital # call A D xchg Next
|
|
end-code
|
|
( ----- 051 )
|
|
\ upper ks 03 aug 87
|
|
|
|
Code upper ( addr len -- )
|
|
D C mov W pop D pop C0= not
|
|
?[ [[ W ) A- mov (capital # call
|
|
A- W ) mov W inc C0= ?] ]? Next
|
|
end-code
|
|
|
|
\\ high level definition, without umlauts
|
|
|
|
: capital ( char -- char')
|
|
dup Ascii a [ Ascii z 1+ ] Literal
|
|
uwithin not ?exit [ Ascii a Ascii A - ] Literal - ;
|
|
|
|
: upper ( addr len -- )
|
|
bounds ?DO I c@ capital I c! LOOP ;
|
|
( ----- 052 )
|
|
\ (word ks 28 mai 87
|
|
|
|
| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop
|
|
A pop >in #) D mov D C sub >= not
|
|
?[ C push D W add 0=rep byte scas W D mov 0= not
|
|
?[ W dec D dec C inc
|
|
0<>rep byte scas 0= ?[ W dec ]?
|
|
]? A pop C A sub A >in #) add
|
|
W C mov D C sub 0= not
|
|
?[ D I xchg u' dp U D) W mov C- W ) mov
|
|
W inc rep byte movs $20 # W ) byte mov
|
|
D I mov u' dp U D) D mov Next
|
|
swap ]? C >in #) add
|
|
]? u' dp U D) W mov $2000 # W ) mov W D mov Next
|
|
end-code
|
|
( ----- 053 )
|
|
\\ (word ks 27 oct 86
|
|
|
|
| : (word ( char adr0 len0 -- addr )
|
|
rot >r over swap >in @ /string r@ skip
|
|
over swap r> scan >r rot over swap - r> 0<> - >in !
|
|
over - here dup >r place bl r@ count + c! r> ;
|
|
( ----- 054 )
|
|
\ source word parse name ks 03 aug 87
|
|
|
|
defer source
|
|
: (source ( -- addr len ) tib #tib @ exit ;
|
|
' source Is (source
|
|
|
|
: word ( char -- addr ) source (word ;
|
|
|
|
: parse ( char -- addr len ) >r source >in @ /string
|
|
over swap r> scan >r over - dup r> 0<> - >in +! ;
|
|
|
|
: name ( -- string ) bl word dup count upper exit ;
|
|
( ----- 055 )
|
|
\ state Ascii ," "lit (" " ks 16 sep 88
|
|
Variable state state off
|
|
|
|
: Ascii ( char -- n ) bl word 1+ c@
|
|
state @ 0=exit [compile] Literal ; immediate
|
|
|
|
: ," Ascii " parse here over 1+ allot place ;
|
|
|
|
Code "lit ( -- addr ) D push R ) D mov D W mov
|
|
W ) A- mov 0 # A+ mov A inc A R ) add Next
|
|
end-code restrict
|
|
\ : "lit r> r> under count + even >r >r ; restrict
|
|
|
|
: (" "lit ; restrict
|
|
|
|
: " compile (" ," align ; immediate restrict
|
|
( ----- 056 )
|
|
\ ." ( .( \ \\ hex decimal ks 12 dez 88
|
|
|
|
: (." "lit count type ; restrict
|
|
: ." compile (." ," align ; immediate restrict
|
|
|
|
: ( Ascii ) parse 2drop ; immediate
|
|
: .( Ascii ) parse type ; immediate
|
|
|
|
: \ >in @ negate c/l mod >in +! ; immediate
|
|
: \\ b/blk >in ! ; immediate
|
|
: have ( <name> -- f ) name find nip 0<> ; immediate
|
|
: \needs have 0=exit [compile] \ ;
|
|
|
|
: hex $10 base ! ;
|
|
: decimal &10 base ! ;
|
|
( ----- 057 )
|
|
\ number conversion: digit? accumulate convert ks 08 okt 87
|
|
|
|
: digit? ( char -- digit true/ false ) dup Ascii 9 >
|
|
IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and
|
|
THEN Ascii 0 - dup base @ u< dup ?exit nip ;
|
|
|
|
: accumulate ( +d0 adr digit -- +d1 adr ) swap >r
|
|
swap base @ um* drop rot base @ um* d+ r> ;
|
|
|
|
: convert ( +d1 addr0 -- +d2 addr2 )
|
|
1+ BEGIN count digit? WHILE accumulate REPEAT 1- ;
|
|
( ----- 058 )
|
|
\ number conversion ks 29 jun 87
|
|
| : end? ( -- flag ) >in @ 0= ;
|
|
|
|
| : char ( addr0 -- addr1 char ) count -1 >in +! ;
|
|
|
|
| : previous ( addr0 -- addr0 char ) 1- count ;
|
|
|
|
| : punctuation? ( char -- flag )
|
|
Ascii , over = swap Ascii . = or ;
|
|
\ : punctuation? ( char -- f ) ?" .," ;
|
|
|
|
| : fixbase? ( char -- char false / newbase true ) capital
|
|
Ascii $ case? IF $10 true exit THEN
|
|
Ascii H case? IF $10 true exit THEN
|
|
Ascii & case? IF &10 true exit THEN
|
|
Ascii % case? IF 2 true exit THEN false ;
|
|
( ----- 059 )
|
|
\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86
|
|
|
|
Variable dpl -1 dpl !
|
|
|
|
| : ?num ( flag -- exit if true ) 0=exit
|
|
rdrop drop r> IF dnegate THEN rot drop
|
|
dpl @ 1+ ?dup ?exit drop true ;
|
|
|
|
| : ?nonum ( flag -- exit if true ) 0=exit
|
|
rdrop 2drop drop rdrop false ;
|
|
|
|
| : ?dpl dpl @ -1 = ?exit 1 dpl +! ;
|
|
( ----- 060 )
|
|
\ number conversion: number? number ks 27 oct 86
|
|
|
|
: number? ( string -- string false / n 0< / d 0> )
|
|
base push >in push dup count >in ! dpl on
|
|
0 >r ( +sign) 0.0 rot end? ?nonum char
|
|
Ascii - case? IF rdrop true >r end? ?nonum char THEN
|
|
fixbase? IF base ! end? ?nonum char THEN
|
|
BEGIN digit? 0= ?nonum
|
|
BEGIN accumulate ?dpl end? ?num char digit?
|
|
0= UNTIL previous punctuation? 0= ?nonum
|
|
dpl off end? ?num char
|
|
REPEAT ;
|
|
|
|
: number ( string -- d )
|
|
number? ?dup 0= Abort" ?" 0> ?exit extend ;
|
|
( ----- 061 )
|
|
\ hide reveal immediate restrict ks 18 m„r 88
|
|
Variable last last off
|
|
|
|
: last' ( -- cfa ) last @ name> ;
|
|
|
|
| : last? ( -- false / nfa true) last @ ?dup ;
|
|
: hide last? 0=exit 2- @ current @ ! ;
|
|
: reveal last? 0=exit 2- current @ ! ;
|
|
|
|
: Recursive reveal ; immediate restrict
|
|
|
|
| : flag! ( 8b --)
|
|
last? IF under c@ or over c! THEN drop ;
|
|
|
|
: immediate $40 flag! ;
|
|
: restrict $80 flag! ;
|
|
( ----- 062 )
|
|
\ clearstack hallot heap heap? ks 27 oct 86
|
|
|
|
Code clearstack u' s0 U D) S mov D pop Next end-code
|
|
|
|
: hallot ( quan -- )
|
|
s0 @ over - swap sp@ 2+ dup rot - dup s0 !
|
|
2 pick over - di move clearstack ei s0 ! ;
|
|
|
|
: heap ( -- addr ) s0 @ 6 + ;
|
|
: heap? ( addr -- flag ) heap up@ uwithin ;
|
|
|
|
| : heapmove ( from -- from )
|
|
dup here over - dup hallot
|
|
heap swap cmove heap over - last +! reveal ;
|
|
( ----- 063 )
|
|
\ Does> ; ks 18 m„r 88
|
|
|
|
| Create dodo Assembler
|
|
R dec R dec I R ) mov \ push IP
|
|
D push 2 W D) D lea \ load parameter address
|
|
W ) I mov 3 # I add Next end-code
|
|
|
|
dodo Host tdodo ! Target \ target compiler needs to know
|
|
|
|
: (;code r> last' ! ;
|
|
|
|
: Does> compile (;code $E9 c, ( jmp instruction)
|
|
dodo here 2+ - , ; immediate restrict
|
|
( ----- 064 )
|
|
\ ?head | alignments ks 19 m„r 88
|
|
Variable ?head ?head off
|
|
|
|
: | ?head @ ?exit ?head on ;
|
|
|
|
\ no alignment required on x86
|
|
: even ( addr -- addr1 ) ; immediate
|
|
: align ( -- ) ; immediate
|
|
: halign ( -- ) ; immediate
|
|
|
|
Variable warning warning on
|
|
|
|
| : ?exists warning @ 0=exit
|
|
last @ current @ (find nip 0=exit
|
|
space last @ .name ." exists " ?cr ;
|
|
( ----- 065 )
|
|
\ Create Variable ks 19 m„r 88
|
|
|
|
Defer makeview ' 0 Is makeview
|
|
|
|
: Create align here makeview , current @ @ ,
|
|
name c@ dup 1 $20 uwithin not Abort" invalid name"
|
|
here last ! 1+ allot align ?exists
|
|
?head @ IF 1 ?head +! dup , \ Pointer to Code
|
|
halign heapmove $20 flag! dup dp !
|
|
THEN drop reveal 0 ,
|
|
;Code ( -- addr ) D push 2 W D) D lea Next end-code
|
|
|
|
: Variable Create 0 , ;
|
|
( ----- 066 )
|
|
\ nfa? ks 28 mai 87
|
|
|
|
Code nfa? ( thread cfa -- nfa / false )
|
|
W pop R A mov $1F # C mov
|
|
[[ W ) W mov W W or 0= not
|
|
?[[ 2 W D) R- mov C R and 3 R W DI) R lea
|
|
$20 # 2 W D) test 0= not ?[ R ) R mov ]?
|
|
D R cmp 0= ?] 2 W D) W lea
|
|
]? W D mov A R mov Next end-code
|
|
|
|
\\
|
|
|
|
: nfa? ( thread cfa -- nfa / false ) >r
|
|
BEGIN @ dup 0= IF rdrop exit THEN
|
|
dup 2+ name> r@ = UNTIL 2+ rdrop ;
|
|
( ----- 067 )
|
|
\ >name name> >body .name ks 13 aug 87
|
|
|
|
: >name ( acf -- anf / ff ) voc-link
|
|
BEGIN @ dup WHILE 2dup 4 - swap nfa?
|
|
?dup IF -rot 2drop exit THEN REPEAT nip ;
|
|
|
|
: (name> ( nfa -- cfa ) count $1F and + even ;
|
|
|
|
: name> ( nfa -- cfa )
|
|
dup (name> swap c@ $20 and 0=exit @ ;
|
|
|
|
: >body ( cfa -- pfa ) 2+ ;
|
|
: body> ( pfa -- cfa ) 2- ;
|
|
|
|
: .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN
|
|
count $1F and type ELSE ." ???" THEN space ;
|
|
( ----- 068 )
|
|
\ : ; Constant Variable ks 29 oct 86
|
|
|
|
: Create: Create hide current @ context ! 0 ] ;
|
|
|
|
: : Create:
|
|
;Code R dec R dec I R ) mov 2 W D) I lea Next
|
|
end-code
|
|
|
|
: ; 0 ?pairs compile unnest [compile] [ reveal ;
|
|
immediate restrict
|
|
|
|
: Constant ( n -- ) Create ,
|
|
;Code ( -- n ) D push 2 W D) D mov Next end-code
|
|
( ----- 069 )
|
|
\ uallot User Alias Defer ks 02 okt 87
|
|
: uallot ( quan -- offset ) even dup udp @ +
|
|
$FF u> Abort" Userarea full" udp @ swap udp +! ;
|
|
|
|
: User Create 2 uallot c,
|
|
;Code ( -- addr ) D push 2 W D) D- mov
|
|
0 # D+ mov U D add Next end-code
|
|
|
|
: Alias ( cfa -- )
|
|
Create last @ dup c@ $20 and
|
|
IF -2 allot ELSE $20 flag! THEN (name> ! ;
|
|
|
|
| : crash true Abort" crash" ;
|
|
|
|
: Defer Create ['] crash ,
|
|
;Code 2 W D) W mov W ) jmp end-code
|
|
( ----- 070 )
|
|
\ vp current context also toss ks 02 okt 87
|
|
|
|
Create vp $10 allot
|
|
Variable current
|
|
|
|
: context ( -- adr ) vp dup @ + 2+ ;
|
|
|
|
| : thru.vocstack ( -- from to ) vp 2+ context ;
|
|
|
|
\ "Only Forth also Assembler" gives
|
|
\ vp: countword = 6 | Root | Forth | Assembler |
|
|
|
|
: also vp @ &10 > Error" Vocabulary stack full"
|
|
context @ 2 vp +! context ! ;
|
|
|
|
: toss vp @ 0=exit -2 vp +! ;
|
|
( ----- 071 )
|
|
\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88
|
|
: Vocabulary Create 0 , 0 , here voc-link @ , voc-link !
|
|
Does> context ! ;
|
|
\ | Name | Code | Thread | Coldthread | Voc-link |
|
|
|
|
Vocabulary Forth
|
|
Host h' Transient 8 + @ T h' Forth 8 + H !
|
|
Target Forth also definitions
|
|
|
|
Vocabulary Root
|
|
|
|
: Only vp off Root also ;
|
|
|
|
: Onlyforth Only Forth also definitions ;
|
|
|
|
: definitions context @ current ! ;
|
|
( ----- 072 )
|
|
\ order vocs words ks 19 jun 88
|
|
| : init-vocabularys voc-link @
|
|
BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ;
|
|
| : .voc ( adr -- ) @ 2- >name .name ;
|
|
|
|
: order vp 4+ context over umax
|
|
DO I .voc -2 +LOOP 2 spaces current .voc ;
|
|
|
|
: vocs voc-link
|
|
BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ;
|
|
|
|
: words ( -- ) [compile] Ascii capital >r context @
|
|
BEGIN @ dup stop? 0= and
|
|
WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or
|
|
IF .name space ELSE drop THEN
|
|
REPEAT drop rdrop ;
|
|
( ----- 073 )
|
|
\ (find found ks 09 jul 87
|
|
| : found ( nfa -- cfa n ) dup c@ >r
|
|
(name> r@ $20 and IF @ THEN
|
|
-1 r@ $80 and IF 1- THEN
|
|
r> $40 and IF negate THEN ;
|
|
|
|
Code (find ( string thread -- string ff / anf tf )
|
|
D I xchg W pop D push W ) A- mov W inc
|
|
W D mov 0 # C+ mov $1F # A+ mov A+ A- and
|
|
[[ I ) I mov I I or 0= not
|
|
?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?]
|
|
I push D W mov 3 # I add
|
|
0=rep byte cmps I pop 0= ?]
|
|
3 # I add I W mov -1 # D mov
|
|
][ D W mov 0 # D mov ]? W dec I pop W push Next
|
|
end-code
|
|
( ----- 074 )
|
|
\\ -text (find ks 02 okt 87
|
|
|
|
: -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 )
|
|
over bounds
|
|
DO drop count I c@ - dup IF LEAVE THEN LOOP nip ;
|
|
|
|
: (find ( string thread -- str false / NFA +n )
|
|
over c@ $1F and >r @
|
|
BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ =
|
|
IF dup 1+ r@ 4 pick 1+ -text
|
|
0= IF rdrop -rot drop exit
|
|
THEN THEN drop
|
|
REPEAT rdrop ;
|
|
( ----- 075 )
|
|
\ find ' [compile] ['] nullstring? ks 29 oct 86
|
|
|
|
: find ( string -- acf n / string false )
|
|
context dup @ over 2- @ = IF 2- THEN
|
|
BEGIN under @ (find IF nip found exit THEN
|
|
swap 2- dup vp = UNTIL drop false ;
|
|
|
|
: ' ( -- cfa ) name find ?exit Error" ?" ;
|
|
|
|
: [compile] ' , ; immediate restrict
|
|
|
|
: ['] ' [compile] Literal ; immediate restrict
|
|
|
|
: nullstring? ( string -- string false / true )
|
|
dup c@ 0= dup 0=exit nip ;
|
|
( ----- 076 )
|
|
\ interpreter ks 07 dez 87
|
|
|
|
Defer notfound
|
|
|
|
| : interpreter ( string -- ) find ?dup
|
|
IF 1 and IF execute exit THEN
|
|
Error" compile only"
|
|
THEN number? ?exit notfound ;
|
|
|
|
| : compiler ( string -- ) find ?dup
|
|
IF 0> IF execute exit THEN , exit THEN
|
|
number? ?dup IF 0> IF swap [compile] Literal THEN
|
|
[compile] Literal exit
|
|
THEN notfound ;
|
|
( ----- 077 )
|
|
\ compiler [ ] ks 16 sep 88
|
|
|
|
: no.extensions ( string -- )
|
|
state @ IF Abort" ?" THEN Error" ?" ;
|
|
|
|
' no.extensions Is notfound
|
|
|
|
Defer parser ( string -- ) ' interpreter Is parser
|
|
|
|
: interpret
|
|
BEGIN ?stack name nullstring? IF aborted off exit THEN
|
|
parser REPEAT ;
|
|
|
|
: [ ['] interpreter Is parser state off ; immediate
|
|
|
|
: ] ['] compiler Is parser state on ;
|
|
( ----- 078 )
|
|
\ Is ks 07 dez 87
|
|
|
|
: (is r> dup 2+ >r @ ! ;
|
|
|
|
| : def? ( cfa -- )
|
|
@ [ ' notfound @ ] Literal - Abort" not deferred" ;
|
|
|
|
: Is ( addr -- ) ' dup def? >body
|
|
state @ IF compile (is , exit THEN ! ; immediate
|
|
( ----- 079 )
|
|
\ ?stack ks 01 okt 87
|
|
|
|
| : stackfull ( -- ) depth $20 > Abort" tight stack"
|
|
reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN
|
|
true Abort" dictionary full" ;
|
|
|
|
Code ?stack u' dp U D) A mov S A sub CS
|
|
?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]?
|
|
u' s0 U D) A mov A inc A inc S A sub
|
|
CS not ?[ Next ]? ;c: true Abort" stack empty" ;
|
|
|
|
\ : ?stack sp@ here - $100 u< IF stackfull THEN
|
|
\ sp@ s0 @ u> Abort" stack empty" ;
|
|
( ----- 080 )
|
|
\ .status push ks 29 oct 86
|
|
|
|
| Create: pull r> r> ! ;
|
|
: push ( addr -- )
|
|
r> swap dup >r @ >r pull >r >r ; restrict
|
|
|
|
Defer .status ' noop Is .status
|
|
|
|
|
|
( ----- 081 )
|
|
|
|
: rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ;
|
|
|
|
: depth ( -- +n ) sp@ s0 @ swap - 2/ ;
|
|
|
|
( ----- 082 )
|
|
\ prompt quit ks 16 sep 88
|
|
|
|
: (prompt .status state @ IF cr ." ] " exit THEN
|
|
aborted @ 0= IF ." ok" THEN cr ;
|
|
|
|
Defer prompt ' (prompt Is prompt
|
|
|
|
: (quit BEGIN prompt query interpret REPEAT ;
|
|
|
|
Defer 'quit ' (quit Is 'quit
|
|
|
|
: quit r0 @ rp! [compile] [ blk off 'quit ;
|
|
|
|
\ : classical cr .status state @
|
|
\ IF ." C> " exit THEN ." I> " ;
|
|
( ----- 083 )
|
|
\ end-trace abort ks 26 jul 87
|
|
|
|
: standardi/o [ output ] Literal output 4 cmove ;
|
|
|
|
Code end-trace next-link # W mov $AD # A- mov
|
|
$FF97 # C mov [[ W ) W mov W W or 0= not
|
|
?[[ A- -4 W D) mov C -3 W D) mov
|
|
]]? lods A W xchg W ) jmp end-code
|
|
|
|
Defer 'abort ' noop Is 'abort
|
|
|
|
: abort end-trace clearstack 'abort standardi/o quit ;
|
|
( ----- 084 )
|
|
\ (error Abort" Error" ks 16 sep 88
|
|
Variable scr 1 scr !
|
|
Variable r# r# off
|
|
|
|
: (error ( string -- ) rdrop r> aborted ! standardi/o
|
|
space here .name count type space ?cr
|
|
blk @ ?dup IF scr ! >in @ r# ! THEN quit ;
|
|
' (error errorhandler !
|
|
|
|
: (abort" "lit swap IF >r clearstack r>
|
|
errorhandler perform exit THEN drop ; restrict
|
|
|
|
| : (error" "lit swap IF errorhandler perform exit THEN
|
|
drop ; restrict
|
|
( ----- 085 )
|
|
\ -trailing space spaces ks 16 sep 88
|
|
|
|
: Abort" compile (abort" ," align ; immediate restrict
|
|
: Error" compile (error" ," align ; immediate restrict
|
|
|
|
$20 Constant bl
|
|
|
|
: -trailing ( addr n1 -- addr n2)
|
|
dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ;
|
|
|
|
: space bl emit ;
|
|
: spaces ( u -- ) 0 ?DO space LOOP ;
|
|
( ----- 086 )
|
|
\ hold <# #> sign # #s ks 29 dez 87
|
|
|
|
| : hld ( -- addr) pad 2- ;
|
|
|
|
: hold ( char -- ) -1 hld +! hld @ c! ;
|
|
|
|
: <# hld hld ! ;
|
|
|
|
: #> ( 32b -- addr +n ) 2drop hld @ hld over - ;
|
|
|
|
: sign ( n -- ) 0< not ?exit Ascii - hold ;
|
|
|
|
: # ( +d1 -- +d2)
|
|
base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ;
|
|
|
|
: #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
|
|
( ----- 087 )
|
|
\ print numbers .s ks 07 feb 89
|
|
|
|
: d.r ( d +n -- ) -rot under dabs <# #s rot sign #>
|
|
rot over max over - spaces type ;
|
|
: d. ( d -- ) 0 d.r space ;
|
|
|
|
: .r ( n +n -- ) swap extend rot d.r ;
|
|
: . ( n -- ) extend d. ;
|
|
|
|
: u.r ( u +n -- ) 0 swap d.r ;
|
|
: u. ( u -- ) 0 d. ;
|
|
|
|
: .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ;
|
|
( ----- 088 )
|
|
\ c/l l/s ks 19 m„r 88
|
|
|
|
&64 Constant c/l \ Screen line length
|
|
&16 Constant l/s \ lines per screen
|
|
|
|
( ----- 089 )
|
|
\ multitasker primitives ks 29 oct 86
|
|
|
|
Code pause D push I push R push
|
|
S 6 U D) mov 2 U D) U add 4 # U add U jmp
|
|
end-code
|
|
|
|
: lock ( addr -- )
|
|
dup @ up@ = IF drop exit THEN
|
|
BEGIN dup @ WHILE pause REPEAT up@ swap ! ;
|
|
|
|
: unlock ( addr -- ) dup lock off ;
|
|
|
|
Label wake Assembler U pop 2 # U sub A pop
|
|
popf 6 U D) S mov R pop I pop D pop Next
|
|
end-code
|
|
$E9 4 * >label >taskINT
|
|
( ----- 090 )
|
|
|
|
( ----- 091 )
|
|
$10000 Constant limit Variable first
|
|
$408 Constant b/buf \ physikalische Groesse
|
|
$400 Constant b/blk \ bytes/block
|
|
|
|
Defer r/w \ physikalischer Diskzugriff
|
|
|
|
( ----- 092 )
|
|
|
|
( ----- 093 )
|
|
|
|
( ----- 094 )
|
|
|
|
( ----- 095 )
|
|
|
|
( ----- 096 )
|
|
|
|
( ----- 097 )
|
|
|
|
( ----- 098 )
|
|
|
|
( ----- 099 )
|
|
\ endpoints of forget uh 27 apr 88
|
|
|
|
| : |? ( nfa -- flag ) c@ $20 and ;
|
|
|
|
| : forget? ( adr nfa -- flag ) \ code in heap or above adr ?
|
|
name> under 1+ u< swap heap? or ;
|
|
|
|
| : endpoint ( addr sym thread -- addr sym' )
|
|
BEGIN BEGIN @ 2 pick over u> IF drop exit THEN
|
|
dup heap? UNTIL dup >r 2+ dup |?
|
|
IF >r over r@ forget? IF r@ (name> >body umax THEN
|
|
rdrop THEN r>
|
|
REPEAT ;
|
|
|
|
| : endpoints ( addr -- addr symb ) heap voc-link @
|
|
BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ;
|
|
( ----- 100 )
|
|
\ remove, -words, -tasks ks 30 apr 88
|
|
: remove ( dic sym thread -- dic sym )
|
|
BEGIN dup @ ?dup \ unlink forg. words
|
|
WHILE dup heap?
|
|
IF 2 pick over u> ELSE 3 pick over 1+ u< THEN
|
|
IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ;
|
|
|
|
| : remove-words ( dic sym -- dic sym ) voc-link
|
|
BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ;
|
|
|
|
| : >up 2+ dup @ 2+ + ;
|
|
|
|
| : remove-tasks ( dic -- ) up@
|
|
BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin
|
|
IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN
|
|
REPEAT 2drop ;
|
|
( ----- 101 )
|
|
\ remove-vocs trim ks 31 oct 86
|
|
|
|
| : remove-vocs ( dic symb -- dic symb )
|
|
voc-link remove thru.vocstack
|
|
DO 2dup I @ -rot uwithin
|
|
IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP
|
|
2dup current @ -rot uwithin 0=exit
|
|
[ ' Forth 2+ ] Literal current ! ;
|
|
|
|
Defer custom-remove ' noop Is custom-remove
|
|
|
|
: trim ( dic symb -- ) next-link remove
|
|
over remove-tasks remove-vocs remove-words
|
|
custom-remove heap swap - hallot dp ! last off ;
|
|
( ----- 102 )
|
|
\ deleting words from dict. ks 02 okt 87
|
|
|
|
: clear here dup up@ trim dp ! ;
|
|
|
|
: (forget ( adr -- )
|
|
dup heap? Abort" is symbol" endpoints trim ;
|
|
|
|
: forget ' dup [ dp ] Literal @ u< Abort" protected"
|
|
>name dup heap? IF name> ELSE 4- THEN (forget ;
|
|
|
|
: empty [ dp ] Literal @ up@ trim
|
|
[ udp ] Literal @ udp ! ;
|
|
( ----- 103 )
|
|
\ save bye stop? ?cr ks 1UH 26sep88
|
|
|
|
: save here up@ trim up@ origin $100 cmove
|
|
voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ;
|
|
|
|
$1B Constant #esc
|
|
|
|
| : end? key #esc case? 0=
|
|
IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN
|
|
true rdrop ;
|
|
|
|
: stop? ( -- flag ) key? IF end? end? THEN false ;
|
|
|
|
: ?cr col c/l u> 0=exit cr ;
|
|
( ----- 104 )
|
|
\ in/output structure ks 31 oct 86
|
|
|
|
| : Out: Create dup c, 2+ Does> c@ output @ + perform ;
|
|
|
|
: Output: Create: Does> output ! ;
|
|
0 Out: emit Out: cr Out: type Out: del
|
|
Out: page Out: at Out: at? drop
|
|
|
|
: row ( -- row ) at? drop ;
|
|
: col ( -- col ) at? nip ;
|
|
|
|
| : In: Create dup c, 2+ Does> c@ input @ + perform ;
|
|
|
|
: Input: Create: Does> input ! ;
|
|
0 In: key In: key? In: decode In: expect drop
|
|
( ----- 105 )
|
|
\ Alias only definitionen ks 31 oct 86
|
|
|
|
Root definitions
|
|
|
|
: seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab.
|
|
|
|
' Only Alias Only
|
|
' Forth Alias Forth
|
|
' words Alias words
|
|
' also Alias also
|
|
' definitions Alias definitions
|
|
|
|
Forth definitions
|
|
( ----- 106 )
|
|
\ 'restart 'cold ks 01 sep 88
|
|
|
|
Defer 'restart ' noop Is 'restart
|
|
|
|
| : (restart ['] (quit Is 'quit 'restart
|
|
[ errorhandler ] Literal @ errorhandler !
|
|
['] noop Is 'abort end-trace clearstack
|
|
standardi/o interpret quit ;
|
|
|
|
Defer 'cold ' noop Is 'cold
|
|
|
|
| : (cold origin up@ $100 cmove $80 count
|
|
$50 umin >r tib r@ move r> #tib ! >in off blk off
|
|
init-vocabularys 'cold
|
|
Onlyforth page &24 spaces logo count type cr (restart ;
|
|
( ----- 107 )
|
|
\ (boot ks 11 m„r 89
|
|
|
|
Label #segs ( -- R: seg ) Assembler
|
|
C: seg ' limit >body #) R mov R R or 0= not
|
|
?[ 4 # C- mov R C* shr R inc ret ]?
|
|
$1000 # R mov ret
|
|
end-code
|
|
|
|
Label (boot Assembler cli cld A A xor A D: mov
|
|
#segs # call C: D mov D R add R E: mov
|
|
$200 # C mov 0 # I mov I W mov rep movs
|
|
wake # >taskINT #) mov C: >taskINT 2+ #) mov
|
|
divovl # >divINT #) mov C: >divINT 2+ #) mov ret
|
|
end-code
|
|
( ----- 108 )
|
|
\ restart ks 09 m„r 89
|
|
|
|
Label warmboot here >restart 2+ - >restart ! Assembler
|
|
(boot # call
|
|
here ' (restart >body # I mov
|
|
Label bootsystem
|
|
C: A mov A E: mov A D: mov A S: mov
|
|
s0 #) U mov 6 # U add u' s0 U D) S mov
|
|
D pop u' r0 U D) R mov sti Next
|
|
end-code
|
|
|
|
Code restart here 2- ! end-code
|
|
( ----- 109 )
|
|
\ bye ks 11 m„r 89
|
|
|
|
Variable return_code return_code off
|
|
|
|
| Code (bye cli A A xor A E: mov #segs # call
|
|
C: D mov D R add R D: mov 0 # I mov I W mov
|
|
$200 # C mov rep movs sti \ restore interrupts
|
|
$4C # A+ mov C: seg return_code #) A- mov
|
|
$21 int warmboot # call
|
|
end-code
|
|
|
|
: bye empty page (bye ;
|
|
( ----- 110 )
|
|
\ cold ks 09 m„r 89
|
|
|
|
here >cold 2+ - >cold ! Assembler
|
|
(boot # call C: A mov A D: mov A E: mov
|
|
#segs # call $41 # R add \ another k for the ints
|
|
$4A # A+ mov $21 int \ alloc memory
|
|
CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]?
|
|
here s0 #) W mov 6 # W add origin # I mov $20 # C mov
|
|
rep movs ' (cold >body # I mov bootsystem # jmp
|
|
end-code
|
|
|
|
Code cold here 2- ! end-code
|
|
( ----- 111 )
|
|
\ System patchup ks 16 sep 88
|
|
|
|
1 &9 +thru \ MS-DOS interface
|
|
|
|
: forth-83 ; \ last word in Dictionary
|
|
|
|
0 ' limit >body ! $DFF6 s0 ! $E77C r0 !
|
|
s0 @ s0 2- ! here dp !
|
|
|
|
Host tudp @ Target udp !
|
|
Host tvoc-link @ Target voc-link !
|
|
Host tnext-link @ Target next-link !
|
|
Host tfile-link @ Target Forth file-link !
|
|
Host T move-threads H
|
|
save-buffers cr .( unresolved: ) .unresolved
|
|
( ----- 112 )
|
|
\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86
|
|
|
|
Code lc@ ( seg:addr -- 8b ) D: pop D W mov
|
|
W ) D- mov 0 # D+ mov C: A mov A D: mov Next
|
|
end-code
|
|
|
|
Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov
|
|
A- W ) mov C: A mov A D: mov D pop Next end-code
|
|
|
|
Code l@ ( seg:addr -- 16b ) D: pop D W mov
|
|
W ) D mov C: A mov A D: mov Next end-code
|
|
|
|
Code l! ( 16b seg:addr -- ) D: pop A pop D W mov
|
|
A W ) mov C: A mov A D: mov D pop Next end-code
|
|
( ----- 113 )
|
|
\ ltype lmove special 8088 operators ks 11 dez 87
|
|
|
|
: ltype ( seg:addr len -- )
|
|
0 ?DO 2dup I + lc@ emit LOOP 2drop ;
|
|
|
|
Code lmove ( from.seg:addr to.seg:addr quan -- )
|
|
A I xchg D C mov W pop E: pop
|
|
I pop D: pop I W cmp CS
|
|
?[ rep byte movs
|
|
][ C dec C W add C I add C inc
|
|
std rep byte movs cld
|
|
]? A I xchg C: A mov A E: mov
|
|
A D: mov D pop Next end-code
|
|
( ----- 114 )
|
|
\ BDOS keyboard input ks 16 sep 88
|
|
\ it really needs to be this complicated, else ^C und ^P would
|
|
\ not work
|
|
\\
|
|
| Variable newkey newkey off
|
|
Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or
|
|
0= ?[ $7 # A+ mov $21 int A- D- mov ]?
|
|
0 # D+ mov D+ newkey 1+ #) mov Next
|
|
end-code
|
|
|
|
Code (key? ( -- f ) D push newkey #) D mov D+ D+ or
|
|
0= ?[ -1 # D- mov 6 # A+ mov $21 int 0=
|
|
?[ 0 # D+ mov
|
|
][ -1 # A+ mov A newkey #) mov -1 # D+ mov
|
|
]? ]? D+ D- mov Next
|
|
end-code
|
|
( ----- 115 )
|
|
\ empty-keys (key ks 16 sep 88
|
|
\\
|
|
Code empty-keys $C00 # A mov $21 int
|
|
0 # newkey 1+ #) byte mov Next end-code
|
|
|
|
: (key ( -- 16b ) BEGIN pause (key? UNTIL
|
|
(key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ;
|
|
( ----- 116 )
|
|
\ BIOS keyboard input ks 16 sep 88
|
|
|
|
Code (key@ ( -- 8b ) D push A+ A+ xor $16 int
|
|
A- D- xchg 0 # D+ mov Next end-code
|
|
|
|
Code (key? ( -- f ) D push 1 # A+ mov D D xor
|
|
$16 int 0= not ?[ D dec ]? Next end-code
|
|
|
|
Code empty-keys $C00 # A mov $21 int Next end-code
|
|
|
|
: (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ;
|
|
|
|
\ mit diesen Keytreibern sind die Funktionstasten nicht
|
|
\ mehr durch ANSI.SYS Sequenzen vorbelegt.
|
|
( ----- 117 )
|
|
\ (decode expect ks 16 sep 88
|
|
|
|
7 Constant #bel 8 Constant #bs
|
|
9 Constant #tab $A Constant #lf
|
|
$D Constant #cr
|
|
|
|
: (decode ( addr pos1 key -- addr pos2 )
|
|
#bs case? IF dup 0=exit del 1- exit THEN
|
|
#cr case? IF dup span ! space exit THEN
|
|
>r 2dup + r@ swap c! r> emit 1+ ;
|
|
|
|
: (expect ( addr len1 -- ) span ! 0
|
|
BEGIN dup span @ u< WHILE key decode REPEAT 2drop ;
|
|
|
|
Input: keyboard [ here input ! ]
|
|
(key (key? (decode (expect [ drop
|
|
( ----- 118 )
|
|
\ MSDOS character output ks 29 jun 87
|
|
|
|
Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]?
|
|
6 # A+ mov $21 int D pop ' pause # W mov W ) jmp
|
|
end-code
|
|
|
|
&80 Constant c/row &25 Constant c/col
|
|
|
|
: (emit ( char -- ) dup bl u< IF $80 or THEN charout ;
|
|
: (cr #cr charout #lf charout ;
|
|
: (del #bs charout bl charout #bs charout ;
|
|
: (at 2drop ;
|
|
: (at? 0 0 ;
|
|
: (page c/col 0 DO cr LOOP ;
|
|
( ----- 119 )
|
|
\ MSDOS character output ks 7 may 85
|
|
|
|
: bell #bel charout ;
|
|
|
|
: tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ;
|
|
|
|
Output: display [ here output ! ]
|
|
(emit (cr tipp (del (page (at (at? [ drop
|
|
|
|
( ----- 120 )
|