dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add proper pretty-printing for syntax errors

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-11-16 02:56:43 +01:00
commit 2090f909b4
2 changed files with 79 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

55
libguile/throw.c
View file

@ -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);

27
module/system/repl/repl.scm
View file

@ -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