104 lines
2.7 KiB
Scheme
104 lines
2.7 KiB
Scheme
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
|
|
|
|
|
|
(define *break-on-user-errors?* #f)
|
|
|
|
(define (user-error node string . args)
|
|
(format #t "~%PreScheme error: ")
|
|
(apply format #t string args)
|
|
(newline)
|
|
(if node (display-source node))
|
|
(if *break-on-user-errors?*
|
|
(breakpoint "")))
|
|
|
|
(define (display-source node)
|
|
(let ((source-node (find-some-source node)))
|
|
(if source-node
|
|
(display-annotation (node-source source-node)
|
|
(eq? source-node node)
|
|
node)
|
|
(pp-cps (top-call node)))))
|
|
|
|
(define (top-call node)
|
|
(let loop ((node node))
|
|
(if (or (not (node? (node-parent node)))
|
|
(and (call-node? node)
|
|
(not (call-node? (node-parent node)))))
|
|
node
|
|
(loop (node-parent node)))))
|
|
|
|
(define (node-source node)
|
|
(cond ((call-node? node)
|
|
(call-source node))
|
|
((lambda-node? node)
|
|
(lambda-source node))
|
|
(else
|
|
#f)))
|
|
|
|
(define (find-some-source node)
|
|
(let loop ((node node))
|
|
(cond ((not (node? node))
|
|
#f)
|
|
((annotation? (node-source node))
|
|
node)
|
|
(else (loop (node-parent node))))))
|
|
|
|
(define (display-annotation annotation exact? node)
|
|
(let ((file (annotation-file annotation))
|
|
(form (annotation-form annotation))
|
|
(row (annotation-row annotation))
|
|
(column (annotation-column annotation)))
|
|
(newline)
|
|
(cond (exact?
|
|
(display " "))
|
|
(else
|
|
(write-one-line (current-output-port)
|
|
60
|
|
(lambda (port)
|
|
(show-user-node node port)))
|
|
(display " within ")))
|
|
(newline)
|
|
(write-one-line (current-output-port)
|
|
70
|
|
(lambda (port) (display form port)))
|
|
(format #t "~% on line ~D of ~A~%" column file)))
|
|
|
|
(define (show-user-node node port)
|
|
(cond ((literal-node? node)
|
|
(format port "'~S" (literal-value node)))
|
|
((reference-node? node)
|
|
(format port "~S" (variable-name (reference-variable node))))
|
|
((lambda-node? node)
|
|
(format port "(lambda ~A ...)"
|
|
(map variable-name
|
|
(if (proc-lambda? node)
|
|
(cdr (lambda-variables node))
|
|
(lambda-variables node))))
|
|
(show-user-node (lambda-body node) port))
|
|
((call-node? node)
|
|
(show-user-call-node node port))))
|
|
|
|
(define (show-user-call-node call port)
|
|
(let ((exits (call-exits call))
|
|
(id (primop-id (call-primop call))))
|
|
(case id
|
|
((let)
|
|
(display "(let ..." port) ; wimpy
|
|
)
|
|
((call unknown-call)
|
|
(display "(" port)
|
|
(show-user-node (call-arg call 1) port)
|
|
(show-user-call-args call (if (eq? 'call id) 2 3) port)
|
|
(display ")" port))
|
|
(else ; wimpy
|
|
(format port "(~S" id)
|
|
(show-user-call-args call exits port)
|
|
(format port ")")))))
|
|
|
|
(define (show-user-call-args call start port)
|
|
(do ((i start (+ i 1)))
|
|
((>= i (call-arg-count call)))
|
|
(display " " port)
|
|
(show-user-node (call-arg call i) port)))
|
|
|
|
|