;;; swank-jolt.k --- Swank server for Jolt -*- goo -*-
;;
;; Copyright (C) 2008 Helmut Eller
;;
;; This file is licensed under the terms of the GNU General Public
;; License as distributed with Emacs (press C-h C-c for details).
;;; Commentary:
;;
;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of
;; C, i.e. most objects are machine words and memory pointers. The
;; standard boot files define an interface to Id Smalltalk. So we can
;; also pretend to do OOP, but we must be careful to pass properly
;; tagged pointers to Smalltalk.
;;
;; This file only implements a minimum of SLIME's functionality. We
;; install a handler with atexit(3) to invoke the debugger. This way
;; we can stop Jolt from terminating the process on every error.
;; Unfortunately, the backtrace doesn't contain much information and
;; we also have no error message (other than the exit code). Jolt
;; usually prints some message to stdout before calling exit, so you
;; have to look in the *inferior-lisp* buffer for hints. We do
;; nothing (yet) to recover from SIGSEGV.
;;; Installation
;;
;; 1. Download and build cola. See <http://piumarta.com/software/cola/>.
;; I used the svn version:
;; svn co http://piumarta.com/svn2/idst/trunk idst
;; 2. Add something like this to your .emacs:
;;
;; (add-to-list 'slime-lisp-implementations
;; '(jolt (".../idst/function/jolt-burg/main"
;; "boot.k" ".../swank-jolt.k" "-") ; note the "-"
;; :init jolt-slime-init
;; :init-function slime-redirect-inferior-output)
;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file)))
;; (defun jolt () (interactive) (slime 'jolt))
;;
;; 3. Use `M-x jolt' to start it.
;;
;;; Code
;; In this file I use 2-3 letters for often used names, like DF or
;; VEC, even if those names are abbreviations. I think that after a
;; little getting used to, this style is just as readable as the more
;; traditional DEFUN and VECTOR. Shorter names make it easier to
;; write terse code, in particular 1-line definitions.
;; `df' is like `defun' in a traditional lisp
(syntax df
(lambda (form compiler)
(printf "df %s ...\n" [[[form second] asString] _stringValue])
`(define ,[form second] (lambda ,@[form copyFrom: '2]))))
;; (! args ...) is the same as [args ...] but easier to edit.
(syntax !
(lambda (form compiler)
(cond ((== [form size] '3)
(if [[form third] isSymbol]
`(send ',[form third] ,[form second])
[compiler errorSyntax: [form third]]))
((and [[form size] > '3]
(== [[form size] \\ '2] '0))
(let ((args [OrderedCollection new])
(keys [OrderedCollection new])
(i '2) (len [form size]))
(while (< i len)
(let ((key [form at: i]))
(if (or [key isKeyword]
(and (== i '2) [key isSymbol])) ; for [X + Y]
[keys addLast: [key asString]]
[compiler errorSyntax: key]))
[args addLast: [form at: [i + '1]]]
(set i [i + '2]))
`(send ',[[keys concatenated] asSymbol] ,[form second] ,@args)))
(1 [compiler errorArgumentCount: form]))))
(define Integer (import "Integer"))
(define Symbol (import "Symbol")) ;; aka. _selector
(define StaticBlockClosure (import "StaticBlockClosure"))
(define BlockClosure (import "BlockClosure"))
(define SequenceableCollection (import "SequenceableCollection"))
(define _vtable (import "_vtable"))
(define ByteArray (import "ByteArray"))
(define CodeGenerator (import "CodeGenerator"))
(define TheGlobalEnvironment (import "TheGlobalEnvironment"))
(df error (msg) (! Object error: msg))
(df print-to-string (obj)
(let ((len '200)
(stream (! WriteStream on: (! String new: len))))
(! stream print: obj)
(! stream contents)))
(df assertion-failed (exp)
(error (! '"Assertion failed: " , (print-to-string exp))))
(syntax assert
(lambda (form)
`(if (not ,(! form second))
(assertion-failed ',(! form second)))))
(df isa? (obj type) (! obj isKindOf: type))
(df equal (o1 o2) (! o1 = o2))
(define nil 0)
(define false 0)
(define true (! Object notNil))
(df bool? (obj) (or (== obj false) (== obj true)))
(df int? (obj) (isa? obj Integer))
;; In this file the convention X>Y is used for operations that convert
;; X-to-Y. And _ means "machine word". So _>int is the operator that
;; converts a machine word to an Integer.
(df _>int (word) (! Integer value_: word))
(df int>_ (i) (! i _integerValue))
;; Fixnum operators. Manual tagging/untagging would probably be more
;; efficent than invoking methods.
(df fix? (obj) (& obj 1))
(df _>fix (n) (! SmallInteger value_: n))
(df fix>_ (i) (! i _integerValue))
(df fx+ (fx1 fx2) (! fx1 + fx2))
(df fx* (fx1 fx2) (! fx1 * fx2))
(df fx1+ (fx) (! fx + '1))
(df fx1- (fx) (! fx - '1))
(df str? (obj) (isa? obj String))
(df >str (o) (! o asString))
(df str>_ (s) (! s _stringValue))
(df _>str (s) (! String value_: s))
(df sym? (obj) (isa? obj Symbol))
(df seq? (obj) (isa? obj SequenceableCollection))
(df array? (obj) (isa? obj Array))
(df len (obj) (! obj size))
(df len_ (obj) (! (! obj size) _integerValue))
(df ref (obj idx) (! obj at: idx))
(df set-ref (obj idx elt) (! obj at: idx put: elt))
(df first (obj) (! obj first))
(df second (obj) (! obj second))
(df puts (string stream) (! stream nextPutAll: string))
(define _GC_base (dlsym "GC_base"))
;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows
;; such things. This is useful for debugging, because we can quite
;; safely (i.e. without provoking SIGSEGV) access such addresses.
(df valid-pointer? (addr)
(let ((ptr (& addr (~ 1))))
(and (_GC_base ptr)
(_GC_base (long@ ptr -1)))))
;; Print OBJ as a Lisp printer would do.
(df prin1 (obj stream)
(cond ((fix? obj) (! stream print: obj))
((== obj nil) (puts '"nil" stream))
((== obj false) (puts '"#f" stream))
((== obj true) (puts '"#t" stream))
((not (valid-pointer? obj))
(begin (puts '"#<w " stream)
(prin1 (_>int obj) stream)
(puts '">" stream)))
((int? obj) (! stream print: obj))
((sym? obj) (puts (>str obj) stream))
((isa? obj StaticBlockClosure)
(begin (puts '"#<fun /" stream)
(! stream print: (! obj arity))
(puts '"#>" stream)))
((and (str? obj) (len obj))
(! obj printEscapedOn: stream delimited: (ref '"\"" '0)))
((and (array? obj) (len obj))
(begin (puts '"(" stream)
(let ((max (- (len_ obj) 1)))
(for (i 0 1 max)
(prin1 (ref obj (_>fix i)) stream)
(if (!= i max)
(puts '" " stream))))
(puts '")" stream)))
((and (isa? obj OrderedCollection) (len obj))
(begin (puts '"#[" stream)
(let ((max (- (len_ obj) 1)))
(for (i 0 1 max)
(prin1 (ref obj (_>fix i)) stream)
(if (!= i max)
(puts '" " stream))))
(puts '"]" stream)))
(true
(begin (puts '"#<" stream)
(puts (! obj debugName) stream)
(puts '">" stream))))
obj)
(df print (obj)
(prin1 obj StdOut)
(puts '"\n" StdOut))
(df prin1-to-string (obj)
(let ((len '100)
(stream (! WriteStream on: (! String new: len))))
(prin1 obj stream)
(! stream contents)))
;;(df %vable-tally (_vtable) (long@ _vtable))
(df cr () (printf "\n"))
(df print-object-selectors (obj)
(let ((vtable (! obj _vtable))
(tally (long@ vtable 0))
(bindings (long@ vtable 1)))
(for (i 1 1 tally)
(print (long@ (long@ bindings i)))
(cr))))
(df print-object-slots (obj)
(let ((size (! obj _sizeof))
(end (+ obj size)))
(while (< obj end)
(print (long@ obj))
(cr)
(incr obj 4))))
(df intern (string) (! Symbol intern: string))
;; Jolt doesn't seem to have an equivalent for gensym, but it's damn
;; hard to write macros without it. So here we adopt the conventions
;; that symbols which look like ".[0-9]+" are reserved for gensym and
;; shouldn't be used for "user visible variables".
(define gensym-counter 0)
(df gensym ()
(set gensym-counter (+ gensym-counter 1))
(intern (! '"." , (>str (_>fix gensym-counter)))))
;; Surprisingly, SequenceableCollection doesn't have a indexOf method.
;; So we even need to implement such mundane things.
(df index-of (seq elt)
(let ((max (len seq))
(i '0))
(while (! i < max)
(if (equal (ref seq i) elt)
(return i)
(set i (! i + '1))))
nil))
(df find-dot (array) (index-of array '.))
;; What followes is the implementation of the pattern matching macro MIF.
;; The syntax is (mif (PATTERN EXP) THEN ELSE).
;; The THEN-branch is executed if PATTERN matches the value produced by EXP.
;; ELSE gets only executed if the match failes.
;; A pattern can be
;; 1) a symbol, which matches all values, but also binds the variable to the
;; value
;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL.
;; 3) (PS ...) matches sequences, if the elements match PS.
;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements
;; at indices 1..n and if Ptail matches the rest
;; of the sequence
;; Examples:
;; (mif (x 10) x 'else) => 10
;; (mif ('a 'a) 'then 'else) => then
;; (mif ('a 'b) 'then 'else) => else
;; (mif ((a b) '(1 2)) b 'else) => 2
;; (mif ((a . b) '(1 2)) b 'else) => '(2)
;; (mif ((. x) '(1 2)) x 'else) => '(1 2)
(define mif% 0) ;; defer
(df mif%array (compiler pattern i value then fail)
;;(print `(mif%array ,pattern ,i ,value))
(cond ((== i (len_ pattern)) then)
((== (ref pattern (_>fix i)) '.)
(begin
(if (!= (- (len_ pattern) 2) i)
(begin
(print pattern)
(! compiler error: (! '"dot in strange position: "
, (>str (_>fix i))))))
(mif% compiler
(ref pattern (_>fix (+ i 1)))
`(! ,value copyFrom: ',(_>fix i))
then fail)))
(true
(mif% compiler
(ref pattern (_>fix i))
`(ref ,value ',(_>fix i))
(mif%array compiler pattern (+ i 1) value then fail)
fail))))
(df mif% (compiler pattern value then fail)
;;(print `(mif% ,pattern ,value ,then))
(cond ((== pattern '_) then)
((== pattern '.) (! compiler errorSyntax: pattern))
((sym? pattern)
`(let ((,pattern ,value)) ,then))
((seq? pattern)
(cond ((== (len_ pattern) 0)
`(if (== (len_ ,value) 0) ,then (goto ,fail)))
((== (first pattern) 'quote)
(begin
(if (not (== (len_ pattern) 2))
(! compiler errorSyntax: pattern))
`(if (equal ,value ,pattern) ,then (goto ,fail))))
(true
(let ((tmp (gensym)) (tmp2 (gensym))
(pos (find-dot pattern)))
`(let ((,tmp2 ,value)
(,tmp ,tmp2))
(if (and (seq? ,tmp)
,(if (find-dot pattern)
`(>= (len ,tmp)
',(_>fix (- (len_ pattern) 2)))
`(== (len ,tmp) ',(len pattern))))
,(mif%array compiler pattern 0 tmp then fail)
(goto ,fail)))))))
(true (! compiler errorSyntax: pattern))))
(syntax mif
(lambda (node compiler)
;;(print `(mif ,node))
(if (not (or (== (len_ node) 4)
(== (len_ node) 3)))
(! compiler errorArgumentCount: node))
(if (not (and (array? (ref node '1))
(== (len_ (ref node '1)) 2)))
(! compiler errorSyntax: (ref node '1)))
(let ((pattern (first (ref node '1)))
(value (second (ref node '1)))
(then (ref node '2))
(else (if (== (len_ node) 4)
(ref node '3)
`(error "mif failed")))
(destination (gensym))
(fail (! compiler newLabel))
(success (! compiler newLabel)))
`(let ((,destination 0))
,(mif% compiler pattern value
`(begin (set ,destination ,then)
(goto ,success))
fail)
(label ,fail)
(set ,destination ,else)
(label ,success)
,destination))))
;; (define *catch-stack* nil)
;;
(df bar (o) (mif ('a o) 'yes 'no))
(assert (== (bar 'a) 'yes))
(assert (== (bar 'b) 'no))
(df foo (o) (mif (('a) o) 'yes 'no))
(assert (== (foo '(a)) 'yes))
(assert (== (foo '(b)) 'no))
(df baz (o) (mif (('a 'b) o) 'yes 'no))
(assert (== (baz '(a b)) 'yes))
(assert (== (baz '(a c)) 'no))
(assert (== (baz '(b c)) 'no))
(assert (== (baz 'a) 'no))
(df mifvar (o) (mif (y o) y 'no))
(assert (== (mifvar 'foo) 'foo))
(df mifvec (o) (mif ((y) o) y 'no))
(assert (== (mifvec '(a)) 'a))
(assert (== (mifvec 'x) 'no))
(df mifvec2 (o) (mif (('a y) o) y 'no))
(assert (== (mifvec2 '(a b)) 'b))
(assert (== (mifvec2 '(b c)) 'no))
(assert (== (mif ((x) '(a)) x 'no) 'a))
(assert (== (mif ((x . y) '(a b)) x 'no) 'a))
(assert (== (mif ((x y . z) '(a b)) y 'no) 'b))
(assert (equal (mif ((x . y) '(a b)) y 'no) '(b)))
(assert (equal (mif ((. x) '(a b)) x 'no) '(a b)))
(assert (equal (mif (((. x)) '((a b))) x 'no) '(a b)))
(assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c)))
(assert (== (mif (() '()) 'yes 'no) 'yes))
(assert (== (mif (() '(a)) 'yes 'no) 'no))
;; Now that we have a somewhat convenient pattern matcher we can write
;; a more convenient macro defining macro:
(syntax defmacro
(lambda (node compiler)
(mif (('defmacro name (. args) . body) node)
(begin
(printf "defmacro %s ...\n" (str>_ (>str name)))
`(syntax ,name
(lambda (node compiler)
(mif ((',name ,@args) node)
(begin ,@body)
(! compiler errorSyntax: node)))))
(! compiler errorSyntax: node))))
;; and an even more convenient pattern matcher:
(defmacro mcase (value . clauses)
(let ((tmp (gensym)))
`(let ((,tmp ,value))
,(mif (() clauses)
`(begin (print ,tmp)
(error "mcase failed"))
(mif (((pattern . body) . more) clauses)
`(mif (,pattern ,tmp)
(begin ,@(mif (() body) '(0) body))
(mcase ,tmp ,@more))
(! compiler errorSyntax: clauses))))))
;; and some traditional macros
(defmacro when (test . body) `(if ,test (begin ,@body)))
(defmacro unless (test . body) `(if ,test 0 (begin ,@body)))
(defmacro or (. args) ; the built in OR returns 1 on success.
(mcase args
(() 0)
((e) e)
((e1 . more)
(let ((tmp (gensym)))
`(let ((,tmp ,e1))
(if ,tmp ,tmp (or ,@more)))))))
(defmacro dotimes_ ((var n) . body)
(let ((tmp (gensym)))
`(let ((,tmp ,n)
(,var 0))
(while (< ,var ,tmp)
,@body
(set ,var (+ ,var 1))))))
(defmacro dotimes ((var n) . body)
(let ((tmp (gensym)))
`(let ((,tmp ,n)
(,var '0))
(while (< ,var ,tmp)
,@body
(set ,var (fx1+ ,var))))))
;; DOVEC is like the traditional DOLIST but works on "vectors"
;; i.e. sequences which can be indexed efficently.
(defmacro dovec ((var seq) . body)
(let ((i (gensym))
(max (gensym))
(tmp (gensym)))
`(let ((,i 0)
(,tmp ,seq)
(,max (len_ ,tmp)))
(while (< ,i ,max)
(let ((,var (! ,tmp at: (_>fix ,i))))
,@body
(set ,i (+ ,i 1)))))))
;; "Packing" is what Lispers usually call "collecting".
;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result))
;; translates to (packing (result) .. (pack x result))
(defmacro packing ((var) . body)
`(let ((,var (! OrderedCollection new)))
,@body
(! ,var asArray)))
(df pack (elt packer) (! packer addLast: elt))
(assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p)))
'(0 1)))
(assert (equal (packing (p) (dovec (e '(2 3)) (pack e p)))
'(2 3)))
(assert (equal (packing (p)
(let ((a '(2 3)))
(dotimes (i (len a))
(pack (ref a i) p))))
'(2 3)))
;; MAPCAR (more or less)
(df map (fun col)
(packing (r)
(dovec (e col)
(pack (fun e) r))))
;; VEC allocates and initializes a new array.
;; The macro translates (vec x y z) to `(,x ,y ,z).
(defmacro vec (. args)
`(quasiquote
(,@(map (lambda (arg) `(,'unquote ,arg))
args))))
(assert (equal (vec '0 '1) '(0 1)))
(assert (equal (vec) '()))
(assert (== (len (vec 0 1 2 3 4)) '5))
;; Concatenate.
(defmacro cat (. args) `(! (vec '"" ,@args) concatenated))
(assert (equal (cat '"a" '"b" '"c") '"abc"))
;; Take a vector of bytes and copy the bytes to a continuous
;; block of memory
(df assemble_ (col) (! (! ByteArray withAll: col) _bytes))
;; Jolt doesn't seem to have catch/throw or something equivalent.
;; Here I use a pair of assembly routines as substitue.
;; (catch% FUN) calls FUN with the current stack pointer.
;; (throw% VALUE K) unwinds the stack to K and then returns VALUE.
;; catch% is a bit like call/cc.
;;
;; [Would setjmp/longjmp work from Jolt? or does setjmp require
;; C-compiler magic?]
;; [I figure Smalltalk has a way to do non-local-exits but, I don't know
;; how to use that in Jolt.]
;;
(define catch%
(assemble_
'(0x55 ; push %ebp
0x89 0xe5 ; mov %esp,%ebp
0x54 ; push %esp
0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax
0xff 0xd0 ; call *%eax
0xc9 ; leave
0xc3 ; ret
)))
(define throw%
(assemble_
`(,@'()
0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax
0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp
0xc9 ; leave
0xc3 ; ret
)))
(df bar (i k)
(if (== i 0)
(throw% 100 k)
(begin
(printf "bar %d\n" i)
(bar (- i 1) k))))
(df foo (k)
(printf "foo.1\n")
(printf "foo.2 %d\n" (bar 10 k)))
;; Our way to produce closures: we compile a new little function which
;; hardcodes the addresses of the code resp. the data-vector. The
;; nice thing is that such closures can be used called C function
;; pointers. It's probably slow to invoke the compiler for such
;; things, so use with care.
(df make-closure (addr state)
(int>_
(! `(lambda (a b c d)
(,(_>int addr) ,(_>int state) a b c d))
eval)))
;; Return a closure which calls FUN with ARGS and the arguments
;; that the closure was called with.
;; Example: ((curry printf "%d\n") 10)
(defmacro curry (fun . args)
`(make-closure
(lambda (state a b c d)
((ref state '0)
,@(packing (sv)
(dotimes (i (len args))
(pack `(ref state ',(fx1+ i)) sv)))
a b c d))
(vec ,fun ,@args)))
(df parse-closure-arglist (vars)
(let ((pos (or (index-of vars '|)
(return nil)))
(cvars (! vars copyFrom: '0 to: (fx1- pos)))
(lvars (! vars copyFrom: (fx1+ pos))))
(vec cvars lvars)))
;; Create a closure, to-be-closed-over variables must enumerated
;; explicitly.
;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4.
;; The variables before the "|" are captured by the closure.
(defmacro closure ((. vars) . body)
(mif ((cvars lvars) (parse-closure-arglist vars))
`(curry (lambda (,@cvars ,@lvars) ,@body)
,@cvars)
(! compiler errorSyntax: vars)))
;; The analog for Smalltalkish "blocks".
(defmacro block ((. vars) . body)
(mif ((cvars lvars) (parse-closure-arglist vars))
`(! StaticBlockClosure
function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body)
,@cvars)
arity_: ,(len lvars))
(! compiler errorSyntax: vars)))
(define %mkstemp (dlsym "mkstemp"))
(df make-temp-file ()
(let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy))
(fd (%mkstemp (! name _stringValue))))
(if (== fd -1)
(error "mkstemp failed"))
`(,fd ,name)))
(define %unlink (dlsym "unlink"))
(df unlink (filename) (%unlink (! filename _stringValue)))
(define write (dlsym "write"))
(df write-bytes (addr count fd)
(let ((written (write fd addr count)))
(if (!= written count)
(begin
(printf "write failed %p %d %d => %d" addr count fd written)
(error '"write failed")))))
(define system (dlsym "system"))
(define main (dlsym "main"))
;; Starting at address ADDR, disassemble COUNT bytes.
;; This is implemented by writing the memory region to a file
;; and call ndisasm on it.
(df disas (addr count)
(let ((fd+name (make-temp-file)))
(write-bytes addr count (first fd+name))
(let ((cmd (str>_ (cat '"ndisasm -u -o "
(>str (_>fix addr))
'" " (second fd+name)))))
(printf "Running: %s\n" cmd)
(system cmd))
(unlink (second fd+name))))
(df rep ()
(let ((result (! (! CokeScanner read: StdIn) eval)))
(puts '"=> " StdOut)
(print result)
(puts '"\n" StdOut)))
;; Perhaps we could use setcontext/getcontext to return from signal
;; handlers (or not).
(define +ucontext-size+ 350)
(define _getcontext (dlsym "getcontext"))
(define _setcontext (dlsym "setcontext"))
(df getcontext ()
(let ((context (malloc 350)))
(_getcontext context)
context))
(define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why?
(define *top-level-restart* 0)
(define *top-level-context* 0)
(define *debugger-hook* 0)
;; Jolt's error handling strategy is charmingly simple: call exit.
;; We invoke the SLIME debugger from an exit handler.
;; (The handler is registered with atexit, that's a libc function.)
(df exit-handler (reason arg)
(printf "exit-handler 0x%x\n" reason)
;;(backtrace)
(on_exit exit-handler nil)
(when *debugger-hook*
(*debugger-hook* `(exit ,reason)))
(cond (*top-level-context*
(_setcontext *top-level-context*))
(*top-level-restart*
(throw% reason *top-level-restart*))))
(df repl ()
(set *top-level-context* (getcontext))
(while (not (! (! StdIn readStream) atEnd))
(printf "top-level\n")
(catch%
(lambda (k)
(set *top-level-restart* k)
(printf "repl\n")
(while 1
(rep)))))
(printf "EOF\n"))
;; (repl)
;;; Socket code. (How boring. Duh, should have used netcat instead.)
(define strerror (dlsym "strerror"))
(df check-os-code (value)
(if (== value -1)
(error (_>str (strerror (fix>_ (! OS errno)))))
value))
;; For now just hard-code constants which usually reside in header
;; files (just like a Forth guy would do).
(define PF_INET 2)
(define SOCK_STREAM 1)
(define SOL_SOCKET 1)
(define SO_REUSEADDR 2)
(define socket (dlsym "socket"))
(define setsockopt (dlsym "setsockopt"))
(df set-reuse-address (sock value)
(let ((word-size 4)
(val (! Object _balloc: (_>fix word-size))))
(set-int@ val value)
(check-os-code
(setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size))))
(define sockaddr_in/size 16)
(define sockaddr_in/sin_family 0)
(define sockaddr_in/sin_port 2)
(define sockaddr_in/sin_addr 4)
(define INADDR_ANY 0)
(define AF_INET 2)
(define htons (dlsym "htons"))
(define bind (dlsym "bind"))
(df bind-socket (sock port)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size))))
(set-short@ (+ addr sockaddr_in/sin_family) AF_INET)
(set-short@ (+ addr sockaddr_in/sin_port) (htons port))
(set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY)
(check-os-code
(bind sock addr sockaddr_in/size))))
(define listen (dlsym "listen"))
(df create-socket (port)
(let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0))))
(set-reuse-address sock 1)
(bind-socket sock port)
(check-os-code (listen sock 1))
sock))
(define accept% (dlsym "accept"))
(df accept (sock)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
(len (! OS _balloc: 4)))
(set-int@ len sockaddr_in/size)
(check-os-code (accept% sock addr len))))
(define getsockname (dlsym "getsockname"))
(define ntohs (dlsym "ntohs"))
(df local-port (sock)
(let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
(len (! OS _balloc: 4)))
(set-int@ len sockaddr_in/size)
(check-os-code
(getsockname sock addr len))
(ntohs (short@ (+ addr sockaddr_in/sin_port)))))
(define close (dlsym "close"))
(define _read (dlsym "read"))
;; Now, after 2/3 of the file we can begin with the actual Swank
;; server.
(df read-string (fd count)
(let ((buffer (! String new: count))
(buffer_ (str>_ buffer))
(count_ (int>_ count))
(start 0))
(while (> (- count_ start) 0)
(let ((rcount (check-os-code (_read fd
(+ buffer_ start)
(- count_ start)))))
(set start (+ start rcount))))
buffer))
;; Read and parse a message from the wire.
(df read-packet (fd)
(let ((header (read-string fd '6))
(length (! Integer fromString: header base: '16))
(payload (read-string fd length)))
(! CokeScanner read: payload)))
;; Print a messag to the wire.
(df send-to-emacs (event fd)
(let ((stream (! WriteStream on: (! String new: '100))))
(! stream position: '6)
(prin1 event stream)
(let ((len (! stream position)))
(! stream position: '0)
(! (fx+ len '-6) printOn: stream base: '16 width: '6)
(write-bytes (str>_ (! stream collection)) (int>_ len) fd))))
(df add-quotes (form)
(mcase form
((fun . args)
`(,fun ,@(packing (s)
(dovec (e args)
(pack `(quote ,e) s)))))))
(define sldb 0) ;defer
(df eval-for-emacs (form id fd abort)
(let ((old-hook *debugger-hook*))
(mcase (catch%
(closure (form fd | k)
(set *debugger-hook* (curry sldb fd k))
`(ok ,(int>_ (! (add-quotes form) eval)))))
(('ok value)
(set *debugger-hook* old-hook)
(send-to-emacs `(:return (:ok ,value) ,id) fd)
'ok)
(arg
(set *debugger-hook* old-hook)
(send-to-emacs `(:return (:abort) ,id) fd)
(throw% arg abort)))))
(df process-events (fd)
(on_exit exit-handler nil)
(let ((done nil))
(while (not done)
(mcase (read-packet fd)
((':emacs-rex form package thread id)
(mcase (catch% (closure (form id fd | abort)
(eval-for-emacs form id fd abort)))
('ok)
;;('abort nil)
('top-level)
(other
;;(return other) ; compiler breaks with return
(set done 1))))))))
(df next-frame (fp)
(let ((next (get-caller-fp fp)))
(if (and (!= next fp)
(<= next %top-level-fp))
next
nil)))
(df nth-frame (n top)
(let ((fp top)
(i 0))
(while fp
(if (== i n) (return fp))
(set fp (next-frame fp))
(set i (+ i 1)))
nil))
(define Dl_info/size 16)
(define Dl_info/dli_fname 0)
(define Dl_info/dli_sname 8)
(df get-dl-sym-name (addr)
(let ((info (! OS _balloc: (_>fix Dl_info/size))))
(when (== (dladdr addr info) 0)
(return nil))
(let ((sname (long@ (+ info Dl_info/dli_sname)) )
(fname (long@ (+ info Dl_info/dli_fname))))
(cond ((and sname fname)
(cat (_>str sname) '" in " (_>str fname)))
(sname (_>str fname))
(fname (cat '"<??> " (_>str fname)))
(true nil)))))
;;(get-dl-sym-name printf)
(df guess-function-name (ip)
(let ((fname (get-function-name ip)))
(if fname
(_>str fname)
(get-dl-sym-name ip))))
(df backtrace>el (top_ from_ to_)
(let ((fp (nth-frame from_ top_))
(i from_))
(packing (bt)
(while (and fp (< i to_))
(let ((ip (get-frame-ip fp)))
(pack (vec (_>int i)
(cat (or (guess-function-name ip) '"(no-name)")
'" " ;;(>str (_>int ip))
))
bt))
(set i (+ i 1))
(set fp (next-frame fp))))))
(df debugger-info (fp msg)
(vec `(,(prin1-to-string msg) " [type ...]" ())
'(("quit" "Return to top level"))
(backtrace>el fp 0 20)
'()))
(define *top-frame* 0)
(define *sldb-quit* 0)
(df debugger-loop (fd args abort)
(let ((fp (get-current-fp)))
(set *top-frame* fp)
(send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd)
(while 1
(mcase (read-packet fd)
((':emacs-rex form package thread id)
(mcase (catch% (closure (form id fd | k)
(set *sldb-quit* k)
(eval-for-emacs form id fd k)
'ok))
('ok nil)
(other
(send-to-emacs `(:return (:abort) ,id) fd)
(throw% other abort))))))))
(df sldb (fd abort args)
(let ((old-top-frame *top-frame*)
(old-sldb-quit *sldb-quit*))
(mcase (catch% (curry debugger-loop fd args))
(value
(set *top-frame* old-top-frame)
(set *sldb-quit* old-sldb-quit)
(send-to-emacs `(:debug-return 0 1 nil) fd)
(throw% value abort)))))
(df swank:backtrace (start end)
(backtrace>el *top-frame* (int>_ start) (int>_ end)))
(df sldb-quit ()
(assert *sldb-quit*)
(throw% 'top-level *sldb-quit*))
(df swank:invoke-nth-restart-for-emacs (...) (sldb-quit))
(df swank:throw-to-toplevel (...) (sldb-quit))
(df setup-server (port announce)
(let ((sock (create-socket port)))
(announce sock)
(let ((client (accept sock)))
(process-events client)
(close client))
(printf "Closing socket: %d %d\n" sock (local-port sock))
(close sock)))
(df announce-port (sock)
(printf "Listening on port: %d\n" (local-port sock)))
(df create-server (port) (setup-server port announce-port))
(df write-port-file (filename sock)
(let ((f (! File create: filename)))
(! f write: (print-to-string (_>int (local-port sock))))
(! f close)))
(df start-swank (port-file)
(setup-server 0 (curry write-port-file (_>str port-file))))
(define getpid (dlsym "getpid"))
(df swank:connection-info ()
`(,@'()
:pid ,(_>int (getpid))
:style nil
:lisp-implementation (,@'()
:type "Coke"
:name "jolt"
:version ,(! CodeGenerator versionString))
:machine (:instance "" :type ,(! OS architecture) :version "")
:features ()
:package (:name "jolt" :prompt "jolt")))
(df swank:listener-eval (string)
(let ((result (! (! CokeScanner read: string) eval)))
`(:values ,(prin1-to-string (if (or (fix? result)
(and (valid-pointer? result)
(int? result)))
(int>_ result)
result))
,(prin1-to-string result))))
(df swank:interactive-eval (string)
(let ((result (! (! CokeScanner read: string) eval)))
(cat '"=> " (prin1-to-string (if (or (fix? result)
(and (valid-pointer? result)
(int? result)))
(int>_ result)
result))
'", " (prin1-to-string result))))
(df swank:operator-arglist () nil)
(df swank:buffer-first-change () nil)
(df swank:create-repl (_) '("jolt" "jolt"))
(df min (x y) (if (<= x y) x y))
(df common-prefix2 (e1 e2)
(let ((i '0)
(max (min (len e1) (len e2))))
(while (and (< i max)
(== (ref e1 i) (ref e2 i)))
(set i (fx1+ i)))
(! e1 copyFrom: '0 to: (fx1- i))))
(df common-prefix (seq)
(mcase seq
(() nil)
(_
(let ((prefix (ref seq '0)))
(dovec (e seq)
(set prefix (common-prefix2 prefix e)))
prefix))))
(df swank:simple-completions (prefix _package)
(let ((matches (packing (s)
(dovec (e (! TheGlobalEnvironment keys))
(let ((name (>str e)))
(when (! name beginsWith: prefix)
(pack name s)))))))
(vec matches (or (common-prefix matches) prefix))))
;; swank-jolt.k ends here