~evhan/beaker

5ac39f9cc2280c8a817620b49ee668dd7ce52ceb — Evan Hanson 1 year, 10 months ago dc15593
Various fixes and feature tweaks to cdb
1 files changed, 75 insertions(+), 47 deletions(-)

M cdb.scm
M cdb.scm => cdb.scm +75 -47
@@ 8,12 8,14 @@
;;;

(declare
  (module cdb)
  (module beaker.cdb)
  (export connect disconnect terminate)
  (export continue next step)
  (export argument arguments)
  (export break mask)
  (export event events source trace value))
  (export event events source trace value)
  (export cdb)
  (not usual-integrations block-ref))

(import (chicken blob)
        (chicken condition)


@@ 22,16 24,18 @@
        (chicken format)
        (chicken io)
        (chicken memory representation)
        (chicken platform)
        (chicken port)
        (chicken pretty-print)
        (chicken process-context)
        (chicken process signal)
        (chicken read-syntax)
        (chicken repl)
        (chicken sort)
        (chicken string))
        (chicken string)
        (chicken type))

(import (begin-syntax)
        (srfi 13)
(import (srfi 13)
        (srfi 14)
        (srfi 69)
        (except (srfi 1) break)


@@ 239,7 243,9 @@

(define (trace->event s)
  (let ((p (string-split s " ")))
    (make-event #f 'call (string-trim-right (first p) #\:) (second p))))
    (if (= (length p) 1)
        (make-event #f 'call runtime-location (first p))
        (make-event #f 'call (string-trim-right (first p) #\:) (second p)))))

(define (dbg-info-type info)
  (debugger-dbg-info-event info))


@@ 253,18 259,13 @@
(define (dbg-info->trace info)
  (and-let* ((location (dbg-info-location info))
             (value    (dbg-info-value info)))
    (string-append (location-prefix location) value)))
    (sprintf "~a ~a~n" location value)))

(define (print-dbg-info info)
  (and-let* ((type     (dbg-info-type info))
             (location (dbg-info-location info))
             (value    (dbg-info-value info)))
    (printf "~a[~a] ~a~n" (location-prefix location) type value)))

(define (location-prefix location)
  (if (string-prefix? "<" location)
      (string-append location " ")
      (string-append location ": ")))
  (let ((type     (dbg-info-type info))
        (location (or (dbg-info-location info) runtime-location))
        (value    (or (dbg-info-value info) "(none)")))
    (printf "~a ~a | ~a~n" location type value)))





@@ 275,6 276,18 @@
(define (read-source path)
  (call-with-input-file path read-lines/vector))

(define (ansify s #!optional (type 'none))
  (and (terminal-port? (current-output-port))
       (let ((term (get-environment-variable "TERM")))
         (and (string? term)
              (not (string=? term "dumb"))))
       (case type
         ((bolden) (conc "\x1b[1m" s "\x1b[0m"))
         ((lighten) (conc "\x1b[2m" s "\x1b[0m"))
         ((italicize) (conc "\x1b[3m" s "\x1b[0m"))
         ((underline) (conc "\x1b[4m" s "\x1b[0m"))
         (else s))))

(define (format-source-location f i s n-min n-max)
  (format "~a:~a ~a" f (format-number string-pad-right (+ n-min i 1) n-max) s))



@@ 287,7 300,9 @@
             (n-min (max (- n n-context 1) 0))
             (n-max (min (+ n n-context 0) (vector-length v))))
    (vector-map
     (lambda (i s) (format-source-location f i s n-min n-max))
     (lambda (i s)
       (ansify (format-source-location f i s n-min n-max)
               (if (= (+ n-min i 1) n) 'bolden 'none)))
     (vector-copy v n-min n-max))))




@@ 622,15 637,17 @@
                   (length args)
                   (if (= n m) n (sprintf "~a-~a" n m))))))

