scsh-0.5/misc/remote.scm

; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; ,load-config =scheme48/alt/packages.scm
; ,open remote

; To start a server, do
;   (define sock (make-socket))
;   (serve sock)
; To start a client, do
;   (remote-repl "hostname" <number>)
; where <number> is the number displayed by the server when it starts up.


; Server side

(define (note-structure-locations! s)
  (define (recur name env trail)
    (let ((b (generic-lookup env name)))
      (if (binding? b)
	  (begin
	    (note-location! (binding-place b))
	    (let ((t (binding-static b)))
	      (if (and (transform? t) (not (member t trail)))
		  (let ((trail (cons t trail))
			(env (transform-env t)))
		    (for-each (lambda (name)
				(recur name env trail))
			      (transform-aux-names (binding-static b))))))))))
  (for-each-declaration (lambda (name type)
			  (recur name s '())) 
			(structure-interface s)))

(note-structure-locations! scheme-level-2)

(define (make-socket)
  (call-with-values socket-server cons))

(define (serve sock)
  (let ((port-number (car sock))
	(accept (cdr sock)))
    (display "Port number is ")
    (write port-number)
    (newline)
    (let ((in #f)
	  (out #f))
      (dynamic-wind (lambda ()
		      (call-with-values accept
			(lambda (i-port o-port)
			  (display "Open") (newline)
			  (set! in i-port)
			  (set! out o-port))))
		    (lambda ()
		      (start-server in out))
		    (lambda ()
		      (if in (close-input-port in))
		      (if out (close-output-port out)))))))

(define (start-server in out)
  (let loop ()
    (let ((message (restore-carefully in)))
      (case (car message)
	((run)
	 (dump (run-carefully (cdr message))
	       (lambda (c) (write-char c out))
	       -1)
	 (force-output out)
	 (loop))
	((eof) (cdr message))
	(else (error "unrecognized message" message))))))

(define (run-carefully template)
  (call-with-current-continuation
    (lambda (escape)
      (with-handler
	  (lambda (c punt)
	    (if (error? c)
		(escape (cons 'condition c))
		(punt)))
	(lambda ()
	  (call-with-values (lambda ()
			      (invoke-closure (make-closure template #f)))
	    (lambda vals
	      (cons 'values vals))))))))


; Client side

(define (make-remote-eval in out)
  (lambda (form p)
    (compile-and-run-forms (list form)
			   p
			   #f
			   (lambda (template)
			     (dump (cons 'run template)
				   (lambda (c) (write-char c out))
				   -1)
			     (force-output out)
			     (let ((reply (restore-carefully in)))
			       (case (car reply)
				 ((values)
				  (apply values (cdr reply)))
				 ((condition)
				  (signal-condition (cdr reply)))
				 ((eof)
				  (error "eof on connection")))))
			   #f)))


(define (make-remote-package in out opens id)
  (let ((p (make-simple-package opens
 				#t
 				(reflective-tower
 				 (package->environment (interaction-environment)))
 				id)))
    (set-package-evaluator! p (make-remote-eval in out))
    p))

(define (remote-repl host-name socket-port-number)
  (let ((in #f) (out #f))
    (dynamic-wind
     (lambda ()
       (call-with-values (lambda ()
			   (socket-client host-name socket-port-number))
	 (lambda (i-port o-port)
	   (set! in i-port)
	   (set! out o-port))))
     (lambda ()
       (with-interaction-environment (make-remote-package in out (list scheme) 'remote)
				     (lambda () (command-loop list #f))))
     (lambda ()
       (if in (close-input-port in))
       (if out (close-output-port out))))))


; Common auxiliary

(define (restore-carefully in)
  (call-with-current-continuation
    (lambda (exit)
      (restore (lambda ()
		 (let ((c (read-char in)))
		   (if (eof-object? c)
		       (exit (cons 'eof c))
		       c)))))))