gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.123 and 1.136

-version 1.123, Fri Dec 27 15:51:28 2002 UTC
+version 1.136, Sat Mar 22 10:15:49 2003 UTC
  Line 1
  Line 1
  Line 1
  \ 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.
  Line 53
  Line 53
  Line 53
  warnings off
+ \ redefinitions of kernel words not present in gforth-0.6.1
+ : latestxt lastcfa @ ;
+ : latest last @ ;
  [IFUNDEF] try
  include startup.fs
  [THEN]
- Line 63
+ Line 67
  Line 63
  Line 67
  \ warnings on
  include ./gray.fs
 constant max-effect \ number of things on one side of a stack effect
 constant max-stacks  \ the max. number of stacks (including inst-stream).
 constant maxchar
  maxchar 1+ constant eof-char
- Line 162
+ Line 166
  Line 162
  Line 166
      cell% 2* field stack-pointer \ stackpointer name
      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-access-transform \ ( nitem -- index )
  end-struct stack%
  struct%
- Line 197
+ Line 202
  Line 197
  Line 202
 next-stack-number +!
      r@ stack-type !
      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 -- }
      \ perform xt for all stacks
- Line 333
+ Line 340
  Line 333
  Line 340
  \ 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
-         drop ." TOS"
+         ." TOS"
      endif ;
  : normal-stack-access ( n stack -- )
- Line 603
+ Line 612
  Line 603
  Line 612
      get-current type-names set-current
      stack-type 2dup nextname stack-type-name
      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
  ' inst-in-index inst-stream stack-in-index-xt !
- Line 626
+ Line 635
  Line 626
  Line 635
  : compute-offset-out ( addr1 addr2 -- )
      ['] stack-out compute-offset ;
- : clear-stack ( stack -- )
-     dup stack-in off stack-out off ;
  : 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-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 ;
- Line 645
+ Line 652
  Line 645
  Line 652
      stack stack-out @ 0<> stack stack-in @ 0= and
      if
          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
-dup type ." [0] = " type ." TOS);" cr
+dup type 0 stack normal-stack-access0 ."  = " type ." TOS);" cr
      endif ;
  : flush-tos ( -- )
- Line 655
+ Line 662
  Line 655
  Line 662
      stack stack-out @ 0= stack stack-in @ 0<> and
      if
          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
-dup type ." TOS = " type ." [0]);" cr
+dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
      endif ;
  : fill-tos ( -- )
- Line 668
+ Line 675
  Line 668
  Line 675
  : fetches ( -- )
      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
+r> execute - ;
  : stack-pointer-update { stack -- }
      \ stacks grow downwards
      stack stack-diff
- Line 675
+ Line 688
  Line 675
  Line 688
          stack inst-stream = if
              ." INC_IP(" 0 .r ." );" cr
          else
-             stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr
+             stack stack-pointer 2@ type ."  += "
+             stack stack-update-transform 0 .r ." ;" cr
          endif
      endif ;
- Line 724
+ Line 738
  Line 724
  Line 738
      endif
 drop ;
+ : output-nextp2 ( -- )
+     ." NEXT_P2;" cr ;
+ variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL
+ ' output-nextp2 tail-nextp2 !
  : output-label2 ( -- )
      ." LABEL2(" prim prim-c-name 2@ type ." )" cr
      ." NEXT_P2;" cr ;
- Line 745
+ Line 765
  Line 745
  Line 765
      xt execute ;
  : output-c-tail ( -- )
-     ['] noop output-c-tail1 ;
+     tail-nextp2 @ output-c-tail1 ;
  : output-c-tail2 ( -- )
      ['] output-label2 output-c-tail1 ;
  : output-c-tail-no-stores ( -- )
-     ['] noop output-c-tail1-no-stores ;
+     tail-nextp2 @ output-c-tail1-no-stores ;
  : output-c-tail2-no-stores ( -- )
      ['] output-label2 output-c-tail1-no-stores ;
- Line 1310
+ Line 1330
  Line 1310
  Line 1330
   getinput member? ;
  ' testchar? test-vector !
- : checksyncline ( -- )
+ : checksynclines ( -- )
      \ when input points to a newline, check if the next line is a
      \ sync line.  If it is, perform the appropriate actions.
-     rawinput @ >r
+     rawinput @ begin >r
      s" #line " r@ over compare if
          rdrop 1 line +! EXIT
      endif
- Line 1325
+ Line 1345
  Line 1325
  Line 1345
      endif
      dup c@ nl-char <> 0= s" sync line syntax" ?print-error
      skipsynclines @ if
-         dup char+ rawinput !
+             char+ dup rawinput !
          rawinput @ c@ cookedinput @ c!
      endif
-     drop ;
+     again ;
  : ?nextchar ( f -- )
      s" syntax error, wrong char" ?print-error
- Line 1337
+ Line 1357
  Line 1337
  Line 1357
 chars rawinput +!
 chars cookedinput +!
          nl-char = if
-             checksyncline
+             checksynclines
              rawinput @ line-start !
          endif
-         rawinput @ c@ cookedinput @ c!
+         rawinput @ c@
+         cookedinput @ c!
      endif ;
  : charclass ( set "name" -- )
- Line 1418
+ Line 1439
  Line 1418
  Line 1439
  (( (( ` g || ` G )) {{ start }} nonl **
     {{ end
        forth-flag @ IF  ." group " type cr  THEN
-       c-flag @     IF  ." GROUP(" type ." )" cr  THEN }}
+       c-flag @     IF  ." GROUP(" type ." , " function-number @ 0 .r ." )" cr  THEN }}
  )) <- group-comment
  (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
- Line 1485
+ Line 1506
  Line 1485
  Line 1506
      \ process the string at addr u
      over dup rawinput ! dup line-start ! cookedinput !
      + endrawinput !
-     checksyncline
+     checksynclines
      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 -- )
      output-combined ! output !
      save-mem 2dup filename 2!
-     slurp-file
+     slurp-file unixify
      warnings @ if
          ." ------------ CUT HERE -------------" cr  endif
      primfilter ;

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.123
 


changed lines


 
Added in v.1.136
 Legend:



Removed from v.1.123
 


changed lines


 
Added in v.1.136
-Removed from v.1.123
+Added in v.1.136

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.123 and 1.136

ViewCVS and CVS Help