[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.77 and 1.78

version 1.77, Mon May 17 15:05:17 1999 UTC version 1.78, Tue May 18 14:38:49 1999 UTC
Line 53 
Line 53 
 only Forth also Target also also  only Forth also Target also also
 definitions Forth  definitions Forth
   
 : T  previous Cross also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
 : H  previous Forth also Cross ; immediate  : H  previous Forth also Cross ; immediate
   
 forth definitions  forth definitions
   
 : T  previous Cross also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
   
 : >cross  also Cross definitions previous ;  : >cross  also Cross definitions previous ;
Line 135 
Line 135 
     r> ;      r> ;
   
 : s>unumber? ( addr u -- ud flag )  : s>unumber? ( addr u -- ud flag )
       over [char] ' =
       IF  \ a ' alone is rather unusual :-)
           drop char+ c@ 0 true EXIT
       THEN
     base @ >r  dpl on  getbase      base @ >r  dpl on  getbase
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
Line 198 
Line 202 
 [THEN]  [THEN]
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
 Warnings off  \ Warnings off
   
 \ words that are generaly useful  \ words that are generaly useful
   
Line 585 
Line 589 
   
 : require bl word count required ;  : require bl word count required ;
   
   0 [IF]
   
 also forth definitions previous  also forth definitions previous
   
 : included ( adr len -- ) included ;  : included ( adr len -- ) included ;
Line 595 
Line 601 
   
 : require require ;  : require require ;
   
   [THEN]
   
 >CROSS  >CROSS
 hex  hex
   
Line 721 
Line 729 
         s" ?!?!?!"          s" ?!?!?!"
   THEN ;    THEN ;
   
   : .ghost ( ghost -- ) >ghostname type ;
   
 \ ' >ghostname ALIAS @name  \ ' >ghostname ALIAS @name
   
 : forward? ( ghost -- flag )  : forward? ( ghost -- flag )
Line 1219 
Line 1229 
   
 : 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 ;
 : c,    ( char -- )     T here    tchar allot c! H ;  : c,    ( char -- )     T here H tchar T allot c! H ;
 : align ( -- )          T here H align+ 0 ?DO  bl T c, tchar H +LOOP ;  : align ( -- )          T here H align+ 0 ?DO  bl T c, H tchar +LOOP ;
 : cfalign ( -- )  : cfalign ( -- )
     T here H cfalign+ 0 ?DO  bl T c, tchar H +LOOP ;      T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;
   
 : >address              dup 0>= IF tbyte / 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 ;
Line 1368 
Line 1378 
 Defer resolve-warning  Defer resolve-warning
   
 : reswarn-test ( ghost res-struct -- ghost res-struct )  : reswarn-test ( ghost res-struct -- ghost res-struct )
   over cr ." Resolving " >ghostname type dup ."  in " >ghost @ >ghostname type ;    over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;
   
 : reswarn-forward ( ghost res-struct -- ghost res-struct )  : reswarn-forward ( ghost res-struct -- ghost res-struct )
   over warnhead >ghostname type dup ."  is referenced in "    over warnhead .ghost dup ."  is referenced in "
   >ghost @ >ghostname type ;    >ghost @ .ghost ;
   
 \ ' reswarn-test IS resolve-warning  \ ' reswarn-test IS resolve-warning
   
Line 1465 
Line 1475 
         >link          >link
         BEGIN   @ dup          BEGIN   @ dup
         WHILE   cr 5 spaces          WHILE   cr 5 spaces
                 dup >ghost @ >ghostname type                  dup >ghost @ .ghost
                 ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN                  ."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
                 ."  line " dup >line @ .dec                  ."  line " dup >line @ .dec
         REPEAT          REPEAT
Line 1518 
Line 1528 
                 <do:> last-header-ghost @ >magic ! ;                  <do:> last-header-ghost @ >magic ! ;
 >CROSS  >CROSS
   
 \ ALIAS2 ansforth conform alias                          9may93jaw  
   
 : ALIAS2 create here 0 , DOES> @ execute ;  
 \ usage:  
 \ ' <name> alias2 bla !  
   
 \ Target Header Creation                               01nov92py  \ Target Header Creation                               01nov92py
   
 >TARGET  >TARGET
Line 1632 
Line 1636 
   
 \ Target header creation  \ Target header creation
   
 Variable CreateFlag  
 CreateFlag off  
   
 Variable NoHeaderFlag  Variable NoHeaderFlag
 NoHeaderFlag off  NoHeaderFlag off
   
Line 1660 
Line 1661 
     IF  NoHeaderFlag off      IF  NoHeaderFlag off
     ELSE      ELSE
         T align H view,          T align H view,
         tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !          tlast @ dup 0> IF tcell - 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
     T cfalign here H tlastcfa !      T cfalign here H tlastcfa !
     \ 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 @      ghost
     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  
         r> Warnings !  
         >in @ ghost swap >in !  
         swap also ghosts ' previous swap !     \ tick ghost and store in alias  
         CreateFlag off  
     ELSE ghost  
     THEN  
     dup Last-Header-Ghost !      dup Last-Header-Ghost !
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     Already @      Already @
Line 1777 
Line 1767 
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ;    T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;
   
 : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H  : (>body)   ( cfa -- pfa ) xt>body + ;          ' (>body) T IS >body H
   
Line 1833 
Line 1823 
     ELSE true ABORT" CROSS: Stack empty" THEN      ELSE true ABORT" CROSS: Stack empty" THEN
     ;      ;
   
 ( Cond ) : chars tchar * ; ( Cond )  
   
 >CROSS  >CROSS
   
 \ tLiteral                                             12dec92py  \ tLiteral                                             12dec92py
Line 1987 
Line 1975 
 \ do:-xt is executet when the created word from builder is executed  \ do:-xt is executet when the created word from builder is executed
 \ for do:-xt an additional entry after the normal ghost-enrys is used  \ for do:-xt an additional entry after the normal ghost-enrys is used
   
   >in @ alias2 swap dup >in ! >r >r    Make-Ghost            ( Create-xt do:-xt ghost )
   Make-Ghost    rot swap              ( do:-xt Create-xt ghost )
   rot swap >exec dup @ ['] NoExec <>    >exec ! , ;
   IF 2drop ELSE ! THEN  \  rot swap >exec dup @ ['] NoExec <>
   ,  \  IF 2drop ELSE ! THEN , ;
   r> r> >in !  
   also ghosts ' previous swap ! ;  
 \  DOES>  dup >exec @ execute ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2014 
Line 1999 
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   executed-ghost @    executed-ghost @
   CreateFlag on  
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   Theader >r dup gdoes,    Theader >r dup gdoes,
 \ stores execution semantic in the built word  \ stores execution semantic in the built word
   >end @ >exec @ r> >exec ! ;  \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @ >exec @ r> >exec dup @ ['] NoExec =
     IF ! ELSE 2drop THEN ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
   executed-ghost @    executed-ghost @
   CreateFlag on  
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
Line 2035 
Line 2021 
   there tlastcfa !    there tlastcfa !
   dup there resolve 0 ;Resolve !    dup there resolve 0 ;Resolve !
   >r dup gdoes,    >r dup gdoes,
   >end @ >exec @ r> >exec ! ;  \ stores execution semantic in the built word
   \ if the word already has a semantic (concerns S", IS, .", DOES>)
   \ then keep it
     >end @ >exec @ r> >exec dup @ ['] NoExec =
     IF ! ELSE 2drop THEN ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
Line 2127 
Line 2117 
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >CROSS  >CROSS
   
 Variable tup  0 tup !  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
   
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    tup @ tudp @ + T  ! H
   tudp @ dup T cell+ H 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 T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 >TARGET  >TARGET
   
 Build: T 0 u, , H ;  Build: 0 u, X , ;
 by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 Builder User  Builder User
   
 Build: T 0 u, , 0 u, drop H ;  Build: 0 u, X , 0 u, drop ;
 by User  by User
 Builder 2User  Builder 2User
   
 Build: T 0 au, , H ;  Build: 0 au, X , ;
 by User  by User
 Builder AUser  Builder AUser
   
Line 2161 
Line 2155 
 by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder Defer  Builder Defer
   
 BuildSmart:  ( inter comp -- ) swap T immediate A, A, H ;  Build: ( inter comp -- ) swap T immediate A, A, H ;
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder interpret/compile:  Builder interpret/compile:
   
Line 2189 
Line 2183 
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      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 2201 
Line 2192 
   
 : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw  : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )        T here ( dup ." >" hex. ) over branchoffset swap ! H ;  : >resolve    ( sys -- )
           X here ( dup ." >" hex. ) over branchoffset swap X ! ;
   
 : <resolve    ( sys -- )        T here ( dup ." <" hex. ) branchoffset , H ;  : <resolve    ( sys -- )
           X here ( dup ." <" hex. ) branchoffset X , ;
   
 :noname compile branch T here branchoffset , H ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch T here branchoffset , H ;  :noname compile ?branch X here branchoffset X , ;
   IS ?branch, ( target-addr -- )    IS ?branch, ( target-addr -- )
 :noname compile branch T here 0 , H ;  :noname compile branch T here 0 , H ;
   IS branchmark, ( -- branchtoken )    IS branchmark, ( -- branchtoken )
Line 2215 
Line 2208 
   IS ?branchmark, ( -- branchtoken )    IS ?branchmark, ( -- branchtoken )
 :noname T here 0 , H ;  :noname T here 0 , H ;
   IS ?domark, ( -- branchtoken )    IS ?domark, ( -- branchtoken )
 :noname dup T @ H ?struc T here over branchoffset swap ! H ;  :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )    IS branchtoresolve, ( branchtoken -- )
 :noname branchto, T here H ;  :noname branchto, X here ;
   IS branchtomark, ( -- target-addr )    IS branchtomark, ( -- target-addr )
   
 >TARGET  >TARGET
Line 2227 
Line 2220 
 Cond: BUT       restrict? sys? swap ;Cond  Cond: BUT       restrict? sys? swap ;Cond
 Cond: YET       restrict? sys? dup ;Cond  Cond: YET       restrict? sys? dup ;Cond
   
 0 [IF]  
 >CROSS  
 Variable tleavings  
 >TARGET  
   
 Cond: DONE   ( addr -- )  restrict? tleavings @  
       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT  
       tleavings ! drop ;Cond  
   
 >CROSS  >CROSS
 : (leave)  T here H tleavings @ T , H  tleavings ! ;  
 >TARGET  
   
 Cond: LEAVE     restrict? compile branch (leave) ;Cond  
 Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave)  ;Cond  
   
 [ELSE]  
     \ !! This is WIP  
     \ The problem is (?DO)!  
     \ perhaps we need a plug-in for (?DO)  
   
 >CROSS  
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( addr -- )
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
Line 2279 
Line 2253 
 Cond: LEAVE     restrict? branchmark, (leave) ;Cond  Cond: LEAVE     restrict? branchmark, (leave) ;Cond
 Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond  Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
   
 [THEN]  
   
 >CROSS  >CROSS
 \ !!JW ToDo : Move to general tools section  \ !!JW ToDo : Move to general tools section
   
Line 2659 
Line 2631 
 : G ghosts ; immediate  : G ghosts ; immediate
   
 : turnkey  : turnkey
    \GFORTH 0 set-order also Target     \GFORTH 0 set-order also ghosts
    \ANSI [ ' target >wordlist ] Literal 1 set-order     \ANSI [ ' ghosts >wordlist ] Literal 1 set-order
    definitions     also target definitions
    also Minimal also ;     also Minimal also ;
   
 \ these ones are pefered:  \ these ones are pefered:
Line 2671 
Line 2643 
   
 \ also minimal  \ also minimal
 : [[ also unlock ;  : [[ also unlock ;
 : ]] previous previous ;  : ]] previous previous also also ;
   
 unlock definitions also minimal  unlock definitions also minimal
 : lock   lock ;  : lock   lock ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help