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

Diff for /gforth/prims2x.fs between versions 1.125 and 1.136

version 1.125, 2002/12/28 17:18:27 version 1.136, 2003/03/22 10:15:49
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 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 53 Line 53
   
 warnings off  warnings off
   
   \ redefinitions of kernel words not present in gforth-0.6.1
   : latestxt lastcfa @ ;
   : latest last @ ;
   
 [IFUNDEF] try  [IFUNDEF] try
 include startup.fs  include startup.fs
 [THEN]  [THEN]
Line 63  warnings off Line 67  warnings off
 \ warnings on  \ warnings on
   
 include ./gray.fs  include ./gray.fs
 32 constant max-effect \ number of things on one side of a stack effect  128 constant max-effect \ number of things on one side of a stack effect
 4 constant max-stacks  \ the max. number of stacks (including inst-stream).  4 constant max-stacks  \ the max. number of stacks (including inst-stream).
 255 constant maxchar  255 constant maxchar
 maxchar 1+ constant eof-char  maxchar 1+ constant eof-char
Line 162  struct% Line 166  struct%
     cell% 2* field stack-pointer \ stackpointer name      cell% 2* field stack-pointer \ stackpointer name
     cell%    field stack-type \ name for default type of stack items      cell%    field stack-type \ name for default type of stack items
     cell%    field stack-in-index-xt \ ( in-size item -- in-index )      cell%    field stack-in-index-xt \ ( in-size item -- in-index )
       cell%    field stack-access-transform \ ( nitem -- index )
 end-struct stack%  end-struct stack%
   
 struct%  struct%
