1 files changed, 416 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-r6rs.scm b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm
new file mode 100644
index 0000000..4e48050
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm
@@ -0,0 +1,416 @@
+;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny
+;;
+;; Licence: public domain
+;; Author: Helmut Eller
+;;
+;; This is a Swank server barely capable enough to process simple eval
+;; requests from Emacs before dying.  No fancy features like
+;; backtraces, module redefintion, M-. etc. are implemented.  Don't
+;; even think about pc-to-source mapping.
+;;
+;; Despite standard modules, this file uses (swank os) and (swank sys)
+;; which define implementation dependend functionality.  There are
+;; multiple modules in this files, which is probably not standardized.
+;;
+
+;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c
+(library (swank format)
+    (export format printf fprintf)
+    (import (rnrs))
+
+ (define (format f . args)
+   (call-with-string-output-port
+    (lambda (port) (apply fprintf port f args))))
+
+ (define (printf f . args)
+   (let ((port (current-output-port)))
+     (apply fprintf port f args)
+     (flush-output-port port)))
+
+ (define (fprintf port f . args)
+   (let ((len (string-length f)))
+     (let loop ((i 0) (args args))
+       (cond ((= i len) (assert (null? args)))
+	     ((and (char=? (string-ref f i) #\~)
+		   (< (+ i 1) len))
+	      (dispatch-format (string-ref f (+ i 1)) port (car args))
+	      (loop (+ i 2) (cdr args)))
+	     (else
+	      (put-char port (string-ref f i))
+	      (loop (+ i 1) args))))))
+ 
+ (define (dispatch-format char port arg)
+   (let ((probe (assoc char format-dispatch-table)))
+     (cond (probe ((cdr probe) arg port))
+	   (else (error "invalid format char: " char)))))
+
+ (define format-dispatch-table 
+   `((#\a . ,display)
+     (#\s . ,write)
+     (#\d . ,(lambda (arg port) (put-string port (number->string arg 10))))
+     (#\x . ,(lambda (arg port) (put-string port (number->string arg 16))))
+     (#\c . ,(lambda (arg port) (put-char port arg))))))
+
+
+;; CL-style restarts to let us continue after errors.
+(library (swank restarts)
+    (export with-simple-restart compute-restarts invoke-restart restart-name
+	    write-restart-report)
+    (import (rnrs))
+
+ (define *restarts* '())
+
+ (define-record-type restart
+   (fields name reporter continuation))
+ 
+ (define (with-simple-restart name reporter thunk)
+   (call/cc 
+    (lambda (k)
+      (let ((old-restarts *restarts*)
+	    (restart (make-restart name (coerce-to-reporter reporter) k)))
+	(dynamic-wind
+	    (lambda () (set! *restarts* (cons restart old-restarts)))
+	    thunk
+	    (lambda () (set! *restarts* old-restarts)))))))
+
+ (define (compute-restarts) *restarts*)
+
+ (define (invoke-restart restart . args)
+   (apply (restart-continuation restart) args))
+
+ (define (write-restart-report restart port)
+   ((restart-reporter restart) port))
+
+ (define (coerce-to-reporter obj)
+   (cond ((string? obj) (lambda (port) (put-string port obj)))
+	 (#t (assert (procedure? obj)) obj)))
+
+ )
+
+;; This module encodes & decodes messages from the wire and queues them.
+(library (swank event-queue)
+    (export make-event-queue wait-for-event enqueue-event 
+	    read-event write-event)
+    (import (rnrs)
+	    (rnrs mutable-pairs)
+	    (swank format))
+
+ (define-record-type event-queue
+   (fields (mutable q) wait-fun)
+   (protocol (lambda (init)
+	       (lambda (wait-fun)
+		 (init '() wait-fun)))))
+
+ (define (wait-for-event q pattern)
+   (or (poll q pattern)
+       (begin
+	 ((event-queue-wait-fun q) q)
+	 (wait-for-event q pattern))))
+ 
+ (define (poll q pattern)
+   (let loop ((lag #f)
+	      (l (event-queue-q q)))
+     (cond ((null? l) #f)
+	   ((event-match? (car l) pattern)
+	    (cond (lag 
+		   (set-cdr! lag (cdr l))
+		   (car l))
+		  (else
+		   (event-queue-q-set! q (cdr l))
+		   (car l))))
+	   (else (loop l (cdr l))))))
+
+ (define (event-match? event pattern)
+   (cond ((or (number? pattern)
+	      (member pattern '(t nil)))
+	  (equal? event pattern))
+	 ((symbol? pattern) #t)
+	 ((pair? pattern)
+	  (case (car pattern)
+	    ((quote) (equal? event (cadr pattern)))
+	    ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern)))
+	    (else (and (pair? event)
+		       (event-match? (car event) (car pattern))
+		       (event-match? (cdr event) (cdr pattern))))))
+	 (else (error "Invalid pattern: " pattern))))
+ 
+ (define (enqueue-event q event)
+   (event-queue-q-set! q
+		       (append (event-queue-q q) 
+			       (list event))))
+
+ (define (write-event event port)
+   (let ((payload (call-with-string-output-port
+		   (lambda (port) (write event port)))))
+     (write-length (string-length payload) port)
+     (put-string port payload)
+     (flush-output-port port)))
+
+ (define (write-length len port)
+   (do ((i 24 (- i 4)))
+       ((= i 0))
+     (put-string port
+		 (number->string (bitwise-bit-field len (- i 4) i)
+				 16))))
+
+ (define (read-event port)
+   (let* ((header (string-append (get-string-n port 2) 
+				 (get-string-n port 2)
+				 (get-string-n port 2)))
+	  (_ (printf "header: ~s\n" header))
+	  (len (string->number header 16))
+	  (_ (printf "len: ~s\n" len))
+	  (payload (get-string-n port len)))
+     (printf "payload: ~s\n" payload)
+     (read (open-string-input-port payload))))
+
+ )
+
+;; Entry points for SLIME commands.
+(library (swank rpc)
+    (export connection-info interactive-eval
+	    ;;compile-string-for-emacs 
+	    throw-to-toplevel sldb-abort
+	    operator-arglist buffer-first-change
+	    create-repl listener-eval)
+    (import (rnrs)
+	    (rnrs eval)
+	    (only (rnrs r5rs) scheme-report-environment)
+	    (swank os)
+	    (swank format)
+	    (swank restarts)
+	    (swank sys)
+	    )
+ 
+ (define (connection-info . _)
+   `(,@'()
+     :pid ,(getpid) 
+     :package (:name ">" :prompt ">")
+     :lisp-implementation (,@'() 
+			   :name ,(implementation-name)
+			   :type "R6RS-Scheme")))
+
+ (define (interactive-eval string)
+   (call-with-values 
+       (lambda ()
+	 (eval-in-interaction-environment (read-from-string string)))
+     (case-lambda
+      (() "; no value")
+      ((value) (format "~s" value))
+      (values (format "values: ~s" values)))))
+ 
+ (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel))
+
+ (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort))
+ 
+ (define (invoke-restart-by-name-or-nil name)
+   (let ((r (find (lambda (r) (eq? (restart-name r) name))
+		  (compute-restarts))))
+     (if r (invoke-restart r) 'nil)))
+
+ (define (create-repl target)
+   (list "" ""))
+
+ (define (listener-eval string)
+   (call-with-values (lambda () (eval-region string))
+     (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values)))))
+
+ (define (eval-region string)
+   (let ((sexp (read-from-string string)))
+     (if (eof-object? exp)
+	 (values)
+	 (eval-in-interaction-environment sexp))))
+
+ (define (read-from-string string)
+   (call-with-port (open-string-input-port string) read))
+
+ (define (operator-arglist . _) 'nil)
+ (define (buffer-first-change . _) 'nil)
+
+ )
+
+;; The server proper.  Does the TCP stuff and exception handling.
+(library (swank)
+    (export start-server)
+    (import (rnrs) 
+	    (rnrs eval)
+	    (swank os)
+	    (swank format)
+	    (swank event-queue)
+	    (swank restarts))
+
+ (define-record-type connection
+   (fields in-port out-port event-queue))
+
+ (define (start-server port)
+   (accept-connections (or port 4005) #f))
+
+ (define (start-server/port-file port-file)
+   (accept-connections #f port-file))
+
+ (define (accept-connections port port-file)
+   (let ((sock (make-server-socket port)))
+     (printf "Listening on port: ~s\n" (local-port sock))
+     (when port-file 
+       (write-port-file (local-port sock) port-file))
+     (let-values (((in out) (accept sock (latin-1-codec))))
+       (dynamic-wind 
+	   (lambda () #f)
+	   (lambda () 
+	     (close-socket sock)
+	     (serve in out))
+	   (lambda () 
+	     (close-port in)
+	     (close-port out))))))
+
+ (define (write-port-file port port-file)
+   (call-with-output-file 
+       (lambda (file) 
+	 (write port file))))
+
+ (define (serve in out) 
+   (let ((err (current-error-port))
+	 (q (make-event-queue 
+	     (lambda (q)
+	       (let ((e (read-event in)))
+		 (printf "read: ~s\n" e)
+		 (enqueue-event q e))))))
+     (dispatch-loop (make-connection in out q))))
+
+ (define-record-type sldb-state
+   (fields level condition continuation next))
+
+ (define (dispatch-loop conn)
+   (let ((event (wait-for-event (connection-event-queue conn) 'x)))
+     (case (car event)
+       ((:emacs-rex) 
+	(with-simple-restart 
+	 'toplevel "Return to SLIME's toplevel"
+	 (lambda ()
+	   (apply emacs-rex conn #f (cdr event)))))
+       (else (error "Unhandled event: ~s" event))))
+   (dispatch-loop conn))
+
+ (define (recover thunk on-error-thunk)
+   (let ((ok #f))
+     (dynamic-wind 
+	 (lambda () #f) 
+	 (lambda () 
+	   (call-with-values thunk 
+	     (lambda vals 
+	       (set! ok #t) 
+	       (apply values vals))))
+	 (lambda ()
+	   (unless ok
+	     (on-error-thunk))))))
+
+ ;; Couldn't resist to exploit the prefix feature.
+ (define rpc-entries (environment '(prefix (swank rpc) swank:)))
+ 
+ (define (emacs-rex conn sldb-state form package thread tag)
+   (let ((out (connection-out-port conn)))
+     (recover
+      (lambda ()
+	(with-exception-handler
+	 (lambda (condition) 
+	   (call/cc 
+	    (lambda (k)
+	      (sldb-exception-handler conn condition k sldb-state))))
+	 (lambda ()
+	   (let ((value (apply (eval (car form) rpc-entries) (cdr form))))
+	     (write-event `(:return (:ok ,value) ,tag) out)))))
+      (lambda ()
+	(write-event `(:return (:abort) ,tag) out)))))
+
+ (define (sldb-exception-handler connection condition k sldb-state)
+   (when (serious-condition? condition)
+     (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1))
+	   (out (connection-out-port connection)))
+       (write-event `(:debug 0 ,level ,@(debugger-info condition connection))
+		    out)
+       (dynamic-wind
+	   (lambda () #f)
+	   (lambda ()
+	     (sldb-loop connection 
+			(make-sldb-state level condition k sldb-state)))
+	   (lambda () (write-event `(:debug-return 0 ,level nil) out))))))
+
+ (define (sldb-loop connection state)
+   (apply emacs-rex connection state
+	  (cdr (wait-for-event (connection-event-queue connection) 
+			       '(':emacs-rex . _))))
+   (sldb-loop connection state))
+
+ (define (debugger-info condition connection)
+   (list `(,(call-with-string-output-port 
+	     (lambda (port) (print-condition condition port)))
+	   ,(format " [type ~s]" (if (record? condition)
+				     (record-type-name (record-rtd condition))
+				     ))
+	   ())
+	 (map (lambda (r) 
+		(list (format "~a" (restart-name r))
+		      (call-with-string-output-port
+		       (lambda (port)
+			 (write-restart-report r port)))))
+	      (compute-restarts))
+	 '()
+	 '()))
+
+ (define (print-condition obj port)
+   (cond ((condition? obj)
+	  (let ((list (simple-conditions obj)))
+	    (case (length list)
+	      ((0)
+	       (display "Compuond condition with zero components" port))
+	      ((1)
+	       (assert (eq? obj (car list)))
+	       (print-simple-condition (car list) port))
+	      (else
+	       (display "Compound condition:\n" port)
+	       (for-each (lambda (c)
+			   (display "  " port)
+			   (print-simple-condition c port)
+			   (newline port))
+			 list)))))
+	 (#t
+	  (fprintf port "Non-condition object: ~s" obj))))
+
+ (define (print-simple-condition condition port)
+   (fprintf port "~a" (record-type-name (record-rtd condition)))
+   (case (count-record-fields condition)
+     ((0) #f)
+     ((1) 
+      (fprintf port ": ")
+      (do-record-fields condition (lambda (name value) (write value port))))
+     (else
+      (fprintf port ":")
+      (do-record-fields condition (lambda (name value) 
+				    (fprintf port "\n~a: ~s" name value))))))
+
+ ;; Call FUN with RECORD's rtd and parent rtds.
+ (define (do-record-rtds record fun)
+   (do ((rtd (record-rtd record) (record-type-parent rtd)))
+       ((not rtd))
+     (fun rtd)))
+
+ ;; Call FUN with RECORD's field names and values.
+ (define (do-record-fields record fun)
+   (do-record-rtds 
+    record
+    (lambda (rtd)
+      (let* ((names (record-type-field-names rtd))
+	     (len (vector-length names)))
+	(do ((i 0 (+ 1 i)))
+	    ((= i len))
+	  (fun (vector-ref names i) ((record-accessor rtd i) record)))))))
+
+ ;; Return the number of fields in RECORD
+ (define (count-record-fields record)
+   (let ((i 0))
+     (do-record-rtds 
+      record (lambda (rtd) 
+	       (set! i (+ i (vector-length (record-type-field-names rtd))))))
+     i))
+
+ )