--- gforth/cross.fs 1999/02/19 18:25:28 1.67 +++ gforth/cross.fs 1999/05/10 13:57:37 1.75 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -52,9 +52,14 @@ Warnings off \G Same behaviour as "Value" if the is not defined \G Same behaviour as "to" if is defined \G SetValue searches in the current vocabulary - save-input bl word >r restore-input throw r> count - get-current search-wordlist - IF ['] to execute ELSE Value THEN ; + save-input bl word >r restore-input throw r> count + get-current search-wordlist + IF drop >r + \ we have to set current to be topmost context wordlist + get-order get-order get-current swap 1+ set-order + r> ['] to execute + set-order + ELSE Value THEN ; : DefaultValue ( n -- ) \G Same behaviour as "Value" if the is not defined @@ -113,8 +118,9 @@ also forth definitions \ these values m false DefaultValue stack-warn \ check on empty stack at any definition false DefaultValue create-forward-warn \ warn on forward declaration of created words -[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] -[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] + + + previous >CROSS @@ -138,7 +144,46 @@ stack-warn [IF] : defempty? ; immediate [THEN] +\ debugging +0 [IF] + +This implements debugflags for the cross compiler and the compiled +images. It works identical to the has-flags in the environment. +The debugflags are defined in a vocabluary. If the word exists and +its value is true, the flag is switched on. + +[THEN] + +Vocabulary debugflags \ debug flags for cross +also debugflags get-order over +Constant debugflags-wl +set-order previous + +: DebugFlag + get-current >r debugflags-wl set-current + SetValue + r> set-current ; + +: Debug? ( adr u -- flag ) +\G return true if debug flag is defined or switched on + debugflags-wl search-wordlist + IF EXECUTE + ELSE false THEN ; + +: D? ( -- flag ) +\G return true if debug flag is defined or switched on +\G while compiling we do not return the current value but + bl word count debug? ; + +: [d?] +\G compile the value-xt so the debug flag can be switched +\G the flag must exist! + bl word count debugflags-wl search-wordlist + IF compile, + ELSE -1 ABORT" unknown debug flag" + \ POSTPONE false + THEN ; immediate \ \ GhostNames Ghosts 9may93jaw @@ -166,6 +211,7 @@ VARIABLE VocTemp hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant +4715 Constant \ iForth makes only immediate directly after create \ make atonce trick! ? @@ -235,6 +281,9 @@ VARIABLE Already : forward? ( ghost -- flag ) >magic @ = ; +: undefined? ( ghost -- flag ) + >magic @ dup = swap = or ; + \ Predefined ghosts 12dec92py ghost 0= drop @@ -276,8 +325,7 @@ VARIABLE env-current \ save information : has? bl word count T environment? H IF \ environment variable is present, return its value ELSE \ environment variable is not present, return false - \ !! JAW abort is just for testing - false true ABORT" arg" + false \ debug true ABORT" arg" THEN ; : $has? T environment? H IF ELSE false THEN ; @@ -310,6 +358,7 @@ false DefaultValue header true DefaultValue interpreter true DefaultValue ITC false DefaultValue rom +true DefaultValue standardthreading >TARGET s" relocate" T environment? H @@ -321,19 +370,43 @@ s" relocate" T environment? H \ \ Create additional parameters 19jan95py -1 8 lshift Constant maxbyte +\ currently cross only works for host machines with address-unit-bits +\ eual to 8 because of s! and sc! +\ but I start to query the environment just to modularize a little bit + +: check-address-unit-bits ( -- ) +\ s" ADDRESS-UNIT-BITS" environment? +\ IF 8 <> ELSE true THEN +\ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!" + +\ shit, this doesn't work because environment? is only defined for +\ gforth.fi and not kernl???.fi + ; + +check-address-unit-bits +8 Constant bits/byte \ we define: byte is address-unit + +1 bits/byte lshift Constant maxbyte \ this sets byte size for the target machine, an (probably right guess) jaw T -NIL Constant TNIL -cell Constant tcell -cell<< Constant tcell<< -cell>bit Constant tcell>bit -bits/byte Constant tbits/byte -bits/byte 8 / Constant tchar -float Constant tfloat -1 bits/byte lshift Constant tmaxbyte +NIL Constant TNIL +cell Constant tcell +cell<< Constant tcell<< +cell>bit Constant tcell>bit +bits/char Constant tbits/char +bits/char H bits/byte T / + Constant tchar +float Constant tfloat +1 bits/char lshift Constant tmaxchar +[IFUNDEF] bits/byte +8 Constant tbits/byte +[ELSE] +bits/byte Constant tbits/byte +[THEN] H +tbits/byte bits/byte / Constant tbyte + \ Variables 06oct92py @@ -348,30 +421,6 @@ Variable bit$ Variable headers-named 0 headers-named ! Variable user-vars 0 user-vars ! -\ Memory initialisation 05dec92py - -[IFDEF] Memory \ Memory is a bigFORTH feature - also Memory - : initmem ( var len -- ) - 2dup swap handle! >r @ r> erase ; - toss -[ELSE] - : initmem ( var len -- ) - tuck allocate abort" CROSS: No memory for target" - ( len var adr ) dup rot ! - ( len adr ) swap erase ; -[THEN] - -\ MakeKernal 12dec92py - -: makekernel ( targetsize -- targetsize ) - bit$ over 1- tcell>bit rshift 1+ initmem - image over initmem ; - ->MINIMAL -: makekernel makekernel ; ->CROSS - : target>bitmask-size ( u1 -- u2 ) 1- tcell>bit rshift 1+ ; @@ -379,8 +428,6 @@ Variable user-vars 0 user-vars ! dup allocate ABORT" CROSS: No memory for target" swap over swap erase ; - - \ \ memregion.fs @@ -425,7 +472,7 @@ Variable mirrored-link \ linked : mirrored \G mark a region as mirrored mirrored-link - linked last-defined-region @ , ; + align linked last-defined-region @ , ; : .addr ( u -- ) \G prints a 16 or 32 Bit nice hex value @@ -486,10 +533,10 @@ T has? rom H : setup-target ( -- ) \G initialize targets memory space s" rom" T $has? H IF \ check for ram and rom... - address-space area nip 0<> + \ address-space area nip 0<> ram-dictionary area nip 0<> rom-dictionary area nip 0<> - and and 0= + and 0= ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" THEN address-space area nip @@ -514,12 +561,20 @@ T has? rom H r@ >rmem ! target>bitmask-size allocatetarget - dup - bit$ ! + dup bit$ ! r> >rbm ! ELSE r> drop THEN - REPEAT ; + REPEAT drop ; + +\ MakeKernal 22feb99jaw + +: makekernel ( targetsize -- targetsize ) + dup dictionary >rlen ! setup-target ; + +>MINIMAL +: makekernel makekernel ; +>CROSS \ \ switched tdp for rom support 03jun97jaw @@ -598,8 +653,8 @@ variable constflag constflag off : cell+ tcell + ; : cells tcell<< lshift ; -: chars ; -: char+ 1 + ; +: chars tchar * ; +: char+ tchar + ; : floats tfloat * ; >CROSS @@ -684,7 +739,7 @@ T has? relocate H [ELSE] ' drop IS relon ' drop IS reloff -' (correcter) IS >image +' (>regionimage) IS >image [THEN] \ Target memory access 06oct92py @@ -721,7 +776,7 @@ T has? relocate H : cfalign ( -- ) T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; -: >address dup 0>= IF tchar / THEN ; \ ?? jaw +: >address dup 0>= IF tbyte / THEN ; \ ?? jaw : A! swap >address swap dup relon T ! H ; : A, ( w -- ) >address T here H relon T , H ; @@ -736,7 +791,7 @@ T has? relocate H \ \ Load Assembler >TARGET -H also Forth definitions \ ." asm: " order +H also Forth definitions : X also target bl word find IF state @ IF compile, @@ -854,8 +909,11 @@ Create NoFile ," #load-file#" REPEAT 2drop drop false ; +false DebugFlag showincludedfiles + : included -\ cr ." Including: " 2dup type ." ..." + [d?] showincludedfiles + IF cr ." Including: " 2dup type ." ..." THEN FileMem >r 2dup add-included-file included r> to FileMem ; @@ -958,7 +1016,7 @@ Exists-Warnings on \G resolve referencies to ghost with tcfa \ is ghost resolved?, second resolve means another definition with the \ same name - over forward? 0= IF exists EXIT THEN + over undefined? 0= IF exists EXIT THEN \ get linked-list swap >r r@ >link @ swap \ ( list tcfa R: ghost ) \ mark ghost as resolved @@ -1135,7 +1193,18 @@ Create tag-bof 1 c, 0C c, Defer skip? ' false IS skip? +: skipdef ( -- ) +\G skip definition of an undefined word in undef-words mode + ghost dup forward? + IF >magic swap ! + ELSE drop THEN ; + : defined? ( -- flag ) \ name + ghost undefined? 0= ; + +: defined2? ( -- flag ) \ name +\G return true for anything else than forward, even for +\G that's what we want ghost forward? 0= ; : needed? ( -- flag ) \ name @@ -1144,7 +1213,7 @@ Defer skip? ' false IS skip? \G a forward reference exists \G so the definition is not skipped! bl word gfind - IF dup forward? + IF dup undefined? nip 0= ELSE drop true THEN ; @@ -1277,7 +1346,7 @@ Comment ( Comment \ THEN ; immediate : ghost>cfa - dup forward? ABORT" CROSS: forward " >link @ ; + dup undefined? ABORT" CROSS: forward " >link @ ; >TARGET @@ -1511,7 +1580,7 @@ Cond: DOES> restrict? : gdoes, ( ghost -- ) \ makes the codefield for a word that is built - >end @ dup forward? 0= + >end @ dup undefined? 0= IF dup >magic @ = IF doer, @@ -2008,8 +2077,10 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond also minimal -\G doesn't skip line when bit is set in debugmask -: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; +: d? d? ; + +\G doesn't skip line when debug switch is on +: \D D? 0= IF postpone \ THEN ; \G interprets the line if word is not defined : \- defined? IF postpone \ THEN ; @@ -2133,7 +2204,8 @@ previous : all-words ['] false IS skip? ; : needed-words ['] needed? IS skip? ; -: undef-words ['] defined? IS skip? ; +: undef-words ['] defined2? IS skip? ; +: skipdef skipdef ; : \ postpone \ ; immediate : \G T-\G ; immediate @@ -2179,7 +2251,7 @@ minimal \ these ones are pefered: : lock turnkey ; -: unlock forth also cross ; +: unlock previous forth also cross ; : [[ also unlock ; : ]] previous previous ;