Diff for /gforth/prims2x.fs between versions 1.49 and 1.50

version 1.49, 2000/11/10 10:04:20 version 1.50, 2000/11/12 14:09:45
Line 430  end-struct type% Line 430  end-struct type%
 \ allocate a string  \ allocate a string
  here swap dup allot move ;   here swap dup allot move ;
   
 : starts-with { addr u xt1 xt2 n stack -- } ( "prefix" -- )  wordlist constant prefixes
   
   : declare ( addr "name" -- )
   \ remember that there is a stack item at addr called name
    create , ;
   
   : !default ( w addr -- )
       dup @ if
           2drop \ leave nonzero alone
       else
           !
       endif ;
   
   : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
     \ describes a type      \ describes a type
     \ addr u specifies the C type name      \ addr u specifies the C type name
     \ stack effect entries of the type start with prefix      \ stack effect entries of the type start with prefix
Line 442  end-struct type% Line 455  end-struct type%
     stack r@ type-stack !      stack r@ type-stack !
     rdrop ;      rdrop ;
   
 wordlist constant types  : type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
 get-current      create-type
 types set-current  does> ( item -- )
       \ initialize item
 s" Bool"        single-type starts-with f      { item typ }
 s" Char"        single-type starts-with c      typ item item-type !
 s" Cell"        single-type starts-with n      typ type-stack @ item item-stack !default
 s" Cell"        single-type starts-with w      item item-name 2@ items @ search-wordlist 0= if \ new name
 s" UCell"       single-type starts-with u          item item-name 2@ 2dup nextname item declare
 s" DCell"       double-type starts-with d          typ type-c-name 2@ type space type  ." ;" cr
 s" UDCell"      double-type starts-with ud      else
 s" Float"       float-type  starts-with r          drop
 s" Cell *"      single-type starts-with a_      endif ;
 s" Char *"      single-type starts-with c_  
 s" Float *"     single-type starts-with f_  : execute-prefix ( item addr1 u1 -- )
 s" DFloat *"    single-type starts-with df_      \ execute the word ( item -- ) associated with the longest prefix
 s" SFloat *"    single-type starts-with sf_      \ of addr1 u1
 s" Xt"          single-type starts-with xt      0 swap ?do
 s" WID"         single-type starts-with wid          dup i prefixes search-wordlist
 s" struct F83Name *"    single-type starts-with f83name          if \ ok, we have the type ( item addr1 xt )
               nip execute
 set-current              UNLOOP EXIT
           endif
 : get-type ( addr1 u1 -- type-descr )          -1 s+loop
 \ get the type of the name in addr1 u1      \ we did not find a type, abort
 \ type-descr is a pointer to a type-descriptor      true abort" unknown prefix" ;
  0 swap ?do  
    dup i types search-wordlist  
    if \ ok, we have the type ( addr1 xt )  
      execute nip  
      UNLOOP EXIT  
    endif  
  -1 s+loop  
  \ we did not find a type, abort  
  true abort" unknown type prefix" ;  
   
 : declare ( addr "name" -- )  
 \ remember that there is a stack item at addr called name  
  create , ;  
   
 : declaration ( item -- )  : declaration ( item -- )
  dup item-name 2@ items @ search-wordlist      dup item-name 2@ execute-prefix ;
  if \ already declared ( item xt )  
      execute @ 2dup item-type @ swap item-type !  
      item-stack @ swap item-stack ! \ !! does not generalize to stack prefixes  
  else ( addr )  
    dup item-name 2@ nextname dup declare ( addr )  
    dup >r item-name 2@ 2dup get-type ( addr1 u type-descr )  
    dup type-stack @ r@ item-stack ! \ !! only if item-stack @ 0=  
    dup r> item-type ! ( addr1 u type-descr )  
    type-c-name 2@ type space type ." ;" cr  
  endif ;  
   
 : declaration-list ( addr1 addr2 -- )  : declaration-list ( addr1 addr2 -- )
  swap ?do   swap ?do
Line 505  set-current Line 495  set-current
  effect-in effect-in-end @ declaration-list   effect-in effect-in-end @ declaration-list
  effect-out effect-out-end @ declaration-list ;   effect-out effect-out-end @ declaration-list ;
   
   get-current
   prefixes set-current
   
   s" Bool"        single-type type-prefix f
   s" Char"        single-type type-prefix c
   s" Cell"        single-type type-prefix n
   s" Cell"        single-type type-prefix w
   s" UCell"       single-type type-prefix u
   s" DCell"       double-type type-prefix d
   s" UDCell"      double-type type-prefix ud
   s" Float"       float-type  type-prefix r
   s" Cell *"      single-type type-prefix a_
   s" Char *"      single-type type-prefix c_
   s" Float *"     single-type type-prefix f_
   s" DFloat *"    single-type type-prefix df_
   s" SFloat *"    single-type type-prefix sf_
   s" Xt"          single-type type-prefix xt
   s" WID"         single-type type-prefix wid
   s" struct F83Name *"    single-type type-prefix f83name
   
   set-current
   
 \ offset computation  \ offset computation
 \ the leftmost (i.e. deepest) item has offset 0  \ the leftmost (i.e. deepest) item has offset 0
 \ the rightmost item has the highest offset  \ the rightmost item has the highest offset

Removed from v.1.49  
changed lines
  Added in v.1.50


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