home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
s
/
s48.zip
/
MISC
/
DISASM.SCM
< prev
next >
Wrap
Text File
|
1992-06-17
|
4KB
|
134 lines
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file assem.scm.
;;;; Disassembler
; This version is intended to be loaded into the Scheme48 system
; environment. It defines a command processor command
; :dis <expression>
; that evaluates <expression> to obtain a procedure or lambda-expression,
; which it then disassembles.
; Needs:
; template? template-name template-code
; closure? closure-template
; code-vector-...
; location-name
(define (disassemble tem)
(cond ((template? tem) (really-disassemble tem 0))
((closure? tem)
(really-disassemble (closure-template tem) 0))
((continuation? tem)
(really-disassemble (continuation-template tem) 0))
(else (display "not coercable to a template")))
(newline))
(define (really-disassemble tem level)
(write (template-name tem))
(let loop ((pc 0))
(if (< pc (code-vector-length (template-code tem)))
(loop (write-instruction tem pc level #t)))))
(define (newline-indent n)
(newline)
(do ((i n (- i 1)))
((= i 0))
(display #\space)))
(define (write-pc pc)
(if (< pc 100) (display " "))
(if (< pc 10) (display " "))
(write pc))
(define (write-instruction tem pc level write-sub-templates?)
(let* ((code (template-code tem))
(const tem) ;constants vector
(opcode (code-vector-ref code pc))
(pc+1 (+ pc 1))
(pc+2 (+ pc 2))
(pc+3 (+ pc 3))
(lit (lambda ()
(template-ref const (code-vector-ref code pc+1))))
(delta (lambda ()
(+ (* (code-vector-ref code pc+1)
byte-limit)
(code-vector-ref code pc+2)))))
(newline-indent (* level 3))
(write-pc pc)
(display " (")
(write (enumerand->name opcode op))
(let ((new-pc
(cond ((= opcode op/literal)
(display #\space)
(display #\')
(write (lit))
pc+2)
((or (= opcode op/global)
(= opcode op/set-global!))
(display #\space)
(let ((loc (lit)))
(write `(location ,(or (location-name loc)
(location-id loc)))))
pc+2)
((= opcode op/closure)
(display #\space)
(if write-sub-templates?
(really-disassemble (lit) (+ level 1))
(display "..."))
pc+2)
((or (= opcode op/local)
(= opcode op/set-local!))
(display #\space)
(write (code-vector-ref code pc+1))
(display #\space)
(write (code-vector-ref code pc+2))
(+ pc 3))
((or (= opcode op/check-nargs=)
(= opcode op/check-nargs>=)
(= opcode op/make-env)
(= opcode op/make-heap-env)
(= opcode op/make-rest-list)
(= opcode op/call)
(= opcode op/move-args-and-call)
(= opcode op/apply)
(= opcode op/local0)
(= opcode op/local1)
(= opcode op/local2)
(= opcode op/stack-ref))
(display #\space)
(write (code-vector-ref code pc+1))
pc+2)
((or (= opcode op/jump-if-false)
(= opcode op/jump))
(display #\space)
(write `(=> ,(+ pc (+ (delta) 3))))
(+ pc 3))
((= opcode op/computed-goto)
(display #\space)
(let ((count (code-vector-ref code pc+1)))
(write count)
(do ((pc pc+2 (+ pc 2))
(count count (- count 1)))
((= count 0) pc)
(display #\space)
(write `(=> ,(+ pc (+ (+ (* (code-vector-ref code pc)
byte-limit)
(code-vector-ref code (+ pc 1)))
2)))))))
((= opcode op/make-cont)
(display #\space)
(write `(=> ,(+ pc (+ (delta) 4))))
(display #\space)
(write (code-vector-ref code pc+3))
(+ pc 4))
(else pc+1))))
(display #\) )
new-pc)))
(define-command 'dis "<exp>" "disassemble procedure"
'(value) disassemble)