src/TeXmacs/progs/kernel/boot/debug.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : debug.scm
   5 ;; DESCRIPTION : debugging tools
   6 ;; COPYRIGHT   : (C) 2002  Joris van der Hoeven, David Allouche
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (kernel boot debug))
  15
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;; Output
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19
  20 (define-public (display* . l)
  21   "Display all objects in @l."
  22   (for-each display l))
  23
  24 (define-public (display-err x)
  25   "Display @x to the error port."
  26   (tm-errput (display-to-string x)))
  27
  28 (define-public (display-err* . l)
  29   "Display all objects in @l to the error port."
  30   (for-each display-err l))
  31
  32 (define-public (tm-display-error . l)
  33   (apply display-err* `("TeXmacs] " ,@l "\n")))
  34
  35 (define-public (write* . l)
  36   "Write all objects in @l to standard output."
  37   (for-each write l))
  38
  39 (define-public (write-err x)
  40   "Write @x to the error port."
  41   (tm-errput (object->string x)))
  42
  43 (define-public (write-err* . l)
  44   "Write all objects in @l to the error port."
  45   (for-each write-err l))
  46
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;; Various tools
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50
  51 (define-public footer-hook (lambda (s) s))
  52
  53 (define-macro (benchmark message . args)
  54   `(let ((start (texmacs-time)))
  55      (begin ,@args)
  56      (display* ,message " " (- (texmacs-time) start) "msec\n")))
  57
  58 (define-public (write-diff t u)
  59   (cond ((== t u) (noop))
  60         ((or (not (and (pair? t) (pair? u))) (not (= (length t) (length u))))
  61          (display "< ")
  62          (write t)
  63          (display "\n> ")
  64          (write u)
  65          (display "\n"))
  66         (else
  67          (write-diff (car t) (car u))
  68          (write-diff (cdr t) (cdr u)))))
  69
  70 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71 ;; TeXmacs errors and assertions
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73
  74 (define old-format?
  75   (catch 'wrong-number-of-args
  76          (lambda () (car))
  77          (lambda (type caller message opts extra)
  78            (let next ((l (string->list message)))
  79              (cond ((null? l) #f)
  80                    ((char=? #\% (car l)) #t)
  81                    (else (next (cdr l))))))))
  82
  83 (define (scm-error* type caller message . opt)
  84   (if old-format?
  85       (begin (set! message (string-replace message "~S" "%S"))
  86              (set! message (string-replace message "~A" "%s"))))
  87   (apply scm-error type caller message opt))
  88
  89 (define-public (texmacs-error where message . args)
  90   (scm-error* 'texmacs-error where message args #f))
  91
  92 (define-public (check-arg-type pred arg caller)
  93   (if (pred arg) arg
  94       (scm-error* 'wrong-type-arg caller
  95                   "Wrong type argument: ~S" (list arg) '())))
  96
  97 (define-public (check-arg-number pred num caller)
  98   (if (pred num) num
  99       (scm-error* 'wrong-number-of-args caller
 100                   "Wrong number of arguments: ~A" (list num) '())))
 101
 102 (define-public (check-arg-range pred arg caller)
 103   (if (pred arg) arg
 104       (scm-error* 'out-of-range caller
 105                   "Argument out of range: ~S" (list arg) '())))
 106
 107 (define-public (syntax-error where message . args)
 108   (scm-error* 'syntax-error where message args #f))
 109
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;;; Regression testing
 112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113
 114 (define-public (regression-test-equal group test res-in result exp-in expected)
 115   (if (not (equal? result expected))
 116       (begin
 117         (newline)
 118         (display* "Expected in - " (object->string exp-in) "\n")
 119         (display* "Result   in - " (object->string res-in) "\n")
 120         (display* "Expected - " (object->string expected) "\n")
 121         (display* "Result   - " (object->string result) "\n")
 122         (display* "Do not match!\n")
 123         (display* "Regression failure: " group " / " test)
 124         (error "Regression failure:" group test))))
 125
 126 (define-public (regression-test-nequal
 127                 group test res-in result exp-in expected)
 128   (if (equal? result expected)
 129       (begin
 130         (newline)
 131         (display* "Expected Not in - " (object->string exp-in) "\n")
 132         (display* "Result       in - " (object->string res-in) "\n")
 133         (display* "Expected Not - " (object->string expected) "\n")
 134         (display* "Result       - " (object->string result) "\n")
 135         (display* "Unwanted match! Regression failure!\n")
 136         (display* "Regression failure: " group " / " test)
 137         (error "Regression failure:" group test))))
 138
 139 (define-public-macro (regression-test-group
 140                       group-desc group-id result-cmd expected-cmd . body)
 141   (let* ((make-command (lambda (cmd)
 142                          (if (equal? cmd ':none)
 143                              (lambda (x) x)
 144                              (lambda (x) (list cmd x)))))
 145          (make-result (make-command result-cmd))
 146          (make-expected (make-command expected-cmd))
 147          (tests
 148           (let rec ((n 1) (l body))     ; process body items
 149             (define (check-test)
 150               (let ((t (first l)))
 151                 (if (null? (cdr t))
 152                     (error "empty test in group " group-id))
 153                 (let ((test-desc (second t)))
 154                   (check-arg-type string? test-desc group-id)
 155                   (check-arg-number (lambda (x) (equal? 4 x)) (length t)
 156                                     (string-append group-id "/" test-desc)))))
 157             (define (make-test e?)
 158               (check-test)
 159               (let* ((t (first l))
 160                      (test-desc (second t))
 161                      (result-in (third t))
 162                      (expected-in (fourth t))
 163                      (result (make-result result-in))
 164                      (expected (make-expected expected-in)))
 165                 ;; Display messages and run test.
 166                 `((display ,(string-append "  -- " test-desc "\n"))
 167                   (,(if e? 'regression-test-equal 'regression-test-nequal)
 168                    ,group-id ,test-desc
 169                    ,result-in ,result ,expected-in ,expected)
 170                   ,@(rec (1+ n) (cdr l))))) ; rest of the body
 171             (cond ((null? l) `(,(1- n))) ; evaluate to number of tests
 172                   ;; Improper list or unexpect atom. Nevermind.
 173                   ((not (pair? l)) l)
 174                   ((not (pair? (car l)))
 175                    (cons (car l) (rec n (cdr l))))
 176                   ;; Test case.
 177                   ((equal? 'test (caar l)) (make-test #t))
 178                   ((equal? 'test-fails (caar l)) (make-test #f))
 179                   ;; Non-test form, preserve.
 180                   (else (cons (car l) (rec n (cdr l))))))))
 181     `(begin
 182        (display ,(string-append "Test group: " group-desc " [" group-id "]\n"))
 183        ,@tests)))
 184
 185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 186 ;;; Test suite library
 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188
 189 (define-public-macro (regtest-table-library)
 190   ;; basic shorthands for input of texmacs tables
 191   `(begin
 192      (define (cell x) `(cell ,x))
 193      (define (row l) `(row ,@(map cell l)))
 194      (define (table ll) `(table ,@(map row ll)))
 195      (define (tformat pp ll) `(tformat ,@pp ,(table ll)))
 196      (define (colwith i var val) `(cwith "1" "-1" ,i ,i ,var ,val))
 197      (define (rowwith i var val) `(cwith ,i ,i "1" "-1" ,var ,val))
 198      (define (allwith var val) `(cwith "1" "-1" "1" "-1" ,var ,val))))
 199
 200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 201 ;;; Debugging
 202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 203
 204 (define-public (wrap-catch proc)
 205   ;; Wrap a procedure in a closure which displays and passes exceptions.
 206   (lambda args
 207     (lazy-catch #t
 208                 (lambda () (apply proc args))
 209                 (lambda err
 210                   (tm-display-error "Guile error: " (list err))
 211                   (apply throw err)))))
 212
 213 (define-public (wrap-catch-list expr)
 214   ;; Similar to wrap-catch for a scheme expression in list form.
 215   `(lazy-catch #t
 216                (lambda () ,expr)
 217                (lambda err
 218                  (tm-display-error "Guile error: " (list err))
 219                  (apply throw err))))
 220
 221 (define trace-level 0)
 222 (define (trace-indent)
 223   ;; Produce the string to be used to indent trace output.
 224   (let rec ((n trace-level) (s '()))
 225     (if (equal? 0 n) (apply string-append s)
 226         (rec (1- n) (cons "| " s)))))
 227
 228 (define-public (trace-display . args)
 229   ;; As display but also print trace indentation.
 230   (display (trace-indent))
 231   (for-each (lambda (a)
 232               (display (if (string? a) a (object->string a)))
 233               (display " "))
 234             args)
 235   (newline))
 236
 237 (define-public-macro (trace-variables . vars)
 238   ;; Use trace-display to show the name and value of some variables.
 239   (define (trace-one-variable v)
 240     `(trace-display (string-append ,(symbol->string v) ": "
 241                                    (object->string ,v))))
 242   `(begin ,@(map trace-one-variable vars)))
 243
 244
 245 ;;   Trace levels
 246 ;; Display parameters and return value of a function.
 247 ;; Increase the trace indentation to show the call hierarchy.
 248 ;; Do not preserve tail recursion.
 249
 250 (define-public (wrap-trace name lam)
 251   (lambda args
 252     (trace-display
 253      (if (null? args)
 254          (string-append "[" name "]")
 255          (apply string-append
 256                 `("[" ,name
 257                   ,@(map (lambda (x) (string-append " " (object->string x)))
 258                          args) "]"))))
 259     (set! trace-level (1+ trace-level))
 260     (lazy-catch #t
 261                 (lambda ()
 262                   (let ((res (apply lam args)))
 263                     (set! trace-level (1- trace-level))
 264                     (trace-display (object->string res))
 265                     res))
 266                 (lambda err
 267                   (set! trace-level (1- trace-level))
 268                   (apply throw err)))))
 269
 270 (define-public-macro (set-trace-level! . names)
 271   ;; Make each function a trace-level. Functions can be set multiple
 272   ;; times, only the first application is effective.
 273   ;; Parameters are function names
 274   `(begin
 275      ,@(map (lambda (name)
 276               `(if (not (procedure-property ,name 'trace-wrapped))
 277                    (begin
 278                      (set! ,name (wrap-trace ,(symbol->string name) ,name))
 279                      (set-procedure-property! ,name 'trace-wrapped #t))))
 280             names)))
 281
 282 ;;   Trace points
 283 ;; Display parameters of a function when it is called.
 284 ;; Preserve tail recursion.
 285
 286 (define-public (wrap-trace-point lam msg)
 287   (lambda args
 288     (trace-display (string-append "[" msg " " (object->string args) "]"))
 289     (apply lam args)))
 290
 291 (define-public-macro (set-trace-point! name . opt)
 292   ;; Make one trace point.
 293   ;; Care must be taken of net setting the same function multiple times.
 294   (let ((msg (if (null? opt)
 295                  (symbol->string name)
 296                  (car opt))))
 297     `(set! ,name (wrap-trace-point ,name ,msg))))