Re: [Chicken-users] SRFIs 34, 35 and 36

[Joerg F. Wittenberger]

felix <address@hidden> writes:

> William Annis wrote:
> > Now that the SRFI has been accepted, are there plans to switch from
> > srfi-12 to 34?  I dropped the reference code into csi -hygienic and
> > all the examples worked, so it shouldn't be too difficult to roll in. 
> 
> 
> To be frank, I don't particularly like SRFI-34. The semantics of `raise'
> are (IMHO) unnecessarily complicated, and
> the whole idea of condition-type defining macros a la ML is not my
> idea of the "Scheme Way" (of which exist about as many as Scheme
> implementors ;-).

I gave an implementation of SRFI-34 a shot.  Seems to work, please
check.

Please take it with a grain of salt: I have to admit, that there is s
variant of my code, which has a different (i.e., broken) semantic and
I don't understand quite why.  You've been warned.

Anyway, I still fail to see what is actually more complicated in the
semantics of 'raise' in comparision to 'abort'.

---------------
moremacros.scm

;; SRFI 34

(define-macro (guard clause . body)
  (let ([args (gensym)] )
    `(with-exception-guard
      (lambda (,(car clause))
        (cond ,@(cdr clause)
              ,@(if (assq 'else (cdr clause))
                    '()
                    `((else (raise ,(car clause)))))))
      (lambda () ,@body)) ) )

---------------
library.scm

(define (##sys#raise x)
  (let ((handler-chain ##sys#current-exception-handler))
    (set! ##sys#current-exception-handler
          (cdr ##sys#current-exception-handler))
    ((car handler-chain) x)
    (set! ##sys#current-exception-handler handler-chain)))

(define (##sys#abort x)
  (##sys#raise x)
  (##sys#abort (make-property-condition 'exn 'message "exception handler 
returned")) )

(define (##sys#signal x)
  ((car ##sys#current-exception-handler) x) )

(define raise ##sys#raise)
(define abort ##sys#abort)
(define signal ##sys#signal)

(define ##sys#current-exception-handler
  ;; Exception-handler for the primordial thread:
  (let ([string-append string-append])
    (list
     (lambda (c)
       (when (##sys#structure? c 'condition)
             (case (##sys#slot (##sys#slot c 1) 0)
               [(exn)
                (let* ([props (##sys#slot c 2)]
                       [msga (memq 'message props)]
                       [argsa (memq 'arguments props)]
                       [loca (memq 'location props)] )
                  (apply
                   (##sys#error-handler)
                   (if msga
                       (let ([msg (cadr msga)]
                             [loc (and loca (cadr loca))] )
                         (if loc
                             (string-append "(" (##sys#symbol->qualified-string 
loc) ") " msg)
                             msg) )
                       "<exn: has no `message' property>")
                   (if argsa
                       (cadr argsa)
                       '() ) )
                  ((##sys#reset-handler)) ) ]
               [(user-interrupt)
                (##sys#print "*** User interrupt ***\n" #f ##sys#standard-error)
                ((##sys#reset-handler)) ] 
               [(uncaught-exception)
                ((##sys#error-handler)
                 "uncaught exception"
                 (cadr (memq 'reason (##sys#slot c 2))) )
                ((##sys#reset-handler)) ] ) )
       (##sys#abort
        (##sys#make-structure
         'condition 
         '(uncaught-exception) 
         (list 'reason c)) ) )) ) )

(define (with-exception-handler handler thunk)
  (let ((handler-chain ##sys#current-exception-handler))
    (##sys#dynamic-wind
     (lambda () (set! ##sys#current-exception-handler
                      (cons handler handler-chain)))
     thunk
     (lambda () (set! ##sys#current-exception-handler handler-chain)) )) )

;; SRFI 34 support

(define (with-exception-guard handler thunk)
  ((call-with-current-continuation
    (lambda (return)
      (with-exception-handler
       (lambda (condition)
         (return (lambda () (handler condition))))
       (lambda ()
         (##sys#call-with-values
          thunk
          (lambda args
            (return (lambda () (##sys#apply ##sys#values args)))) ) ) ) ) )) )

(define (current-exception-handler) (car ##sys#current-exception-handler))

regards

/Jörg

-- 
The worst of harm may often result from the best of intentions.