--- gforth/prims2x.fs	2001/01/09 16:11:36	1.63
+++ gforth/prims2x.fs	2001/01/18 16:44:15	1.66
@@ -68,7 +68,8 @@ variable rawinput \ pointer to next char
 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
-1 line !
+variable line-start \ pointer to start of current line (for error messages)
+0 line !
 2variable filename \ filename of original input file
 0 0 filename 2!
 2variable f-comment
@@ -103,6 +104,7 @@ struct%
  cell%    field item-stack  \ descriptor for the stack used, 0 is default
  cell%    field item-type   \ descriptor for the item type
  cell%    field item-offset \ offset in stack items, 0 for the deepest element
+ cell%	  field item-first  \ true if this is the first occurence of the item
 end-struct item%
 
 struct%
@@ -140,6 +142,12 @@ s" IP" save-mem s" error don't use # on
     dup item% %size erase
     item-name 2! ;
 
+: map-items { addr end xt -- }
+    \ perform xt for all items in array addr...end
+    end addr ?do
+	i xt execute
+    item% %size +loop ;
+
 \ various variables for storing stuff of one primitive
 
 2variable forth-name
@@ -219,11 +227,22 @@ print-token !
     endif
     drop ;
 
+: print-error-line ( -- )
+    \ print the current line and position
+    line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
+    over - type cr
+    line-start @ rawinput @ over - typewhite ." ^" cr ;
+    
 : ?nextchar ( f -- )
     ?not? if
-	filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
-	getinput . cr
-	rawinput @ endrawinput @ over - 100 min type cr
+	outfile-id >r try
+	    stderr to outfile-id
+	    filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
+	    getinput . cr
+	    print-error-line
+	    0
+	recover endtry
+	r> to outfile-id throw
 	abort
     endif
     rawinput @ endrawinput @ <> if
@@ -232,6 +251,7 @@ print-token !
 	1 chars cookedinput +!
 	nl-char = if
 	    checksyncline
+	    rawinput @ line-start !
 	endif
 	rawinput @ c@ cookedinput @ c!
     endif ;
@@ -343,7 +363,7 @@ warnings @ [IF]
 : primfilter ( file-id xt -- )
 \ fileid is for the input file, xt ( -- ) is for the output word
  output !
- here dup rawinput ! cookedinput !
+ here dup rawinput ! dup line-start ! cookedinput !
  here unused rot read-file throw
  dup here + endrawinput !
  allot
@@ -483,10 +503,12 @@ does> ( item -- )
     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
+	item item-name 2@ nextname item declare
+	item item-first on
+	\ typ type-c-name 2@ type space type  ." ;" cr
     else
 	drop
+	item item-first off
     endif ;
 
 : execute-prefix ( item addr1 u1 -- )
@@ -505,6 +527,24 @@ does> ( item -- )
 : declaration ( item -- )
     dup item-name 2@ execute-prefix ;
 
