scsh-0.6/scsh/scsh-condition.scm

98 lines
2.7 KiB
Scheme

;;; Copyright (c) 1994 by Olin Shivers
;;; Add scsh conditions to s48.
;;; A syscall-error condition-type:
(define-condition-type 'syscall-error '(error))
(define syscall-error? (condition-predicate 'syscall-error))
(define (errno-error errno syscall . stuff)
(let ((msg (errno-msg errno)))
(apply (structure-ref exceptions signal-exception)
(enum op call-external-value) (enum exception os-error)
syscall errno msg stuff)))
(define (with-errno-handler* handler thunk)
(with-handler
(lambda (condition more)
(if (and (exception? condition) (eq? (exception-reason condition)
'os-error))
(let ((stuff (exception-arguments condition)))
(handler (cadr stuff) ; errno
(list (caddr stuff) ;msg
(car stuff) ;syscall
(cdddr stuff) ;packet
)))) ; (msg syscall . packet)
(more))
thunk))
;;; (with-errno-handler
;;; ((errno data) ; These are vars bound in this scope.
;;; ((errno/exist) . body1)
;;; ((errno/wouldblock errno/again) . body2)
;;; (else . body3))
;;;
;;; . body)
(define-syntax with-errno-handler
(lambda (exp rename compare)
(let* ((%lambda (rename 'lambda))
(%cond (rename 'cond))
(%else (rename 'else))
(%weh (rename 'with-errno-handler*))
(%= (rename '=))
(%begin (rename `begin))
(%or (rename `or))
(%call/cc (rename 'call-with-current-continuation))
(%cwv (rename 'call-with-values))
(%ret (rename 'ret)) ; I think this is the way to gensym.
(err-var (caaadr exp))
(data-var (car (cdaadr exp)))
(clauses (cdadr exp))
(body (cddr exp))
(arms (map (lambda (clause)
(let ((test (if (compare (car clause) %else)
%else
(let ((errs (car clause)))
`(,%or . ,(map (lambda (err)
`(,%= ,err ,err-var))
errs))))))
`(,test
(,%cwv (,%lambda () . ,(cdr clause)) ,%ret))))
clauses)))
`(,%call/cc (,%lambda (,%ret)
(,%weh
(,%lambda (,err-var ,data-var)
(,%cond . ,arms))
(,%lambda () . ,body)))))))
;;;; S48 already has this machinery, i.e., (SET-INTERACTIVE?! flag)
;;;; Interactive => breakpoint on errors.
;;;; Noninteractive => exit on errors.
;
;(define $interactive-errors? (make-fluid #f))
;
;(define (with-interactive-errors val thunk)
; (let-fluid $interactive-errors? val thunk))
;
;(define (set-interactive-errors! val)
; (set-fluid! $interactive-errors? val))
;
;;;; Just quit if non-interactive. Otherwise, punt to next handler.
;;;; A hack, because we use the default handler for the interactive
;;;; case.
;
;(define (scsh-error-handler condition more)
; (if (and (error? condition)
; (not (fluid $interactive-errors?)))
; (begin (display condition (current-error-port))
; (exit -1))
; (more)))