[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.125 and 1.130

version 1.125, Thu Mar 21 17:20:38 2002 UTC version 1.130, Sat Dec 14 17:34:12 2002 UTC
Line 30 
Line 30 
   
 [THEN]  [THEN]
   
   s" compat/strcomp.fs" included
   
 hex  hex
   
 \ debugging for compiling  \ debugging for compiling
Line 259 
Line 261 
   
 \ FIXME move down  \ FIXME move down
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" str=
         IF    postpone (          IF    postpone (
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" str= IF postpone \ THEN
         THEN ;          THEN ;
   
 : X ( -- <name> )  : X ( -- <name> )
Line 474 
Line 476 
     2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....      2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
     over c@ [char] / = >r      over c@ [char] / = >r
     over c@ [char] ~ = >r      over c@ [char] ~ = >r
     \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic      \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
     2 min S" ./" compare 0=      S" ./" string-prefix?
     r> r> r> or or or ;      r> r> r> or or or ;
   
 Create ofile 0 c, 255 chars allot  Create ofile 0 c, 255 chars allot
Line 491 
Line 493 
   REPEAT ;    REPEAT ;
   
 : remove~+ ( -- )  : remove~+ ( -- )
     ofile count 3 min s" ~+/" compare 0=      ofile count s" ~+/" string-prefix?
     IF      IF
         ofile count 3 /string ofile place          ofile count 3 /string ofile place
     THEN ;      THEN ;
   
 : expandtopic ( -- ) \ stack effect correct? - anton  : expandtopic ( -- ) \ stack effect correct? - anton
     \ expands "./" into an absolute name      \ expands "./" into an absolute name
     ofile count 2 min s" ./" compare 0=      ofile count s" ./" string-prefix?
     IF      IF
         ofile count 1 /string tfile place          ofile count 1 /string tfile place
         0 ofile c! sourcefilename extractpath ofile place          0 ofile c! sourcefilename extractpath ofile place
Line 511 
Line 513 
     \ deletes phrases like "xy/.." out of our directory name 2dec97jaw      \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
     over swap      over swap
     BEGIN  dup  WHILE      BEGIN  dup  WHILE
         dup >r '/ scan 2dup 4 min s" /../" compare 0=          dup >r '/ scan 2dup s" /../" string-prefix?
         IF          IF
             dup r> - >r 4 /string over r> + 4 -              dup r> - >r 4 /string over r> + 4 -
             swap 2dup + >r move dup r> over -              swap 2dup + >r move dup r> over -
Line 574 
Line 576 
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f )
   file-list    file-list
   BEGIN @ dup    BEGIN @ dup
   WHILE >r 2dup r@ >fl-name count compare 0=    WHILE >r 2dup r@ >fl-name count str=
         IF rdrop 2drop true EXIT THEN          IF rdrop 2drop true EXIT THEN
         r>          r>
   REPEAT    REPEAT
Line 1172 
Line 1174 
 false DefaultValue backtrace  false DefaultValue backtrace
 false DefaultValue new-input  false DefaultValue new-input
 false DefaultValue peephole  false DefaultValue peephole
   false DefaultValue abranch
   true  DefaultValue control-rack
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1700 
Line 1704 
 Ghost (next)                                    drop  Ghost (next)                                    drop
 Ghost (does>)   Ghost (compile)                 2drop  Ghost (does>)   Ghost (compile)                 2drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")                                      drop  Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop  Ghost '                                         drop
   
 \ user ghosts  \ user ghosts
Line 1730 
Line 1734 
 : ht-string,  ( addr count -- )  : ht-string,  ( addr count -- )
   dup there swap last-string 2!    dup there swap last-string 2!
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
   : ht-mem, ( addr count )
       bounds ?DO  I c@  T c, H  LOOP ;
   
 >TARGET  >TARGET
   
Line 2925 
Line 2931 
   
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )  
         X here ( dup ." >" hex. ) over branchoffset swap X ! ;  
   
 : <resolve    ( sys -- )  
         X here ( dup ." <" hex. ) branchoffset X , ;  
   
 :noname compile branch X here branchoffset X , ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch X here branchoffset X , ;  :noname compile ?branch X here branchoffset X , ;
Line 2957 
Line 2957 
   
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( do-addr -- )
   \G resolve branches of leave and ?leave and ?do
   \G do-addr is the address of the beginning of our
   \G loop so we can take care of nested loops
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
     WHILE      WHILE
Line 3007 
Line 3010 
     0 DO  dup @ swap 1 cells -  LOOP      0 DO  dup @ swap 1 cells -  LOOP
     free throw ;      free throw ;
   
 : loop]     branchto, dup <resolve tcell - (done) ;  : loop] ( target-addr -- )
     branchto,
     dup   X here branchoffset X ,
     tcell - (done) ;
   
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
Line 3111 
Line 3117 
 Cond: +LOOP     1 ncontrols? +loop, ;Cond  Cond: +LOOP     1 ncontrols? +loop, ;Cond
 Cond: NEXT      1 ncontrols? next, ;Cond  Cond: NEXT      1 ncontrols? next, ;Cond
   
   \ Absoulte branches                                     26sep02jaw
   
   \ This section defined different semantics for
   \ conditionals, using and compiling absolute branches
   
   X has? abranch [IF]
   
   Ghost abranch drop
   Ghost a?branch drop
   Ghost a(?do) drop
   Ghost a(do) drop
   Ghost a(next) drop
   Ghost a(+loop) drop
   Ghost a(loop) drop
   
   :noname compile abranch X a, ;             plugin-of branch,
   
   :noname compile a?branch X a, ;            plugin-of ?branch,
   
   :noname compile abranch T here 0  a, H ;   plugin-of branchmark,
   
   :noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,
   
   :noname
     dup X @ ABORT" CROSS: branch already resolved"
     X here swap X a! ;                       plugin-of branchtoresolve,
   
   :noname
     0 compile a(?do) ?domark, (leave)
     branchtomark, 2 to1 ;                    plugin-of ?do,
   
   : aloop] ( target-addr -- )
     branchto,
     dup X a,
     tcell - (done) ;
   
   :noname
     1to compile a(loop) aloop]
     compile unloop skiploop] ;               plugin-of loop,
   
   :noname
     1to compile a(+loop) aloop]
     compile unloop skiploop] ;               plugin-of +loop,
   
   :noname
     compile a(next) aloop] compile unloop ;   plugin-of next,
   
   [THEN]
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse ht-string, X align ;  : ,"            [char] " parse ht-string, X align ;
   
   X has? control-rack [IF]
 Cond: ."        compile (.")     T ," H ;Cond  Cond: ."        compile (.")     T ," H ;Cond
 Cond: S"        compile (S")     T ," H ;Cond  Cond: S"        compile (S")     T ," H ;Cond
 Cond: C"        compile (C")     T ," H ;Cond  Cond: C"        compile (C")     T ," H ;Cond
 Cond: ABORT"    compile (ABORT") T ," H ;Cond  Cond: ABORT"    compile (ABORT") T ," H ;Cond
   [ELSE]
   Cond: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >r then, r> compile ALiteral compile Literal compile type ;Cond
   Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >r then, r> compile ALiteral compile Literal ;Cond
   Cond: C"        ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral ;Cond
   Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral compile c(abort") then, ;Cond
   [THEN]
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;  : IS            T >address ' >body ! H ;
Line 3352 
Line 3418 
   dup @ dup IF addr-refs @ THEN    dup @ dup IF addr-refs @ THEN
   swap >r    swap >r
   over align+ tuck tcell swap - rshift swap 0    over align+ tuck tcell swap - rshift swap 0
   DO dup 1 and    ?DO dup 1 and
      IF drop rdrop snl-calc UNLOOP EXIT THEN       IF drop rdrop snl-calc UNLOOP EXIT THEN
      2/ swap 1+ swap       2/ swap 1+ swap
   LOOP    LOOP
Line 3439 
Line 3505 
     1 BEGIN      1 BEGIN
         BEGIN bl word count dup WHILE          BEGIN bl word count dup WHILE
             comment? 20 umin parsed place upcase parsed count              comment? 20 umin parsed place upcase parsed count
             2dup s" [IF]" compare 0= >r              2dup s" [IF]" str= >r
             2dup s" [IFUNDEF]" compare 0= >r              2dup s" [IFUNDEF]" str= >r
             2dup s" [IFDEF]" compare 0= r> or r> or              2dup s" [IFDEF]" str= r> or r> or
             IF   2drop 1+              IF   2drop 1+
             ELSE 2dup s" [ELSE]" compare 0=              ELSE 2dup s" [ELSE]" str=
                 IF   2drop 1- dup                  IF   2drop 1- dup
                     IF 1+                      IF 1+
                     THEN                      THEN
                 ELSE                  ELSE
                     2dup s" [ENDIF]" compare 0= >r                      2dup s" [ENDIF]" str= >r
                     s" [THEN]" compare 0= r> or                      s" [THEN]" str= r> or
                     IF 1- THEN                      IF 1- THEN
                 THEN                  THEN
             THEN              THEN
Line 3497 
Line 3563 
      IF    >in ! X :       IF    >in ! X :
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
               IF   count comment? s" ;" compare 0= ?EXIT                IF   count comment? s" ;" str= ?EXIT
               ELSE refill 0= ABORT" CROSS: Out of Input while C:"                ELSE refill 0= ABORT" CROSS: Out of Input while C:"
               THEN                THEN
         AGAIN          AGAIN
Line 3631 
Line 3697 
 : doc-on        true  to-doc ! ;  : doc-on        true  to-doc ! ;
   
 : declareunique ( "name" -- )  : declareunique ( "name" -- )
 \G Sets the unique flag for a ghost. The assembler output  \ Sets the unique flag for a ghost. The assembler output
 \G generates labels with the ghostname concatenated with the address  \ generates labels with the ghostname concatenated with the address
 \G while cross-compiling. The address is concatenated  \ while cross-compiling. The address is concatenated
 \G because we have double occurences of the same name.  \ because we have double occurences of the same name.
 \G If we want to reference the labels from the assembler or C  \ If we want to reference the labels from the assembler or C
 \G code we declare them unique, so the address is skipped.  \ code we declare them unique, so the address is skipped.
   Ghost >ghost-flags dup @ <unique> or swap ! ;    Ghost >ghost-flags dup @ <unique> or swap ! ;
   
 \ [IFDEF] dbg : dbg dbg ; [THEN]  \ [IFDEF] dbg : dbg dbg ; [THEN]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help