--- gforth/prims2x.fs	2001/02/09 20:15:31	1.80
+++ gforth/prims2x.fs	2001/02/24 17:24:44	1.84
@@ -101,6 +101,13 @@ skipsynclines on
     loop
     drop ;
 
+: insert-wordlist { c-addr u wordlist xt -- }
+    \ adds name "addr u" to wordlist using defining word xt
+    \ xt may cause additional stack effects
+    get-current >r wordlist set-current
+    c-addr u nextname xt execute
+    r> set-current ;
+
 : start ( -- addr )
  cookedinput @ ;
 
@@ -131,9 +138,6 @@ skipsynclines on
 variable output          \ xt ( -- ) of output word for simple primitives
 variable output-combined \ xt ( -- ) of output word for combined primitives
 
-: printprim ( -- )
- output @ execute ;
-
 struct%
     cell%    field stack-number \ the number of this stack
     cell% 2* field stack-pointer \ stackpointer name
@@ -205,6 +209,7 @@ struct%
     cell% 2* field prim-c-code
     cell% 2* field prim-forth-code
     cell% 2* field prim-stack-string
+    cell%    field prim-num            \ ordinal number
     cell%    field prim-items-wordlist \ unique items
     item% max-effect * field prim-effect-in
     item% max-effect * field prim-effect-out
@@ -228,6 +233,9 @@ variable in-part \ true if processing a
 create combined-prims max-combined cells allot
 variable num-combined
 
+table constant combinations
+  \ the keys are the sequences of pointers to primitives
+
 create current-depth max-stacks cells allot
 create max-depth     max-stacks cells allot
 create min-depth     max-stacks cells allot
@@ -235,10 +243,7 @@ create min-depth     max-stacks cells al
 wordlist constant primitives
 
 : create-prim ( prim -- )
-    get-current >r
-    primitives set-current
-    dup prim-name 2@ nextname constant
-    r> set-current ;
+    dup prim-name 2@ primitives ['] constant insert-wordlist ;
 
 : stack-in ( stack -- addr )
     \ address of number of stack items in effect in
@@ -447,7 +452,7 @@ does> ( item -- )
 	endif
 	-1 s+loop
     \ we did not find a type, abort
-    true abort" unknown prefix" ;
+    false s" unknown prefix" ?print-error ;
 
 : declaration ( item -- )
     dup item-name 2@ execute-prefix ;
@@ -479,13 +484,14 @@ does> ( item -- )
     item declaration ;
 
 \ types pointed to by stacks for use in combined prims
-s" Cell"  single 0 create-type cell-type
-s" Float" single 0 create-type float-type
-
-s" sp" save-mem cell-type  s" (Cell)" make-stack data-stack 
-s" fp" save-mem float-type s" "       make-stack fp-stack
-s" rp" save-mem cell-type  s" (Cell)" make-stack return-stack
-s" IP" save-mem cell-type  s" error don't use # on results" make-stack inst-stream
+\ !! output-c-combined shouldn't use these names!
+s" Cell"  single 0 create-type w
+s" Float" single 0 create-type r
+
+s" sp" save-mem w s" (Cell)" make-stack data-stack 
+s" fp" save-mem r s" "       make-stack fp-stack
+s" rp" save-mem w s" (Cell)" make-stack return-stack
+s" IP" save-mem w s" error don't use # on results" make-stack inst-stream
 ' inst-in-index inst-stream stack-in-index-xt !
 ' inst-stream <is> inst-stream-f
 \ !! initialize stack-in and stack-out
@@ -514,7 +520,13 @@ s" IP" save-mem cell-type  s" error don'
     inst-stream clear-stack
     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
-    inst-stream stack-out @ 0<> abort" # can only be on the input side" ;
+    inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
+
+: process-simple ( -- )
+    prim prim { W^ key } key cell
+    combinations ['] constant insert-wordlist
+    declarations compute-offsets
+    output @ execute ;
 
 : flush-a-tos { stack -- }
     stack stack-out @ 0<> stack stack-in @ 0= and
@@ -745,14 +757,12 @@ s" IP" save-mem cell-type  s" error don'
 
 [IFDEF] documentation
 : register-doc ( -- )
-    get-current documentation set-current
-    prim prim-name 2@ nextname create
+    prim prim-name 2@ documentation ['] create insert-wordlist
     prim prim-name 2@ 2,
     prim prim-stack-string 2@ condition-stack-effect 2,
     prim prim-wordset 2@ 2,
     prim prim-c-name 2@ condition-pronounciation 2,
-    prim prim-doc 2@ 2,
-    set-current ;
+    prim prim-doc 2@ 2, ;
 [THEN]
 
 
@@ -888,6 +898,8 @@ s" IP" save-mem cell-type  s" error don'
     loop ;
 
 : process-combined ( -- )
+    combined combined-prims num-combined @ cells
+    combinations ['] constant insert-wordlist
     prim compute-effects
     prim init-effects
     output-combined perform ;
@@ -910,7 +922,8 @@ s" IP" save-mem cell-type  s" error don'
     fetches ;
 
 : part-output-c-tail ( -- )
-    output-c-tail ;
+    stores
+    fill-tos ;
 
 : output-part ( p -- )
     to prim
@@ -954,7 +967,25 @@ s" IP" save-mem cell-type  s" error don'
     cr ;
 
 : output-forth-combined ( -- )
-    ;
+;
+
+
+\ peephole optimization rules
+
+\ in order for this to work as intended, shorter combinations for each
+\ length must be present, and the longer combinations must follow
+\ shorter ones (this restriction may go away in the future).
+  
+: output-peephole ( -- )
+    combined-prims num-combined @ 1- cells combinations search-wordlist
+    s" the prefix for this combination must be defined earlier" ?print-error
+    ." {"
+    execute prim-num @ 5 .r ." ,"
+    combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
+    combined prim-num @ 5 .r ." }, /* "
+    combined prim-c-name 2@ type ."  */"
+    cr ;
+
 
 \ the parser
 
@@ -989,11 +1020,11 @@ print-token !
     endif
     0. 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 c@ [char] " <> 0= s" sync line syntax" ?print-error
 	char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
 	char+
     endif
-    dup c@ nl-char <> abort" sync line syntax"
+    dup c@ nl-char <> 0= s" sync line syntax" ?print-error
     skipsynclines @ if
 	dup char+ rawinput !
 	rawinput @ c@ cookedinput @ c!
@@ -1104,7 +1135,7 @@ Variable c-flag
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }}
    (( ` :  white ** nleof
       {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
-   )) ?? {{  declarations compute-offsets printprim 1 function-number +! }}
+   )) ?? {{ process-simple }}
    nleof
 )) <- simple-primitive ( -- )
 
@@ -1115,8 +1146,9 @@ Variable c-flag
 
 (( {{ make-prim to prim 0 to combined
       line @ name-line ! filename 2@ name-filename 2!
+      function-number @ prim prim-num !
       start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++
-   (( simple-primitive || combined-primitive ))
+   (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
 )) <- primitive ( -- )
 
 (( (( comment || primitive || nl white ** )) ** eof ))