home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / etc / disload.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  79 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: disload.scm,v 1.8 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1993, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Load the disassembler into a Scheme containing the compiler
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (load-disassembler #!optional directory addressing-granularity)
  27.   (with-working-directory-pathname
  28.     (cond ((not (default-object? directory))
  29.        directory)
  30.       ((equal? microcode-id/operating-system-name "unix")
  31.        "/usr/local/lib/mit-scheme/SRC/compiler/machine")
  32.       (else
  33.        "/scheme/compiler/machines/i386"))
  34.     (lambda ()
  35.       (let* ((parent (or (name->package '(compiler))
  36.              (find-package '())))
  37.          (parenv (package/environment parent))
  38.          (disassembler
  39.           (package/add-child! parent
  40.                   'disassembler
  41.                   (eval '(make-environment) parenv))))
  42.     (let ((disenv (package/environment disassembler))
  43.           (global system-global-environment)
  44.           (compinfo (package/environment
  45.              (find-package '(runtime compiler-info)))))
  46.       (define (export name)
  47.         (environment-link-name global disenv name))
  48.       (define (import name)
  49.         (environment-link-name disenv compinfo name))
  50.  
  51.       (if (not (environment-bound? parenv 'addressing-granularity))
  52.           (local-assignment
  53.            parenv
  54.            'addressing-granularity
  55.            (if (default-object? addressing-granularity)
  56.            8
  57.            addressing-granularity)))
  58.       (for-each import
  59.             '(compiled-code-block/dbg-info
  60.               dbg-info-vector/blocks-vector
  61.               dbg-info-vector?
  62.               dbg-info/labels
  63.               dbg-label/external?
  64.               dbg-label/name
  65.               dbg-labels/find-offset))
  66.       (if (file-exists? "mips.scm")
  67.           (load "mips" disenv))
  68.       (load "dassm1" disenv)
  69.       (load "dassm2" disenv)
  70.       (load "dassm3" disenv)
  71.       (if (file-exists? "dinstr1.scm")
  72.           (begin
  73.         ;; For the vax
  74.         (load "dinstr1")
  75.         (load "dinstr2")
  76.         (load "dinstr3")))
  77.       (for-each export
  78.             '(compiler:write-lap-file
  79.               compiler:disassemble)))))))