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

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

version 1.49, 2000/11/10 10:04:20 version 1.52, 2000/11/14 10:36:02
Line 103  end-struct stack% Line 103  end-struct stack%
   
 s" sp" save-mem s" (Cell)" make-stack data-stack   s" sp" save-mem s" (Cell)" make-stack data-stack 
 s" fp" save-mem s" "       make-stack fp-stack  s" fp" save-mem s" "       make-stack fp-stack
   s" rp" save-mem s" (Cell)" make-stack return-stack
 \ !! initialize stack-in and stack-out  \ !! initialize stack-in and stack-out
   
 \ stack items  \ stack items
Line 245  eof-char singleton     charclass eof Line 246  eof-char singleton     charclass eof
   
   
 (( letter (( letter || digit )) **  (( letter (( letter || digit )) **
 )) <- c-name ( -- )  )) <- c-ident ( -- )
   
   (( ` # ?? (( letter || digit || ` : )) **
   )) <- stack-ident ( -- )
   
 (( nowhitebq nowhite ** ))  (( nowhitebq nowhite ** ))
 <- name ( -- )  <- forth-ident ( -- )
   
 Variable forth-flag  Variable forth-flag
 Variable c-flag  Variable c-flag
Line 283  Variable c-flag Line 287  Variable c-flag
   
 (( ` \ comment-body nl )) <- comment ( -- )  (( ` \ comment-body nl )) <- comment ( -- )
   
 (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick init-item item% %size + }} white ** )) ** {{ effect-in-end ! }}  (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
   <- stack-items
   
   (( {{ effect-in }}  stack-items {{ effect-in-end ! }}
    ` - ` - white **     ` - ` - white **
    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick init-item item% %size + }} white ** )) ** {{ effect-out-end ! }}     {{ effect-out }} stack-items {{ effect-out-end ! }}
 )) <- stack-effect ( -- )  )) <- stack-effect ( -- )
   
 (( {{ s" " doc 2! s" " forth-code 2! }}  (( {{ s" " doc 2! s" " forth-code 2! }}
    (( {{ line @ name-line ! filename 2@ name-filename 2! }}     (( {{ line @ name-line ! filename 2@ name-filename 2! }}
       {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  white ++        {{ start }} forth-ident {{ end 2dup forth-name 2! c-name 2! }}  white ++
       ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white **        ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white **
         {{ start }} name {{ end wordset 2! }} white **          {{ start }} forth-ident {{ end wordset 2! }} white **
         (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl          (( {{ start }}  c-ident {{ end c-name 2! }} )) ??  nl
    ))     ))
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??     (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! skipsynclines on }}     {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! skipsynclines on }}
Line 430  end-struct type% Line 437  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 462  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_  
 s" DFloat *"    single-type starts-with df_  
 s" SFloat *"    single-type starts-with sf_  
 s" Xt"          single-type starts-with xt  
 s" WID"         single-type starts-with wid  
 s" struct F83Name *"    single-type starts-with f83name  
   
 set-current  
   
 : get-type ( addr1 u1 -- type-descr )  
 \ get the type of the name in addr1 u1  
 \ type-descr is a pointer to a type-descriptor  
  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" -- )  : execute-prefix ( item addr1 u1 -- )
 \ remember that there is a stack item at addr called name      \ execute the word ( item -- ) associated with the longest prefix
  create , ;      \ of addr1 u1
       0 swap ?do
           dup i prefixes search-wordlist
           if \ ok, we have the type ( item addr1 xt )
               nip execute
               UNLOOP EXIT
           endif
           -1 s+loop
       \ we did not find a type, abort
       true abort" unknown prefix" ;
   
 : 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 ;  
   
   : stack-prefix ( stack "prefix" -- )
       name tuck nextname create ( stack length ) 2,
   does> ( item -- )
       2@ { item stack prefix-length }
       item item-name 2@ prefix-length /string item item-name 2!
       stack item item-stack !
       item declaration ;
       
 : declaration-list ( addr1 addr2 -- )  : declaration-list ( addr1 addr2 -- )
  swap ?do   swap ?do
   i declaration    i declaration
Line 505  set-current Line 510  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
   
   return-stack stack-prefix R:
   
   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
Line 526  set-current Line 555  set-current
   
   
 : compute-offsets ( -- )  : compute-offsets ( -- )
     data-stack clear-stack  fp-stack clear-stack      data-stack clear-stack  fp-stack clear-stack return-stack clear-stack
     effect-in  effect-in-end  @ ['] stack-in  compute-list      effect-in  effect-in-end  @ ['] stack-in  compute-list
     effect-out effect-out-end @ ['] stack-out compute-list ;      effect-out effect-out-end @ ['] stack-out compute-list ;
   
Line 538  set-current Line 567  set-current
     endif ;      endif ;
   
 : flush-tos ( -- )  : flush-tos ( -- )
     data-stack flush-a-tos      data-stack   flush-a-tos
     fp-stack   flush-a-tos ;      fp-stack     flush-a-tos
       return-stack flush-a-tos ;
   
 : fill-a-tos { stack -- }  : fill-a-tos { stack -- }
     stack stack-out @ 0= stack stack-in @ 0<> and      stack stack-out @ 0= stack stack-in @ 0<> and
Line 549  set-current Line 579  set-current
     endif ;      endif ;
   
 : fill-tos ( -- )  : fill-tos ( -- )
     fp-stack   fill-a-tos      fp-stack     fill-a-tos
     data-stack fill-a-tos ;      data-stack   fill-a-tos
       return-stack fill-a-tos ;
   
 : fetch ( addr -- )  : fetch ( addr -- )
  dup item-type @ type-fetch @ execute ;   dup item-type @ type-fetch @ execute ;
Line 568  set-current Line 599  set-current
     endif ;      endif ;
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     data-stack stack-pointer-update      data-stack   stack-pointer-update
     fp-stack   stack-pointer-update ;      fp-stack     stack-pointer-update
       return-stack stack-pointer-update ;
   
 : store ( item -- )  : store ( item -- )
 \ f is true if the item should be stored  \ f is true if the item should be stored
Line 581  set-current Line 613  set-current
    i store     i store
  item% %size +loop ;    item% %size +loop ; 
   
   : output-c-tail ( -- )
       \ the final part of the generated C code
       ." NEXT_P1;" cr
       stores
       fill-tos
       ." NEXT_P2;" cr ;
   
   : type-c ( c-addr u -- )
       \ like TYPE, but replaces "TAIL;" with tail code
       begin ( c-addr1 u1 )
           2dup s" TAIL;" search
       while ( c-addr1 u1 c-addr3 u3 )
           2dup 2>r drop nip over - type
           output-c-tail
           2r> 5 /string
           \ !! resync #line missing
       repeat
       2drop type ;
   
 : output-c ( -- )   : output-c ( -- ) 
  ." I_" c-name 2@ type ." :     /* " forth-name 2@ type ."  ( " stack-string 2@ type ." ) */" cr   ." I_" c-name 2@ type ." :     /* " forth-name 2@ type ."  ( " stack-string 2@ type ." ) */" cr
  ." /* " doc 2@ type ."  */" cr   ." /* " doc 2@ type ."  */" cr
Line 595  set-current Line 646  set-current
  stack-pointer-updates   stack-pointer-updates
  ." {" cr   ." {" cr
  ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr   ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
  c-code 2@ type   c-code 2@ type-c
  ." }" cr   ." }" cr
  ." NEXT_P1;" cr   output-c-tail
  stores  
  fill-tos  
  ." NEXT_P2;" cr  
  ." }" cr   ." }" cr
  cr   cr
 ;  ;
Line 627  set-current Line 675  set-current
     ." {" cr      ." {" cr
     declarations      declarations
     compute-offsets \ for everything else      compute-offsets \ for everything else
     data-stack stack-used? IF ." Cell *sp=SP;" cr THEN      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
     fp-stack   stack-used? IF ." Cell *fp=*FP;" cr THEN      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
       return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
     flush-tos      flush-tos
     fetches      fetches
     stack-pointer-updates      stack-pointer-updates
Removed from v.1.49  
changed lines
  Added in v.1.52

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