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

Diff for /gforth/prims2x.fs between versions 1.157 and 1.162

version 1.157, 2005/07/28 14:12:33 version 1.162, 2006/10/25 22:01:16
Line 1 Line 1
 \ converts primitives to, e.g., C code   \ converts primitives to, e.g., C code 
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 51 Line 51
 \ (stack-in-index-xt and a test for stack==instruction-stream); there  \ (stack-in-index-xt and a test for stack==instruction-stream); there
 \ should be only one.  \ should be only one.
   
   
 \ for backwards compatibility, jaw  \ for backwards compatibility, jaw
 require compat/strcomp.fs  require compat/strcomp.fs
   
Line 102  variable include-skipped-insts Line 103  variable include-skipped-insts
 \ inline arguments (false)  \ inline arguments (false)
 include-skipped-insts off  include-skipped-insts off
   
   2variable threaded-code-pointer-type \ type used for geninst etc.
   s" Inst **" threaded-code-pointer-type 2!
   
 variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)  variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
 $12340000 immarg !  $12340000 immarg !
   
Line 201  struct% Line 205  struct%
 end-struct ss% \ stack-state  end-struct ss% \ stack-state
   
 struct%  struct%
       cell%              field state-enabled
     cell%              field state-number      cell%              field state-number
     cell% max-stacks * field state-sss      cell% max-stacks * field state-sss
 end-struct state%  end-struct state%
Line 351  wordlist constant primitives Line 356  wordlist constant primitives
     \ address of number of stack items in effect out      \ address of number of stack items in effect out
     stack-number @ cells prim prim-stacks-out + ;      stack-number @ cells prim prim-stacks-out + ;
   
   : stack-prim-stacks-sync ( stack -- addr )
       prim prim-stacks-sync swap stack-number @ th ;
   
 \ global vars  \ global vars
 variable c-line  variable c-line
 2variable c-filename  2variable c-filename
Line 497  defer inst-stream-f ( -- stack ) Line 505  defer inst-stream-f ( -- stack )
     ." vm_two"      ." vm_two"
     r@ item-stack-type-name type ." 2"      r@ item-stack-type-name type ." 2"
     r@ item-type @ print-type-prefix ." ("      r@ item-type @ print-type-prefix ." ("
     r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read      r@ item-in-index r@ item-stack @ 2dup stack-read
     ." , "                      -1 under+ ." (Cell)" stack-read      ." , "                      -1 under+ stack-read
     ." , " r@ item-name 2@ type      ." , " r@ item-name 2@ type
     ." )" cr      ." )" cr
     rdrop ;      rdrop ;
   
 : same-as-in? ( item -- f )  : same-as-in? ( item -- f )
  \ f is true iff the offset and stack of item is the same as on input      \ f is true iff the offset and stack of item is the same as on input
  >r      >r
  r@ item-first @ if      r@ item-stack @ stack-prim-stacks-sync @ if
      rdrop false exit          rdrop false exit
  endif      endif
  r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"      r@ item-first @ if
  execute @          rdrop false exit
  dup r@ =      endif
  if \ item first appeared in output      r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
    drop false      execute @
  else      dup r@ =
    dup  item-stack  @ r@ item-stack  @ =       if \ item first appeared in output
    swap item-offset @ r@ item-offset @ = and          drop false
  endif      else
  rdrop ;          dup  item-stack  @ r@ item-stack  @ = 
           swap item-offset @ r@ item-offset @ = and
       endif
       rdrop ;
   
 : item-out-index ( item -- n )  : item-out-index ( item -- n )
     \ n is the index of item (in the out-effect)      \ n is the index of item (in the out-effect)
Line 616  does> ( item -- ) Line 627  does> ( item -- )
             UNLOOP EXIT              UNLOOP EXIT
         endif          endif
         -1 s+loop          -1 s+loop
     \ we did not find a type, abort          \ we did not find a type, abort
           abort
     false s" unknown prefix" ?print-error ;      false s" unknown prefix" ?print-error ;
   
 : declaration ( item -- )  : declaration ( item -- )
