[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.67 and 1.76

version 1.67, 1999/02/19 18:25:28 version 1.76, 1999/05/17 13:12:25
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ 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.  \ This file is part of Gforth.
   
Line 52  Warnings off Line 52  Warnings off
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
 \G Same behaviour as "to" if <name> is defined  \G Same behaviour as "to" if <name> is defined
 \G SetValue searches in the current vocabulary  \G SetValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count    save-input bl word >r restore-input throw r> count
  get-current search-wordlist    get-current search-wordlist
  IF ['] to execute ELSE Value THEN ;    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 -- <name> )  : DefaultValue ( n -- <name> )
 \G Same behaviour as "Value" if the <name> is not defined  \G Same behaviour as "Value" if the <name> is not defined
Line 113  also forth definitions  \ these values m Line 118  also forth definitions  \ these values m
 false DefaultValue stack-warn            \ check on empty stack at any definition  false DefaultValue stack-warn            \ check on empty stack at any definition
 false DefaultValue create-forward-warn   \ warn on forward declaration of created words  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  previous >CROSS
   
 : .dec  : .dec
Line 138  stack-warn [IF] Line 140  stack-warn [IF]
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [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? ( <name> -- 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  \ \ GhostNames Ghosts                                  9may93jaw
   
Line 166  VARIABLE VocTemp Line 207  VARIABLE VocTemp
 hex  hex
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
   4715 Constant <skip>
   
 \ iForth makes only immediate directly after create  \ iForth makes only immediate directly after create
 \ make atonce trick! ?  \ make atonce trick! ?
   
 Variable atonce atonce off  Variable atonce atonce off
   
 : NoExec true ABORT" CROSS: Don't execute ghost" ;  : NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
Line 217  VARIABLE Already Line 259  VARIABLE Already
   
 : ghost   ( "name" -- ghost )  : ghost   ( "name" -- ghost )
   Already off    Already off
   >in @  bl word gfind   IF  Already on nip EXIT  THEN    >in @  bl word gfind   IF  atonce off Already on nip EXIT  THEN
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
   
 : >ghostname ( ghost -- adr len )  : >ghostname ( ghost -- adr len )
Line 235  VARIABLE Already Line 277  VARIABLE Already
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
   >magic @ <fwd> = ;    >magic @ <fwd> = ;
   
   : undefined? ( ghost -- flag )
     >magic @ dup <fwd> = swap <skip> = or ;
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
 ghost 0=                                        drop  ghost 0=                                        drop
Line 276  VARIABLE env-current \ save information Line 321  VARIABLE env-current \ save information
 : has?  bl word count T environment? H   : has?  bl word count T environment? H 
         IF      \ environment variable is present, return its value          IF      \ environment variable is present, return its value
         ELSE    \ environment variable is not present, return false          ELSE    \ environment variable is not present, return false
                 \ !! JAW abort is just for testing                  false \ debug true ABORT" arg" 
                 false true ABORT" arg"   
         THEN ;          THEN ;
   
 : $has? T environment? H IF ELSE false THEN ;  : $has? T environment? H IF ELSE false THEN ;
Line 310  false DefaultValue header Line 354  false DefaultValue header
 true DefaultValue interpreter  true DefaultValue interpreter
 true DefaultValue ITC  true DefaultValue ITC
 false DefaultValue rom  false DefaultValue rom
   true DefaultValue standardthreading
   
 >TARGET  >TARGET
 s" relocate" T environment? H   s" relocate" T environment? H 
Line 321  s" relocate" T environment? H Line 366  s" relocate" T environment? H
   
 \ \ Create additional parameters                         19jan95py  \ \ 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  \ this sets byte size for the target machine, an (probably right guess) jaw
   
 T  T
 NIL                Constant TNIL  NIL                     Constant TNIL
 cell               Constant tcell  cell                    Constant tcell
 cell<<             Constant tcell<<  cell<<                  Constant tcell<<
 cell>bit           Constant tcell>bit  cell>bit                Constant tcell>bit
 bits/byte          Constant tbits/byte  bits/char               Constant tbits/char
 bits/byte 8 /      Constant tchar  bits/char H bits/byte T /      
 float              Constant tfloat                          Constant tchar
 1 bits/byte lshift Constant tmaxbyte  float                   Constant tfloat
   1 bits/char lshift      Constant tmaxchar
   [IFUNDEF] bits/byte
   8                       Constant tbits/byte
   [ELSE]
   bits/byte               Constant tbits/byte
   [THEN]
 H  H
   tbits/byte bits/byte /  Constant tbyte
   
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
Line 348  Variable bit$ Line 417  Variable bit$
 Variable headers-named 0 headers-named !  Variable headers-named 0 headers-named !
 Variable user-vars 0 user-vars !  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 )  : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;    1- tcell>bit rshift 1+ ;
   
Line 379  Variable user-vars 0 user-vars ! Line 424  Variable user-vars 0 user-vars !
   dup allocate ABORT" CROSS: No memory for target"    dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;    swap over swap erase ;
   
   
   
 \ \ memregion.fs  \ \ memregion.fs
   
   
Line 425  Variable mirrored-link          \ linked Line 468  Variable mirrored-link          \ linked
   
 : mirrored                              \G mark a region as mirrored  : mirrored                              \G mark a region as mirrored
   mirrored-link    mirrored-link
   linked last-defined-region @ , ;    align linked last-defined-region @ , ;
   
 : .addr ( u -- )  : .addr ( u -- )
 \G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
Line 486  T has? rom H Line 529  T has? rom H
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize targets memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       address-space area nip 0<>        \ address-space area nip 0<>
       ram-dictionary area nip 0<>        ram-dictionary area nip 0<>
       rom-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!"        ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
   THEN    THEN
   address-space area nip    address-space area nip
Line 514  T has? rom H Line 557  T has? rom H
                 r@ >rmem !                  r@ >rmem !
   
                 target>bitmask-size allocatetarget                  target>bitmask-size allocatetarget
                 dup                  dup bit$ !
                 bit$ !  
                 r> >rbm !                  r> >rbm !
   
         ELSE    r> drop THEN          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  \ \ switched tdp for rom support                                03jun97jaw
   
Line 598  variable constflag constflag off Line 649  variable constflag constflag off
   
 : cell+         tcell + ;  : cell+         tcell + ;
 : cells         tcell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         tchar * ;
 : char+         1 + ;  : char+         tchar + ;
 : floats        tfloat * ;  : floats        tfloat * ;
           
 >CROSS  >CROSS
Line 684  T has? relocate H Line 735  T has? relocate H
 [ELSE]  [ELSE]
 ' drop IS relon  ' drop IS relon
 ' drop IS reloff  ' drop IS reloff
 ' (correcter) IS >image  ' (>regionimage) IS >image
 [THEN]  [THEN]
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
Line 721  T has? relocate H Line 772  T has? relocate H
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;      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!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
Line 736  T has? relocate H Line 787  T has? relocate H
 \ \ Load Assembler  \ \ Load Assembler
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions
   
 : X     also target bl word find  : X     also target bl word find
         IF      state @ IF compile,          IF      state @ IF compile,
Line 854  Create NoFile ," #load-file#" Line 905  Create NoFile ," #load-file#"
         REPEAT          REPEAT
         2drop drop false ;                2drop drop false ;      
   
   false DebugFlag showincludedfiles
   
 : included   : included 
 \       cr ." Including: " 2dup type ." ..."          [d?] showincludedfiles
           IF      cr ." Including: " 2dup type ." ..." THEN
         FileMem >r          FileMem >r
         2dup add-included-file included           2dup add-included-file included 
         r> to FileMem ;          r> to FileMem ;
Line 958  Exists-Warnings on Line 1012  Exists-Warnings on
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another definition with the      \ is ghost resolved?, second resolve means another definition with the
     \ same name      \ same name
     over forward? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      \ get linked-list
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
Line 1135  Create tag-bof 1 c,  0C c, Line 1189  Create tag-bof 1 c,  0C c,
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
   
   : skipdef ( <name> -- )
   \G skip definition of an undefined word in undef-words mode
       ghost dup forward?
       IF  >magic <skip> swap !
       ELSE drop THEN ;
   
 : defined? ( -- flag ) \ name  : defined? ( -- flag ) \ name
       ghost undefined? 0= ;
   
   : defined2? ( -- flag ) \ name
   \G return true for anything else than forward, even for <skip>
   \G that's what we want
     ghost forward? 0= ;      ghost forward? 0= ;
   
 : needed? ( -- flag ) \ name  : needed? ( -- flag ) \ name
Line 1144  Defer skip? ' false IS skip? Line 1209  Defer skip? ' false IS skip?
 \G a forward reference exists  \G a forward reference exists
 \G so the definition is not skipped!  \G so the definition is not skipped!
     bl word gfind      bl word gfind
     IF dup forward?      IF dup undefined?
         nip          nip
         0=          0=
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
Line 1193  NoHeaderFlag off Line 1258  NoHeaderFlag off
     \ Symbol table      \ Symbol table
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     CreateFlag @      CreateFlag @
     IF      IF  \ for a created word we need also a definition in target
           \ to execute the created word while compile time
           \ dont mind if a alias is defined twice
           Warnings @ >r Warnings off
         >in @ alias2 swap >in !         \ create alias in target          >in @ alias2 swap >in !         \ create alias in target
           r> Warnings !
         >in @ ghost swap >in !          >in @ ghost swap >in !
         swap also ghosts ' previous swap !     \ tick ghost and store in alias          swap also ghosts ' previous swap !     \ tick ghost and store in alias
         CreateFlag off          CreateFlag off
Line 1277  Comment (       Comment \ Line 1346  Comment (       Comment \
   THEN ; immediate    THEN ; immediate
   
 : ghost>cfa  : ghost>cfa
   dup forward? ABORT" CROSS: forward " >link @ ;    dup undefined? ABORT" CROSS: forward " >link @ ;
                                 
 >TARGET  >TARGET
   
Line 1511  Cond: DOES> restrict? Line 1580  Cond: DOES> restrict?
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
   >end @ dup forward? 0=    >end @ dup undefined? 0=
   IF    IF
         dup >magic @ <do:> =          dup >magic @ <do:> =
         IF       doer,           IF       doer, 
Line 2008  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 2077  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 also minimal  also minimal
   
 \G doesn't skip line when bit is set in debugmask  : d? d? ;
 : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ;  
   \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  \G interprets the line if word is not defined
 : \- defined? IF postpone \ THEN ;  : \- defined? IF postpone \ THEN ;
Line 2133  previous Line 2204  previous
   
 : all-words    ['] false    IS skip? ;  : all-words    ['] false    IS skip? ;
 : needed-words ['] needed?  IS skip? ;  : needed-words ['] needed?  IS skip? ;
 : undef-words  ['] defined? IS skip? ;  : undef-words  ['] defined2? IS skip? ;
   : skipdef skipdef ;
   
 : \  postpone \ ;  immediate  : \  postpone \ ;  immediate
 : \G T-\G ; immediate  : \G T-\G ; immediate
Line 2179  minimal Line 2251  minimal
 \ these ones are pefered:  \ these ones are pefered:
   
 : lock   turnkey ;  : lock   turnkey ;
 : unlock forth also cross ;  : unlock previous forth also cross ;
   
 : [[ also unlock ;  : [[ also unlock ;
 : ]] previous previous ;  : ]] previous previous ;
Removed from v.1.67  
changed lines
  Added in v.1.76

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>