Skip to content
GitLab
Commit f622597c authored by bp's avatar bp
Browse files

Fixed cross for alginment 

git-svn-id: https://forth-ev.de/repos/bigforth@1701 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 9240f085
Hide whitespace changes
Inline Side-by-side
forth.fb
View file @ f622597c
No preview for this file type
forthker-bsd.fi
View file @ f622597c
No preview for this file type
forthker-linux.fi
View file @ f622597c
No preview for this file type
forthker-osx.fi
View file @ f622597c
No preview for this file type
forthker-win32.fi
View file @ f622597c
No preview for this file type
target.fb
View file @ f622597c
\\ *** Target-Compiler fr volksFORTH *** 25aug87rewe Der Target-Compiler erzeugt fr jedes Wort im Target-System einen 'Ghost' mit folgendem Aufbau: | LFA | Name+bl | Ptr auf <forw>/<res> | TargetCFA | Ptr TDoes| PtrDoes zeigt auf | DoesCFA | TargetDoes | \ Target compiler loadscr 21dec08py\ Idea and first Implementation by ks/bp \ Implemented on 6502 by ks/bp \ ultraFORTH83-Version by bp/we \ Atari 520 ST - Version by we \ bigFORTH Version by py \ bigFORTH.386 Version by py Onlyforth Assembler nonrelocate Forth Vocabulary Ttools Vocabulary Defining 1 $30 +thru Onlyforth \ Target header pointers 11jul96py 0 Constant NIL Variable tdp : there tdp @ ; Variable tactModule : >trel tactModule @ - ; Variable ?thead Variable tlast Variable tlastcfa Variable tlastopt Variable tlastdes Variable tstate Variable glast' Variable >in: Variable tuser Variable tvoc Variable tvoc-link NIL tvoc-link ! Variable tfile-link NIL tfile-link ! Variable tfileno 1 tfileno ! \ Image and byteorder 01jan93py : c+! ( 8b addr -- ) dup c@ rot + swap c! ; \ : >image ( addr1 -- addr2 ) displace @ + ; : >heap ( from quan -- ) dup hallot heap swap move ; 4 Constant cell ' 4+ Alias cell+ ' 4- Alias cell- ' 4* Alias cells ' 4/ Alias cell/ \ Ghost-creating 18jun97py 0 Constant dummy $4711 Constant <forw> $4712 Constant <res> : Make_ghost ( -- ghostbody ) here align here state @ tstate @ or IF context ELSE current THEN @ dup @ , name capitalize dup c@ $1F 1 within abort" invalid Gname" dup c@ 1+ over c! c@ allot bl c, align 0 w, here 2 pick - -rot <forw> , NIL , NIL , swap here over - >heap heap swap over cell+ over 'reveal ! swap dp ! heap + ; \ ghost words 2723jan05py : gfind ( string -- ghostbody tf / string ff ) dup count + 1+ bl swap c! dup >r 1 over c+! find -1 r> c+! ; : ghost ( -- cfa ) >in @ name gfind IF nip exit THEN drop >in ! Make_ghost ; : gdoes> ( ghostbody -- cfa.does ) cell+ cell+ dup @ IF @ exit THEN here dup <forw> , NIL , 2 cells >heap dp ! heap tuck swap ! ; \ ghost utilities 2518jun97py : g' ( <name> -- cfa ) name gfind 0= abort" No ghost" ; : '. ( <name> -- ) g' dup @ <forw> case? IF ." forw" ELSE <res> - abort" What's up?" ." res" THEN cell+ dup @ 7 u.r cell+ @ ?dup IF dup @ <forw> case? IF ." fdef" ELSE <res> - abort" What ??" ." rdef" THEN cell+ @ 7 u.r THEN ; ' ' Alias h' \ .unresolved 26aug87marewe : forward? ( cfa -- cfa / exit&true ) \ hlich !!! dup @ <forw> = over cell+ @ and IF drop true rdrop exit THEN ; : unresolved? ( lfa -- f ) cell+ dup c@ $1F and over + c@ bl = IF name> forward? cell+ cell+ @ dup IF forward? THEN THEN drop false ; : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup cell+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup cell- cell- unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation 22sep91py : Vocabulary Vocabulary NIL , here tvoc @ , tvoc ! ; Vocabulary Transient NIL tvoc ! Only definitions Forth also Root : T Transient ; immediate : H Forth ; immediate \ Transient primitives 01jan93pyTransient definitions \ : @ [ $205E w, 3 [FOR] $1D18 w, [NEXT] ] ; \ : w@ [ $205E w, 1 [FOR] $1D18 w, [NEXT] $4266 w, ] ; \ : wx@ w@ wextend ; \ : ! [ $205E5888 , 3 [FOR] $111E w, [NEXT] ] ; \ : w! [ $205E w, $5488548E , 1 [FOR] $111E w, [NEXT] ] ; : here there ; : allot tdp +! ; : htcmove ( from.mem to.target quan -) move ; : trelinfo H tactModule @ dup cell+ T @ H + ; \ [JSR] [BSR] 26au18jun97py $E8 Constant [call] $C3 Constant [ret] $F487 Constant [s~r] : cfa@ ( tcfa -- tcfa@ ) dup T c@ H T [call] H = IF 1+ dup T @ H + cell+ exit THEN true abort" Neither nor...." ; : movebits ( B$s B$z s z # -- ) >r 2dup > IF rot swap r> 0 ?DO 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN 1+ LOOP ELSE rot swap r@ + r> ?dup IF 1- FOR 1- 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN NEXT THEN THEN 2drop 2drop ; \ Transient primitives 14jul96py : c, T here c! 1 allot H ; : w, T here w! 2 allot H ; : , T here ! 4 allot H ; : A, T here swap , trelinfo swap >trel +Bit H ; : A! T trelinfo over >trel +Bit ! H ; : align T ( here 1 and IF bl c, THEN ) H ; : ," Ascii " parse dup T c, under here swap htcmove allot H ; : ,0" Ascii " parse T under here swap htcmove allot 0 c, H ; \ : fill ( addr quan 8b -) >r >r >image r> r> fill ; \ -rot bounds ?DO dup I T c! H LOOP drop ; \ : erase 0 T fill ; \ Resolving 28dec92py : >len ( cfa -- lengthfield ) 2- ; : call! ( addr cfa.target -- ) over - 4- swap T ! H ; : call, ( cfa.target -- ) T [call] c, here over call! 4 allot H tactModule @ there within 0= IF T trelinfo here 4- >trel 2dup +Bit 1+ +Bit H THEN ; \ : cmove ( from to count -- ) >r >image >r >image r> r> cmove ; Defer (do_resolve \ Resolving Part 2 26aug87marewe Forth definitions : resolve ( ghostbody cfa.target -- ) over dup @ <res> = IF space dup >name .name ." exists " ?cr cell+ ! drop exit THEN >r >r cell+ @ ?dup IF BEGIN dup T @ H 2dup = abort" resolve loop" swap r@ T call! H ?dup 0= UNTIL THEN r> r> <res> over ! cell+ ! ; : resdoes> ( ghostbody cfa.target -- ) swap gdoes> dup @ <res> = IF cell+ ! exit THEN swap resolve ; \ Code-Body <forw> und <res> 18jun97py: do_forward ( ghostbody -- ) T [call] c, H cell+ dup @ there rot ! T , $80 tlastdes H ! ; : do_resolve ( ghostbody -- ) cell+ @ T (do_resolve H ; : gexecute ( ghostbody -- ) dup @ <forw> case? IF do_forward exit THEN <res> = IF do_resolve exit THEN true abort" What's that, a CFA ??" ; : ghost, ghost gexecute ; : move-threads Tvoc @ Tvoc-link @ BEGIN dup WHILE over cell- @ over cell- T ! @ H swap @ swap REPEAT 2drop ; : tlatest ( -- addr ) current @ cell+ cell+ cell+ cell+ ;\ Tabelle einrichten 27oct95py \needs troot Variable Troot Dos also | : (inittab ( root -- ) BEGIN dup , dup T @ H , 0 , dup 8+ T @ H ?dup IF recurse THEN $10 + T @ H dup 0= UNTIL drop ; | : inittab ( -- tab ) here troot @ (inittab 0 , $7FFF , 0 , ; | : name, ( tab -- tab ) dup @ dup $30 + count here place here c@ 1+ allot $14 + @ , 0 , dup 8+ dup T @ H , off ; | : >LinkTab ( tabstart module -- linktabstart ) here 0 w, >r over BEGIN 2dup @ = 0= WHILE $C + REPEAT name, 2drop BEGIN dup @ WHILE dup 8+ @ IF name, THEN $C + REPEAT [ " nil" @ ] Literal , 0 , 8+ dup T @ H , off here r@ - 2- r@ T w! H r> ; \ Module umformen, auf Diskette sichern... 30jan97py| : tabsearch ( addr tab -- addr entry ) BEGIN 2dup 2@ under + within 0= WHILE dup >r $C + r> @ 0= UNTIL rdrop I . drop . true abort" No address!" THEN ; | : ((savemod ( module tab handle -- return ) >r over dup T @ H >r dup cell+ T @ H + r> 0 ?DO dup I bit@ IF -rot 2 pick I 1+ bit@ IF over I + dup >r T @ H r@ + 4+ over tabsearch under @ - r@ 2+ T w! H dup $A + w@ r> over 0= IF nip I swap THEN T w! H I swap $A + w! ELSE over I + dup >r T @ H over tabsearch under @ - r@ 2+ T w! H dup 8+ w@ r> over 0= IF nip I swap THEN T w! H I swap 8+ w! THEN rot 4 ELSE 1 THEN +LOOP 2drop dup T @ H r> fwrite ; \ savemod savesystem 27dec92py | Variable handle | Variable modtab | : ?abort ( diskerr -- ) dup 0< IF r0 @ rp! ELSE drop THEN ; | : (savemod ( back linkpos module -- ) cr ." saving " dup $30 + .name T dup 8+ @ >r dup $C + @ >r dup $10 + @ >r >r H dup IF 0 handle @ 1 fseek >r handle @ 0 fseek ?abort rp@ T @ H sp@ 4 handle @ fwrite ?abort drop r@ handle @ 0 fseek ?abort r> THEN drop r@ $C + T ! H r@ 8+ off r@ $10 + off r@ modtab @ handle @ ((savemod T r> r> over $10 + ! r> over $C + ! r> over 8+ ! >r H ?abort modtab @ r> >linktab dup dup T w@ H 2+ handle @ fwrite ?abort dp ! ." saved" ; \ savemod savesystem 20may00py \needs >len : >len dup $100 0 scan drop over - ; | : getmodname ( -- addr ) Name count pad place pad 0 over count + c! count over + 4- dup c@ Ascii . = IF 0 swap c! ELSE drop THEN >len over + S" .fi" >r over r> move 0 swap 3 + c! ; | : >savemod ( back linkpos module -- ) recursive >r BEGIN >r 0 handle @ 1 fseek over r> r@ (savemod r@ 8+ T @ H ?dup IF >r dup dup 8+ r> >savemod THEN over 0< 0= r> $10 + T @ H and dup WHILE >r $10 + REPEAT drop 2drop ; \ save-target 01jan01py : savedp tactModule @ ?dup IF >r there r@ - r> T ! H ELSE EXIT THEN 0 there tactModule @ ?DO I T @ H + dup 2* swap 0< - cell +LOOP tactModule @ 5 cells + T ! H ; \needs ?diskabort : ?diskabort 0< abort" Disk error! " ; : save-target ( -- ) clear ['] ?diskabort >r r0 push dp push rp@ r0 ! >in @ >r getmodname [IFDEF] go32 0 [ELSE] r/w [THEN] fcreate dup ?abort handle ! inittab modtab ! -1 0 troot @ >savemod handle @ fclose ( r@ >in ! getmodname ) ( [ saving ] r> >in ! saveloader) rdrop ; toss \ compiling names into targ. 15nov95py Variable thead+ 7 thead+ ! Variable theadalign 3 theadalign ! : (theader >in @ name c@ swap >in ! there + thead+ @ swap - theadalign @ and 0 ?DO bl T c, H LOOP ?thead @ IF 1 ?thead +! exit THEN >in @ name capitalize swap >in ! dup c@ $20 1 within abort" inval. Tname" blk @ abs $400 + T w, H \ Loaded from File# 1 there tlatest dup @ T A, H ! there dup tlast ! over c@ 1+ dup T allot htcmove align H ; : Theader tlast off $80 tlastdes ! (theader T 0 w, H there tlastcfa ! ghost dup glast' ! there resolve ; \ prebuild defining words 01jan93py : executable? ( addr -- addr f ) dup ; : tpfa, there , ; : (prebuild ( cfa.addr -- ) >in @ Create immediate >in ! here 4- under 4+ - swap ! ; : prebuild ( addr 0_from_: -- 0 ) ?struc executable? dup >r IF compile Literal compile (prebuild ELSE drop THEN compile Theader ghost gdoes> compile Literal compile gexecute r> IF compile tpfa, THEN 0 ; immediate restrict \ code portion of def.words 02jan93py : DO> ( -- addr.of.jmp.dodoes> 0 ) 0 w, !lastdes here compile r> compile @ 0 ] ; Transient definitions : compile H ghost compile Literal compile gexecute ; immediate restrict : >T&P H $FF and >r $FF and $100 Q* r> or ; : T&P ( Take Push -- ) T >T&P tstate H @ IF T tlastdes H w! ELSE T tlastopt H @ T w! H THEN ; FORTH definitions : T&P: H : swap compile Literal compile ; macro ; \ the 468 Assembler 07nov92py Forth definitions 0 constant NIL T : +tbit trelinfo there >trel +bit ; | Table: relocate c, here allot c! +tbit [ : !length tlastcfa H @ ?dup IF dup T >len w@ H IF drop exit THEN there over - swap T >len w! H THEN ; Assembler definitions : end-code end-code !length ; \\ D6 Constant loopreg D7 Constant looplim A7 Constant RP A5 Constant UP A6 Constant SP : Next rts ; \ Definitionen fuer Assembler b20jun01pyFORTH definitions warning off $100 loadfrom forth.fb Transient definitions warning on : Assembler H relocate [ Assembler ] >codes H ! Assembler ; : >label ( addr -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Create , immediate Does> @ tstate @ IF T compile lit here 6 - A! H THEN ; : Label T align \ H tlastcfa off T here >label Assembler H ; : Code H THeader T [ Assembler ] :R T Assembler [ Assembler ] S: H ; \ immed. restr. ' \ compile 24dec92py : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; : >mark ( -- sys ) T here 6 - 0 over ! H ; : >resolve ( sys -- ) H >r there r@ - cell- r> T ! H ; : <mark ( -- addr ) H there ; : <resolve ( sys -- ) H there 2- - there 6 - T ! H ; : flag! >r H Tlast @ ?dup IF glast' @ >name dup c@ r@ or swap c! dup T c@ r@ or swap c! H THEN rdrop ; : restrict T $80 flag! H ; : immediate T $40 flag! H ; : ' ( <name> -- cfa ) H g' dup @ <res> - abort" ?" cell+ @ ; : | H ?thead @ ?exit ?thead on ; \ Target tools 07dec91py Onlyforth Ttools also definitions | : ttype ( addr n -- ) bounds ?DO I T c@ H dup bl > IF emit ELSE drop Ascii . emit THEN LOOP ; Ttools : .name ( nfa -- ) ?dup IF dup 1+ swap T c@ H $1F and ttype ELSE ." ??? " THEN space ?cr ; Ttools | : nfa? ( cfa lfa -- nfa / cfa ff ) BEGIN dup 0> WHILE 2dup 4+ dup T c@ H $1F and + 1+ aligned 2+ = IF 4+ nip exit THEN T @ H REPEAT ; Ttools : >name ( cfa -- nfa / ff ) Tvoc BEGIN @ dup WHILE under 4- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; Ttools \ Ttools for decompiling 26aug87marewe | : ?: dup 4 u.r ." :" ; | : w@? dup T w@ H 6 u.r ; | : @? dup T @ H 6 u.r ; | : c? dup T c@ H 3 .r ; : s ( addr -- addr+ ) ?: space c? 3 spaces dup 1+ over T c@ H ttype dup T c@ H + 1+ ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T cfa@ H [ Ttools ] >name .name H 4+ ; : d ( addr n -- addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot ttype ; \ Tools for decompiling bp01jan93py : l ( addr -- addr+4 ) ?: 5 spaces @? 4+ ; : c ( addr -- addr+1 ) 1 d ; : b ( addr -- addr+2 ) ?: w@? dup T w@ H over + 5 u.r 2+ ; : dump ( addr n -) bounds ?DO cr I $10 d drop stop? IF LEAVE THEN $10 +LOOP ; : view T ' H [ Ttools ] >name ?dup IF 6 - T w@ H l THEN ; : tdump ( offset -- ) >r tactmodule @ cell+ T @ H r> ?DO cr I 6 .r space $10 0 DO T trelinfo H j i + bit@ IF '* ELSE bl THEN emit tactmodule @ j i + + c@ 0 <# # # #> type I 7 = IF space THEN LOOP 2 spaces $10 0 DO tactmodule @ j i + + c@ bl max emit LOOP stop? ?LEAVE $10 +LOOP ; \ clear Liter. Ascii ['] ." 14jul96pyOnlyforth Transient definitions : !tlastdes H :r tlastdes dup c@ tlastdes 2+ c! w! ; : clear true abort" There are ghosts" ; : Literal ( n -- ) H tstate @ 0= ?exit T compile lit here 6 - ! H ; immediate restrict : ALiteral ( a --) H tstate @ 0= ?exit T compile lit here 6 - A! H ; immediate restrict : Ascii H bl word 1+ c@ T [compile] Literal H ; immediate : ['] T ' [compile] ALiteral H ; immediate restrict : " T compile (C" ," align H ; immediate restrict : S" T compile (S" ," align H ; immediate restrict : ." T compile (." ," align H ; immediate restrict \ Target compilation ] 28jan97pyForth definitions : tcompiler >in @ over c@ 1+ - swap find ?dup IF 0> IF nip execute exit THEN drop dup >in ! name THEN gfind IF nip gexecute exit THEN number? ?dup IF 0> IF swap T [compile] Literal H THEN T [compile] Literal H drop exit THEN drop >in ! ghost, exit ; Transient definitions : ] H tstate on state on ['] tcompiler Is parser ; : [ H tstate off compile [ ; immediate also Assembler : >c: ?struc compile [ Assembler :R S: ; immediate previous Assembler definitions : ;c: R: T $80 tlastdes H ! current @ context ! 0 T ] H ; Transient definitions \ Macro handling 01jan93py: macro H tlastcfa @ ?dup IF T 2- dup wx@ negate swap w! here tlastopt H ! tlastdes 2+ w@ T w, trelinfo here tlastcfa H @ T >trel 0 tlastcfa H @ T 2- wx@ negate dup 1- 3 >> 1+ allot movebits H THEN ; | : macro, ( addr count skip -- ) dup >r /string 2dup T here swap move under + 3+ trelinfo r> here >trel 4 pick movebits allot H ; | : S: ( -- ) tlastdes c@ dup :r = IF drop T [s~r] w, H ELSE :s = 0= IF T -2 allot H THEN THEN 0 tlastdes c! ; | : R: ( addr1 count1 T&P -- addr2 count2 skip T&P ) dup $FF and :r = 0= IF dup 8 >> :r = 0= IF T -2 allot H 2 ELSE 0 THEN ELSE 0 THEN swap ; \ (opt, 13apr93py | : <move> ( size +- -- ) dup $80 and IF $FFFFFF00 or THEN dup 0= IF 2drop exit THEN >r there dup r@ abs + r> 0< IF swap THEN 2dup 4 pick 1+ T move >trel >r >trel >r >r trelinfo dup r> r> 2- r> 2- rot 2+ movebits H ; | : (opt, ( addr -- ) 0 T here ! H dup 3+ c@ dup negate T allot H over 2+ c@ T <move> H dup 5 + count bounds ?DO i c@ dup IF T c, H ELSE T drop 1 allot H THEN LOOP c@ dup IF tlastdes c@ IF tlastdes w! exit THEN THEN drop ; : .align ( -- ) there 3 and 3 case? IF T $90 c, H exit THEN 2 case? IF T $ED8B w, H exit THEN 1 = IF T $6D8D w, 0 c, H exit THEN ; \ topt, 03jan99py| : flag> T -7 allot 2 + here 1+ dup 1+ >r c@ $94 xor >r macro, H r> r> dup T c@ H $84 = 0= + under T c@ H xor swap T c! H ; | : topt, ( addr len skip Push&Take -- ) $0505 case? IF T flag> H exit THEN dup 8 >> opttab #opt bounds DO dup I c@ = IF drop $FF and dup dup $60 < IF $F and THEN I 1+ count bounds DO I c@ IF over ELSE dup THEN I 1+ c@ = IF 2drop I T (opt, H I 4+ c@ + T macro, H unloop unloop exit THEN I 5 + c@ 6 + +LOOP LEAVE THEN I 1+ c@ 2+ +LOOP drop drop T macro, H ; \ Target conditionals 12apr93py: BUT H depth 2/ 2 min 2- ?struc 2swap H ; immediate restrict : YET T dup 0= 0 ?pairs 2dup H ; immediate restrict : IF T compile ?branch >mark H 1 ; immediate restrict : AHEAD T compile branch >mark H 1 ; immediate restrict : THEN T S: abs 1 ?pairs >resolve [s~r] w, H ; immediate restrict : ELSE T [compile] AHEAD 2swap [compile] THEN H negate ; immediate restrict : BEGIN T S: .align <mark [s~r] w, H 2 ; immediate restrict : WHILE T [compile] IF [compile] BUT H ; immediate restrict : AGAIN T 2 ?pairs compile branch <resolve H ; immediate restrict : UNTIL T 2 ?pairs compile ?branch <resolve H ; immediate restrict : REPEAT T [compile] AGAIN [compile] THEN H ; immediate restrict\ Target conditionals b20may00py Variable tleavings : endloops ( addr -- ) T S: tleavings H @ BEGIN 2dup u< WHILE T dup @ H dup 0<> IF over + cell+ THEN swap T >resolve H REPEAT T tleavings H ! drop T [s~r] w, H ; : (leave T here 6 - tleavings H @ dup IF T <resolve H ELSE T over ! H THEN T tleavings H ! ; : LEAVE T compile branch (leave H ; immediate restrict : ?LEAVE T compile 0= compile ?branch (leave H ; immediate restrict : >R T compile >r H ; immediate restrict : R> T compile r> H ; immediate restrict \ Target conditionals 30dec92py : DO ( limit start -- ) T compile (do S: <mark [s~r] w, H 3 ; immediate restrict : ?DO ( limit start -- ) T compile (?do [compile] LEAVE <mark 2- H 3 ; immediate restrict : FOR T compile (for [compile] BEGIN H drop 4 ; immediate restrict : loop] T dup <resolve 5 - endloops compile unloop H ; : LOOP T 3 ?pairs compile (loop loop] H ; immediate restrict : +LOOP T 3 ?pairs compile (+loop loop] H ; immediate restrict : NEXT T 4 ?pairs compile (next loop] H ; immediate restrict \ predefinitions bp14jul96py: abort" T compile (abort" ," align H ; immediate : error" T compile (error" ," align H ; immediate Forth definitions Variable tsemalink Variable torigin Variable tudp 0 tudp ! Variable tlibs 0 tlibs ! : >user H @ torigin @ + ; : auser+ troot @ dup cell+ T @ H + tudp @ torigin @ + Troot @ - +Bit ; Transient definitions : origin! H torigin ! ; : user' ( -- n ) T ' 4+ count H $45 = IF T c@ H ELSE T @ H THEN ; : uallot ( n -- ) H tudp @ swap tudp +! ; \ Datatypes 15nov95py: User H >in @ Create immediate >in ! T Theader cell uallot H dup , dup $80 < IF T compile (suser here 3 - c! H ELSE T compile (user here 6 - ! H THEN T compile exit !length macro DOES> H tstate @ 0= IF >user exit THEN @ dup $80 < IF T compile (suser here 3 - c! H ELSE T compile (user here 6 - ! H THEN ; : AUser Auser+ T User H ; DO> T [compile] ALiteral H ; : Create thead+ push -5 thead+ +! prebuild Create ; \ Datatypes 11jul96py DO> H tstate @ 0= IF T @ H ELSE T [compile] ALiteral compile @ H THEN ; : Value prebuild Value T , H ; : AValue T Value trelinfo H there 4- >trel +Bit ; : Variable T Create 0 , H ; : AVariable T Create 0 A, H ; : Sema T Create 0 A, 0 A, here tsemalink H @ T A, tsemalink H ! ; dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild (Vocabulary NIL A, NIL A, here H tvoc-link @ T A, H tvoc-link ! T 0 , H ; dummy : File T prebuild File here H tfile-link @ T , H tfile-link ! T 0 , H tfileno @ T w, H 1 tfileno +! ; \ : Alias ; 06apr96py : : H >in @ >in: ! Theader H current @ context ! T ] H 0 ; : ; T 0 ?pairs compile exit !length [compile] [ H ; immediate restrict : Constant T : swap [compile] Literal [compile] ; macro H ; : AConstant T : swap [compile] ALiteral [compile] ; macro H ; : Alias ( n -- ) H tlast off tlastcfa off (theader ghost over resolve tlast @ ?dup IF T c@ H $20 or tlast @ T c! A, H ELSE drop THEN ; : T] H BEGIN >in @ name w@ $5B01 = 0= WHILE >in ! T ' A, H REPEAT drop ; \ Predefinition Input/Output-Struktur 21dec08pydummy : Out: T prebuild Out: dup c, cell+ H ; dummy : Output: T prebuild Output: T] H ; dummy : In: T prebuild In: dup c, cell+ H ; dummy : Input: T prebuild Input: T] H ; dummy : Vec: T prebuild Vec: c, H ; [IFUNDEF] :go32 H Variable direction Variable offset Variable lastcorrect Variable thelib Variable aligncorrect : proc, ( -- ) T here thelib H @ T 2 cells + dup @ A, ! thelib H @ T A, bl word count tuck here place 1+ allot H ; ghost .save ghost .int ghost .sys-stack ghost resolve-syms ghost .voidr ghost .intr ghost .correct 6 [FOR] drop [NEXT] | : !offset ( n -- ) T direction H @ 0= IF negate cells T offset H +! THEN T offset H @ T here 3 - c! H T direction H @ IF cells T offset H +! THEN ; \ Predefinition library access 24jan10py| : correct ( -- ) T direction H @ 0= IF T compile .correct 0 !offset H ELSE T offset H @ negate T lastcorrect H @ T c! H THEN [IFDEF] :osx T offset H @ T abs cell+ negate $F and negate aligncorrect H @ T c! [THEN] T offset H off ; : int ( -- ) T compile .int 1 !offset H ; immediate restrict : llong T [compile] int [compile] int H ; immediate restrict : (void) T correct compile .sys-stack compile resolve-syms compile .voidr [compile] ; proc, H ; immediate restrict : (int) T correct compile .sys-stack compile resolve-syms compile .intr [compile] ; proc, H ; immediate restrict : <rev> ( -- ) T compile .correct here 3 - lastcorrect H ! T direction H on ; immediate restrict \ Predefinition library access 21dec08py: proc: T offset direction H off off T : compile .save [IFDEF] :osx compile .correct here 3 - aligncorrect H ! T [THEN] H ; DO> T thelib H ! T proc: H ; : library T prebuild library H tlibs @ T here tlibs H ! T A, 0 , 0 A, 0 A, bl word count tuck here place 1+ allot H ; [THEN] \ target defining words 01jan93py: Defer H Auser+ T THeader compile (defer cell uallot , [ret] c, !length macro $8080 tlastopt H @ T w! H ; : Patch T THeader compile (patch H ; : IS ( adr -- ) T ' H state @ IF dup w@ $95FF = IF T 2+ @ compile (user here 6 - ! compile ! H exit THEN dup c@ $BA = IF T 1+ [compile] ALiteral compile ! H exit THEN ELSE dup w@ $95FF = IF T 2+ @ torigin H @ + T ! H exit THEN dup c@ $BA = IF 1+ T ! H exit THEN THEN true abort" not deferred!" ; immediate | : dodoes> T compile (;code !length 0 w, H Glast' @ there dup tlastcfa ! resdoes> ; : ;Code 0 T ?pairs dodoes> Assembler [compile] [ H ; immediate restrict : Does> T dodoes> compile r> H ; immediate restrict \ predefinitions 23jan05py : T&P ( takemode pushmode -- ) H tstate @ IF T compile (T&P H exit THEN T >T&P tlastopt H @ T w! H ; immediate : T&P: T : swap [compile] Literal [compile] ; macro H ; : Host H Onlyforth ; : Compiler T Host H Transient also definitions ; \ @ ! 15apr91py \ | : lit? ( -- lit t/f ) T tlastdes H 2+ w@ \ T :lit H = IF T -6 allot here 2+ @ H true exit THEN \ false ; \ \ : ! H tstate @ 0= IF T ! H ELSE T lit? H \ IF T $23DE w, A, !tlastdes H \ ELSE T compile ! H THEN THEN ; immediate \ : @ H tstate @ 0= IF T @ H exit THEN \ T lit? H IF T $2D39 $2D3A addr, !tlastdes H exit THEN\ T compile @ H ; immediate : compile H >in @ name swap >in ! gfind nip 0< IF T compile (compile ' A, H ELSE ghost, THEN ; immediate restrict \ Modul-Struktur 20may00pydummy : (Vocabulary H >in @ Vocabulary also lastcfa perform also definitions >in ! T prebuild (Vocabulary NIL A, NIL A, here H tvoc-link @ T A, H tvoc-link ! T 0 , H ; H $10000 Constant MaxModLen H &10 cells Constant ModHeader memory also | : ModInit ( addr -- ) dup >r tdp ! T 0 , MaxModLen , 0 , H tactModule @ dup T , H dup IF 8+ dup T @ r@ rot ! H ELSE r@ Troot ! THEN T , 0 , r@ tactModule H ! r> T $28 + dup dup dup A, A, A, A, $C3 w, H ; : Module ( -- ) \ Name H savedp T MaxModLen H dup 8 / + dup NewPtr under swap erase T ModInit theadalign push theadalign off (Vocabulary H ; \ Modul-Struktur 20may00py| : vec! H cells $18 + tactModule @ + T ! H ; | : vec: H Create c, DOES> c@ H >r T 0 w, here H r> T vec! ] H $80 tlastdes ! there tlastcfa ! 0 ; T 0 vec: cold: 1 vec: main: 2 vec: bye: 3 vec: export: H : Module] H savedp tactModule @ $C + T @ H dup tactModule ! ?dup IF dup T @ H + tdp ! THEN toss toss definitions ; : Module; ( -- ) T align savedp H tactModule @ >r T r@ dup cell+ @ + r@ @ $BA + r@ cell+ ! r@ dup cell+ @ dup H >r + r> T 1- 3 >> 1+ move r@ dup cell+ @ dup 1- 3 >> 1+ + SetPtrSize Module] H tactModule @ 0= IF rdrop exit THEN r> $30 + dup count + 2+ swap count ">tib T Alias H ; toss \ Target 21feb95pydummy : vec: T Prebuild vec: c, H ; : tcfa, ( addr -- ) T !tlastdes dup 2- wx@ dup 0< 0= H IF drop T call, H :r tlastdes c! exit THEN T negate 2dup + w@ H tlastdes w! there tlastcfa @ = IF tlastdes 1+ c@ tlastdes 3+ c! THEN 1- tlastdes 1+ w@ T R: H dup $0F00 and IF dup $000F and IF T topt, H exit THEN THEN drop T macro, H ; Transient also Forth ' tcfa, IS (do_resolve Onlyforth : Target Onlyforth Transient also definitions ; Transient definitions Ghost c, drop Ghost a, drop Ghost cfa, drop Ghost ' drop Ghost 'prehash drop
\ No newline at end of file
\\ *** Target-Compiler fr volksFORTH *** 25aug87rewe Der Target-Compiler erzeugt fr jedes Wort im Target-System einen 'Ghost' mit folgendem Aufbau: | LFA | Name+bl | Ptr auf <forw>/<res> | TargetCFA | Ptr TDoes| PtrDoes zeigt auf | DoesCFA | TargetDoes | \ Target compiler loadscr 21dec08py\ Idea and first Implementation by ks/bp \ Implemented on 6502 by ks/bp \ ultraFORTH83-Version by bp/we \ Atari 520 ST - Version by we \ bigFORTH Version by py \ bigFORTH.386 Version by py Onlyforth Assembler nonrelocate Forth Vocabulary Ttools Vocabulary Defining 1 $30 +thru Onlyforth \ Target header pointers 11jul96py 0 Constant NIL Variable tdp : there tdp @ ; Variable tactModule : >trel tactModule @ - ; Variable ?thead Variable tlast Variable tlastcfa Variable tlastopt Variable tlastdes Variable tstate Variable glast' Variable >in: Variable tuser Variable tvoc Variable tvoc-link NIL tvoc-link ! Variable tfile-link NIL tfile-link ! Variable tfileno 1 tfileno ! \ Image and byteorder 01jan93py : c+! ( 8b addr -- ) dup c@ rot + swap c! ; \ : >image ( addr1 -- addr2 ) displace @ + ; : >heap ( from quan -- ) dup hallot heap swap move ; 4 Constant cell ' 4+ Alias cell+ ' 4- Alias cell- ' 4* Alias cells ' 4/ Alias cell/ \ Ghost-creating 17jun10py 0 Constant dummy $4711 Constant <forw> $4712 Constant <res> : Make_ghost ( -- ghostbody ) here ( align ) here state @ tstate @ or IF context ELSE current THEN @ dup @ , name capitalize dup c@ $1F 1 within abort" invalid Gname" dup c@ 1+ over c! c@ allot bl c, ( align ) 0 w, here 2 pick - -rot <forw> , NIL , NIL , swap here over - >heap heap swap over cell+ over 'reveal ! swap dp ! heap + ; \ ghost words 2723jan05py : gfind ( string -- ghostbody tf / string ff ) dup count + 1+ bl swap c! dup >r 1 over c+! find -1 r> c+! ; : ghost ( -- cfa ) >in @ name gfind IF nip exit THEN drop >in ! Make_ghost ; : gdoes> ( ghostbody -- cfa.does ) cell+ cell+ dup @ IF @ exit THEN here dup <forw> , NIL , 2 cells >heap dp ! heap tuck swap ! ; \ ghost utilities 2518jun97py : g' ( <name> -- cfa ) name gfind 0= abort" No ghost" ; : '. ( <name> -- ) g' dup @ <forw> case? IF ." forw" ELSE <res> - abort" What's up?" ." res" THEN cell+ dup @ 7 u.r cell+ @ ?dup IF dup @ <forw> case? IF ." fdef" ELSE <res> - abort" What ??" ." rdef" THEN cell+ @ 7 u.r THEN ; ' ' Alias h' \ .unresolved 26aug87marewe : forward? ( cfa -- cfa / exit&true ) \ hlich !!! dup @ <forw> = over cell+ @ and IF drop true rdrop exit THEN ; : unresolved? ( lfa -- f ) cell+ dup c@ $1F and over + c@ bl = IF name> forward? cell+ cell+ @ dup IF forward? THEN THEN drop false ; : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup cell+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup cell- cell- unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation 22sep91py : Vocabulary Vocabulary NIL , here tvoc @ , tvoc ! ; Vocabulary Transient NIL tvoc ! Only definitions Forth also Root : T Transient ; immediate : H Forth ; immediate \ Transient primitives 01jan93pyTransient definitions \ : @ [ $205E w, 3 [FOR] $1D18 w, [NEXT] ] ; \ : w@ [ $205E w, 1 [FOR] $1D18 w, [NEXT] $4266 w, ] ; \ : wx@ w@ wextend ; \ : ! [ $205E5888 , 3 [FOR] $111E w, [NEXT] ] ; \ : w! [ $205E w, $5488548E , 1 [FOR] $111E w, [NEXT] ] ; : here there ; : allot tdp +! ; : htcmove ( from.mem to.target quan -) move ; : trelinfo H tactModule @ dup cell+ T @ H + ; \ [JSR] [BSR] 26au18jun97py $E8 Constant [call] $C3 Constant [ret] $F487 Constant [s~r] : cfa@ ( tcfa -- tcfa@ ) dup T c@ H T [call] H = IF 1+ dup T @ H + cell+ exit THEN true abort" Neither nor...." ; : movebits ( B$s B$z s z # -- ) >r 2dup > IF rot swap r> 0 ?DO 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN 1+ LOOP ELSE rot swap r@ + r> ?dup IF 1- FOR 1- 2over i + bit@ IF 2dup +bit ELSE 2dup -bit THEN NEXT THEN THEN 2drop 2drop ; \ Transient primitives 17jun10py : c, T here c! 1 allot H ; : w, T here w! 2 allot H ; : , T here ! 4 allot H ; : A, T here swap , trelinfo swap >trel +Bit H ; : A! T trelinfo over >trel +Bit ! H ; : align T here dup aligned swap ?DO bl c, LOOP H ; : ," Ascii " parse dup T c, under here swap htcmove allot H ; : ,0" Ascii " parse T under here swap htcmove allot 0 c, H ; \ : fill ( addr quan 8b -) >r >r >image r> r> fill ; \ -rot bounds ?DO dup I T c! H LOOP drop ; \ : erase 0 T fill ; \ Resolving 28dec92py : >len ( cfa -- lengthfield ) 2- ; : call! ( addr cfa.target -- ) over - 4- swap T ! H ; : call, ( cfa.target -- ) T [call] c, here over call! 4 allot H tactModule @ there within 0= IF T trelinfo here 4- >trel 2dup +Bit 1+ +Bit H THEN ; \ : cmove ( from to count -- ) >r >image >r >image r> r> cmove ; Defer (do_resolve \ Resolving Part 2 26aug87marewe Forth definitions : resolve ( ghostbody cfa.target -- ) over dup @ <res> = IF space dup >name .name ." exists " ?cr cell+ ! drop exit THEN >r >r cell+ @ ?dup IF BEGIN dup T @ H 2dup = abort" resolve loop" swap r@ T call! H ?dup 0= UNTIL THEN r> r> <res> over ! cell+ ! ; : resdoes> ( ghostbody cfa.target -- ) swap gdoes> dup @ <res> = IF cell+ ! exit THEN swap resolve ; \ Code-Body <forw> und <res> 18jun97py: do_forward ( ghostbody -- ) T [call] c, H cell+ dup @ there rot ! T , $80 tlastdes H ! ; : do_resolve ( ghostbody -- ) cell+ @ T (do_resolve H ; : gexecute ( ghostbody -- ) dup @ <forw> case? IF do_forward exit THEN <res> = IF do_resolve exit THEN true abort" What's that, a CFA ??" ; : ghost, ghost gexecute ; : move-threads Tvoc @ Tvoc-link @ BEGIN dup WHILE over cell- @ over cell- T ! @ H swap @ swap REPEAT 2drop ; : tlatest ( -- addr ) current @ cell+ cell+ cell+ cell+ ;\ Tabelle einrichten 27oct95py \needs troot Variable Troot Dos also | : (inittab ( root -- ) BEGIN dup , dup T @ H , 0 , dup 8+ T @ H ?dup IF recurse THEN $10 + T @ H dup 0= UNTIL drop ; | : inittab ( -- tab ) here troot @ (inittab 0 , $7FFF , 0 , ; | : name, ( tab -- tab ) dup @ dup $30 + count here place here c@ 1+ allot $14 + @ , 0 , dup 8+ dup T @ H , off ; | : >LinkTab ( tabstart module -- linktabstart ) here 0 w, >r over BEGIN 2dup @ = 0= WHILE $C + REPEAT name, 2drop BEGIN dup @ WHILE dup 8+ @ IF name, THEN $C + REPEAT [ " nil" @ ] Literal , 0 , 8+ dup T @ H , off here r@ - 2- r@ T w! H r> ; \ Module umformen, auf Diskette sichern... 30jan97py| : tabsearch ( addr tab -- addr entry ) BEGIN 2dup 2@ under + within 0= WHILE dup >r $C + r> @ 0= UNTIL rdrop I . drop . true abort" No address!" THEN ; | : ((savemod ( module tab handle -- return ) >r over dup T @ H >r dup cell+ T @ H + r> 0 ?DO dup I bit@ IF -rot 2 pick I 1+ bit@ IF over I + dup >r T @ H r@ + 4+ over tabsearch under @ - r@ 2+ T w! H dup $A + w@ r> over 0= IF nip I swap THEN T w! H I swap $A + w! ELSE over I + dup >r T @ H over tabsearch under @ - r@ 2+ T w! H dup 8+ w@ r> over 0= IF nip I swap THEN T w! H I swap 8+ w! THEN rot 4 ELSE 1 THEN +LOOP 2drop dup T @ H r> fwrite ; \ savemod savesystem 27dec92py | Variable handle | Variable modtab | : ?abort ( diskerr -- ) dup 0< IF r0 @ rp! ELSE drop THEN ; | : (savemod ( back linkpos module -- ) cr ." saving " dup $30 + .name T dup 8+ @ >r dup $C + @ >r dup $10 + @ >r >r H dup IF 0 handle @ 1 fseek >r handle @ 0 fseek ?abort rp@ T @ H sp@ 4 handle @ fwrite ?abort drop r@ handle @ 0 fseek ?abort r> THEN drop r@ $C + T ! H r@ 8+ off r@ $10 + off r@ modtab @ handle @ ((savemod T r> r> over $10 + ! r> over $C + ! r> over 8+ ! >r H ?abort modtab @ r> >linktab dup dup T w@ H 2+ handle @ fwrite ?abort dp ! ." saved" ; \ savemod savesystem 20may00py \needs >len : >len dup $100 0 scan drop over - ; | : getmodname ( -- addr ) Name count pad place pad 0 over count + c! count over + 4- dup c@ Ascii . = IF 0 swap c! ELSE drop THEN >len over + S" .fi" >r over r> move 0 swap 3 + c! ; | : >savemod ( back linkpos module -- ) recursive >r BEGIN >r 0 handle @ 1 fseek over r> r@ (savemod r@ 8+ T @ H ?dup IF >r dup dup 8+ r> >savemod THEN over 0< 0= r> $10 + T @ H and dup WHILE >r $10 + REPEAT drop 2drop ; \ save-target 01jan01py : savedp tactModule @ ?dup IF >r there r@ - r> T ! H ELSE EXIT THEN 0 there tactModule @ ?DO I T @ H + dup 2* swap 0< - cell +LOOP tactModule @ 5 cells + T ! H ; \needs ?diskabort : ?diskabort 0< abort" Disk error! " ; : save-target ( -- ) clear ['] ?diskabort >r r0 push dp push rp@ r0 ! >in @ >r getmodname [IFDEF] go32 0 [ELSE] r/w [THEN] fcreate dup ?abort handle ! inittab modtab ! -1 0 troot @ >savemod handle @ fclose ( r@ >in ! getmodname ) ( [ saving ] r> >in ! saveloader) rdrop ; toss \ compiling names into targ. 17jun10py Variable thead+ 7 thead+ ! Variable theadalign 3 theadalign ! : (theader >in @ name c@ swap >in ! there + thead+ @ swap - theadalign @ and 0 ?DO bl T c, H LOOP ?thead @ IF 1 ?thead +! exit THEN >in @ name capitalize swap >in ! dup c@ $20 1 within abort" inval. Tname" blk @ abs $400 + T w, H \ Loaded from File# 1 there tlatest dup @ T A, H ! there dup tlast ! over c@ 1+ dup T allot htcmove ( align ) H ; : Theader tlast off $80 tlastdes ! (theader T 0 w, H there tlastcfa ! ghost dup glast' ! there resolve ; \ prebuild defining words 01jan93py : executable? ( addr -- addr f ) dup ; : tpfa, there , ; : (prebuild ( cfa.addr -- ) >in @ Create immediate >in ! here 4- under 4+ - swap ! ; : prebuild ( addr 0_from_: -- 0 ) ?struc executable? dup >r IF compile Literal compile (prebuild ELSE drop THEN compile Theader ghost gdoes> compile Literal compile gexecute r> IF compile tpfa, THEN 0 ; immediate restrict \ code portion of def.words 02jan93py : DO> ( -- addr.of.jmp.dodoes> 0 ) 0 w, !lastdes here compile r> compile @ 0 ] ; Transient definitions : compile H ghost compile Literal compile gexecute ; immediate restrict : >T&P H $FF and >r $FF and $100 Q* r> or ; : T&P ( Take Push -- ) T >T&P tstate H @ IF T tlastdes H w! ELSE T tlastopt H @ T w! H THEN ; FORTH definitions : T&P: H : swap compile Literal compile ; macro ; \ the 468 Assembler 07nov92py Forth definitions 0 constant NIL T : +tbit trelinfo there >trel +bit ; | Table: relocate c, here allot c! +tbit [ : !length tlastcfa H @ ?dup IF dup T >len w@ H IF drop exit THEN there over - swap T >len w! H THEN ; Assembler definitions : end-code end-code !length ; \\ D6 Constant loopreg D7 Constant looplim A7 Constant RP A5 Constant UP A6 Constant SP : Next rts ; \ Definitionen fuer Assembler b17jun10pyFORTH definitions warning off $100 loadfrom forth.fb Transient definitions warning on : Assembler H relocate [ Assembler ] >codes H ! Assembler ; : >label ( addr -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Create , immediate Does> @ tstate @ IF T compile lit here 6 - A! H THEN ; : Label T ( align ) \ H tlastcfa off T here >label Assembler H ; : Code H THeader T [ Assembler ] :R T Assembler [ Assembler ] S: H ; \ immed. restr. ' \ compile 24dec92py : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; : >mark ( -- sys ) T here 6 - 0 over ! H ; : >resolve ( sys -- ) H >r there r@ - cell- r> T ! H ; : <mark ( -- addr ) H there ; : <resolve ( sys -- ) H there 2- - there 6 - T ! H ; : flag! >r H Tlast @ ?dup IF glast' @ >name dup c@ r@ or swap c! dup T c@ r@ or swap c! H THEN rdrop ; : restrict T $80 flag! H ; : immediate T $40 flag! H ; : ' ( <name> -- cfa ) H g' dup @ <res> - abort" ?" cell+ @ ; : | H ?thead @ ?exit ?thead on ; \ Target tools 17jun10py Onlyforth Ttools also definitions | : ttype ( addr n -- ) bounds ?DO I T c@ H dup bl > IF emit ELSE drop Ascii . emit THEN LOOP ; Ttools : .name ( nfa -- ) ?dup IF dup 1+ swap T c@ H $1F and ttype ELSE ." ??? " THEN space ?cr ; Ttools | : nfa? ( cfa lfa -- nfa / cfa ff ) BEGIN dup 0> WHILE 2dup 4+ dup T c@ H $1F and + 1+ ( aligned ) 2+ = IF 4+ nip exit THEN T @ H REPEAT ; Ttools : >name ( cfa -- nfa / ff ) Tvoc BEGIN @ dup WHILE under 4- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; Ttools \ Ttools for decompiling 26aug87marewe | : ?: dup 4 u.r ." :" ; | : w@? dup T w@ H 6 u.r ; | : @? dup T @ H 6 u.r ; | : c? dup T c@ H 3 .r ; : s ( addr -- addr+ ) ?: space c? 3 spaces dup 1+ over T c@ H ttype dup T c@ H + 1+ ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T cfa@ H [ Ttools ] >name .name H 4+ ; : d ( addr n -- addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot ttype ; \ Tools for decompiling bp01jan93py : l ( addr -- addr+4 ) ?: 5 spaces @? 4+ ; : c ( addr -- addr+1 ) 1 d ; : b ( addr -- addr+2 ) ?: w@? dup T w@ H over + 5 u.r 2+ ; : dump ( addr n -) bounds ?DO cr I $10 d drop stop? IF LEAVE THEN $10 +LOOP ; : view T ' H [ Ttools ] >name ?dup IF 6 - T w@ H l THEN ; : tdump ( offset -- ) >r tactmodule @ cell+ T @ H r> ?DO cr I 6 .r space $10 0 DO T trelinfo H j i + bit@ IF '* ELSE bl THEN emit tactmodule @ j i + + c@ 0 <# # # #> type I 7 = IF space THEN LOOP 2 spaces $10 0 DO tactmodule @ j i + + c@ bl max emit LOOP stop? ?LEAVE $10 +LOOP ; \ clear Liter. Ascii ['] ." 17jun10pyOnlyforth Transient definitions : !tlastdes H :r tlastdes dup c@ tlastdes 2+ c! w! ; : clear true abort" There are ghosts" ; : Literal ( n -- ) H tstate @ 0= ?exit T compile lit here 6 - ! H ; immediate restrict : ALiteral ( a --) H tstate @ 0= ?exit T compile lit here 6 - A! H ; immediate restrict : Ascii H bl word 1+ c@ T [compile] Literal H ; immediate : ['] T ' [compile] ALiteral H ; immediate restrict : " T compile (C" ," H ; immediate restrict : S" T compile (S" ," H ; immediate restrict : ." T compile (." ," H ; immediate restrict \ Target compilation ] 28jan97pyForth definitions : tcompiler >in @ over c@ 1+ - swap find ?dup IF 0> IF nip execute exit THEN drop dup >in ! name THEN gfind IF nip gexecute exit THEN number? ?dup IF 0> IF swap T [compile] Literal H THEN T [compile] Literal H drop exit THEN drop >in ! ghost, exit ; Transient definitions : ] H tstate on state on ['] tcompiler Is parser ; : [ H tstate off compile [ ; immediate also Assembler : >c: ?struc compile [ Assembler :R S: ; immediate previous Assembler definitions : ;c: R: T $80 tlastdes H ! current @ context ! 0 T ] H ; Transient definitions \ Macro handling 01jan93py: macro H tlastcfa @ ?dup IF T 2- dup wx@ negate swap w! here tlastopt H ! tlastdes 2+ w@ T w, trelinfo here tlastcfa H @ T >trel 0 tlastcfa H @ T 2- wx@ negate dup 1- 3 >> 1+ allot movebits H THEN ; | : macro, ( addr count skip -- ) dup >r /string 2dup T here swap move under + 3+ trelinfo r> here >trel 4 pick movebits allot H ; | : S: ( -- ) tlastdes c@ dup :r = IF drop T [s~r] w, H ELSE :s = 0= IF T -2 allot H THEN THEN 0 tlastdes c! ; | : R: ( addr1 count1 T&P -- addr2 count2 skip T&P ) dup $FF and :r = 0= IF dup 8 >> :r = 0= IF T -2 allot H 2 ELSE 0 THEN ELSE 0 THEN swap ; \ (opt, 13apr93py | : <move> ( size +- -- ) dup $80 and IF $FFFFFF00 or THEN dup 0= IF 2drop exit THEN >r there dup r@ abs + r> 0< IF swap THEN 2dup 4 pick 1+ T move >trel >r >trel >r >r trelinfo dup r> r> 2- r> 2- rot 2+ movebits H ; | : (opt, ( addr -- ) 0 T here ! H dup 3+ c@ dup negate T allot H over 2+ c@ T <move> H dup 5 + count bounds ?DO i c@ dup IF T c, H ELSE T drop 1 allot H THEN LOOP c@ dup IF tlastdes c@ IF tlastdes w! exit THEN THEN drop ; : .align ( -- ) there 3 and 3 case? IF T $90 c, H exit THEN 2 case? IF T $ED8B w, H exit THEN 1 = IF T $6D8D w, 0 c, H exit THEN ; \ topt, 03jan99py| : flag> T -7 allot 2 + here 1+ dup 1+ >r c@ $94 xor >r macro, H r> r> dup T c@ H $84 = 0= + under T c@ H xor swap T c! H ; | : topt, ( addr len skip Push&Take -- ) $0505 case? IF T flag> H exit THEN dup 8 >> opttab #opt bounds DO dup I c@ = IF drop $FF and dup dup $60 < IF $F and THEN I 1+ count bounds DO I c@ IF over ELSE dup THEN I 1+ c@ = IF 2drop I T (opt, H I 4+ c@ + T macro, H unloop unloop exit THEN I 5 + c@ 6 + +LOOP LEAVE THEN I 1+ c@ 2+ +LOOP drop drop T macro, H ; \ Target conditionals 12apr93py: BUT H depth 2/ 2 min 2- ?struc 2swap H ; immediate restrict : YET T dup 0= 0 ?pairs 2dup H ; immediate restrict : IF T compile ?branch >mark H 1 ; immediate restrict : AHEAD T compile branch >mark H 1 ; immediate restrict : THEN T S: abs 1 ?pairs >resolve [s~r] w, H ; immediate restrict : ELSE T [compile] AHEAD 2swap [compile] THEN H negate ; immediate restrict : BEGIN T S: .align <mark [s~r] w, H 2 ; immediate restrict : WHILE T [compile] IF [compile] BUT H ; immediate restrict : AGAIN T 2 ?pairs compile branch <resolve H ; immediate restrict : UNTIL T 2 ?pairs compile ?branch <resolve H ; immediate restrict : REPEAT T [compile] AGAIN [compile] THEN H ; immediate restrict\ Target conditionals b20may00py Variable tleavings : endloops ( addr -- ) T S: tleavings H @ BEGIN 2dup u< WHILE T dup @ H dup 0<> IF over + cell+ THEN swap T >resolve H REPEAT T tleavings H ! drop T [s~r] w, H ; : (leave T here 6 - tleavings H @ dup IF T <resolve H ELSE T over ! H THEN T tleavings H ! ; : LEAVE T compile branch (leave H ; immediate restrict : ?LEAVE T compile 0= compile ?branch (leave H ; immediate restrict : >R T compile >r H ; immediate restrict : R> T compile r> H ; immediate restrict \ Target conditionals 30dec92py : DO ( limit start -- ) T compile (do S: <mark [s~r] w, H 3 ; immediate restrict : ?DO ( limit start -- ) T compile (?do [compile] LEAVE <mark 2- H 3 ; immediate restrict : FOR T compile (for [compile] BEGIN H drop 4 ; immediate restrict : loop] T dup <resolve 5 - endloops compile unloop H ; : LOOP T 3 ?pairs compile (loop loop] H ; immediate restrict : +LOOP T 3 ?pairs compile (+loop loop] H ; immediate restrict : NEXT T 4 ?pairs compile (next loop] H ; immediate restrict \ predefinitions bp17jun10py: abort" T compile (abort" ," H ; immediate : error" T compile (error" ," H ; immediate Forth definitions Variable tsemalink Variable torigin Variable tudp 0 tudp ! Variable tlibs 0 tlibs ! : >user H @ torigin @ + ; : auser+ troot @ dup cell+ T @ H + tudp @ torigin @ + Troot @ - +Bit ; Transient definitions : origin! H torigin ! ; : user' ( -- n ) T ' 4+ count H $45 = IF T c@ H ELSE T @ H THEN ; : uallot ( n -- ) H tudp @ swap tudp +! ; \ Datatypes 15nov95py: User H >in @ Create immediate >in ! T Theader cell uallot H dup , dup $80 < IF T compile (suser here 3 - c! H ELSE T compile (user here 6 - ! H THEN T compile exit !length macro DOES> H tstate @ 0= IF >user exit THEN @ dup $80 < IF T compile (suser here 3 - c! H ELSE T compile (user here 6 - ! H THEN ; : AUser Auser+ T User H ; DO> T [compile] ALiteral H ; : Create thead+ push -5 thead+ +! prebuild Create ; \ Datatypes 11jul96py DO> H tstate @ 0= IF T @ H ELSE T [compile] ALiteral compile @ H THEN ; : Value prebuild Value T , H ; : AValue T Value trelinfo H there 4- >trel +Bit ; : Variable T Create 0 , H ; : AVariable T Create 0 A, H ; : Sema T Create 0 A, 0 A, here tsemalink H @ T A, tsemalink H ! ; dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild (Vocabulary NIL A, NIL A, here H tvoc-link @ T A, H tvoc-link ! T 0 , H ; dummy : File T prebuild File here H tfile-link @ T , H tfile-link ! T 0 , H tfileno @ T w, H 1 tfileno +! ; \ : Alias ; 06apr96py : : H >in @ >in: ! Theader H current @ context ! T ] H 0 ; : ; T 0 ?pairs compile exit !length [compile] [ H ; immediate restrict : Constant T : swap [compile] Literal [compile] ; macro H ; : AConstant T : swap [compile] ALiteral [compile] ; macro H ; : Alias ( n -- ) H tlast off tlastcfa off (theader ghost over resolve tlast @ ?dup IF T c@ H $20 or tlast @ T c! A, H ELSE drop THEN ; : T] H BEGIN >in @ name w@ $5B01 = 0= WHILE >in ! T ' A, H REPEAT drop ; \ Predefinition Input/Output-Struktur 21dec08pydummy : Out: T prebuild Out: dup c, cell+ H ; dummy : Output: T prebuild Output: T] H ; dummy : In: T prebuild In: dup c, cell+ H ; dummy : Input: T prebuild Input: T] H ; dummy : Vec: T prebuild Vec: c, H ; [IFUNDEF] :go32 H Variable direction Variable offset Variable lastcorrect Variable thelib Variable aligncorrect : proc, ( -- ) T here thelib H @ T 2 cells + dup @ A, ! thelib H @ T A, bl word count tuck here place 1+ allot H ; ghost .save ghost .int ghost .sys-stack ghost resolve-syms ghost .voidr ghost .intr ghost .correct 6 [FOR] drop [NEXT] | : !offset ( n -- ) T direction H @ 0= IF negate cells T offset H +! THEN T offset H @ T here 3 - c! H T direction H @ IF cells T offset H +! THEN ; \ Predefinition library access 24jan10py| : correct ( -- ) T direction H @ 0= IF T compile .correct 0 !offset H ELSE T offset H @ negate T lastcorrect H @ T c! H THEN [IFDEF] :osx T offset H @ T abs cell+ negate $F and negate aligncorrect H @ T c! [THEN] T offset H off ; : int ( -- ) T compile .int 1 !offset H ; immediate restrict : llong T [compile] int [compile] int H ; immediate restrict : (void) T correct compile .sys-stack compile resolve-syms compile .voidr [compile] ; proc, H ; immediate restrict : (int) T correct compile .sys-stack compile resolve-syms compile .intr [compile] ; proc, H ; immediate restrict : <rev> ( -- ) T compile .correct here 3 - lastcorrect H ! T direction H on ; immediate restrict \ Predefinition library access 21dec08py: proc: T offset direction H off off T : compile .save [IFDEF] :osx compile .correct here 3 - aligncorrect H ! T [THEN] H ; DO> T thelib H ! T proc: H ; : library T prebuild library H tlibs @ T here tlibs H ! T A, 0 , 0 A, 0 A, bl word count tuck here place 1+ allot H ; [THEN] \ target defining words 01jan93py: Defer H Auser+ T THeader compile (defer cell uallot , [ret] c, !length macro $8080 tlastopt H @ T w! H ; : Patch T THeader compile (patch H ; : IS ( adr -- ) T ' H state @ IF dup w@ $95FF = IF T 2+ @ compile (user here 6 - ! compile ! H exit THEN dup c@ $BA = IF T 1+ [compile] ALiteral compile ! H exit THEN ELSE dup w@ $95FF = IF T 2+ @ torigin H @ + T ! H exit THEN dup c@ $BA = IF 1+ T ! H exit THEN THEN true abort" not deferred!" ; immediate | : dodoes> T compile (;code !length 0 w, H Glast' @ there dup tlastcfa ! resdoes> ; : ;Code 0 T ?pairs dodoes> Assembler [compile] [ H ; immediate restrict : Does> T dodoes> compile r> H ; immediate restrict \ predefinitions 23jan05py : T&P ( takemode pushmode -- ) H tstate @ IF T compile (T&P H exit THEN T >T&P tlastopt H @ T w! H ; immediate : T&P: T : swap [compile] Literal [compile] ; macro H ; : Host H Onlyforth ; : Compiler T Host H Transient also definitions ; \ @ ! 15apr91py \ | : lit? ( -- lit t/f ) T tlastdes H 2+ w@ \ T :lit H = IF T -6 allot here 2+ @ H true exit THEN \ false ; \ \ : ! H tstate @ 0= IF T ! H ELSE T lit? H \ IF T $23DE w, A, !tlastdes H \ ELSE T compile ! H THEN THEN ; immediate \ : @ H tstate @ 0= IF T @ H exit THEN \ T lit? H IF T $2D39 $2D3A addr, !tlastdes H exit THEN\ T compile @ H ; immediate : compile H >in @ name swap >in ! gfind nip 0< IF T compile (compile ' A, H ELSE ghost, THEN ; immediate restrict \ Modul-Struktur 20may00pydummy : (Vocabulary H >in @ Vocabulary also lastcfa perform also definitions >in ! T prebuild (Vocabulary NIL A, NIL A, here H tvoc-link @ T A, H tvoc-link ! T 0 , H ; H $10000 Constant MaxModLen H &10 cells Constant ModHeader memory also | : ModInit ( addr -- ) dup >r tdp ! T 0 , MaxModLen , 0 , H tactModule @ dup T , H dup IF 8+ dup T @ r@ rot ! H ELSE r@ Troot ! THEN T , 0 , r@ tactModule H ! r> T $28 + dup dup dup A, A, A, A, $C3 w, H ; : Module ( -- ) \ Name H savedp T MaxModLen H dup 8 / + dup NewPtr under swap erase T ModInit theadalign push theadalign off (Vocabulary H ; \ Modul-Struktur 20may00py| : vec! H cells $18 + tactModule @ + T ! H ; | : vec: H Create c, DOES> c@ H >r T 0 w, here H r> T vec! ] H $80 tlastdes ! there tlastcfa ! 0 ; T 0 vec: cold: 1 vec: main: 2 vec: bye: 3 vec: export: H : Module] H savedp tactModule @ $C + T @ H dup tactModule ! ?dup IF dup T @ H + tdp ! THEN toss toss definitions ; : Module; ( -- ) T align savedp H tactModule @ >r T r@ dup cell+ @ + r@ @ $BA + r@ cell+ ! r@ dup cell+ @ dup H >r + r> T 1- 3 >> 1+ move r@ dup cell+ @ dup 1- 3 >> 1+ + SetPtrSize Module] H tactModule @ 0= IF rdrop exit THEN r> $30 + dup count + 2+ swap count ">tib T Alias H ; toss \ Target 21feb95pydummy : vec: T Prebuild vec: c, H ; : tcfa, ( addr -- ) T !tlastdes dup 2- wx@ dup 0< 0= H IF drop T call, H :r tlastdes c! exit THEN T negate 2dup + w@ H tlastdes w! there tlastcfa @ = IF tlastdes 1+ c@ tlastdes 3+ c! THEN 1- tlastdes 1+ w@ T R: H dup $0F00 and IF dup $000F and IF T topt, H exit THEN THEN drop T macro, H ; Transient also Forth ' tcfa, IS (do_resolve Onlyforth : Target Onlyforth Transient also definitions ; Transient definitions Ghost c, drop Ghost a, drop Ghost cfa, drop Ghost ' drop Ghost 'prehash drop
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment