176 lines
4.6 KiB
Scheme
176 lines
4.6 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Alternate implementation of PRIMITIVES module.
|
|
|
|
(define underlying-error error)
|
|
|
|
(define (unspecific) (if #f #f))
|
|
|
|
|
|
; Records
|
|
|
|
(define-record-type new-record :new-record
|
|
(make-new-record fields)
|
|
record?
|
|
(fields new-record-fields))
|
|
|
|
(define (make-record size init)
|
|
(make-new-record (make-vector size init)))
|
|
|
|
(define (record-ref r i)
|
|
(vector-ref (new-record-fields r) i))
|
|
|
|
(define (record-set! r i value)
|
|
(vector-set! (new-record-fields r) i value))
|
|
|
|
(define (record-length r)
|
|
(vector-length (new-record-fields r)))
|
|
|
|
|
|
; Extended numbers
|
|
|
|
(define-record-type new-extended-number :new-extended-number
|
|
(make-new-extended-number fields)
|
|
extended-number?
|
|
(fields new-extended-number-fields))
|
|
|
|
(define-record-discloser :new-extended-number
|
|
(lambda (n) `(extended-number ,(new-extended-number-fields n))))
|
|
|
|
(define (make-extended-number size init)
|
|
(make-new-extended-number (make-vector size init)))
|
|
|
|
(define (extended-number-ref n i)
|
|
(vector-ref (new-extended-number-fields n) i))
|
|
|
|
(define (extended-number-set! n i value)
|
|
(vector-set! (new-extended-number-fields n) i value))
|
|
|
|
(define (extended-number-length n)
|
|
(vector-length (new-extended-number-fields n)))
|
|
|
|
|
|
; Dynamic state (= current thread)
|
|
|
|
(define *dynamic-state* 'uninitialized-dynamic-state)
|
|
(define (get-dynamic-state) *dynamic-state*)
|
|
(define (set-dynamic-state! state)
|
|
(if (not (and (record? state)
|
|
(list? (record-ref state 1))))
|
|
(underlying-error "invalid dynamic state" state))
|
|
(set! *dynamic-state* state))
|
|
|
|
; Etc.
|
|
|
|
(define (close-port port)
|
|
((if (input-port? port) close-input-port close-output-port)
|
|
port))
|
|
|
|
(define (write-string s port)
|
|
(display s port))
|
|
|
|
(define (schedule-interrupt interval)
|
|
(if (not (= interval 0))
|
|
(warn "ignoring schedule-interrupt" interval)))
|
|
|
|
(define *pseudo-enabled-interrupts* 0)
|
|
|
|
(define (set-enabled-interrupts! ei)
|
|
(let ((previous *pseudo-enabled-interrupts*))
|
|
(set! *pseudo-enabled-interrupts* ei)
|
|
;; (if (bitwise-and *pseudo-pending-interrupts* ei) ...)
|
|
previous))
|
|
|
|
(define *pseudo-pending-interrupts* 0)
|
|
|
|
(define *pseudo-exception-handler* #f)
|
|
(define (set-exception-handler! h)
|
|
(set! *pseudo-exception-handler* h))
|
|
|
|
(define *pseudo-interrupt-handlers* #f)
|
|
(define (set-interrupt-handlers! v)
|
|
(set! *pseudo-interrupt-handlers* v))
|
|
|
|
(define (unimplemented name)
|
|
(lambda args (underlying-error "unimplemented primitive" name args)))
|
|
(define collect (unimplemented 'collect))
|
|
(define external-call (unimplemented 'external-call))
|
|
(define external-lookup (unimplemented 'external-lookup))
|
|
(define external-name (unimplemented 'external-name))
|
|
(define external-value (unimplemented 'external-value))
|
|
(define (external? x) #f)
|
|
(define find-all-xs (unimplemented 'find-all-xs))
|
|
(define make-external (unimplemented 'make-external))
|
|
(define vm-extension (unimplemented 'vm-extension))
|
|
|
|
(define (memory-status which arg)
|
|
(case which
|
|
((2) 100)
|
|
((3) (display "(Ignoring set-minimum-recovered-space!)") (newline))
|
|
(else (underlying-error "unimplemented memory-status" which arg))))
|
|
|
|
(define (time which arg)
|
|
(case which
|
|
((0) 1000)
|
|
(else (underlying-error "unimplemented time" which arg))))
|
|
|
|
|
|
; end of definitions implementing PRIMITIVES structure
|
|
|
|
|
|
; --------------------
|
|
|
|
; Auxiliary crud.
|
|
|
|
(define (maybe-handle-interrupt which)
|
|
;; Should actually do (get-highest-priority-interrupt!) ...
|
|
(let ((bit (arithmetic-shift 1 which)))
|
|
(cond ((= (bitwise-and *pseudo-enabled-interrupts* bit) 0)
|
|
(set! *pseudo-pending-interrupts*
|
|
(bitwise-ior *pseudo-pending-interrupts* bit))
|
|
(display "(Interrupt deferred)")
|
|
(newline)
|
|
#f)
|
|
(else
|
|
(set! *pseudo-pending-interrupts*
|
|
(bitwise-and *pseudo-pending-interrupts*
|
|
(bitwise-not bit)))
|
|
(display "(Handling interrupt)")
|
|
(newline)
|
|
((vector-ref *pseudo-interrupt-handlers* which)
|
|
(set-enabled-interrupts! 0))
|
|
#t))))
|
|
|
|
(define (raise-exception opcode arguments)
|
|
(apply (get-exception-handler)
|
|
opcode
|
|
arguments))
|
|
|
|
(define (get-exception-handler)
|
|
*pseudo-exception-handler*)
|
|
|
|
|
|
(define (clear-registers!)
|
|
(set! *dynamic-state* 'uninitialized-dynamic-state)
|
|
(set! *pseudo-enabled-interrupts* 0)
|
|
(set! *pseudo-interrupt-handlers* #f)
|
|
(set! *pseudo-exception-handler* #f))
|
|
|
|
(define *vm-return* #f)
|
|
|
|
(define (vm-return . rest)
|
|
(if *vm-return*
|
|
(apply *vm-return* rest)
|
|
(underlying-error "vm-return" rest)))
|
|
|
|
|
|
(define (?start entry-point arg) ;E.g. (?start (usual-resumer bare) 0)
|
|
(clear-registers!)
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(set! *vm-return* k)
|
|
(entry-point arg
|
|
(current-input-port)
|
|
(current-output-port)))))
|