;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; cdb.scm - A console-based CHICKEN debugger
;;;
;;; Copyright (c) 2015-2022, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

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

(import (chicken blob)
        (chicken condition)
        (chicken file)
        (chicken foreign)
        (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 type))

(import (srfi 13)
        (srfi 14)
        (srfi 69)
        (except (srfi 1) break)
        (prefix (debugger-protocol) debugger-)
        (vector-lib))

(import-for-syntax (vector-lib))



;;;
;;; Helper syntax.
;;;

(define-syntax begin0-let
  (syntax-rules ()
    ((_ ((a e) . r) . b)
     (let ((a e) . r) (begin . b) a))))

(define-syntax interruptable
  (syntax-rules ()
    ((_ e)
     (condition-case e
       ((user-interrupt)
        (comment "interrupted")
        (unbound))))))

(define-syntax fallible
  (syntax-rules ()
    ((_ e) (fallible () e))
    ((_ c e) (condition-case e (x c x)))))

(define-syntax define-foreign
  (cond-expand
    (compiling
     (syntax-rules ()
       ((_ name expr) (define name expr))))
    (else
     (syntax-rules ()
       ((_ name expr)
        (begin
          (import (compile-file))
          (with-output-to-file "_f.scm" (lambda () (write `(define name expr))))
          (compile-file "_f.scm")
          (delete-file "_f.scm")))))))

(define-constant runtime-location "<runtime>")
(define-constant more-trace-message "... more ...")
(define-constant help-text "\
; break [<event>]    toggle breakpoint
; connect            await connection
; continue           resume program
; disconnect         terminate program and reconnect
; events             show breakable events
; print <item>       inspect item
; info               show current event
; mask [<mask> ...]  set active event types
; next [<event> ...] run program until next event
; quit               terminate program and exit
; step [<count>]     step program
; trace              print call history
")



;;;
;;; General-purpose utilities.
;;;

(define error-message
  (condition-property-accessor 'exn 'message "unknown"))

(define error-arguments
  (condition-property-accessor 'exn 'arguments '()))

(define (comment format . args)
  (fprintf (current-error-port) "; ~?~n" format args))

(define (comment-error e)
  (let ((m (error-message e))
        (a (error-arguments e)))
    (if (null? a)
        (comment "error: ~a" m)
        (comment "error: ~a: ~a" m (string-join (map ->string a))))))

(define (make-error type message . args)
  (make-composite-condition
   (make-property-condition type)
   (make-property-condition 'exn 'message message 'arguments args)))

(define (fail . args)
  (signal (apply make-error args)))

(define (user-interrupt n)
  (signal (make-property-condition 'user-interrupt 'signal n)))

(define (eof) #!eof)

(define nonnegative-integer?
  (conjoin integer? (complement negative?)))

(define (unbound . _)
  (block-ref 'aardvark 0))

(define undefined void)

(define (unbound? x)
  (eq? (unbound) x))

(define (undefined? x)
  (eq? (undefined) x))

(define (datum->string s)
  (sprintf "~s" s))

(define (string->datum s)
  (call-with-input-string s read))

(define (read-line* . port)
  (read-list (open-input-string (apply read-line port))))

(define (lset-disjoin f l . ls)
  (lset-difference f l ls))

(define (vector-max f v)
  (vector-fold (lambda (_ n e) (max (f e) n)) 0 v))

(define (vector-filter f v)
  (list->vector (filter-map f (vector->list v))))

(define (symbol-length x)
  (string-length (symbol->string x)))

(define ((adjoin f) . a)
  (and (apply f a)
       (apply values a)))

(define ((partial f . a) . b)
  (apply f (append a b)))

(define read-lines/vector
  (compose list->vector read-lines))



;;;
;;; Procedure call memoization, used for caching remote object slots.
;;;

(define (with-cached-result table key thunk)
  (condition-case (hash-table-ref (table) key)
    ((exn access)
     (begin0-let ((value (thunk)))
       (hash-table-set! (table) key value)))))

(define (forget-cached-results! table)
  (hash-table-clear! (table)))



;;;
;;; Debug info helpers.
;;;

;; XXX this is a nasty hack
;; shadow record type from debugger-client
(define-record dbg-info event location value c-location data)

(define make-dbg-info
  (let ((make-dbg-info make-dbg-info))
    (lambda args
      (begin0-let ((x (apply make-dbg-info args)))
        (block-set! x 0 'debugger-protocol#dbg-info)))))

(define debug-info-separators
  (char-set #\# #\space))

(define (debug-info-location s)
  (and (string? s)
       (let* ((i (string-index s #\:))
              (j (if (not i)
                     (string-index s debug-info-separators)
                     (string-index s debug-info-separators (+ i 1)))))
         (cond ((not i) runtime-location)
               ((not j) s)
               ((= i j) s)
               (else (substring s 0 j))))))

(define (debug-info-value s)
  (and (string? s)
       (let* ((i (string-index-right s debug-info-separators))
              (x (string->datum (if (not i) s (substring s (+ i 1))))))
         (and (symbol? x)
              (symbol->string x)))))

(define (debug-info-filename s)
  (and (string? s)
       (let ((i (string-index s #\:)))
         (and i (substring s 0 i)))))

(define (debug-info-line-number s)
  (and (string? s)
       (let ((i (string-index s #\:)))
         (and i (string->number (substring s (add1 i)))))))

(define (trace->event s)
  (let ((p (string-split s " ")))
    (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))

(define (dbg-info-location info)
  (debug-info-location (debugger-dbg-info-location info)))

(define (dbg-info-value info)
  (debug-info-value (debugger-dbg-info-value info)))

(define (dbg-info->trace info)
  (and-let* ((location (dbg-info-location info))
             (value    (dbg-info-value info)))
    (sprintf "~a ~a~n" location value)))

(define (print-dbg-info info)
  (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)))



;;;
;;; Source file handling
;;;

(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))

(define (dbg-info-source-listing i #!optional (n-context 5))
  (and-let* ((l (dbg-info-location i))
             (f (debug-info-filename l))
             (n (debug-info-line-number l))
             (_ (file-exists? f))
             (v (read-source f))
             (n-min (max (- n n-context 1) 0))
             (n-max (min (+ n n-context 0) (vector-length v))))
    (vector-map
     (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))))



;;;
;;; Events
;;;

(define-constant event-types
  #(call global-assign gc entry signal connect listen interrupted))

(define-constant mask/none '())
(define-constant mask/all (vector->list event-types))

(define-inline (event-type? x)
  (memq x mask/all))

(define (valid-mask? x)
  (and (list? x) (every (disjoin event-type? integer?) x)))

(define (make-mask x)
  (if (valid-mask? x)
      (delete-duplicates x)
      (fail 'cdb "invalid event mask" x)))

(define unknown
  (let ()
    (define-record unknown)
    (make-unknown)))

(define (unknown? x)
  (eq? x unknown))

(define-record event id type location value)

(define-record-printer (event x port)
  (fprintf port "#<event ~a ~a ~a ~a>"
           (event-id x)
           (event-type x)
           (event-location x)
           (event-value x)))

(define (list->event l)
  (let ((type     (second l))
        (location (third l))
        (value    (fourth l)))
    (make-event (first l)
                (vector-ref event-types (sub1 type))
                (debug-info-location location)
                (debug-info-value value))))

(define (event->dbg-info e)
  (make-dbg-info (event-type e) (event-location e) (event-value e) #f #f))

(define (event->debug-info e)
  (conc (event-location e) " " (event-value e) (event-value e)))

(define (dbg-info->event i)
  (make-event #f (dbg-info-type i) (dbg-info-location i) (dbg-info-value i)))

(define (event=? . es)
  (apply = (map event-id es)))

(define (event<? . es)
  (apply < (map event-id es)))

(define (event-exists? e)
  (vector-any (constantly #t) (find-events e (current-events))))

(define (make-event-predicate x)
  (cond ((event? x)
         (lambda (e) (event=? x e)))
        ((number? x)
         (lambda (e) (= (event-id e) x)))
        ((symbol? x)
         (make-event-predicate (symbol->string x)))
        ((string? x)
         (lambda (e)
           (let* ((value    (event-value e))
                  (location (event-location e))
                  (filename (debug-info-filename location)))
             (or (and (string? value)
                      (string-contains value x))
                 (and (string? location)
                      (string=? location x))
                 (and (not (string-index x #\:))
                      (string? filename)
                      (string=? filename x))))))
        (else
         (fail 'cdb "invalid event specifier" x))))

(define (find-event x #!optional (events (current-events)))
  (let* ((f (make-event-predicate x))
         (n (vector-count (lambda (_ e) (f e)) events)))
    (when (> n 1)
      (fail 'cdb "ambiguous event" x))
    (begin0-let ((e (vector-any (lambda (e) (and (f e) e)) events)))
      (when (not e)
        (fail 'cdb "no such event" x)))))

(define (find-events x #!optional (events (current-events)))
  (let ((f (make-event-predicate x)))
    (vector-filter (lambda (e) (and (f e) e)) events)))

(define (fetch-events debugger)
  (let ((data (debugger-dbg-info-data (debugger-list-events debugger))))
    (list->vector (filter-map list->event data))))



;;;
;;; Remote object handling.
;;;

(define-record remote address cache)

(define-record-printer (remote x port)
  (fprintf port "#<~a (remote) #x~a>"
           (remote-type x)
           (number->string (remote-address x) 16)))

(define-foreign become-flonum!
  (foreign-lambda* void ((scheme-object x))
    "C_block_header(x) &= C_HEADER_SIZE_MASK;"
    "C_block_header(x) |= C_FLONUM_TYPE;"))

(define-record lambda-info >string)

(define-record-printer (lambda-info x port)
  (fprintf port "#<lambda-info ~s>" (lambda-info->string x)))

(define (remote-slots x)
  (with-cached-result current-remote-slots
   x
   (lambda ()
     (let ((data (debugger-dbg-info-data
                  (debugger-get-slots (debugger) (remote-address x)))))
       (first data)))))

(define (remote-type x)
  (case (list-ref (remote-slots x) 1)
    ((0)  'vector)
    ((1)  'symbol)
    ((3)  'pair)
    ((8)  'structure)
    ((15) 'bucket)
    ((36) 'procedure)
    ((39) 'port)
    ((41) 'pointer)
    ((42) 'locative)
    ((43) 'tagged-pointer)
    ((66) 'string)
    ((77) 'lambda-info)
    ((80) 'blob)
    ((85) 'flonum)
    (else (error "unrecognized value type" x))))

(define (localize-remote x)
  (define slots
    (list-tail (remote-slots x) 2))
  (define (localize-string)
    (list->string (map integer->char slots)))
  (case (remote-type x)
    ((string)
     (localize-string))
    ((blob)
     (string->blob (localize-string)))
    ((symbol)
     (string->symbol (localize (translate (second slots)))))
    ((lambda-info)
     (make-lambda-info (localize-string)))
    ((pair)
     (cons (localize (translate (first slots)))
           (localize (translate (second slots)))))
    ((flonum)
     (begin0-let ((x’ (localize-string)))
       (become-flonum! x’)))
    ((vector)
     (list->vector (map (compose localize translate) slots)))
    (else x)))

(define (localize x)
  (if (remote? x) (localize-remote x) x))



(define (translate-fixnum x) x)

(define (translate-immediate x)
  (case x
    ((6)  #f)
    ((22) #t)
    ((30) (undefined))
    ((46) (unbound))
    ((62) (eof))
    ((14) (list))
    (else (integer->char x))))

(define (translate-remote x)
  (make-remote x #f))

(define (translate-complex x)
  (let* ((s (symbol->string x))
         (n (string->number (substring s 1))))
    (case (string-ref s 0)
      ((#\=) (translate-immediate n))
      ((#\@) (translate-remote n))
      (else  (error "unknown value" x)))))

(define (translate x)
  (cond ((fixnum? x) (translate-fixnum x))
        ((symbol? x) (translate-complex x))
        (else        (error "unknown value" x))))



;;;
;;; Debugger state.
;;;

;; Local parameters.
(define current-mask
  (make-parameter mask/all))

(define current-breakpoints
  (make-parameter '() (lambda (events) (sort events event<?))))

;; Connection-specific parameters.
(define current-info (make-parameter #f))
(define current-events (make-parameter #()))
(define current-source-files (make-parameter #f))
(define current-remote-slots (make-parameter #f))

(define current-connection
  (make-parameter
   #f
   (adjoin
    (lambda (connection)
      (unless (not connection)
        (current-info #f)
        (current-events #())
        (current-breakpoints '())
        (current-source-files (make-hash-table))
        (current-remote-slots (make-hash-table)))))))

(define disconnect-handler (make-parameter void))

(define (debugger)
  (or (current-connection)
      (fail 'cdb "no debugger connection")))

(define (current-arguments)
  (let* ((data (debugger-dbg-info-data (debugger-get-arguments (debugger))))
         (args (first data)))
    (if (null? args)
        (list)
        (cons (translate (car args))
              (map translate (cddr args))))))

(define (valid-argument? x)
  (and (nonnegative-integer? x)
       (< x (length (current-arguments)))))

(define (continue-program)
  (let ((info (debugger-continue (debugger))))
    (unless (debugger-dbg-info? info)
      (fail 'i/o "client program terminated"))
    (forget-cached-results! current-remote-slots)
    ;; NOTE signal events always break so check against mask
    (if (and (eq? (dbg-info-type info) 'signal)
             (not (memq 'signal (current-mask))))
        (continue-program)
        (current-info info))))

(define (set-mask! x)
  (let ((mask (make-mask x)))
    (unless (lset= equal? (current-mask) mask)
      (debugger-set-event-mask (debugger) mask)
      (current-mask mask))
    (current-mask)))

(define (debug-wind before thunk after)
  (dynamic-wind before thunk (lambda () (fallible (debug) (after)))))

(define (with-mask mask thunk)
  (let ((original (current-mask)))
    (debug-wind
     (lambda () (set-mask! mask))
     (lambda () (thunk))
     (lambda () (set-mask! original)))))

(define (set-breakpoints! events)
  (let*-values (((diff int) (lset-diff+intersection event=? (current-breakpoints) events))
                ((events’)  (lset-difference event=? events int)))
    (for-each remove-breakpoint! diff)
    (for-each add-breakpoint! events’)))

(define (add-breakpoint! event)
  (debugger-set-breakpoint (debugger) (event-id event))
  (current-breakpoints (lset-adjoin event=? (current-breakpoints) event)))

(define (remove-breakpoint! event)
  (debugger-clear-breakpoint (debugger) (event-id event))
  (current-breakpoints (lset-disjoin event=? (current-breakpoints) event)))

(define (breakpoint-enabled? event)
  (member event (current-breakpoints) event=?))

(define (toggle-breakpoint! event)
  (if (breakpoint-enabled? event)
      (remove-breakpoint! event)
      (add-breakpoint! event)))

(define (with-breakpoints events thunk)
  (let ((original (current-breakpoints)))
    (debug-wind
     (lambda () (set-breakpoints! events))
     (lambda () (thunk))
     (lambda () (set-breakpoints! original)))))

(define (list-events!)
  (current-events
   (vector-append (current-events)
                  (fetch-events (debugger)))))



(define (assert-argument-count args n #!optional (m n))
  (unless (<= n (length args) m)
    (fail 'arity ; Fake a runtime-generated arity error.
          (sprintf "bad argument count - received ~a but expected ~a"
                   (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))
        (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)))
    (do ((i 0 (add1 i)))
        ((= i n))
      (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) 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 event-location) trace))))
    (do ((t trace (cdr t)))
        ((null? t))
      (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))
         (max-v (vector-max (compose string-length ->string) v)))
    (do ((i 0 (add1 i)))
        ((= i n))
      (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))))))



;;;
;;; Command definitions.
;;;

(define-record command name arguments)

(define (command name . arguments)
  (make-command name arguments))

(define-record-printer (command x port)
  (fprintf port "~a" (cons (command-name x) (command-arguments x))))

(define-syntax define-command
  (syntax-rules ()
    ((_ (n . a) . b)
     (define (n . a)
       (condition-case (begin . b)
         (e (debug)
          (comment (error-message e))
          (undefined))
         (e (i/o)
          (comment "connection lost: ~a" (error-message e))
          (disconnect)))))))

(define (help)
  (display help-text))

(define (valid-protocol-version? info)
  (equal? (last (string-split info ":"))
          (number->string debugger-protocol-version)))

(define (connect)
  (comment "awaiting client connection...")
  (receive (connection info) (debugger-wait)
    (unless (valid-protocol-version? info)
      (error 'connect "protocol version mismatch"))
    (debugger-set-event-mask connection (current-mask))
    (current-connection connection)))

(define (disconnect)
  (current-connection #f)
  ((disconnect-handler)))

(define (terminate)
  (when (current-connection)
    (comment "terminating client program...")
    (fallible (i/o) (debugger-terminate (debugger)))
    (disconnect)))

(define-command (arguments)
  (current-arguments))

(define-command (argument x)
  (unless (nonnegative-integer? x)
    (error 'argument "invalid argument number" x))
  (let ((a (current-arguments)))
    (if (<= (length a) x)
        (undefined)
        (list-ref a x))))

(define-command (breakpoints)
  (current-breakpoints))

(define-command (break . points)
  (assert-argument-count points 0 1)
  (list-events!)
  (if (pair? points)
      (toggle-breakpoint! (find-event (car points)))
      (current-breakpoints)))

(define-command (event . id)
  (assert-argument-count id 0 1)
  (list-events!)
  (if (pair? id)
      (find-event (car id) (current-events))
      (and (current-info)
           (dbg-info->event (current-info)))))

(define-command (events . filter)
  (assert-argument-count filter 0 1)
  (list-events!)
  (if (pair? filter)
      (find-events (car filter) (current-events))
      (current-events)))

(define-command (continue)
  (continue-program))

(define-command (step . count)
  (assert-argument-count count 0 1)
  (with-mask mask/all
   (lambda ()
     (let ((n (optional count 1)))
       (do ((i 0 (+ i 1))
            (e (undefined) (continue-program)))
           ((= i n) e))))))

(define-command (next . args)
  (define (next/events events)
    (let ((events* (map find-event events)))
      (with-breakpoints events* continue-program)))
  (define (next/mask events)
    (let ((mask (if (pair? events) events mask/all)))
      (with-mask mask continue-program)))
  (let-values (((mask events) (partition event-type? args)))
    (cond ((null? args) (step))
          ((null? mask) (next/events events))
          ((null? events) (next/mask mask))
          (else (with-breakpoints (map find-event events)
                 (lambda () (next/mask mask)))))))

(define-command (mask . events)
  (assert-argument-count events 0 +inf.0)
  (cond ((memq 'none events)
         (set-mask! mask/none))
        ((memq 'all events)
         (set-mask! mask/all))
        ((pair? events)
         (set-mask! events))
        (else
         (current-mask))))

(define-command (source)
  (and-let* ((i (current-info)))
    (dbg-info-source-listing i 4)))

(define-command (trace)
  (filter-map
   (lambda (data)
     (let ((s (first data)))
       (cond ((string=? s "...more...") #f)
             ((string-suffix? "<--" s)
              (trace->event (string-trim-right (string-drop-right s 3))))
             (else
              (trace->event s)))))
   (debugger-dbg-info-data (debugger-get-trace (debugger)))))

(define-command (value x)
  (cond ((remote? x) (localize x))
        ((symbol? x)
         (let ((data (debugger-dbg-info-data (debugger-get-global (debugger) x))))
           (case (first (first data))
             ((UNKNOWN) (unbound))
             (else => translate))))
        (else
         (error 'argument "unprintable expression" x))))



;;;
;;; Console.
;;;

(define (run-command c)
  (case (command-name c)
    ((h help ?)
     (apply help (command-arguments c)))
    ((connect)
     (apply disconnect (command-arguments c)))
    ((disconnect)
     (apply terminate (command-arguments c)))
    ((q quit)
     (parameterize ((disconnect-handler quit))
       (apply terminate (command-arguments c))))
    ((b break)
     (let ((x (apply break (command-arguments c))))
       (cond ((undefined? x))
             ((pair? x) (print-events (list->vector x)))
             (else (comment "no breakpoints")))))
    ((n next)
     (let ((x (apply next (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((s step)
     (let ((x (apply step (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((c continue)
     (let ((x (apply continue (command-arguments c))))
       (when (debugger-dbg-info? x) (print-dbg-info x))))
    ((a arguments)
     (let ((a (apply arguments (command-arguments c))))
       (if (pair? a)
           (print-arguments a)
           (comment "no arguments"))))
    ((e events)
     (let ((e (apply events (command-arguments c))))
       (if (vector? e)
           (print-events e)
           (comment "no events"))))
    ((i info)
     (let ((e (apply event (command-arguments c))))
       (if (event? e)
           (print-dbg-info (event->dbg-info e))
           (comment "no info"))))
    ((l list)
     (let ((x (apply source (command-arguments c))))
       (if (vector? x)
           (vector-for-each (lambda (_ line) (print line)) x)
           (comment "no source file"))))
    ((m mask)
     (let ((x (apply mask (command-arguments c))))
       (if (pair? x)
           (comment (string-join (map ->string (current-mask))))
           (comment "none"))))
    ((p print)
     (pretty-print (apply value (command-arguments c))))
    ((t trace)
     (let ((t (apply trace (command-arguments c))))
       (if (pair? t)
           (print-trace t)
           (comment "no trace"))))
    (else
     (comment "unrecognized command ~a" c))))

(define (read-command-arguments)
  (dynamic-wind
   (lambda ()
     (set-read-syntax!
      #\$
      (lambda (p)
        (let ((n (read p)))
          (if (valid-argument? n)
              (argument n)
              (error "invalid argument" n))))))
   (lambda () (read-line*))
   (lambda () (set-sharp-read-syntax! #\a #f))))

(define (read-command)
  (let ((e (interruptable (read))))
    (cond ((symbol? e)
           (make-command e (read-command-arguments)))
          (else e))))

(define (evaluate c)
  (let ((x (eval c)))
    (unless (undefined? x) (printf "~s~n" x))))

(define (run-input)
  (let ((c (read-command)))
    (cond ((unbound? c))
          ((undefined? c))
          ((eof-object? c) (disconnect))
          ((command? c) (run-command c))
          (else (evaluate c)))))

(define (console . _)
  (let ((connection (interruptable (connect))))
    (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))



;;;
;;; Entry point.
;;;

(unless (feature? #:csi)
  (compiled-entrypoint))