~ chicken-core (chicken-5) 4f55a2120ec36d9ae3ef3ae48f4ddb0448ce8024
commit 4f55a2120ec36d9ae3ef3ae48f4ddb0448ce8024
Author: felix <bunny351@gmail.com>
AuthorDate: Wed May 5 14:06:51 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Wed May 5 14:06:51 2010 +0200
better messagess for syntax-errors with context
diff --git a/compiler.scm b/compiler.scm
index a03a3781..2c890733 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1192,11 +1192,8 @@
(walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) )
(else
- (let* ((msyntax (unimported-syntax name))
- (x2 (if msyntax
- (fluid-let ((##sys#unimported-syntax-context name))
- (mapwalk x e se))
- (mapwalk x e se)))
+ (let* ((x2 (fluid-let ((##sys#syntax-context (cons name ##sys#syntax-context)))
+ (mapwalk x e se)))
(head2 (car x2))
(old (##sys#hash-table-ref line-number-database-2 head2)) )
(when ln
@@ -1223,14 +1220,6 @@
(,tmp ,@(cdr x)))
e se dest)))))
- (define (unimported-syntax sym)
- (let ((defs (##sys#get (##sys#strip-syntax sym) '##core#db)))
- (and defs
- (let loop ((defs defs))
- (and (pair? defs)
- (or (eq? 'syntax (caar defs))
- (loop (cdr defs))))))))
-
(define (mapwalk xs e se)
(map (lambda (x) (walk x e se #f)) xs) )
diff --git a/eval.scm b/eval.scm
index f1e1ebc3..53a6df99 100644
--- a/eval.scm
+++ b/eval.scm
@@ -747,24 +747,13 @@
(compile-call (cdr x) e tf cntr se) ]
(else
- (let ((msyntax (unimported-syntax head)))
- (if msyntax
- (fluid-let ((##sys#unimported-syntax-context head))
- (compile-call x e tf cntr se))
- (compile-call x e tf cntr se)) ) ) ) ) ) ) ]
+ (fluid-let ((##sys#syntax-context (cons head ##sys#syntax-context)))
+ (compile-call x e tf cntr se)))))))]
[else
(emit-syntax-trace-info tf x cntr)
(compile-call x e tf cntr se)] ) )
- (define (unimported-syntax sym)
- (let ((defs (##sys#get (##sys#strip-syntax sym) '##core#db)))
- (and defs
- (let loop ((defs defs))
- (and (pair? defs)
- (or (eq? 'syntax (caar defs))
- (loop (cdr defs))))))))
-
(define (fudge-argument-list n alst)
(if (null? alst)
(list alst)
diff --git a/expand.scm b/expand.scm
index 07e07b25..1dc1e934 100644
--- a/expand.scm
+++ b/expand.scm
@@ -613,7 +613,7 @@
(define ##sys#line-number-database #f)
(define ##sys#syntax-error-culprit #f)
-(define ##sys#unimported-syntax-context #f)
+(define ##sys#syntax-context '())
(define (##sys#syntax-error-hook . args)
(apply ##sys#signal-hook #:syntax-error
@@ -623,37 +623,52 @@
(let ((open-output-string open-output-string)
(get-output-string get-output-string))
(lambda (msg arg)
- (cond (##sys#unimported-syntax-context
- =>
- (lambda (cx)
- (let* ((cx (##sys#strip-syntax cx))
- (a (##sys#get cx '##core#db))
- (out (open-output-string)))
- (##sys#print msg #f out)
- (##sys#print ": " #f out)
- (##sys#print arg #t out)
- (##sys#print "\n\nPerhaps you intended to use the syntax `" #f out)
- (##sys#print cx #f out)
- (##sys#print "' without importing it first.\n" #f out)
- (if (= 1 (length a))
- (##sys#print
- (string-append
- "Suggesting: `(import "
- (symbol->string (cadar a))
- ")'")
- #f out)
- (##sys#print
- (string-append
- "Suggesting one of:\n"
- (let loop ((lst a))
- (if (null? lst)
- ""
- (string-append
- "\n (import " (symbol->string (cadar lst)) ")"
- (loop (cdr lst))))))
- #f out))
- (##sys#syntax-error-hook (get-output-string out)))))
- (else (##sys#syntax-error-hook msg arg))))))
+ (define (syntax-imports sym)
+ (let loop ((defs (or (##sys#get (##sys#strip-syntax sym) '##core#db) '())))
+ (cond ((null? defs) '())
+ ((eq? 'syntax (caar defs))
+ (cons (cadar defs) (loop (cdr defs))))
+ (else (loop (cdr defs))))))
+ (if (null? ##sys#syntax-context)
+ (##sys#syntax-error-hook msg arg)
+ (let ((out (open-output-string)))
+ (define (outstr str)
+ (##sys#print str #f out))
+ (let loop ((cx ##sys#syntax-context))
+ (cond ((null? cx) ; no unimported syntax found
+ (outstr msg)
+ (outstr ": ")
+ (##sys#print arg #t out)
+ (outstr "\ninside expression `(")
+ (##sys#print (##sys#strip-syntax (car ##sys#syntax-context)) #t out)
+ (outstr " ...)'"))
+ (else
+ (let* ((sym (##sys#strip-syntax (car cx)))
+ (us (syntax-imports sym)))
+ (cond ((pair? us)
+ (outstr msg)
+ (outstr ": ")
+ (##sys#print arg #t out)
+ (outstr "\n\n Perhaps you intended to use the syntax `(")
+ (##sys#print sym #t out)
+ (outstr " ...)' without importing it first.\n")
+ (if (fx= 1 (length us))
+ (outstr
+ (string-append
+ " Suggesting: `(import "
+ (symbol->string (car us))
+ ")'"))
+ (outstr
+ (string-append
+ " Suggesting one of:\n"
+ (let loop ((lst us))
+ (if (null? lst)
+ ""
+ (string-append
+ "\n (import " (symbol->string (car lst)) ")'"
+ (loop (cdr lst)))))))))
+ (else (loop (cdr cx))))))))
+ (##sys#syntax-error-hook (get-output-string out)))))))
(define syntax-error ##sys#syntax-error-hook)
Trap