Changeset 34102 in project


Ignore:
Timestamp:
05/29/17 21:37:20 (5 months ago)
Author:
kon
Message:

added errorf/no-raise, param for format proc

Location:
release/4/error-utils
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/error-utils/tags/1.1.0/error-utils.meta

    r27651 r34102  
    88 (synopsis "Error Utilities")
    99 (depends
    10   (setup-helper "1.5.2")
    11   (moremacros "1.2.0")
    12   (variable-item "1.3.0"))
     10  (setup-helper "1.5.2"))
    1311 (test-depends test)
    1412 (files "error-utils.release-info" "error-utils.meta" "tests/run.scm" "error-utils.scm" "error-utils.setup") )
  • release/4/error-utils/tags/1.1.0/error-utils.scm

    r24156 r34102  
    11;;;; error-utils.scm
    22;;;; Kon Lovett, Aug '10
     3;;;; Kon Lovett, Aug '17
    34
    45(module error-utils
    56
    6   (;export
    7     *error/no-raise
    8     error/no-raise
    9     error-format-procedure
    10     errorf)
     7(;export
     8  error/no-raise
     9  *error/no-raise
     10  errorf
     11  errorf/no-raise
     12  error-format-procedure)
    1113
    12   (import
    13     scheme
    14     chicken
    15     (only ports with-output-to-port)
    16     (only extras format)
    17     (only type-checks check-procedure))
     14(import scheme)
    1815
    19   (require-library ports extras type-checks)
     16(import chicken)
    2017
    21   (use variable-item)
     18(import (only extras format) )
     19(require-library extras)
     20
     21(import (only data-structures chop ->string) )
     22(require-library data-structures)
     23
     24;;;
     25
     26;; Print error message but don't throw an exception
     27;;
     28(define (error/no-raise . args)
     29  (let* ((len (length args) )
     30         (argls (and (<= 2 len) (chop args (fx- len 1))) )
     31         (args (if argls (car argls) args) )
     32         (port (and argls (caadr argls)) )
     33         (args (if (port? port) args (append args (if port `(,port) '()))) )
     34         (port (if (port? port) port (current-error-port)) ) )
     35    (*error/no-raise args port) ) )
     36
     37;; Print error-style message to port
     38;; unlike 'error' will print arguments when loc but no msg
     39;;
     40(define (*error/no-raise args #!optional (port (current-error-port)))
     41  (let-values (((loc msg args) (error-params args)))
     42    (newline port)
     43    (display
     44      (string-append
     45        "Error"
     46        (if (or loc msg) ": " "")
     47        (if (and loc msg) (string-append "(" (->string loc) ")") "")
     48        " "
     49        (or (and msg (->string msg)) (and loc (->string loc)) ""))
     50      port)
     51    (unless (null? args)
     52      (if (null? (cdr args))
     53        (begin (display ": " port) (write (car args) port))
     54        (for-each (lambda (arg) (newline port) (write arg port)) args) ) )
     55    (newline port) ) )
     56
     57;;
     58(define (errorf . args)
     59  (*errorf error args) )
     60
     61;;
     62(define (errorf/no-raise . args)
     63  (*errorf error/no-raise args) )
     64
     65;; Format procedure for error
     66;;
     67(define error-format-procedure
     68  (make-parameter
     69    format
     70    (lambda (x)
     71      (if (procedure? x)
     72        x
     73        (begin
     74          (warning 'error-format-procedure "invalid procedure" x)
     75          (error-format-procedure) ) ) ) ) )
     76
     77;;;
     78
     79;;
     80(define (*errorf proc args)
     81  (let-values (((loc fmt fmtargs) (error-params args)))
     82    (if (not fmt)
     83      (apply proc args)
     84      (proc loc (apply (error-format-procedure) #f fmt fmtargs)) ) ) )
    2285
    2386;; Parse error-style argument list into 3 values
    24 
     87;;
    2588(define (error-params args)
    26   (let* ((loc (and (not (null? args)) (symbol? (car args)) (car args)) )
    27          (msg (if (not loc) (and (not (null? args)) (string? (car args)) (car args))
    28                 (and (not (null? (cdr args))) (string? (cadr args)) (cadr args))) )
    29          (args (if (and loc msg) (cddr args) (if (or loc msg) (cdr args) args)) ) )
     89  (let* (
     90      (loc
     91        (and
     92          (not (null? args))
     93          (symbol? (car args)) (car args)) )
     94      (msg
     95        (if (not loc)
     96          (and
     97            (not (null? args))
     98            (string? (car args)) (car args))
     99          (and
     100            (not (null? (cdr args)))
     101            (string? (cadr args)) (cadr args)) ) )
     102      (args
     103        (if (and loc msg)
     104          (cddr args)
     105          (if (or loc msg)
     106            (cdr args)
     107            args ) ) ) )
    30108    (values loc msg args) ) )
    31109
    32 ;; Print error-style message to port
    33 
    34 ; unlike 'error' will print arguments when loc but no msg
    35 
    36 (define (*error/no-raise args #!optional (port (current-error-port)))
    37   (newline port)
    38   (display "Error" port)
    39   (let-values (((loc msg args) (error-params args)))
    40     (when (or loc msg) (display ": " port))
    41     (when (and loc msg) (display #\( port) (display loc port) (display ") " port))
    42     (if msg
    43        (display msg port)
    44        (when loc (display loc port)))
    45     (unless (null? args)
    46       (if (null? (cdr args))
    47           (begin (display ": " port) (write (car args) port))
    48           (for-each (lambda (arg) (newline port) (write arg port)) args) ) ) )
    49   (newline port) )
    50 
    51 ;; Print error message but don't throw an exception
    52 
    53 (define (error/no-raise . args) (*error/no-raise args))
    54 
    55 ;; Format version of error
    56 
    57 (define-checked-variable error-format-procedure format procedure)
    58 
    59 (define (errorf . args)
    60   (let-values (((loc fmt fmtargs) (error-params args)))
    61     (if (not fmt) (apply error args)
    62       (error loc (apply (error-format-procedure) #f fmt fmtargs)) ) ) )
    63 
    64110) ;module error-utils
  • release/4/error-utils/tags/1.1.0/error-utils.setup

    r27651 r34102  
    55(verify-extension-name "error-utils")
    66
    7 (setup-shared-extension-module 'error-utils (extension-version "1.0.3")
     7(setup-shared-extension-module 'error-utils (extension-version "1.1.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -scrutinize
    10     -fixnum-arithmetic
    11     -optimize-level 3
    12     -no-procedure-checks -no-bound-checks -no-argc-checks))
     12    -optimize-level 3 -debug-level 1
     13    -no-procedure-checks))
  • release/4/error-utils/tags/1.1.0/tests/run.scm

    r21080 r34102  
    1 (use error-utils)
    21(use test)
    32
     3(use error-utils)
     4
    45(test-group "errorf"
     6
    57  (test-error (errorf "foo"))
     8  (errorf/no-raise "foo")
     9
    610  (test-error (errorf 'foo))
     11  (errorf/no-raise 'foo)
     12
    713  (test-error (errorf 'foo "foo"))
     14  (errorf/no-raise 'foo "foo")
     15
    816  (test-error (errorf "foo ~A ~S" "hello" "hello"))
     17  (errorf/no-raise "foo ~A ~S" "hello" "hello")
    918)
    1019
    11 (unless (zero? (test-failure-count)) (exit 1))
     20(error/no-raise 'foo "bar" 'baz 1 (current-output-port))
     21(error/no-raise 'foo "bar" 'baz 1)
     22
     23(test-exit)
  • release/4/error-utils/trunk/error-utils.meta

    r27651 r34102  
    88 (synopsis "Error Utilities")
    99 (depends
    10   (setup-helper "1.5.2")
    11   (moremacros "1.2.0")
    12   (variable-item "1.3.0"))
     10  (setup-helper "1.5.2"))
    1311 (test-depends test)
    1412 (files "error-utils.release-info" "error-utils.meta" "tests/run.scm" "error-utils.scm" "error-utils.setup") )
  • release/4/error-utils/trunk/error-utils.scm

    r24156 r34102  
    11;;;; error-utils.scm
    22;;;; Kon Lovett, Aug '10
     3;;;; Kon Lovett, Aug '17
    34
    45(module error-utils
    56
    6   (;export
    7     *error/no-raise
    8     error/no-raise
    9     error-format-procedure
    10     errorf)
     7(;export
     8  error/no-raise
     9  *error/no-raise
     10  errorf
     11  errorf/no-raise
     12  error-format-procedure)
    1113
    12   (import
    13     scheme
    14     chicken
    15     (only ports with-output-to-port)
    16     (only extras format)
    17     (only type-checks check-procedure))
     14(import scheme)
    1815
    19   (require-library ports extras type-checks)
     16(import chicken)
    2017
    21   (use variable-item)
     18(import (only extras format) )
     19(require-library extras)
     20
     21(import (only data-structures chop ->string) )
     22(require-library data-structures)
     23
     24;;;
     25
     26;; Print error message but don't throw an exception
     27;;
     28(define (error/no-raise . args)
     29  (let* ((len (length args) )
     30         (argls (and (<= 2 len) (chop args (fx- len 1))) )
     31         (args (if argls (car argls) args) )
     32         (port (and argls (caadr argls)) )
     33         (args (if (port? port) args (append args (if port `(,port) '()))) )
     34         (port (if (port? port) port (current-error-port)) ) )
     35    (*error/no-raise args port) ) )
     36
     37;; Print error-style message to port
     38;; unlike 'error' will print arguments when loc but no msg
     39;;
     40(define (*error/no-raise args #!optional (port (current-error-port)))
     41  (let-values (((loc msg args) (error-params args)))
     42    (newline port)
     43    (display
     44      (string-append
     45        "Error"
     46        (if (or loc msg) ": " "")
     47        (if (and loc msg) (string-append "(" (->string loc) ")") "")
     48        " "
     49        (or (and msg (->string msg)) (and loc (->string loc)) ""))
     50      port)
     51    (unless (null? args)
     52      (if (null? (cdr args))
     53        (begin (display ": " port) (write (car args) port))
     54        (for-each (lambda (arg) (newline port) (write arg port)) args) ) )
     55    (newline port) ) )
     56
     57;;
     58(define (errorf . args)
     59  (*errorf error args) )
     60
     61;;
     62(define (errorf/no-raise . args)
     63  (*errorf error/no-raise args) )
     64
     65;; Format procedure for error
     66;;
     67(define error-format-procedure
     68  (make-parameter
     69    format
     70    (lambda (x)
     71      (if (procedure? x)
     72        x
     73        (begin
     74          (warning 'error-format-procedure "invalid procedure" x)
     75          (error-format-procedure) ) ) ) ) )
     76
     77;;;
     78
     79;;
     80(define (*errorf proc args)
     81  (let-values (((loc fmt fmtargs) (error-params args)))
     82    (if (not fmt)
     83      (apply proc args)
     84      (proc loc (apply (error-format-procedure) #f fmt fmtargs)) ) ) )
    2285
    2386;; Parse error-style argument list into 3 values
    24 
     87;;
    2588(define (error-params args)
    26   (let* ((loc (and (not (null? args)) (symbol? (car args)) (car args)) )
    27          (msg (if (not loc) (and (not (null? args)) (string? (car args)) (car args))
    28                 (and (not (null? (cdr args))) (string? (cadr args)) (cadr args))) )
    29          (args (if (and loc msg) (cddr args) (if (or loc msg) (cdr args) args)) ) )
     89  (let* (
     90      (loc
     91        (and
     92          (not (null? args))
     93          (symbol? (car args)) (car args)) )
     94      (msg
     95        (if (not loc)
     96          (and
     97            (not (null? args))
     98            (string? (car args)) (car args))
     99          (and
     100            (not (null? (cdr args)))
     101            (string? (cadr args)) (cadr args)) ) )
     102      (args
     103        (if (and loc msg)
     104          (cddr args)
     105          (if (or loc msg)
     106            (cdr args)
     107            args ) ) ) )
    30108    (values loc msg args) ) )
    31109
    32 ;; Print error-style message to port
    33 
    34 ; unlike 'error' will print arguments when loc but no msg
    35 
    36 (define (*error/no-raise args #!optional (port (current-error-port)))
    37   (newline port)
    38   (display "Error" port)
    39   (let-values (((loc msg args) (error-params args)))
    40     (when (or loc msg) (display ": " port))
    41     (when (and loc msg) (display #\( port) (display loc port) (display ") " port))
    42     (if msg
    43        (display msg port)
    44        (when loc (display loc port)))
    45     (unless (null? args)
    46       (if (null? (cdr args))
    47           (begin (display ": " port) (write (car args) port))
    48           (for-each (lambda (arg) (newline port) (write arg port)) args) ) ) )
    49   (newline port) )
    50 
    51 ;; Print error message but don't throw an exception
    52 
    53 (define (error/no-raise . args) (*error/no-raise args))
    54 
    55 ;; Format version of error
    56 
    57 (define-checked-variable error-format-procedure format procedure)
    58 
    59 (define (errorf . args)
    60   (let-values (((loc fmt fmtargs) (error-params args)))
    61     (if (not fmt) (apply error args)
    62       (error loc (apply (error-format-procedure) #f fmt fmtargs)) ) ) )
    63 
    64110) ;module error-utils
  • release/4/error-utils/trunk/error-utils.setup

    r27651 r34102  
    55(verify-extension-name "error-utils")
    66
    7 (setup-shared-extension-module 'error-utils (extension-version "1.0.3")
     7(setup-shared-extension-module 'error-utils (extension-version "1.1.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -scrutinize
    10     -fixnum-arithmetic
    11     -optimize-level 3
    12     -no-procedure-checks -no-bound-checks -no-argc-checks))
     12    -optimize-level 3 -debug-level 1
     13    -no-procedure-checks))
  • release/4/error-utils/trunk/tests/run.scm

    r21080 r34102  
    1 (use error-utils)
    21(use test)
    32
     3(use error-utils)
     4
    45(test-group "errorf"
     6
    57  (test-error (errorf "foo"))
     8  (errorf/no-raise "foo")
     9
    610  (test-error (errorf 'foo))
     11  (errorf/no-raise 'foo)
     12
    713  (test-error (errorf 'foo "foo"))
     14  (errorf/no-raise 'foo "foo")
     15
    816  (test-error (errorf "foo ~A ~S" "hello" "hello"))
     17  (errorf/no-raise "foo ~A ~S" "hello" "hello")
    918)
    1019
    11 (unless (zero? (test-failure-count)) (exit 1))
     20(error/no-raise 'foo "bar" 'baz 1 (current-output-port))
     21(error/no-raise 'foo "bar" 'baz 1)
     22
     23(test-exit)
Note: See TracChangeset for help on using the changeset viewer.