mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 05:32:28 +00:00
579 lines
36 KiB
Forth
579 lines
36 KiB
Forth
\ *** Block No. 0 Hexblock 0
|
|
\ 05Jul86
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 1 Hexblock 1
|
|
\ Target compiler loadscr UH 07Jun86
|
|
\ Idea and first Implementation by ks/bp
|
|
\ Implemented on 6502 by ks/bp
|
|
\ ultraFORTH83-Version by bp/we
|
|
\ Atari 520 ST - Version by we
|
|
\ CP/M 2.2 Version by UH
|
|
|
|
Onlyforth hex Assembler nonrelocate
|
|
Vocabulary Ttools
|
|
Vocabulary Defining
|
|
1 10 +thru \ Target compiler
|
|
11 13 +thru \ Target Tools
|
|
14 16 +thru \ Redefinitions
|
|
save 17 20 +thru \ Predefinitions
|
|
|
|
Onlyforth
|
|
\ *** Block No. 2 Hexblock 2
|
|
\ Target header pointers UH 26Mar88
|
|
|
|
Create lastname $20 allot
|
|
Variable tdp : there tdp @ ;
|
|
Variable displace
|
|
Variable image
|
|
Variable ?thead ?thead off
|
|
Variable tlast tlast off
|
|
Variable glast' glast' off
|
|
Variable tdoes>
|
|
Variable >in:
|
|
Variable tvoc tvoc off
|
|
Variable tvoc-link tvoc-link off
|
|
0 | Constant <forw>
|
|
0 | Constant <res>
|
|
| : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ;
|
|
\ *** Block No. 3 Hexblock 3
|
|
\ Image and byteorder UH 26Mar88
|
|
|
|
Code c+! ( 8b addr -- )
|
|
H pop D pop E A mov M add A M mov Next end-code
|
|
|
|
Code /block ( addr -- +n blk )
|
|
H pop L E mov H A mov 3 ani A D mov
|
|
H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp
|
|
end-code
|
|
|
|
: >image ( addr1 - addr2 )
|
|
displace @ ( - /block image @ + block ) + ;
|
|
|
|
: >heap ( from quan - ) dup hallot heap swap cmove ;
|
|
\\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ;
|
|
: /block ( addr -- +n blk ) b/blk /mod ;
|
|
\ *** Block No. 4 Hexblock 4
|
|
\ Ghost-creating UH 26Mar88
|
|
|
|
| : (make.ghost ( str -- cfa.ghost ) dp push
|
|
count dup 1 $1F uwithin not Abort" invalid Ghostname"
|
|
here 2+ place
|
|
here state @ \ address of link field
|
|
IF context @ ELSE current THEN @ under @ , \ link
|
|
1 here c+! here c@ allot bl c, \ name
|
|
here over - swap \ offset to codefield
|
|
<forw> , 0 , 0 , \ code and parameter field
|
|
here over - >heap \ move to heap
|
|
heap rot ! \ link
|
|
heap + ; \ codefield address
|
|
|
|
| : Make.Ghost ( -- cfa.ghost ) name (make.ghost ;
|
|
|
|
\ *** Block No. 5 Hexblock 5
|
|
\ ghost words UH 28Apr88
|
|
|
|
: gfind ( string - cfa tf / string ff )
|
|
>r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ;
|
|
|
|
: (ghost ( string -- cfa ) gfind ?exit (make.ghost ;
|
|
|
|
: ghost ( -- cfa ) name (ghost ;
|
|
|
|
: gdoes> ( cfa.ghost - cfa.does ) dp push
|
|
4+ dup @ IF @ exit THEN \ defined
|
|
here <forw> , 0 , 4 >heap \ forward-chain
|
|
heap dup rot ! ; \ forward-link
|
|
|
|
|
|
|
|
\ *** Block No. 6 Hexblock 6
|
|
\ ghost utilities 2UH 26Mar88
|
|
|
|
: g' ( -- cfa.ghost ) name gfind 0= abort" ?" ;
|
|
|
|
| : .ghost-type ( cfa.ghost -- ) @
|
|
<forw> case? IF ." forward" exit THEN
|
|
<res> - Abort" type unknown" ." resolved " ;
|
|
|
|
| : .does-type ( cfa.does -- ) @
|
|
<forw> case? IF ." forward-define" exit THEN
|
|
<res> - Abort" does-type unknown" ." resolved-define" ;
|
|
|
|
: '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r
|
|
4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ;
|
|
|
|
' ' Alias h'
|
|
\ *** Block No. 7 Hexblock 7
|
|
\ .unresolved UH 26Mar88
|
|
|
|
| : forward? ( cfa -- f ) dup @ <forw> = swap 2+ @ and ;
|
|
| : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ;
|
|
|
|
| : unresolved? ( addr - f ) 2+
|
|
dup ghost? not IF drop false exit THEN
|
|
name> dup forward? IF drop true exit THEN
|
|
4+ @ forward? ;
|
|
|
|
| : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE
|
|
dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ;
|
|
|
|
: .unresolved ( -- ) voc-link @
|
|
BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ;
|
|
|
|
\ *** Block No. 8 Hexblock 8
|
|
\ Extending Vocabularys for Target-Compilation 2UH 26Mar88
|
|
|
|
: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ;
|
|
|
|
Vocabulary Transient tvoc off
|
|
|
|
Root definitions
|
|
|
|
: T Transient ; immediate
|
|
: H Forth ; immediate
|
|
|
|
OnlyForth
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 9 Hexblock 9
|
|
\ Transient primitives UH 26Mar88
|
|
|
|
Code byte> ( 8bl 8bh -- 16b )
|
|
D pop H pop E H mov hpush jmp end-code
|
|
Code >byte ( 16b -- 8bh 8bl )
|
|
H pop H E mov 0 H mvi H D mov dpush jmp end-code
|
|
|
|
Transient definitions
|
|
: c@ ( addr -- 8b ) H >image c@ ;
|
|
: c! ( 8b addr -- ) H >image c! ( update ) ;
|
|
: @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ;
|
|
: ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ;
|
|
: cmove ( from.mem to.target quan -)
|
|
bounds ?DO dup H c@ I T c! H 1+ LOOP drop ;
|
|
: on ( addr -- ) true swap T ! H ;
|
|
: off ( addr -- ) false swap T ! H ;
|
|
\ *** Block No. 10 Hexblock A
|
|
\ Transient primitives UH 26Mar88
|
|
|
|
: here ( -- taddr ) there ;
|
|
: allot ( n -- ) Tdp +! ;
|
|
: c, ( c -- ) T here c! 1 allot H ;
|
|
: , ( n -- ) T here ! 2 allot H ;
|
|
|
|
: ," ( -- ) Ascii " parse
|
|
dup T c, under here swap cmove allot H ;
|
|
|
|
: fill ( addr len c -- )
|
|
-rot bounds ?DO dup I T c! H LOOP drop ;
|
|
|
|
: erase ( addr len -- ) 0 T fill H ;
|
|
: blank ( addr len -- ) bl T fill H ;
|
|
: here! ( addr -- ) H tdp ! ;
|
|
\ *** Block No. 11 Hexblock B
|
|
\ Resolving UH 26Mar88
|
|
|
|
Forth definitions
|
|
|
|
: resolve ( cfa.ghost cfa.target -- )
|
|
2dup swap >body dup @ >r ! over @ <res> =
|
|
IF drop >name space .name ." exists" ?cr rdrop exit THEN
|
|
r> swap >r <res> rot ! ?dup 0= IF rdrop exit THEN
|
|
BEGIN dup T @ H 2dup = abort" resolve loop"
|
|
r@ rot T ! H ?dup 0= UNTIL rdrop ;
|
|
|
|
: resdoes> ( cfa.ghost cfa.target -- )
|
|
swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
|
|
|
|
' <forw> Is> ( -- ) dup @ there rot ! T , H ; \ forward link
|
|
' <res> Is> ( -- ) @ T , H ; \ compile target.cfa
|
|
\ *** Block No. 12 Hexblock C
|
|
\ move-threads UH 26Mar88
|
|
|
|
: move-threads Tvoc @ Tvoc-link @
|
|
BEGIN over ?dup
|
|
WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT
|
|
error" some undef. Target-Vocs left" drop ;
|
|
|
|
| : tlatest ( - addr) Current @ 6 + ;
|
|
|
|
|
|
: save-target \ filename
|
|
$100 dup >image there rot - savefile ;
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 13 Hexblock D
|
|
\ compiling names into targ. UH 26Mar88
|
|
|
|
| : viewfield ( -- n ) H blk @ $200 + ; \ in File #1
|
|
|
|
: (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN
|
|
>in push
|
|
name dup c@ 1 $20 uwithin not abort" invalid Targetname"
|
|
viewfield T ,
|
|
H there tlatest @ T , H tlatest ! \ link
|
|
there dup tlast !
|
|
over c@ 1+ dup T allot cmove H ;
|
|
|
|
: Theader ( -- ) tlast off
|
|
(theader Ghost dup glast' ! there resolve ;
|
|
|
|
|
|
\ *** Block No. 14 Hexblock E
|
|
\ prebuild defining words bp2UH 26Mar88
|
|
|
|
| : executable? ( adr - adr f ) dup ;
|
|
| : tpfa, there , ;
|
|
|
|
| : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ;
|
|
|
|
: prebuild ( adr 0.from.: - 0 ) 0 ?pairs
|
|
executable? dup >r
|
|
IF [compile] Literal compile (prebuild ELSE drop THEN
|
|
compile Theader Ghost gdoes> ,
|
|
r> IF compile tpfa, THEN 0 ; immediate restrict
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 15 Hexblock F
|
|
\ code portion of def.words bp2UH 26Mar88
|
|
|
|
: dummy 0 ;
|
|
|
|
: DO> ( - adr.of.jmp.dodoes> 0 )
|
|
[compile] Does> here 3 - compile @ 0 ] ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 16 Hexblock 10
|
|
\ The Target-Assembler UH 26Mar88
|
|
|
|
|
|
Forth definitions
|
|
| Create relocate ] T c, , c@ here allot ! c! H [
|
|
|
|
Transient definitions
|
|
|
|
: Assembler H [ Assembler ] relocate >codes ! Assembler ;
|
|
: >label ( 16b -) H >in @ name gfind rot >in !
|
|
IF over resolve dup THEN drop Constant ;
|
|
: Label H there T >label Assembler H ;
|
|
: Code H Theader there 2+ T , Assembler H ;
|
|
|
|
|
|
|
|
\ *** Block No. 17 Hexblock 11
|
|
\ immed. restr. ' \ compile bp2UH 26Mar88
|
|
|
|
: ?pairs ( n1 n2 -- ) H - abort" unstructured" ;
|
|
: >mark ( - addr) H there T 0 , H ;
|
|
: >resolve ( addr -) H there over - swap T ! H ;
|
|
: <mark ( - addr) H there ;
|
|
: <resolve ( addr -) H there - T , H ;
|
|
: immediate H Tlast @ ?dup 0=exit dup T c@ $40 or swap c! H ;
|
|
: restrict H Tlast @ ?dup 0=exit dup T c@ $80 or swap c! H ;
|
|
: ' ( <name> - cfa) H g' dup @ <res> - abort" ?" 2+ @ ;
|
|
: | H ?thead @ ?exit ?thead on ;
|
|
: compile H Ghost , ; immediate restrict
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 18 Hexblock 12
|
|
\ Target tools UH 26Mar88
|
|
Onlyforth Ttools also definitions
|
|
|
|
| : ttype ( adr n -) bounds ?DO I T c@ H dup
|
|
bl > IF emit ELSE drop ascii . emit THEN LOOP ;
|
|
|
|
: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype
|
|
ELSE ." ??? " THEN space ?cr ;
|
|
|
|
| : nfa? ( cfa lfa - nfa / cfa ff)
|
|
BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ =
|
|
IF 2+ nip exit THEN T @ H REPEAT ;
|
|
|
|
: >name ( cfa - nfa / ff)
|
|
Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup
|
|
IF nip exit THEN swap REPEAT nip ;
|
|
\ *** Block No. 19 Hexblock 13
|
|
\ Ttools for decompiling ks29jun85we
|
|
|
|
| : ?: dup 4 u.r ." :" ;
|
|
| : @? dup T @ H 6 u.r ;
|
|
| : c? dup T c@ H 3 .r ;
|
|
|
|
: s ( adr - adr+) ?: space c? 3 spaces
|
|
dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
|
|
|
|
: n ( adr - adr+2) ?: @? 2 spaces
|
|
dup T @ H [ Ttools ] >name .name H 2+ ;
|
|
|
|
: d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP
|
|
2 spaces -rot ttype ;
|
|
|
|
|
|
\ *** Block No. 20 Hexblock 14
|
|
\ Tools for decompiling bp204dec85we
|
|
|
|
: l ( adr - adr+2) ?: 5 spaces @? 2+ ;
|
|
|
|
: c ( adr - adr+1) 1 d ;
|
|
|
|
: b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ;
|
|
|
|
: dump ( adr n -) bounds ?DO cr I 10 d drop stop?
|
|
IF LEAVE THEN 10 +LOOP ;
|
|
|
|
: view T ' H [ Ttools ] >name ?dup
|
|
IF 4 - T @ H list THEN ;
|
|
|
|
|
|
|
|
\ *** Block No. 21 Hexblock 15
|
|
\ reinterpretation def.-words UH 26Mar88
|
|
|
|
Onlyforth
|
|
|
|
: redefinition ( -- ) tdoes> @ 0=exit
|
|
>in push [ ' parser >body ] Literal push
|
|
state push context push
|
|
>in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit
|
|
cr ." Redefinition: " here .name
|
|
>in: @ >in ! : Defining interpret tdoes> off ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 22 Hexblock 16
|
|
\ Create..does> structure 27Apr86
|
|
|
|
| : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ;
|
|
|
|
| : changecfa compile lit tdoes> @ , compile (;tcode ;
|
|
|
|
Defining definitions
|
|
|
|
: ;code 0 ?pairs changecfa reveal rdrop rdrop ;
|
|
immediate restrict
|
|
|
|
Defining ' ;code Alias does> immediate restrict
|
|
|
|
: ; [compile] ; rdrop rdrop ; immediate restrict
|
|
|
|
|
|
\ *** Block No. 23 Hexblock 17
|
|
\ redefinition conditionals bp27jun85we
|
|
|
|
' DO Alias DO immediate restrict
|
|
' ?DO Alias ?DO immediate restrict
|
|
' LOOP Alias LOOP immediate restrict
|
|
' IF Alias IF immediate restrict
|
|
' THEN Alias THEN immediate restrict
|
|
' ELSE Alias ELSE immediate restrict
|
|
' BEGIN Alias BEGIN immediate restrict
|
|
' UNTIL Alias UNTIL immediate restrict
|
|
' WHILE Alias WHILE immediate restrict
|
|
' REPEAT Alias REPEAT immediate restrict
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 24 Hexblock 18
|
|
\ clear Liter. Ascii ['] ." UH 26Mar88
|
|
|
|
Onlyforth Transient definitions
|
|
|
|
: clear True abort" There are ghosts" ;
|
|
: Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN
|
|
T compile clit c, H ; immediate
|
|
: Ascii H bl word 1+ c@
|
|
state @ 0=exit T [compile] Literal H ; immediate
|
|
: ['] T ' [compile] Literal H ; immediate restrict
|
|
: " T compile (" ," H ; immediate restrict
|
|
: ." T compile (." ," H ; immediate restrict
|
|
|
|
: even H ; immediate \ machen nichts beim 8080
|
|
: align H ; immediate
|
|
: halign H ; immediate
|
|
\ *** Block No. 25 Hexblock 19
|
|
\ Target compilation ] [ bp0UH 26Mar88
|
|
|
|
Forth definitions
|
|
|
|
: tcompile ( str -- ) count lastname place
|
|
lastname find ?dup
|
|
IF 0> IF execute exit THEN drop lastname THEN
|
|
gfind IF execute exit THEN
|
|
number? ?dup
|
|
IF 0> IF swap T [compile] Literal THEN
|
|
[compile] Literal H exit THEN
|
|
(ghost execute ;
|
|
|
|
Transient definitions
|
|
: ] H State on ['] tcompile is parser ;
|
|
|
|
\ *** Block No. 26 Hexblock 1A
|
|
\ Target conditionals bp27jun85we
|
|
|
|
: IF T compile ?branch >mark H 1 ; immediate restrict
|
|
: THEN abs 1 T ?pairs >resolve H ; immediate restrict
|
|
: ELSE T 1 ?pairs compile branch >mark swap >resolve
|
|
H -1 ; immediate restrict
|
|
: BEGIN T <mark H 2 ; immediate restrict
|
|
: WHILE T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
|
|
immediate restrict
|
|
| : (repeat T 2 ?pairs <resolve H BEGIN dup -2 =
|
|
WHILE drop T >resolve H REPEAT ;
|
|
: UNTIL T compile ?branch (repeat H ; immediate restrict
|
|
: REPEAT T compile branch (repeat H ; immediate restrict
|
|
|
|
|
|
|
|
\ *** Block No. 27 Hexblock 1B
|
|
\ Target conditionals bp27jun85we
|
|
|
|
: DO T compile (do >mark H 3 ; immediate restrict
|
|
: ?DO T compile (?do >mark H 3 ; immediate restrict
|
|
: LOOP T 3 ?pairs compile (loop compile endloop
|
|
>resolve H ; immediate restrict
|
|
: +LOOP T 3 ?pairs compile (+loop compile endloop
|
|
>resolve H ; immediate restrict
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 28 Hexblock 1C
|
|
\ predefinitions bp27jun85we
|
|
|
|
: abort" T compile (abort" ," H ; immediate
|
|
: error" T compile (err" ," H ; immediate
|
|
|
|
Forth definitions
|
|
|
|
Variable torigin
|
|
Variable tudp 0 tudp !
|
|
|
|
: >user T c@ H torigin @ + ;
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 29 Hexblock 1D
|
|
\ Datatypes bp2UH 07Nov87
|
|
|
|
Transient definitions
|
|
: origin! H torigin ! ;
|
|
: user' ( - 8b) T ' 2 + c@ H ;
|
|
: uallot ( n -) H tudp @ swap tudp +! ;
|
|
|
|
DO> >user ;
|
|
: User prebuild User 2 T uallot c, ;
|
|
|
|
DO> ;
|
|
: Create prebuild (create ;
|
|
|
|
DO> T @ H ;
|
|
: Constant prebuild Constant T , ;
|
|
: Variable Create 2 T allot ;
|
|
\ *** Block No. 30 Hexblock 1E
|
|
\ Datatypes UH 07Nov87
|
|
|
|
dummy
|
|
: Vocabulary
|
|
H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
|
|
here H tvoc-link @ T , H tvoc-link ! ;
|
|
|
|
|
|
dummy
|
|
: (create prebuild (create ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 31 Hexblock 1F
|
|
\ target defining words 27Apr86
|
|
|
|
Do> ;
|
|
: Defer prebuild Defer 2 T allot ;
|
|
: Is T ' H >body State @ IF T compile (is , H
|
|
ELSE T ! H THEN ; immediate
|
|
| : dodoes> T compile (;code H Glast' @
|
|
there resdoes> there tdoes> ! ;
|
|
|
|
: ;code 0 T ?pairs dodoes> Assembler H [compile] [
|
|
redefinition ; immediate restrict
|
|
: does> T dodoes> $CD c,
|
|
compile (dodoes> H ; immediate restrict
|
|
|
|
|
|
|
|
\ *** Block No. 32 Hexblock 20
|
|
\ : Alias ; bUH 07Jun86
|
|
|
|
dummy
|
|
: : H tdoes> off >in @ >in: ! T prebuild :
|
|
H current @ context ! T ] H 0 ;
|
|
|
|
: Create: Create H current @ context ! T ] H 0 ;
|
|
|
|
: Alias ( n -- ) H Tlast off (theader Ghost over resolve
|
|
tlast @ T c@ H 20 or tlast @ T c! , H ;
|
|
|
|
: ; T 0 ?pairs compile unnest [compile] [ H redefinition ;
|
|
immediate restrict
|
|
|
|
|
|
|
|
\ *** Block No. 33 Hexblock 21
|
|
\ predefinitions UH 26Mar88
|
|
|
|
: compile T compile compile H ; immediate restrict
|
|
: Host H Onlyforth Ttools also ;
|
|
: Compiler T Host H Transient also definitions ;
|
|
: [compile] H ghost execute ; immediate restrict
|
|
\ : Onlypatch H there 3 - 0 tdoes> ! 0 ;
|
|
|
|
Onlyforth
|
|
: Target Onlyforth Transient also definitions ;
|
|
|
|
Transient definitions
|
|
Ghost c, drop
|
|
|
|
|
|
|