--- gforth/cross.fs 1997/02/08 22:58:09 1.43 +++ gforth/cross.fs 1997/07/31 16:17:07 1.51 @@ -37,6 +37,11 @@ \ targets 09jun93jaw \ added: 2user and value 11jun93jaw +\ needed? works better now!!! 01mar97jaw +\ mach file is only loaded into target +\ cell corrected + + \ include other.fs \ ansforth extentions for cross : string, ( c-addr u -- ) @@ -93,29 +98,24 @@ H \ Parameter for target systems 06oct92py +>TARGET mach-file count included +[IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN] + also Forth definitions [IFDEF] asm-include asm-include [THEN] previous +hex >CROSS -\ Variables 06oct92py - -Variable image -Variable tlast NIL tlast ! \ Last name field -Variable tlastcfa \ Last code field -Variable tdoes \ Resolve does> calls -Variable bit$ -Variable tdp -: there tdp @ ; - \ Create additional parameters 19jan95py T +NIL Constant TNIL cell Constant tcell cell<< Constant tcell<< cell>bit Constant tcell>bit @@ -124,6 +124,17 @@ float Constant tfloat 1 bits/byte lshift Constant maxbyte H +\ Variables 06oct92py + +Variable image +Variable tlast TNIL tlast ! \ Last name field +Variable tlastcfa \ Last code field +Variable tdoes \ Resolve does> calls +Variable bit$ +Variable tdp +: there tdp @ ; + + >TARGET \ Byte ordering and cell size 06oct92py @@ -131,13 +142,14 @@ H : cell+ tcell + ; : cells tcell<< lshift ; : chars ; +: char+ 1 + ; : floats tfloat * ; >CROSS : cell/ tcell<< rshift ; >TARGET 20 CONSTANT bl --1 Constant NIL +TNIL Constant NIL >CROSS @@ -173,7 +185,7 @@ bigendian >MINIMAL : makekernel ( targetsize -- targetsize ) - bit$ over 1- cell>bit rshift 1+ initmem + bit$ over 1- tcell>bit rshift 1+ initmem image over initmem tdp off ; >CROSS @@ -191,7 +203,7 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, \ Target memory access 06oct92py : align+ ( taddr -- rest ) - cell tuck 1- and - [ cell 1- ] Literal and ; + tcell tuck 1- and - [ tcell 1- ] Literal and ; : cfalign+ ( taddr -- rest ) \ see kernel.fs:cfaligned /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; @@ -219,7 +231,7 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, : here ( -- there ) there ; : allot ( n -- ) tdp +! ; -: , ( w -- ) T here H cell T allot ! H ; +: , ( w -- ) T here H tcell T allot ! H ; : c, ( char -- ) T here 1 allot c! H ; : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; : cfalign ( -- ) @@ -245,6 +257,7 @@ VARIABLE VocTemp : previous VocTemp @ set-current ; +hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant @@ -269,6 +282,11 @@ Variable last-ghost here tuck swap ! ghostheader T> DOES> dup last-ghost ! >exec @ execute ; +variable cfalist 0 cfalist ! + +: markcfa + cfalist here over @ , swap ! , ; + \ ghost words 14oct92py \ changed: 10may93py/jaw @@ -338,7 +356,7 @@ variable ResolveFlag WHILE dup ?resolved REPEAT drop ResolveFlag @ IF - abort" Unresolved words!" + -1 abort" Unresolved words!" ELSE ." Nothing!" THEN @@ -374,7 +392,7 @@ VARIABLE ^imm \ Target Document Creation (goes to crossdoc.fd) 05jul95py -s" crossdoc.fd" r/w create-file throw value doc-file-id +s" doc/crossdoc.fd" r/w create-file throw value doc-file-id \ contains the file-id of the documentation file : T-\G ( -- ) @@ -441,8 +459,19 @@ Defer skip? ' false IS skip? ghost >magic @ <> ; : needed? ( -- flag ) \ name - ghost dup >magic @ = - IF >link @ 0<> ELSE drop false THEN ; +\G returns a false flag when +\G a word is not defined +\G a forward reference exists +\G so the definition is not skipped! + bl word gfind + IF dup >magic @ = + \ swap >link @ 0<> and + nip + 0= + ELSE drop true THEN ; + +: doer? ( -- flag ) \ name + ghost >magic @ = ; : skip-defs ( -- ) BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; @@ -525,6 +554,7 @@ ghost (does>) ghost noop ghost (.") ghost (S") ghost (ABORT") 2drop drop ghost ' drop ghost :docol ghost :doesjump ghost :dodoes 2drop drop +ghost over ghost = ghost drop 2drop drop \ compile 10may93jaw @@ -539,21 +569,27 @@ ghost :docol ghost :doesjump ghost :d \ generic threading modell : docol, ( -- ) compile :docol T 0 , H ; -: dodoes, ( -- ) compile :doesjump T 0 , H ; +: dodoes, ( -- ) T cfalign H compile :doesjump T 0 , H ; [IFUNDEF] (code) Defer (code) Defer (end-code) [THEN] +[IFUNDEF] ca>native +defer ca>native +[THEN] + >TARGET : Code - (THeader there resolve - there 2 T cells H + T a, 0 , H - depth (code) ; + (THeader there resolve + [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF] + there 2 T cells H + ca>native T a, 0 , H + [THEN] + depth (code) ; : Code: - ghost dup there resolve swap >magic ! + ghost dup there ca>native resolve swap >magic ! depth (code) ; : end-code @@ -644,7 +680,7 @@ Cond: MAXI docol, depth T ] H ; : :noname ( -- colon-sys ) - T align H there docol, depth T ] H ; + T cfalign H there docol, depth T ] H ; Cond: EXIT ( -- ) restrict? compile ;S ;Cond @@ -686,7 +722,7 @@ Cond: DOES> restrict? dup >magic @ = IF gexecute T 0 , H EXIT THEN THEN - compile :dodoes gexecute T here H cell - reloff ; + compile :dodoes gexecute T here H tcell - reloff ; : TCreate ( -- ) last-ghost @ @@ -760,24 +796,28 @@ Build: T 0 au, , H ; by User Builder AUser -Build: ( n -- ) T , H ; +Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO +Builder (Constant) + +Build: ( n -- ) T , H ; +by (Constant) Builder Constant Build: ( n -- ) T A, H ; -by Constant +by (Constant) Builder AConstant Build: ( d -- ) T , , H ; DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO Builder 2Constant -Build: T 0 , H ; -by Constant +Build: T , H ; +by (Constant) Builder Value -Build: T 0 A, H ; -by Constant +Build: T A, H ; +by (Constant) Builder AValue Build: ( -- ) compile noop ; @@ -796,16 +836,21 @@ Builder interpret/compile: 1- tuck + swap invert and ; >TARGET -Build: >r rot r@ nalign dup T , H ( align1 size offset ) - + swap r> nalign ; +Build: ; by: :dofield T @ H + ;DO +Builder (Field) + +Build: ( align1 offset1 align size "name" -- align2 offset2 ) + rot dup T , H ( align1 align size offset1 ) + + >r nalign r> ; +by (Field) Builder Field -: struct T 0 1 chars H ; +: struct T 1 chars 0 H ; : end-struct T 2Constant H ; -: cells: ( n -- size align ) - T cells 1 cells H ; +: cell% ( -- align size ) + T 1 cells H dup ; \ ' 2Constant Alias2 end-struct \ 0 1 T Chars H 2Constant struct @@ -853,14 +898,20 @@ Cond: AGAIN restrict? sys? compile b Cond: UNTIL restrict? sys? compile ?branch r compile over compile = compile IF compile drop + r> ;Cond +Cond: ENDOF restrict? >r compile ELSE r> ;Cond +Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond + \ Structural Conditionals 12dec92py Cond: DO restrict? compile (do) T here H ;Cond -Cond: ?DO restrict? compile (?do) (leave T here H ;Cond +Cond: ?DO restrict? compile (?do) T (leave here H ;Cond Cond: FOR restrict? compile (for) T here H ;Cond >CROSS -: loop] dup TARGET Cond: LOOP restrict? sys? compile (loop) loop] ;Cond @@ -920,6 +971,8 @@ also minimal \ define new [IFDEF] and [IFUNDEF] 20may93jaw : defined? defined? ; +: needed? needed? ; +: doer? doer? ; : [IFDEF] defined? postpone [IF] ; : [IFUNDEF] defined? 0= postpone [IF] ; @@ -938,9 +991,21 @@ also minimal also minimal +\G interprets the line if word is not defined : \- defined? IF postpone \ THEN ; + +\G interprets the line if word is defined : \+ defined? 0= IF postpone \ THEN ; +Cond: \- \- ;Cond +Cond: \+ \+ ;Cond + +: ?? bl word find IF execute ELSE drop 0 THEN ; + +: needed: +\G defines ghost for words that we want to be compiled + BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; + : [IF] postpone [IF] ; : [THEN] postpone [THEN] ; : [ELSE] postpone [ELSE] ; @@ -951,24 +1016,19 @@ Cond: [IFUNDEF] [IFUNDEF] ;Cond Cond: [THEN] [THEN] ;Cond Cond: [ELSE] [ELSE] ;Cond -\ save-cross 17mar93py - -\ i'm not interested in bigforth features this time 10may93jaw -\ [IFDEF] file -\ also file -\ [THEN] -\ included throw after create-file 11may93jaw +previous -bigendian Constant bigendian +\ save-cross 17mar93py +>CROSS Create magic s" Gforth10" here over allot swap move -char 1 bigendian + cell + magic 7 + c! +char 1 bigendian + tcell + magic 7 + c! : save-cross ( "image-name" "binary-name" -- ) bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r - NIL IF + TNIL IF s" #! " r@ write-file throw bl parse r@ write-file throw s" -i" r@ write-file throw @@ -983,16 +1043,24 @@ char 1 bigendian + cell + magic 7 + c! bl parse 2drop THEN image @ there r@ write-file throw \ write image - NIL IF - bit$ @ there 1- cell>bit rshift 1+ + TNIL IF + bit$ @ there 1- tcell>bit rshift 1+ r@ write-file throw \ write tags THEN r> close-file throw ; \ words that should be in minimal +>MINIMAL +also minimal +bigendian Constant bigendian +: save-cross save-cross ; : here there ; -also forth [IFDEF] Label : Label Label ; [THEN] previous +also forth +[IFDEF] Label : Label Label ; [THEN] +[IFDEF] start-macros : start-macros start-macros ; [THEN] +previous + : + + ; : or or ; : 1- 1- ; @@ -1010,14 +1078,16 @@ also forth [IFDEF] Label : Label Label ; : lshift lshift ; : 2/ 2/ ; : . . ; +: const ; -mach-file count included +\ mach-file count included : all-words ['] false IS skip? ; : needed-words ['] needed? IS skip? ; : undef-words ['] defined? IS skip? ; : \ postpone \ ; immediate +: \G T-\G ; immediate : ( postpone ( ; immediate : include bl word count included ; : .( [char] ) parse type ;