gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.8 and 1.30

-version 1.8, Mon Sep 12 19:00:36 1994 UTC
+version 1.30, Sat May  2 21:28:43 1998 UTC
  Line 1
  Line 1
  Line 1
+ \ converts primitives to, e.g., C code
+ \ Copyright (C) 1995 Free Software Foundation, Inc.
+ \ This file is part of Gforth.
+ \ Gforth is free software; you can redistribute it and/or
+ \ modify it under the terms of the GNU General Public License
+ \ as published by the Free Software Foundation; either version 2
+ \ of the License, or (at your option) any later version.
+ \ This program is distributed in the hope that it will be useful,
+ \ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ \ GNU General Public License for more details.
+ \ You should have received a copy of the GNU General Public License
+ \ along with this program; if not, write to the Free Software
+ \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)
  \ Optimizations:
- Line 21
+ Line 42
  Line 21
  Line 42
  warnings off
- [IFUNDEF] vocabulary  include search-order.fs [THEN]
+ include search.fs
+ include extend.fs
+ \ require interpretation.fs
+ \ require debugs.fs
+ [IFUNDEF] vocabulary    include search.fs [THEN]
+ [IFUNDEF] environment?  include environ.fs      [THEN]
  include gray.fs
 constant max-effect \ number of things on one side of a stack effect
-constant batch-size \ no meaning, just make sure it's >0
 constant maxchar
  maxchar 1+ constant eof-char
-constant tab-char
+ #tab constant tab-char
-constant nl-char
+ #lf constant nl-char
  : read-whole-file ( c-addr1 file-id -- c-addr2 )
  \ reads the contents of the file file-id puts it into memory at c-addr1
  \ c-addr2 is the first address after the file block
-   begin ( c-addr file-id )
+   >r dup $7fffffff r> read-file throw + ;
-dup batch-size swap read-file
-     if
-       true abort" I/O error"
-     endif
-     ( c-addr file-id actual-size ) rot over + -rot
-     batch-size <>
-   until
-   drop ;
- variable input \ pointer to next character to be parsed
+ variable rawinput \ pointer to next character to be scanned
- variable endinput \ pointer to the end of the input (the char after the last)
+ variable endrawinput \ pointer to the end of the input (the char after the last)
+ variable cookedinput \ pointer to the next char to be parsed
+ variable line \ line number of char pointed to by input
+line !
+variable filename \ filename of original input file
+0 filename 2!
+variable f-comment
+0 f-comment 2!
+ variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
+ skipsynclines on
+ Variable flush-comment flush-comment off
+ : ?flush-comment
+  flush-comment @ 0= ?EXIT
+  f-comment 2@ nip
+  IF  cr f-comment 2@ 2 /string type 0 0 f-comment 2! THEN ;
  : start ( -- addr )
-  input @ ;
+  cookedinput @ ;
  : end ( addr -- addr u )
-  input @ over - ;
+  cookedinput @ over - ;
  variable output \ xt ( -- ) of output word
- Line 88
+ Line 122
  Line 88
  Line 122
  variable effect-out-end ( pointer )
 variable effect-in-size
 variable effect-out-size
+ variable c-line
+variable c-filename
+ variable name-line
+variable name-filename
+variable last-name-filename
- variable primitive-number -9 primitive-number !
+ variable primitive-number -10 primitive-number !
+ Variable function-number 0 function-number !
  \ for several reasons stack items of a word are stored in a wordlist
  \ since neither forget nor marker are implemented yet, we make a new
- Line 109
+ Line 149
  Line 109
  Line 149
  eof-char max-member \ the whole character set + EOF
  : getinput ( -- n )
-  input @
+  rawinput @ endrawinput @ =
-  dup endinput @ =
   if
-    drop eof-char
+    eof-char
   else
-    c@
+    cookedinput @ c@
   endif ;
  :noname ( n -- )
- Line 129
+ Line 168
  Line 129
  Line 168
   getinput member? ;
  ' 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.
