gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.12 and 1.48

-version 1.12, Thu Feb  2 18:13:10 1995 UTC
+version 1.48, Sat Sep 23 15:46:58 2000 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.
+ \ 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., 59 Temple Place, Suite 330, Boston, MA 02111, 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]
+ [IFUNDEF] vocabulary    \ we are executed just with kernel image
- [IFUNDEF] environment?  include environ.fs      [THEN]
+                         \ load the rest that is needed
- include gray.fs
+                         \ (require fails because this file is needed from a
+                         \ different directory with the wordlibraries)
+ include ./search.fs
+ include ./extend.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 )
-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
  : start ( -- addr )
-  input @ ;
+  cookedinput @ ;
  : end ( addr -- addr u )
-  input @ over - ;
+  cookedinput @ over - ;
  variable output \ xt ( -- ) of output word
- Line 89
+ Line 115
  Line 89
  Line 115
  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 110
+ Line 142
  Line 110
  Line 142
  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 130
+ Line 161
  Line 130
  Line 161
   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 153
+ Line 210
  Line 153
  Line 210
  : ` ( -- 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
- bl singleton                                            charclass blank
+ bl singleton tab-char over add-member                   charclass white
- tab-char singleton                                      charclass tab
  nl-char singleton eof-char over add-member complement   charclass nonl
- nl-char singleton eof-char over add-member char : over add-member complement  charclass nocolonnl
+ nl-char singleton eof-char over add-member
+     char : over add-member complement                   charclass nocolonnl
+ bl 1+ maxchar .. char \ singleton complement intersection
+                                                         charclass nowhitebq
  bl 1+ maxchar ..                                        charclass nowhite
  char " singleton eof-char over add-member complement    charclass noquote
  nl-char singleton                                       charclass nl
- Line 170
+ Line 229
  Line 170
  Line 229
  (( letter (( letter || digit )) **
  )) <- c-name ( -- )
- nowhite ++
+ (( nowhitebq nowhite ** ))
  <- name ( -- )
- (( ` \ nonl ** nl
+ Variable forth-flag
- )) <- comment ( -- )
+ Variable c-flag
- (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
+ (( (( ` f || ` F )) {{ start }} nonl **
-    ` - ` - blank **
+    {{ end forth-flag @ IF type cr ELSE 2drop THEN }}
-    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
+ )) <- forth-comment ( -- )
+ (( (( ` c || ` C )) {{ start }} nonl **
+    {{ end c-flag @ IF type cr ELSE 2drop THEN }}
+ )) <- c-comment ( -- )
+ (( ` - nonl ** {{
+         forth-flag @ IF ." [ELSE]" cr THEN
+         c-flag @ IF ." #else" cr THEN }}
+ )) <- else-comment
+ (( ` + {{ start }} nonl ** {{ end
+         dup
+         IF      c-flag @
+                 IF    ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
+                 THEN
+                 forth-flag @
+                 IF  ." has? " type ."  [IF]"  cr THEN
+         ELSE    2drop
+             c-flag @      IF  ." #endif"  cr THEN
+             forth-flag @  IF  ." [THEN]"  cr THEN
+         THEN }}
+ )) <- if-comment
+ (( (( forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body
+ (( ` \ comment-body nl )) <- comment ( -- )
+ (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} white ** )) ** {{ effect-in-end ! }}
+    ` - ` - white **
+    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} white ** )) ** {{ effect-out-end ! }}
  )) <- stack-effect ( -- )
  (( {{ s" " doc 2! s" " forth-code 2! }}
-    (( comment || nl )) **
+    (( {{ line @ name-line ! filename 2@ name-filename 2! }}
-    (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++
+       {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  white ++
-       {{ start }} stack-effect {{ end stack-string 2! }} tab ++
+       ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white **
-         {{ start }} name {{ end wordset 2! }} tab **
+         {{ start }} name {{ end wordset 2! }} white **
          (( {{ 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! }}
-    )) ??
+    )) ?? {{ printprim }}
     (( nl || eof ))
  )) <- primitive ( -- )
- (( (( primitive {{ printprim }} )) **  eof ))
+ (( (( comment || primitive || nl )) ** eof ))
  parser primitives2something
  warnings @ [IF]
  .( parser generated ok ) cr
- Line 205
+ Line 294
  Line 205
  Line 294
  : 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
+  here unused rot read-file throw
-  dup endinput !
+  dup here + endrawinput !
-  here - allot
+  allot
   align
+  checksyncline
+ \ begin
+ \     getinput dup eof-char = ?EXIT emit true ?nextchar
+ \ again ;
   primitives2something ;
  \ types
- Line 250
+ Line 343
  Line 250
  Line 343
  : 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 283
+ Line 376
  Line 283
  Line 376
  \ true if item has the same offset as the input TOS
   item-d-offset @ 1+ effect-in-size 2@ drop = ;
+ : is-out-tos? ( item -- f )
+ \ true if item has the same offset as the input TOS
+  item-d-offset @ 1+ effect-out-size 2@ drop = ;
  : really-store-single ( item -- )
   >r
   r@ item-d-offset @ effect-out-size 2@ data-stack-access ."  = (Cell)"
- Line 293
+ Line 390
  Line 293
  Line 390
   >r
   r@ d-same-as-in?
   if
-    r@ is-in-tos?
+    r@ is-in-tos? r@ is-out-tos? xor
     if
       ." IF_TOS(" r@ really-store-single ." );" cr
     endif
- Line 305
+ Line 402
  Line 305
  Line 402
  : 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 392
+ Line 489
  Line 392
  Line 489
  s" SFloat *"    single-type starts-with sf_
  s" Xt"          single-type starts-with xt
  s" WID"         single-type starts-with wid
- s" F83Name *"   single-type starts-with f83name
+ s" struct F83Name *"    single-type starts-with f83name
  set-current
- Line 463
+ Line 560
  Line 463
  Line 560
  : flush-tos ( -- )
   effect-in-size 2@ effect-out-size 2@
-  rot - swap rot - ( -f-diff -d-diff ) >r >r
-  effect-in-size 2@ effect-out-size 2@
 <> rot 0= and
   if
-    ." IF_FTOS(fp[" r@ 0 .r ." ] = FTOS);" cr
+    ." IF_FTOS(fp[0] = FTOS);" cr
-  endif  rdrop
+  endif
 <> swap 0= and
   if
-    ." IF_TOS(sp[" r@ 0 .r ." ] = TOS);" cr
+    ." IF_TOS(sp[0] = TOS);" cr
-  endif  rdrop ;
+  endif ;
  : fill-tos ( -- )
   effect-in-size 2@ effect-out-size 2@
- Line 517
+ Line 612
  Line 517
  Line 612
  : 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
-  flush-tos
   stores
   fill-tos
   ." NEXT_P2;" cr
- Line 536
+ Line 633
  Line 536
  Line 633
   cr
  ;
+ : dstack-used?
+   effect-in-size 2@ drop
+   effect-out-size 2@ drop max 0<> ;
+ : fstack-used?
+   effect-in-size 2@ nip
+   effect-out-size 2@ nip max 0<> ;
+ : output-funclabel ( -- )
+function-number +!
+   ." &I_" c-name 2@ type ." ," cr ;
+ : output-forthname ( -- )
+function-number +!
+   '" emit forth-name 2@ type '" emit ." ," cr ;
+ : output-c-func ( -- )
+ \ used for word libraries
+function-number +!
+     ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP)      /* " 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
+     declarations
+     compute-offsets \ for everything else
+     dstack-used? IF ." Cell *sp=SP;" cr THEN
+     fstack-used? IF ." Cell *fp=*FP;" cr THEN
+     flush-tos
+     fetches
+     stack-pointer-updates
+     fstack-used? IF ." *FP=fp;" cr THEN
+     ." {" cr
+     ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
+     c-code 2@ type
+     ." }" cr
+     stores
+     fill-tos
+     ." return (sp);" cr
+     ." }" cr
+     cr ;
  : output-label ( -- )
-  ." &&I_" c-name 2@ type ." ," cr ;
+     ." (Label)&&I_" c-name 2@ type ." ," cr
+     -1 primitive-number +! ;
  : output-alias ( -- )
-  primitive-number @ . ." alias " forth-name 2@ type cr
+     ( primitive-number @ . ." alias " ) ." Primitive " forth-name 2@ type cr
   -1 primitive-number +! ;
  : output-forth ( -- )
   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
- Line 553
+ Line 696
  Line 553
  Line 696
         -1 primitive-number +!
   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@ 2,
+     stack-string 2@ condition-stack-effect 2,
      wordset 2@ 2,
-     c-name 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.12
 


changed lines


 
Added in v.1.48
 Legend:



Removed from v.1.12
 


changed lines


 
Added in v.1.48
-Removed from v.1.12
+Added in v.1.48

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.12 and 1.48

ViewCVS and CVS Help