529 lines
16 KiB
Scheme
529 lines
16 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
; Scalar primitives
|
|
|
|
(define-primitive eq? (any-> any->) vm-eq? return-boolean)
|
|
|
|
(define-primitive char? (any->) vm-char? return-boolean)
|
|
(define-primitive char=? (vm-char-> vm-char->) vm-char=? return-boolean)
|
|
(define-primitive char<? (vm-char-> vm-char->) vm-char<? return-boolean)
|
|
(define-primitive char->ascii (char->) char->ascii return-fixnum)
|
|
|
|
(define-primitive ascii->char
|
|
(fixnum->)
|
|
(lambda (x)
|
|
(if (or (> x 255) (< x 0))
|
|
(raise-exception wrong-type-argument 0 (enter-fixnum x))
|
|
(goto return (enter-char (ascii->char x))))))
|
|
|
|
(define-primitive eof-object?
|
|
(any->)
|
|
(lambda (x) (vm-eq? x eof-object))
|
|
return-boolean)
|
|
|
|
;----------------
|
|
|
|
(define-primitive stored-object-has-type?
|
|
(any->)
|
|
(lambda (x)
|
|
(goto continue-with-value
|
|
(enter-boolean (stob-of-type? x (code-byte 0)))
|
|
1)))
|
|
|
|
(define-primitive stored-object-length
|
|
(any->)
|
|
(lambda (stob)
|
|
(let ((type (code-byte 0)))
|
|
(if (stob-of-type? stob type)
|
|
(goto continue-with-value
|
|
(enter-fixnum (d-vector-length stob))
|
|
1)
|
|
(raise-exception wrong-type-argument 1 stob (enter-fixnum type))))))
|
|
|
|
; Fixed sized objects
|
|
|
|
(define-primitive stored-object-ref
|
|
(any->)
|
|
(lambda (stob)
|
|
(let ((type (code-byte 0))
|
|
(offset (code-byte 1)))
|
|
(if (stob-of-type? stob type)
|
|
(goto continue-with-value
|
|
(d-vector-ref stob offset)
|
|
2)
|
|
(raise-exception wrong-type-argument 2
|
|
stob
|
|
(enter-fixnum type)
|
|
(enter-fixnum offset))))))
|
|
|
|
(define-primitive stored-object-set!
|
|
(any-> any->)
|
|
(lambda (stob value)
|
|
(let ((type (code-byte 0))
|
|
(offset (code-byte 1)))
|
|
(cond ((and (stob-of-type? stob type)
|
|
(not (immutable? stob)))
|
|
(d-vector-set! stob offset value)
|
|
(goto continue-with-value
|
|
unspecific-value
|
|
2))
|
|
(else
|
|
(raise-exception wrong-type-argument 2
|
|
stob
|
|
(enter-fixnum type)
|
|
(enter-fixnum offset)
|
|
value))))))
|
|
|
|
; Indexed objects
|
|
|
|
(define-primitive stored-object-indexed-ref (any-> any->)
|
|
(lambda (stob index)
|
|
(let ((type (code-byte 0)))
|
|
(cond ((or (not (fixnum? index))
|
|
(not (stob-of-type? stob type)))
|
|
(raise-exception wrong-type-argument 1
|
|
stob (enter-fixnum type) index))
|
|
((valid-index? (extract-fixnum index) (d-vector-length stob))
|
|
(goto continue-with-value
|
|
(d-vector-ref stob (extract-fixnum index))
|
|
1))
|
|
(else
|
|
(raise-exception index-out-of-range 1
|
|
stob (enter-fixnum type) index))))))
|
|
|
|
(define-primitive stored-object-indexed-set! (any-> any-> any->)
|
|
(lambda (stob index value)
|
|
(let ((type (code-byte 0)))
|
|
(cond ((or (not (fixnum? index))
|
|
(not (stob-of-type? stob type))
|
|
(immutable? stob))
|
|
(raise-exception wrong-type-argument 1
|
|
stob (enter-fixnum type) index value))
|
|
((valid-index? (extract-fixnum index) (d-vector-length stob))
|
|
(d-vector-set! stob (extract-fixnum index) value)
|
|
(goto continue-with-value unspecific-value 1))
|
|
(else
|
|
(raise-exception index-out-of-range 1
|
|
stob (enter-fixnum type) index value))))))
|
|
|
|
; Hacko record handlers done for speed.
|
|
|
|
(define-primitive checked-record-ref
|
|
(any-> any-> fixnum->)
|
|
(lambda (record type index)
|
|
(cond ((not (and (stob-of-type? record (enum stob record))
|
|
(vm-eq? type (record-ref record 0))))
|
|
(raise-exception wrong-type-argument 0
|
|
record type (enter-fixnum index)))
|
|
((valid-index? index (record-length record))
|
|
(goto return (record-ref record index)))
|
|
(else
|
|
(raise-exception index-out-of-range 0
|
|
record type (enter-fixnum index))))))
|
|
|
|
(define-primitive checked-record-set! (any-> any-> fixnum-> any->)
|
|
(lambda (record type index value)
|
|
(cond ((not (and (stob-of-type? record (enum stob record))
|
|
(vm-eq? type (record-ref record 0))
|
|
(not (immutable? record))))
|
|
(raise-exception wrong-type-argument 0
|
|
record type (enter-fixnum index) value))
|
|
((valid-index? index (record-length record))
|
|
(record-set! record index value)
|
|
(goto no-result))
|
|
(else
|
|
(raise-exception index-out-of-range 0
|
|
record type (enter-fixnum index) value)))))
|
|
|
|
; Constructors
|
|
|
|
(define-primitive make-stored-object ()
|
|
(lambda ()
|
|
(let* ((len (code-byte 0))
|
|
(key (ensure-space (cells->bytes (+ stob-overhead len))))
|
|
(new (make-d-vector (code-byte 1) len key)))
|
|
(cond ((>= len 1)
|
|
(d-vector-init! new (- len 1) *val*)
|
|
(do ((i (- len 2) (- i 1)))
|
|
((> 0 i)
|
|
(unspecific)) ; for the type checker!
|
|
(d-vector-init! new i (pop)))))
|
|
(goto continue-with-value new 2))))
|
|
|
|
; This is for the closed compiled versions of VECTOR and RECORD.
|
|
; *stack* = arg0 arg1 ... argN rest-list N+1 total-nargs
|
|
|
|
(define-primitive closed-make-stored-object ()
|
|
(lambda ()
|
|
(let* ((len (extract-fixnum (pop)))
|
|
(key (ensure-space (cells->bytes (+ stob-overhead len))))
|
|
(new (make-d-vector (code-byte 0) len key))
|
|
(stack-nargs (extract-fixnum (pop)))
|
|
(rest-list (pop)))
|
|
(do ((i (- stack-nargs 1) (- i 1)))
|
|
((> 0 i)
|
|
(unspecific)) ; for the type checker!
|
|
(d-vector-init! new i (pop)))
|
|
(do ((i stack-nargs (+ i 1))
|
|
(rest-list rest-list (vm-cdr rest-list)))
|
|
((vm-eq? rest-list null)
|
|
(unspecific)) ; for the type checker!
|
|
(d-vector-init! new i (vm-car rest-list)))
|
|
(goto continue-with-value new 1))))
|
|
|
|
(define-primitive make-vector-object (any-> any->)
|
|
(lambda (len init)
|
|
(let ((type (code-byte 0)))
|
|
(if (fixnum? len)
|
|
(let* ((len (extract-fixnum len))
|
|
(size (vm-vector-size len)))
|
|
(if (or (< len 0)
|
|
(> size max-stob-size-in-cells))
|
|
(raise-exception wrong-type-argument 1
|
|
(enter-fixnum type) (enter-fixnum len) init)
|
|
(receive (okay? key init)
|
|
(maybe-ensure-space-saving-temp size init)
|
|
(if (not okay?)
|
|
(raise-exception heap-overflow 1
|
|
(enter-fixnum type) (enter-fixnum len)
|
|
init)
|
|
(let ((v (make-d-vector type len key)))
|
|
(do ((i (- len 1) (- i 1)))
|
|
((< i 0))
|
|
(d-vector-set! v i init))
|
|
(goto continue-with-value v 1))))))
|
|
(raise-exception wrong-type-argument 1
|
|
(enter-fixnum type) len init)))))
|
|
|
|
; Strings and byte vectors
|
|
|
|
(define-primitive string-length
|
|
(string->)
|
|
(lambda (string)
|
|
(goto return-fixnum (vm-string-length string))))
|
|
|
|
(define-primitive byte-vector-length
|
|
(code-vector->)
|
|
(lambda (byte-vector)
|
|
(goto return-fixnum (code-vector-length byte-vector))))
|
|
|
|
(define (make-byte-ref ref length returner)
|
|
(lambda (vector index)
|
|
(if (valid-index? index (length vector))
|
|
(goto returner (ref vector index))
|
|
(raise-exception index-out-of-range 0 vector (enter-fixnum index)))))
|
|
|
|
(let ((proc (make-byte-ref vm-string-ref vm-string-length return-char)))
|
|
(define-primitive string-ref (string-> fixnum->) proc))
|
|
|
|
(let ((proc (make-byte-ref code-vector-ref code-vector-length return-fixnum)))
|
|
(define-primitive byte-vector-ref (code-vector-> fixnum->) proc))
|
|
|
|
(define (make-byte-setter setter length enter-elt)
|
|
(lambda (vector index char)
|
|
(cond ((immutable? vector)
|
|
(raise-exception wrong-type-argument 0
|
|
vector (enter-fixnum index) (enter-elt char)))
|
|
((valid-index? index (length vector))
|
|
(setter vector index char)
|
|
(goto no-result))
|
|
(else
|
|
(raise-exception index-out-of-range 0
|
|
vector (enter-fixnum index) (enter-elt char))))))
|
|
|
|
(let ((proc (make-byte-setter vm-string-set! vm-string-length enter-char)))
|
|
(define-primitive string-set! (string-> fixnum-> char->) proc))
|
|
|
|
(let ((proc (make-byte-setter code-vector-set! code-vector-length enter-fixnum)))
|
|
(define-primitive byte-vector-set! (code-vector-> fixnum-> fixnum->) proc))
|
|
|
|
(define (byte-vector-maker size maker setter enter-elt)
|
|
(lambda (len init)
|
|
(let ((size (size len)))
|
|
(if (or (< len 0)
|
|
(> size max-stob-size-in-cells))
|
|
(raise-exception wrong-type-argument 0
|
|
(enter-fixnum len) (enter-elt init))
|
|
(receive (okay? key)
|
|
(maybe-ensure-space size)
|
|
(if (not okay?)
|
|
(raise-exception heap-overflow 0
|
|
(enter-fixnum len) (enter-elt init))
|
|
(let ((vector (maker len key)))
|
|
(do ((i (- len 1) (- i 1)))
|
|
((< i 0))
|
|
(setter vector i init))
|
|
(goto return vector))))))))
|
|
|
|
(let ((proc (byte-vector-maker vm-string-size
|
|
vm-make-string
|
|
vm-string-set!
|
|
enter-char)))
|
|
(define-primitive make-string (fixnum-> char->) proc))
|
|
|
|
(let ((proc (byte-vector-maker code-vector-size
|
|
make-code-vector
|
|
code-vector-set!
|
|
enter-fixnum)))
|
|
(define-primitive make-byte-vector (fixnum-> fixnum->) proc))
|
|
|
|
; Locations & mutability
|
|
|
|
(define-primitive location-defined? (location->)
|
|
(lambda (loc)
|
|
(return-boolean (or (not (undefined? (contents loc)))
|
|
(= (contents loc) unassigned-marker)))))
|
|
|
|
(define-primitive set-location-defined?! (location-> boolean->)
|
|
(lambda (loc value)
|
|
(cond ((not value)
|
|
(set-contents! loc unbound-marker))
|
|
((undefined? (contents loc))
|
|
(set-contents! loc unassigned-marker))))
|
|
return-unspecific)
|
|
|
|
(define-primitive immutable? (any->) immutable? return-boolean)
|
|
|
|
(define-primitive make-immutable! (any->)
|
|
(lambda (thing)
|
|
(make-immutable! thing)
|
|
(goto return thing)))
|
|
|
|
;----------------
|
|
; Misc
|
|
|
|
(define-primitive false ()
|
|
(lambda ()
|
|
(goto return false)))
|
|
|
|
(define-primitive eof-object ()
|
|
(lambda ()
|
|
(goto return eof-object)))
|
|
|
|
(define-primitive trap (any->)
|
|
(lambda (arg)
|
|
(raise-exception trap 0 arg)))
|
|
|
|
(define-primitive find-all (fixnum->)
|
|
(lambda (type)
|
|
(let loop ((first? #t))
|
|
(let ((vector (s48-find-all type)))
|
|
(cond ((not (false? vector))
|
|
(goto return vector))
|
|
(first?
|
|
(collect)
|
|
(loop #f))
|
|
(else
|
|
(raise-exception heap-overflow 0 (enter-fixnum type))))))))
|
|
|
|
(define-primitive find-all-records (any->)
|
|
(lambda (type)
|
|
(let loop ((first? #t) (type type))
|
|
(let ((vector (s48-find-all-records type))) ; only one call site
|
|
(cond ((not (false? vector))
|
|
(goto return vector))
|
|
(first?
|
|
(loop #f (collect-saving-temp type)))
|
|
(else
|
|
(raise-exception heap-overflow 0 type)))))))
|
|
|
|
(define-primitive collect ()
|
|
(lambda ()
|
|
(set! *val* unspecific-value)
|
|
(collect)
|
|
(goto continue 0)))
|
|
|
|
(define-consing-primitive add-finalizer! (any-> any->)
|
|
(lambda (n) (* 2 vm-pair-size))
|
|
(lambda (stob proc key)
|
|
(cond ((not (and (stob? stob)
|
|
(closure? proc)))
|
|
(raise-exception wrong-type-argument 0 stob proc))
|
|
; This would be useful but could get quite expensive
|
|
; ((vm-assq stob *finalizer-alist*)
|
|
; (raise-exception has-finalizer 0 stob proc))
|
|
(else
|
|
(set! *finalizer-alist*
|
|
(vm-cons (vm-cons stob proc key)
|
|
*finalizer-alist*
|
|
key))
|
|
(goto no-result)))))
|
|
|
|
(define-primitive memory-status (fixnum-> any->)
|
|
(lambda (key other)
|
|
(enum-case memory-status-option key
|
|
((pointer-hash)
|
|
(goto return (descriptor->fixnum other)))
|
|
((available)
|
|
(goto return-fixnum (s48-available)))
|
|
((heap-size)
|
|
(goto return-fixnum (bytes->cells (s48-heap-size))))
|
|
((stack-size)
|
|
(goto return-fixnum (stack-size)))
|
|
((gc-count)
|
|
(goto return-fixnum (s48-gc-count)))
|
|
((expand-heap!)
|
|
(raise-exception unimplemented-instruction 0 (enter-fixnum key) other))
|
|
(else
|
|
(raise-exception bad-option 0 (enter-fixnum key) other)))))
|
|
|
|
(define-primitive time (fixnum-> any->)
|
|
(lambda (option other)
|
|
(enum-case time-option option
|
|
((cheap-time)
|
|
(goto return-fixnum (cheap-time)))
|
|
((run-time)
|
|
(receive (seconds mseconds)
|
|
(run-time)
|
|
(goto return-time-value option seconds mseconds)))
|
|
((real-time)
|
|
(receive (seconds mseconds)
|
|
(real-time)
|
|
(goto return-time-value option seconds mseconds)))
|
|
(else
|
|
(raise-exception bad-option 0 (enter-fixnum option) other)))))
|
|
|
|
; The largest number of seconds that can be converted into a fixnum number
|
|
; of milliseconds.
|
|
|
|
(define maximum-seconds (quotient (- greatest-fixnum-value 1000) 1000))
|
|
|
|
(define (return-time-value option seconds mseconds)
|
|
(if (> seconds maximum-seconds)
|
|
(raise-exception arithmetic-overflow 0
|
|
(enter-fixnum option)
|
|
(enter-fixnum seconds)
|
|
(enter-fixnum mseconds))
|
|
(goto return-fixnum (+ (* seconds 1000) mseconds))))
|
|
|
|
(define-primitive schedule-interrupt (fixnum->)
|
|
(lambda (delta)
|
|
(clear-interrupt! (enum interrupt alarm))
|
|
(goto return-fixnum (schedule-interrupt delta))))
|
|
|
|
; Convert from the user's exponent to the system's.
|
|
|
|
;(define (adjust-time mantissa exponent)
|
|
; (let ((system (clock-exponent)))
|
|
; (cond ((= exponent system)
|
|
; mantissa)
|
|
; ((> system exponent)
|
|
; (quotient mantissa (expt 10 (- system exponent))))
|
|
; (else
|
|
; (* mantissa (expt 10 (- exponent system)))))))
|
|
|
|
(define-enumeration vm-extension-status
|
|
(okay
|
|
exception
|
|
))
|
|
|
|
(define s48-*extension-value*)
|
|
|
|
(define-primitive vm-extension (fixnum-> any->)
|
|
(lambda (key value)
|
|
(let ((status (extended-vm key value)))
|
|
(cond ((vm-eq? status (enum vm-extension-status okay))
|
|
(goto return s48-*extension-value*))
|
|
((vm-eq? status (enum vm-extension-status exception))
|
|
(raise-exception extension-exception 0 (enter-fixnum key) value))
|
|
(else
|
|
(raise-exception extension-return-error 0 (enter-fixnum key) value))))))
|
|
|
|
; This is exported to keep s48-*EXTENSION-VALUE* from being eliminated by the
|
|
; compiler.
|
|
|
|
(define (s48-set-extension-value! value)
|
|
(set! s48-*extension-value* value))
|
|
|
|
; Used to indicate which stack block we are returning to. Set to FALSE if we are
|
|
; returning from the VM as a whole.
|
|
(define s48-*callback-return-stack-block* false)
|
|
|
|
(define-primitive return-from-callback (any-> any->)
|
|
(lambda (stack-block value)
|
|
(enable-interrupts!) ; Disabled to ensure that we return to the right
|
|
; stack block.
|
|
(set! s48-*callback-return-stack-block* stack-block)
|
|
value)) ; the interpreter returns this value
|
|
|
|
(define-primitive current-thread ()
|
|
(lambda () *current-thread*)
|
|
return-any)
|
|
|
|
(define-primitive set-current-thread! (any->)
|
|
(lambda (state)
|
|
(set! *current-thread* state))
|
|
return-unspecific)
|
|
|
|
(define-primitive session-data ()
|
|
(lambda () *session-data*)
|
|
return-any)
|
|
|
|
(define-primitive set-session-data! (any->)
|
|
(lambda (state)
|
|
(set! *session-data* state))
|
|
return-unspecific)
|
|
|
|
; Unnecessary primitives
|
|
|
|
(define-primitive string=? (string-> string->) vm-string=? return-boolean)
|
|
|
|
; Special primitive called by the reader.
|
|
; Primitive for the sake of speed. Probably should be flushed.
|
|
|
|
(define-consing-primitive reverse-list->string (any-> fixnum->)
|
|
(lambda (n) (vm-string-size (extract-fixnum n)))
|
|
(lambda (l n k)
|
|
(if (not (or (vm-pair? l) (vm-eq? l null)))
|
|
(raise-exception wrong-type-argument 0 l (enter-fixnum n))
|
|
(let ((obj (vm-make-string n k)))
|
|
(do ((l l (vm-cdr l))
|
|
(i (- n 1) (- i 1)))
|
|
((< i 0)
|
|
(goto return obj))
|
|
(vm-string-set! obj i (extract-char (vm-car l))))))))
|
|
|
|
(define-primitive string-hash (string->) vm-string-hash return-fixnum)
|
|
|
|
; Messy because we have to detect circular lists (alternatively we
|
|
; could check for interrupts and then pclsr). ***
|
|
|
|
(define-primitive assq (any-> any->)
|
|
(lambda (thing list)
|
|
(let ((lose (lambda ()
|
|
(raise-exception wrong-type-argument 0 thing list))))
|
|
(let loop ((list list) (slow list) (move-slow? #t))
|
|
(cond ((vm-eq? list null)
|
|
(goto return-boolean #f))
|
|
((not (vm-pair? list))
|
|
(lose))
|
|
(else
|
|
(let ((head (vm-car list)))
|
|
(cond ((not (vm-pair? head))
|
|
(lose))
|
|
((vm-eq? (vm-car head) thing)
|
|
(goto return head))
|
|
(else
|
|
(let ((list (vm-cdr list)))
|
|
(cond ((eq? list slow)
|
|
(lose))
|
|
(move-slow?
|
|
(loop list (vm-cdr slow) #f))
|
|
(else
|
|
(loop list slow #t)))))))))))))
|
|
|
|
; Eventually add make-table, table-ref, table-set! as primitives?
|
|
; No -- write a compiler instead.
|
|
|
|
; *** Our entry for the obscure comment of the year contest.
|
|
;
|
|
; Pclsring is the term in ITS for the mechanism that makes the operating system
|
|
; appear to be a virtual machine. The paradigm is that of the BLT instruction
|
|
; on the PDP-10: its arguments are in a set of registers, and if the instruction
|
|
; gets interrupted in the middle, the registers reflect the intermediate state;
|
|
; the PC is set to the BLT instruction itself, and the process can be resumed
|
|
; in the usual way.
|
|
; For more on pclsring see `Pclsring: Keeping Process State Modular' by Alan
|
|
; Bawden (ftp.ai.mit.edu:pub/alan/pclsr.memo).
|