From fa3f23105ddcf07c5900de47f19af43d1db1b597 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:27 -0800
Subject: Import Upstream version 2c3

---
 prec.scm | 38 ++++++++++++++++++++++++--------------
 1 file changed, 24 insertions(+), 14 deletions(-)

(limited to 'prec.scm')

diff --git a/prec.scm b/prec.scm
index bb66763..f2f7582 100644
--- a/prec.scm
+++ b/prec.scm
@@ -72,7 +72,7 @@
      (cond ((eqv? #\newline (tok:peek-char))
 	    (tok:read-char)))		;to do newline
      (set! tok:column (+ tok:column pos)))))
-(define (prec:warn msg)
+(define (prec:warn . msgs)
   (do ((j (+ -1 tok:column) (+ -8 j)))
       ((> 8 j)
        (do ((i j (+ -1 i)))
@@ -80,7 +80,8 @@
 	 (display #\ )))
     (display slib:tab))
   (display "^ ")
-  (display msg)
+  (newline)
+  (for-each (lambda (x) (write x) (display #\ )) msgs)
   (newline))
 
 ;; Structure of lexical records.
@@ -189,9 +190,10 @@
 (define (prec:delim tk)
   (prec:make-led tk 0 #f))
 
-(define (prec:nofix tk sop)
-  (prec:make-nud tk prec:parse-nofix sop))
-(define (prec:parse-nofix self sop)
+(define (prec:nofix tk sop . binds)
+  (prec:make-nud tk prec:parse-nofix sop (apply append binds)))
+(define (prec:parse-nofix self sop binds)
+  (set! *syn-rules* (prec:process-binds binds *syn-rules*))
   (prec:call-or-list (or sop (prec:symbolfy self))))
 
 (define (prec:prefix tk sop bp . binds)
@@ -212,9 +214,10 @@
   (prec:apply-or-cons (or sop (prec:symbolfy self))
 		      (cons left (prec:parse-list self bp))))
 
-(define (prec:postfix tk sop lbp)
-  (prec:make-led tk lbp prec:parse-postfix sop))
-(define (prec:parse-postfix left self lbp sop)
+(define (prec:postfix tk sop lbp . binds)
+  (prec:make-led tk lbp prec:parse-postfix sop (apply append binds)))
+(define (prec:parse-postfix left self lbp sop binds)
+  (set! *syn-rules* (prec:process-binds binds *syn-rules*))
   (prec:call-or-list (or sop (prec:symbolfy self)) left))
 
 (define (prec:prestfix tk sop bp . binds)
@@ -269,9 +272,12 @@
 		  (cond ((equal? (force prec:token) match)
 			 (prec:advance))
 			((prec:delim? (force prec:token))
-			 (prec:warn 'mismatched-delimiter)
+			 (prec:warn 'mismatched-delimiter (force prec:token)
+				    'not match)
 			 (prec:advance))
-			(else (prec:warn 'delimiter-expected--ignoring-rest)
+			(else (prec:warn 'delimiter-expected--ignoring-rest
+					 (force prec:token) 'expected match
+					 'or-delimiter)
 			      (do () ((prec:delim? (force prec:token)))
 				(prec:parse1 0))))
 		  ans)))))
@@ -356,15 +362,18 @@
 	 (cons '? (prec:parse-delimited sep delim)))
 	((prec:delim? (force prec:token))
 	 (if (not (equal? (force prec:token) delim))
-	     (prec:warn 'mismatched-delimiter))
+	     (prec:warn 'mismatched-delimiter (force prec:token)
+			'expected delim))
 	 (if (not sep) (prec:warn 'expression-missing))
 	 (prec:advance)
 	 (if sep '() '(?)))
 	(else (let ((ans (prec:parse-list sep bp)))
 		(cond ((equal? (force prec:token) delim))
 		      ((prec:delim? (force prec:token))
-		       (prec:warn 'mismatched-delimiter))
-		      (else (prec:warn 'delimiter-expected--ignoring-rest)
+		       (prec:warn 'mismatched-delimiter (force prec:token)
+				  'expecting delim))
+		      (else (prec:warn 'delimiter-expected--ignoring-rest
+				       (force prec:token) '...)
 			    (do () ((prec:delim? (force prec:token)))
 			      (prec:parse1 bp))))
 		(prec:advance)
@@ -381,7 +390,8 @@
 	   (let ((ans (prec:parse1 0)))
 	     (cond ((eof-object? (force prec:token)))
 		   ((equal? (force prec:token) delim))
-		   (else (prec:warn 'delimiter-expected--ignoring-rest)
+		   (else (prec:warn 'delimiter-expected--ignoring-rest
+				    (force prec:token) 'not delim)
 			 (do () ((or (equal? (force prec:token) delim)
 				     (eof-object? (force prec:token))))
 			   (prec:advance))))
-- 
cgit v1.2.3