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
No preview for this file type
No preview for this file type
No preview for this file type
No preview for this file type
No preview for this file type
\\ *** 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