[BACK]Return to cross.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.3 and 1.6

version 1.3, 1994/05/05 15:46:38 version 1.6, 1994/06/17 12:34:58
Line 23 Line 23
   
 include other.fs       \ ansforth extentions for cross  include other.fs       \ ansforth extentions for cross
   
   : comment? ( c-addr u -- c-addr u )
           2dup s" (" compare 0=
           IF    postpone (
           ELSE  2dup s" \" compare 0= IF postpone \ THEN
           THEN ;
   
 decimal  decimal
   
 \ number?                                               11may93jaw  \ number?                                               11may93jaw
Line 128  include machine.fs Line 134  include machine.fs
 : cell+         cell + ;  : cell+         cell + ;
 : cells         cell<< lshift ;  : cells         cell<< lshift ;
 : chars         ;  : chars         ;
   : floats        float * ;
       
 >CROSS  >CROSS
 : cell/         cell<< rshift ;  : cell/         cell<< rshift ;
 >TARGET  >TARGET
Line 155  endian  0 pad ! -1 pad c! pad @ 0< Line 162  endian  0 pad ! -1 pad c! pad @ 0<
 \ 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 181  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 188  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   
 : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;  : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
   : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 : relon ( taddr -- )  bit$ @ swap cell/ +bit ;  : relon ( taddr -- )  bit$ @ swap cell/ +bit ;
   : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
Line 261  Variable atonce atonce off Line 270  Variable atonce atonce off
 : 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  \ !! wouldn't it be simpler to just use search-wordlist ? ae
   >r get-order  0 set-order also ghosts  r> find >r >r    dup count [ ' ghosts >body ] ALiteral search-wordlist
   set-order  r> r@  IF  >body  THEN  r> ;  \ >r get-order  0 set-order also ghosts  r> find >r >r
     >r r@ IF  >body nip  THEN  r> ;
   \ set-order  r> r@  IF  >body  THEN  r> ;
   
 VARIABLE Already  VARIABLE Already
   
Line 478  Cond: [Char]   ( "<char>" -- )  restrict Line 489  Cond: [Char]   ( "<char>" -- )  restrict
   
 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 510  Cond: DOES> restrict? Line 523  Cond: DOES> restrict?
   
 : 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 dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
   :dodoes T A, H gexecute ;    :dodoes T A, H gexecute T here H cell - reloff ;
   
 : TCreate ( ghost -- )  : TCreate ( ghost -- )
   CreateFlag on    CreateFlag on
Removed from v.1.3  
changed lines
  Added in v.1.6

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