+     rawinput @ >r
+     s" #line " r@ over compare 0<> if
+         rdrop 1 line +! EXIT
+     endif
+. 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 - save-mem filename 2!
+         char+
+     endif
+     dup c@ nl-char <> abort" sync line syntax"
+     skipsynclines @ if
+         dup char+ rawinput !
+         rawinput @ c@ cookedinput @ c!
+     endif
+     drop ;
  : ?nextchar ( f -- )
   ?not? if
-    ." syntax error" cr
+         filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
     getinput . cr
-    input @ endinput @ over - 100 min type cr
+         rawinput @ endrawinput @ over - 100 min type cr
     abort
   endif
-  input @ endinput @ <> if
+     rawinput @ endrawinput @ <> if
-input +!
+         rawinput @ c@
+chars rawinput +!
+chars cookedinput +!
+         nl-char = if
+             checksyncline
+         endif
+         rawinput @ c@ cookedinput @ c!
   endif ;
  : charclass ( set "name" -- )
- Line 152
+ Line 217
  Line 152
  Line 217
  : ` ( -- terminal ) ( use: ` c )
   ( creates anonymous terminal for the character c )
-  [compile] ascii singleton ['] ?nextchar make-terminal ;
+  char singleton ['] ?nextchar make-terminal ;
  char a char z ..  char A char Z ..  union char _ singleton union  charclass letter
  char 0 char 9 ..                                        charclass digit
- Line 172
+ Line 237
  Line 172
  Line 237
  nowhite ++
  <- name ( -- )
- (( ` \ nonl ** nl
+ (( {{ ?flush-comment start }} ` \ nonl ** nl {{ end
+dup 2 min s" \+" compare 0= IF  f-comment 2!  ELSE  2drop  THEN }}
  )) <- comment ( -- )
  (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
- Line 182
+ Line 248
  Line 182
  Line 248
  (( {{ s" " doc 2! s" " forth-code 2! }}
     (( 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 }} name {{ end wordset 2! }} tab **
          (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl
     ))
     (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
-    {{ start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! }}
+    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! skipsynclines on }}
     (( ` :  nl
        {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}
     )) ??
- Line 204
+ Line 271
  Line 204
  Line 271
  : primfilter ( file-id xt -- )
  \ fileid is for the input file, xt ( -- ) is for the output word
   output !
-  here input !
+  here dup rawinput ! cookedinput !
   here swap read-whole-file
-  dup endinput !
+  dup endrawinput !
   here - allot
   align
+  checksyncline
+ \ begin
+ \     getinput dup eof-char = ?EXIT emit true ?nextchar
+ \ again ;
   primitives2something ;
  \ types
- Line 249
+ Line 320
  Line 249
  Line 320
  : fetch-double ( item -- )
   >r
-  r@ item-name 2@ type
+  ." FETCH_DCELL("
-  ." = ({Double_Store _d; _d.cells.low = "
+  r@ item-name 2@ type ." , "
   r@ item-d-offset @ dup    effect-in-size 2@ data-stack-access
-  ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access
+  ." , "                 1+ effect-in-size 2@ data-stack-access
-  ." ; _d.dcell;});" cr
+  ." );" cr
   rdrop ;
  : fetch-float ( item -- )
- Line 304
+ Line 375
  Line 304
  Line 375
  : store-double ( item -- )
  \ !! store optimization is not performed, because it is not yet needed
   >r
-  ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
+  ." STORE_DCELL(" r@ item-name 2@ type ." , "
   r@ item-d-offset @ dup    effect-out-size 2@ data-stack-access
-  ."  = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
+  ." , "                 1+ effect-out-size 2@ data-stack-access
-  ." = _d.cells.high;}" cr
+  ." );" cr
   rdrop ;
  : f-same-as-in? ( item -- f )
- Line 347
+ Line 418
  Line 347
  Line 418
   endif
   rdrop ;
- : single-type ( -- xt n1 n2 )
+ : single-type ( -- xt1 xt2 n1 n2 )
   ['] fetch-single ['] store-single 1 0 ;
- : double-type ( -- xt n1 n2 )
+ : double-type ( -- xt1 xt2 n1 n2 )
   ['] fetch-double ['] store-double 2 0 ;
- : float-type ( -- xt n1 n2 )
+ : float-type ( -- xt1 xt2 n1 n2 )
   ['] fetch-float ['] store-float 0 1 ;
  : s, ( addr u -- )
- Line 404
+ Line 475
  Line 404
  Line 475
       execute nip
       UNLOOP EXIT
     endif
-  -1 +loop
+  -1 s+loop
   \ we did not find a type, abort
   true abort" unknown type prefix" ;
- Line 514
+ Line 585
  Line 514
  Line 585
  : output-c ( -- )
   ." I_" c-name 2@ type ." :     /* " forth-name 2@ type ."  ( " stack-string 2@ type ."  ) */" cr
   ." /* " doc 2@ type ."  */" cr
+  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
   ." {" cr
   ." DEF_CA" cr
   declarations
   compute-offsets \ for everything else
+  ." NEXT_P0;" cr
   flush-tos
   fetches
-  stack-pointer-updates cr
+  stack-pointer-updates
-  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
   ." {" cr
+  ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
   c-code 2@ type
   ." }" cr
   ." NEXT_P1;" cr
   stores
   fill-tos
-  ." NEXT1_P2;" cr
+  ." NEXT_P2;" cr
   ." }" cr
   cr
  ;
+ : output-funclabel ( -- )
+function-number +!
+   ." &I_" c-name 2@ type ." ," cr ;
+ : output-forthname ( -- )
+function-number +!
+   '" emit forth-name 2@ type '" emit ." ," cr ;
+ : output-c-func ( -- )
+function-number +!
+     ." void I_" c-name 2@ type ." ()      /* " forth-name 2@ type
+     ."  ( " stack-string 2@ type ."  ) */" cr
+     ." /* " doc 2@ type ."  */" cr
+     ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr
+     \ debugging
+     ." {" cr
+     ." DEF_CA" cr
+     declarations
+     compute-offsets \ for everything else
+     ." NEXT_P0;" cr
+     flush-tos
+     fetches
+     stack-pointer-updates
+     ." {" cr
+     ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
+     c-code 2@ type
+     ." }" cr
+     ." NEXT_P1;" cr
+     stores
+     fill-tos
+     ." NEXT_P2;" cr
+     ." }" cr
+     cr ;
  : output-label ( -- )
   ." &&I_" c-name 2@ type ." ," cr ;
- : output-alias ( -- )
+ : output-alias ( -- )  flush-comment on
+  ?flush-comment
   primitive-number @ . ." alias " forth-name 2@ type cr
   -1 primitive-number +! ;
- : output-forth ( -- )
+ : output-forth ( -- )  flush-comment on
+     ?flush-comment
   forth-code @ 0=
-  IF    output-alias
+     IF          \ output-alias
+         \ this is bad for ec: an alias is compiled if tho word does not exist!
+         \ JAW
   ELSE  ." : " forth-name 2@ type ."   ( "
         effect-in effect-in-end @ .stack-list ." -- "
         effect-out effect-out-end @ .stack-list ." )" cr
         forth-code 2@ type cr
         -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
+emit
+     space forth-name 2@ type space
+emit
+     name-line @ 0 .r
+     ." ,0" cr ;
+ [IFDEF] documentation
+ : register-doc ( -- )
+     get-current documentation set-current
+     forth-name 2@ nextname create
+     forth-name 2@ 2,
+     stack-string 2@ condition-stack-effect 2,
+     wordset 2@ 2,
+     c-name 2@ condition-pronounciation 2,
+     doc 2@ 2,
+     set-current ;
+ [THEN]
  : process-file ( addr u xt -- )
-  >r r/o open-file abort" cannot open file"
+     >r
+dup filename 2!
+function-number !
+     r/o open-file abort" cannot open file"
   warnings @ if
   ." ------------ CUT HERE -------------" cr  endif
   r> primfilter ;
+ : process      ( xt -- )
+     bl word count rot
+     process-file ;

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



Removed from v.1.8
 


changed lines


 
Added in v.1.30
 Legend:



Removed from v.1.8
 


changed lines


 
Added in v.1.30
-Removed from v.1.8
+Added in v.1.30

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.8 and 1.30

ViewCVS and CVS Help