Diff for /gforth/prims2x.fs between versions 1.158 and 1.167

version 1.158, 2005/07/28 19:15:00 version 1.167, 2007/07/10 21:23:24
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,2006 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
   
   [undefined] outfile-execute [if]
       : outfile-execute ( ... xt file-id -- ... )
           \ unsafe replacement
           outfile-id >r to outfile-id execute r> to outfile-id ;
   [then]
   
 warnings off  warnings off
   
 \ redefinitions of kernel words not present in gforth-0.6.1  \ redefinitions of kernel words not present in gforth-0.6.1
Line 102  variable include-skipped-insts Line 109  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 134  $12340000 immarg ! Line 144  $12340000 immarg !
     over - type cr      over - type cr
     line-start @ rawinput @ over - typewhite ." ^" cr ;      line-start @ rawinput @ over - typewhite ." ^" cr ;
   
   : print-error { addr u -- }
       filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
       print-error-line ;
   
 : ?print-error { f addr u -- }  : ?print-error { f addr u -- }
     f ?not? if      f ?not? if
         outfile-id >r try          addr u ['] print-error stderr outfile-execute
             stderr to outfile-id  
             filename 2@ type ." :" line @ 0 .r ." : " addr u type cr  
             print-error-line  
             0  
         recover endtry  
         r> to outfile-id throw  
         1 (bye) \ abort          1 (bye) \ abort
     endif ;      endif ;
   
Line 201  struct% Line 209  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 362  variable name-line Line 371  variable name-line
 2variable last-name-filename  2variable last-name-filename
 Variable function-number 0 function-number !  Variable function-number 0 function-number !
 Variable function-old 0 function-old !  Variable function-old 0 function-old !
 : function-diff ( n -- )  : function-diff ( -- )
     ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr      ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr
     function-number @ function-old ! ;      function-number @ function-old ! ;
 : forth-fdiff ( -- )  : forth-fdiff ( -- )
Line 500  defer inst-stream-f ( -- stack ) Line 509  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 ;
Line 676  get-current prefixes set-current Line 685  get-current prefixes set-current
 set-current  set-current
   
 create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it  create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
 item% %allot                \ stores the stack temporarily until used by ...  item% %allot drop           \ stores the stack temporarily until used by ...
   
 : init-item1 ( addr1 addr u -- addr2 )  : init-item1 ( addr1 addr u -- addr2 )
     \ initialize item at addr1 with name addr u, next item is at addr2      \ initialize item at addr1 with name addr u, next item is at addr2
Line 751  stack inst-stream IP Cell Line 760  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 1169  variable tail-nextp2 \ xt to execute for Line 1185  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 1457  variable reprocessed-num 0 reprocessed-n Line 1474  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 1837  Variable c-flag Line 1855  Variable c-flag
 )) <- else-comment  )) <- else-comment
   
 (( ` + {{ start }} nonl ** {{ end  (( ` + {{ start }} nonl ** {{ end
         dup          dup
         IF      c-flag @          IF
             IF              c-flag @ IF
                 function-diff                  function-diff
                 ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr                  ." #ifdef HAS_" 2dup bounds ?DO  I c@ toupper emit  LOOP cr
                 THEN              THEN
                 forth-flag @              forth-flag @ IF
                 IF  forth-fdiff  ." has? " type ."  [IF]"  cr THEN                  forth-fdiff  ." has? " 2dup type ."  [IF]"  cr
         ELSE    2drop              THEN
               2drop
           ELSE
               2drop
             c-flag @      IF              c-flag @      IF
                 function-diff  ." #endif" cr THEN                  function-diff  ." #endif" cr THEN
             forth-flag @  IF  forth-fdiff  ." [THEN]"  cr THEN              forth-flag @  IF  forth-fdiff  ." [THEN]"  cr THEN
Line 1854  Variable c-flag Line 1875  Variable c-flag
   
 (( (( ` g || ` G )) {{ start }} nonl **  (( (( ` g || ` G )) {{ start }} nonl **
    {{ end     {{ end
       forth-flag @ IF  forth-fdiff  ." group " type cr  THEN        forth-flag @ IF  forth-fdiff  ." group " 2dup type cr  THEN
       c-flag @     IF  function-diff        c-flag @     IF  function-diff
           ." GROUP(" type ." , " function-number @ 0 .r ." )" cr  THEN }}            ." GROUP(" 2dup type ." , " function-number @ 0 .r ." )" cr  THEN
         2drop }}
 )) <- group-comment  )) <- group-comment
   
 (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body  (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
Line 1874  Variable c-flag Line 1896  Variable c-flag
 (( {{ prim create-prim prim init-simple }}  (( {{ prim create-prim prim init-simple }}
    ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **     ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
    (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **     (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
       (( {{ start }}  c-ident {{ end 2dup prim-c-name-2! }} )) ??        (( {{ start }}  c-ident {{ end prim-c-name-2! }} )) ??
    )) ??  nleof     )) ??  nleof
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??     (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}     {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}

Removed from v.1.158  
changed lines
  Added in v.1.167


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