--- gforth/prims2x.fs	2000/11/10 10:04:20	1.49
+++ gforth/prims2x.fs	2000/11/14 10:36:02	1.52
@@ -103,6 +103,7 @@ end-struct stack%
 
 s" sp" save-mem s" (Cell)" make-stack data-stack 
 s" fp" save-mem s" "       make-stack fp-stack
+s" rp" save-mem s" (Cell)" make-stack return-stack
 \ !! initialize stack-in and stack-out
 
 \ stack items
@@ -245,10 +246,13 @@ eof-char singleton					charclass eof
 
 
 (( letter (( letter || digit )) **
-)) <- c-name ( -- )
+)) <- c-ident ( -- )
+
+(( ` # ?? (( letter || digit || ` : )) **
+)) <- stack-ident ( -- )
 
 (( nowhitebq nowhite ** ))
-<- name ( -- )
+<- forth-ident ( -- )
 
 Variable forth-flag
 Variable c-flag
@@ -283,17 +287,20 @@ Variable c-flag
 
 (( ` \ comment-body nl )) <- comment ( -- )
 
-(( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick init-item item% %size + }} white ** )) ** {{ effect-in-end ! }}
+(( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
+<- stack-items
+
+(( {{ effect-in }}  stack-items {{ effect-in-end ! }}
    ` - ` - white **
-   {{ effect-out }} (( {{ start }} c-name {{ end 2 pick init-item item% %size + }} white ** )) ** {{ effect-out-end ! }}
+   {{ effect-out }} stack-items {{ effect-out-end ! }}
 )) <- stack-effect ( -- )
 
 (( {{ s" " doc 2! s" " forth-code 2! }}
    (( {{ line @ name-line ! filename 2@ name-filename 2! }}
-      {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  white ++
+      {{ start }} forth-ident {{ end 2dup forth-name 2! c-name 2! }}  white ++
       ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white **
-        {{ start }} name {{ end wordset 2! }} white **
-        (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl
+        {{ start }} forth-ident {{ end wordset 2! }} white **
+        (( {{ start }}  c-ident {{ end c-name 2! }} )) ??  nl
    ))
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! skipsynclines on }}
@@ -430,7 +437,20 @@ end-struct type%
 \ allocate a string
  here swap dup allot move ;
 
-: starts-with { addr u xt1 xt2 n stack -- } ( "prefix" -- )
+wordlist constant prefixes
+
+: declare ( addr "name" -- )
+\ remember that there is a stack item at addr called name
+ create , ;
+
+: !default ( w addr -- )
+    dup @ if
+	2drop \ leave nonzero alone
+    else
+	!
+    endif ;
+
+: create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
     \ describes a type
     \ addr u specifies the C type name
     \ stack effect entries of the type start with prefix
@@ -442,59 +462,44 @@ end-struct type%
     stack r@ type-stack !
     rdrop ;
 
-wordlist constant types
-get-current
-types set-current
-
-s" Bool"	single-type starts-with f
-s" Char"	single-type starts-with c
-s" Cell"	single-type starts-with n
-s" Cell"	single-type starts-with w
-s" UCell"	single-type starts-with u
-s" DCell"	double-type starts-with d
-s" UDCell"	double-type starts-with ud
-s" Float"	float-type  starts-with r
-s" Cell *"	single-type starts-with a_
-s" Char *"	single-type starts-with c_
-s" Float *"	single-type starts-with f_
-s" DFloat *"	single-type starts-with df_
-s" SFloat *"	single-type starts-with sf_
-s" Xt"		single-type starts-with xt
-s" WID"		single-type starts-with wid
-s" struct F83Name *"	single-type starts-with f83name
-
-set-current
-
-: get-type ( addr1 u1 -- type-descr )
-\ get the type of the name in addr1 u1
-\ type-descr is a pointer to a type-descriptor
- 0 swap ?do
-   dup i types search-wordlist
-   if \ ok, we have the type ( addr1 xt )
-     execute nip
-     UNLOOP EXIT
-   endif
- -1 s+loop
- \ we did not find a type, abort
- true abort" unknown type prefix" ;
+: type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
+    create-type
+does> ( item -- )
+    \ initialize item
+    { item typ }
+    typ item item-type !
+    typ type-stack @ item item-stack !default
+    item item-name 2@ items @ search-wordlist 0= if \ new name
+	item item-name 2@ 2dup nextname item declare
+	typ type-c-name 2@ type space type  ." ;" cr
+    else
+	drop
+    endif ;
 
-: declare ( addr "name" -- )
-\ remember that there is a stack item at addr called name
- create , ;
+: execute-prefix ( item addr1 u1 -- )
+    \ execute the word ( item -- ) associated with the longest prefix
+    \ of addr1 u1
+    0 swap ?do
+	dup i prefixes search-wordlist
+	if \ ok, we have the type ( item addr1 xt )
+	    nip execute
+	    UNLOOP EXIT
+	endif
+	-1 s+loop
+    \ we did not find a type, abort
+    true abort" unknown prefix" ;
 
 : declaration ( item -- )
- dup item-name 2@ items @ search-wordlist
- if \ already declared ( item xt )
-     execute @ 2dup item-type @ swap item-type !
-     item-stack @ swap item-stack ! \ !! does not generalize to stack prefixes
- else ( addr )
-   dup item-name 2@ nextname dup declare ( addr )
-   dup >r item-name 2@ 2dup get-type ( addr1 u type-descr )
-   dup type-stack @ r@ item-stack ! \ !! only if item-stack @ 0=
-   dup r> item-type ! ( addr1 u type-descr )
-   type-c-name 2@ type space type ." ;" cr
- endif ;
+    dup item-name 2@ execute-prefix ;
 
+: stack-prefix ( stack "prefix" -- )
+    name tuck nextname create ( stack length ) 2,
+does> ( item -- )
+    2@ { item stack prefix-length }
+    item item-name 2@ prefix-length /string item item-name 2!
+    stack item item-stack !
+    item declaration ;
+    
 : declaration-list ( addr1 addr2 -- )
  swap ?do
   i declaration
@@ -505,6 +510,30 @@ set-current
  effect-in effect-in-end @ declaration-list
  effect-out effect-out-end @ declaration-list ;
 
+get-current
+prefixes set-current
+
+s" Bool"	single-type type-prefix f
+s" Char"	single-type type-prefix c
+s" Cell"	single-type type-prefix n
+s" Cell"	single-type type-prefix w
+s" UCell"	single-type type-prefix u
+s" DCell"	double-type type-prefix d
+s" UDCell"	double-type type-prefix ud
+s" Float"	float-type  type-prefix r
+s" Cell *"	single-type type-prefix a_
+s" Char *"	single-type type-prefix c_
+s" Float *"	single-type type-prefix f_
+s" DFloat *"	single-type type-prefix df_
+s" SFloat *"	single-type type-prefix sf_
+s" Xt"		single-type type-prefix xt
+s" WID"		single-type type-prefix wid
+s" struct F83Name *"	single-type type-prefix f83name
+
+return-stack stack-prefix R:
+
+set-current
+
 \ offset computation
 \ the leftmost (i.e. deepest) item has offset 0
 \ the rightmost item has the highest offset
@@ -526,7 +555,7 @@ set-current
 
 
 : compute-offsets ( -- )
-    data-stack clear-stack  fp-stack clear-stack
+    data-stack clear-stack  fp-stack clear-stack return-stack clear-stack
     effect-in  effect-in-end  @ ['] stack-in  compute-list
     effect-out effect-out-end @ ['] stack-out compute-list ;
 
@@ -538,8 +567,9 @@ set-current
     endif ;
 
 : flush-tos ( -- )
-    data-stack flush-a-tos
-    fp-stack   flush-a-tos ;
+    data-stack   flush-a-tos
+    fp-stack     flush-a-tos
+    return-stack flush-a-tos ;
 
 : fill-a-tos { stack -- }
     stack stack-out @ 0= stack stack-in @ 0<> and
@@ -549,8 +579,9 @@ set-current
     endif ;
 
 : fill-tos ( -- )
-    fp-stack   fill-a-tos
-    data-stack fill-a-tos ;
+    fp-stack     fill-a-tos
+    data-stack   fill-a-tos
+    return-stack fill-a-tos ;
 
 : fetch ( addr -- )
  dup item-type @ type-fetch @ execute ;
@@ -568,8 +599,9 @@ set-current
     endif ;
 
 : stack-pointer-updates ( -- )
-    data-stack stack-pointer-update
-    fp-stack   stack-pointer-update ;
+    data-stack   stack-pointer-update
+    fp-stack     stack-pointer-update
+    return-stack stack-pointer-update ;
 
 : store ( item -- )
 \ f is true if the item should be stored
@@ -581,6 +613,25 @@ set-current
    i store
  item% %size +loop ; 
 
+: output-c-tail ( -- )
+    \ the final part of the generated C code
+    ." NEXT_P1;" cr
+    stores
+    fill-tos
+    ." NEXT_P2;" cr ;
+
+: type-c ( c-addr u -- )
+    \ like TYPE, but replaces "TAIL;" with tail code
+    begin ( c-addr1 u1 )
+	2dup s" TAIL;" search
+    while ( c-addr1 u1 c-addr3 u3 )
+	2dup 2>r drop nip over - type
+	output-c-tail
+	2r> 5 /string
+	\ !! resync #line missing
+    repeat
+    2drop type ;
+
 : output-c ( -- ) 
  ." I_" c-name 2@ type ." :	/* " forth-name 2@ type ."  ( " stack-string 2@ type ." ) */" cr
  ." /* " doc 2@ type ."  */" cr
@@ -595,12 +646,9 @@ set-current
  stack-pointer-updates
  ." {" cr
  ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
- c-code 2@ type
+ c-code 2@ type-c
  ." }" cr
- ." NEXT_P1;" cr
- stores
- fill-tos
- ." NEXT_P2;" cr
+ output-c-tail
  ." }" cr
  cr
 ;
@@ -627,8 +675,9 @@ set-current
     ." {" cr
     declarations
     compute-offsets \ for everything else
-    data-stack stack-used? IF ." Cell *sp=SP;" cr THEN
-    fp-stack   stack-used? IF ." Cell *fp=*FP;" cr THEN
+    data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
+    fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
+    return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
     flush-tos
     fetches
     stack-pointer-updates