[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.4 and 1.51

version 1.4, Wed May 18 17:29:50 1994 UTC version 1.51, Thu Jul 31 16:17:07 1997 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 by the ANSI figForth 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 21 
Line 37 
 \             targets                         09jun93jaw  \             targets                         09jun93jaw
 \       added: 2user and value                11jun93jaw  \       added: 2user and value                11jun93jaw
   
 include other.fs       \ ansforth extentions for cross  \       needed? works better now!!!             01mar97jaw
   \       mach file is only loaded into target
 decimal  \       cell corrected
   
 \ number?                                               11may93jaw  
   
 \ checks for +, -, $, & ...  
 : leading? ( c-addr u -- c-addr u doubleflag negflag base )  
         2dup 1- chars + c@ [char] . =   \ process double  
         IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN  
         \ only if more than only . ( may be number output! )  
         \ if only . => store garbage  
         ELSE false THEN >r      \ numbers  
         false -rot base @ -rot  
         BEGIN over c@  
                 dup [char] - =  
                         IF drop >r >r >r  
                            drop true r> r> r> 0 THEN  
                 dup [char] + =  
                         IF drop 0 THEN  
                 dup [char] $ =  
                         IF drop >r >r drop 16 r> r> 0 THEN  
                 dup [char] & =  
                         IF drop >r >r drop 10 r> r> 0 THEN  
               0= IF 1 chars - swap char+ swap false ELSE true THEN  
               over 0= or  
         UNTIL  
               rot >r rot r> r> -rot ;  
   
 : number? ( c-addr -- n/d flag )  
 \ return -1 if cell 1 if double 0 if garbage  
                 0 swap 0 swap           \ create double number  
                 count leading?  
                 base @ >r base !  
                 >r >r  
                 >number IF 2drop false r> r> 2drop  
                            r> base ! EXIT THEN  
                 drop r> r>  
                 IF IF dnegate 1  
                    ELSE drop negate -1 THEN  
                 ELSE IF 1 ELSE drop -1 THEN  
                 THEN r> base ! ;  
   
   \ 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 )
           2dup s" (" compare 0=
           IF    postpone (
           ELSE  2dup s" \" compare 0= IF postpone \ THEN
           THEN ;
   
   decimal
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
Line 75 
Line 65 
 0 GhostNames !  0 GhostNames !
 : GhostName ( -- addr )  : GhostName ( -- addr )
         here GhostNames @ , GhostNames ! here 0 ,          here GhostNames @ , GhostNames ! here 0 ,
         name count      bl word count
 \        2dup type space  \        2dup type space
         dup c, here over chars allot swap move align ;      string, cfalign ;
   
 hex  hex
   
Line 106 
Line 96 
   
 >CROSS  >CROSS
   
   \ 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
   
   \ Create additional parameters                         19jan95py
   
   T
   NIL                Constant TNIL
   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
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
 -1 Constant NIL  
 Variable image  Variable image
 Variable tlast    NIL tlast !  \ Last name field  Variable tlast    TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
 Variable tdoes    \ Resolve does> calls  Variable tdoes    \ Resolve does> calls
 Variable bit$  Variable bit$
 Variable tdp  Variable tdp
 : there  tdp @ ;  : there  tdp @ ;
   
 \ Parameter for target systems                         06oct92py  
   
 include machine.fs  
   
 >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         ;
   : char+         1 + ;
   : floats        tfloat * ;
   
 >CROSS  >CROSS
 : cell/         cell<< rshift ;  : cell/         tcell<< rshift ;
 >TARGET  >TARGET
 20 CONSTANT bl  20 CONSTANT bl
 -1 Constant NIL  TNIL Constant NIL
 -2 Constant :docol  
 -3 Constant :docon  
 -4 Constant :dovar  
 -5 Constant :douser  
 -6 Constant :dodoes  
 -7 Constant :doesjump  
   
 >CROSS  >CROSS
   
 endian  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
 \ Fixed bug in else part                               11may93jaw  \ Fixed bug in else part                               11may93jaw
   
 [IFDEF] Memory \ Memory is a bigFORTH feature  [IFDEF] Memory \ Memory is a bigFORTH feature
    Memory     also Memory
    : initmem ( var len -- )     : initmem ( var len -- )
      2dup swap handle! >r @ r> erase ;       2dup swap handle! >r @ r> erase ;
    Target     toss
 [ELSE]  [ELSE]
    : initmem ( var len -- )     : initmem ( var len -- )
      tuck allocate abort" CROSS: No memory for target"       tuck allocate abort" CROSS: No memory for target"
Line 169 
Line 184 
 \ MakeKernal                                           12dec92py  \ MakeKernal                                           12dec92py
   
 >MINIMAL  >MINIMAL
 : makekernal ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   bit$  over 1- cell>bit rshift 1+ initmem    bit$  over 1- tcell>bit rshift 1+ initmem
   image over initmem tdp off ;    image over initmem tdp off ;
   
 >CROSS  >CROSS
Line 188 
Line 203 
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
 : align+  ( taddr -- rest )  : 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 ;
   
 >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 kernel.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! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
   
 \ Target compilation primitives                        06oct92py  \ Target compilation primitives                        06oct92py
 \ included A!                                          16may93jaw  \ included A!                                          16may93jaw
   
 : here  ( -- there )    there ;  : here  ( -- there )    there ;
 : allot ( n -- )        tdp +! ;  : 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 ;  : 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 218 
Line 244 
   
 \ threading modell                                     13dec92py  \ threading modell                                     13dec92py
   
 \ generic threading modell  
 : docol,  ( -- ) :docol T A, 0 , H ;  
   
 >TARGET  >TARGET
 : >body   ( cfa -- pfa ) T cell+ cell+ H ;  : >body   ( cfa -- pfa ) T cell+ cell+ H ;
 >CROSS  >CROSS
   
 : dodoes, ( -- ) T :doesjump A, 0 , H ;  
   
 \ Ghost Builder                                        06oct92py  \ Ghost Builder                                        06oct92py
   
 \ <T T> new version with temp variable                 10may93jaw  \ <T T> new version with temp variable                 10may93jaw
Line 236 
Line 257 
 : <T  get-current VocTemp ! also Ghosts definitions ;  : <T  get-current VocTemp ! also Ghosts definitions ;
 : T>  previous VocTemp @ set-current ;  : T>  previous VocTemp @ set-current ;
   
   hex
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>  4713 Constant <imm>             4714 Constant <do:>
   
 \ iForth makes only immediate directly after create  \ iForth makes only immediate directly after create
 \ make atonce trick! ?  \ make atonce trick! ?
Line 248 
Line 270 
   
 : GhostHeader <fwd> , 0 , ['] NoExec , ;  : GhostHeader <fwd> , 0 , ['] NoExec , ;
   
 : >magic ; : >link cell+ ; : >exec cell+ cell+ ;  : >magic ;
   : >link cell+ ;
   : >exec cell+ cell+ ;
 : >end 3 cells + ;  : >end 3 cells + ;
   
   Variable last-ghost
 : Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
   >in @ GhostName swap >in !    >in @ GhostName swap >in !
   <T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
   here tuck swap ! ghostheader T>    here tuck swap ! ghostheader T>
   DOES>  >exec @ execute ;    DOES> dup last-ghost ! >exec @ execute ;
   
   variable cfalist 0 cfalist !
   
   : markcfa
     cfalist here over @ , swap ! , ;
   
 \ ghost words                                          14oct92py  \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
   
 : gfind   ( string -- ghost true/1 / string false )  : gfind   ( string -- ghost true/1 / string false )
 \ searches for string in word-list ghosts  \ searches for string in word-list ghosts
 \ !! wouldn't it be simpler to just use search-wordlist ? ae    dup count [ ' ghosts >body ] ALiteral search-wordlist
   >r get-order  0 set-order also ghosts  r> find >r >r    dup IF >r >body nip r>  THEN ;
   set-order  r> r@  IF  >body  THEN  r> ;  
   
 VARIABLE Already  VARIABLE Already
   
 : ghost   ( "name" -- ghost )  : ghost   ( "name" -- ghost )
   Already off    Already off
   >in @  name gfind   IF  Already on nip EXIT  THEN    >in @  bl word gfind   IF  Already on nip EXIT  THEN
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
   
 \ resolve                                              14oct92py  \ resolve                                              14oct92py