Line 650  does> ( item -- ) Line 662  does> ( item -- )
     stack item item-stack !      stack item item-stack !
     item declaration ;      item declaration ;
   
 : stack-prim-stacks-sync ( stack -- addr )  
     prim prim-stacks-sync swap stack-number @ th ;  
   
 : set-prim-stacks-sync ( stack -- )  : set-prim-stacks-sync ( stack -- )
     stack-prim-stacks-sync on ;      stack-prim-stacks-sync on ;
   
Line 667  get-current prefixes set-current Line 676  get-current prefixes set-current
     item-stack @ dup if      item-stack @ dup if
         set-prim-stacks-sync          set-prim-stacks-sync
     else \ prefixless "..." syncs all stacks      else \ prefixless "..." syncs all stacks
         ['] set-prim-stacks-sync map-stacks1          drop ['] set-prim-stacks-sync map-stacks1
     endif ;      endif ;
 set-current  set-current
   
Line 747  stack inst-stream IP Cell Line 756  stack inst-stream IP Cell
 : state ( "name" -- )  : state ( "name" -- )
     \ create a state initialized with default-sss      \ create a state initialized with default-sss
     create state% %allot { s }      create state% %allot { s }
       s state-enabled on
     next-state-number @ s state-number ! 1 next-state-number +!      next-state-number @ s state-number ! 1 next-state-number +!
     max-stacks 0 ?do      max-stacks 0 ?do
         default-ss s state-sss i th !          default-ss s state-sss i th !
     loop ;      loop ;
   
   : state-disable ( state -- )
       state-enabled off ;
   
   : state-enabled? ( state -- f )
       state-enabled @ ;
   
 : .state ( state -- )  : .state ( state -- )
     0 >body - >name .name ;      0 >body - >name .name ;
   
Line 1165  variable tail-nextp2 \ xt to execute for Line 1181  variable tail-nextp2 \ xt to execute for
   
 : output-gen ( -- )  : output-gen ( -- )
     \ generate C code for generating VM instructions      \ generate C code for generating VM instructions
     ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr      ." void gen_" prim prim-c-name 2@ type ." ("
       threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr
     ." {" cr      ." {" cr
     ."   gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr      ."   gen_inst(ctp, " function-number @ 0 .r ." );" cr
     gen-args-gen      gen-args-gen
     ." }" cr ;      ." }" cr ;
   
Line 1453  variable reprocessed-num 0 reprocessed-n Line 1470  variable reprocessed-num 0 reprocessed-n
   
 : state-prim1 { in-state out-state prim -- }  : state-prim1 { in-state out-state prim -- }
     in-state out-state state-default dup d= ?EXIT      in-state out-state state-default dup d= ?EXIT
       in-state state-enabled? out-state state-enabled? and 0= ?EXIT
     in-state  to state-in      in-state  to state-in
     out-state to state-out      out-state to state-out
     prim reprocess-simple ;      prim reprocess-simple ;
Line 1800  nl-char singleton eof-char over add-memb Line 1818  nl-char singleton eof-char over add-memb
 (( letter (( letter || digit )) **  (( letter (( letter || digit )) **
 )) <- c-ident ( -- )  )) <- c-ident ( -- )
   
 (( ` # ?? (( letter || digit || ` : )) ++ (( ` . ` . ` . )) ??  (( ` . ` . ` .
   )) <- sync-stack ( -- )
   
   (( ` # ?? (( letter || digit || ` : )) ++ sync-stack ??
   || sync-stack
 )) <- stack-ident ( -- )  )) <- stack-ident ( -- )
   
 (( nowhitebq nowhite ** ))  (( nowhitebq nowhite ** ))
Removed from v.1.157  
changed lines
  Added in v.1.162

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