995 lines
No EOL
30 KiB
Text
995 lines
No EOL
30 KiB
Text
;;;; 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)
|
||
((,@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))
|
||
((,@_) (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 ,@body)
|
||
`(set (elt slimefuns ',name)
|
||
(df ,(cat-sym 'swank@ name) ,args ,@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 ,@args)
|
||
(match (map as-sym (split (sym-name op) #\:))
|
||
((swank ,name)
|
||
`((slimefun ',name) ,@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-and-catch-tags (frame-idx)
|
||
(def frame (nth-frame frame-idx))
|
||
(list
|
||
(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 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 (frame-idx)
|
||
(match (nth-frame frame-idx)
|
||
((,f ,@_)
|
||
(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 ,@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 ,@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 ,@_) (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>))
|
||
(dp! @object (<inspector> => <any>))
|
||
(dp! @parts (<inspector> => <vec>) (new <vec>))
|
||
(dp! @stack (<inspector> => <lst>) '())
|
||
|
||
(dv inspector #f)
|
||
|
||
(defslimefun init-inspector (form|<str>)
|
||
(reset-inspector)
|
||
(inspect-object (str-eval form (buffer-module))))
|
||
|
||
(defslimefun quit-inspector () (reset-inspector) 'nil)
|
||
|
||
(defslimefun inspect-nth-part (n|<int>)
|
||
(inspect-object (elt (@parts inspector) n)))
|
||
|
||
(defslimefun inspector-pop ()
|
||
(cond ((<= 2 (len (@stack inspector)))
|
||
(popf (@stack inspector))
|
||
(inspect-object (popf (@stack inspector))))
|
||
(#t 'nil)))
|
||
|
||
(df reset-inspector () (set inspector (new <inspector>)))
|
||
|
||
(df inspect-object (o)
|
||
(set (@object inspector) o)
|
||
(set (@parts inspector) (new <vec>))
|
||
(pushf (@stack inspector) o)
|
||
(lst ':title (safe-write-to-string o) ; ':type (class-name-str o)
|
||
':content (inspector-content
|
||
`("class: " (:value ,(class-of o)) "\n"
|
||
,@(inspect o)))))
|
||
|
||
(df inspector-content (content)
|
||
(map (fun (part)
|
||
(case-by part isa?
|
||
((<str>) part)
|
||
((<lst>)
|
||
(match part
|
||
((:value ,o ,@str)
|
||
`(:value ,@(if (nul? str)
|
||
(lst (safe-write-to-string o))
|
||
str)
|
||
,(assign-index o)))))
|
||
(#t (error "Bad inspector content: %=" part))))
|
||
content))
|
||
|
||
(df assign-index (o)
|
||
(pushf (@parts inspector) o)
|
||
(1- (len (@parts inspector))))
|
||
|
||
(dg inspect (o))
|
||
|
||
;; a list of dangerous functions
|
||
(d. getter-blacklist (lst fun-code fun-env class-row))
|
||
|
||
(dm inspect (o)
|
||
(join (map (fun (p)
|
||
(let ((getter (prop-getter p)))
|
||
`(,(sym-name (fun-name getter)) ": "
|
||
,(cond ((mem? getter-blacklist getter) "<...>")
|
||
((not (prop-bound? o getter)) "<unbound>")
|
||
(#t (try-or (fun () `(:value ,(getter o)))
|
||
"<...>"))))))
|
||
(class-props (class-of o)))
|
||
'("\n")))
|
||
|
||
(dm inspect (o|<seq>)
|
||
(join (packing (do-keyed (fun (pos val)
|
||
(pack `(,(num-to-str pos) ": " (:value ,val))))
|
||
o))
|
||
'("\n")))
|
||
|
||
(dm inspect (o|<tab>)
|
||
(join (packing (do-keyed (fun (key val)
|
||
(pack `((:value ,key) "\t: " (:value ,val))))
|
||
o))
|
||
'("\n")))
|
||
|
||
;; inspecting the env of closures is broken
|
||
;; (dm inspect (o|<met>)
|
||
;; (cat (sup o)
|
||
;; '("\n")
|
||
;; (if (%fun-env? o)
|
||
;; (inspect (packing (for ((i (below (%fun-env-len o))))
|
||
;; (pack (%fun-env-elt o i)))))
|
||
;; '())))
|
||
;;
|
||
;; (df %fun-env? (f|<met> => <log>) #eb{ FUNENV($f) != $#f })
|
||
;; (df %fun-env-len (f|<met> => <int>) #ei{ ((ENV)FUNENV ($f))->size })
|
||
;; (df %fun-env-elt (f|<met> i|<int> => <any>) #eg{ FUNENVGET($f, @i) })
|
||
|
||
|
||
;;;; init
|
||
|
||
(defslimefun connection-info ()
|
||
`(:pid
|
||
,(process-id) :style nil
|
||
:lisp-implementation (:type "GOO" :name "goo"
|
||
:version ,(%lookup '*goo-version* 'eval/main))
|
||
:machine (:instance "" :type "" :version "")
|
||
:features ()
|
||
:package (:name "goo/user" :prompt "goo/user")))
|
||
|
||
(defslimefun quit-lisp () #ei{ exit (0),0 })
|
||
|
||
(defslimefun set-default-directory (dir|<str>) #ei{ chdir(@dir) } dir)
|
||
|
||
|
||
;;;; eval
|
||
|
||
(defslimefun ping () "PONG")
|
||
|
||
(defslimefun create-repl (_)
|
||
(let ((name (sym-name (module-name (buffer-module)))))
|
||
`(,name ,name)))
|
||
|
||
(defslimefun listener-eval (string)
|
||
(clear-input in)
|
||
`(:values ,(write-to-string (str-eval string (buffer-module)))))
|
||
|
||
(defslimefun interactive-eval (string)
|
||
(cat "=> " (write-to-string (str-eval string (buffer-module)))))
|
||
|
||
(df str-eval (s|<str> m|<module>)
|
||
(eval (read-from-string s) (module-name m)))
|
||
|
||
(df clear-input (in|<in-port>) (while (ready? in) (get in)))
|
||
|
||
(dc <break> (<restart>))
|
||
|
||
(defslimefun simple-break ()
|
||
(simple-restart
|
||
<break> "Continue from break"
|
||
(fun () (sig (new <simple-condition>
|
||
condition-message "Interrupt from Emacs"))))
|
||
'nil)
|
||
|
||
(defslimefun clear-repl-results () 'nil)
|
||
|
||
|
||
;;;; compile
|
||
|
||
(defslimefun compile-string-for-emacs (string buffer position directory)
|
||
(def start (current-time))
|
||
(def r (g2c-eval (read-from-string string)
|
||
(module-target-environment (buffer-module))))
|
||
(lst (write-to-string r)
|
||
(/ (as <flo> (- (current-time) start)) 1000000.0)))
|
||
|
||
(defslimefun compiler-notes-for-emacs () 'nil)
|
||
|
||
(defslimefun filename-to-modulename (filename|<str> => (t+ <str> <nil>))
|
||
(try-or (fun () (sym-name (filename-to-modulename filename))) 'nil))
|
||
|
||
(df filename-to-modulename (filename|<str> => <sym>)
|
||
(def paths (map pathname-to-components
|
||
(map simplify-filename
|
||
(pick file-exists? *module-search-path*))))
|
||
(def filename (pathname-to-components filename))
|
||
(def moddir (rep parent ((modpath filename))
|
||
(cond ((any? (curry = modpath) paths)
|
||
modpath)
|
||
(#t
|
||
(parent (components-parent-directory modpath))))))
|
||
(def modfile (components-to-pathname (sub* filename (len moddir))))
|
||
(as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*)))))
|
||
|
||
|
||
|
||
;;;; Load
|
||
|
||
(defslimefun load-file (filename)
|
||
(let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename)
|
||
(#t (cat filename ".goo")))))
|
||
(safe-write-to-string (load-file file (filename-to-modulename file)))))
|
||
|
||
|
||
;;;; background activities
|
||
|
||
(defslimefun operator-arglist (op _)
|
||
(try-or (fun ()
|
||
(let ((value (str-eval op (buffer-module))))
|
||
(if (isa? value <fun>)
|
||
(write-to-string value)
|
||
'nil)))
|
||
'nil))
|
||
|
||
|
||
;;;; M-.
|
||
|
||
(defslimefun find-definitions-for-emacs (name|<str>)
|
||
(match (parse-symbol name)
|
||
((,sym ,modname)
|
||
(def env (module-target-environment (runtime-module modname)))
|
||
(def b (find-binding sym env))
|
||
(cond (b (find-binding-definitions b))
|
||
(#t 'nil)))))
|
||
|
||
(df parse-symbol (name|<str> => <lst>)
|
||
(if (mem? name #\:)
|
||
(match (split name #\:)
|
||
((,module ,name) (lst (as-sym name) (as-sym module))))
|
||
(lst (as-sym name) (module-name (buffer-module)))))
|
||
|
||
(df find-binding-definitions (b|<binding>)
|
||
(def value (case (binding-kind b)
|
||
(('runtime) (loc-val (binding-locative b)))
|
||
(('global) (let ((box (binding-global-box b)))
|
||
(and box (global-box-value box))))
|
||
(('macro) (binding-info b))
|
||
(#t (error "unknown binding kind %=" (binding-kind b)))))
|
||
(map (fun (o)
|
||
(def loc (emacs-src-loc o))
|
||
`(,(write-to-string (dspec o))
|
||
,(or loc `(:error "no src-loc available"))))
|
||
(defining-objects value)))
|
||
|
||
(dm defining-objects (o => <lst>) '())
|
||
(dm defining-objects (o|<fun> => <lst>) (lst o))
|
||
(dm defining-objects (o|<gen> => <lst>) (pair o (fun-mets o)))
|
||
|
||
(dm emacs-src-loc (o|<fun>)
|
||
(def loc (fun-src-loc o))
|
||
(and loc `(:location (:file ,(simplify-filename
|
||
(find-goo-file-in-path
|
||
(module-name-to-relpath (src-loc-file loc))
|
||
*module-search-path*)))
|
||
(:line ,(src-loc-line loc))
|
||
())))
|
||
|
||
(dm dspec (f|<fun>)
|
||
(cond ((fun-name f)
|
||
`(,(if (isa? f <gen>) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f)))
|
||
(#t f)))
|
||
|
||
(df dspec-arglist (f|<fun>)
|
||
(map2 (fun (name class)
|
||
(cond ((= class <any>) name)
|
||
((isa? class <class>)
|
||
`(,name ,(class-name class)))
|
||
(#t `(,name ,class))))
|
||
(fun-info-names (fun-info f))
|
||
(sig-specs (fun-sig f))))
|
||
|
||
(defslimefun buffer-first-change (filename) 'nil)
|
||
|
||
|
||
;;;; apropos
|
||
|
||
(defslimefun apropos-list-for-emacs
|
||
(pattern only-external? case-sensitive? package)
|
||
(def matches (fab <tab> 100))
|
||
(do-all-bindings
|
||
(fun (b)
|
||
(when (finds (binding-name-str b) pattern)
|
||
(set (elt matches
|
||
(cat-sym (binding-name b)
|
||
(module-name (binding-module b))))
|
||
b))))
|
||
(set matches (sort-by (packing-as <vec> (for ((b matches)) (pack b)))
|
||
(fun (x y)
|
||
(< (binding-name x)
|
||
(binding-name y)))))
|
||
(map (fun (b)
|
||
`(:designator
|
||
,(cat (sym-name (module-name (binding-module b))) ":"
|
||
(binding-name-str b)
|
||
"\tkind: " (sym-name (binding-kind b)))))
|
||
(as <lst> matches)))
|
||
|
||
(df do-all-bindings (f|<fun>)
|
||
(for ((module (%module-loader-modules (runtime-module-loader))))
|
||
(do f (environment-bindings (module-target-environment module)))))
|
||
|
||
(dm < (s1|<str> s2|<str> => <log>)
|
||
(let ((l1 (len s1)) (l2 (len s2)))
|
||
(rep loop ((i 0))
|
||
(cond ((= i l1) (~= l1 l2))
|
||
((= i l2) #f)
|
||
((< (elt s1 i) (elt s2 i)) #t)
|
||
((= (elt s1 i) (elt s2 i)) (loop (1+ i)))
|
||
(#t #f)))))
|
||
|
||
(df %binding-info (name|<sym> module|<sym>)
|
||
(binding-info
|
||
(find-binding
|
||
name (module-target-environment (runtime-module module)))))
|
||
|
||
|
||
;;;; completion
|
||
|
||
(defslimefun simple-completions (pattern|<str> package)
|
||
(def matches (lst))
|
||
(for ((b (environment-bindings (module-target-environment (buffer-module)))))
|
||
(when (prefix? (binding-name-str b) pattern)
|
||
(pushf matches b)))
|
||
(def strings (map binding-name-str matches))
|
||
`(,strings ,(cond ((nul? strings) pattern)
|
||
(#t (fold+ common-prefix strings)))))
|
||
|
||
(df common-prefix (s1|<seq> s2|<seq>)
|
||
(let ((limit (min (len s1) (len s2))))
|
||
(rep loop ((i 0))
|
||
(cond ((or (= i limit)
|
||
(~= (elt s1 i) (elt s2 i)))
|
||
(sub s1 0 i))
|
||
(#t (loop (1+ i)))))))
|
||
|
||
(defslimefun list-all-package-names (_|...)
|
||
(map sym-name (keys (all-modules))))
|
||
|
||
(df all-modules () (%module-loader-modules (runtime-module-loader)))
|
||
|
||
|
||
;;;; Macroexpand
|
||
|
||
(defslimefun swank-macroexpand-1 (str|<str>)
|
||
(write-to-string
|
||
(%ast-macro-expand (read-from-string str)
|
||
(module-target-environment (buffer-module))
|
||
#f)))
|
||
|
||
|
||
;;;; streams
|
||
|
||
(dc <slime-out-port> (<out-port>))
|
||
(dp @socket (<slime-out-port> => <port>))
|
||
(dp! @buf-len (<slime-out-port> => <int>) 0)
|
||
(dp @buf (<slime-out-port> => <vec>) (new <vec>))
|
||
(dp! @timestamp (<slime-out-port> => <int>) 0)
|
||
|
||
(dm recurring-write (port|<out-port> x|<slime-out-port> d|<int> recur|<fun>)
|
||
(msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x)))
|
||
|
||
(dm put (p|<slime-out-port> c|<chr>)
|
||
(add! (@buf p) c)
|
||
(incf (@buf-len p))
|
||
(maybe-flush p (= c #\newline)))
|
||
|
||
(dm puts (p|<slime-out-port> s|<str>)
|
||
(add! (@buf p) s)
|
||
(incf (@buf-len p) (len s))
|
||
(maybe-flush p (mem? s #\newline)))
|
||
|
||
(df maybe-flush (p|<slime-out-port> newline?|<log>)
|
||
(and (or (> (@buf-len p) 4000) newline?)
|
||
(> (- (current-time) (@timestamp p)) 100000)
|
||
(force-out p)))
|
||
|
||
(dm force-out (p|<slime-out-port>)
|
||
(unless (zero? (@buf-len p))
|
||
(dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p))
|
||
(set (@buf-len p) 0)
|
||
(zap! (@buf p)))
|
||
(set (@timestamp p) (current-time)))
|
||
|
||
(df %buf-to-str (buf|<vec>)
|
||
(packing-as <str>
|
||
(for ((i buf))
|
||
(cond ((isa? i <str>) (for ((c i)) (pack c)))
|
||
(#t (pack i))))))
|
||
|
||
(dc <slime-in-port> (<in-port>))
|
||
(dp @socket (<slime-in-port> => <port>))
|
||
(dp! @idx (<slime-in-port> => <int>) 0)
|
||
(dp! @buf (<slime-in-port> => <str>) "")
|
||
|
||
(df receive-input (p|<slime-in-port>)
|
||
(dispatch-event `(:read-string ,0) (@socket p)))
|
||
|
||
(dm get (p|<slime-in-port> => <chr>)
|
||
(cond ((< (@idx p) (len (@buf p)))
|
||
(def c (elt (@buf p) (@idx p)))
|
||
(incf (@idx p))
|
||
c)
|
||
(#t
|
||
(def input (receive-input p))
|
||
(cond ((zero? (len input)) (eof-object))
|
||
(#t (set (@buf p) input)
|
||
(set (@idx p) 0)
|
||
(get p))))))
|
||
|
||
(dm ready? (p|<slime-in-port> => <log>) (< (@idx p) (len (@buf p))))
|
||
|
||
(dm peek (p|<slime-in-port> => <chr>)
|
||
(let ((c (get p)))
|
||
(unless (eof-object? c)
|
||
(decf (@idx p)))
|
||
c))
|
||
|
||
|
||
;;;; Message encoding
|
||
|
||
(df decode-message (port|<in-port>)
|
||
(read-from-string (get-block port (read-message-length port))))
|
||
|
||
(df read-message-length (port)
|
||
(or (str-to-num (cat "#x" (get-block port 6)))
|
||
(error "can't parse message length")))
|
||
|
||
(df encode-message (message port)
|
||
(let ((string (dlet ((*max-print-length* 1000000)
|
||
(*max-print-depth* 1000000))
|
||
(write-to-string message))))
|
||
(puts port (encode-message-length (len string)))
|
||
(puts port string)
|
||
(force-out port)))
|
||
|
||
(df encode-message-length (n)
|
||
(loc ((hex (byte)
|
||
(if (< byte #x10)
|
||
(cat "0" (num-to-str-base byte 16))
|
||
(num-to-str-base byte 16)))
|
||
(byte (i) (hex (& (>> n (* i 8)) 255))))
|
||
(cat (byte 2) (byte 1) (byte 0))))
|
||
|
||
|
||
;;;; semi general utilities
|
||
|
||
;; Return the name of O's class as string.
|
||
(df class-name-str (o => <str>) (sym-name (class-name (class-of o))))
|
||
|
||
(df binding-name-str (b|<binding> => <str>) (sym-name (binding-name b)))
|
||
|
||
(df as-sym (str|<str>) (as <sym> str))
|
||
|
||
;; Replace '//' in the middle of a filename with with a '/'
|
||
(df simplify-filename (str|<str> => <str>)
|
||
(match (pathname-to-components str)
|
||
((,hd ,@tl)
|
||
(components-to-pathname (cons hd (del-vals tl 'root))))))
|
||
|
||
;; Execute BODY and only if BODY exits abnormally execute RECOVER.
|
||
(df try-recover (body recover)
|
||
(let ((ok #f))
|
||
(fin (let ((val (body)))
|
||
(set ok #t)
|
||
val)
|
||
(unless ok
|
||
(recover)))))
|
||
|
||
;; like CL's IGNORE-ERRORS but return VALUE in case of an error.
|
||
(df try-or (body|<fun> value)
|
||
(esc ret
|
||
(try <error> (fun (condition resume) (ret value))
|
||
(body))))
|
||
|
||
(df simple-restart (type msg body)
|
||
(esc restart
|
||
(try ((type type) (description msg))
|
||
(fun (c r) (restart #f))
|
||
(body))))
|
||
|
||
(df safe-write-to-string (o)
|
||
(esc ret
|
||
(try <error> (fun (c r)
|
||
(ret (cat "#<error during write " (class-name-str o) ">")))
|
||
(write-to-string o))))
|
||
|
||
;; Read a string of length COUNT.
|
||
(df get-block (port|<in-port> count|<int> => <str>)
|
||
(packing-as <str>
|
||
(for ((i (below count)))
|
||
(let ((c (get port)))
|
||
(cond ((eof-object? c)
|
||
(error "Premature EOF (read %d of %d)" i count))
|
||
(#t (pack c)))))))
|
||
|
||
|
||
;;;; import some internal bindings
|
||
|
||
(df %lookup (name|<sym> module|<sym>)
|
||
(loc-val
|
||
(binding-locative
|
||
(find-binding
|
||
name (module-target-environment (runtime-module module))))))
|
||
|
||
(d. %handler-info (%lookup 'handler-info 'goo/conditions))
|
||
(d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions))
|
||
(d. %do-handlers-of-type (%lookup 'do-handlers-of-type 'goo/conditions))
|
||
(d. %module-loader-modules (%lookup 'module-loader-modules 'eval/module))
|
||
(d. %ast-macro-expand (%lookup 'ast-macro-expand 'eval/ast))
|
||
|
||
|
||
;;;; low level socket stuff
|
||
;;; this shouldn't be here
|
||
|
||
#{
|
||
#include <sys/types.h>
|
||
#include <sys/socket.h>
|
||
#include <netinet/in.h>
|
||
#include <errno.h>
|
||
#include <string.h>
|
||
#include <stdlib.h>
|
||
#include <sys/time.h>
|
||
|
||
/* convert a goo number to a C long */
|
||
static long g2i (P o) { return untag (o); }
|
||
|
||
static int
|
||
set_reuse_address (int socket, int value) {
|
||
return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value);
|
||
}
|
||
|
||
static int
|
||
bind_socket (int socket, int port) {
|
||
struct sockaddr_in addr;
|
||
addr.sin_family = AF_INET;
|
||
addr.sin_port = htons (port);
|
||
addr.sin_addr.s_addr = htonl (INADDR_ANY);
|
||
return bind (socket, (struct sockaddr *)&addr, sizeof addr);
|
||
}
|
||
|
||
static int
|
||
local_port (int socket) {
|
||
struct sockaddr_in addr;
|
||
socklen_t len = sizeof addr;
|
||
int code = getsockname (socket, (struct sockaddr *)&addr, &len);
|
||
return (code == -1) ? -1 : ntohs (addr.sin_port);
|
||
}
|
||
|
||
static int
|
||
c_accept (int socket) {
|
||
struct sockaddr_in addr;
|
||
socklen_t len = sizeof addr;
|
||
return accept (socket, (struct sockaddr *)&addr, &len);
|
||
}
|
||
|
||
static P tup3 (P e0, P e1, P e2) {
|
||
P tup = YPPtfab ((P)3, YPfalse);
|
||
YPtelt_setter (e0, tup, (P)0);
|
||
YPtelt_setter (e1, tup, (P)1);
|
||
YPtelt_setter (e2, tup, (P)2);
|
||
return tup;
|
||
}
|
||
|
||
static P
|
||
current_time (void) {
|
||
struct timeval timeval;
|
||
int code = gettimeofday (&timeval, NULL);
|
||
if (code == 0) {
|
||
return tup3 (YPib ((P)(timeval.tv_sec >> 24)),
|
||
YPib ((P)(timeval.tv_sec & 0xffffff)),
|
||
YPib ((P)(timeval.tv_usec)));
|
||
} else return YPib ((P)errno);
|
||
}
|
||
}
|
||
|
||
;; Return the current time in microsecs
|
||
(df current-time (=> <int>)
|
||
(def t #eg{ current_time () })
|
||
(cond ((isa? t <int>) (error "%s" (strerror t)))
|
||
(#t (+ (* (+ (<< (1st t) 24)
|
||
(2nd t))
|
||
1000000)
|
||
(3rd t)))))
|
||
|
||
(dm strerror (e|<int> => <str>) #es{ strerror (g2i ($e)) })
|
||
(dm strerror (e|(t= #f) => <str>) #es{ strerror (errno) })
|
||
|
||
(df checkr (value|<int>)
|
||
(cond ((~== value -1) value)
|
||
(#t (error "%s" (strerror #f)))))
|
||
|
||
(df create-socket (port|<int> => <int>)
|
||
(let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) })))
|
||
(checkr #ei{ set_reuse_address (g2i ($socket), 1) })
|
||
(checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) })
|
||
(checkr #ei{ listen (g2i ($socket), 1)})
|
||
socket))
|
||
|
||
(df %local-port (fd|<int>) (checkr #ei{ local_port (g2i ($fd)) }))
|
||
(df %close (fd|<int>) (checkr #ei{ close (g2i ($fd)) }))
|
||
|
||
(dc <fd-io-port> (<in-port> <out-port>))
|
||
(dp @fd (<fd-io-port> => <int>))
|
||
(dp @in (<fd-io-port> => <file-in-port>))
|
||
(dp @out (<fd-io-port> => <file-out-port>))
|
||
|
||
(dm recurring-write (port|<out-port> x|<fd-io-port> d|<int> recur|<fun>)
|
||
(msg port "#{%s fd: %s}" (class-name-str x) (@fd x)))
|
||
|
||
(dm get (port|<fd-io-port> => <chr>) (get (@in port)))
|
||
|
||
(dm puts (port|<fd-io-port> s|<str>) (puts (@out port) s))
|
||
(dm force-out (port|<fd-io-port>) (force-out (@out port)))
|
||
|
||
(dm fdopen (fd|<int> type|(t= <fd-io-port>) => <fd-io-port>)
|
||
(new <fd-io-port> @fd fd
|
||
@in (new <file-in-port> port-handle (%fdopen fd "r"))
|
||
@out (new <file-out-port> port-handle (%fdopen fd "w"))))
|
||
|
||
(df %fdopen (fd|<int> mode|<str> => <loc>)
|
||
(def addr #ei{ fdopen (g2i ($fd), @mode) })
|
||
(when (zero? addr)
|
||
(error "fdopen failed: %s" (strerror #f)))
|
||
(%lb (%iu addr)))
|
||
|
||
(df accept (socket|<int> => <fd-io-port>)
|
||
(fdopen (checkr #ei{ c_accept (g2i ($socket)) }) <fd-io-port>))
|
||
|
||
(export
|
||
start-swank
|
||
create-server)
|
||
|
||
;;; swank-goo.goo ends here |