Diff for /gforth/cross.fs between versions 1.55 and 1.65

version 1.55, 1998/05/31 19:29:22 version 1.65, 1999/01/10 22:00:22
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 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 52  Warnings off Line 52  Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
   : KB  400 * ;
 : >wordlist ( vocabulary-xt -- wordlist-struct )  : >wordlist ( vocabulary-xt -- wordlist-struct )
   also execute get-order swap >r 1- set-order r> ;    also execute get-order swap >r 1- set-order r> ;
   
Line 68  Warnings off Line 69  Warnings off
 \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 bl word drop >body ! ELSE Value THEN ;   IF ['] to execute 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
 \G DefaultValue searches in the current vocabulary  \G DefaultValue 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 bl word drop drop drop ELSE Value THEN ;   IF bl word drop 2drop ELSE Value THEN ;
   
 hex  hex
   
Line 302  true  SetValue cross Line 303  true  SetValue cross
 true SetValue standard-threading  true SetValue standard-threading
 >TARGET previous  >TARGET previous
   
   
 mach-file count included hex  mach-file count included hex
   
 >ENVIRON  >ENVIRON
Line 334  s" relocate" T environment? H Line 336  s" relocate" T environment? H
   
 \ \ Create additional parameters                         19jan95py  \ \ Create additional parameters                         19jan95py
   
   1 8 lshift Constant maxbyte
 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/byte          Constant tbits/byte
   bits/byte 8 /      Constant tchar
 float              Constant tfloat  float              Constant tfloat
 1 bits/byte lshift Constant maxbyte  1 bits/byte lshift Constant tmaxbyte
 H  H
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
Line 589  bigendian Line 593  bigendian
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds     : S@  ( addr -- n )  >r 0 0 r> tcell bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
        DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : S!  ( n addr -- )  >r s>d r> tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
      : Sc!  ( n addr -- )  >r s>d r> tchar bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 >CROSS  >CROSS
Line 629  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 641  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 >TARGET  >TARGET
 : @  ( taddr -- w )     >image S@ ;  : @  ( taddr -- w )     >image S@ ;
 : !  ( w taddr -- )     >image S! ;  : !  ( w taddr -- )     >image S! ;
 : c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image c! ;  : c! ( char taddr -- )  >image Sc! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
   
Line 640  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 652  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : here  ( -- there )    there ;  : here  ( -- there )    there ;
 : allot ( n -- )        tdp +! ;  : allot ( n -- )        tdp +! ;
 : ,     ( w -- )        T here H tcell T allot  ! H T here drop H ;  : ,     ( w -- )        T here H tcell T allot  ! H T here drop H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here    tchar allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, H LOOP ;      T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;
   
 : A!                    dup relon T ! H ;  : >address              dup 0>= IF tchar / THEN ;
 : A,    ( w -- )        T here H relon T , H ;  : A!                    swap >address swap dup relon T ! H ;
   : A,    ( w -- )        >address T here H relon T , H ;
   
 >CROSS  >CROSS
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
 \G cmove in target memory  \G cmove in target memory
   bounds    tchar * bounds
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   LOOP  drop ;    tchar +LOOP  drop ;
   
 >TARGET  >TARGET
 H also Forth definitions \ ." asm: " order  H also Forth definitions \ ." asm: " order
Line 1105  NoHeaderFlag off Line 1118  NoHeaderFlag off
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !          tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !
         1 headers-named +!      \ Statistic          1 headers-named +!      \ Statistic
         >in @ T name, H >in !          >in @ T name, H >in !
     THEN      THEN
Line 1151  VARIABLE ;Resolve 1 cells allot Line 1164  VARIABLE ;Resolve 1 cells allot
         .sourcepos ." needs doer: " >in @ bl word count type >in ! cr          .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
     THEN      THEN
     ghost tuck swap resolve <do:> swap >magic ! ;      ghost tuck swap resolve <do:> swap >magic ! ;
   
   Variable prim#
   : first-primitive ( n -- )  prim# ! ;
   : Primitive  ( -- ) \ name
       prim# @ T Alias H  -1 prim# +! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 1213  Cond: [']  T ' H alit, ;Cond Line 1231  Cond: [']  T ' H alit, ;Cond
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ;    T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
Line 1263  Defer (end-code) Line 1281  Defer (end-code)
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 Cond: chars ;Cond  ( Cond ) : chars tchar * ; ( Cond )
   
 >CROSS  >CROSS
   
Line 1621  Builder Field Line 1639  Builder Field
 : sys?        ( sys -- sys )    dup 0= ?struc ;  : sys?        ( sys -- sys )    dup 0= ?struc ;
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
   
 : branchoffset ( src dest -- ) - ;  : branchoffset ( src dest -- ) - tchar / ;
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;
   
Line 1941  previous Line 1959  previous
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
   
 >CROSS  >CROSS
 Create magic  s" Gforth10" here over allot swap move  Create magic  s" Gforth2x" here over allot swap move
   
 char 1 bigendian + tcell + magic 7 + c!  bigendian 1+ \ strangely, in magic big=0, little=1
   tcell 1 = 0 and or
   tcell 2 = 2 and or
   tcell 4 = 4 and or
   tcell 8 = 6 and or
   tchar 1 = $00 and or
   tchar 2 = $28 and or
   tchar 4 = $50 and or
   tchar 8 = $78 and or
   magic 7 + c!
   
 : save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type cr    bl parse ." Saving to " 2dup type cr
Line 1993  bigendian Constant bigendian Line 2020  bigendian Constant bigendian
 : tempdp> tempdp> ;  : tempdp> tempdp> ;
 : const constflag on ;  : const constflag on ;
 : warnings name 3 = 0= twarnings ! drop ;  : warnings name 3 = 0= twarnings ! drop ;
 : | NoHeaderFlag on ;  : | ;
   \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
   
 : save-cross save-cross ;  : save-cross save-cross ;
 : save-region save-region ;  : save-region save-region ;

Removed from v.1.55  
changed lines
  Added in v.1.65


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