home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / VM / DEBUG.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  127 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 debug.scm
  6.  
  7. ;;;; Debugging
  8.  
  9. (import vm-environment
  10.     initialize-heap
  11.     initialize-machine
  12.     initialize-i/o-system
  13.     clear-registers
  14.     reset-stack-pointer
  15.     (get-symbol-table get-saved-symbol-table)
  16.     (get-system-environment get-saved-environment-table)
  17.     (vm-make-closure make-closure)
  18.     start-vm
  19.     (vm-set-contents! set-contents!)
  20.     (collect interpreter-collect)
  21.     available
  22.     )
  23.  
  24. (define (init . size-option)
  25.   (let ((size (if (null? size-option) 200000 (car size-option))))
  26.     (initialize-heap size)
  27.     (initialize-machine)
  28.     (initialize-i/o-system)
  29.     (clear-registers)                ;purge garbage from registers
  30.     'done))
  31.  
  32. (define (reset-interpreter)
  33.   (clear-registers)
  34.   (reset-stack-pointer))
  35.  
  36. (define (cold-load)
  37.   (for-each (lambda (def)
  38.               (run-form def #f))
  39.             (definitions-for-all-compiler-primitives))
  40.   (let ((load (lambda (f)
  41.                 (let ((f (string-downcase (symbol->string f))))
  42.                   (boot-load (string-append s48/rts
  43.                                             "/"
  44.                                             f
  45.                                             ".scm"))))))
  46.     (for-each load '(enum arch basic rtsistruct sys io read))
  47.     (collect)
  48.     (for-each load '(comp cprim derive ssig))
  49.     (run-form '(initialize-user-environment) #f)
  50.     'done))
  51.  
  52. (define (string-downcase string)
  53.   (list->string (map char-downcase (string->list string))))
  54.  
  55. ; Misc. bootstrap and debugging stuff
  56.  
  57. (define (boot-load filename)
  58.   (if (< (available) 5000)    ; heuristic check
  59.       (collect))
  60.   (call-with-input-file
  61.     filename
  62.     (lambda (port)
  63.       (newline)
  64.       (display "Loading ")
  65.       (write filename)
  66.       (force-output (current-output-port))
  67.       (let loop ()
  68.         (let ((form (read port)))
  69.           (cond ((eof-object? form) 'done)
  70.                 (else
  71.                  (run-form form filename)
  72.                  (write-char #\.)
  73.                  (force-output (current-output-port))
  74.                  (loop))))))))
  75.  
  76. (define (run exp)
  77.   (reset-interpreter)
  78.   (extract (run-form exp #f)))
  79.  
  80. (define (run-form form file-id)
  81.   (let loop ((forms (process-forms (list form) system-environment)) (value #f))
  82.     (cond ((null? forms)
  83.        value)
  84.       ((caar forms)
  85.        (let ((form (cdar forms)))
  86.          (boot-define (cadr form)
  87.               (run-expression (caddr form)
  88.                       (cadr form)))
  89.          (loop (cdr forms) unspecified)))
  90.       (else
  91.        (loop (cdr forms) (run-expression (cdar forms) file-id))))))
  92.  
  93. (define (warn message . rest)
  94.   (display message)
  95.   (for-each display rest))
  96.  
  97. (define system-environment
  98.   (let ((package (make-package 'debug (list specials-package))))
  99.     (initialize-usual-macros! package)
  100.     (integrate-all-primitives! package)
  101.     package))
  102.  
  103. (define (run-expression exp where)
  104.   (if (and (pair? exp) (eq? (car exp) 'lambda))
  105.       (vm-make-closure
  106.        (enter (compile-lambda exp system-environment where))
  107.        (enter where)
  108.        universal-key)
  109.       (start-vm
  110.        (vm-make-closure
  111.     (enter (compile-lambda `(lambda () (halt ,exp))
  112.                    system-environment
  113.                    where))
  114.     (enter where)
  115.     universal-key))))
  116.  
  117. (define (boot-define name val)  ;RUN relies on this returning a descriptor
  118.   (let ((name (enter name)))
  119.     (vm-set-contents! (lookup (get-system-environment)
  120.                   name
  121.                   universal-key)
  122.               val)
  123.     name))
  124.  
  125.  
  126.  
  127.