Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

416 lines
12 KiB

;; 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))
)