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 / UTIL.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  115 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 util.scm
  6.  
  7. ;;;; "Bare machine"
  8.  
  9. ; Random things needed to build the datatypes and GC.
  10.  
  11. ; error
  12.  
  13. (define unassigned
  14.   (let ((marker (list '<unassigned>)))
  15.     (lambda () marker)))
  16.  
  17. ; Now defined in macros.scm
  18. ;(define (assert test)
  19. ;  (if (not test) (error "assertion failed")))
  20.  
  21. (define (make-byte-vector-pointer vector offset)
  22.   offset)
  23.  
  24. (define byte-vector-pointer-ref  byte-vector-ref)
  25. (define byte-vector-pointer-set! byte-vector-set!)
  26.  
  27. (define byte-vector-pointer-word-ref  byte-vector-word-ref)
  28. (define byte-vector-pointer-word-set! byte-vector-word-set!)
  29.  
  30. (define (adjoin-bits high low k)
  31.   (+ (ashl high k) low))
  32.  
  33. (define (low-bits n k)
  34.   (bitwise-and n (- (ashl 1 k) 1)))
  35.  
  36. (define high-bits ashr)
  37.  
  38. (define (vm-read-char in char-cont eof-cont)
  39.   (let ((ch (read-char in)))
  40.     (if (eof-object? ch) (eof-cont) (char-cont ch))))
  41.  
  42. (define bits-per-io-byte 8)
  43.  
  44. (define (write-byte byte out)
  45.   (write-char (ascii->char (bitwise-and byte #xFF)) out))
  46.  
  47. (define (read-byte in char-cont eof-cont)
  48.   (let ((ch (read-char in)))
  49.     (if (eof-object? ch) (eof-cont) (char-cont (char->ascii ch)))))
  50.  
  51. (define (write-number num port)
  52.   (write num port)
  53.   (newline port))
  54.  
  55. (define (read-number port)
  56.   (read port))
  57.  
  58. (define (write-page port)
  59.   (write-char #\page port))
  60.  
  61. (define (read-page port)
  62.   (let loop ((ch (read-char port)))
  63.     (cond ((eof-object? ch)
  64.            (error "end of file while looking for page break"))
  65.           ((not (char=? ch #\page))
  66.            (loop (read-char port))))))
  67.  
  68. ;;;; Control primitives
  69.  
  70. (define *goto-tag* '#f)
  71. (define *exit-status* '#f)
  72.  
  73. (define goto-token (list '<goto-token>))
  74.  
  75. (define halt-token (list '<halt-token>))
  76.  
  77. (define (run-machine start-tag)
  78.   (driver-loop start-tag))
  79.  
  80. (define (driver-loop start-tag)
  81.   (set! *goto-tag* start-tag)
  82.   (let loop ((token goto-token))
  83.     (cond ((eq? token goto-token)
  84.            (loop (*goto-tag*)))
  85.           ((not (eq? token halt-token))
  86.            (error "funny label" token))
  87.       (else
  88.        *exit-status*))))
  89.  
  90. (define (halt-machine status)
  91.   (set! *exit-status* status)
  92.   halt-token)
  93.  
  94. (define (goto tag)
  95.   (set! *goto-tag* (label tag))
  96.   goto-token)
  97.  
  98. ; Assigned goto (e.g. for return addresses)
  99.  
  100. (define (label tag)
  101.   tag)     ; Declaration for (set! *finished* ...)
  102.  
  103. (define computed-goto goto)
  104.  
  105. ; Dispatch
  106.  
  107. (define (dispatch table tag)
  108.   ((vector-ref table tag)))
  109.  
  110. (define make-dispatch-table make-vector)
  111.  
  112. (define define-dispatch! vector-set!)
  113.  
  114.  
  115.