;;;; 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