+: declaration-list ( addr1 addr2 -- )
+    ['] declaration map-items ;
+
+: declarations ( -- )
+ wordlist dup items ! set-current
+ effect-in effect-in-end @ declaration-list
+ effect-out effect-out-end @ declaration-list ;
+
+: print-declaration { item -- }
+    item item-first @ if
+	item item-type @ type-c-name 2@ type space
+	item item-name 2@ type ." ;" cr
+    endif ;
+
+: print-declarations ( -- )
+    effect-in  effect-in-end  @ ['] print-declaration map-items
+    effect-out effect-out-end @ ['] print-declaration map-items ;
+    
 : stack-prefix ( stack "prefix" -- )
     name tuck nextname create ( stack length ) 2,
 does> ( item -- )
@@ -512,16 +552,6 @@ does> ( item -- )
     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
- item% %size +loop ;
-
-: declarations ( -- )
- wordlist dup items ! set-current
- effect-in effect-in-end @ declaration-list
- effect-out effect-out-end @ declaration-list ;
 
 \ offset computation
 \ the leftmost (i.e. deepest) item has offset 0
@@ -533,11 +563,11 @@ does> ( item -- )
     item item-stack @ xt execute dup @ >r +!
     r> item item-offset ! ;
 
-: compute-list ( addr1 addr2 xt -- )
-    { xt }
-    swap u+do
-	i xt compute-offset
-    item% %size +loop ;
+: compute-offset-in ( addr1 addr2 -- )
+    ['] stack-in compute-offset ;
+
+: compute-offset-out ( addr1 addr2 -- )
+    ['] stack-out compute-offset ;
 
 : clear-stack { -- }
     dup stack-in off stack-out off ;
@@ -545,8 +575,8 @@ does> ( item -- )
 : compute-offsets ( -- )
     data-stack clear-stack  fp-stack clear-stack return-stack clear-stack
     inst-stream clear-stack
-    effect-in  effect-in-end  @ ['] stack-in  compute-list
-    effect-out effect-out-end @ ['] stack-out compute-list
+    effect-in  effect-in-end  @ ['] compute-offset-in  map-items
+    effect-out effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0<> abort" # can only be on the input side" ;
 
 : flush-a-tos { stack -- }
@@ -578,9 +608,7 @@ does> ( item -- )
  dup item-type @ type-fetch @ execute ;
 
 : fetches ( -- )
- effect-in-end @ effect-in ?do
-   i fetch
- item% %size +loop ; 
+    effect-in effect-in-end @ ['] fetch map-items ;
 
 : stack-pointer-update { stack -- }
     \ stack grow downwards
@@ -606,9 +634,7 @@ does> ( item -- )
  dup item-type @ type-store @ execute ;
 
 : stores ( -- )
- effect-out-end @ effect-out ?do
-   i store
- item% %size +loop ; 
+    effect-out effect-out-end @ ['] store map-items ;
 
 : output-c-tail ( -- )
     \ the final part of the generated C code
@@ -640,9 +666,7 @@ does> ( item -- )
 : print-debug-args ( -- )
     ." #ifdef VM_DEBUG" cr
     ." if (vm_debug) {" cr
-    effect-in-end @ effect-in ?do
-	i print-debug-arg
-	item% %size +loop
+    effect-in effect-in-end @ ['] print-debug-arg map-items
     ." fputc('\n', vm_out);" cr
     ." }" cr
     ." #endif" cr ;
@@ -655,6 +679,7 @@ does> ( item -- )
  ." DEF_CA" cr
  declarations
  compute-offsets \ for everything else
+ print-declarations
  ." NEXT_P0;" cr
  flush-tos
  fetches
@@ -678,9 +703,7 @@ does> ( item -- )
     endif ;
 
 : disasm-args ( -- )
- effect-in-end @ effect-in ?do
-   i disasm-arg
- item% %size +loop ; 
+    effect-in effect-in-end @ ['] disasm-arg map-items ;
 
 : output-disasm ( -- )
     \ generate code for disassembling VM instructions
@@ -700,9 +723,7 @@ does> ( item -- )
     endif ;
 
 : gen-args-parm ( -- )
- effect-in-end @ effect-in ?do
-   i gen-arg-parm
- item% %size +loop ; 
+    effect-in effect-in-end @ ['] gen-arg-parm map-items ;
 
 : gen-arg-gen { item -- }
     item item-stack @ inst-stream = if
@@ -711,9 +732,7 @@ does> ( item -- )
     endif ;
 
 : gen-args-gen ( -- )
- effect-in-end @ effect-in ?do
-   i gen-arg-gen
- item% %size +loop ; 
+    effect-in effect-in-end @ ['] gen-arg-gen map-items ;
 
 : output-gen ( -- )
     \ generate C code for generating VM instructions
@@ -748,6 +767,7 @@ does> ( item -- )
     ." {" cr
     declarations
     compute-offsets \ for everything else
+    print-declarations
     inst-stream  stack-used? IF ." Cell *ip=IP;" cr THEN
     data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
     fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN