Diff for /gforth/cross.fs between versions 1.12 and 1.18

version 1.12, 1994/09/09 16:27:17 version 1.18, 1994/12/15 12:35:12
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ $Id$  \ $Id$
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992-94 by the GNU Forth Development Group
   
 \ Log:  \ Log:
 \       changed in ; [ to state off           12may93jaw  \       changed in ; [ to state off           12may93jaw
Line 40  VARIABLE GhostNames Line 40  VARIABLE GhostNames
 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 ;          dup c, here over chars allot swap move align ;
   
Line 84  Variable tdp Line 84  Variable tdp
   
 \ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py
   
 include-file  included
   
 >TARGET  >TARGET
   
Line 234  Variable last-ghost Line 234  Variable last-ghost
 \ 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  \ !! wouldn't it be simpler to just use search-wordlist ? ae
   dup count [ ' ghosts >body ] ALiteral search-wordlist    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 ;
   >r r@ IF  >body nip  THEN  r> ;  
 \ 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 258  VARIABLE Already Line 256  VARIABLE Already
   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 ;
Line 314  VARIABLE ^imm Line 312  VARIABLE ^imm
   
 >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 324  VARIABLE ^imm Line 322  VARIABLE ^imm
   
 : 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 align H ;
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
   
 VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
Line 339  VARIABLE CreateFlag CreateFlag off Line 337  VARIABLE CreateFlag CreateFlag off
   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
   >in @ alias2 swap >in !         \ create alias in target         >in @ alias2 swap >in !         \ create alias in target
   >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
   ELSE ghost THEN    ELSE ghost THEN
   dup >magic ^imm !     \ a pointer for immediate    dup >magic ^imm !     \ a pointer for immediate
   Already @ IF  dup >end tdoes !    Already @ IF  dup >end tdoes !
Line 398  ghost ' Line 396  ghost '
   
 : 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
   
 >TARGET  >TARGET
 : '  ( -- cfa ) name gfind 0= ABORT" CROSS: undefined "  : '  ( -- 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 442  Cond: [Char]   ( "<char>" -- )  restrict Line 442  Cond: [Char]   ( "<char>" -- )  restrict
   
 : ] 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 672  Cond: TO        T ' >body H compile ALit Line 672  Cond: TO        T ' >body H compile ALit
 \ 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 693  also minimal Line 693  also minimal
   
 \ define new [IFDEF] and [IFUNDEF]                      20may93jaw  \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
   
 : there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
   
 : [IFDEF] there? postpone [IF] ;  : [IFDEF] there? postpone [IF] ;
 : [IFUNDEF] there? 0= postpone [IF] ;  : [IFUNDEF] there? 0= postpone [IF] ;
Line 738  bigendian Constant bigendian Line 738  bigendian Constant bigendian
 : 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
   image @ there r@ write-file throw    s" gforth00"  r@ write-file throw \ write magic
   bit$  @ there 1- cell>bit rshift 1+ r@ write-file throw    image @ there r@ write-file throw \ write image
     bit$  @ there 1- cell>bit rshift 1+
                   r@ write-file throw \ write tags
   r> close-file throw ;    r> close-file throw ;
   
 \ words that should be in minimal  \ words that should be in minimal
Line 749  bigendian Constant bigendian Line 751  bigendian Constant bigendian
 : * * ;         : / / ;  : * * ;         : / / ;
 : dup dup ;     : over over ;  : dup dup ;     : over over ;
 : swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
   : drop drop ;
   : lshift lshift ; : 2/ 2/ ;
   cell constant cell
   
 \ include bug5.fs  \ include bug5.fs
 \ only forth also minimal definitions  \ only forth also minimal definitions

Removed from v.1.12  
changed lines
  Added in v.1.18


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