lexer, parser: show initial parsing word line as part of lexer-errors

diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
index b3bd3cacdb7f49fe13762d53a6245b4880a35c9d..3b0348aa1016a868e2138799ecf24376d1913cac 100644 (file)
--- a/core/lexer/lexer.factor
+++ b/core/lexer/lexer.factor
@@ -5,7 +5,9 @@ io vectors arrays math.parser combinators continuations
 source-files.errors ;
 IN: lexer
 
-TUPLE: lexer text line line-text line-length column ;
+TUPLE: lexer text line line-text line-length column parsing-words ;
+
+TUPLE: lexer-parsing-word word line line-text column ;
 
 : next-line ( lexer -- )
     dup [ line>> ] [ text>> ] bi ?nth >>line-text
@@ -14,10 +16,23 @@ TUPLE: lexer text line line-text line-length column ;
     0 >>column
     drop ;
 
+: push-parsing-word ( word -- )
+    lexer-parsing-word new
+        swap >>word
+        lexer get [
+            [ line>>      >>line      ]
+            [ line-text>> >>line-text ]
+            [ column>>    >>column    ] tri
+        ] [ parsing-words>> push ] bi ;
+
+: pop-parsing-word ( -- )
+    lexer get parsing-words>> pop drop ;
+
 : new-lexer ( text class -- lexer )
     new
         0 >>line
         swap >>text
+        V{ } clone >>parsing-words
     dup next-line ; inline
 
 : <lexer> ( text -- lexer )
@@ -92,27 +107,46 @@ PREDICATE: unexpected-eof < unexpected
 : parse-tokens ( end -- seq )
     100 <vector> swap (parse-tokens) >array ;
 
-TUPLE: lexer-error line column line-text error ;
+TUPLE: lexer-error line column line-text parsing-words error ;
 
 M: lexer-error error-file error>> error-file ;
 M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
 
 : <lexer-error> ( msg -- error )
     \ lexer-error new
-        lexer get
-        [ line>> >>line ]
-        [ column>> >>column ]
-        [ line-text>> >>line-text ]
-        tri
+        lexer get [
+            [ line>> >>line ]
+            [ column>> >>column ] bi
+        ] [ 
+            [ line-text>> >>line-text ]
+            [ parsing-words>> clone >>parsing-words ] bi
+        ] bi
         swap >>error ;
 
-: lexer-dump ( error -- )
+: simple-lexer-dump ( error -- )
     [ line>> number>string ": " append ]
     [ line-text>> dup string? [ drop "" ] unless ]
     [ column>> 0 or ] tri
     pick length + CHAR: \s <string>
     [ write ] [ print ] [ write "^" print ] tri* ;
 
+: (parsing-word-lexer-dump) ( error parsing-word -- )
+    [
+        line>> number>string
+        over line>> number>string length
+        CHAR: \s pad-head
+        ": " append write
+    ] [ line-text>> dup string? [ drop "" ] unless print ] bi
+    simple-lexer-dump ;
+
+: parsing-word-lexer-dump ( error parsing-word -- )
+    2dup [ line>> ] bi@ =
+    [ drop simple-lexer-dump ]
+    [ (parsing-word-lexer-dump) ] if ;
+
+: lexer-dump ( error -- )
+    dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+
 : with-lexer ( lexer quot -- newquot )
     [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
 

diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index e3e7d79c40c7f83ac54a1a420b6a4e534125d2e1..3257bd69a4b2f137023ca8ec2cbce7cfa67d579e 100644 (file)
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -58,9 +58,14 @@ SYMBOL: auto-use?
 
 ERROR: staging-violation word ;
 
+: (execute-parsing) ( accum word -- accum )
+    dup push-parsing-word
+    execute( accum -- accum )
+    pop-parsing-word ; inline
+
 : execute-parsing ( accum word -- accum )
     dup changed-definitions get key? [ staging-violation ] when
-    execute( accum -- accum ) ;
+    (execute-parsing) ;
 
 : scan-object ( -- object )
     scan-word {