mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
221 lines
6.3 KiB
Scheme
221 lines
6.3 KiB
Scheme
;;; shell.scm --- interactive VM operations
|
||
|
||
;; Copyright (C) 2000 Free Software Foundation, Inc.
|
||
|
||
;; This file is part of Guile VM.
|
||
|
||
;; Guile VM 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, or (at your option)
|
||
;; any later version.
|
||
;;
|
||
;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (vm shell)
|
||
:use-module (vm vm)
|
||
:use-module (vm utils)
|
||
:use-module (vm compile)
|
||
:use-module (ice-9 format))
|
||
|
||
;;;
|
||
;;; VM Shell
|
||
;;;
|
||
|
||
(define *vm-default-prompt* "VM> ")
|
||
|
||
(define *vm-boot-message* "\
|
||
Copyright (C) 2000 Free Software Foundation, Inc.
|
||
Guile VM is free software, covered by the GNU General Public License,
|
||
and you are welcome to change it and/or distribute copies of it under
|
||
certain conditions. There is absolutely no warranty for Guile VM.\n")
|
||
|
||
(define (vm-init vm)
|
||
(vm-set-option! vm 'prompt *vm-default-prompt*)
|
||
(vm-set-option! vm 'verbose #f)
|
||
(vm-set-option! vm 'history-count 1))
|
||
|
||
(define-public (vm-boot vm)
|
||
(format #t "Guile Virtual Machine ~A\n" (vm-version))
|
||
(display *vm-boot-message*)
|
||
(display "\nType \"help\" for information\n")
|
||
(vm-shell vm))
|
||
|
||
(define-public (vm-shell vm)
|
||
(vm-init vm)
|
||
(let ((read-expr (lambda () (read (current-input-port)))))
|
||
(let loop ()
|
||
(display (or (vm-option vm 'prompt) *vm-default-prompt*))
|
||
(let ((cmd (read-expr)))
|
||
(if (not (eof-object? cmd))
|
||
(case cmd
|
||
((eval) (vm-eval vm (read-expr)) (loop))
|
||
((trace) (vm-trace vm (read-expr)) (loop))
|
||
((parse) (vm-parse vm (read-expr)) (loop))
|
||
((compile) (vm-compile vm (read-expr)) (loop))
|
||
((set) (vm-set-option! vm (read-expr) (read-expr)) (loop))
|
||
(else
|
||
(error "Unknown command: ~S" cmd))))))))
|
||
|
||
(define-public (vm-repl vm)
|
||
(vm-init vm)
|
||
(let loop ()
|
||
(display (or (vm-option vm 'prompt) *vm-default-prompt*))
|
||
(let ((form (read (current-input-port))))
|
||
(if (not (eof-object? form))
|
||
(begin
|
||
(vm-eval vm form)
|
||
(loop))))))
|
||
|
||
(define (vm-eval vm form)
|
||
(let ((result (vm-run vm (compile form))))
|
||
(if (not (eq? result *unspecified*))
|
||
(let* ((n (or (vm-option vm 'history-count) 1))
|
||
(var (symbol-append "$" (number->string n))))
|
||
(intern-symbol #f var)
|
||
(symbol-set! #f var result)
|
||
(format #t "~A = ~S\n" var result)
|
||
(vm-set-option! vm 'history-count (1+ n))
|
||
result))))
|
||
|
||
(define (vm-parse vm form)
|
||
(parse form (make-top-level-env)))
|
||
|
||
(define (vm-compile vm form)
|
||
#f)
|
||
|
||
|
||
;;;
|
||
;;; Step
|
||
;;;
|
||
|
||
(define (vm-step-boot vm)
|
||
(format #t "VM: Starting a program ~S:~%"
|
||
(frame-program (vm-current-frame vm))))
|
||
|
||
(define (vm-step-halt vm)
|
||
(display "VM: Program terminated with the return value: ")
|
||
(display (vm:ac vm))
|
||
(newline))
|
||
|
||
(define (vm-step-next vm)
|
||
(if (vm-option vm 'verbose)
|
||
(let ((frame (vm-current-frame vm)))
|
||
(display "--------------------------------------------------\n")
|
||
(format #t "PC = 0x~X SP = 0x~X FP = 0x~X AC = ~S~%"
|
||
(vm:pc vm) (vm:sp vm) (vm:fp vm) (vm:ac vm))
|
||
(do ((frame frame (frame-dynamic-link frame))
|
||
(frames '() (cons frame frames)))
|
||
((not frame)
|
||
(for-each (lambda (frame)
|
||
(format #t "Frame = [~S 0x~X 0x~X]~%"
|
||
(frame-program frame)
|
||
(frame-stack-pointer frame)
|
||
(frame-return-address frame)))
|
||
frames)))
|
||
(format #t "Local variables = ~S~%" (frame-variables frame))
|
||
(format #t "External variables = ~S~%" (program-external (frame-program frame)))
|
||
(format #t "Stack = ~S~%" (vm-stack->list vm))))
|
||
(format #t "0x~X:" (vm:pc vm))
|
||
(for-each (lambda (obj) (display " ") (write obj))
|
||
(vm-fetch-code vm (vm:pc vm)))
|
||
(newline))
|
||
|
||
(define-public (vm-step vm form . opts)
|
||
(let ((debug-flag (vm-option vm 'debug)))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(add-hook! (vm-boot-hook vm) vm-step-boot)
|
||
(add-hook! (vm-halt-hook vm) vm-step-halt)
|
||
(add-hook! (vm-next-hook vm) vm-step-next)
|
||
(vm-set-option! vm 'debug #t))
|
||
(lambda ()
|
||
(if (pair? opts)
|
||
(vm-set-option! vm 'verbose #t))
|
||
(vm-run vm (compile form)))
|
||
(lambda ()
|
||
(remove-hook! (vm-boot-hook vm) vm-step-boot)
|
||
(remove-hook! (vm-halt-hook vm) vm-step-halt)
|
||
(remove-hook! (vm-next-hook vm) vm-step-next)
|
||
(vm-set-option! vm 'debug debug-flag)))))
|
||
|
||
|
||
;;;
|
||
;;; Trace
|
||
;;;
|
||
|
||
(define (vm-trace-prefix frame)
|
||
(and-let* ((link (frame-dynamic-link frame)))
|
||
(display "| ")
|
||
(vm-trace-prefix link)))
|
||
|
||
(define (vm-frame->call frame)
|
||
(define (truncate! list n)
|
||
(let loop ((list list) (n n))
|
||
(if (<= n 1)
|
||
(set-cdr! list '())
|
||
(loop (cdr list) (1- n))))
|
||
list)
|
||
(let* ((prog (frame-program frame))
|
||
(name (or (program-name prog) prog)))
|
||
(cons name (reverse! (vector->list (frame-variables frame))))))
|
||
|
||
(define (vm-trace-apply vm)
|
||
(let ((frame (vm-current-frame vm)))
|
||
(vm-trace-prefix frame)
|
||
(display (vm-frame->call frame))
|
||
(newline)))
|
||
|
||
(define (vm-trace-return vm)
|
||
(vm-trace-prefix (vm-current-frame vm))
|
||
(display (vm:ac vm))
|
||
(newline))
|
||
|
||
(define-public (vm-trace vm form)
|
||
(let ((debug-flag (vm-option vm 'debug)))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(add-hook! (vm-apply-hook vm) vm-trace-apply)
|
||
(add-hook! (vm-return-hook vm) vm-trace-return)
|
||
(vm-set-option! vm 'debug #t))
|
||
(lambda ()
|
||
(vm-run vm (compile form)))
|
||
(lambda ()
|
||
(remove-hook! (vm-apply-hook vm) vm-trace-apply)
|
||
(remove-hook! (vm-return-hook vm) vm-trace-return)
|
||
(vm-set-option! vm 'debug debug-flag)))))
|
||
|
||
|
||
;;;
|
||
;;; Disassemble
|
||
;;;
|
||
|
||
(define-public (disassemble program)
|
||
(format #t "Program at ~X:" (program-base program))
|
||
(let ((subprogs '())
|
||
(list (vector->list (bytecode-decode (program-code program)))))
|
||
(for-each (lambda (obj)
|
||
(cond ((opcode? obj)
|
||
(newline)
|
||
(display obj))
|
||
((program? obj)
|
||
(set! subprogs (cons subprogs obj))
|
||
(display " ")
|
||
(display obj))
|
||
(else
|
||
(display " ")
|
||
(display obj))))
|
||
list)
|
||
(newline)
|
||
(for-each disassemble (reverse! subprogs))))
|
||
|
||
;;; shell.scm ends here
|