Changeset 35972 in project


Ignore:
Timestamp:
07/17/18 19:09:20 (14 months ago)
Author:
Kon Lovett
Message:

exn own mod

Location:
release/5/condition-utils/trunk
Files:
2 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/condition-utils/trunk/condition-utils.egg

    r35969 r35972  
    33
    44((synopsis "SRFI 12 Condition Utilities")
    5  (version "2.0.0")
     5 (version "2.1.0")
    66 (category misc)
    77 (author "[[kon lovett]]")
     
    1313 (test-dependencies test)
    1414 (components
     15  (extension condition-utils-support
     16    #;(inline-file)
     17    (types-file)
     18    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1519  (extension condition-utils
    1620    #;(inline-file)
    1721    (types-file)
     22    (component-dependencies condition-utils-support)
     23    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     24  (extension exn-condition
     25    #;(inline-file)
     26    (types-file)
     27    (component-dependencies condition-utils-support condition-utils)
    1828    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1929  (extension standard-conditions
  • release/5/condition-utils/trunk/condition-utils.scm

    r35969 r35972  
    2424  (make-condition-property-accessor condition-property-accessor*)
    2525  ;
    26   make-exn-condition
    27   make-exn-condition+
    28   ;
    29   write-exn-condition
    30   write-condition )
     26  write-condition)
    3127
    3228(import scheme
     
    4036  (only (chicken port) call-with-output-string)
    4137  (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!)
    42   (only (srfi 1) concatenate append!)
    43   (only type-errors error-argument-type))
     38  (only (srfi 1) concatenate)
     39  (only type-errors error-argument-type)
     40  condition-utils-support)
    4441
    4542;;;
     
    144141      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
    145142
    146 ;;;FIXME should be in standard-conditions module
    147 ;;; EXN Condition
    148 
    149 ;;
    150 
    151 (: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
    152 ;
    153 (define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
    154   (let (
    155     (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
    156     (apply make-property-condition 'exn
    157       (append!
    158         (if@ 'location    loc)
    159         (if@ 'message     (or msg "unknown"))
    160         (if@ 'arguments   args)
    161         (if@ 'call-chain  chain))) ) )
    162 
    163143;;
    164144
     
    171151    (and (pair? x) (vector? (car x)))) )
    172152
    173 ;;
    174 
    175 (: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
    176 ;
    177 (define (make-exn-condition+ loc msg args . cnds)
    178   (let* (
    179     (chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)))
    180     (cnds (if chn (cdr cnds) cnds)) )
    181     (apply make-composite-condition
    182       (make-exn-condition loc msg args chn)
    183       (expand-property-conditions cnds)) ) )
    184 
    185 ;;
    186 
    187 (: write-exn-condition (condition #!optional output-port string string -> void))
    188 ;
    189 ;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
    190 (define (write-exn-condition cnd
    191             #!optional
    192             (port (current-output-port))
    193             (header "Error")
    194             (chain-header "\n\tCall history:\n"))
    195   ;exn portion
    196   (print-error-message cnd port header)
    197   ;rest of the composite condition (if any)
    198   (write-condition-list (cdr (condition->list cnd)) port header)
    199   ;call-chain?
    200   (and-let* (
    201     (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
    202     (write-call-chain chain port chain-header) )
    203   ;no abstraction leakage
    204   (void) )
    205 
    206153(: write-condition (condition #!optional output-port string -> void))
    207154;
     
    211158    (call-with-output-string
    212159      (lambda (p) (write-condition-list (condition->list cnd) p header)))) )
    213 
    214 (: write-call-chain (list output-port string -> void))
    215 ;
    216 (define (write-call-chain chain port header)
    217   (##sys#really-print-call-chain port chain header) )
    218 
    219 #; ;using builtin
    220 (define (write-call-chain chain port header)
    221   ;
    222   (define (write-call-entry call)
    223     (let (
    224       (type (vector-ref call 0))
    225       (line (vector-ref call 1)) )
    226       (write-type-item type line header) ) )
    227   ;
    228   (define (write-type-item type line header)
    229     (format port "~A~A\t  ~S~%" header type line) )
    230   ;
    231   (for-each write-call-entry chain)
    232   (newline port) )
    233160
    234161;;;
     
    240167(define (condition-property->string cnd kind prop #!optional (def ""))
    241168  (->string ((condition-property-accessor kind prop def) cnd)) )
    242 
    243 ;; Interpret condition expression
    244 
    245 ;; <condition>  ->  <condition>
    246 ;; <symbol>     ->  (make-property-condition <symbol>)
    247 ;; <pair>       ->  (apply make-property-condition <pair>)
    248 ;;
    249 ;; (<symbol> [<symbol> <object>]...)
    250 
    251 (: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
    252 ;
    253 (define (expand-property-conditions cnds)
    254   (map
    255     (lambda (x)
    256       (cond
    257         ((condition? x)
    258           x )
    259         ((symbol? x)
    260           (make-property-condition x) )
    261         ((list? x)
    262           (apply make-property-condition x) )
    263         (else
    264           (error-argument-type
    265             'expand-property-conditions
    266             x 'condition-expression "cond-parm") ) ) )
    267     cnds) )
    268 
    269 ;;
    270 
    271 (: write-condition-list ((list-of pair) output-port string -> string))
    272 ;
    273 (define (write-condition-list cnds port header)
    274   (let (
    275     (leader (string-append (subheader-string header) ": ")) )
    276     (for-each
    277       (lambda (cnd-info)
    278         (let (
    279           (kind (car cnd-info))
    280           (args (cdr cnd-info)) )
    281           (format port "~A~A:~A~%"
    282             leader kind
    283             (call-with-output-string
    284               (lambda (p) (for-each (cut format p " ~S" <>) args)))) ) )
    285       cnds) ) )
    286169
    287170;;
  • release/5/condition-utils/trunk/standard-conditions.scm

    r35969 r35972  
    66
    77(;export
    8   ;
    9   exn-condition?
    10   exn-location
    11   exn-message
    12   exn-arguments
    13   exn-call-chain
    148  ;
    159  arity-condition?
     
    3529
    3630;;; Builtin Conditions
    37 
    38 ; Signaled on errors.
    39 (define exn-condition? (condition-predicate* 'exn))
    40 
    41 (define exn-location (make-condition-property-accessor exn location))
    42 (define exn-message (make-condition-property-accessor exn message))
    43 (define exn-arguments (make-condition-property-accessor exn arguments))
    44 (define exn-call-chain (make-condition-property-accessor exn call-chain))
    4531
    4632; Signaled when a procedure is called with the wrong number of arguments.
  • release/5/condition-utils/trunk/tests/condition-utils-test.scm

    r35969 r35972  
    1010(import (chicken condition) (chicken port))
    1111
    12 (import condition-utils)
     12(import condition-utils exn-condition)
    1313
    1414(define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
     
    4141  (with-output-to-string (lambda () (write-exn-condition testc))))
    4242
    43 (import standard-conditions)
    44 
    4543(test-assert (exn-condition? testc))
    4644(test 'test (exn-location testc))
     
    4846(test '(test) (exn-arguments testc))
    4947(test #f (exn-call-chain testc))
     48
     49(import standard-conditions)
    5050
    5151(import http-client-conditions)
Note: See TracChangeset for help on using the changeset viewer.