diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/main.scm | 44 | ||||
-rw-r--r-- | module/util/config.scm | 11 |
2 files changed, 27 insertions, 28 deletions
diff --git a/module/main.scm b/module/main.scm index 331268f8..31d6957c 100644 --- a/module/main.scm +++ b/module/main.scm @@ -169,29 +169,29 @@ (string->symbol stprof))))) -(use-modules (system vm frame)) +(define logport (make-parameter (open-file "/tmp/calp.xml" "a"))) (define (main args) + + (when (zero? (ftell (logport))) + (format (logport) "<?xml version=\"1.0\" encoding=\"UTF-8\"?>~%")) + + (format (logport) "<run><start>~a</start>~%" + ((@ (datetime util) datetime->string) + ((@ (datetime) current-datetime)))) (report-time! "Program start") ;; ((@ (util config) print-configuration-documentation)) - (with-throw-handler #t - (lambda () (dynamic-wind (lambda () 'noop) - (lambda () (catch 'return (lambda () (wrapped-main args)) values)) - (lambda () (run-hook shutdown-hook)) - )) - (lambda (err . args) - (define stack (make-stack #t)) - (with-output-to-port (current-error-port) - (lambda () - (format #t "bindings = ") - (let loop ((frame (stack-ref stack 0))) - (when frame - (format #t "~{~a~^ ~}" (map binding-name (frame-bindings frame))) - (let ((event (and=> (frame-lookup-binding frame 'event) - binding-ref))) - (when event - (format (current-error-port) "event = ~a~%" event))) - - (loop (frame-previous frame)))) - (format #t "~%") - ))))) + (let ((stack #f)) + (catch #t + (lambda () (dynamic-wind (lambda () 'noop) + (lambda () (catch 'return (lambda () (wrapped-main args)) values)) + (lambda () (run-hook shutdown-hook)) + )) + (lambda (err raiser fmt . args) + (format #t "Calp has crashed with [~a], +~?~%See ~a for full backtrace~%" + err fmt args (port-filename (logport))) + (format (logport) "<trace>~%<![CDATA[~%") + (display-backtrace stack (logport)) + (format (logport) "]]></trace></run>~%")) + (lambda _ (set! stack (make-stack #t)))))) diff --git a/module/util/config.scm b/module/util/config.scm index a5d29f8e..0131335d 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -92,12 +92,11 @@ (set-value! conf it) ((config-attribute conf #:post identity) it)) - (scm-error 'config-error 'define-config - "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%" - (list (quote ,name) - value - (get-documentation conf)) - (list value)) + (throw 'config-error 'set-config! + "~a->~a = ~s is invalid,~%Field doc is \"~a\"" + (module-name (get-source-module conf)) + key value + (get-documentation conf)) ))] [else (hashq-set! config-values key (make-unconfig value))])) |