Diff for /gforth/prims2x.fs between versions 1.92 and 1.96

version 1.92, 2001/03/18 11:35:35 version 1.96, 2001/05/13 10:54:10
Line 53 Line 53
   
 warnings off  warnings off
   
 [IFUNDEF] vocabulary    \ we are executed just with kernel image  
                         \ load the rest that is needed  
                         \ (require fails because this file is needed from a  
                         \ different directory with the wordlibraries)  
 include ./search.fs                       
 include ./extend.fs  
 include ./stuff.fs  
 [THEN]  
   
 [IFUNDEF] environment?  
 include ./environ.fs  
 [THEN]  
   
 : struct% struct ; \ struct is redefined in gray  : struct% struct ; \ struct is redefined in gray
   
 include ./gray.fs  include ./gray.fs
Line 431  wordlist constant prefixes Line 418  wordlist constant prefixes
     rdrop ;      rdrop ;
   
 : type-prefix ( xt1 xt2 n stack "prefix" -- )  : type-prefix ( xt1 xt2 n stack "prefix" -- )
     create-type      get-current >r prefixes set-current
       create-type r> set-current
 does> ( item -- )  does> ( item -- )
     \ initialize item      \ initialize item
     { item typ }      { item typ }
Line 481  does> ( item -- ) Line 469  does> ( item -- )
     prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;      prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
           
 : stack-prefix ( stack "prefix" -- )  : stack-prefix ( stack "prefix" -- )
       get-current >r prefixes set-current
     name tuck nextname create ( stack length ) 2,      name tuck nextname create ( stack length ) 2,
       r> set-current
 does> ( item -- )  does> ( item -- )
     2@ { item stack prefix-length }      2@ { item stack prefix-length }
     item item-name 2@ prefix-length /string item item-name 2!      item item-name 2@ prefix-length /string item item-name 2!
Line 493  does> ( item -- ) Line 483  does> ( item -- )
 : stack-type-name ( addr u "name" -- )  : stack-type-name ( addr u "name" -- )
     single 0 create-type ;      single 0 create-type ;
   
 s" Cell"  stack-type-name w  wordlist constant type-names \ this is here just to meet the requirement
 s" Float" stack-type-name r                      \ that a type be a word; it is never used for lookup
   
   : stack ( "name" "stack-pointer" "type" -- )
       \ define stack
       name { d: stack-name }
       name { d: stack-pointer }
       name { d: stack-type }
       get-current type-names set-current
       stack-type 2dup nextname stack-type-name
       set-current
       stack-pointer lastxt >body stack-name nextname make-stack ;
   
 s" IP" save-mem w make-stack inst-stream  stack inst-stream IP Cell
 ' inst-in-index inst-stream stack-in-index-xt !  ' inst-in-index inst-stream stack-in-index-xt !
 ' inst-stream <is> inst-stream-f  ' inst-stream <is> inst-stream-f
   
 s" sp" save-mem w make-stack data-stack   
 s" fp" save-mem r make-stack fp-stack  
 s" rp" save-mem w make-stack return-stack  
 \ !! initialize stack-in and stack-out  \ !! initialize stack-in and stack-out
   
 \ offset computation  \ offset computation
Line 1217  warnings @ [IF] Line 1213  warnings @ [IF]
 .( parser generated ok ) cr  .( parser generated ok ) cr
 [THEN]  [THEN]
   
   
   \ run with out of box gforth 0.5.0
   [IFUNDEF] slurp-file
   : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
       \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
       r/o bin open-file throw >r
       r@ file-size throw abort" file too large"
       dup allocate throw swap
       2dup r@ read-file throw over <> abort" could not read whole file"
       r> close-file throw ;
   [THEN]
   
 : primfilter ( addr u -- )  : primfilter ( addr u -- )
     \ process the string at addr u      \ process the string at addr u
     over dup rawinput ! dup line-start ! cookedinput !      over dup rawinput ! dup line-start ! cookedinput !

Removed from v.1.92  
changed lines
  Added in v.1.96


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