[slime-cvs] CVS slime/contrib

[heller]

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv759

Modified Files:
	ChangeLog 
Added Files:
	swank-mit-scheme.scm 
Log Message:
* swank-mit-scheme.scm: New file.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 15:21:52	1.95
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/03/02 22:41:45	1.96
@@ -13,6 +13,10 @@
 	(slime-presentation-easy-menu): New entry "Find Definition".
 	(slime-presentations-init): Hook into `slime-edit-definition-hooks'.
 
+2008-03-02  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-mit-scheme.scm: New file.
+
 2008-02-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Having the `slime-presentations' contrib enabled, (princ 10)

--- /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/02 22:41:45	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm	2008/03/02 22:41:45	1.1
;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
;;
;; Copyright (C) 2008  Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).

;;;; Installation:
#|

1. You need MIT Scheme (version 7.7.0 and 7.7.90 seem to work).

2. You also need the `netcat' program to create sockets.  MIT Scheme
   has some socket functions built-in, but I couldn't figure out how
   to access the locat port number of a server socket.  We shell out
   to netcat to get us started.

3. The Emacs side needs a bit configuration.  I have the following in
   my .emacs:

(setq slime-lisp-implementations
      '((mit-scheme ("mit-scheme") :init mit-scheme-init)))

(defun mit-scheme-init (file encoding)
  (format "%S\n\n"
	  `(begin
	    (load-option 'format)
	    (load-option 'sos)
	    (eval 
	     '(construct-normal-package-from-description
	       (make-package-description '(swank) '(()) 
					 (vector) (vector) (vector) false))
	     (->environment '(package)))
	    (load ,(expand-file-name 
		    ".../contrib/swank-mit-scheme.scm" ; <-- insert your path
		    slime-path)
		  (->environment '(swank)))
	    (eval '(start-swank ,file) (->environment '(swank))))))

(defun mit-scheme ()
  (interactive)
  (slime 'mit-scheme))

(defun find-mit-scheme-package ()
  (save-excursion
    (let ((case-fold-search t))
      (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
	   (match-string-no-properties 1)))))

(setq slime-find-buffer-package-function 'find-mit-scheme-package)

   The `mit-scheme-init' function first loads the SOS and FORMAT
   libraries, then creates a package "(swank)", and loads this file
   into that package.  Finally it starts the server.  

   `find-mit-scheme-package' tries to figure out which package the
   buffer belongs to, assuming that ";;; package: (FOO)" appears
   somewhere in the file.  Luckily, this assumption is true for many of
   MIT Scheme's own files.  Alternatively, you could add Emacs style
   -*- slime-buffer-package: "(FOO)" -*- file variables.

4. Start everything with `M-x mit-scheme'.

|#

;;; package: (swank)

(define (swank port)
  (accept-connections (or port 4005) #f))

(define (start-swank port-file)
  (accept-connections #f port-file))

;;;; Networking

(define (accept-connections port port-file)
  (let ((nc (netcat port)))
    (format #t "Listening on port: ~s~%" (cadr nc))
    (if port-file (write-port-file (cadr nc) port-file))
    (dynamic-wind 
	(lambda () #f)
	(lambda () (serve (netcat-accept (car nc))))
	(lambda () (close-port (subprocess-input-port (car nc)))))))

(define (netcat port)
  (let* ((sh (os/shell-file-name))
	 (cmd (format #f "exec netcat -s localhost -q 0 -l -v ~a 2>&1"
		      (if port (format #f "-p ~a" port) "")))
	 (netcat (start-pipe-subprocess sh 
					(vector sh "-c" cmd)
					scheme-subprocess-environment))
	 (line (read-line (subprocess-input-port netcat)))
	 (match (re-string-match "^listening on \\[[^]]+\\] \\([0-9]+\\) ...$"
				 line)))
    (cond ((not match)
	   (close-port (subprocess-input-port netcat))
	   (error "netcat:" line))
	  (else (list netcat 
		      (string->number (re-match-extract line match 1)))))))

(define (netcat-accept nc)
  (let* ((rx "^connect to \\[[^]]+\\] from [^ ]+ \\[[^]]+\\] \\([0-9]+\\)$")
	 (line (read-line (subprocess-input-port nc)))
	 (match (re-string-match rx line)))
    (cond ((not match) (error "netcat:" line))
	  (else (subprocess-input-port nc)))))

(define (write-port-file portnumber filename)
  (call-with-output-file filename (lambda (p) (write portnumber p))))

(define *top-level-restart* #f)
(define (serve socket)
  (with-simple-restart 
      'disconnect "Close connection."
      (lambda ()
	(with-keyboard-interrupt-handler 
	    (lambda () (main-loop socket))))))

(define (disconnect) 
  (format #t "Disconnecting ...~%")
  (invoke-restart (find-restart 'disconnect)))

(define (main-loop socket)
  (do () (#f)
    (with-simple-restart 
	'abort "Return to SLIME top-level."
	(lambda () 
	  (fluid-let ((*top-level-restart* (find-restart 'abort)))
	    (dispatch (read-packet socket) socket 0))))))

(define (with-keyboard-interrupt-handler fun)
  (define (set-^G-handler exp)
    (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp)
	  (->environment '(runtime interrupt-handler))))
  (dynamic-wind
      (lambda () #f)
      (lambda ()
	(set-^G-handler
	 `(lambda (char) (with-simple-restart
			  'continue "Continue from interrupt."
			  (lambda () (error "Keyboard Interrupt.")))))
	(fun))
      (lambda ()
	(set-^G-handler '^G-interrupt-handler))))


;;;; Reading/Writing of SLIME packets

(define (read-packet in)
  "Read an S-expression from STREAM using the SLIME protocol."
  (let* ((len (read-length in))
	 (buffer (make-string len)))
    (fill-buffer! in buffer)
    (read-from-string buffer)))

(define (write-packet message out)
  (let* ((string (write-to-string message)))
    (log-event "WRITE: [~a]~s~%" (string-length string) string)
    (write-length (string-length string) out)
    (write-string string out)
    (flush-output out)))

(define (fill-buffer! in buffer)
  (read-string! buffer in))

(define (read-length in)
  (if (eof-object? (peek-char in)) (disconnect))
  (do ((len 6 (1- len))
       (sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
      ((zero? len) sum)))

(define (ldb size position integer)
  "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
  (fix:and (fix:lsh integer (- position))
	   (1- (fix:lsh 1 size))))

(define (write-length len out)
  (do ((pos 20 (- pos 4)))
      ((< pos 0))
    (write-hex-digit (ldb 4 pos len) out)))

(define (write-hex-digit n out)
  (write-char (hex-digit->char n) out))

(define (hex-digit->char n)
  (digit->char n 16))

(define (char->hex-digit c)
  (char->digit c 16))


;;;; Event dispatching

(define (dispatch request socket level)
  (log-event "READ: ~s~%" request)
  (case (car request)
    ((:emacs-rex) (apply emacs-rex socket level (cdr request)))))

(define (swank-package)
  (or (name->package '(swank))
      (name->package '(user))))

(define *buffer-package* #f)
(define (find-buffer-package name)
  (if (elisp-false? name)
      #f
      (let ((v (ignore-errors 
		(lambda () (name->package (read-from-string name))))))
	(and (package? v) v))))

(define swank-env (->environment (swank-package)))
(define (user-env buffer-package)
  (cond ((string? buffer-package)
	 (let ((p (find-buffer-package buffer-package)))
	   (if (not p) (error "Invalid package name: " buffer-package))
	   (package/environment p)))
	(else (nearest-repl/environment))))

(define (emacs-rex socket level sexp package thread id)
  (let ((ok? #f) (result #f))
    (dynamic-wind
	(lambda () #f)
	(lambda ()
	  (bind-condition-handler 
	   (list condition-type:serious-condition)
	   (lambda (c) (invoke-sldb socket (1+ level) c))
	   (lambda ()
	     (fluid-let ((*buffer-package* package))
	       (set! result 
		     (eval (cons* (car sexp) socket (cdr sexp))
			   swank-env))
	       (set! ok? #t)))))
	(lambda ()
	  (write-packet `(:return ,(if ok? `(:ok ,result) '(:abort))
				   ,id)
			 socket)))))

(define (swank:connection-info _)
  (let ((p (environment->package (user-env #f))))
    `(:pid ,(unix/current-pid)
      :package (:name ,(write-to-string (package/name p))
		      :prompt ,(write-to-string (package/name p)))
      :lisp-implementation 
      (:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
      )))

(define (swank:quit-lisp _)
  (%exit))


;;;; Evaluation

(define (swank:listener-eval socket string)
  ;;(call-with-values (lambda () (eval-region string socket))
  ;;  (lambda values `(:values . ,(map write-to-string values))))
  `(:values ,(write-to-string (eval-region string socket))))

(define (eval-region string socket)
  (let ((sexp (read-from-string string)))
    (if (eof-object? exp)
	(values)
	(with-output-to-repl socket
	  (lambda () (eval sexp (user-env *buffer-package*)))))))

(define (with-output-to-repl socket fun)
  (let ((p (make-port repl-port-type socket)))
    (dynamic-wind
	(lambda () #f)
	(lambda () (with-output-to-port p fun))
	(lambda () (flush-output p)))))

(define (swank:interactive-eval socket string)
  ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
  (format-values (eval-region string socket))
  )

(define (format-values . values)
  (if (null? values) 
      "; No value"
      (with-string-output-port
	  (lambda (out)
	    (write-string "=> " out)
	    (do ((vs values (cdr vs))) ((null? vs))
	      (write (car vs) out)
	      (if (not (null? (cdr vs)))
		  (write-string ", " out)))))))

(define (swank:pprint-eval _ string)
  (pprint-to-string (eval (read-from-string string) 
			  (user-env *buffer-package*))))

(define (swank:interactive-eval-region socket string)
  (format-values (eval-region string socket)))

(define (swank:set-package _ package)
  (set-repl/environment! (nearest-repl) 
			 (->environment (read-from-string package)))
  (let* ((p (environment->package (user-env #f)))
	 (n (write-to-string (package/name p))))
    (list n n)))

 
(define (repl-write-substring port string start end)
  (cond ((< start end)
	 (write-packet `(:write-string ,(substring string start end))
		       (port/state port))))
  (- end start))

(define (repl-write-char port char)
  (write-packet `(:write-string ,(string char))
                (port/state port)))

(define repl-port-type
  (make-port-type `((write-substring ,repl-write-substring)
		    (write-char ,repl-write-char)) #f))


;;;; Compilation

(define (swank:compile-string-for-emacs _ string . x)
  (call-compiler
   (lambda ()
     (let* ((sexps (snarf-string string))
	    (env (user-env *buffer-package*))
	    (scode (syntax `(begin , at sexps) env))
	    (compiled-expression (compile-scode scode #t)))
       (scode-eval compiled-expression env)))))

(define (snarf-string string)
  (with-input-from-string string
    (lambda () 
      (let loop ()
	(let ((e (read)))
	  (if (eof-object? e) '() (cons e (loop))))))))

(define (call-compiler fun)
  (let ((time #f))
    (with-timings fun
      (lambda (run-time gc-time real-time)
	(set! time real-time)))
    (list 'nil (format #f "~a" (internal-time/ticks->seconds time)))))

(define (swank:compiler-notes-for-emacs _) nil)

(define (swank:compile-file-for-emacs socket file load?)
  (call-compiler
   (lambda ()
     (with-output-to-repl socket
       (lambda () (compile-file file)))
     (cond ((elisp-true? load?)
	    (load (pathname-new-type file "com")
		  (user-env *buffer-package*)))))))

(define (swank:load-file socket file)
  (with-output-to-repl socket
    (lambda () (load file (user-env *buffer-package*)))))

(define (swank:disassemble-symbol _ string)
  (with-output-to-string
      (lambda () 
	(compiler:disassemble
	 (eval (read-from-string string) 
	       (user-env *buffer-package*))))))


;;; Arglist

(define (swank:operator-arglist socket name pack)
  (let ((v (ignore-errors
	    (lambda ()
	      (with-output-to-string 
		(lambda ()
		  (carefully-pa 
		   (eval (read-from-string name) (user-env pack)))))))))
    (if (condition? v) 'nil v)))

(define (carefully-pa o)
  (cond ((arity-dispatched-procedure? o) 
	 ;; MIT Scheme crashes for (pa /)
	 (display "arity-dispatched-procedure"))
	((procedure? o) (pa o))
	(else (error "Not a procedure"))))


;;; Some unimplemented stuff.
(define (swank:buffer-first-change . _) nil)
(define (swank:frame-catch-tags-for-emacs . _) nil)

[457 lines skipped]