@@ -67,180 +67,5 @@ (lambda () (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) - -;; ;; this was cached based on results from profiling but it turned out the profiling -;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching -;; ;; in for now but can probably take it out later. -;; ;; -;; (define (debug:calc-verbosity vstr) -;; (or (hash-table-ref/default *verbosity-cache* vstr #f) -;; (let ((res (cond -;; ((number? vstr) vstr) -;; ((not (string? vstr)) 1) -;; ;; ((string-match "^\\s*$" vstr) 1) -;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) -;; (cond -;; ((> (length debugvals) 1) debugvals) -;; ((> (length debugvals) 0)(car debugvals)) -;; (else 1)))) -;; ((args:get-arg "-v") 2) -;; ((args:get-arg "-q") 0) -;; (else 1)))) -;; (hash-table-set! *verbosity-cache* vstr res) -;; res))) -;; -;; ;; check verbosity, #t is ok -;; (define (debug:check-verbosity verbosity vstr) -;; (if (not (or (number? verbosity) -;; (list? verbosity))) -;; (begin -;; (print "ERROR: Invalid debug value \"" vstr "\"") -;; #f) -;; #t)) -;; -;; (define (debug:debug-mode n) -;; (cond -;; ((and (number? *verbosity*) ;; number number -;; (number? n)) -;; (<= n *verbosity*)) -;; ((and (list? *verbosity*) ;; list number -;; (number? n)) -;; (member n *verbosity*)) -;; ((and (list? *verbosity*) ;; list list -;; (list? n)) -;; (not (null? (lset-intersection! eq? *verbosity* n)))) -;; ((and (number? *verbosity*) -;; (list? n)) -;; (member *verbosity* n)))) -;; -;; (define (debug:setup) -;; (let ((debugstr (or (args:get-arg "-debug") -;; (args:get-arg "-debug-noprop") -;; (getenv "MT_DEBUG_MODE")))) -;; (set! *verbosity* (debug:calc-verbosity debugstr)) -;; (debug:check-verbosity *verbosity* debugstr) -;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue -;; (if (not *verbosity*)(set! *verbosity* 1)) -;; (if (and (not (args:get-arg "-debug-noprop")) -;; (or (args:get-arg "-debug") -;; (not (getenv "MT_DEBUG_MODE")))) -;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) -;; (string-intersperse (map conc *verbosity*) ",") -;; (conc *verbosity*)))))) -;; -;; (define (debug:print n e . params) -;; (if (debug:debug-mode n) -;; (with-output-to-port (or e (current-error-port)) -;; (lambda () -;; (if *logging* -;; (db:log-event (apply conc params)) -;; (apply print params) -;; ))))) -;; -;; ;; Brandon's debug printer shortcut (indulge me :) -;; (define *BB-process-starttime* (current-milliseconds)) -;; (define (BB> . in-args) -;; (let* ((stack (get-call-chain)) -;; (location "??")) -;; (for-each -;; (lambda (frame) -;; (let* ((this-loc (vector-ref frame 0)) -;; (temp (string-split (->string this-loc) " ")) -;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) -;; (if (equal? this-func "BB>") -;; (set! location this-loc)))) -;; stack) -;; (let* ((color-on "\x1b[1m") -;; (color-off "\x1b[0m") -;; (dp-args -;; (append -;; (list 0 *default-log-port* -;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) -;; in-args))) -;; (apply debug:print dp-args)))) -;; -;; (define *BBpp_custom_expanders_list* (make-hash-table)) -;; -;; -;; -;; ;; register hash tables with BBpp. -;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: -;; (cons hash-table? hash-table->alist)) -;; -;; ;; test name converter -;; (define (BBpp_custom_converter arg) -;; (let ((res #f)) -;; (for-each -;; (lambda (custom-type-name) -;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) -;; (custom-type-test (car custom-type-info)) -;; (custom-type-converter (cdr custom-type-info))) -;; (when (and (not res) (custom-type-test arg)) -;; (set! res (custom-type-converter arg))))) -;; (hash-table-keys *BBpp_custom_expanders_list*)) -;; (if res (BBpp_ res) arg))) -;; -;; (define (BBpp_ arg) -;; (cond -;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) -;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) -;; ((hash-table? arg) -;; (let ((al (hash-table->alist arg))) -;; (BBpp_ (cons HASH_TABLE: al)))) -;; ((null? arg) '()) -;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) -;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) -;; (else (BBpp_custom_converter arg)))) -;; -;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -;; (define (BBpp arg) -;; (pp (BBpp_ arg))) -;; -;; ;(use define-macro) -;; (define-syntax inspect -;; (syntax-rules () -;; [(_ x) -;; ;; (with-output-to-port (current-error-port) -;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) -;; ;; ) -;; ] -;; [(_ x y ...) (begin (inspect x) (inspect y ...))])) -;; -;; (define (debug:print-error n e . params) -;; ;; normal print -;; (if (debug:debug-mode n) -;; (with-output-to-port (if (port? e) e (current-error-port)) -;; (lambda () -;; (if *logging* -;; (db:log-event (apply conc params)) -;; ;; (apply print "pid:" (current-process-id) " " params) -;; (apply print "ERROR: " params) -;; )))) -;; ;; pass important messages to stderr -;; (if (and (eq? n 0)(not (eq? e (current-error-port)))) -;; (with-output-to-port (current-error-port) -;; (lambda () -;; (apply print "ERROR: " params) -;; )))) -;; -;; (define (debug:print-info n e . params) -;; (if (debug:debug-mode n) -;; (with-output-to-port (if (port? e) e (current-error-port)) -;; (lambda () -;; (if *logging* -;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) -;; (db:log-event res)) -;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) -;; (apply print "INFO: (" n ") " params) ;; res) -;; ))))) -;; -;; -;; -;; ;; if a value is printable (i.e. string or number) return the value -;; ;; else return an empty string -;; (define-inline (printable val) -;; (if (or (number? val)(string? val)) val "")) -;; -;;