;;;; error-utils.scm -*- Scheme -*- ;;;; Kon Lovett, Jul '18 ;;;; Kon Lovett, may '17 ;;;; Kon Lovett, Aug '10 (module error-utils (;export ; error-format-procedure ; errorf ; error-print *error-print errorf-print) (import scheme (chicken base) (chicken fixnum) (only (chicken format) format) (only (chicken string) ->string string-intersperse) (only (srfi 1) append!) ) ;;; ;; Print error message but don't throw an exception ;; (define (error-print . args) (let-values (((port args) (error-port-args args))) (*error-print args port) ) ) ;; Print error-style message to port ;; unlike 'error' will print arguments when loc but no msg ;; (define (*error-print args #!optional (port (current-error-port))) (let-values (((loc msg args) (error-params args))) (let ( (errmsg (string-append "\n" "Error" (if (or loc msg) ": " "") (if (and loc msg) (string-append "(" (->string loc) ")" " ") "") (or (and msg (->string msg)) (and loc (->string loc)) "") (cond ((null? args) "" ) ((null? (cdr args)) (string-append ": " (->sexpr-string (car args))) ) (else ;leading empty string so leading newline (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) ) "\n" ))) (display errmsg port) ) ) ) ;; (define (errorf . args) (*errorf #f error args) ) ;; (define (errorf-print . args) (let-values (((port args) (error-port-args args))) (*errorf port error-print args) ) ) ;; Format procedure for error ;; (define error-format-procedure (make-parameter format (lambda (x) (if (procedure? x) x (begin (warning 'error-format-procedure "invalid procedure" x) (error-format-procedure) ) ) ) ) ) ;;; ;; (define (*errorf port proc args) (let ((portarg (if port `(,port) '()))) (let-values (((loc fmt fmtargs) (error-params args))) (let ( (err-args (if (not fmt) (append args portarg) (let ((msg (apply (error-format-procedure) #f fmt fmtargs))) (if loc (append! `(,loc ,msg) portarg) (append! `(,msg) portarg) ) ) ) ) ) (apply proc err-args) ) ) ) ) ;; (define (->sexpr-string obj) ((error-format-procedure) #f "~S" obj) ) ;; Parse error style argument list into (values loc msg args) ;; (define (error-params args) (let* ( (loc (and (not (null? args)) (symbol? (car args)) (car args)) ) (msg (if (not loc) (and (not (null? args)) (string? (car args)) (car args)) (and (not (null? (cdr args))) (string? (cadr args)) (cadr args)) ) ) (args (cond ((and loc msg) (cddr args) ) ((or loc msg) (cdr args) ) (else args ) ) ) ) (values loc msg args) ) ) ;; Parse error-print style argument list into (values port args) ;; (define (error-port-args args) (let* ( (len (length args) ) (argls (and (<= 2 len) (chop args (fx- len 1))) ) (args (if argls (car argls) args) ) (port (and argls (caadr argls)) ) (args (if (port? port) args (append args (if port `(,port) '()))) ) (port (if (port? port) port (current-error-port)) ) ) (values port args) ) ) ) ;module error-utils