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 >
Text File  |  1992-06-17  |  4KB  |  134 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file assem.scm.
  6.  
  7. ;;;; Disassembler
  8.  
  9. ; This version is intended to be loaded into the Scheme48 system
  10. ; environment.  It defines a command processor command
  11. ;      :dis <expression>
  12. ; that evaluates <expression> to obtain a procedure or lambda-expression,
  13. ; which it then disassembles.
  14.  
  15. ; Needs:
  16. ;   template? template-name template-code
  17. ;   closure? closure-template
  18. ;   code-vector-...
  19. ;   location-name
  20.  
  21. (define (disassemble tem)
  22.   (cond ((template? tem) (really-disassemble tem 0))
  23.     ((closure? tem)
  24.      (really-disassemble (closure-template tem) 0))
  25.     ((continuation? tem)
  26.      (really-disassemble (continuation-template tem) 0))
  27.     (else (display "not coercable to a template")))
  28.   (newline))
  29.  
  30. (define (really-disassemble tem level)
  31.   (write (template-name tem))
  32.   (let loop ((pc 0))
  33.     (if (< pc (code-vector-length (template-code tem)))
  34.         (loop (write-instruction tem pc level #t)))))
  35.  
  36. (define (newline-indent n)
  37.   (newline)
  38.   (do ((i n (- i 1)))
  39.       ((= i 0))
  40.     (display #\space)))
  41.  
  42. (define (write-pc pc)
  43.   (if (< pc 100) (display " "))
  44.   (if (< pc 10) (display " "))
  45.   (write pc))
  46.  
  47. (define (write-instruction tem pc level write-sub-templates?)
  48.   (let* ((code (template-code tem))
  49.          (const tem)  ;constants vector
  50.          (opcode (code-vector-ref code pc))
  51.          (pc+1 (+ pc 1))
  52.          (pc+2 (+ pc 2))
  53.      (pc+3 (+ pc 3))
  54.          (lit (lambda ()
  55.                 (template-ref const (code-vector-ref code pc+1))))
  56.          (delta (lambda ()
  57.           (+ (* (code-vector-ref code pc+1)
  58.             byte-limit)
  59.              (code-vector-ref code pc+2)))))
  60.     (newline-indent (* level 3))
  61.     (write-pc pc)
  62.     (display " (")
  63.     (write (enumerand->name opcode op))
  64.     (let ((new-pc
  65.            (cond ((= opcode op/literal)
  66.                   (display #\space)
  67.                   (display #\')
  68.                   (write (lit))
  69.                   pc+2)
  70.                  ((or (= opcode op/global)
  71.                       (= opcode op/set-global!))
  72.                   (display #\space)
  73.           (let ((loc (lit)))
  74.             (write `(location ,(or (location-name loc)
  75.                        (location-id loc)))))
  76.                   pc+2)
  77.                  ((= opcode op/closure)
  78.                   (display #\space)
  79.                   (if write-sub-templates?
  80.                       (really-disassemble (lit) (+ level 1))
  81.                       (display "..."))
  82.                   pc+2)
  83.                  ((or (= opcode op/local)
  84.                       (= opcode op/set-local!))
  85.                   (display #\space)
  86.                   (write (code-vector-ref code pc+1))
  87.                   (display #\space)
  88.                   (write (code-vector-ref code pc+2))
  89.                   (+ pc 3))
  90.                  ((or (= opcode op/check-nargs=)
  91.                       (= opcode op/check-nargs>=)
  92.                       (= opcode op/make-env)
  93.                       (= opcode op/make-heap-env)
  94.                       (= opcode op/make-rest-list)
  95.                       (= opcode op/call)
  96.                       (= opcode op/move-args-and-call)
  97.                       (= opcode op/apply)
  98.               (= opcode op/local0)
  99.               (= opcode op/local1)
  100.               (= opcode op/local2)
  101.               (= opcode op/stack-ref))
  102.           (display #\space)
  103.                   (write (code-vector-ref code pc+1))
  104.                   pc+2)
  105.                  ((or (= opcode op/jump-if-false)
  106.                       (= opcode op/jump))
  107.                   (display #\space)
  108.                   (write `(=> ,(+ pc (+ (delta) 3))))
  109.                   (+ pc 3))
  110.          ((= opcode op/computed-goto)
  111.           (display #\space)
  112.           (let ((count (code-vector-ref code pc+1))) 
  113.             (write count)
  114.             (do ((pc pc+2 (+ pc 2))
  115.              (count count (- count 1)))
  116.             ((= count 0) pc)
  117.               (display #\space)
  118.               (write `(=> ,(+ pc (+ (+ (* (code-vector-ref code pc)
  119.                           byte-limit)
  120.                            (code-vector-ref code (+ pc 1)))
  121.                         2)))))))
  122.                  ((= opcode op/make-cont)
  123.                   (display #\space)
  124.                   (write `(=> ,(+ pc (+ (delta) 4))))
  125.                   (display #\space) 
  126.                   (write (code-vector-ref code pc+3))
  127.                   (+ pc 4))
  128.                  (else pc+1))))
  129.       (display #\) )
  130.       new-pc)))
  131.  
  132. (define-command 'dis "<exp>" "disassemble procedure"
  133.   '(value) disassemble)
  134.