mirror of
https://github.com/nunuhara/xsystem4.git
synced 2026-10-05 13:28:04 +03:00
Nunuhara Cabbage
1a0a0e0c12
This is implemented by inserting special opcodes into the game's code. When the breakpoint handler is finished, it returns the original opcode so that execute_instruction can continue executing normally. E.g. * start xsystem4 with --debug option to drop into debugger immediately * run (bp "game_main") * ^d or \exit to close debugger REPL * ...drop into a debugger REPL again at the game_main function
135 lines
4.3 KiB
Scheme
135 lines
4.3 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 (print-locals)
|
|
(print-page (local-page)))
|
|
|
|
(define (print-variable name)
|
|
(show #t (pretty (var name)))
|
|
(void))
|
|
|
|
(define (set-breakpoint fun-or-addr . rest)
|
|
(let ((handler (cond ((null? rest) #f)
|
|
((not (null? (cdr rest))) (error "Too many arguments to SET-BREAKPOINT" (+ 1 (length rest))))
|
|
((not (procedure? (car rest))) (error "Breakpoint handler must be a procedure"))
|
|
(else (car rest)))))
|
|
(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)
|