summaryrefslogtreecommitdiffstats
path: root/prec.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /prec.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
Diffstat (limited to 'prec.scm')
-rw-r--r--prec.scm38
1 files changed, 24 insertions, 14 deletions
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))))