Changeset 20430 in project


Ignore:
Timestamp:
09/21/10 03:43:36 (10 years ago)
Author:
Kon Lovett
Message:

Ver w/ srfi-12 impl

Location:
release/4/srfi-34/branches/native
Files:
2 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/srfi-34/branches/native/srfi-34.scm

    r15265 r20430  
    11;;; SRFI-34: Exceptions for scheme
     2;;; A SRFI 34 inteface using the Chicken SRFI 12 implementation.
    23
    3 ;;; This file contains the macros.  srfi-34-support.scm contains
    4 ;;; some support procedures needed at runtime.
    5        
    6 ;;; This is the reference implementation copied (almost) verbatim from
    7 ;;; http://srfi.schemers.org/srfi-34/srfi-34.html with rearranging and
    8 ;;; slight modifications to be a chicken egg.
     4(declare
     5  (bound-to-procedure
     6    ##sys#abort
     7    ##sys#signal))
    98
    109(module srfi-34
    11    (*current-exception-handlers*
    12     with-exception-handlers
    13     with-exception-handler
     10
     11  (;export
    1412    raise
     13    raise-continuable
    1514    guard)
    16 (import (except chicken with-exception-handler) scheme)
    1715
    18 (define *current-exception-handlers*
    19   (list (lambda (condition)
    20           (error "unhandled exception" condition))))
     16  (import scheme chicken)
    2117
    22 (define (with-exception-handlers new-handlers thunk)
    23   (let ((previous-handlers *current-exception-handlers*))
    24     (dynamic-wind
    25       (lambda ()
    26         (set! *current-exception-handlers* new-handlers))
    27       thunk
    28       (lambda ()
    29         (set! *current-exception-handlers* previous-handlers)))))
     18(define-syntax raise
     19  (syntax-rules ()
     20    ((_ ?obj) (##sys#abort ?obj))))
    3021
    31 (define (with-exception-handler handler thunk)
    32   (with-exception-handlers (cons handler *current-exception-handlers*)
    33                            thunk))
    34 
    35 (define (raise obj)
    36   (let ((handlers *current-exception-handlers*))
    37     (with-exception-handlers (cdr handlers)
    38       (lambda ()
    39         ((car handlers) obj)
    40         (error "handler returned"
    41                (car handlers)
    42                obj)))))
    43 
    44 ;(require-extension ports)
     22(define-syntax raise-continuable
     23  (syntax-rules ()
     24    ((_ ?obj) (##sys#signal ?obj))))
    4525
    4626(define-syntax guard
     
    5131         (with-exception-handler
    5232           (lambda (condition)
    53              ((call-with-current-continuation
    54                (lambda (handler-k)
     33             ((call-with-current-continuation
     34               (lambda (handler-k)
    5535                 (guard-k
    5636                  (lambda ()
     
    6040                                 clause ...))))))))
    6141           (lambda ()
    62              (call-with-values
    63                  (lambda () e1 e2 ...)
    64                (lambda args
    65                  (guard-k (lambda ()
    66                             (apply values args)))))))))))))
    67 
     42             (call-with-values
     43                 (lambda () e1 e2 ...)
     44               (lambda args
     45                 (guard-k (lambda ()
     46                            (apply values args)))))))))))))
    6847
    6948(define-syntax guard-aux
     
    7352    ((guard-aux reraise (test => result))
    7453     (let ((temp test))
    75        (if temp 
     54       (if temp
    7655           (result temp)
    7756           reraise)))
     
    9574     (if test
    9675         (begin result1 result2 ...)
    97          (guard-aux reraise clause1 clause2 ...))))) )
     76         (guard-aux reraise clause1 clause2 ...)))))
     77
     78) ;module srfi-34
  • release/4/srfi-34/branches/native/srfi-34.setup

    r16974 r20430  
    11;;; srfi-34.setup
    22
    3 (compile -s -O2 -d1 srfi-34.scm -j srfi-34)
    4 (compile -s -O2 -d0 srfi-34.import.scm)
    5 (compile -c -O2 -d1 srfi-34.scm -j srfi-34)
     3(compile -s -O3 -d0 srfi-34.scm -j srfi-34)
     4(compile -s -O3 -d0 srfi-34.import.scm)
    65
    76(install-extension
    87 'srfi-34
    9  '("srfi-34.so" "srfi-34.import.so" "srfi-34.setup")
    10  '((version "0.4")
    11    (static "srfi-34.o")
    12    (documentation "srfi-34.html")))
     8 '("srfi-34.so" "srfi-34.import.so")
     9 '((syntax)
     10   (import-only)
     11   (version "0.5")))
    1312 
    1413 
Note: See TracChangeset for help on using the changeset viewer.