674 lines
20 KiB
Scheme
674 lines
20 KiB
Scheme
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|||
|
|
|
|||
|
|
; This is file prim.scm.
|
|||
|
|
; Requires DEFINE-PRIMITIVE macro.
|
|||
|
|
|
|||
|
|
;;;; VM data manipulation primitives
|
|||
|
|
|
|||
|
|
; Input checking and coercion
|
|||
|
|
|
|||
|
|
(define (input-type pred coercer) ;Alonzo wins
|
|||
|
|
(lambda (f) (f pred coercer)))
|
|||
|
|
|
|||
|
|
(define (input-type-predicate type) (type (lambda (x y) y x)))
|
|||
|
|
(define (input-type-coercion type) (type (lambda (x y) x y)))
|
|||
|
|
|
|||
|
|
(define (no-coercion x) x)
|
|||
|
|
|
|||
|
|
(define any-> (input-type (lambda (x) x #t) no-coercion))
|
|||
|
|
(define fixnum-> (input-type fixnum? extract-fixnum))
|
|||
|
|
(define char-> (input-type vm-char? extract-char))
|
|||
|
|
(define vm-char-> (input-type vm-char? no-coercion))
|
|||
|
|
(define boolean-> (input-type vm-boolean? extract-boolean))
|
|||
|
|
(define location-> (input-type location? no-coercion))
|
|||
|
|
(define string-> (input-type vm-string? no-coercion))
|
|||
|
|
(define vector-> (input-type vm-vector? no-coercion))
|
|||
|
|
(define code-vector-> (input-type code-vector? no-coercion))
|
|||
|
|
|
|||
|
|
; Output coercion
|
|||
|
|
|
|||
|
|
(define (return val)
|
|||
|
|
(set! *val* val)
|
|||
|
|
(goto interpret))
|
|||
|
|
|
|||
|
|
(define return-any return)
|
|||
|
|
|
|||
|
|
(define (return-boolean x)
|
|||
|
|
(goto return (enter-boolean x)))
|
|||
|
|
|
|||
|
|
(define (return-fixnum x)
|
|||
|
|
(goto return (enter-fixnum x)))
|
|||
|
|
|
|||
|
|
(define (return-char x)
|
|||
|
|
(goto return (enter-char x)))
|
|||
|
|
|
|||
|
|
(define (return-unspecific x)
|
|||
|
|
x ;ignored
|
|||
|
|
(goto return unspecific))
|
|||
|
|
|
|||
|
|
; Scalar primitives
|
|||
|
|
|
|||
|
|
(define-primitive eq? (any-> any->) vm-eq? return-boolean)
|
|||
|
|
|
|||
|
|
; Rudimentary generic arithmetic. Incomplete and confusing.
|
|||
|
|
; How to modularize for VM's like Maclisp that have generic arithmetic
|
|||
|
|
; built-in?
|
|||
|
|
|
|||
|
|
; These predicates are used to characterize the numeric representations that
|
|||
|
|
; are implemented in the VM.
|
|||
|
|
|
|||
|
|
(define primitive-number? fixnum?)
|
|||
|
|
(define primitive-real? fixnum?)
|
|||
|
|
(define primitive-integer? fixnum?)
|
|||
|
|
|
|||
|
|
(define number-> (input-type primitive-number? no-coercion))
|
|||
|
|
(define real-> (input-type primitive-real? no-coercion))
|
|||
|
|
(define integer-> (input-type primitive-integer? no-coercion))
|
|||
|
|
|
|||
|
|
(define-primitive number? (any->)
|
|||
|
|
(lambda (x)
|
|||
|
|
(or (fixnum? x)
|
|||
|
|
(extended-number? x)))
|
|||
|
|
return-boolean)
|
|||
|
|
|
|||
|
|
(define-syntax define-numeric-predicate
|
|||
|
|
(syntax-rules ()
|
|||
|
|
((define-numeric-predicate op)
|
|||
|
|
(define-primitive op
|
|||
|
|
(any->)
|
|||
|
|
(lambda (n)
|
|||
|
|
(cond ((fixnum? n)
|
|||
|
|
(goto return (enter-boolean #t)))
|
|||
|
|
((extended-number? n)
|
|||
|
|
(goto raise-exception1 0 n))
|
|||
|
|
(else
|
|||
|
|
(goto return (enter-boolean #f)))))))))
|
|||
|
|
|
|||
|
|
(define-numeric-predicate integer?)
|
|||
|
|
(define-numeric-predicate rational?)
|
|||
|
|
(define-numeric-predicate real?)
|
|||
|
|
(define-numeric-predicate complex?)
|
|||
|
|
|
|||
|
|
; These primitives have a simple answer in the case of fixnums; for all other
|
|||
|
|
; they punt to the run-time system.
|
|||
|
|
|
|||
|
|
(define-primitive exact? (number->) (lambda (n) #t) return-boolean)
|
|||
|
|
(define-primitive real-part (number->) (lambda (n) (goto return n)))
|
|||
|
|
(define-primitive imag-part (number->) (lambda (n)
|
|||
|
|
(goto return (enter-fixnum 0))))
|
|||
|
|
(define-primitive floor (number->) (lambda (n) (goto return n)))
|
|||
|
|
(define-primitive numerator (number->) (lambda (n) (goto return n)))
|
|||
|
|
(define-primitive denominator (number->) (lambda (n)
|
|||
|
|
(goto return (enter-fixnum 1))))
|
|||
|
|
(define-primitive angle (number->) (lambda (n)
|
|||
|
|
(if (>= n 0)
|
|||
|
|
(goto return (enter-fixnum 0))
|
|||
|
|
(goto raise-exception1 0 n))))
|
|||
|
|
|
|||
|
|
; beware of (abs least-fixnum)
|
|||
|
|
(define-primitive magnitude (number->)
|
|||
|
|
(lambda (n)
|
|||
|
|
(abs-carefully n
|
|||
|
|
return
|
|||
|
|
(lambda (n)
|
|||
|
|
(goto raise-exception1 0 n)))))
|
|||
|
|
|
|||
|
|
; These primitives all just raise an exception and let the run-time system do
|
|||
|
|
; the work.
|
|||
|
|
|
|||
|
|
(define-syntax define-punt-primitive
|
|||
|
|
(syntax-rules ()
|
|||
|
|
((define-punt-primitive op)
|
|||
|
|
(define-primitive op (number->)
|
|||
|
|
(lambda (n) (goto raise-exception1 0 n))))))
|
|||
|
|
|
|||
|
|
(define-punt-primitive exact->inexact)
|
|||
|
|
(define-punt-primitive inexact->exact)
|
|||
|
|
(define-punt-primitive exp)
|
|||
|
|
(define-punt-primitive log)
|
|||
|
|
(define-punt-primitive sin)
|
|||
|
|
(define-punt-primitive cos)
|
|||
|
|
(define-punt-primitive tan)
|
|||
|
|
(define-punt-primitive asin)
|
|||
|
|
(define-punt-primitive acos)
|
|||
|
|
(define-punt-primitive sqrt)
|
|||
|
|
|
|||
|
|
(define-syntax define-punt2-primitive
|
|||
|
|
(syntax-rules ()
|
|||
|
|
((define-punt2-primitive op)
|
|||
|
|
(define-primitive op (number-> number->)
|
|||
|
|
(lambda (n m) (goto raise-exception2 0 n m))))))
|
|||
|
|
|
|||
|
|
(define-punt2-primitive atan)
|
|||
|
|
(define-punt2-primitive make-polar)
|
|||
|
|
(define-punt2-primitive make-rectangular)
|
|||
|
|
|
|||
|
|
(define (arithmetic-overflow x y)
|
|||
|
|
(goto raise-exception2 0 x y))
|
|||
|
|
|
|||
|
|
(define (arith op)
|
|||
|
|
(lambda (x y)
|
|||
|
|
(goto op x y return arithmetic-overflow)))
|
|||
|
|
|
|||
|
|
(define-primitive + (number-> number->) (arith add-carefully))
|
|||
|
|
(define-primitive - (number-> number->) (arith subtract-carefully))
|
|||
|
|
(define-primitive * (number-> number->) (arith multiply-carefully))
|
|||
|
|
(define-primitive / (number-> number->) (arith divide-carefully))
|
|||
|
|
(define-primitive quotient (integer-> integer->) (arith quotient-carefully))
|
|||
|
|
(define-primitive remainder (integer-> integer->) (arith remainder-carefully))
|
|||
|
|
(define-primitive = (number-> number->) vm-= return-boolean)
|
|||
|
|
(define-primitive < (real-> real->) vm-< return-boolean)
|
|||
|
|
(define-primitive arithmetic-shift (number-> number->)
|
|||
|
|
(arith shift-carefully))
|
|||
|
|
|
|||
|
|
(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))
|
|||
|
|
(goto raise-exception1 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 bitwise-not (fixnum->) bitwise-not return-fixnum)
|
|||
|
|
(define-primitive bitwise-and (fixnum-> fixnum->) bitwise-and return-fixnum)
|
|||
|
|
(define-primitive bitwise-ior (fixnum-> fixnum->) bitwise-ior return-fixnum)
|
|||
|
|
(define-primitive bitwise-xor (fixnum-> fixnum->) bitwise-xor return-fixnum)
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-has-type?
|
|||
|
|
(any->)
|
|||
|
|
(lambda (x)
|
|||
|
|
(stob-of-type? x (next-byte)))
|
|||
|
|
return-boolean)
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-length
|
|||
|
|
(any->)
|
|||
|
|
(lambda (stob)
|
|||
|
|
(let ((type (next-byte)))
|
|||
|
|
(if (stob-of-type? stob type)
|
|||
|
|
(goto return-fixnum (d-vector-length stob))
|
|||
|
|
(goto raise-exception2 1 stob (enter-fixnum type))))))
|
|||
|
|
|
|||
|
|
; Fixed sized objects
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-ref
|
|||
|
|
(any->)
|
|||
|
|
(lambda (stob)
|
|||
|
|
(let* ((type (next-byte))
|
|||
|
|
(offset (next-byte)))
|
|||
|
|
(if (stob-of-type? stob type)
|
|||
|
|
(goto return (d-vector-ref stob offset))
|
|||
|
|
(goto raise-exception3 2
|
|||
|
|
stob
|
|||
|
|
(enter-fixnum type)
|
|||
|
|
(enter-fixnum offset))))))
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-set!
|
|||
|
|
(any-> any->)
|
|||
|
|
(lambda (stob value)
|
|||
|
|
(let* ((type (next-byte))
|
|||
|
|
(offset (next-byte)))
|
|||
|
|
(cond ((and (stob-of-type? stob type)
|
|||
|
|
(not (immutable? stob)))
|
|||
|
|
(d-vector-set! stob offset value)
|
|||
|
|
(goto return unspecific))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception4 2
|
|||
|
|
stob
|
|||
|
|
(enter-fixnum type)
|
|||
|
|
(enter-fixnum offset)
|
|||
|
|
value))))))
|
|||
|
|
|
|||
|
|
; Indexed objects
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-indexed-ref
|
|||
|
|
(any-> fixnum->)
|
|||
|
|
(lambda (stob index)
|
|||
|
|
(let ((type (next-byte)))
|
|||
|
|
(if (and (stob-of-type? stob type)
|
|||
|
|
(valid-index? index (d-vector-length stob)))
|
|||
|
|
(goto return (d-vector-ref stob index))
|
|||
|
|
(goto raise-exception3 1
|
|||
|
|
stob (enter-fixnum type) (enter-fixnum index))))))
|
|||
|
|
|
|||
|
|
(define-primitive stored-object-indexed-set! (any-> fixnum-> any->)
|
|||
|
|
(lambda (stob index value)
|
|||
|
|
(let ((type (next-byte)))
|
|||
|
|
(cond ((and (stob-of-type? stob type)
|
|||
|
|
(valid-index? index (d-vector-length stob))
|
|||
|
|
(not (immutable? stob)))
|
|||
|
|
(d-vector-set! stob index value)
|
|||
|
|
(goto return unspecific))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception4 1
|
|||
|
|
stob
|
|||
|
|
(enter-fixnum type)
|
|||
|
|
(enter-fixnum index)
|
|||
|
|
value))))))
|
|||
|
|
|
|||
|
|
; Code-vectors
|
|||
|
|
|
|||
|
|
(define-primitive code-vector-length
|
|||
|
|
(code-vector->)
|
|||
|
|
(lambda (code-vector)
|
|||
|
|
(goto return-fixnum (code-vector-length code-vector))))
|
|||
|
|
|
|||
|
|
(define-primitive code-vector-ref
|
|||
|
|
(code-vector-> fixnum->)
|
|||
|
|
(lambda (code-vector index)
|
|||
|
|
(if (valid-index? index (code-vector-length code-vector))
|
|||
|
|
(goto return-fixnum (code-vector-ref code-vector index))
|
|||
|
|
(goto raise-exception2 0 code-vector (enter-fixnum index)))))
|
|||
|
|
|
|||
|
|
(define-primitive code-vector-set!
|
|||
|
|
(code-vector-> fixnum-> fixnum->)
|
|||
|
|
(lambda (code-vector index value)
|
|||
|
|
(cond ((valid-index? index (code-vector-length code-vector))
|
|||
|
|
(code-vector-set! code-vector index value)
|
|||
|
|
(goto return unspecific))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception3 0
|
|||
|
|
code-vector
|
|||
|
|
(enter-fixnum index)
|
|||
|
|
(enter-fixnum value))))))
|
|||
|
|
|
|||
|
|
(define-primitive make-code-vector
|
|||
|
|
(fixnum-> fixnum->)
|
|||
|
|
(lambda (len init)
|
|||
|
|
(let ((lose (lambda ()
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum len) (enter-fixnum init))))
|
|||
|
|
(size (code-vector-size len)))
|
|||
|
|
(if (or (< len 0)
|
|||
|
|
(> size max-stob-size-in-cells))
|
|||
|
|
(lose)
|
|||
|
|
(maybe-ensure-space-saving-temp
|
|||
|
|
size
|
|||
|
|
(enter-fixnum 0)
|
|||
|
|
(lambda (okay? key ignore)
|
|||
|
|
(if (not okay?)
|
|||
|
|
(lose)
|
|||
|
|
(let ((code-vector (make-code-vector len key)))
|
|||
|
|
(do ((i (- len 1) (- i 1)))
|
|||
|
|
((< i 0))
|
|||
|
|
(code-vector-set! code-vector i init))
|
|||
|
|
(goto return code-vector)))))))))
|
|||
|
|
|
|||
|
|
; Strings
|
|||
|
|
|
|||
|
|
(define-primitive string-length
|
|||
|
|
(string->)
|
|||
|
|
(lambda (string)
|
|||
|
|
(goto return-fixnum (vm-string-length string))))
|
|||
|
|
|
|||
|
|
(define-primitive string-ref
|
|||
|
|
(string-> fixnum->)
|
|||
|
|
(lambda (string index)
|
|||
|
|
(if (valid-index? index (vm-string-length string))
|
|||
|
|
(goto return-char (vm-string-ref string index))
|
|||
|
|
(goto raise-exception2 0 string (enter-fixnum index)))))
|
|||
|
|
|
|||
|
|
(define-primitive string-set!
|
|||
|
|
(string-> fixnum-> char->)
|
|||
|
|
(lambda (string index char)
|
|||
|
|
(cond ((valid-index? index (vm-string-length string))
|
|||
|
|
(vm-string-set! string index char)
|
|||
|
|
(goto return unspecific))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception3 0
|
|||
|
|
string
|
|||
|
|
(enter-fixnum index)
|
|||
|
|
(enter-char char))))))
|
|||
|
|
|
|||
|
|
(define-primitive make-string
|
|||
|
|
(fixnum-> char->)
|
|||
|
|
(lambda (len init)
|
|||
|
|
(let ((lose (lambda ()
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum len) (enter-char init))))
|
|||
|
|
(size (vm-string-size len)))
|
|||
|
|
(if (or (< len 0)
|
|||
|
|
(> size max-stob-size-in-cells))
|
|||
|
|
(lose)
|
|||
|
|
(maybe-ensure-space-saving-temp
|
|||
|
|
size
|
|||
|
|
(enter-fixnum 0)
|
|||
|
|
(lambda (okay? key ignore)
|
|||
|
|
(if (not okay?)
|
|||
|
|
(lose)
|
|||
|
|
(let ((string (vm-make-string len key)))
|
|||
|
|
(do ((i (- len 1) (- i 1)))
|
|||
|
|
((< i 0))
|
|||
|
|
(vm-string-set! string i init))
|
|||
|
|
(goto return string)))))))))
|
|||
|
|
|
|||
|
|
; Constructors
|
|||
|
|
|
|||
|
|
(define-primitive make-stored-object
|
|||
|
|
()
|
|||
|
|
(lambda ()
|
|||
|
|
(let* ((key (ensure-space (cells->bytes (+ 1 (this-byte)))))
|
|||
|
|
(len (next-byte)) ; can't consume this byte until after ENSURE-SPACE
|
|||
|
|
(new (make-d-vector (next-byte) len key)))
|
|||
|
|
(cond ((>= len 1)
|
|||
|
|
(d-vector-set! new (- len 1) *val*)
|
|||
|
|
(do ((i (- len 2) (- i 1)))
|
|||
|
|
((> 0 i)
|
|||
|
|
(unassigned)) ; for the type checker!
|
|||
|
|
(d-vector-set! new i (pop)))))
|
|||
|
|
new))
|
|||
|
|
return)
|
|||
|
|
|
|||
|
|
(define-primitive make-vector-object (fixnum-> any->)
|
|||
|
|
(lambda (len init)
|
|||
|
|
(let* ((type (next-byte))
|
|||
|
|
(lose (lambda (init)
|
|||
|
|
(goto raise-exception3 1 (enter-fixnum type)
|
|||
|
|
(enter-fixnum len) init)))
|
|||
|
|
(size (vm-vector-size len)))
|
|||
|
|
(if (or (< len 0)
|
|||
|
|
(> size max-stob-size-in-cells))
|
|||
|
|
(lose init)
|
|||
|
|
(maybe-ensure-space-saving-temp size init
|
|||
|
|
(lambda (okay? key init)
|
|||
|
|
(if (not okay?)
|
|||
|
|
(lose init)
|
|||
|
|
(let ((v (make-d-vector type len key)))
|
|||
|
|
(do ((i (- len 1) (- i 1)))
|
|||
|
|
((< i 0))
|
|||
|
|
(d-vector-set! v i init))
|
|||
|
|
(goto return v)))))))))
|
|||
|
|
|
|||
|
|
(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)))
|
|||
|
|
(goto return unspecific)))
|
|||
|
|
|
|||
|
|
(define-primitive immutable? (any->) immutable? return-boolean)
|
|||
|
|
|
|||
|
|
(define-primitive make-immutable! (any->)
|
|||
|
|
(lambda (thing)
|
|||
|
|
(make-immutable! thing)
|
|||
|
|
(goto return thing)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
; I/O primitives
|
|||
|
|
|
|||
|
|
(define port-> (input-type port? no-coercion))
|
|||
|
|
(define input-port-> (input-type vm-input-port? no-coercion))
|
|||
|
|
(define output-port-> (input-type vm-output-port? no-coercion))
|
|||
|
|
(define open-input-port->
|
|||
|
|
(input-type (lambda (p)
|
|||
|
|
(and (vm-input-port? p)
|
|||
|
|
(open? p)))
|
|||
|
|
no-coercion))
|
|||
|
|
(define open-output-port->
|
|||
|
|
(input-type (lambda (p)
|
|||
|
|
(and (vm-output-port? p)
|
|||
|
|
(open? p)))
|
|||
|
|
extract-port))
|
|||
|
|
|
|||
|
|
(define-primitive input-port? (any->) vm-input-port? return-boolean)
|
|||
|
|
(define-primitive output-port? (any->) vm-output-port? return-boolean)
|
|||
|
|
|
|||
|
|
(define-consing-primitive open-port (string-> fixnum->)
|
|||
|
|
(lambda (ignore) port-size)
|
|||
|
|
(lambda (filename mode key)
|
|||
|
|
(open-port filename mode key
|
|||
|
|
collect-saving-temp ; a GC may be needed to free up a port
|
|||
|
|
(lambda (vm-port) ; all is okay
|
|||
|
|
(goto return vm-port))
|
|||
|
|
(lambda (filename) ; OS couldn't open filename
|
|||
|
|
(goto return false))
|
|||
|
|
(lambda (filename) ; VM is out of port descriptors
|
|||
|
|
(goto raise-exception2 0 filename (enter-fixnum key))))))
|
|||
|
|
|
|||
|
|
(define-primitive close-port (port->) close-port return-unspecific)
|
|||
|
|
|
|||
|
|
(define-primitive read-char (open-input-port->)
|
|||
|
|
(lambda (port)
|
|||
|
|
(let ((c (peeked-char port)))
|
|||
|
|
(goto return (cond ((false? c)
|
|||
|
|
(ps-read-char (extract-port port)
|
|||
|
|
enter-char
|
|||
|
|
(lambda () eof-object)))
|
|||
|
|
(else
|
|||
|
|
(set-peeked-char! port false)
|
|||
|
|
c))))))
|
|||
|
|
|
|||
|
|
(define-primitive peek-char (open-input-port->)
|
|||
|
|
(lambda (port)
|
|||
|
|
(let ((c (peeked-char port)))
|
|||
|
|
(goto return (cond ((false? c)
|
|||
|
|
(let ((c (ps-read-char (extract-port port)
|
|||
|
|
enter-char
|
|||
|
|
(lambda () eof-object))))
|
|||
|
|
(set-peeked-char! port c)
|
|||
|
|
c))
|
|||
|
|
(else c))))))
|
|||
|
|
|
|||
|
|
(define-primitive char-ready? (open-input-port->)
|
|||
|
|
(lambda (port)
|
|||
|
|
(goto return (enter-boolean (or (not (false? (peeked-char port)))
|
|||
|
|
(char-ready? (extract-port port)))))))
|
|||
|
|
|
|||
|
|
(define-primitive write-char (char-> open-output-port->)
|
|||
|
|
(lambda (c port)
|
|||
|
|
(write-char c port)
|
|||
|
|
(goto return unspecific)))
|
|||
|
|
|
|||
|
|
(define-primitive write-string (string-> open-output-port->)
|
|||
|
|
(lambda (s port)
|
|||
|
|
(write-vm-string s port)
|
|||
|
|
(goto return unspecific)))
|
|||
|
|
|
|||
|
|
(define-primitive force-output (open-output-port->)
|
|||
|
|
(lambda (port)
|
|||
|
|
(force-output port)
|
|||
|
|
(goto return unspecific)))
|
|||
|
|
|
|||
|
|
; Misc
|
|||
|
|
|
|||
|
|
(define-primitive false ()
|
|||
|
|
(lambda ()
|
|||
|
|
(goto return false)))
|
|||
|
|
|
|||
|
|
(define-primitive trap (any->)
|
|||
|
|
(lambda (arg)
|
|||
|
|
(goto raise-exception1 0 arg)))
|
|||
|
|
|
|||
|
|
(define-primitive find-all-symbols (vector->)
|
|||
|
|
(lambda (table)
|
|||
|
|
(if (walk-over-symbols
|
|||
|
|
(lambda (symbol)
|
|||
|
|
(if (available? vm-pair-size)
|
|||
|
|
(let ((key (preallocate-space vm-pair-size)))
|
|||
|
|
(add-to-symbol-table symbol table key)
|
|||
|
|
#t)
|
|||
|
|
#f)))
|
|||
|
|
(goto return unspecific)
|
|||
|
|
(goto raise-exception 0))))
|
|||
|
|
|
|||
|
|
(define-primitive find-all-xs (fixnum->)
|
|||
|
|
(lambda (type)
|
|||
|
|
(let ((vector (find-all-xs type)))
|
|||
|
|
(if (not (false? vector))
|
|||
|
|
(goto return vector)
|
|||
|
|
(goto raise-exception1 0 (enter-fixnum type))))))
|
|||
|
|
|
|||
|
|
; RESUME-PROC is called when the image is resumed.
|
|||
|
|
; This does a garbage collection rooting from RESUME-PROC, writes the heap
|
|||
|
|
; into a file, and then aborts the garbage collection (which didn't modify
|
|||
|
|
; any VM registers or the stack).
|
|||
|
|
|
|||
|
|
(define-primitive write-image (string-> any-> string->)
|
|||
|
|
(lambda (filename resume-proc comment-string)
|
|||
|
|
(if (not (image-writing-okay?))
|
|||
|
|
(goto raise-exception2 0 filename resume-proc)
|
|||
|
|
(let ((port (open-output-file (extract-string filename))))
|
|||
|
|
(cond ((null-port? port)
|
|||
|
|
(goto raise-exception2 0 filename resume-proc))
|
|||
|
|
(else
|
|||
|
|
(write-vm-string comment-string port)
|
|||
|
|
(begin-collection)
|
|||
|
|
(let ((resume-proc (trace-value resume-proc)))
|
|||
|
|
(do-gc)
|
|||
|
|
(close-untraced-ports!)
|
|||
|
|
(let ((size (write-image port resume-proc)))
|
|||
|
|
(close-output-port port)
|
|||
|
|
(abort-collection)
|
|||
|
|
(goto return (enter-fixnum size))))))))))
|
|||
|
|
|
|||
|
|
(define-primitive collect ()
|
|||
|
|
(lambda ()
|
|||
|
|
(set! *val* unspecific)
|
|||
|
|
(collect)
|
|||
|
|
(goto return unspecific)))
|
|||
|
|
|
|||
|
|
(define-primitive memory-status (fixnum-> any->)
|
|||
|
|
(lambda (key other)
|
|||
|
|
(cond ((= key (enum memory-status-option available))
|
|||
|
|
(goto return (enter-fixnum (available))))
|
|||
|
|
((= key (enum memory-status-option heap-size))
|
|||
|
|
(goto return
|
|||
|
|
(enter-fixnum
|
|||
|
|
(bytes->cells (heap-size)))))
|
|||
|
|
((= key (enum memory-status-option stack-size))
|
|||
|
|
(goto return (enter-fixnum (stack-size))))
|
|||
|
|
((= key (enum memory-status-option set-minimum-recovered-space!))
|
|||
|
|
(cond ((fixnum? other)
|
|||
|
|
(let ((old *minimum-recovered-space*))
|
|||
|
|
(set! *minimum-recovered-space*
|
|||
|
|
(extract-fixnum other))
|
|||
|
|
(goto return (enter-fixnum old))))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum key) other))))
|
|||
|
|
((= key (enum memory-status-option gc-count))
|
|||
|
|
(goto return (enter-fixnum (gc-count))))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum key) other)))))
|
|||
|
|
|
|||
|
|
(define-primitive time (fixnum-> any->)
|
|||
|
|
(lambda (key other)
|
|||
|
|
(cond ((= key (enum time-option ticks-per-second))
|
|||
|
|
(goto return (enter-fixnum (ps-ticks-per-second))))
|
|||
|
|
((= key (enum time-option run-time))
|
|||
|
|
(goto return (enter-fixnum (ps-run-time))))
|
|||
|
|
((= key (enum time-option real-time))
|
|||
|
|
(goto return (enter-fixnum (ps-real-time))))
|
|||
|
|
(else
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum key) other)))))
|
|||
|
|
|
|||
|
|
(define-primitive schedule-interrupt (fixnum->)
|
|||
|
|
(lambda (time)
|
|||
|
|
(clear-interrupt! (enum interrupt alarm))
|
|||
|
|
(goto return (enter-fixnum (ps-schedule-interrupt time)))))
|
|||
|
|
|
|||
|
|
(define external-> (input-type external? no-coercion))
|
|||
|
|
|
|||
|
|
(define-primitive external-lookup (external->)
|
|||
|
|
(lambda (external)
|
|||
|
|
(let ((name (external-name external))
|
|||
|
|
(value (external-value external)))
|
|||
|
|
(if (and (vm-string? name)
|
|||
|
|
(code-vector? value)
|
|||
|
|
(lookup-external-name (address-after-header name)
|
|||
|
|
(address-after-header value)))
|
|||
|
|
(goto return unspecific)
|
|||
|
|
(goto raise-exception1 0 external)))))
|
|||
|
|
|
|||
|
|
; This is only for the closed-compiled version of EXTERNAL-CALL.
|
|||
|
|
;
|
|||
|
|
; This is a mess because the arguments have been pushed on the stack after
|
|||
|
|
; the procedure.
|
|||
|
|
; The top-level driver loop removes the procedure and the arguments from
|
|||
|
|
; the stack.
|
|||
|
|
|
|||
|
|
(define-primitive external-call ()
|
|||
|
|
(lambda ()
|
|||
|
|
(let ((proc (stack-ref (- *nargs* 1))))
|
|||
|
|
(cond ((not (external? proc))
|
|||
|
|
(goto raise-exception1 0 proc)) ; lots of junk on the stack...
|
|||
|
|
(else
|
|||
|
|
(set! *nargs* (- *nargs* 1)) ; don't count the procedure
|
|||
|
|
(set! *val* proc)
|
|||
|
|
(enum return-option external-call)))))) ; return to driver loop
|
|||
|
|
|
|||
|
|
(define-primitive vm-extension (fixnum-> any->)
|
|||
|
|
(lambda (key value)
|
|||
|
|
(let ((return-value (extended-vm key value)))
|
|||
|
|
(if (undefined? return-value)
|
|||
|
|
(goto raise-exception2 0 (enter-fixnum key) value)
|
|||
|
|
(goto return return-value)))))
|
|||
|
|
|
|||
|
|
(define-primitive vm-return (fixnum-> any->)
|
|||
|
|
(lambda (key value)
|
|||
|
|
(set! *val* value)
|
|||
|
|
(enum return-option exit))) ; the VM returns this value
|
|||
|
|
|
|||
|
|
(define-primitive get-dynamic-state ()
|
|||
|
|
(lambda () *dynamic-state*)
|
|||
|
|
return-any)
|
|||
|
|
|
|||
|
|
(define-primitive set-dynamic-state! (any->)
|
|||
|
|
(lambda (state)
|
|||
|
|
(set! *dynamic-state* state)
|
|||
|
|
unspecific)
|
|||
|
|
return-any)
|
|||
|
|
|
|||
|
|
; 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 n))
|
|||
|
|
(lambda (l n k)
|
|||
|
|
(if (not (or (vm-pair? l) (vm-eq? l null)))
|
|||
|
|
(goto raise-exception2 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)
|
|||
|
|
|
|||
|
|
(define-consing-primitive intern (string-> vector->)
|
|||
|
|
(lambda (ignore) (+ vm-symbol-size vm-pair-size))
|
|||
|
|
intern
|
|||
|
|
return)
|
|||
|
|
|
|||
|
|
;#|
|
|||
|
|
;(define-primitive vector (fixnum->)
|
|||
|
|
; (let* ((min-args (next-byte))
|
|||
|
|
; (len (- *nargs* min-args))
|
|||
|
|
; (key (ensure-space (vector-size len)))
|
|||
|
|
; (vec (make-vector len)))
|
|||
|
|
; (do ((i (- len 1) (- i 1)))
|
|||
|
|
; ((= i -1)
|
|||
|
|
; (set! *val* l)
|
|||
|
|
; (set! *nargs* (+ min-args 1))
|
|||
|
|
; (goto interpret))
|
|||
|
|
; (vector-set vec i (pop)))))
|
|||
|
|
;|#
|
|||
|
|
; Eventually add make-table, table-ref, table-set! as primitives?
|
|||
|
|
; No -- write a compiler instead.
|