Line 286 
Line 315 
   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 325 
Line 354 
   Ghostnames    Ghostnames
   BEGIN @ dup    BEGIN @ dup
   WHILE dup ?resolved    WHILE dup ?resolved
   REPEAT drop ResolveFlag @ 0= IF ." Nothing!" THEN cr ;    REPEAT drop ResolveFlag @
     IF
         -1 abort" Unresolved words!"
     ELSE
         ." Nothing!"
     THEN
     cr ;
   
 >CROSS  >CROSS
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
Line 335 
Line 370 
 VARIABLE ^imm  VARIABLE ^imm
   
 >TARGET  >TARGET
 : immediate     20 flag!  : immediate     40 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      ;  : restrict      20 flag! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
   
 : 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" -- )  name 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" doc/crossdoc.fd" r/w create-file throw value doc-file-id
   \ contains the file-id of the documentation file
   
   : T-\G ( -- )
       source >in @ /string doc-file-id write-line throw
       postpone \ ;
   
   Variable to-doc  to-doc on
   
   : 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
           T-\G
           >in !
       THEN ;
   
   \ Target TAGS creation
   
   s" kernel.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 ;
   
   \ Check for words
   
   Defer skip? ' false IS skip?
   
   : defined? ( -- flag ) \ name
       ghost >magic @ <fwd> <> ;
   
   : needed? ( -- flag ) \ name
   \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 @ <fwd> =
           \ swap >link @ 0<> and
           nip
           0=
       ELSE  drop true  THEN ;
   
   : doer? ( -- flag ) \ name
       ghost >magic @ <do:> = ;
   
   : skip-defs ( -- )
       BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
   
   \ Target header creation
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
   
 : (Theader ( "name" -- ghost ) T align H view,  : (Theader ( "name" -- ghost )
   \  >in @ bl word count type 2 spaces >in !
     T align H view,
   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !    tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
   >in @ name, >in ! T here H tlastcfa !    >in @ name, >in ! T here H tlastcfa !
   CreateFlag @ IF    CreateFlag @ IF
Line 369 
Line 494 
   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
   
 : Theader  ( "name" -- )     (THeader there resolve 0 ;Resolve ! ;  : Theader  ( "name" -- ghost )
     (THeader dup there resolve 0 ;Resolve ! ;
   
 >TARGET  >TARGET
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
       >in @ skip? IF  2drop  EXIT  THEN  >in !
       dup 0< has-prims 0= and
       IF
           ." needs prim: " >in @ bl word count type >in ! cr
       THEN
   (THeader over resolve T A, H 80 flag! ;    (THeader over resolve T A, H 80 flag! ;
   : Alias:   ( cfa -- ) \ name
       >in @ skip? IF  2drop  EXIT  THEN  >in !
       dup 0< has-prims 0= and
       IF
           ." needs doer: " >in @ bl word count type >in ! cr
       THEN
       ghost tuck swap resolve <do:> swap >magic ! ;
 >CROSS  >CROSS
   
 \ Conditionals and Comments                            11may93jaw  \ Conditionals and Comments                            11may93jaw
Line 411 
Line 550 
 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 '                                         drop
   ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
   ghost over      ghost =         ghost drop      2drop drop
   
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( -- ) \ name  : compile  ( -- ) \ name
   restrict?    restrict?
   name gfind dup 0= ABORT" CROSS: Can't compile "    bl word gfind dup 0= ABORT" CROSS: Can't compile "
   0> ( immediate? )    0> ( immediate? )
   IF    >exec @ compile,    IF    >exec @ compile,
   ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
                                         immediate                                          immediate
   
   \ generic threading modell
   : docol,  ( -- ) compile :docol 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  >TARGET
 : '  ( -- cfa ) name gfind 0= ABORT" CROSS: undefined "  : 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 ca>native resolve  <do:> swap >magic !
       depth (code) ;
   
   : end-code
       depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
       ELSE true ABORT" CROSS: Stack empty" THEN
       (end-code) ;
   
   : '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
   dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;    dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
   
 Cond: [']  compile lit ghost gexecute ;Cond  Cond: [']  compile lit ghost gexecute ;Cond
   
   Cond: chars ;Cond
   
 >CROSS  >CROSS
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
   
Line 437 
Line 611 
 : alit, ( n -- )  compile lit T A,  H ;  : alit, ( n -- )  compile lit T A,  H ;
   
 >TARGET  >TARGET
   Cond: \G  T-\G ;Cond
   
 Cond:  Literal ( n -- )   restrict? lit, ;Cond  Cond:  Literal ( n -- )   restrict? lit, ;Cond
 Cond: ALiteral ( n -- )   restrict? alit, ;Cond  Cond: ALiteral ( n -- )   restrict? alit, ;Cond
   
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
   
   \ some special literals                                 27jan97jaw
   
   Cond: MAXU
    restrict? compile lit
    tcell 0 ?DO FF T c, H LOOP ;Cond
   
   Cond: MINI
    restrict? compile lit
    bigendian IF
    80 T c, H tcell 1 ?DO 0 T c, H LOOP
    ELSE
    tcell 1 ?DO 0 T c, H LOOP 80 T c, H
    THEN
    ;Cond
   
   Cond: MAXI
    restrict? compile lit
    bigendian IF
    7F T c, H tcell 1 ?DO FF T c, H LOOP
    ELSE
    tcell 1 ?DO FF T c, H LOOP 7F T c, H
    THEN
    ;Cond
   
 >CROSS  >CROSS
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
Line 462 
Line 662 
   
 : ] state on  : ] state on
     BEGIN      BEGIN
         BEGIN >in @ name          BEGIN >in @ bl word
               dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE 2drop refill 0=
               ABORT" CROSS: End of file while target compiling"                ABORT" CROSS: End of file while target compiling"
         REPEAT          REPEAT
Line 475 
Line 675 
 \             is not allowed if a system should be ans conform  \             is not allowed if a system should be ans conform
   
 : : ( -- colon-sys ) \ Name  : : ( -- colon-sys ) \ Name
     >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
   docol, depth T ] H ;    docol, depth T ] H ;
   
   : :noname ( -- colon-sys )
     T cfalign H there docol, depth T ] H ;
   
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
   
   Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
   
 Cond: ; ( -- ) restrict?  Cond: ; ( -- ) restrict?
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"                 depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                           ELSE true ABORT" CROSS: Stack empty" THEN                            ELSE true ABORT" CROSS: Stack empty" THEN
Line 490 
Line 696 
 Cond: [  restrict? state off ;Cond  Cond: [  restrict? state off ;Cond
   
 >CROSS  >CROSS
 : !does  :dodoes tlastcfa @ tuck T ! cell+ ! H ;  : !does
       tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
   
 >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 507 
Line 714 
   >in @ alias2 swap dup >in ! >r >r    >in @ alias2 swap dup >in ! >r >r
   Make-Ghost rot swap >exec ! ,    Make-Ghost rot swap >exec ! ,
   r> r> >in !    r> r> >in !
   also ghosts ' previous swap !    also ghosts ' previous swap ! ;
   DOES> dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;
   
 : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>  : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
   IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN      IF
   :dodoes T A, H gexecute T here H cell - reloff ;          dup >magic @ <do:> =
           IF  gexecute T 0 , H  EXIT THEN
       THEN
       compile :dodoes gexecute T here H tcell - reloff ;
   
 : TCreate ( ghost -- )  : TCreate ( -- )
     last-ghost @
   CreateFlag on    CreateFlag on
   Theader dup gdoes,    Theader >r dup gdoes,
   >end @ >exec @ execute ;    >end @ >exec @ r> >exec ! ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname  postpone TCreate ;    :noname  postpone TCreate ;
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
     last-ghost @
   state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
   cell+ @ T >body H false ;    cell+ @ T >body H false ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : (does>)        postpone does> ; immediate \ second level does>  
   
 : DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- addr [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname    :noname postpone gdoes> postpone ?EXIT ;
   postpone (does>) postpone gdoes> postpone ?EXIT ;  
   : by:     ( -- addr [xt] [colon-sys] ) \ name
     ghost
     :noname postpone gdoes> postpone ?EXIT ;
   
 : ;DO ( addr [xt] [colon-sys] -- )  : ;DO ( addr [xt] [colon-sys] -- )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
Line 547 
Line 760 
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ;  Build:  ;
 DO: ( ghost -- addr ) ;DO  by: :dovar ( ghost -- addr ) ;DO
 Builder Create  Builder Create
 by Create :dovar resolve  
   
 Build: T 0 , H ;  Build: T 0 , H ;
 by Create  by Create
Line 566 
Line 778 
 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 ;
 DO: ( ghost -- up-addr )  T @ H tup @ + ;DO  by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO
 Builder User  Builder User
 by User :douser resolve  
   
 Build: T 0 u, , 0 u, drop H ;  Build: T 0 u, , 0 u, drop H ;
 by User  by User
Line 585 
Line 796 
 by User  by User
 Builder AUser  Builder AUser
   
   Build:  ( n -- ) ;
   by: :docon ( ghost -- n ) T @ H ;DO
   Builder (Constant)
   
 Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
 DO: ( ghost -- n ) T @ H ;DO  by (Constant)
 Builder Constant  Builder Constant
 by Constant :docon resolve  
   
 Build:  ( n -- ) T A, H ;  Build:  ( n -- ) T A, H ;
 by Constant  by (Constant)
 Builder AConstant  Builder AConstant
   
 Build: T 0 , H ;  Build:  ( d -- ) T , , H ;
 by Constant  DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
   Builder 2Constant
   
   Build: T , H ;
   by (Constant)
 Builder Value  Builder Value
   
   Build: T A, H ;
   by (Constant)
   Builder AValue
   
 Build:  ( -- ) compile noop ;  Build:  ( -- ) compile noop ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Defer  Builder Defer
   
   Build:  ( inter comp -- ) swap T immediate A, A, H ;
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   Builder interpret/compile:
   
   \ 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: ;
   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 1 chars 0 H ;
   : end-struct  T 2Constant H ;
   
   : cell% ( -- align size )
       T 1 cells H dup ;
   
   \ ' 2Constant Alias2 end-struct
   \ 0 1 T Chars H 2Constant struct
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
 >CROSS  >CROSS
Line 645 
Line 898 
 Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond  Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond
 Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond  Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
   
   Cond: CASE      restrict? 0 ;Cond
   Cond: OF        restrict? 1+ >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  \ Structural Conditionals                              12dec92py
   
 Cond: DO        restrict? compile (do)   T here H ;Cond  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  Cond: FOR       restrict? compile (for)  T here H ;Cond
   
 >CROSS  >CROSS
 : loop]   dup <resolve cell - compile DONE compile unloop ;  : loop]   dup <resolve tcell - compile DONE compile unloop ;
 >TARGET  >TARGET
   
 Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond  Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
Line 669 
Line 928 
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T ' >body ! H ;  : IS            T ' >body ! H ;
   Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
   : TO            T ' >body ! H ;
   
 \ LINKED ERR" ENV" 2ENV"                                18may93jaw  \ LINKED ERR" ENV" 2ENV"                                18may93jaw
   
Line 688 
Line 949 
 \ compile must be last                                 22feb93py  \ compile must be last                                 22feb93py
   
 Cond: compile ( -- ) restrict? \ name  Cond: compile ( -- ) restrict? \ name
       name gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
                ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) gexecute THEN THEN ;Cond
   
 Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
       name gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
       0> IF    gexecute        0> IF    gexecute
          ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
                IF   gexecute                 IF   gexecute
Line 709 
Line 970 
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : defined? defined? ;
   : needed? needed? ;
   : doer? doer? ;
   
 : [IFDEF] there? postpone [IF] ;  : [IFDEF] defined? postpone [IF] ;
 : [IFUNDEF] there? 0= postpone [IF] ;  : [IFUNDEF] defined? 0= postpone [IF] ;
   
 \ C: \- \+ Conditional Compiling                         09jun93jaw  \ C: \- \+ Conditional Compiling                         09jun93jaw
   
 : C: >in @ there? 0=  : C: >in @ defined? 0=
      IF    >in ! T : H       IF    >in ! T : H
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
Line 728 
Line 991 
   
 also minimal  also minimal
   
 : \- there? IF postpone \ THEN ;  \G interprets the line if word is not defined
 : \+ there? 0= IF postpone \ THEN ;  : \- 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] ;  : [IF]   postpone [IF] ;
 : [THEN] postpone [THEN] ;  : [THEN] postpone [THEN] ;
