Changeset 35548 in project


Ignore:
Timestamp:
05/19/18 09:59:14 (4 months ago)
Author:
kon
Message:

call-chain could be empty (?), use format, shorten

Location:
release/4/condition-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/condition-utils/trunk/condition-utils.scm

    r35242 r35548  
    2929(import scheme chicken)
    3030(use
    31   srfi-69
    32   data-structures
    33   (only srfi-1 append!)
    34   type-errors)
     31  (only srfi-69 make-hash-table hash-table-ref/default hash-table-set!)
     32  (only data-structures ->string)
     33  (only extras format)
     34  (only ports call-with-output-string)
     35  (only srfi-1 concatenate append!)
     36  (only type-errors error-argument-type))
    3537
    3638(declare
     
    6769  ;indifferent to plist vs alist representation of condition-properties
    6870  ;from 'condition->list'.
    69   (foldl
    70     (lambda (ls kndlst)
    71       (append! ls (cdr kndlst)) )
    72     '()
    73     (condition->list cnd)) )
     71  (concatenate (map cdr (condition->list cnd))) )
    7472
    7573;; Condition from condition expression; composite when indicated
     
    149147(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
    150148;
    151 (define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
    152   ;
    153   (define (incl tag val)
    154     (if val `(,tag ,val) '()) )
    155   ;
    156   (apply make-property-condition 'exn
    157     (append!
    158       (incl 'location loc)
    159       `(message ,(or msg "unknown"))
    160       (incl 'arguments args)
    161       (incl 'call-chain calls))) )
     149(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
     150  (let (
     151    (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
     152    (apply make-property-condition 'exn
     153      (append!
     154        (if@ 'location    loc)
     155        (if@ 'message     (or msg "unknown"))
     156        (if@ 'arguments   args)
     157        (if@ 'call-chain  chain))) ) )
     158
     159;;
     160
     161(: call-chain? (* -> boolean : (list-of vector)))
     162;
     163(define (call-chain? x)
     164  ;(or (null? x) (and (proper-list? x) (every vector? x)))
     165  (or
     166    (null? x) ;chain could be empty
     167    (and (pair? x) (vector? (car x)))) )
    162168
    163169;;
     
    166172;
    167173(define (make-exn-condition+ loc msg args . cnds)
    168   ;
    169174  (let* (
    170175    (chn
     
    172177    (cnds
    173178      (if chn (cdr cnds) cnds)) )
    174     (apply
    175       make-composite-condition
     179    (apply make-composite-condition
    176180      (make-exn-condition loc msg args chn)
    177181      (expand-property-conditions cnds)) ) )
    178 
    179 (: call-chain? (* -> boolean : (list-of vector)))
    180 ;
    181 (define (call-chain? x)
    182   ;(and (proper-list? x) (every vector? x))
    183   (and (pair? x) (vector? (car x))) )
    184182
    185183;;
     
    201199    (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
    202200    (write-call-chain chain port chain-header) )
    203   ;
     201  ;no abstraction leakage
    204202  (void) )
    205203
     
    207205;
    208206(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
    209   (display header port)
    210   (display ": " port)
    211   (write-condition-list (condition->list cnd) port header) )
     207  (format port "~A: ~A"
     208    header
     209    (call-with-output-string
     210      (lambda (p) (write-condition-list (condition->list cnd) p header)))) )
    212211
    213212(: write-call-chain (list output-port string -> void))
     
    220219  ;
    221220  (define (write-call-entry call)
    222     (let ((type (vector-ref call 0))
    223           (line (vector-ref call 1)) )
     221    (let (
     222      (type (vector-ref call 0))
     223      (line (vector-ref call 1)) )
    224224      (write-type-item type line header) ) )
    225225  ;
    226226  (define (write-type-item type line header)
    227     (display header port)
    228     (display type port)
    229     (display "\t  " port)
    230     (write line port)
    231     (newline port) )
     227    (format port "~A~A\t  ~S~%" header type line) )
    232228  ;
    233229  (for-each write-call-entry chain)
     
    281277          (kind (car cnd-info))
    282278          (args (cdr cnd-info)) )
    283           (display leader port)
    284           (display kind port)
    285           (display ":" port)
    286           (for-each
    287             (lambda (arg)
    288               (display " " port)
    289               (write arg port) )
    290             args)
    291           (newline port) ) )
     279          (format port "~A~A:~A~%"
     280            leader kind
     281            (call-with-output-string
     282              (lambda (p) (for-each (cut format p " ~S" <>) args)))) ) )
    292283      cnds) ) )
    293284
    294285;;
     286
     287#; ;UNUSED
     288(define (exn-prop->string prop)
     289  (condition-property->string cnd 'exn prop) )
    295290
    296291#; ;UNUSED
    297292(define (write-error-message cnd port header)
    298   ;
    299   (define (exn-prop->string prop)
    300     (condition-property->string cnd 'exn prop) )
    301   ;
    302   (let (
    303     (errmsg
    304       (string-append
    305         "\n"
    306         header
    307         "(" (exn-prop->string 'location) ")"
    308         " " (exn-prop->string 'message) ":"
    309         " " (exn-prop->string 'arguments))))
    310     (display errmsg port)
    311     (newline port) ) )
     293  (format port "~%~A(~A) ~A: ~A~%"
     294    header
     295    (exn-prop->string 'location)
     296    (exn-prop->string 'message)
     297    (exn-prop->string 'arguments)) )
    312298
    313299;;
  • release/4/condition-utils/trunk/condition-utils.setup

    r35242 r35548  
    55(verify-extension-name "condition-utils")
    66
    7 (setup-shared-extension-module 'condition-utils (extension-version "1.5.0")
     7(setup-shared-extension-module 'condition-utils (extension-version "1.5.1")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    1111    -scrutinize
    12     -fixnum-arithmetic
    13     -optimize-level 3
     12    -specialize
     13    -optimize-level 3 -debug-level 1
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'standard-conditions (extension-version "1.5.0")
     16(setup-shared-extension-module 'standard-conditions (extension-version "1.5.1")
    1717  #:inline? #t
    1818  #:types? #t
    1919  #:compile-options '(
    2020    -scrutinize
    21     -fixnum-arithmetic
    22     -optimize-level 3
     21    -specialize
     22    -optimize-level 3 -debug-level 1
    2323    -no-procedure-checks))
    2424
    25 (setup-shared-extension-module 'http-client-conditions (extension-version "1.5.0")
     25(setup-shared-extension-module 'http-client-conditions (extension-version "1.5.1")
    2626  #:inline? #t
    2727  #:types? #t
    2828  #:compile-options '(
    2929    -scrutinize
    30     -fixnum-arithmetic
    31     -optimize-level 3
     30    -specialize
     31    -optimize-level 3 -debug-level 1
    3232    -no-procedure-checks))
    3333
    34 (setup-shared-extension-module 'intarweb-conditions (extension-version "1.5.0")
     34(setup-shared-extension-module 'intarweb-conditions (extension-version "1.5.1")
    3535  #:inline? #t
    3636  #:types? #t
    3737  #:compile-options '(
    3838    -scrutinize
    39     -fixnum-arithmetic
    40     -optimize-level 3
     39    -specialize
     40    -optimize-level 3 -debug-level 1
    4141    -no-procedure-checks))
  • release/4/condition-utils/trunk/tests/condition-utils-test.scm

    r35242 r35548  
    1919(define testcc)
    2020(let ((chn (get-call-chain 1)))
    21   (set! testcc (make-exn-condition+ 'test "test" '(test) chn 'misc '(extra test 23))) )
     21  (set! testcc
     22    (make-exn-condition+
     23      'test "test" '(test)              ;std
     24      chn                               ;+ 1
     25      'misc '(extra test 23))) )        ;cnds
    2226(test-assert "composite of exn test extra (set!)" (testc? testcc))
    2327
     
    4751(print)
    4852(print "Writing exn condition")
     53(print " (expect an \"error\")")
    4954(print "---------------------")
    5055(write-exn-condition testcc)
Note: See TracChangeset for help on using the changeset viewer.