[slime-cvs] CVS slime/contrib
heller
heller at common-lisp.net
Sat Jan 19 14:08:28 UTC 2008
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv20851
Modified Files:
ChangeLog
Added Files:
swank-goo.goo swank-kawa.scm
Log Message:
swank-goo.goo: New file.
swank-kawa.scm: New file.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/01/11 13:06:45 1.78
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/01/19 14:08:27 1.79
@@ -1,3 +1,8 @@
+2008-01-19 Helmut Eller <heller at common-lisp.net>
+
+ * swank-goo.goo: New file.
+ * swank-kawa.scm: New file.
+
2008-01-11 Stelian Ionescu <sionescu at common-lisp.net>
* slime-presentations.el
--- /project/slime/cvsroot/slime/contrib/swank-goo.goo 2008/01/19 14:08:28 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-goo.goo 2008/01/19 14:08:28 1.1
;;;; swank-goo.goo --- Swank server for GOO
;;;
;;; Copyright (C) 2005 Helmut Eller
;;;
;;; This file is licensed under the terms of the GNU General Public
;;; License as distributed with Emacs (press C-h C-c to view it).
;;;; Installation
;;
;; 1. Add something like this to your .emacs:
;;
;; (setq slime-lisp-implementations
;; '((goo ("g2c") :init goo-slime-init)))
;;
;; (defun goo-slime-init (file _)
;; (format "%S\n%S\n"
;; `(set goo/system:*module-search-path*
;; (cat '(".../slime/contrib/")
;; goo/system:*module-search-path*))
;; `(swank-goo:start-swank ,file)))
;;
;; 2. Start everything with M-- M-x slime goo
;;
;;;; Code
(use goo)
(use goo/boot)
(use goo/x)
(use goo/io/port)
(use goo/io/write)
(use goo/eval)
(use goo/system)
(use goo/conditions)
(use goo/fun)
(use goo/loc)
(use goo/chr)
(use eval/module)
(use eval/ast)
(use eval/g2c)
;;;; server setup
(df create-server (port-number) (setup-server port-number announce-port))
(df start-swank (port-file)
(setup-server 0 (fun (s) (write-port-file (%local-port s) port-file))))
(df setup-server (port-number announce)
(let ((s (create-socket port-number)))
(fin (seq
(announce s)
(let ((c (accept s)))
;;(post "connection: %s" c)
(fin (serve-requests c)
(%close (@fd c)))))
(post "closing socket: %s" s)
(%close s))))
(df announce-port (socket)
(post "Listening on port: %d\n" (%local-port socket)))
(df write-port-file (port-number filename)
(with-port (file (open <file-out-port> filename))
(msg file "%d\n" port-number)))
(dc <slime-toplevel> (<restart>))
(dc <connection> (<any>))
(dp @socket (<connection> => <port>))
(dp @in (<connection> => <in-port>))
(dp @out (<connection> => <out-port>))
(dv emacs-connection|(t? <connection>) #f)
(df serve-requests (socket)
(dlet ((emacs-connection (new <connection>
@socket socket
@out (new <slime-out-port> @socket socket)
@in (new <slime-in-port> @socket socket))))
(dlet ((out (@out emacs-connection))
(in (@in emacs-connection)))
(while #t
(simple-restart
<slime-toplevel> "SLIME top-level"
(fun () (process-next-event socket)))))))
(d. <nil> (t= 'nil))
(d. t #t)
(d. cons pair)
(dv tag-counter|<int> 0)
(df process-next-event (port) (dispatch-event (decode-message port) port))
(df dispatch-event (event port)
;; (post "%=\n" event)
(match event
((:emacs-rex ,form ,package ,_thread-id ,id)
(eval-for-emacs form package port id))
((:read-string ,_)
(def tag (incf tag-counter))
(encode-message `(:read-string ,_ ,tag) port)
(rep loop ()
(match (decode-message port)
((:emacs-return-string ,_ ,rtag ,str)
(assert (= tag rtag) "Unexpected reply tag: %d" rtag)
str)
((, at evt)
(try-recover
(fun () (dispatch-event evt port))
(fun () (encode-message `(:read-aborted ,_ ,tag) port)))
(loop)))))
((:emacs-return-string ,_ ,rtag ,str)
(error "Unexpected event: %=" event))
((, at _) (encode-message event port))))
(dc <eval-context> (<any>))
(dp @module (<eval-context> => <module>))
(dp @id (<eval-context> => <int>))
(dp @port (<eval-context> => <port>))
(dp @prev (<eval-context> => (t? <eval-context>)))
;; should be ddv
(dv eval-context|(t? <eval-context>) #f)
(df buffer-module () (@module eval-context))
(df eval-for-emacs (form|<lst> package|(t+ <str> <nil>) port id|<int>)
(try-recover
(fun ()
(try <condition> debugger-hook
(dlet ((eval-context (new <eval-context>
@module (find-buffer-module package) @id id
@port port @prev eval-context)))
(def result (eval (frob-form-for-eval form) 'swank-goo))
(force-out out)
(dispatch-event `(:return (:ok ,result) ,id) port))))
(fun () (dispatch-event `(:return (:abort) ,id) port))))
(dm find-buffer-module (name|<str> => <module>)
(or (elt-or (all-modules) (as-sym name) #f)
(find-buffer-module 'nil)))
(dm find-buffer-module (name|<nil> => <module>) default-module)
(dv default-module|<module> (runtime-module 'goo/user))
(d. slimefuns (fab <tab> 100))
(ds defslimefun (,name ,args , at body)
`(set (elt slimefuns ',name)
(df ,(cat-sym 'swank@ name) ,args , at body)))
(df slimefun (name)
(or (elt-or slimefuns name #f)
(error "Undefined slimefun: %=" name)))
;; rewrite (swank:foo ...) to ((slimefun 'foo) ...)
(df frob-form-for-eval (form)
(match form
((,op , at args)
(match (map as-sym (split (sym-name op) #\:))
((swank ,name)
`((slimefun ',name) , at args))))))
;;;; debugger
(dc <sldb-context> (<any>))
(dp @level (<sldb-context> => <int>))
(dp @top-frame (<sldb-context> => <lst>))
(dp @restarts (<sldb-context> => <lst>))
(dp @condition (<sldb-context> => <condition>))
(dp @eval-context (<sldb-context> => (t? <eval-context>)))
(dv sldb-context|(t? <sldb-context>) #f)
(df debugger-hook (c|<condition> resume)
(let ((tf (find-top-frame 'debugger-hook 2))
(rs (compute-restarts c))
(l (if sldb-context (1+ (@level sldb-context)) 1)))
(cond ((> l 10) (emergency-abort c))
(#t
(dlet ((sldb-context (new <sldb-context>
@level l @top-frame tf
@restarts rs @condition c
@eval-context eval-context)))
(let ((bt (compute-backtrace tf 0 10)))
(force-out out)
(dispatch-event `(:debug 0 ,l
,@(debugger-info c rs bt eval-context))
(@port eval-context))
(sldb-loop l (@port eval-context))))))))
(df emergency-abort (c)
(post "Maximum debug level reached aborting...\n")
(post "%s\n" (describe-condition c))
(do-stack-frames (fun (f args) (msg out " %= %=\n" f args)))
(invoke-handler-interactively (find-restart <slime-toplevel>) in out))
(df sldb-loop (level port)
(fin (while #t
(dispatch-event `(:debug-activate 0 ,level) port)
(simple-restart
<restart> (msg-to-str "Return to SLDB level %s" level)
(fun () (process-next-event port))))
(dispatch-event `(:debug-return 0 ,level nil) port)))
(defslimefun backtrace (start|<int> end|(t+ <int> <nil>))
(backtrace-for-emacs
(compute-backtrace (@top-frame sldb-context)
start
(if (isa? end <int>) end #f))))
(defslimefun throw-to-toplevel ()
(invoke-handler-interactively (find-restart <slime-toplevel>) in out))
(defslimefun invoke-nth-restart-for-emacs (sldb-level|<int> n|<int>)
(when (= (@level sldb-context) sldb-level)
(invoke-handler-interactively (elt (@restarts sldb-context) n) in out)))
(defslimefun debugger-info-for-emacs (start end)
(debugger-info (@condition sldb-context)
(@restarts sldb-context)
(compute-backtrace (@top-frame sldb-context)
start
(if (isa? end <int>) end #f))))
(defslimefun frame-locals-for-emacs (frame-idx)
(def frame (nth-frame frame-idx))
(map-keyed (fun (i name)
(lst ':name (sym-name name) ':id 0
':value (safe-write-to-string (frame-var-value frame i))))
(frame-var-names frame)))
(defslimefun frame-catch-tags-for-emacs (frame-idx) '())
(defslimefun inspect-frame-var (frame-idx var-idx)
(reset-inspector)
(inspect-object (frame-var-value (nth-frame frame-idx) var-idx)))
(defslimefun inspect-current-condition ()
(reset-inspector)
(inspect-object (@condition sldb-context)))
(defslimefun frame-source-location-for-emacs (frame-idx)
(match (nth-frame frame-idx)
((,f , at _)
(or (emacs-src-loc f)
`(:error ,(msg-to-str "No src-loc available for: %s" f))))))
(defslimefun eval-string-in-frame (string frame-idx)
(def frame (nth-frame frame-idx))
(let ((names (frame-var-names frame))
(values (frame-var-values frame)))
(write-to-string
(app (eval `(fun ,names ,(read-from-string string))
(module-name (buffer-module)))
values))))
(df debugger-info (condition restarts backtrace eval-context)
(lst `(,(try-or (fun () (describe-condition condition)) "<...>")
,(cat " [class: " (class-name-str condition) "]")
())
(restarts-for-emacs restarts)
(backtrace-for-emacs backtrace)
(pending-continuations eval-context)))
(df backtrace-for-emacs (backtrace)
(map (fun (f)
(match f
((,idx (,f , at args))
(lst idx (cat (if (fun-name f)
(sym-name (fun-name f))
(safe-write-to-string f))
(safe-write-to-string args))))))
backtrace))
(df restarts-for-emacs (restarts)
(map (fun (x) `(,(sym-name (class-name (%handler-condition-type x)))
,(describe-restart x)))
restarts))
(df describe-restart (restart)
(describe-handler (%handler-info restart) (%handler-condition-type restart)))
(df compute-restarts (condition)
(packing (%do-handlers-of-type <restart> (fun (c) (pack c)))))
(df find-restart (type)
(esc ret
(%do-handlers-of-type type ret)
#f))
(df pending-continuations (context|(t? <eval-context>))
(if context
(pair (@id context) (pending-continuations (@prev context)))
'()))
(df find-top-frame (fname|<sym> offset|<int>)
(esc ret
(let ((top-seen? #f))
(do-stack-frames (fun (f args)
(cond (top-seen?
(cond ((== offset 0)
(ret (pair f args)))
(#t (decf offset))))
((== (fun-name f) fname)
(set top-seen? #t))))))))
(df compute-backtrace (top-frame start|<int> end)
(packing
(esc break
(do-user-frames (fun (idx f args)
(when (and end (<= end idx))
(break #f))
(when (<= start idx)
(pack (lst idx (pair f args)))))
top-frame))))
(df nth-frame (n|<int>)
(esc ret
(do-user-frames
(fun (idx f args)
(when (= idx n)
(ret (pair f args))))
(@top-frame sldb-context))))
(df frame-var-value (frame var-idx)
(match frame
((,f , at args)
(def sig (fun-sig f))
(def arity (sig-arity sig))
(def nary? (sig-nary? sig))
(cond ((< var-idx arity) (elt args var-idx))
(nary? (sub* args arity))))))
(df frame-var-names (frame)
(match frame
((,f , at _) (fun-info-names (fun-info f)))))
(df frame-var-values (frame)
(map (curry frame-var-value frame) (keys (frame-var-names frame))))
(df do-user-frames (f|<fun> top-frame)
(let ((idx -1)
(top-seen? #f))
(do-stack-frames
(fun (ffun args)
(cond (top-seen?
(incf idx)
(f idx ffun (rev args)))
((= (pair ffun args) top-frame)
(set top-seen? #t)))))))
;;;; Write some classes a little less verbose
;; (dm recurring-write (port|<out-port> x d|<int> recur|<fun>)
;; (msg port "#{%s &%s}" (class-name-str x)
;; (num-to-str-base (address-of x) 16)))
(dm recurring-write (port|<out-port> x|<module> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (module-name x)))
(dm recurring-write (port|<out-port> x|<module-binding> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (binding-name x)))
(dm recurring-write (port|<out-port> x|<tab> d|<int> recur|<fun>)
(msg port "#{%s %s}" (class-name-str x) (len x)))
(dm recurring-write (port|<out-port> x|<static-global-environment>
d|<int> recur|<fun>)
(msg port "#{%s}" (class-name-str x)))
(dm recurring-write (port|<out-port> x|<regular-application>
d|<int> recur|<fun>)
(msg port "#{%s}" (class-name-str x)))
(dm recurring-write (port|<out-port> x|<src-loc> d|<int> recur|<fun>)
(msg port "#{%s %s:%=}" (class-name-str x)
(src-loc-file x) (src-loc-line x)))
;;;; Inspector
(dc <inspector> (<any>))
[602 lines skipped]
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/01/19 14:08:28 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/01/19 14:08:28 1.1
[2466 lines skipped]
More information about the slime-cvs
mailing list