/usr/share/scsh-0.6/scsh/scsh-condition.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | ;;; 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)
(apply errno-error-with-message errno (errno-msg errno) syscall stuff))
(define (errno-error-with-message errno msg syscall . stuff)
(apply signal 'syscall-error errno msg syscall stuff))
(define (with-errno-handler* handler thunk)
(with-handler
(lambda (condition more)
(if (syscall-error? condition)
(let ((stuff (condition-stuff condition)))
(handler (car stuff) ; errno
(cdr stuff))) ; (msg syscall . packet)
;; capture VM exceptions (currently only prim-io.scm)
(if (and (exception? condition)
(eq? (exception-reason condition)
'os-error))
(let ((stuff (condition-stuff condition)))
(if (> (length stuff) 3)
(handler (caddr stuff) ; errno
(cons
(last stuff) ; msg
(cons
(enumerand->name ; syscall (almost ...)
(exception-opcode condition) op)
; packet:
(drop-right (cdddr stuff) 1))))))))
(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)))
|