61 lines
2.0 KiB
Scheme
61 lines
2.0 KiB
Scheme
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
||
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
; This is file resume.scm.
|
||
|
|
|
||
|
|
(define (s48-initialize-vm stack-begin stack-size)
|
||
|
|
(install-symbols!+gc (s48-initial-symbols))
|
||
|
|
(install-shared-bindings!+gc (s48-initial-imported-bindings)
|
||
|
|
(s48-initial-exported-bindings))
|
||
|
|
(initialize-stack+gc stack-begin stack-size)
|
||
|
|
(initialize-interpreter+gc))
|
||
|
|
|
||
|
|
;----------------
|
||
|
|
; Push the arguments to the initial procedure (a vector of strings passed
|
||
|
|
; in from the outside and the three standard channels) and call it.
|
||
|
|
|
||
|
|
(define (s48-call-startup-procedure startup-vector startup-vector-length)
|
||
|
|
(clear-registers)
|
||
|
|
(push (enter-startup-argument+gc startup-vector startup-vector-length))
|
||
|
|
(receive (input output error)
|
||
|
|
(initialize-i/o-system+gc)
|
||
|
|
(push input)
|
||
|
|
(push output)
|
||
|
|
(push error)
|
||
|
|
(push (s48-resumer-records))
|
||
|
|
(s48-initialization-complete!)
|
||
|
|
(s48-restart (s48-startup-procedure) 5)))
|
||
|
|
|
||
|
|
(define (enter-startup-argument+gc startup-vector startup-vector-length)
|
||
|
|
(let* ((size (+ (do ((i 0 (+ i 1))
|
||
|
|
(size 0 (+ size (vm-string-size
|
||
|
|
(string-length
|
||
|
|
(vector-ref startup-vector i))))))
|
||
|
|
((= i startup-vector-length)
|
||
|
|
size))
|
||
|
|
(vm-vector-size startup-vector-length)))
|
||
|
|
(key (ensure-space size))
|
||
|
|
(vector (vm-make-vector startup-vector-length key)))
|
||
|
|
(natural-for-each (lambda (i)
|
||
|
|
(vm-vector-set! vector
|
||
|
|
i
|
||
|
|
(enter-string
|
||
|
|
(vector-ref startup-vector i)
|
||
|
|
key)))
|
||
|
|
startup-vector-length)
|
||
|
|
vector))
|
||
|
|
|
||
|
|
;----------------
|
||
|
|
; Restart the interpreter, calling PROC with NARGS arguments already on the
|
||
|
|
; stack.
|
||
|
|
|
||
|
|
(define (s48-restart proc nargs)
|
||
|
|
(receive (key proc)
|
||
|
|
(ensure-space-saving-temp (code-vector-size 2) proc)
|
||
|
|
(let ((code (make-code-vector 2 key)))
|
||
|
|
(code-vector-set! code 0 (enum op call))
|
||
|
|
(code-vector-set! code 1 nargs)
|
||
|
|
(set-code-pointer! code 0)
|
||
|
|
(set-val! proc)
|
||
|
|
(interpret (code-pointer)))))
|