[slime-cvs] CVS slime/contrib
CVS User heller
heller at common-lisp.net
Tue Jun 23 18:11:14 UTC 2009
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv12558
Modified Files:
ChangeLog
Added Files:
swank-ikarus.ss swank-larceny.scm swank-r6rs.scm
Log Message:
* swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/16 06:36:40 1.218
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2009/06/23 18:11:13 1.219
@@ -1,3 +1,7 @@
+2009-06-23 Helmut Eller <heller at common-lisp.net>
+
+ * swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files.
+
2009-06-16 Tobias C. Rittweiler <tcr at freebits.de>
* slime-fontifying-fu.el (slime-search-suppressed-form):
--- /project/slime/cvsroot/slime/contrib/swank-ikarus.ss 2009/06/23 18:11:14 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-ikarus.ss 2009/06/23 18:11:14 1.1
;; swank-larceny.scm --- Swank server for Ikarus
;;
;; License: Public Domain
;; Author: Helmut Eller
;;
;; In a shell execute:
;; ikarus swank-ikarus.ss
;; and then `M-x slime-connect' in Emacs.
;;
(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(only (ikarus foreign) make-c-callout dlsym dlopen
pointer-set-c-long! pointer-ref-c-unsigned-short
malloc free pointer-size)
(rename (only (ikarus ipc) tcp-server-socket accept-connection
close-tcp-server-socket)
(tcp-server-socket make-server-socket)
(close-tcp-server-socket close-socket))
(only (ikarus)
struct-type-descriptor
struct-type-field-names
struct-field-accessor)
)
(define libc (dlopen))
(define (cfun name return-type arg-types)
((make-c-callout return-type arg-types) (dlsym libc name)))
(define getpid (cfun "getpid" 'signed-int '()))
(define (accept socket codec)
(let-values (((in out) (accept-connection socket)))
(values (transcoded-port in (make-transcoder codec))
(transcoded-port out (make-transcoder codec)))))
(define (socket-fd socket)
(let ((rtd (struct-type-descriptor socket)))
(do ((i 0 (+ i 1))
(names (struct-type-field-names rtd) (cdr names)))
((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket)))))
(define sockaddr_in/size 16)
(define sockaddr_in/sin_family 0)
(define sockaddr_in/sin_port 2)
(define sockaddr_in/sin_addr 4)
(define (local-port socket)
(let* ((fd (socket-fd socket))
(addr (malloc sockaddr_in/size))
(size (malloc (pointer-size))))
(pointer-set-c-long! size 0 sockaddr_in/size)
(let ((code (getsockname fd addr size))
(port (ntohs (pointer-ref-c-unsigned-short
addr sockaddr_in/sin_port))))
(free addr)
(free size)
(cond ((= code -1) (error "getsockname failed"))
(#t port)))))
(define getsockname
(cfun "getsockname" 'signed-int '(signed-int pointer pointer)))
(define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short)))
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(rnrs eval)
(only (ikarus) interaction-environment))
(define (implementation-name) "ikarus")
(define (eval-in-interaction-environment form)
(eval form (interaction-environment)))
)
(import (only (ikarus) load))
(load "swank-r6rs.scm")
(import (swank))
(start-server #f)
--- /project/slime/cvsroot/slime/contrib/swank-larceny.scm 2009/06/23 18:11:14 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-larceny.scm 2009/06/23 18:11:14 1.1
;; swank-larceny.scm --- Swank server for Larceny
;;
;; License: Public Domain
;; Author: Helmut Eller
;;
;; In a shell execute:
;; larceny -r6rs -program swank-larceny.scm
;; and then `M-x slime-connect' in Emacs.
(library (swank os)
(export getpid make-server-socket accept local-port close-socket)
(import (rnrs)
(primitives foreign-procedure
ffi/handle->address
ffi/string->asciiz
sizeof:pointer
sizeof:int
%set-pointer
%get-int))
(define getpid (foreign-procedure "getpid" '() 'int))
(define fork (foreign-procedure "fork" '() 'int))
(define close (foreign-procedure "close" '(int) 'int))
(define dup2 (foreign-procedure "dup2" '(int int) 'int))
(define bytevector-content-offset$ sizeof:pointer)
(define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
(define (execvp file . args)
(let* ((nargs (length args))
(argv (make-bytevector (* (+ nargs 1)
sizeof:pointer))))
(do ((offset 0 (+ offset sizeof:pointer))
(as args (cdr as)))
((null? as))
(%set-pointer argv
offset
(+ (ffi/handle->address (ffi/string->asciiz (car as)))
bytevector-content-offset$)))
(%set-pointer argv (* nargs sizeof:pointer) 0)
(execvp% file argv)))
(define pipe% (foreign-procedure "pipe" '(boxed) 'int))
(define (pipe)
(let ((array (make-bytevector (* sizeof:int 2))))
(let ((r (pipe% array)))
(values r (%get-int array 0) (%get-int array sizeof:int)))))
(define (fork/exec file . args)
(let ((pid (fork)))
(cond ((= pid 0)
(apply execvp file args))
(#t pid))))
(define (start-process file . args)
(let-values (((r1 down-out down-in) (pipe))
((r2 up-out up-in) (pipe))
((r3 err-out err-in) (pipe)))
(assert (= 0 r1))
(assert (= 0 r2))
(assert (= 0 r3))
(let ((pid (fork)))
(case pid
((-1)
(error "Failed to fork a subprocess."))
((0)
(close up-out)
(close err-out)
(close down-in)
(dup2 down-out 0)
(dup2 up-in 1)
(dup2 err-in 2)
(apply execvp file args)
(exit 1))
(else
(close down-out)
(close up-in)
(close err-in)
(list pid
(make-fd-io-stream up-out down-in)
(make-fd-io-stream err-out err-out)))))))
(define (make-fd-io-stream in out)
(let ((write (lambda (bv start count) (fd-write out bv start count)))
(read (lambda (bv start count) (fd-read in bv start count)))
(closeit (lambda () (close in) (close out))))
(make-custom-binary-input/output-port
"fd-stream" read write #f #f closeit)))
(define write% (foreign-procedure "write" '(int ulong int) 'int))
(define (fd-write fd bytevector start count)
(write% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define read% (foreign-procedure "read" '(int ulong int) 'int))
(define (fd-read fd bytevector start count)
;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count)
(read% fd
(+ (ffi/handle->address bytevector)
bytevector-content-offset$
start)
count))
(define (make-server-socket port)
(let* ((args `("/bin/bash" "bash"
"-c"
,(string-append
"netcat -s 127.0.0.1 -q 0 -l -v "
(if port
(string-append "-p " (number->string port))
""))))
(nc (apply start-process args))
(err (transcoded-port (list-ref nc 2)
(make-transcoder (latin-1-codec))))
(line (get-line err))
(pos (last-index-of line '#\])))
(cond (pos
(let* ((tail (substring line (+ pos 1) (string-length line)))
(port (get-datum (open-string-input-port tail))))
(list (car nc) (cadr nc) err port)))
(#t (error "netcat failed: " line)))))
(define (accept socket codec)
(let* ((line (get-line (caddr socket)))
(pos (last-index-of line #\])))
(cond (pos
(close-port (caddr socket))
(let ((stream (cadr socket)))
(let ((io (transcoded-port stream (make-transcoder codec))))
(values io io))))
(else (error "accept failed: " line)))))
(define (local-port socket)
(list-ref socket 3))
(define (last-index-of str chr)
(let loop ((i (string-length str)))
(cond ((<= i 0) #f)
(#t (let ((i (- i 1)))
(cond ((char=? (string-ref str i) chr)
i)
(#t
(loop i))))))))
(define (close-socket socket)
;;(close-port (cadr socket))
#f
)
)
(library (swank sys)
(export implementation-name eval-in-interaction-environment)
(import (rnrs)
(primitives system-features
aeryn-evaluator))
(define (implementation-name) "larceny")
;; see $LARCENY/r6rsmode.sch:
;; Larceny's ERR5RS and R6RS modes.
;; Code names:
;; Aeryn ERR5RS
;; D'Argo R6RS-compatible
;; Spanky R6RS-conforming (not yet implemented)
(define (eval-in-interaction-environment form)
(aeryn-evaluator form))
)
(import (rnrs) (rnrs eval) (larceny load))
(load "swank-r6rs.scm")
(eval '(start-server #f) (environment '(swank)))
--- /project/slime/cvsroot/slime/contrib/swank-r6rs.scm 2009/06/23 18:11:14 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-r6rs.scm 2009/06/23 18:11:14 1.1
;; 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)
[288 lines skipped]
More information about the slime-cvs
mailing list