883 lines
26 KiB
Scheme
883 lines
26 KiB
Scheme
;;; 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 9.2
|
||
|
||
2. The Emacs side needs some fiddling. 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
|
||
'(create-package-from-description
|
||
(make-package-description '(swank) (list (list))
|
||
(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)
|
||
(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
|
||
|
||
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)
|
||
|
||
;; Modified for Slimv:
|
||
;; - load options
|
||
;; - remove extension in compile-file-for-emacs
|
||
(load-option 'format)
|
||
(load-option 'sos)
|
||
|
||
(if (< (car (get-subsystem-version "Release"))
|
||
'9)
|
||
(error "This file requires MIT Scheme Release 9"))
|
||
|
||
(define (swank port)
|
||
(accept-connections (or port 4005) #f))
|
||
|
||
;; ### hardcoded port number for now. netcat-openbsd doesn't print
|
||
;; the listener port anymore.
|
||
(define (start-swank port-file)
|
||
(accept-connections 4055 port-file)
|
||
)
|
||
|
||
;;;; Networking
|
||
|
||
(define (accept-connections port port-file)
|
||
(let ((sock (open-tcp-server-socket port (host-address-loopback))))
|
||
(format #t "Listening on port: ~s~%" port)
|
||
(if port-file (write-port-file port port-file))
|
||
(dynamic-wind
|
||
(lambda () #f)
|
||
(lambda () (serve (tcp-server-connection-accept sock #t #f)))
|
||
(lambda () (close-tcp-server-socket sock)))))
|
||
|
||
(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->integer #\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)
|
||
(if (name->package '(swank))
|
||
'(swank)
|
||
'(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))))
|
||
|
||
;; quote keywords
|
||
(define (hack-quotes list)
|
||
(map (lambda (x)
|
||
(cond ((symbol? x) `(quote ,x))
|
||
(#t x)))
|
||
list))
|
||
|
||
(define (emacs-rex socket level sexp package thread id)
|
||
(let ((ok? #f) (result #f) (condition #f))
|
||
(dynamic-wind
|
||
(lambda () #f)
|
||
(lambda ()
|
||
(bind-condition-handler
|
||
(list condition-type:serious-condition)
|
||
(lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
|
||
(lambda ()
|
||
(fluid-let ((*buffer-package* package))
|
||
(set! result
|
||
(eval (cons* (car sexp) socket (hack-quotes (cdr sexp)))
|
||
swank-env))
|
||
(set! ok? #t)))))
|
||
(lambda ()
|
||
(write-packet `(:return
|
||
,(if ok? `(:ok ,result)
|
||
`(:abort
|
||
,(if condition
|
||
(format #f "~a"
|
||
(condition/type condition))
|
||
"<unknown reason>")))
|
||
,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"))
|
||
:encoding (:coding-systems ("iso-8859-1"))
|
||
)))
|
||
|
||
(define (swank:quit-lisp _)
|
||
(%exit))
|
||
|
||
|
||
;;;; Evaluation
|
||
|
||
(define (swank-repl: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))
|
||
|
||
(define (swank-repl:create-repl socket . _)
|
||
(let* ((env (user-env #f))
|
||
(name (format #f "~a" (package/name (environment->package env)))))
|
||
(list name name)))
|
||
|
||
|
||
;;;; Compilation
|
||
|
||
(define (swank:compile-string-for-emacs _ string . x)
|
||
(apply
|
||
(lambda (errors seconds)
|
||
`(:compilation-result ,errors t ,seconds nil nil))
|
||
(call-compiler
|
||
(lambda ()
|
||
(let* ((sexps (snarf-string string))
|
||
(env (user-env *buffer-package*))
|
||
(scode (syntax `(begin ,@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 (internal-time/ticks->seconds time))))
|
||
|
||
(define (swank:compiler-notes-for-emacs _) nil)
|
||
|
||
(define (swank:compile-file-for-emacs socket file load?)
|
||
(apply
|
||
(lambda (errors seconds)
|
||
(list ':compilation-result errors 't seconds load?
|
||
(->namestring (pathname-name file))))
|
||
(call-compiler
|
||
(lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
|
||
|
||
(define (swank:load-file socket file)
|
||
(with-output-to-repl socket
|
||
(lambda ()
|
||
(pprint-to-string
|
||
(load file (user-env *buffer-package*))))))
|
||
|
||
(define (swank:disassemble-form _ string)
|
||
(let ((sexp (let ((sexp (read-from-string string)))
|
||
(cond ((and (pair? sexp) (eq? (car sexp) 'quote))
|
||
(cadr sexp))
|
||
(#t sexp)))))
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(compiler:disassemble
|
||
(eval sexp (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*))))))
|
||
|
||
|
||
;;;; Macroexpansion
|
||
|
||
(define (swank:swank-macroexpand-all _ string)
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(pp (syntax (read-from-string string)
|
||
(user-env *buffer-package*))))))
|
||
(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
|
||
(define swank:swank-macroexpand swank:swank-macroexpand-all)
|
||
|
||
|
||
;;; Arglist
|
||
|
||
(define (swank:operator-arglist socket name pack)
|
||
(let ((v (ignore-errors
|
||
(lambda ()
|
||
(string-trim-right
|
||
(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:filename-to-modulename . _) nil)
|
||
(define (swank:swank-require . _) nil)
|
||
|
||
;; M-. is beyond my capabilities.
|
||
(define (swank:find-definitions-for-emacs . _) nil)
|
||
|
||
|
||
;;; Debugger
|
||
|
||
(define-structure (sldb-state (conc-name sldb-state.)) condition restarts)
|
||
|
||
(define *sldb-state* #f)
|
||
(define (invoke-sldb socket level condition)
|
||
(fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts))))
|
||
(dynamic-wind
|
||
(lambda () #f)
|
||
(lambda ()
|
||
(write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20))
|
||
socket)
|
||
(sldb-loop level socket))
|
||
(lambda ()
|
||
(write-packet `(:debug-return 0 ,level nil) socket)))))
|
||
|
||
(define (sldb-loop level socket)
|
||
(write-packet `(:debug-activate 0 ,level) socket)
|
||
(with-simple-restart
|
||
'abort (format #f "Return to SLDB level ~a." level)
|
||
(lambda () (dispatch (read-packet socket) socket level)))
|
||
(sldb-loop level socket))
|
||
|
||
(define (sldb-info state start end)
|
||
(let ((c (sldb-state.condition state))
|
||
(rs (sldb-state.restarts state)))
|
||
(list (list (condition/report-string c)
|
||
(format #f " [~a]" (%condition-type/name (condition/type c)))
|
||
nil)
|
||
(sldb-restarts rs)
|
||
(sldb-backtrace c start end)
|
||
;;'((0 "dummy frame"))
|
||
'())))
|
||
|
||
(define %condition-type/name
|
||
(eval '%condition-type/name (->environment '(runtime error-handler))))
|
||
|
||
(define (sldb-restarts restarts)
|
||
(map (lambda (r)
|
||
(list (symbol->string (restart/name r))
|
||
(with-string-output-port
|
||
(lambda (p) (write-restart-report r p)))))
|
||
restarts))
|
||
|
||
(define (swank:throw-to-toplevel . _)
|
||
(invoke-restart *top-level-restart*))
|
||
|
||
(define (swank:sldb-abort . _)
|
||
(abort (sldb-state.restarts *sldb-state*)))
|
||
|
||
(define (swank:sldb-continue . _)
|
||
(continue (sldb-state.restarts *sldb-state*)))
|
||
|
||
(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n)
|
||
(invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n)))
|
||
|
||
(define (swank:debugger-info-for-emacs _ from to)
|
||
(sldb-info *sldb-state* from to))
|
||
|
||
(define (swank:backtrace _ from to)
|
||
(sldb-backtrace (sldb-state.condition *sldb-state*) from to))
|
||
|
||
(define (sldb-backtrace condition from to)
|
||
(sldb-backtrace-aux (condition/continuation condition) from to))
|
||
|
||
(define (sldb-backtrace-aux k from to)
|
||
(let ((l (map frame>string (substream (continuation>frames k) from to))))
|
||
(let loop ((i from) (l l))
|
||
(if (null? l)
|
||
'()
|
||
(cons (list i (car l)) (loop (1+ i) (cdr l)))))))
|
||
|
||
;; Stack parser fails for this:
|
||
;; (map (lambda (x) x) "/tmp/x.x")
|
||
|
||
(define (continuation>frames k)
|
||
(let loop ((frame (continuation->stack-frame k)))
|
||
(cond ((not frame) (stream))
|
||
(else
|
||
(let ((next (ignore-errors
|
||
(lambda () (stack-frame/next-subproblem frame)))))
|
||
(cons-stream frame
|
||
(if (condition? next)
|
||
(stream next)
|
||
(loop next))))))))
|
||
|
||
(define (frame>string frame)
|
||
(if (condition? frame)
|
||
(format #f "Bogus frame: ~a ~a" frame
|
||
(condition/report-string frame))
|
||
(with-string-output-port (lambda (p) (print-frame frame p)))))
|
||
|
||
(define (print-frame frame port)
|
||
(define (invalid-subexpression? subexpression)
|
||
(or (debugging-info/undefined-expression? subexpression)
|
||
(debugging-info/unknown-expression? subexpression)))
|
||
(define (invalid-expression? expression)
|
||
(or (debugging-info/undefined-expression? expression)
|
||
(debugging-info/compiled-code? expression)))
|
||
(with-values (lambda () (stack-frame/debugging-info frame))
|
||
(lambda (expression environment subexpression)
|
||
(cond ((debugging-info/compiled-code? expression)
|
||
(write-string ";unknown compiled code" port))
|
||
((not (debugging-info/undefined-expression? expression))
|
||
(fluid-let ((*unparse-primitives-by-name?* #t))
|
||
(write
|
||
(unsyntax (if (invalid-subexpression? subexpression)
|
||
expression
|
||
subexpression))
|
||
port)))
|
||
((debugging-info/noise? expression)
|
||
(write-string ";" port)
|
||
(write-string ((debugging-info/noise expression) #f)
|
||
port))
|
||
(else
|
||
(write-string ";undefined expression" port))))))
|
||
|
||
(define (substream s from to)
|
||
(let loop ((i 0) (l '()) (s s))
|
||
(cond ((or (= i to) (stream-null? s)) (reverse l))
|
||
((< i from) (loop (1+ i) l (stream-cdr s)))
|
||
(else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s))))))
|
||
|
||
(define (swank:frame-locals-and-catch-tags _ frame)
|
||
(list (map frame-var>elisp (frame-vars (sldb-get-frame frame)))
|
||
'()))
|
||
|
||
(define (frame-vars frame)
|
||
(with-values (lambda () (stack-frame/debugging-info frame))
|
||
(lambda (expression environment subexpression)
|
||
(cond ((environment? environment)
|
||
(environment>frame-vars environment))
|
||
(else '())))))
|
||
|
||
(define (environment>frame-vars environment)
|
||
(let loop ((e environment))
|
||
(cond ((environment->package e) '())
|
||
(else (append (environment-bindings e)
|
||
(if (environment-has-parent? e)
|
||
(loop (environment-parent e))
|
||
'()))))))
|
||
|
||
(define (frame-var>elisp b)
|
||
(list ':name (write-to-string (car b))
|
||
':value (cond ((null? (cdr b)) "{unavailable}")
|
||
(else (>line (cadr b))))
|
||
':id 0))
|
||
|
||
(define (sldb-get-frame index)
|
||
(stream-ref (continuation>frames
|
||
(condition/continuation
|
||
(sldb-state.condition *sldb-state*)))
|
||
index))
|
||
|
||
(define (frame-var-value frame var)
|
||
(let ((binding (list-ref (frame-vars frame) var)))
|
||
(cond ((cdr binding) (cadr binding))
|
||
(else unspecific))))
|
||
|
||
(define (swank:inspect-frame-var _ frame var)
|
||
(reset-inspector)
|
||
(inspect-object (frame-var-value (sldb-get-frame frame) var)))
|
||
|
||
|
||
;;;; Completion
|
||
|
||
(define (swank:simple-completions _ string package)
|
||
(let ((strings (all-completions string (user-env package) string-prefix?)))
|
||
(list (sort strings string<?)
|
||
(longest-common-prefix strings))))
|
||
|
||
(define (all-completions pattern env match?)
|
||
(let ((ss (map %symbol->string (environment-names env))))
|
||
(keep-matching-items ss (lambda (s) (match? pattern s)))))
|
||
|
||
;; symbol->string is too slow
|
||
(define %symbol->string symbol-name)
|
||
|
||
(define (environment-names env)
|
||
(append (environment-bound-names env)
|
||
(if (environment-has-parent? env)
|
||
(environment-names (environment-parent env))
|
||
'())))
|
||
|
||
(define (longest-common-prefix strings)
|
||
(define (common-prefix s1 s2)
|
||
(substring s1 0 (string-match-forward s1 s2)))
|
||
(reduce common-prefix "" strings))
|
||
|
||
|
||
;;;; Apropos
|
||
|
||
(define (swank:apropos-list-for-emacs _ name #!optional
|
||
external-only case-sensitive package)
|
||
(let* ((pkg (and (string? package)
|
||
(find-package (read-from-string package))))
|
||
(parent (and (not (default-object? external-only))
|
||
(elisp-false? external-only)))
|
||
(ss (append-map (lambda (p)
|
||
(map (lambda (s) (cons p s))
|
||
(apropos-list name p (and pkg parent))))
|
||
(if pkg (list pkg) (all-packages))))
|
||
(ss (sublist ss 0 (min (length ss) 200))))
|
||
(map (lambda (e)
|
||
(let ((p (car e)) (s (cdr e)))
|
||
(list ':designator (format #f "~a ~a" s (package/name p))
|
||
':variable (>line
|
||
(ignore-errors
|
||
(lambda () (package-lookup p s)))))))
|
||
ss)))
|
||
|
||
(define (swank:list-all-package-names . _)
|
||
(map (lambda (p) (write-to-string (package/name p)))
|
||
(all-packages)))
|
||
|
||
(define (all-packages)
|
||
(define (package-and-children package)
|
||
(append (list package)
|
||
(append-map package-and-children (package/children package))))
|
||
(package-and-children system-global-package))
|
||
|
||
|
||
;;;; Inspector
|
||
|
||
(define-structure (inspector-state (conc-name istate.))
|
||
object parts next previous content)
|
||
|
||
(define istate #f)
|
||
|
||
(define (reset-inspector)
|
||
(set! istate #f))
|
||
|
||
(define (swank:init-inspector _ string)
|
||
(reset-inspector)
|
||
(inspect-object (eval (read-from-string string)
|
||
(user-env *buffer-package*))))
|
||
|
||
(define (inspect-object o)
|
||
(let ((previous istate)
|
||
(content (inspect o))
|
||
(parts (make-eqv-hash-table)))
|
||
(set! istate (make-inspector-state o parts #f previous content))
|
||
(if previous (set-istate.next! previous istate))
|
||
(istate>elisp istate)))
|
||
|
||
(define (istate>elisp istate)
|
||
(list ':title (>line (istate.object istate))
|
||
':id (assign-index (istate.object istate) (istate.parts istate))
|
||
':content (prepare-range (istate.parts istate)
|
||
(istate.content istate)
|
||
0 500)))
|
||
|
||
(define (assign-index o parts)
|
||
(let ((i (hash-table/count parts)))
|
||
(hash-table/put! parts i o)
|
||
i))
|
||
|
||
(define (prepare-range parts content from to)
|
||
(let* ((cs (substream content from to))
|
||
(ps (prepare-parts cs parts)))
|
||
(list ps
|
||
(if (< (length cs) (- to from))
|
||
(+ from (length cs))
|
||
(+ to 1000))
|
||
from to)))
|
||
|
||
(define (prepare-parts ps parts)
|
||
(define (line label value)
|
||
`(,(format #f "~a: " label)
|
||
(:value ,(>line value) ,(assign-index value parts))
|
||
"\n"))
|
||
(append-map (lambda (p)
|
||
(cond ((string? p) (list p))
|
||
((symbol? p) (list (symbol->string p)))
|
||
(#t
|
||
(case (car p)
|
||
((line) (apply line (cdr p)))
|
||
(else (error "Invalid part:" p))))))
|
||
ps))
|
||
|
||
(define (swank:inspect-nth-part _ index)
|
||
(inspect-object (hash-table/get (istate.parts istate) index 'no-such-part)))
|
||
|
||
(define (swank:quit-inspector _)
|
||
(reset-inspector))
|
||
|
||
(define (swank:inspector-pop _)
|
||
(cond ((istate.previous istate)
|
||
(set! istate (istate.previous istate))
|
||
(istate>elisp istate))
|
||
(else 'nil)))
|
||
|
||
(define (swank:inspector-next _)
|
||
(cond ((istate.next istate)
|
||
(set! istate (istate.next istate))
|
||
(istate>elisp istate))
|
||
(else 'nil)))
|
||
|
||
(define (swank:inspector-range _ from to)
|
||
(prepare-range (istate.parts istate)
|
||
(istate.content istate)
|
||
from to))
|
||
|
||
(define-syntax stream*
|
||
(syntax-rules ()
|
||
((stream* tail) tail)
|
||
((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...)))))
|
||
|
||
(define (iline label value) `(line ,label ,value))
|
||
|
||
(define-generic inspect (o))
|
||
|
||
(define-method inspect ((o <object>))
|
||
(cond ((environment? o) (inspect-environment o))
|
||
((vector? o) (inspect-vector o))
|
||
((procedure? o) (inspect-procedure o))
|
||
((compiled-code-block? o) (inspect-code-block o))
|
||
;;((system-pair? o) (inspect-system-pair o))
|
||
((probably-scode? o) (inspect-scode o))
|
||
(else (inspect-fallback o))))
|
||
|
||
(define (inspect-fallback o)
|
||
(let* ((class (object-class o))
|
||
(slots (class-slots class)))
|
||
(stream*
|
||
(iline "Class" class)
|
||
(let loop ((slots slots))
|
||
(cond ((null? slots) (stream))
|
||
(else
|
||
(let ((n (slot-name (car slots))))
|
||
(stream* (iline n (slot-value o n))
|
||
(loop (cdr slots))))))))))
|
||
|
||
(define-method inspect ((o <pair>))
|
||
(if (or (pair? (cdr o)) (null? (cdr o)))
|
||
(inspect-list o)
|
||
(inspect-cons o)))
|
||
|
||
(define (inspect-cons o)
|
||
(stream (iline "car" (car o))
|
||
(iline "cdr" (cdr o))))
|
||
|
||
(define (inspect-list o)
|
||
(let loop ((i 0) (o o))
|
||
(cond ((null? o) (stream))
|
||
((or (pair? (cdr o)) (null? (cdr o)))
|
||
(stream* (iline i (car o))
|
||
(loop (1+ i) (cdr o))))
|
||
(else
|
||
(stream (iline i (car o))
|
||
(iline "tail" (cdr o)))))))
|
||
|
||
(define (inspect-environment o)
|
||
(stream*
|
||
(iline "(package)" (environment->package o))
|
||
(let loop ((bs (environment-bindings o)))
|
||
(cond ((null? bs)
|
||
(if (environment-has-parent? o)
|
||
(stream (iline "(<parent>)" (environment-parent o)))
|
||
(stream)))
|
||
(else
|
||
(let* ((b (car bs)) (s (car b)))
|
||
(cond ((null? (cdr b))
|
||
(stream* s " {" (environment-reference-type o s) "}\n"
|
||
(loop (cdr bs))))
|
||
(else
|
||
(stream* (iline s (cadr b))
|
||
(loop (cdr bs)))))))))))
|
||
|
||
(define (inspect-vector o)
|
||
(let ((len (vector-length o)))
|
||
(let loop ((i 0))
|
||
(cond ((= i len) (stream))
|
||
(else (stream* (iline i (vector-ref o i))
|
||
(loop (1+ i))))))))
|
||
|
||
(define (inspect-procedure o)
|
||
(cond ((primitive-procedure? o)
|
||
(stream (iline "name" (primitive-procedure-name o))
|
||
(iline "arity" (primitive-procedure-arity o))
|
||
(iline "doc" (primitive-procedure-documentation o))))
|
||
((compound-procedure? o)
|
||
(stream (iline "arity" (procedure-arity o))
|
||
(iline "lambda" (procedure-lambda o))
|
||
(iline "env" (ignore-errors
|
||
(lambda () (procedure-environment o))))))
|
||
(else
|
||
(stream
|
||
(iline "block" (compiled-entry/block o))
|
||
(with-output-to-string (lambda () (compiler:disassemble o)))))))
|
||
|
||
(define (inspect-code-block o)
|
||
(stream-append
|
||
(let loop ((i (compiled-code-block/constants-start o)))
|
||
(cond ((>= i (compiled-code-block/constants-end o)) (stream))
|
||
(else
|
||
(stream*
|
||
(iline i (system-vector-ref o i))
|
||
(loop (+ i compiled-code-block/bytes-per-object))))))
|
||
(stream (iline "debuginfo" (compiled-code-block/debugging-info o))
|
||
(iline "env" (compiled-code-block/environment o))
|
||
(with-output-to-string (lambda () (compiler:disassemble o))))))
|
||
|
||
(define (inspect-scode o)
|
||
(stream (pprint-to-string o)))
|
||
|
||
(define (probably-scode? o)
|
||
(define tests (list access? assignment? combination? comment?
|
||
conditional? definition? delay? disjunction? lambda?
|
||
quotation? sequence? the-environment? variable?))
|
||
(let loop ((tests tests))
|
||
(cond ((null? tests) #f)
|
||
(((car tests) o))
|
||
(else (loop (cdr tests))))))
|
||
|
||
(define (inspect-system-pair o)
|
||
(stream (iline "car" (system-pair-car o))
|
||
(iline "cdr" (system-pair-cdr o))))
|
||
|
||
|
||
;;;; Auxilary functions
|
||
|
||
(define nil '())
|
||
(define t 't)
|
||
(define (elisp-false? o) (member o '(nil ())))
|
||
(define (elisp-true? o) (not (elisp-false? o)))
|
||
(define (>line o)
|
||
(let ((r (write-to-string o 100)))
|
||
(cond ((not (car r)) (cdr r))
|
||
(else (string-append (cdr r) " ..")))))
|
||
;; Must compile >line otherwise we can't write unassigend-reference-traps.
|
||
(set! >line (compile-procedure >line))
|
||
(define (read-from-string s) (with-input-from-string s read))
|
||
(define (pprint-to-string o)
|
||
(with-string-output-port
|
||
(lambda (p)
|
||
(fluid-let ((*unparser-list-breadth-limit* 10)
|
||
(*unparser-list-depth-limit* 4)
|
||
(*unparser-string-length-limit* 100))
|
||
(pp o p)))))
|
||
;(define (1+ n) (+ n 1))
|
||
(define (1- n) (- n 1))
|
||
(define (package-lookup package name)
|
||
(let ((p (if (package? package) package (find-package package))))
|
||
(environment-lookup (package/environment p) name)))
|
||
(define log-port (current-output-port))
|
||
(define (log-event fstring . args)
|
||
;;(apply format log-port fstring args)
|
||
#f
|
||
)
|
||
|
||
;; Modified for Slimv:
|
||
;; - restart swank server in a loop
|
||
(let loop ()
|
||
(swank 4005)
|
||
(loop))
|
||
|
||
;;; swank-mit-scheme.scm ends here
|