Line 741 
Line 1016 
 Cond: [THEN]    [THEN] ;Cond  Cond: [THEN]    [THEN] ;Cond
 Cond: [ELSE]    [ELSE] ;Cond  Cond: [ELSE]    [ELSE] ;Cond
   
   previous
   
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
   
 \ i'm not interested in bigforth features this time    10may93jaw  >CROSS
 \ [IFDEF] file  Create magic  s" Gforth10" here over allot swap move
 \ also file  
 \ [THEN]  
 \ included throw after create-file                     11may93jaw  
   
 endian Constant endian  char 1 bigendian + tcell + magic 7 + c!
   
 : save-cross ( "name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type    bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r    w/o bin create-file throw >r
   image @ there r@ write-file throw    TNIL IF
   bit$  @ there 1- cell>bit rshift 1+ r@ write-file throw        s" #! "   r@ write-file throw
         bl parse  r@ write-file throw
         s"  -i"   r@ write-file throw
         #lf       r@ emit-file throw
         r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
         ?do
             bl over emit-file throw
         loop
         drop
         magic 8       r@ write-file throw \ write magic
     ELSE
         bl parse 2drop
     THEN
     image @ there r@ write-file throw \ write image
     TNIL IF
         bit$  @ there 1- tcell>bit rshift 1+
                   r@ write-file throw \ write tags
     THEN
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
   >MINIMAL
   also minimal
   
 : + + ;         : 1- 1- ;  bigendian Constant bigendian
 : - - ;         : 2* 2* ;  : save-cross save-cross ;
 : dup dup ;     : over over ;  : here there ;
 : swap swap ;   : rot rot ;  also forth
   [IFDEF] Label : Label Label ; [THEN]
 \ include bug5.fs  [IFDEF] start-macros : start-macros start-macros ; [THEN]
 \ only forth also minimal definitions  previous
   
 : \ postpone \ ;  : + + ;
 : ( postpone ( ;  : or or ;
   : 1- 1- ;
   : - - ;
   : 2* 2* ;
   : * * ;
   : / / ;
   : dup dup ;
   : over over ;
   : swap swap ;
   : rot rot ;
   : drop drop ;
   : =   = ;
   : 0=   0= ;
   : lshift lshift ;
   : 2/ 2/ ;
   : . . ;
   : const ;
   
   \ 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 ;  : include bl word count included ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;
 : cr cr ;  : cr cr ;
Line 783 
Line 1102 
 : hex           hex ;  : hex           hex ;
   
 : tudp          T tudp H ;  : tudp          T tudp H ;
 : tup           T tup H ;  minimal  : tup           T tup H ;
   
   : doc-off       false T to-doc H ! ;
   : doc-on        true  T to-doc H ! ;
   
   minimal
   
 \ for debugging...  \ for debugging...
 : order         order ;  : order         order ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help