;;; -*- Mode: Scheme -*-
;;;; Riaxpander
;;;; MIT Scheme Port
;;;;
;;; Copyright (c) 2008, Taylor R. Campbell
;;; See the LICENCE file for licence terms and warranty disclaimer.
(define condition-type:syntax-error
(make-condition-type 'SYNTAX-ERROR condition-type:error
'(MESSAGE IRRITANTS HISTORY)
(lambda (condition output-port)
(format-error-message (access-condition condition 'MESSAGE)
(access-condition condition 'IRRITANTS)
output-port))))
(define signal-syntax-error
(let ((make-condition
(condition-constructor condition-type:syntax-error
'(MESSAGE IRRITANTS HISTORY))))
(lambda (message irritants history wrapper)
(call-with-current-continuation
(lambda (continuation)
((lambda (signal)
(if history
(with-syntax-replacement-restart (wrapper continuation)
signal)
(signal)))
(lambda ()
(let ((condition
(make-condition continuation 'BOUND-RESTARTS
message irritants history)))
(signal-condition condition)
(standard-error-handler condition)))))))))
(define (with-syntax-replacement-restart continuation thunk)
(with-restart 'USE-VALUE "Use a different form."
continuation
(lambda ()
(values (prompt-for-expression "New form (not evaluated)")))
thunk))
(define (syntax-error message history . irritants)
(signal-syntax-error message irritants history identity-procedure))
(define (classify-error message history . irritants)
(signal-syntax-error message irritants history
(lambda (continuation)
(lambda (form)
;** Be careful of multiple return values here. They're broken
;** in MIT Scheme, so continuations are unary.
(continuation (hook/reclassify form history))))))
(define (hook/reclassify form history)
form history ;ignore
(error "Classifier not yet available."))
;;; MIT Scheme is not quite R5RS-compliant in the area of EVAL
;;; environment specifiers. This wouldn't be hard to fix, but no one
;;; has done it. (Then again, INTERACTION-ENVIRONMENT is optional.)
(define (interaction-environment)
(nearest-repl/environment))
(with-working-directory-pathname
(directory-pathname (current-load-pathname))
(lambda ()
(for-each load
'(
"history"
"closure"
"denotation"
"environment"
"transform"
"taxonomy"
"classify"
"standard"
"synrules"
;; For now, we just use S-expression output. Later
;; there ought to be an scode generator.
"sexp"
))))
;;; Make things print more nicely.
(set-record-type-unparser-method!
(simple-unparser-method 'SYNTACTIC-CLOSURE
(lambda (closure)
(cons* (syntactic-closure/form closure)
(syntactic-closure/free-names closure)
(disclose-syntactic-environment
(syntactic-closure/environment closure))))))
(set-record-type-unparser-method!
(simple-unparser-method 'VARIABLE
(lambda (variable)
(list (variable/name variable)
(variable/location variable)))))
(set-record-type-unparser-method!
(simple-unparser-method 'SYNTACTIC-ENVIRONMENT
disclose-syntactic-environment))
(set! hook/reclassify reclassify)