diff options
author | Andy Wingo <wingo@pobox.com> | 2010-11-16 02:56:43 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-11-16 02:57:27 +0100 |
commit | 2090f909b4675286b0de11936771a77a515d885e (patch) | |
tree | 7b09e68cb941d4a9443475b26177c153be88e053 | |
parent | 6cb423613ebf6103d15be355041bdd789c3cb05a (diff) | |
download | guile-2090f909b4675286b0de11936771a77a515d885e.tar.gz |
add proper pretty-printing for syntax errors
* module/system/repl/repl.scm (display-syntax-error): New helper,
displays a syntax error.
(abort-on-error, run-repl): Use it.
* libguile/throw.c (handler_message): Re-code the same thing in C.
-rw-r--r-- | libguile/throw.c | 55 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 27 |
2 files changed, 79 insertions, 3 deletions
diff --git a/libguile/throw.c b/libguile/throw.c index 238c52c5e..623407749 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -341,7 +341,60 @@ handler_message (void *handler_data, SCM tag, SCM args) char *prog_name = (char *) handler_data; SCM p = scm_current_error_port (); - if (scm_ilength (args) == 4) + if (scm_is_eq (tag, scm_from_locale_symbol ("syntax-error")) + && scm_ilength (args) >= 5) + { + SCM who = SCM_CAR (args); + SCM what = SCM_CADR (args); + SCM where = SCM_CADDR (args); + SCM form = SCM_CADDDR (args); + SCM subform = SCM_CAR (SCM_CDDDDR (args)); + + scm_puts ("Syntax error:\n", p); + + if (scm_is_true (where)) + { + SCM file, line, col; + + file = scm_assq_ref (where, scm_sym_filename); + line = scm_assq_ref (where, scm_sym_line); + col = scm_assq_ref (where, scm_sym_column); + + if (scm_is_true (file)) + scm_display (file, p); + else + scm_puts ("unknown file", p); + scm_puts (": ", p); + scm_display (line, p); + scm_puts (": ", p); + scm_display (col, p); + scm_puts (": ", p); + } + else + scm_puts ("unknown location: ", p); + + if (scm_is_true (who)) + { + scm_display (who, p); + scm_puts (": ", p); + } + + scm_display (what, p); + + if (scm_is_true (subform)) + { + scm_puts (" in subform ", p); + scm_write (subform, p); + scm_puts (" of ", p); + scm_write (form, p); + } + else if (scm_is_true (form)) + { + scm_puts (" in form ", p); + scm_write (form, p); + } + } + else if (scm_ilength (args) == 4) { SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL); SCM subr = SCM_CAR (args); diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index fbe7b12bc..237919edb 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -90,6 +90,23 @@ (define* (start-repl #:optional (lang (current-language)) #:key debug) (run-repl (make-repl lang debug))) +(define (display-syntax-error port who what where form subform extra) + (format port "Syntax error:~%") + (if where + (let ((file (or (assq-ref where 'filename) "unknown file")) + (line (assq-ref where 'line)) + (col (assq-ref where 'column))) + (format port "~a:~a:~a: " file line col)) + (format port "unknown location: ")) + (if who + (format port "~a: " who)) + (format port "~a" what) + (if subform + (format port " in subform ~s of ~s" subform form) + (if form + (format port " in form ~s" form))) + (newline port)) + ;; (put 'abort-on-error 'scheme-indent-function 1) (define-syntax abort-on-error (syntax-rules () @@ -98,8 +115,11 @@ (lambda () exp) (lambda (key . args) (format #t "While ~A:~%" string) - (pmatch args - ((,subr ,msg ,args . ,rest) + (pmatch (cons key args) + ((syntax-error ,who ,message ,where ,form ,subform . ,rest) + (display-syntax-error (current-output-port) + who message where form subform rest)) + ((_ ,subr ,msg ,args . ,rest) (display-error #f (current-output-port) subr msg args rest)) (else (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args))) @@ -131,6 +151,9 @@ (begin (format #t "While executing meta-command:~%") (pmatch args + ((syntax-error ,who ,message ,where ,form ,subform . ,rest) + (display-syntax-error (current-output-port) + who message where form subform rest)) ((,subr ,msg ,args . ,rest) (display-error #f (current-output-port) subr msg args rest)) (else |