mirror of
https://github.com/nunuhara/xsystem4.git
synced 2026-09-22 23:18:01 +03:00
Nunuhara Cabbage
76f7e21c95
Stack traces now list addresses in addition to function names. Additionally, debugger stack traces number each frame, and the numbers can be used together with the PRINT-LOCALS function to print the values of local variables for any frame on the stack.
140 lines
4.4 KiB
Scheme
140 lines
4.4 KiB
Scheme
;; Copyright (C) 2019 Nunuhara Cabbage <nunuhara@haniwa.technology>
|
|
;;
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2 of the License, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, see <http://gnu.org/licenses/>.
|
|
|
|
(import (scheme base))
|
|
(import (chibi show))
|
|
(import (chibi show pretty))
|
|
|
|
(define (void) (when #f))
|
|
|
|
(define type/array-types
|
|
(list type/array-int
|
|
type/array-float
|
|
type/array-string
|
|
type/array-struct
|
|
type/array-func-type
|
|
type/array-bool
|
|
type/array-long
|
|
type/array-delegate))
|
|
|
|
(define type/ref-array-types
|
|
(list type/ref-array-int
|
|
type/ref-array-float
|
|
type/ref-array-string
|
|
type/ref-array-struct
|
|
type/ref-array-func-type
|
|
type/ref-array-bool
|
|
type/ref-array-long
|
|
type/ref-array-delegate))
|
|
|
|
(define (vm-value->scheme val type)
|
|
(cond
|
|
((= type type/int) (vm-value-int val))
|
|
((= type type/bool) (not (zero? (vm-value-int val))))
|
|
((= type type/long) (vm-value-long val))
|
|
((= type type/float) (vm-value-float val))
|
|
((= type type/string) (vm-value-string val))
|
|
((= type type/struct) (get-page (vm-value-int val)))
|
|
((memv type type/array-types) (get-page (vm-value-int val)))
|
|
((memv type type/ref-array-types) (get-page (vm-value-int val)))
|
|
(else 'unsupported-data-type)))
|
|
|
|
(define (iota n)
|
|
(let loop ((n (- n 1)) (result '()))
|
|
(if (< n 0)
|
|
result
|
|
(loop (- n 1) (cons n result)))))
|
|
|
|
(define (page->vector page)
|
|
(list->vector (map (lambda (varno)
|
|
(let ((var (page-ref page varno)))
|
|
(vm-value->scheme/recursive (variable-vm-value var)
|
|
(variable-data-type var))))
|
|
(iota (page-nr-vars page)))))
|
|
|
|
(define (page->alist page)
|
|
(map (lambda (varno)
|
|
(let ((var (page-ref page varno)))
|
|
(cons (variable-name var)
|
|
(vm-value->scheme/recursive (variable-vm-value var)
|
|
(variable-data-type var)))))
|
|
(iota (page-nr-vars page))))
|
|
|
|
(define (vm-value->scheme/recursive val type)
|
|
(let ((scm-val (vm-value->scheme val type)))
|
|
(if (page? scm-val)
|
|
(cond
|
|
((= (page-type scm-val) page-type/array) (page->vector scm-val))
|
|
(else (page->alist scm-val)))
|
|
scm-val)))
|
|
|
|
(define (variable-value v)
|
|
(vm-value->scheme/recursive (variable-vm-value v)
|
|
(variable-data-type v)))
|
|
|
|
(define (global name)
|
|
(let ((v (get-global-variable name)))
|
|
(if v
|
|
(variable-value v)
|
|
'no-such-variable)))
|
|
|
|
(define (local name)
|
|
(let ((v (get-local-variable name)))
|
|
(if v
|
|
(variable-value v)
|
|
'no-such-variable)))
|
|
|
|
(define (var name)
|
|
(let ((v (local name)))
|
|
(if (eqv? v 'no-such-variable)
|
|
(global name)
|
|
v)))
|
|
|
|
(define (print-page page)
|
|
(for-each (lambda (v)
|
|
(show #t (variable-name v) "\t = " (variable-value v) nl))
|
|
(map (lambda (i) (page-ref page i)) (iota (page-nr-vars page)))))
|
|
|
|
(define (_dbg-optional args default fname)
|
|
(cond ((null? args) default)
|
|
((not (null? (cdr args))) (error (string-append "Too many arguments to " fname) (+ 1 (length args))))
|
|
(else (car args))))
|
|
|
|
(define (print-locals . rest)
|
|
(let ((i (_dbg-optional rest 0 "PRINT-LOCALS")))
|
|
(print-page (frame-page i))))
|
|
|
|
(define (print-variable name)
|
|
(show #t (pretty (var name)))
|
|
(void))
|
|
|
|
(define (set-breakpoint fun-or-addr . rest)
|
|
(let ((handler (_dbg-optional rest #f "SET-BREAKPOINT")))
|
|
(when (and handler (not (procedure? handler)))
|
|
(error "Breakpoint handler must be a procedure"))
|
|
(if (string? fun-or-addr)
|
|
(set-function-breakpoint fun-or-addr handler)
|
|
(set-address-breakpoint fun-or-addr handler))))
|
|
|
|
;; aliases
|
|
|
|
(define g global)
|
|
(define l local)
|
|
(define v variable)
|
|
(define bt backtrace)
|
|
(define pl print-locals)
|
|
(define p print-variable)
|
|
(define bp set-breakpoint)
|