Changeset 29092 in project


Ignore:
Timestamp:
06/13/13 21:14:25 (8 years ago)
Author:
sjamaan
Message:

R7RS: Fix with-exception-handler and "guard"; improve tests a bit

Location:
release/4/r7rs/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/scheme.base.scm

    r29049 r29092  
    3838
    3939;; guard & guard-aux copied verbatim from the draft.
     40;; guard-aux put in a letrec-syntax due to import/export issues...
    4041(define-syntax guard
    4142  (syntax-rules ()
    4243    ((guard (var clause ...) e1 e2 ...)
    43      ((call/cc
     44     (letrec-syntax ((guard-aux
     45                      (syntax-rules ___ (else =>)
     46                        ((guard-aux reraise (else result1 result2 ___))
     47                         (begin result1 result2 ___))
     48                        ((guard-aux reraise (test => result))
     49                         (let ((temp test))
     50                           (if temp
     51                               (result temp)
     52                               reraise)))
     53                        ((guard-aux reraise (test => result)
     54                                    clause1 clause2 ___)
     55                         (let ((temp test))
     56                           (if temp
     57                               (result temp)
     58                               (guard-aux reraise clause1 clause2 ___))))
     59                        ((guard-aux reraise (test))
     60                         (or test reraise))
     61                        ((guard-aux reraise (test) clause1 clause2 ___)
     62                         (let ((temp test))
     63                           (if temp
     64                               temp
     65                               (guard-aux reraise clause1 clause2 ___))))
     66                        ((guard-aux reraise (test result1 result2 ___))
     67                         (if test
     68                             (begin result1 result2 ___)
     69                             reraise))
     70                        ((guard-aux reraise
     71                                    (test result1 result2 ___)
     72                                    clause1 clause2 ___)
     73                         (if test
     74                             (begin result1 result2 ___)
     75                             (guard-aux reraise clause1 clause2 ___))))))
     76      ((call/cc
    4477        (lambda (guard-k)
    4578          (with-exception-handler
    4679           (lambda (condition)
    4780             ((call/cc
    48                 (lambda (handler-k)
    49                   (guard-k
    50                    (lambda ()
    51                      (let ((var condition))
    52                        (guard-aux
    53                         (handler-k
    54                          (lambda ()
    55                            (raise-continuable condition)))
    56                         clause ...))))))))
     81               (lambda (handler-k)
     82                 (guard-k
     83                  (lambda ()
     84                    (let ((var condition))
     85                      (guard-aux
     86                       (handler-k
     87                        (lambda ()
     88                          (raise-continuable condition)))
     89                       clause ...))))))))
    5790           (lambda ()
    5891             (call-with-values
    59               (lambda () e1 e2 ...)
    60               (lambda args
    61                 (guard-k
    62                  (lambda ()
    63                    (apply values args)))))))))))))
    64 
    65 (define-syntax guard-aux
    66   (syntax-rules (else =>)
    67     ((guard-aux reraise (else result1 result2 ...))
    68      (begin result1 result2 ...))
    69     ((guard-aux reraise (test => result))
    70      (let ((temp test))
    71        (if temp
    72            (result temp)
    73            reraise)))
    74     ((guard-aux reraise (test => result)
    75                 clause1 clause2 ...)
    76      (let ((temp test))
    77        (if temp
    78            (result temp)
    79            (guard-aux reraise clause1 clause2 ...))))
    80     ((guard-aux reraise (test))
    81      (or test reraise))
    82     ((guard-aux reraise (test) clause1 clause2 ...)
    83      (let ((temp test))
    84        (if temp
    85            temp
    86            (guard-aux reraise clause1 clause2 ...))))
    87     ((guard-aux reraise (test result1 result2 ...))
    88      (if test
    89          (begin result1 result2 ...)
    90          reraise))
    91     ((guard-aux reraise
    92                 (test result1 result2 ...)
    93                 clause1 clause2 ...)
    94      (if test
    95          (begin result1 result2 ...)
    96          (guard-aux reraise clause1 clause2 ...)))))
     92                 (lambda () e1 e2 ...)
     93               (lambda args
     94                 (guard-k
     95                  (lambda ()
     96                    (apply values args))))))))))))))
    9797
    9898
     
    101101;;;
    102102
     103;; XXX TODO: This is not threadsafe!
    103104(define-values (with-exception-handler raise raise-continuable)
    104105  (let ((exception-handlers
     
    111112       (dynamic-wind
    112113        (lambda ()
     114          ;; We might be interoperating with srfi-12 handlers set by intermediate
     115          ;; non-R7RS code, so check if a new handler was set in the meanwhile.
     116          (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
     117            (set! exception-handlers
     118              (cons ##sys#current-exception-handler exception-handlers)))
    113119          (set! exception-handlers (cons handler exception-handlers))
    114120          (set! ##sys#current-exception-handler handler))
  • release/4/r7rs/trunk/tests/run.scm

    r29049 r29092  
    33(define (read-from-string s)
    44  (with-input-from-string s read))
     5
     6(test-begin "r7rs tests")
    57
    68(test-group "long boolean literals"
     
    2931  (test-error "with-exception-handler (raise)"
    3032              (with-exception-handler
    31                (lambda (e) 'ignore)
     33               (lambda (e) (raise 'another-error))
    3234               (lambda () (+ 1 (raise 'an-error)))))
    3335  (test "with-exception-handler (raise-continuable)"
    34         65
    35         (with-exception-handler
    36          (lambda (e) 42)
    37          (lambda () (+ (raise-continuable "should be a number") 23))))
     36        '("should be a number" 65)
     37        (let* ((exception-object #f)
     38               (return-value
     39                (with-exception-handler
     40                 (lambda (e) (set! exception-object e) 42)
     41                 (lambda () (+ (raise-continuable "should be a number") 23)))))
     42          (list exception-object return-value)))
    3843  (test "error-object? (#f)" #f (error-object? 'no))
    3944  (test "error-object? (#t)" #t (error-object? (catch (car '()))))
     
    111116      (test-assert "It's ok to close input ports that are already closed"
    112117                   (close-port the-string-port)))))
     118
     119(test-end "r7rs tests")
     120
     121(test-exit)
Note: See TracChangeset for help on using the changeset viewer.