[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.16 and 1.17

version 1.16, Tue Nov 7 18:06:57 1995 UTC version 1.17, Sat Dec 23 16:21:59 1995 UTC
Line 50 
Line 50 
 4096 constant batch-size \ no meaning, just make sure it's >0  4096 constant batch-size \ no meaning, just make sure it's >0
 255 constant maxchar  255 constant maxchar
 maxchar 1+ constant eof-char  maxchar 1+ constant eof-char
 9 constant tab-char  #tab constant tab-char
 10 constant nl-char  #lf constant nl-char
   
 : read-whole-file ( c-addr1 file-id -- c-addr2 )  : read-whole-file ( c-addr1 file-id -- c-addr2 )
 \ reads the contents of the file file-id puts it into memory at c-addr1  \ reads the contents of the file file-id puts it into memory at c-addr1
Line 68 
Line 68 
   
 variable input \ pointer to next character to be parsed  variable input \ pointer to next character to be parsed
 variable endinput \ pointer to the end of the input (the char after the last)  variable endinput \ pointer to the end of the input (the char after the last)
   variable line \ line number of char pointed to by input
   1 line !
   2variable filename \ filename of original input file
   0 0 filename 2!
   variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
   skipsynclines on
   \ !! unfortunately, this does not mean that they do not appear in the
   \ output. This could be changed by copying the input (skipping
   \ synclines) in ?nextchar
   
 : start ( -- addr )  : start ( -- addr )
  input @ ;   input @ ;
Line 110 
Line 119 
 variable effect-out-end ( pointer )  variable effect-out-end ( pointer )
 2variable effect-in-size  2variable effect-in-size
 2variable effect-out-size  2variable effect-out-size
   variable c-line
   2variable c-filename
   variable name-line
   2variable name-filename
   2variable last-name-filename
   
 variable primitive-number -10 primitive-number !  variable primitive-number -10 primitive-number !
   
Line 151 
Line 165 
  getinput member? ;   getinput member? ;
 ' testchar? test-vector !  ' testchar? test-vector !
   
   : checksyncline ( -- )
       \ when input points to a newline, check if the next line is a
       \ sync line.  If it is, perform the appropriate actions.
       input @ >r
       s" #line " r@ over compare 0<> if
           rdrop 1 line +! EXIT
       endif
       0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
       dup c@ bl = if
           char+ dup c@ [char] " <> abort" sync line syntax"
           char+ dup 100 [char] " scan drop swap 2dup - filename 2!
           char+
       endif
       dup c@ nl-char <> abort" sync line syntax"
       skipsynclines @ if
           dup char+ input !
       endif
       drop ;
   
 : ?nextchar ( f -- )  : ?nextchar ( f -- )
  ?not? if   ?not? if
    ." syntax error" cr     ." syntax error" cr
Line 159 
Line 192 
    abort     abort
  endif   endif
  input @ endinput @ <> if   input @ endinput @ <> if
           input @ c@
    1 input +!     1 input +!
           nl-char = if
               checksyncline
           endif
  endif ;   endif ;
   
 : charclass ( set "name" -- )  : charclass ( set "name" -- )
Line 197 
Line 234 
 (( ` \ nonl ** nl  (( ` \ nonl ** nl
 )) <- comment ( -- )  )) <- comment ( -- )
   
   \ (( ` # ` l ` i ` n ` e blank
   \ {{ 0. start }} digit ++ {{ end >number abort" line number?" drop drop 1- line ! }} blank
   \    (( ` " {{ start }} noquote ++ {{ end filename 2! }} `" )) ??
   \    nl
   \ )) <- syncline ( -- )
   
   \ (( nl syncline ?? )) <- nlsync
   
 (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}  (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
    ` - ` - blank **     ` - ` - blank **
    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}     {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
Line 204 
Line 249 
   
 (( {{ s" " doc 2! s" " forth-code 2! }}  (( {{ s" " doc 2! s" " forth-code 2! }}
    (( comment || nl )) **     (( comment || nl )) **
    (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++     (( {{ line @ name-line ! filename 2@ name-filename 2! }}
         {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++
       {{ start }} stack-effect {{ end stack-string 2! }} tab ++        {{ start }} stack-effect {{ end stack-string 2! }} tab ++
         {{ start }} name {{ end wordset 2! }} tab **          {{ start }} name {{ end wordset 2! }} tab **
         (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl          (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl
    ))     ))
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??     (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
    {{ start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! }}     {{ line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! }}
    (( ` :  nl     (( ` :  nl
       {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}        {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}
    )) ??     )) ??
Line 231 
Line 277 
  dup endinput !   dup endinput !
  here - allot   here - allot
  align   align
    checksyncline
  primitives2something ;   primitives2something ;
   
 \ types  \ types
Line 546 
Line 593 
  fetches   fetches
  stack-pointer-updates   stack-pointer-updates
  ." {" cr   ." {" cr
    ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
  c-code 2@ type   c-code 2@ type
  ." }" cr   ." }" cr
  ." NEXT_P1;" cr   ." NEXT_P1;" cr
Line 573 
Line 621 
        -1 primitive-number +!         -1 primitive-number +!
  THEN ;   THEN ;
   
   : output-tag-file ( -- )
       name-filename 2@ last-name-filename 2@ compare if
           name-filename 2@ last-name-filename 2!
           #ff emit cr
           name-filename 2@ type
           ." ,0" cr
       endif ;
   
   : output-tag ( -- )
       output-tag-file
       forth-name 2@ 1+ type
       127 emit
       space forth-name 2@ type space
       1 emit
       name-line @ 0 .r
       ." ,0" cr ;
   
 [IFDEF] documentation  [IFDEF] documentation
 : register-doc ( -- )  : register-doc ( -- )
     get-current documentation set-current      get-current documentation set-current
Line 586 
Line 651 
 [THEN]  [THEN]
   
 : process-file ( addr u xt -- )  : process-file ( addr u xt -- )
  >r r/o open-file abort" cannot open file"      >r
       2dup filename 2!
       r/o open-file abort" cannot open file"
  warnings @ if   warnings @ if
  ." ------------ CUT HERE -------------" cr  endif   ." ------------ CUT HERE -------------" cr  endif
  r> primfilter ;   r> primfilter ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help