[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.16 and 1.32

version 1.16, Thu Nov 17 15:53:07 1994 UTC version 1.32, Thu Nov 30 18:01:47 1995 UTC
Line 1 
Line 1 
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ $Id$  
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992-94 by the GNU Forth Development Group  
   \ Copyright (C) 1995 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
 \ Log:  \ Log:
 \       changed in ; [ to state off           12may93jaw  \       changed in ; [ to state off           12may93jaw
Line 23 
Line 39 
   
 \ include other.fs       \ ansforth extentions for cross  \ include other.fs       \ ansforth extentions for cross
   
   : string, ( c-addr u -- )
       \ puts down string as cstring
       dup c, here swap chars dup allot move ;
   ' falign Alias cfalign
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
         IF    postpone (          IF    postpone (
Line 42 
Line 62 
         here GhostNames @ , GhostNames ! here 0 ,          here GhostNames @ , GhostNames ! here 0 ,
         bl word count          bl word count
 \        2dup type space  \        2dup type space
         dup c, here over chars allot swap move align ;      string, cfalign ;
   
 hex  hex
   
Line 86 
Line 106 
   
 included  included
   
   \ Create additional parameters                         19jan95py
   
   T
   cell               Constant tcell
   cell<<             Constant tcell<<
   cell>bit           Constant tcell>bit
   bits/byte          Constant tbits/byte
   float              Constant tfloat
   1 bits/byte lshift Constant maxbyte
   H
   
 >TARGET  >TARGET
   
 \ Byte ordering and cell size                          06oct92py  \ Byte ordering and cell size                          06oct92py
   
 : cell+         cell + ;  : cell+         tcell + ;
 : cells         cell<< lshift ;  : cells         tcell<< lshift ;
 : chars         ;  : chars         ;
 : floats        float * ;  : floats        tfloat * ;
   
 >CROSS  >CROSS
 : cell/         cell<< rshift ;  : cell/         tcell<< rshift ;
 >TARGET  >TARGET
 20 CONSTANT bl  20 CONSTANT bl
 -1 Constant NIL  -1 Constant NIL
Line 105 
Line 136 
 -4 Constant :dovar  -4 Constant :dovar
 -5 Constant :douser  -5 Constant :douser
 -6 Constant :dodefer  -6 Constant :dodefer
 -7 Constant :dodoes  -7 Constant :dofield
 -8 Constant :doesjump  -8 Constant :dodoes
   -9 Constant :doesjump
   
 >CROSS  >CROSS
   
 bigendian  0 pad ! -1 pad c! pad @ 0<  bigendian
 = [IF]   : bswap ; immediate  [IF]
 [ELSE]   : bswap ( big / little -- little / big )  0     : T!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
            cell 1- FOR  bits/byte lshift over       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
                         [ 1 bits/byte lshift 1- ] Literal and or     : T@  ( addr -- n )  >r 0 0 r> tcell bounds
                         swap bits/byte rshift swap  NEXT  nip ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
   [ELSE]
      : T!  ( n addr -- )  >r s>d r> tcell bounds
        DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
      : T@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
        DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
 \ Memory initialisation                                05dec92py  \ Memory initialisation                                05dec92py
Line 156 
Line 193 
   
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
     cell tuck 1- and - [ cell 1- ] Literal and ;      cell tuck 1- and - [ cell 1- ] Literal and ;
   : cfalign+  ( taddr -- rest )
       \ see kernal.fs:cfaligned
       float tuck 1- and - [ float 1- ] Literal and ;
   
 >TARGET  >TARGET
 : aligned ( taddr -- ta-addr )  dup align+ + ;  : aligned ( taddr -- ta-addr )  dup align+ + ;
 \ assumes cell alignment granularity (as GNU C)  \ assumes cell alignment granularity (as GNU C)
   
   : cfaligned ( taddr1 -- taddr2 )
       \ see kernal.fs
       dup cfalign+ + ;
   
 >CROSS  >CROSS
 : >image ( taddr -- absaddr )  image @ + ;  : >image ( taddr -- absaddr )  image @ + ;
 >TARGET  >TARGET
 : @  ( taddr -- w )     >image @ bswap ;  : @  ( taddr -- w )     >image t@ ;
 : !  ( w taddr -- )     >r bswap r> >image ! ;  : !  ( w taddr -- )     >image t! ;
 : c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image c@ ;
 : c! ( char taddr -- )  >image c! ;  : c! ( char taddr -- )  >image c! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
Line 179 
Line 223 
 : ,     ( w -- )        T here H cell T allot  ! H ;  : ,     ( w -- )        T here H cell T allot  ! H ;
 : c,    ( char -- )     T here    1 allot c! H ;  : c,    ( char -- )     T here    1 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 ( -- )
       T here H cfalign+ 0 ?DO  bl T c, H LOOP ;
   
 : A!                    dup relon T ! H ;  : A!                    dup relon T ! H ;
 : A,    ( w -- )        T here H relon T , H ;  : A,    ( w -- )        T here H relon T , H ;
Line 256 
Line 302 
   BEGIN @ dup    BEGIN @ dup
   WHILE 2dup cell+ @ =    WHILE 2dup cell+ @ =
   UNTIL    UNTIL
         nip 2 cells + count cr ." CROSS: Exists: " type 4 spaces          2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
         swap cell+ !          swap cell+ !
   ELSE true ABORT" CROSS: Ghostnames inconsistent"    ELSE  true abort" CROSS: Ghostnames inconsistent "
   THEN ;    THEN ;
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
Line 312 
Line 358 
   
 >TARGET  >TARGET
 : immediate     20 flag!  : immediate     20 flag!
                 ^imm @ @ dup <imm> = ?EXIT                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      40 flag! ;  : restrict      40 flag! ;
Line 322 
Line 368 
   
 : ALIAS2 create here 0 , DOES> @ execute ;  : ALIAS2 create here 0 , DOES> @ execute ;
 \ usage:  \ usage:
 \ ' alias2 bla !  \ ' <name> alias2 bla !
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
 : string,  ( addr count -- )  : string,  ( addr count -- )
   dup T c, H bounds  DO  I c@ T c, H  LOOP ;    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
 : name,  ( "name" -- )  bl word count string, T align H ;  : name,  ( "name" -- )  bl word count string, T cfalign H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
   
   \ Target Document Creation (goes to crossdoc.fd)       05jul95py
   
   s" crossdoc.fd" r/w create-file throw value doc-file-id
   \ contains the file-id of the documentation file
   
   : \G ( -- )
       source >in @ /string doc-file-id write-line throw
       source >in ! drop ; immediate
   
   Variable to-doc
   
   : cross-doc-entry  ( -- )
       to-doc @ tlast @ 0<> and    \ not an anonymous (i.e. noname) header
       IF
           s" " doc-file-id write-line throw
           s" make-doc " doc-file-id write-file throw
           tlast @ >image count $1F and doc-file-id write-file throw
           >in @
           [char] ( parse 2drop
           [char] ) parse doc-file-id write-file throw
           s"  )" doc-file-id write-file throw
           [char] \ parse 2drop
           POSTPONE \g
           >in !
       THEN  to-doc on ;
   
   \ Target TAGS creation
   
   s" TAGS" r/w create-file throw value tag-file-id
   \ contains the file-id of the tags file
   
   Create tag-beg 2 c,  7F c, bl c,
   Create tag-end 2 c,  bl c, 01 c,
   Create tag-bof 1 c,  0C c,
   
   2variable last-loadfilename 0 0 last-loadfilename 2!
   
   : put-load-file-name ( -- )
       loadfilename 2@ last-loadfilename 2@ d<>
       IF
           tag-bof count tag-file-id write-line throw
           sourcefilename 2dup
           tag-file-id write-file throw
           last-loadfilename 2!
           s" ,0" tag-file-id write-line throw
       THEN ;
   
   : cross-tag-entry  ( -- )
       tlast @ 0<> \ not an anonymous (i.e. noname) header
       IF
           put-load-file-name
           source >in @ min tag-file-id write-file throw
           tag-beg count tag-file-id write-file throw
           tlast @ >image count $1F and tag-file-id write-file throw
           tag-end count tag-file-id write-file throw
           base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
   \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
           s" ,0" tag-file-id write-line throw
           base !
       THEN ;
   
   \ Target header creation
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
   
 : (Theader ( "name" -- ghost ) T align H view,  : (Theader ( "name" -- ghost ) T align H view,
Line 345 
Line 454 
   dup >magic ^imm !     \ a pointer for immediate    dup >magic ^imm !     \ a pointer for immediate
   Already @ IF  dup >end tdoes !    Already @ IF  dup >end tdoes !
   ELSE 0 tdoes ! THEN    ELSE 0 tdoes ! THEN
   80 flag! ;    80 flag!
     cross-doc-entry cross-tag-entry ;
   
 VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot
   
Line 354 
Line 464 
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
     dup 0< IF  to-doc off  THEN
   (THeader over resolve T A, H 80 flag! ;    (THeader over resolve T A, H 80 flag! ;
 >CROSS  >CROSS
   
Line 388 
Line 499 
 ghost (next)                                    drop  ghost (next)                                    drop
 ghost unloop    ghost ;S                        2drop  ghost unloop    ghost ;S                        2drop
 ghost lit       ghost (compile) ghost !         2drop drop  ghost lit       ghost (compile) ghost !         2drop drop
 ghost (;code)   ghost noop                      2drop  ghost (does>)   ghost noop                      2drop
 ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
 ghost '  ghost '
   
Line 476 
Line 587 
   
 >TARGET  >TARGET
 Cond: DOES> restrict?  Cond: DOES> restrict?
         compile (;code) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN          compile (does>) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN
         ;Cond          ;Cond
 : DOES> dodoes, T here H !does depth T ] H ;  : DOES> dodoes, T here H !does depth T ] H ;
   
Line 547 
Line 658 
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    tup @ tudp @ + T  ! H
   tudp @ dup cell+ tudp ! ;    tudp @ dup T cell+ H tudp ! ;
 : au, ( n -- udp )  : au, ( n -- udp )
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup cell+ tudp ! ;    tudp @ dup T cell+ H tudp ! ;
 >TARGET  >TARGET
   
 Build: T 0 u, , H ;  Build: T 0 u, , H ;
Line 575 
Line 686 
 by Constant  by Constant
 Builder AConstant  Builder AConstant
   
   Build:  ( d -- ) T , , H ;
   DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   Builder 2Constant
   
 Build: T 0 , H ;  Build: T 0 , H ;
 by Constant  by Constant
 Builder Value  Builder Value
   
   Build: T 0 A, H ;
   by Constant
   Builder AValue
   
 Build:  ( -- ) compile noop ;  Build:  ( -- ) compile noop ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Defer  Builder Defer
 by Defer :dodefer resolve  by Defer :dodefer resolve
   
   \ Sturctures                                           23feb95py
   
   >CROSS
   : nalign ( addr1 n -- addr2 )
   \ addr2 is the aligned version of addr1 wrt the alignment size n
    1- tuck +  swap invert and ;
   >TARGET
   
   Build:  >r rot r@ nalign  dup T , H  ( align1 size offset )
           + swap r> nalign ;
   DO: T @ H + ;DO
   Builder Field
   by Field :dofield resolve
   
   : struct  T 0 1 chars H ;
   : end-struct  T 2Constant H ;
   
   : cells: ( n -- size align )
       T cells 1 cells H ;
   
   \ ' 2Constant Alias2 end-struct
   \ 0 1 T Chars H 2Constant struct
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 735 
Line 877 
   
 bigendian Constant bigendian  bigendian Constant bigendian
   
   Create magic  s" gforth00" here over allot swap move
   
   [char] 1 bigendian + cell + magic 7 + c!
   
 : save-cross ( "name" -- )  : save-cross ( "name" -- )
   bl parse ." Saving to " 2dup type    bl parse ." Saving to " 2dup type
   w/o bin create-file throw >r    w/o bin create-file throw >r
   s" gforth00"  r@ write-file throw \ write magic    magic 8       r@ write-file throw \ write magic
   image @ there r@ write-file throw \ write image    image @ there r@ write-file throw \ write image
   bit$  @ there 1- cell>bit rshift 1+    bit$  @ there 1- cell>bit rshift 1+
                 r@ write-file throw \ write tags                  r@ write-file throw \ write tags
Line 751 
Line 897 
 : * * ;         : / / ;  : * * ;         : / / ;
 : dup dup ;     : over over ;  : dup dup ;     : over over ;
 : swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
 : drop drop ;  : drop drop ;   : =   = ;
 : lshift lshift ; : 2/ 2/ ;  : lshift lshift ; : 2/ 2/ ;
   : . . ;
 cell constant cell  cell constant cell
   
 \ include bug5.fs  \ include bug5.fs
 \ only forth also minimal definitions  \ only forth also minimal definitions
   
 : \ postpone \ ;  : \ postpone \ ;
   : \G postpone \G ;
 : ( postpone ( ;  : ( postpone ( ;
 : include bl word count included ;  : include bl word count included ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;

Generate output suitable for use with a patch program
Legend:
Removed from v.1.16  
changed lines
  Added in v.1.32
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help