(: format-string ((#!rest -> string) string number -> string))
(define (format-string pad s len-max)
  (pad s len-max))

(: format-number ((#!rest -> string) number number -> string))
(define (format-number pad n n-max)
  (pad (number->string n)
       (inexact->exact (max (ceiling (/ (log (max n-max 1)) (log 9))) 1))))

(define (print-events events)
  (let ((n (vector-length events))
  (let ((n        (vector-length events))
        (max-id   (vector-max event-id events))
        (max-loc  (vector-max (compose string-length ->string event-location) events))
        (max-type (vector-max (compose string-length ->string event-type) events)))


@@ 639,25 656,35 @@
      (let ((e (vector-ref events i)))
        (printf "[~a] ~a ~a | ~a~n"
                (format-number string-pad (event-id e) max-id)
                (format-string string-pad-right (or (event-location e) "(none)") (add1 max-loc))
                (format-string string-pad-right (or (event-location e) runtime-location) (max max-loc 9))
                (format-string string-pad (symbol->string (event-type e)) max-type)
                (or (event-value e) "(none)"))))))

(define (print-trace trace)
  (let ((max-loc (apply max (map (compose string-length location-prefix event-location) trace))))
  (let ((max-loc (apply max (map (compose string-length event-location) trace))))
    (do ((t trace (cdr t)))
        ((null? t))
      (let ((x (car trace)))
        (printf "~a~a~n"
                (format-string string-pad-right (location-prefix (event-location x)) max-loc)
      (let ((x (car t)))
        (printf "~a ~a~n"
                (format-string string-pad-right (event-location x) max-loc)
                (event-value x))))))

(define (summarize-argument x)
  (let ((x* (localize x)))
    (if (eq? x* x)
        (string)
        (format " ; ~s" x*))))

(define (print-arguments arguments)
  (let* ((v (list->vector arguments))
         (n (vector-length v)))
  (let* ((v     (list->vector arguments))
         (n     (vector-length v))
         (max-v (vector-max (compose string-length ->string) v)))
    (do ((i 0 (add1 i)))
        ((= i n))
      (printf "#a~a ~s~n" (format-number string-pad-right i n) (vector-ref v i)))))
      (printf "$~a = ~a~a~n"
              (format-number string-pad-right i n)
              (format-string string-pad-right (->string (vector-ref v i)) max-v)
              (summarize-argument (vector-ref v i))))))





@@ 822,9 849,6 @@
     (apply disconnect (command-arguments c)))
    ((disconnect)
     (apply terminate (command-arguments c)))
    ((terminate)
     (parameterize ((disconnect-handler void))
       (apply terminate (command-arguments c))))
    ((q quit)
     (parameterize ((disconnect-handler quit))
       (apply terminate (command-arguments c))))


@@ 880,8 904,8 @@
(define (read-command-arguments)
  (dynamic-wind
   (lambda ()
     (set-sharp-read-syntax!
      #\a
     (set-read-syntax!
      #\$
      (lambda (p)
        (let ((n (read p)))
          (if (valid-argument? n)


@@ 910,15 934,24 @@

(define (console . _)
  (let ((connection (interruptable (connect))))
    (when (unbound? connection) (quit))
    (parameterize ((current-connection connection)
                   (disconnect-handler console))
      (let loop ()
        (printf "(cdb) ")
        (flush-output)
        (condition-case (run-input)
          (e () (comment-error e)))
        (loop)))))
    (unless (unbound? connection)
      (parameterize ((current-connection connection)
                     (repl-prompt (constantly "(cdb) ")))
        (let loop ()
          (unless (feature? #:csi)
            (printf ((repl-prompt)))
            (flush-output))
          (condition-case (run-input)
            (e () (comment-error e)))
          (loop))))))

(define (cdb)
  (disconnect-handler reset)
  (console))

(define (compiled-entrypoint)
  (set-signal-handler! signal/int user-interrupt)
  (console))





@@ 926,10 959,5 @@
;;; Entry point.
;;;

(cond-expand
  (compiling
   (set-signal-handler! signal/int user-interrupt)
   (console))
  (chicken-script
   (console))
  (else))
(unless (feature? #:csi)
  (compiled-entrypoint))