--- gforth/prims2x.fs	1994/05/07 14:56:04	1.1
+++ gforth/prims2x.fs	1995/11/07 18:06:57	1.16
@@ -1,3 +1,24 @@
+\ 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:
@@ -19,8 +40,11 @@
 \ regarding problem 1 above: It would be better (for over) to implement
 \ 	the alternative
 
+warnings off
+
+[IFUNDEF] vocabulary    include search-order.fs [THEN]
+[IFUNDEF] environment?  include environ.fs      [THEN]
 include gray.fs
-include search-order.fs
 
 100 constant max-effect \ number of things on one side of a stack effect
 4096 constant batch-size \ no meaning, just make sure it's >0
@@ -35,7 +59,7 @@ maxchar 1+ constant eof-char
   begin ( c-addr file-id )
     2dup batch-size swap read-file 
     if
-      abort" I/O error"
+      true abort" I/O error"
     endif
     ( c-addr file-id actual-size ) rot over + -rot
     batch-size <>
@@ -87,7 +111,7 @@ variable effect-out-end ( pointer )
 2variable effect-in-size
 2variable effect-out-size
 
-variable primitive-number -8 primitive-number !
+variable primitive-number -10 primitive-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
@@ -195,7 +219,9 @@ nowhite ++
 
 (( (( primitive {{ printprim }} )) **  eof ))
 parser primitives2something
+warnings @ [IF]
 .( parser generated ok ) cr
+[THEN]
 
 : primfilter ( file-id xt -- )
 \ fileid is for the input file, xt ( -- ) is for the output word
@@ -204,6 +230,7 @@ parser primitives2something
  here swap read-whole-file
  dup endinput !
  here - allot
+ align
  primitives2something ;
 
 \ types
@@ -220,7 +247,7 @@ constant type-description
 \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  drop swap - 1- dup
  if
-   ." sp[" . ." ]"
+   ." sp[" 0 .r ." ]"
  else
    drop ." TOS"
  endif ;
@@ -229,29 +256,32 @@ constant type-description
 \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  nip swap - 1- dup
  if
-   ." fp[" . ." ]"
+   ." fp[" 0 .r ." ]"
  else
    drop ." FTOS"
  endif ;
 
 : fetch-single ( item -- )
  >r
- r@ item-name 2@ type ."  = (" 
+ r@ item-name 2@ type
+ ."  = (" 
  r@ item-type @ type-c-name 2@ type ." ) "
  r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
  rdrop ; 
 
 : fetch-double ( item -- )
  >r
- ." {Double_Store _d; _d.cells.low = "
+ r@ item-name 2@ type 
+ ." = ({Double_Store _d; _d.cells.low = "
  r@ item-d-offset @ dup    effect-in-size 2@ data-stack-access
- ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access ." ; "
- r@ item-name 2@ type ."  = _d.dcell;}" cr
+ ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access
+ ." ; _d.dcell;});" cr
  rdrop ;
 
 : fetch-float ( item -- )
  >r
- r@ item-name 2@ type ."  = "
+ r@ item-name 2@ type
+ ."  = "
  \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
  r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
  rdrop ;
@@ -260,9 +290,7 @@ constant type-description
 \ f is true iff the offset of item is the same as on input
  >r
  r@ item-name 2@ items @ search-wordlist 0=
- if
-   ." bug" cr abort
- endif
+ abort" bug"
  execute @
  dup r@ =
  if \ item first appeared in output
@@ -300,17 +328,15 @@ constant type-description
  >r
  ." {Double_Store _d; _d.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
- ." =  _d.cells.high;}" cr
+ ."  = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
+ ." = _d.cells.high;}" cr
  rdrop ;
 
 : f-same-as-in? ( item -- f )
 \ f is true iff the offset of item is the same as on input
  >r
  r@ item-name 2@ items @ search-wordlist 0=
- if
-   ." bug" cr abort
- endif
+ abort" bug"
  execute @
  dup r@ =
  if \ item first appeared in output
@@ -343,13 +369,13 @@ constant type-description
  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 -- )
@@ -402,7 +428,7 @@ set-current
    endif
  -1 s+loop
  \ we did not find a type, abort
- ." unknown type prefix" cr ABORT ;
+ true abort" unknown type prefix" ;
 
 : declare ( addr "name" -- )
 \ remember that there is a stack item at addr called name
@@ -424,6 +450,9 @@ set-current
   i declaration
  item-descr +loop ;
 
+: fetch ( addr -- )
+ dup item-type @ type-fetch-handler execute ;
+
 : declarations ( -- )
  wordlist dup items ! set-current
  effect-in effect-in-end @ declaration-list
@@ -475,22 +504,19 @@ set-current
    ." IF_TOS(TOS = sp[0]);" cr
  endif ;
 
-: fetch ( addr -- )
- dup item-type @ type-fetch-handler execute ;
-
 : fetches ( -- )
  effect-in-end @ effect-in ?do
    i fetch
  item-descr +loop ; 
 
 : stack-pointer-updates ( -- )
-\ we do not check if an update is a noop; gcc does this for us
+\ we need not check if an update is a noop; gcc does this for us
  effect-in-size 2@
  effect-out-size 2@
  rot swap - ( d-in d-out f-diff )
  rot rot - ( f-diff d-diff )
- ." sp += " . ." ;" cr
- ." fp += " . ." ;" cr ;
+ ?dup IF  ." sp += " 0 .r ." ;" cr  THEN
+ ?dup IF  ." fp += " 0 .r ." ;" cr  THEN ;
 
 : store ( item -- )
 \ f is true if the item should be stored
@@ -502,24 +528,30 @@ set-current
    i store
  item-descr +loop ; 
 
+: .stack-list ( start end -- )
+ swap ?do
+   i item-name 2@ type space
+ item-descr +loop ; 
+
 : output-c ( -- )
- ." I_" c-name 2@ type ." : /* " forth-name 2@ type ."  ( " stack-string 2@ type ."  ) */" cr
+ ." 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
- ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
  ." {" cr
  c-code 2@ type
  ." }" cr
  ." NEXT_P1;" cr
  stores
  fill-tos
- ." NEXT1_P2;" cr
+ ." NEXT_P2;" cr
  ." }" cr
  cr
 ;
@@ -531,10 +563,31 @@ set-current
  primitive-number @ . ." alias " forth-name 2@ type cr
  -1 primitive-number +! ;
 
+: output-forth ( -- )
+ forth-code @ 0=
+ IF    output-alias
+ 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 ;
+
+[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
- if
-   ." cannot open file" cr abort
- endif
- ." ------------ CUT HERE -------------" cr
+ >r r/o open-file abort" cannot open file"
+ warnings @ if
+ ." ------------ CUT HERE -------------" cr  endif
  r> primfilter ;
+