Changeset 35182 in project


Ignore:
Timestamp:
02/23/18 05:10:37 (7 months ago)
Author:
kon
Message:

better names, re-flow

File:
1 edited

Legend:

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

    r34409 r35182  
    77(;export
    88  ;
    9   error/no-raise *error/no-raise
     9  error-format-procedure
    1010  ;
    11   errorf errorf/no-raise
     11  errorf
    1212  ;
    13   error-format-procedure)
     13  error-print *error-print
     14  errorf-print
     15  ;
     16  error/no-raise *error/no-raise errorf/no-raise)
    1417
    15 (import scheme)
    16 
    17 (import chicken)
    18 
    19 (import (only extras format))
    20 (require-library extras)
    21 
    22 (import (only data-structures chop ->string string-intersperse) )
    23 (require-library data-structures)
    24 
    25 (import (only (srfi 1) append!) )
    26 (require-library (srfi 1))
     18(import scheme  chicken)
     19(use
     20  (only extras format)
     21  (only data-structures chop ->string string-intersperse)
     22  (only (srfi 1) append!) )
    2723
    2824;;;
     
    3026;; Print error message but don't throw an exception
    3127;;
    32 (define (error/no-raise . args)
    33   (receive (port args) (error-port-args args)
    34     (*error/no-raise args port) ) )
     28(define (error-print . args)
     29  (let-values (((port args) (error-port-args args)))
     30    (*error-print args port) ) )
    3531
    3632;; Print error-style message to port
    3733;; unlike 'error' will print arguments when loc but no msg
    3834;;
    39 (define (*error/no-raise args #!optional (port (current-error-port)))
    40   (receive (loc msg args) (error-params args)
     35(define (*error-print args #!optional (port (current-error-port)))
     36  (let-values (((loc msg args) (error-params args)))
    4137    (let (
    42         (errmsg
    43           (string-append
    44             "\n"
    45             "Error" (if (or loc msg) ": " "")
    46             (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
    47             (or (and msg (->string msg)) (and loc (->string loc)) "")
    48             (cond
    49               ((null? args)
    50                 "" )
    51               ((null? (cdr args))
    52                 (string-append ": " (->sexpr-string (car args))) )
    53               (else
    54                 ;leading empty string so leading newline
    55                 (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
    56             "\n" )))
     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" )))
    5753      (display errmsg port) ) ) )
    5854
     
    6258
    6359;;
    64 (define (errorf/no-raise . args)
    65   (receive (port args) (error-port-args args)
    66     (*errorf port error/no-raise args) ) )
     60(define (errorf-print . args)
     61  (let-values (((port args) (error-port-args args)))
     62    (*errorf port error-print args) ) )
    6763
    6864;; Format procedure for error
     
    8379(define (*errorf port proc args)
    8480  (let ((portarg (if port `(,port) '())))
    85     (receive (loc fmt fmtargs) (error-params args)
     81    (let-values (((loc fmt fmtargs) (error-params args)))
    8682      (let (
    87           (err-args
    88             (if (not fmt)
    89               (append args portarg)
    90               (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
    91                 (if loc
    92                   (append! `(,loc ,msg) portarg)
    93                   (append! `(,msg) portarg) ) ) ) ) )
     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) ) ) ) ) )
    9490        (apply proc err-args) ) ) ) )
    9591
     
    10298(define (error-params args)
    10399  (let* (
    104       (loc
     100    (loc
     101      (and
     102        (not (null? args))
     103        (symbol? (car args)) (car args)) )
     104    (msg
     105      (if (not loc)
    105106        (and
    106107          (not (null? args))
    107           (symbol? (car args)) (car args)) )
    108       (msg
    109         (if (not loc)
    110           (and
    111             (not (null? args))
    112             (string? (car args)) (car args))
    113           (and
    114             (not (null? (cdr args)))
    115             (string? (cadr args)) (cadr args)) ) )
    116       (args
    117         (if (and loc msg)
    118           (cddr args)
    119           (if (or loc msg)
    120             (cdr args)
    121             args ) ) ) )
     108          (string? (car args)) (car args))
     109        (and
     110          (not (null? (cdr args)))
     111          (string? (cadr args)) (cadr args)) ) )
     112    (args
     113      (cond
     114        ((and loc msg)  (cddr args) )
     115        ((or loc msg)   (cdr args) )
     116        (else           args ) ) ) )
    122117    (values loc msg args) ) )
    123118
    124 ;; Parse error/no-raise style argument list into (values port args)
     119;; Parse error-print style argument list into (values port args)
    125120;;
    126121(define (error-port-args args)
    127   (let* ((len (length args) )
    128          (argls (and (<= 2 len) (chop args (fx- len 1))) )
    129          (args (if argls (car argls) args) )
    130          (port (and argls (caadr argls)) )
    131          (args (if (port? port) args (append args (if port `(,port) '()))) )
    132          (port (if (port? port) port (current-error-port)) ) )
     122  (let* (
     123    (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)) ) )
    133129    (values port args) ) )
    134130
     131;;;
     132
     133(define error/no-raise error-print)
     134(define *error/no-raise *error-print)
     135(define errorf/no-raise errorf-print)
     136
    135137) ;module error-utils
Note: See TracChangeset for help on using the changeset viewer.