/
swank.sch
132 lines (110 loc) · 3.65 KB
/
swank.sch
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
;;; swank.sch --- BS swank server
;; DESCRIPTION: Provides Swank services for use with Emacs and Slime.
;;
;; Connecting and basic use works, evaluating code from a buffer or
;; the REPL. Autodoc requests are ignored. Debugging doesn't work at
;; all yet.
(require 'socket)
(define *swank-port* 4005)
(define *swank-debug* #f)
(define (swank-listen . port-arg)
"Start the swank server."
(let* ((port0 (car-else port-arg *swank-port*))
(port (if (zero? port0) (+ 1024 (random 10000)) port0)))
(printf "Starting swank server on port %a\n" port)
(define *swank-stream* (make-server-stream port))
(while #t
(let ((exp (swank:recv)))
(when *swank-debug*
(print-object stdout-stream exp)
(newline))
(let ((out
`(:return ,(apply (eval (car (second exp)))
(cdr (second exp)))
,(fifth exp))))
(when *swank-debug*
(print-object stdout-stream out)
(newline))
(swank:send out))))))
(define (swank:send exp)
"Send the expression to SLIME."
(let ((buffer (make-string-buffer))
(pad (lambda (str)
(if (< (string-length str) 6)
(string-append (make-string (- 6 (string-length str)) #\0)
str)
str))))
(print-object buffer exp)
(write-stream buffer "\n")
(let ((str (string-buffer->string buffer)))
(write-stream *swank-stream*
(pad (integer->string (string-length str) :base 16)))
(write-stream *swank-stream* str))))
(define (swank:recv)
"Read an expression from SLIME."
(dotimes (i 6)
(read-stream-char *swank-stream*)) ; throw out the number
(let ((exp (read-stream *swank-stream*)))
(read-stream-char *swank-stream*) ; throw out newline
exp))
;; Communication functions.
(define (object->string form)
"stringify a form using the standard printer"
(string-buffer->string
(doto (make-string-buffer)
(print-object form))))
(define (safe-eval exp)
"for internal evaluations: returns exception or result"
(guard
(ex
(#t ex))
(eval exp)))
(define-syntax (with-standard-return . body)
`(cons ':ok (begin . ,body)))
(define (swank:connection-info . args)
(with-standard-return
(list `(:pid ,(getpid) :style nil :lisp-implementation (:name "bsch")
:version "2010-12-10"))))
(define (swank:swank-require . args)
"Ignore for now."
(with-standard-return
'(("SWANK"))))
(define (swank:create-repl . args)
"Ignore for now."
(with-standard-return
'(("BSCH" "USER"))))
(define (swank:interactive-eval . args)
"Evaluate expression from SLIME."
(with-standard-return
(list (object->string (safe-eval (read-from-string (car args)))))))
(define (swank:listener-eval . args)
"Evaluate code from SLIME REPL."
(with-standard-return
(swank:send `(:presentation-start 1 :repl-result))
(swank:send `(:write-string ,(object->string
(safe-eval (read-from-string (car args))))
:repl-result))
(swank:send `(:presentation-end 1 :repl-result))
(swank:send `(:write-string "\n" :repl-result))
`(nil)))
(define (swank:compile-string-for-emacs . args)
"handle ctrl+c ctrl+c method of sending forms"
(list ':ok
`(:compilation-result
nil
,(object->string (safe-eval (read-from-string (car args)))))))
(define (swank:compile-file-for-emacs . args)
"handle ctrl+c ctrl+k method of sending a file"
(list ':ok
`(:compilation-result
nil
,(object->string (load (car args))))))
(define (swank:autodoc . args)
"Ignore for now."
(with-standard-return
(list "")))
(define (swank:buffer-first-change . args)
(with-standard-return
(list "")))
;; un-comment to have swank load on (require 'swank):
;(swank-listen)