Changeset 34142 in project


Ignore:
Timestamp:
05/31/17 20:38:54 (3 weeks ago)
Author:
kon
Message:

fix *error/no-raise. Add port argument.

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

Legend:

Unmodified
Added
Removed
  • release/4/error-utils/tags/1.2.0/error-utils.scm

    r34102 r34142  
    11;;;; error-utils.scm
    22;;;; Kon Lovett, Aug '10
    3 ;;;; Kon Lovett, Aug '17
     3;;;; Kon Lovett, may '17
    44
    55(module error-utils
    66
    77(;export
    8   error/no-raise
    9   *error/no-raise
    10   errorf
    11   errorf/no-raise
     8  ;
     9  error/no-raise *error/no-raise
     10  ;
     11  errorf errorf/no-raise
     12  ;
    1213  error-format-procedure)
    1314
     
    1516
    1617(import chicken)
     18(import (only extras format) )
     19(import (only data-structures chop ->string string-intersperse) )
    1720
    18 (import (only extras format) )
    19 (require-library extras)
    20 
    21 (import (only data-structures chop ->string) )
    22 (require-library data-structures)
     21(import (only (srfi 1) append!) )
     22(require-library (srfi 1))
    2323
    2424;;;
     
    2727;;
    2828(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)) ) )
     29  (receive (port args) (error-port-args args)
    3530    (*error/no-raise args port) ) )
    3631
     
    3934;;
    4035(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) ) )
     36  (receive (loc msg args) (error-params args)
     37    (let (
     38        (errmsg
     39          (string-append
     40            "\n"
     41            "Error" (if (or loc msg) ": " "")
     42            (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
     43            (or (and msg (->string msg)) (and loc (->string loc)) "")
     44            (cond
     45              ((null? args)
     46                "" )
     47              ((null? (cdr args))
     48                (string-append ": " (->sexpr-string (car args))) )
     49              (else
     50                ;leading empty string so leading newline
     51                (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
     52            "\n" )))
     53      (display errmsg port) ) ) )
    5654
    5755;;
    5856(define (errorf . args)
    59   (*errorf error args) )
     57  (*errorf #f error args) )
    6058
    6159;;
    6260(define (errorf/no-raise . args)
    63   (*errorf error/no-raise args) )
     61  (receive (port args) (error-port-args args)
     62    (*errorf port error/no-raise args) ) )
    6463
    6564;; Format procedure for error
     
    7877
    7978;;
    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)) ) ) )
     79(define (*errorf port proc args)
     80  (let ((portarg (if port `(,port) '())))
     81    (receive (loc fmt fmtargs) (error-params args)
     82      (let (
     83          (err-args
     84            (if (not fmt)
     85              (append args portarg)
     86              (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
     87                (if loc
     88                  (append! `(,loc ,msg) portarg)
     89                  (append! `(,msg) portarg) ) ) ) ) )
     90        (apply proc err-args) ) ) ) )
    8591
    86 ;; Parse error-style argument list into 3 values
     92;;
     93(define (->sexpr-string obj)
     94  ((error-format-procedure) #f "~S" obj) )
     95
     96;; Parse error style argument list into (values loc msg args)
    8797;;
    8898(define (error-params args)
     
    108118    (values loc msg args) ) )
    109119
     120;; Parse error/no-raise style argument list into (values port args)
     121;;
     122(define (error-port-args args)
     123  (let* ((len (length args) )
     124         (argls (and (<= 2 len) (chop args (fx- len 1))) )
     125         (args (if argls (car argls) args) )
     126         (port (and argls (caadr argls)) )
     127         (args (if (port? port) args (append args (if port `(,port) '()))) )
     128         (port (if (port? port) port (current-error-port)) ) )
     129    (values port args) ) )
     130
    110131) ;module error-utils
  • release/4/error-utils/tags/1.2.0/error-utils.setup

    r34102 r34142  
    55(verify-extension-name "error-utils")
    66
    7 (setup-shared-extension-module 'error-utils (extension-version "1.1.0")
     7(setup-shared-extension-module 'error-utils (extension-version "1.2.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    11     -scrutinize
    12     -optimize-level 3 -debug-level 1
     11    -optimize-level 3 -debug-level 2
    1312    -no-procedure-checks))
  • release/4/error-utils/tags/1.2.0/tests/run.scm

    r34102 r34142  
    33(use error-utils)
    44
    5 (test-group "errorf"
     5(test-group "errorf & errorf/no-raise"
    66
    7   (test-error (errorf "foo"))
    8   (errorf/no-raise "foo")
     7  (test
     8    "\nError: msg\n"
     9    (call-with-output-string
     10      (lambda (port)
     11        (errorf/no-raise "msg" port))))
     12  (test-error (errorf "msg"))
    913
    10   (test-error (errorf 'foo))
    11   (errorf/no-raise 'foo)
     14  (test
     15    "\nError: loc\n"
     16    (call-with-output-string
     17      (lambda (port)
     18        (errorf/no-raise 'loc port))))
     19  (test-error (errorf 'loc))
    1220
    13   (test-error (errorf 'foo "foo"))
    14   (errorf/no-raise 'foo "foo")
     21  (test
     22    "\nError: (loc) msg\n"
     23    (call-with-output-string
     24      (lambda (port)
     25        (errorf/no-raise 'loc "msg" port))))
     26  (test-error (errorf 'loc "msg"))
    1527
    16   (test-error (errorf "foo ~A ~S" "hello" "hello"))
    17   (errorf/no-raise "foo ~A ~S" "hello" "hello")
     28  (test
     29    "\nError: msg hello \"hello\"\n"
     30    (call-with-output-string
     31      (lambda (port)
     32        (errorf/no-raise "msg ~A ~S" "hello" "hello" port))))
     33  (test-error (errorf "msg ~A ~S" "hello" "hello"))
     34
     35  (test
     36    "\nError: (loc) msg hello \"hello\"\n"
     37    (call-with-output-string
     38      (lambda (port)
     39        (errorf/no-raise 'loc "msg ~A ~S" "hello" "hello" port))))
     40  (test-error (errorf 'loc "msg ~A ~S" "hello" "hello"))
    1841)
    1942
    20 (error/no-raise 'foo "bar" 'baz 1 (current-output-port))
    21 (error/no-raise 'foo "bar" 'baz 1)
     43(test-group "error/no-raise"
     44  (test
     45    "\nError: (loc) msg\narg\n1\n"
     46    (call-with-output-string
     47      (lambda (port)
     48        (error/no-raise 'loc "msg" 'arg 1 port))))
     49  (test-error (error 'loc "msg" 'arg 1))
     50)
    2251
    2352(test-exit)
  • release/4/error-utils/trunk/error-utils.scm

    r34102 r34142  
    11;;;; error-utils.scm
    22;;;; Kon Lovett, Aug '10
    3 ;;;; Kon Lovett, Aug '17
     3;;;; Kon Lovett, may '17
    44
    55(module error-utils
    66
    77(;export
    8   error/no-raise
    9   *error/no-raise
    10   errorf
    11   errorf/no-raise
     8  ;
     9  error/no-raise *error/no-raise
     10  ;
     11  errorf errorf/no-raise
     12  ;
    1213  error-format-procedure)
    1314
     
    1516
    1617(import chicken)
     18(import (only extras format) )
     19(import (only data-structures chop ->string string-intersperse) )
    1720
    18 (import (only extras format) )
    19 (require-library extras)
    20 
    21 (import (only data-structures chop ->string) )
    22 (require-library data-structures)
     21(import (only (srfi 1) append!) )
     22(require-library (srfi 1))
    2323
    2424;;;
     
    2727;;
    2828(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)) ) )
     29  (receive (port args) (error-port-args args)
    3530    (*error/no-raise args port) ) )
    3631
     
    3934;;
    4035(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) ) )
     36  (receive (loc msg args) (error-params args)
     37    (let (
     38        (errmsg
     39          (string-append
     40            "\n"
     41            "Error" (if (or loc msg) ": " "")
     42            (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
     43            (or (and msg (->string msg)) (and loc (->string loc)) "")
     44            (cond
     45              ((null? args)
     46                "" )
     47              ((null? (cdr args))
     48                (string-append ": " (->sexpr-string (car args))) )
     49              (else
     50                ;leading empty string so leading newline
     51                (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
     52            "\n" )))
     53      (display errmsg port) ) ) )
    5654
    5755;;
    5856(define (errorf . args)
    59   (*errorf error args) )
     57  (*errorf #f error args) )
    6058
    6159;;
    6260(define (errorf/no-raise . args)
    63   (*errorf error/no-raise args) )
     61  (receive (port args) (error-port-args args)
     62    (*errorf port error/no-raise args) ) )
    6463
    6564;; Format procedure for error
     
    7877
    7978;;
    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)) ) ) )
     79(define (*errorf port proc args)
     80  (let ((portarg (if port `(,port) '())))
     81    (receive (loc fmt fmtargs) (error-params args)
     82      (let (
     83          (err-args
     84            (if (not fmt)
     85              (append args portarg)
     86              (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
     87                (if loc
     88                  (append! `(,loc ,msg) portarg)
     89                  (append! `(,msg) portarg) ) ) ) ) )
     90        (apply proc err-args) ) ) ) )
    8591
    86 ;; Parse error-style argument list into 3 values
     92;;
     93(define (->sexpr-string obj)
     94  ((error-format-procedure) #f "~S" obj) )
     95
     96;; Parse error style argument list into (values loc msg args)
    8797;;
    8898(define (error-params args)
     
    108118    (values loc msg args) ) )
    109119
     120;; Parse error/no-raise style argument list into (values port args)
     121;;
     122(define (error-port-args args)
     123  (let* ((len (length args) )
     124         (argls (and (<= 2 len) (chop args (fx- len 1))) )
     125         (args (if argls (car argls) args) )
     126         (port (and argls (caadr argls)) )
     127         (args (if (port? port) args (append args (if port `(,port) '()))) )
     128         (port (if (port? port) port (current-error-port)) ) )
     129    (values port args) ) )
     130
    110131) ;module error-utils
  • release/4/error-utils/trunk/error-utils.setup

    r34102 r34142  
    55(verify-extension-name "error-utils")
    66
    7 (setup-shared-extension-module 'error-utils (extension-version "1.1.0")
     7(setup-shared-extension-module 'error-utils (extension-version "1.2.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    11     -scrutinize
    12     -optimize-level 3 -debug-level 1
     11    -optimize-level 3 -debug-level 2
    1312    -no-procedure-checks))
  • release/4/error-utils/trunk/tests/run.scm

    r34102 r34142  
    33(use error-utils)
    44
    5 (test-group "errorf"
     5(test-group "errorf & errorf/no-raise"
    66
    7   (test-error (errorf "foo"))
    8   (errorf/no-raise "foo")
     7  (test
     8    "\nError: msg\n"
     9    (call-with-output-string
     10      (lambda (port)
     11        (errorf/no-raise "msg" port))))
     12  (test-error (errorf "msg"))
    913
    10   (test-error (errorf 'foo))
    11   (errorf/no-raise 'foo)
     14  (test
     15    "\nError: loc\n"
     16    (call-with-output-string
     17      (lambda (port)
     18        (errorf/no-raise 'loc port))))
     19  (test-error (errorf 'loc))
    1220
    13   (test-error (errorf 'foo "foo"))
    14   (errorf/no-raise 'foo "foo")
     21  (test
     22    "\nError: (loc) msg\n"
     23    (call-with-output-string
     24      (lambda (port)
     25        (errorf/no-raise 'loc "msg" port))))
     26  (test-error (errorf 'loc "msg"))
    1527
    16   (test-error (errorf "foo ~A ~S" "hello" "hello"))
    17   (errorf/no-raise "foo ~A ~S" "hello" "hello")
     28  (test
     29    "\nError: msg hello \"hello\"\n"
     30    (call-with-output-string
     31      (lambda (port)
     32        (errorf/no-raise "msg ~A ~S" "hello" "hello" port))))
     33  (test-error (errorf "msg ~A ~S" "hello" "hello"))
     34
     35  (test
     36    "\nError: (loc) msg hello \"hello\"\n"
     37    (call-with-output-string
     38      (lambda (port)
     39        (errorf/no-raise 'loc "msg ~A ~S" "hello" "hello" port))))
     40  (test-error (errorf 'loc "msg ~A ~S" "hello" "hello"))
    1841)
    1942
    20 (error/no-raise 'foo "bar" 'baz 1 (current-output-port))
    21 (error/no-raise 'foo "bar" 'baz 1)
     43(test-group "error/no-raise"
     44  (test
     45    "\nError: (loc) msg\narg\n1\n"
     46    (call-with-output-string
     47      (lambda (port)
     48        (error/no-raise 'loc "msg" 'arg 1 port))))
     49  (test-error (error 'loc "msg" 'arg 1))
     50)
    2251
    2352(test-exit)
Note: See TracChangeset for help on using the changeset viewer.