Changeset 32228 in project


Ignore:
Timestamp:
01/31/15 17:56:30 (5 years ago)
Author:
Kon Lovett
Message:

rel 1.1.0, added write-exn-condition

Location:
release/4/condition-utils
Files:
6 edited
1 copied

Legend:

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

    r31306 r32228  
    2121    make-exn-condition
    2222    make-exn-condition+
     23    ;
     24    write-exn-condition
    2325  )
    2426
    2527  (import scheme chicken)
    2628
    27   (use srfi-1 srfi-69 #;type-checks)
     29  (use srfi-1 srfi-69 data-structures #;type-checks)
    2830
    2931;;;
     
    119121      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
    120122
     123;;;FIXME should be in standard-conditions module
    121124;;; EXN Condition
    122125
     
    124127
    125128(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
    126   (define (incl tag val) (if val `(,tag ,val) '()) )
     129  (define (incl tag val)
     130    (if val `(,tag ,val) '()) )
    127131  (apply make-property-condition 'exn
    128132    (append!
     
    137141  (define (call-chain? x)
    138142    ;(and (proper-list? x) (every vector? x))
    139     (and
    140       (pair? x)
    141       (vector? (car x))) )
     143    (and (pair? x) (vector? (car x))) )
    142144  (let ((chn (and (not (null? cnds))
    143145                  (call-chain? (car cnds))
     
    147149           (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
    148150
     151;;
     152
     153(define (write-exn-condition exn)
     154  (define (write-call-entry call)
     155    (let ((type (vector-ref call 0))
     156          (line (vector-ref call 1)) )
     157      (cond
     158        ((equal? type "<syntax>")
     159          (display (string-append type " ")) (write line) (newline) )
     160        ((equal? type "<eval>")
     161          (display (string-append type " ")) (write line) (newline) ) ) ) )
     162  (display
     163    (string-append
     164      "Error: "
     165      "(" (->string ((condition-property-accessor 'exn 'location "") exn)) ")"
     166      " " (->string ((condition-property-accessor 'exn 'message "") exn)) ":"
     167      " " (->string ((condition-property-accessor 'exn 'arguments "") exn))))
     168  (newline)
     169  (display "Call history: ") (newline)
     170  (map write-call-entry ((condition-property-accessor 'exn 'call-chain '()) exn))
     171  (newline) )
     172
    149173) ;module condition-utils
  • release/4/condition-utils/tags/1.1.0/condition-utils.setup

    r31306 r32228  
    55(verify-extension-name "condition-utils")
    66
    7 (setup-shared-extension-module 'condition-utils (extension-version "1.0.4")
     7(setup-shared-extension-module 'condition-utils (extension-version "1.1.0")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'standard-conditions (extension-version "1.0.4")
     16(setup-shared-extension-module 'standard-conditions (extension-version "1.1.0")
    1717  #:inline? #t
    1818  #:types? #t
     
    2323    -no-procedure-checks))
    2424
    25 (setup-shared-extension-module 'http-client-conditions (extension-version "1.0.4")
     25(setup-shared-extension-module 'http-client-conditions (extension-version "1.1.0")
    2626  #:inline? #t
    2727  #:types? #t
     
    3232    -no-procedure-checks))
    3333
    34 (setup-shared-extension-module 'intarweb-conditions (extension-version "1.0.4")
     34(setup-shared-extension-module 'intarweb-conditions (extension-version "1.1.0")
    3535  #:inline? #t
    3636  #:types? #t
  • release/4/condition-utils/tags/1.1.0/tests/run.scm

    r29156 r32228  
    1313(test 'foobar (testc-extra-foo testc))
    1414
     15(test "Error: (test) test: (test)\nCall history: \n\n" (with-output-to-string (lambda () (write-exn-condition testc))))
     16
    1517(use standard-conditions)
    1618
  • release/4/condition-utils/trunk/condition-utils.scm

    r31306 r32228  
    2121    make-exn-condition
    2222    make-exn-condition+
     23    ;
     24    write-exn-condition
    2325  )
    2426
    2527  (import scheme chicken)
    2628
    27   (use srfi-1 srfi-69 #;type-checks)
     29  (use srfi-1 srfi-69 data-structures #;type-checks)
    2830
    2931;;;
     
    119121      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )
    120122
     123;;;FIXME should be in standard-conditions module
    121124;;; EXN Condition
    122125
     
    124127
    125128(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
    126   (define (incl tag val) (if val `(,tag ,val) '()) )
     129  (define (incl tag val)
     130    (if val `(,tag ,val) '()) )
    127131  (apply make-property-condition 'exn
    128132    (append!
     
    137141  (define (call-chain? x)
    138142    ;(and (proper-list? x) (every vector? x))
    139     (and
    140       (pair? x)
    141       (vector? (car x))) )
     143    (and (pair? x) (vector? (car x))) )
    142144  (let ((chn (and (not (null? cnds))
    143145                  (call-chain? (car cnds))
     
    147149           (expand-property-conditions (if chn (cdr cnds) cnds))) ) )
    148150
     151;;
     152
     153(define (write-exn-condition exn)
     154  (define (write-call-entry call)
     155    (let ((type (vector-ref call 0))
     156          (line (vector-ref call 1)) )
     157      (cond
     158        ((equal? type "<syntax>")
     159          (display (string-append type " ")) (write line) (newline) )
     160        ((equal? type "<eval>")
     161          (display (string-append type " ")) (write line) (newline) ) ) ) )
     162  (display
     163    (string-append
     164      "Error: "
     165      "(" (->string ((condition-property-accessor 'exn 'location "") exn)) ")"
     166      " " (->string ((condition-property-accessor 'exn 'message "") exn)) ":"
     167      " " (->string ((condition-property-accessor 'exn 'arguments "") exn))))
     168  (newline)
     169  (display "Call history: ") (newline)
     170  (map write-call-entry ((condition-property-accessor 'exn 'call-chain '()) exn))
     171  (newline) )
     172
    149173) ;module condition-utils
  • release/4/condition-utils/trunk/condition-utils.setup

    r31306 r32228  
    55(verify-extension-name "condition-utils")
    66
    7 (setup-shared-extension-module 'condition-utils (extension-version "1.0.4")
     7(setup-shared-extension-module 'condition-utils (extension-version "1.1.0")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks))
    1515
    16 (setup-shared-extension-module 'standard-conditions (extension-version "1.0.4")
     16(setup-shared-extension-module 'standard-conditions (extension-version "1.1.0")
    1717  #:inline? #t
    1818  #:types? #t
     
    2323    -no-procedure-checks))
    2424
    25 (setup-shared-extension-module 'http-client-conditions (extension-version "1.0.4")
     25(setup-shared-extension-module 'http-client-conditions (extension-version "1.1.0")
    2626  #:inline? #t
    2727  #:types? #t
     
    3232    -no-procedure-checks))
    3333
    34 (setup-shared-extension-module 'intarweb-conditions (extension-version "1.0.4")
     34(setup-shared-extension-module 'intarweb-conditions (extension-version "1.1.0")
    3535  #:inline? #t
    3636  #:types? #t
  • release/4/condition-utils/trunk/tests/run.scm

    r29156 r32228  
    1313(test 'foobar (testc-extra-foo testc))
    1414
     15(test "Error: (test) test: (test)\nCall history: \n\n" (with-output-to-string (lambda () (write-exn-condition testc))))
     16
    1517(use standard-conditions)
    1618
Note: See TracChangeset for help on using the changeset viewer.