dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/swank-goo.goo

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