--- gforth/prims2x.fs	1994/07/07 14:59:26	1.3
+++ gforth/prims2x.fs	1995/02/02 18:13:10	1.12
@@ -21,8 +21,9 @@
 
 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
@@ -37,7 +38,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 <>
@@ -89,7 +90,7 @@ variable effect-out-end ( pointer )
 2variable effect-in-size
 2variable effect-out-size
 
-variable primitive-number -8 primitive-number !
+variable primitive-number -9 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
@@ -241,22 +242,25 @@ constant type-description
 
 : 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 ;
@@ -265,9 +269,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
@@ -313,9 +315,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
@@ -348,13 +348,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 -- )
@@ -407,7 +407,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
@@ -429,6 +429,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
@@ -460,14 +463,16 @@ set-current
 
 : 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@
  0<> rot 0= and
  if
-   ." IF_FTOS(fp[0] = FTOS);" cr
- endif
+   ." IF_FTOS(fp[" r@ 0 .r ." ] = FTOS);" cr
+ endif  rdrop
  0<> swap 0= and
  if
-   ." IF_TOS(sp[0] = TOS);" cr
- endif ;
+   ." IF_TOS(sp[" r@ 0 .r ." ] = TOS);" cr
+ endif  rdrop ;
 
 : fill-tos ( -- )
  effect-in-size 2@ effect-out-size 2@
@@ -480,16 +485,13 @@ 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 )
@@ -507,6 +509,11 @@ 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
  ." /* " doc 2@ type ."  */" cr
@@ -514,7 +521,6 @@ set-current
  ." DEF_CA" cr
  declarations
  compute-offsets \ for everything else
- flush-tos
  fetches
  stack-pointer-updates cr
  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
@@ -522,9 +528,10 @@ set-current
  c-code 2@ type
  ." }" cr
  ." NEXT_P1;" cr
+ flush-tos
  stores
  fill-tos
- ." NEXT1_P2;" cr
+ ." NEXT_P2;" cr
  ." }" cr
  cr
 ;
@@ -536,11 +543,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@ 2,
+    wordset 2@ 2,
+    c-name 2@ 2,
+    doc 2@ 2,
+    set-current ;
+[THEN]
+
 : process-file ( addr u xt -- )
- >r r/o open-file
- if
-   ." cannot open file" cr abort
- endif
+ >r r/o open-file abort" cannot open file"
  warnings @ if
  ." ------------ CUT HERE -------------" cr  endif
  r> primfilter ;
+