Line 197  create stacks max-stacks cells allot \ a Line 202  create stacks max-stacks cells allot \ a
     1 next-stack-number +!      1 next-stack-number +!
     r@ stack-type !      r@ stack-type !
     save-mem r@ stack-pointer 2!       save-mem r@ stack-pointer 2! 
     ['] stack-in-index r> stack-in-index-xt ! ;      ['] stack-in-index r@ stack-in-index-xt !
       ['] noop r@ stack-access-transform !
       rdrop ;
   
 : map-stacks { xt -- }  : map-stacks { xt -- }
     \ perform xt for all stacks      \ perform xt for all stacks
Line 333  defer inst-stream-f ( -- stack ) Line 340  defer inst-stream-f ( -- stack )
   
 \ stack access stuff  \ stack access stuff
   
 : normal-stack-access1 ( n stack -- )  : normal-stack-access0 { n stack -- }
     stack-pointer 2@ type      n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
     dup      
     if  : normal-stack-access1 { n stack -- }
         ." [" 0 .r ." ]"      stack stack-pointer 2@ type
       n if
           n stack normal-stack-access0
     else      else
         drop ." TOS"          ." TOS"
     endif ;      endif ;
   
 : normal-stack-access ( n stack -- )  : normal-stack-access ( n stack -- )
Line 603  wordlist constant type-names \ this is h Line 612  wordlist constant type-names \ this is h
     get-current type-names set-current      get-current type-names set-current
     stack-type 2dup nextname stack-type-name      stack-type 2dup nextname stack-type-name
     set-current      set-current
     stack-pointer lastxt >body stack-name nextname make-stack ;      stack-pointer latestxt >body stack-name nextname make-stack ;
   
 stack inst-stream IP Cell  stack inst-stream IP Cell
 ' inst-in-index inst-stream stack-in-index-xt !  ' inst-in-index inst-stream stack-in-index-xt !
Line 626  stack inst-stream IP Cell Line 635  stack inst-stream IP Cell
 : compute-offset-out ( addr1 addr2 -- )  : compute-offset-out ( addr1 addr2 -- )
     ['] stack-out compute-offset ;      ['] stack-out compute-offset ;
   
 : clear-stack ( stack -- )  
     dup stack-in off stack-out off ;  
   
 : compute-offsets ( -- )  : compute-offsets ( -- )
     ['] clear-stack map-stacks      prim prim-stacks-in  max-stacks cells erase
       prim prim-stacks-out max-stacks cells erase
     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items      prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items      prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
Line 645  stack inst-stream IP Cell Line 652  stack inst-stream IP Cell
     stack stack-out @ 0<> stack stack-in @ 0= and      stack stack-out @ 0<> stack stack-in @ 0= and
     if      if
         ." IF_" stack stack-pointer 2@ 2dup type ." TOS("          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
         2dup type ." [0] = " type ." TOS);" cr          2dup type 0 stack normal-stack-access0 ."  = " type ." TOS);" cr
     endif ;      endif ;
   
 : flush-tos ( -- )  : flush-tos ( -- )
Line 655  stack inst-stream IP Cell Line 662  stack inst-stream IP Cell
     stack stack-out @ 0= stack stack-in @ 0<> and      stack stack-out @ 0= stack stack-in @ 0<> and
     if      if
         ." IF_" stack stack-pointer 2@ 2dup type ." TOS("          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
         2dup type ." TOS = " type ." [0]);" cr          2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
     endif ;      endif ;
   
 : fill-tos ( -- )  : fill-tos ( -- )
Line 668  stack inst-stream IP Cell Line 675  stack inst-stream IP Cell
 : fetches ( -- )  : fetches ( -- )
     prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;      prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
   
   : stack-update-transform ( n1 stack -- n2 )
       \ n2 is the number by which the stack pointer should be
       \ incremented to pop n1 items
       stack-access-transform @ dup >r execute
       0 r> execute - ;
   
 : stack-pointer-update { stack -- }  : stack-pointer-update { stack -- }
     \ stacks grow downwards      \ stacks grow downwards
     stack stack-diff      stack stack-diff
Line 675  stack inst-stream IP Cell Line 688  stack inst-stream IP Cell
         stack inst-stream = if          stack inst-stream = if
             ." INC_IP(" 0 .r ." );" cr              ." INC_IP(" 0 .r ." );" cr
         else          else
             stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr              stack stack-pointer 2@ type ."  += "
               stack stack-update-transform 0 .r ." ;" cr
         endif          endif
     endif ;      endif ;
   
Line 923  variable tail-nextp2 \ xt to execute for Line 937  variable tail-nextp2 \ xt to execute for
 \      cr ;  \      cr ;
   
 : output-label ( -- )    : output-label ( -- )  
     ." INST_ADDR(" prim prim-c-name 2@ type ." )" cr ;      ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
   
 : output-alias ( -- )   : output-alias ( -- ) 
     ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;      ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
Line 1316  print-token ! Line 1330  print-token !
  getinput member? ;   getinput member? ;
 ' testchar? test-vector !  ' testchar? test-vector !
   
 : checksyncline ( -- )  : checksynclines ( -- )
     \ when input points to a newline, check if the next line is a      \ when input points to a newline, check if the next line is a
     \ sync line.  If it is, perform the appropriate actions.      \ sync line.  If it is, perform the appropriate actions.
     rawinput @ >r      rawinput @ begin >r
     s" #line " r@ over compare if          s" #line " r@ over compare if
         rdrop 1 line +! EXIT              rdrop 1 line +! EXIT
     endif          endif
     0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )          0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
     dup c@ bl = if          dup c@ bl = if
         char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error              char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error
         char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!              char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
         char+              char+
     endif          endif
     dup c@ nl-char <> 0= s" sync line syntax" ?print-error          dup c@ nl-char <> 0= s" sync line syntax" ?print-error
     skipsynclines @ if          skipsynclines @ if
         dup char+ rawinput !              char+ dup rawinput !
         rawinput @ c@ cookedinput @ c!              rawinput @ c@ cookedinput @ c!
     endif          endif
     drop ;      again ;
   
 : ?nextchar ( f -- )  : ?nextchar ( f -- )
     s" syntax error, wrong char" ?print-error      s" syntax error, wrong char" ?print-error
Line 1343  print-token ! Line 1357  print-token !
         1 chars rawinput +!          1 chars rawinput +!
         1 chars cookedinput +!          1 chars cookedinput +!
         nl-char = if          nl-char = if
             checksyncline              checksynclines
             rawinput @ line-start !              rawinput @ line-start !
         endif          endif
         rawinput @ c@ cookedinput @ c!          rawinput @ c@
           cookedinput @ c!
     endif ;      endif ;
   
 : charclass ( set "name" -- )  : charclass ( set "name" -- )
Line 1491  warnings @ [IF] Line 1506  warnings @ [IF]
     \ 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 !
     + endrawinput !      + endrawinput !
     checksyncline      checksynclines
     primitives2something ;          primitives2something ;    
   
   : unixify ( c-addr u1 -- c-addr u2 )
       \ delete crs from the string
       bounds tuck tuck ?do ( c-addr1 )
           i c@ dup #cr <> if
               over c! char+
           else
               drop
           endif
       loop
       over - ;
   
 : process-file ( addr u xt-simple x-combined -- )  : process-file ( addr u xt-simple x-combined -- )
     output-combined ! output !      output-combined ! output !
     save-mem 2dup filename 2!      save-mem 2dup filename 2!
     slurp-file      slurp-file unixify
     warnings @ if      warnings @ if
         ." ------------ CUT HERE -------------" cr  endif          ." ------------ CUT HERE -------------" cr  endif
     primfilter ;      primfilter ;
Removed from v.1.125  
changed lines
  Added in v.1.136

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