summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm')
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm882
1 files changed, 882 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm
new file mode 100644
index 0000000..98af388
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm
@@ -0,0 +1,882 @@
+;;; 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->ascii #\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)
+ (or (name->package '(swank))
+ (name->package '(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
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-05 17:28:17 +0000