[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.70 and 1.71

version 1.70, Sat Jan 20 20:17:39 2001 UTC version 1.71, Sun Jan 21 20:36:31 2001 UTC
Line 19 
Line 19 
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)  \ This is not very nice (hard limits, no checking, assumes 1 chars = 1).
   \ And it grew even worse when it aged.
   
 \ Optimizations:  \ Optimizations:
 \ superfluous stores are removed. GCC removes the superfluous loads by itself  \ superfluous stores are removed. GCC removes the superfluous loads by itself
Line 59 
Line 60 
 include ./gray.fs  include ./gray.fs
   
 32 constant max-effect \ number of things on one side of a stack effect  32 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).
 255 constant maxchar  255 constant maxchar
 maxchar 1+ constant eof-char  maxchar 1+ constant eof-char
 #tab constant tab-char  #tab constant tab-char
Line 77 
Line 79 
 variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?  variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
 skipsynclines on  skipsynclines on
   
   variable next-stack-number 0 next-stack-number !
   
 : start ( -- addr )  : start ( -- addr )
  cookedinput @ ;   cookedinput @ ;
   
 : end ( addr -- addr u )  : end ( addr -- addr u )
  cookedinput @ over - ;   cookedinput @ over - ;
   
   : print-error-line ( -- )
       \ print the current line and position
       line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
       over - type cr
       line-start @ rawinput @ over - typewhite ." ^" cr ;
   
   : ?print-error { f addr u -- }
       f ?not? if
           outfile-id >r try
               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
           abort
       endif ;
   
 : quote ( -- )  : quote ( -- )
     [char] " emit ;      [char] " emit ;
   
Line 92 
Line 114 
  output @ execute ;   output @ execute ;
   
 struct%  struct%
       cell%    field stack-number \ the number of this stack
     cell% 2* field stack-pointer \ stackpointer name      cell% 2* field stack-pointer \ stackpointer name
     cell% 2* field stack-cast \ cast string for assignments to stack elements      cell% 2* field stack-cast \ cast string for assignments to stack elements
     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-in  \ number of stack items in effect in  
     cell%    field stack-out \ number of stack items in effect out  
 end-struct stack%  end-struct stack%
   
 struct%  struct%
Line 123 
Line 144 
   
 : make-stack ( addr-ptr u1 addr-cast u2 "stack-name" -- )  : make-stack ( addr-ptr u1 addr-cast u2 "stack-name" -- )
     create stack% %allot >r      create stack% %allot >r
       next-stack-number @ r@ stack-number !  1 next-stack-number +!
     save-mem r@ stack-cast 2!      save-mem r@ stack-cast 2!
     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 ! ;
Line 162 
Line 184 
     item% max-effect * field prim-effect-out      item% max-effect * field prim-effect-out
     cell%    field prim-effect-in-end      cell%    field prim-effect-in-end
     cell%    field prim-effect-out-end      cell%    field prim-effect-out-end
       cell% max-stacks * field prim-stacks-in  \ number of in items per stack
       cell% max-stacks * field prim-stacks-out \ number of out items per stack
 end-struct prim%  end-struct prim%
   
 : make-prim ( -- prim )  : make-prim ( -- prim )
Line 171 
Line 195 
   
 0 value prim  0 value prim
   
   wordlist constant primitives
   
   : create-prim ( prim -- )
       get-current >r
       primitives set-current
       dup prim-name 2@ nextname constant
       r> set-current ;
   
   : stack-in ( stack -- addr )
       \ address of number of stack items in effect in
       stack-number @ cells prim prim-stacks-in + ;
   
   : stack-out ( stack -- addr )
       \ address of number of stack items in effect out
       stack-number @ cells prim prim-stacks-out + ;
   
 \ global vars  \ global vars
 variable c-line  variable c-line
 2variable c-filename  2variable c-filename
Line 703 
Line 743 
 \  spTOS = (Cell)_x_sp0;  \  spTOS = (Cell)_x_sp0;
 \  NEXT_P2;  \  NEXT_P2;
   
   1000 constant max-combined
   create combined-prims max-combined cells allot
   variable num-combined
   
   create current-depth max-stacks cells allot
   create max-depth     max-stacks cells allot
   
   : init-combined ( -- )
       0 num-combined !
       current-depth max-stacks cells erase
       max-depth     max-stacks cells erase ;
   
   : max! ( n addr -- )
       tuck @ max swap ! ;
   
   : add-depths { p -- }
       \ combine stack effect of p with *-depths
       max-stacks 0 ?do
           current-depth i cells + @
           p prim-stacks-in  i cells + @ +
           dup max-depth i cells + max!
           p prim-stacks-out i cells + @ -
           current-depth i cells + !
       loop ;
   
   : add-prim ( addr u -- )
       \ add primitive given by "addr u" to combined-prims
       primitives search-wordlist s" unknown primitive" ?print-error
       execute { p }
       p combined-prims num-combined @ cells + !
       1 num-combined +!
       p add-depths ;
   
   : compute-effects { q -- }
       \ compute the stack effects of q from the depths
       max-stacks 0 ?do
           max-depth i cells + @ dup
           q prim-stacks-in i cells + !
           current-depth i cells + @ -
           q prim-stacks-out i cells + !
       loop ;
   
   : process-combined ( -- )
       prim compute-effects ;
   
 \ the parser  \ the parser
   
Line 748 
Line 832 
     endif      endif
     drop ;      drop ;
   
 : print-error-line ( -- )  
     \ print the current line and position  
     line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )  
     over - type cr  
     line-start @ rawinput @ over - typewhite ." ^" cr ;  
   
 : ?nextchar ( f -- )  : ?nextchar ( f -- )
     ?not? if      s" syntax error, wrong char" ?print-error
         outfile-id >r try  
             stderr to outfile-id  
             filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"  
             getinput . cr  
             print-error-line  
             0  
         recover endtry  
         r> to outfile-id throw  
         abort  
     endif  
     rawinput @ endrawinput @ <> if      rawinput @ endrawinput @ <> if
         rawinput @ c@          rawinput @ c@
         1 chars rawinput +!          1 chars rawinput +!
Line 859 
Line 927 
    {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}     {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
 )) <- stack-effect ( -- )  )) <- stack-effect ( -- )
   
 ((  (( {{ prim create-prim }}
    ` ( 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 prim prim-c-name 2! }} )) ??        (( {{ start }}  c-ident {{ end prim prim-c-name 2! }} )) ??
Line 872 
Line 940 
    (( nl || eof ))     (( nl || eof ))
 )) <- simple-primitive ( -- )  )) <- simple-primitive ( -- )
   
 (( ` = (( white ++ forth-ident )) ++ (( nl || eof ))  (( {{ init-combined }}
      ` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++
      (( nl || eof )) {{ process-combined }}
 )) <- combined-primitive  )) <- combined-primitive
   
 (( {{ make-prim to prim  (( {{ make-prim to prim

Generate output suitable for use with a patch program
Legend:
Removed from v.1.70  
changed lines
  Added in v.1.71
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help