/[slime]/slime/contrib/swank-jolt.k
ViewVC logotype

Contents of /slime/contrib/swank-jolt.k

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Tue Jul 21 11:02:42 2009 UTC (4 years, 8 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-2-3, FAIRLY-STABLE, byte-stream, SLIME-2-2, HEAD
Changes since 1.1: +3 -2 lines
* swank-goo.goo, swank-jolt.k (create-repl): Implemented.
1 ;;; swank-jolt.k --- Swank server for Jolt -*- goo -*-
2 ;;
3 ;; Copyright (C) 2008 Helmut Eller
4 ;;
5 ;; This file is licensed under the terms of the GNU General Public
6 ;; License as distributed with Emacs (press C-h C-c for details).
7
8 ;;; Commentary:
9 ;;
10 ;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of
11 ;; C, i.e. most objects are machine words and memory pointers. The
12 ;; standard boot files define an interface to Id Smalltalk. So we can
13 ;; also pretend to do OOP, but we must be careful to pass properly
14 ;; tagged pointers to Smalltalk.
15 ;;
16 ;; This file only implements a minimum of SLIME's functionality. We
17 ;; install a handler with atexit(3) to invoke the debugger. This way
18 ;; we can stop Jolt from terminating the process on every error.
19 ;; Unfortunately, the backtrace doesn't contain much information and
20 ;; we also have no error message (other than the exit code). Jolt
21 ;; usually prints some message to stdout before calling exit, so you
22 ;; have to look in the *inferior-lisp* buffer for hints. We do
23 ;; nothing (yet) to recover from SIGSEGV.
24
25 ;;; Installation
26 ;;
27 ;; 1. Download and build cola. See <http://piumarta.com/software/cola/>.
28 ;; I used the svn version:
29 ;; svn co http://piumarta.com/svn2/idst/trunk idst
30 ;; 2. Add something like this to your .emacs:
31 ;;
32 ;; (add-to-list 'slime-lisp-implementations
33 ;; '(jolt (".../idst/function/jolt-burg/main"
34 ;; "boot.k" ".../swank-jolt.k" "-") ; note the "-"
35 ;; :init jolt-slime-init
36 ;; :init-function slime-redirect-inferior-output)
37 ;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file)))
38 ;; (defun jolt () (interactive) (slime 'jolt))
39 ;;
40 ;; 3. Use `M-x jolt' to start it.
41 ;;
42
43 ;;; Code
44
45 ;; In this file I use 2-3 letters for often used names, like DF or
46 ;; VEC, even if those names are abbreviations. I think that after a
47 ;; little getting used to, this style is just as readable as the more
48 ;; traditional DEFUN and VECTOR. Shorter names make it easier to
49 ;; write terse code, in particular 1-line definitions.
50
51 ;; `df' is like `defun' in a traditional lisp
52 (syntax df
53 (lambda (form compiler)
54 (printf "df %s ...\n" [[[form second] asString] _stringValue])
55 `(define ,[form second] (lambda ,@[form copyFrom: '2]))))
56
57 ;; (! args ...) is the same as [args ...] but easier to edit.
58 (syntax !
59 (lambda (form compiler)
60 (cond ((== [form size] '3)
61 (if [[form third] isSymbol]
62 `(send ',[form third] ,[form second])
63 [compiler errorSyntax: [form third]]))
64 ((and [[form size] > '3]
65 (== [[form size] \\ '2] '0))
66 (let ((args [OrderedCollection new])
67 (keys [OrderedCollection new])
68 (i '2) (len [form size]))
69 (while (< i len)
70 (let ((key [form at: i]))
71 (if (or [key isKeyword]
72 (and (== i '2) [key isSymbol])) ; for [X + Y]
73 [keys addLast: [key asString]]
74 [compiler errorSyntax: key]))
75 [args addLast: [form at: [i + '1]]]
76 (set i [i + '2]))
77 `(send ',[[keys concatenated] asSymbol] ,[form second] ,@args)))
78 (1 [compiler errorArgumentCount: form]))))
79
80 (define Integer (import "Integer"))
81 (define Symbol (import "Symbol")) ;; aka. _selector
82 (define StaticBlockClosure (import "StaticBlockClosure"))
83 (define BlockClosure (import "BlockClosure"))
84 (define SequenceableCollection (import "SequenceableCollection"))
85 (define _vtable (import "_vtable"))
86 (define ByteArray (import "ByteArray"))
87 (define CodeGenerator (import "CodeGenerator"))
88 (define TheGlobalEnvironment (import "TheGlobalEnvironment"))
89
90 (df error (msg) (! Object error: msg))
91 (df print-to-string (obj)
92 (let ((len '200)
93 (stream (! WriteStream on: (! String new: len))))
94 (! stream print: obj)
95 (! stream contents)))
96 (df assertion-failed (exp)
97 (error (! '"Assertion failed: " , (print-to-string exp))))
98
99 (syntax assert
100 (lambda (form)
101 `(if (not ,(! form second))
102 (assertion-failed ',(! form second)))))
103
104 (df isa? (obj type) (! obj isKindOf: type))
105 (df equal (o1 o2) (! o1 = o2))
106
107 (define nil 0)
108 (define false 0)
109 (define true (! Object notNil))
110 (df bool? (obj) (or (== obj false) (== obj true)))
111 (df int? (obj) (isa? obj Integer))
112
113 ;; In this file the convention X>Y is used for operations that convert
114 ;; X-to-Y. And _ means "machine word". So _>int is the operator that
115 ;; converts a machine word to an Integer.
116
117 (df _>int (word) (! Integer value_: word))
118 (df int>_ (i) (! i _integerValue))
119
120 ;; Fixnum operators. Manual tagging/untagging would probably be more
121 ;; efficent than invoking methods.
122
123 (df fix? (obj) (& obj 1))
124 (df _>fix (n) (! SmallInteger value_: n))
125 (df fix>_ (i) (! i _integerValue))
126 (df fx+ (fx1 fx2) (! fx1 + fx2))
127 (df fx* (fx1 fx2) (! fx1 * fx2))
128 (df fx1+ (fx) (! fx + '1))
129 (df fx1- (fx) (! fx - '1))
130
131 (df str? (obj) (isa? obj String))
132 (df >str (o) (! o asString))
133 (df str>_ (s) (! s _stringValue))
134 (df _>str (s) (! String value_: s))
135 (df sym? (obj) (isa? obj Symbol))
136 (df seq? (obj) (isa? obj SequenceableCollection))
137 (df array? (obj) (isa? obj Array))
138 (df len (obj) (! obj size))
139 (df len_ (obj) (! (! obj size) _integerValue))
140 (df ref (obj idx) (! obj at: idx))
141 (df set-ref (obj idx elt) (! obj at: idx put: elt))
142 (df first (obj) (! obj first))
143 (df second (obj) (! obj second))
144
145 (df puts (string stream) (! stream nextPutAll: string))
146
147 (define _GC_base (dlsym "GC_base"))
148
149 ;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows
150 ;; such things. This is useful for debugging, because we can quite
151 ;; safely (i.e. without provoking SIGSEGV) access such addresses.
152 (df valid-pointer? (addr)
153 (let ((ptr (& addr (~ 1))))
154 (and (_GC_base ptr)
155 (_GC_base (long@ ptr -1)))))
156
157 ;; Print OBJ as a Lisp printer would do.
158 (df prin1 (obj stream)
159 (cond ((fix? obj) (! stream print: obj))
160 ((== obj nil) (puts '"nil" stream))
161 ((== obj false) (puts '"#f" stream))
162 ((== obj true) (puts '"#t" stream))
163 ((not (valid-pointer? obj))
164 (begin (puts '"#<w " stream)
165 (prin1 (_>int obj) stream)
166 (puts '">" stream)))
167 ((int? obj) (! stream print: obj))
168 ((sym? obj) (puts (>str obj) stream))
169 ((isa? obj StaticBlockClosure)
170 (begin (puts '"#<fun /" stream)
171 (! stream print: (! obj arity))
172 (puts '"#>" stream)))
173 ((and (str? obj) (len obj))
174 (! obj printEscapedOn: stream delimited: (ref '"\"" '0)))
175 ((and (array? obj) (len obj))
176 (begin (puts '"(" stream)
177 (let ((max (- (len_ obj) 1)))
178 (for (i 0 1 max)
179 (prin1 (ref obj (_>fix i)) stream)
180 (if (!= i max)
181 (puts '" " stream))))
182 (puts '")" stream)))
183 ((and (isa? obj OrderedCollection) (len obj))
184 (begin (puts '"#[" stream)
185 (let ((max (- (len_ obj) 1)))
186 (for (i 0 1 max)
187 (prin1 (ref obj (_>fix i)) stream)
188 (if (!= i max)
189 (puts '" " stream))))
190 (puts '"]" stream)))
191 (true
192 (begin (puts '"#<" stream)
193 (puts (! obj debugName) stream)
194 (puts '">" stream))))
195 obj)
196
197 (df print (obj)
198 (prin1 obj StdOut)
199 (puts '"\n" StdOut))
200
201 (df prin1-to-string (obj)
202 (let ((len '100)
203 (stream (! WriteStream on: (! String new: len))))
204 (prin1 obj stream)
205 (! stream contents)))
206
207 ;;(df %vable-tally (_vtable) (long@ _vtable))
208 (df cr () (printf "\n"))
209 (df print-object-selectors (obj)
210 (let ((vtable (! obj _vtable))
211 (tally (long@ vtable 0))
212 (bindings (long@ vtable 1)))
213 (for (i 1 1 tally)
214 (print (long@ (long@ bindings i)))
215 (cr))))
216
217 (df print-object-slots (obj)
218 (let ((size (! obj _sizeof))
219 (end (+ obj size)))
220 (while (< obj end)
221 (print (long@ obj))
222 (cr)
223 (incr obj 4))))
224
225 (df intern (string) (! Symbol intern: string))
226
227 ;; Jolt doesn't seem to have an equivalent for gensym, but it's damn
228 ;; hard to write macros without it. So here we adopt the conventions
229 ;; that symbols which look like ".[0-9]+" are reserved for gensym and
230 ;; shouldn't be used for "user visible variables".
231 (define gensym-counter 0)
232 (df gensym ()
233 (set gensym-counter (+ gensym-counter 1))
234 (intern (! '"." , (>str (_>fix gensym-counter)))))
235
236 ;; Surprisingly, SequenceableCollection doesn't have a indexOf method.
237 ;; So we even need to implement such mundane things.
238 (df index-of (seq elt)
239 (let ((max (len seq))
240 (i '0))
241 (while (! i < max)
242 (if (equal (ref seq i) elt)
243 (return i)
244 (set i (! i + '1))))
245 nil))
246
247 (df find-dot (array) (index-of array '.))
248
249 ;; What followes is the implementation of the pattern matching macro MIF.
250 ;; The syntax is (mif (PATTERN EXP) THEN ELSE).
251 ;; The THEN-branch is executed if PATTERN matches the value produced by EXP.
252 ;; ELSE gets only executed if the match failes.
253 ;; A pattern can be
254 ;; 1) a symbol, which matches all values, but also binds the variable to the
255 ;; value
256 ;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL.
257 ;; 3) (PS ...) matches sequences, if the elements match PS.
258 ;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements
259 ;; at indices 1..n and if Ptail matches the rest
260 ;; of the sequence
261 ;; Examples:
262 ;; (mif (x 10) x 'else) => 10
263 ;; (mif ('a 'a) 'then 'else) => then
264 ;; (mif ('a 'b) 'then 'else) => else
265 ;; (mif ((a b) '(1 2)) b 'else) => 2
266 ;; (mif ((a . b) '(1 2)) b 'else) => '(2)
267 ;; (mif ((. x) '(1 2)) x 'else) => '(1 2)
268
269 (define mif% 0) ;; defer
270 (df mif%array (compiler pattern i value then fail)
271 ;;(print `(mif%array ,pattern ,i ,value))
272 (cond ((== i (len_ pattern)) then)
273 ((== (ref pattern (_>fix i)) '.)
274 (begin
275 (if (!= (- (len_ pattern) 2) i)
276 (begin
277 (print pattern)
278 (! compiler error: (! '"dot in strange position: "
279 , (>str (_>fix i))))))
280 (mif% compiler
281 (ref pattern (_>fix (+ i 1)))
282 `(! ,value copyFrom: ',(_>fix i))
283 then fail)))
284 (true
285 (mif% compiler
286 (ref pattern (_>fix i))
287 `(ref ,value ',(_>fix i))
288 (mif%array compiler pattern (+ i 1) value then fail)
289 fail))))
290
291 (df mif% (compiler pattern value then fail)
292 ;;(print `(mif% ,pattern ,value ,then))
293 (cond ((== pattern '_) then)
294 ((== pattern '.) (! compiler errorSyntax: pattern))
295 ((sym? pattern)
296 `(let ((,pattern ,value)) ,then))
297 ((seq? pattern)
298 (cond ((== (len_ pattern) 0)
299 `(if (== (len_ ,value) 0) ,then (goto ,fail)))
300 ((== (first pattern) 'quote)
301 (begin
302 (if (not (== (len_ pattern) 2))
303 (! compiler errorSyntax: pattern))
304 `(if (equal ,value ,pattern) ,then (goto ,fail))))
305 (true
306 (let ((tmp (gensym)) (tmp2 (gensym))
307 (pos (find-dot pattern)))
308 `(let ((,tmp2 ,value)
309 (,tmp ,tmp2))
310 (if (and (seq? ,tmp)
311 ,(if (find-dot pattern)
312 `(>= (len ,tmp)
313 ',(_>fix (- (len_ pattern) 2)))
314 `(== (len ,tmp) ',(len pattern))))
315 ,(mif%array compiler pattern 0 tmp then fail)
316 (goto ,fail)))))))
317 (true (! compiler errorSyntax: pattern))))
318
319 (syntax mif
320 (lambda (node compiler)
321 ;;(print `(mif ,node))
322 (if (not (or (== (len_ node) 4)
323 (== (len_ node) 3)))
324 (! compiler errorArgumentCount: node))
325 (if (not (and (array? (ref node '1))
326 (== (len_ (ref node '1)) 2)))
327 (! compiler errorSyntax: (ref node '1)))
328 (let ((pattern (first (ref node '1)))
329 (value (second (ref node '1)))
330 (then (ref node '2))
331 (else (if (== (len_ node) 4)
332 (ref node '3)
333 `(error "mif failed")))
334 (destination (gensym))
335 (fail (! compiler newLabel))
336 (success (! compiler newLabel)))
337 `(let ((,destination 0))
338 ,(mif% compiler pattern value
339 `(begin (set ,destination ,then)
340 (goto ,success))
341 fail)
342 (label ,fail)
343 (set ,destination ,else)
344 (label ,success)
345 ,destination))))
346
347 ;; (define *catch-stack* nil)
348 ;;
349 (df bar (o) (mif ('a o) 'yes 'no))
350 (assert (== (bar 'a) 'yes))
351 (assert (== (bar 'b) 'no))
352 (df foo (o) (mif (('a) o) 'yes 'no))
353 (assert (== (foo '(a)) 'yes))
354 (assert (== (foo '(b)) 'no))
355 (df baz (o) (mif (('a 'b) o) 'yes 'no))
356 (assert (== (baz '(a b)) 'yes))
357 (assert (== (baz '(a c)) 'no))
358 (assert (== (baz '(b c)) 'no))
359 (assert (== (baz 'a) 'no))
360 (df mifvar (o) (mif (y o) y 'no))
361 (assert (== (mifvar 'foo) 'foo))
362 (df mifvec (o) (mif ((y) o) y 'no))
363 (assert (== (mifvec '(a)) 'a))
364 (assert (== (mifvec 'x) 'no))
365 (df mifvec2 (o) (mif (('a y) o) y 'no))
366 (assert (== (mifvec2 '(a b)) 'b))
367 (assert (== (mifvec2 '(b c)) 'no))
368 (assert (== (mif ((x) '(a)) x 'no) 'a))
369 (assert (== (mif ((x . y) '(a b)) x 'no) 'a))
370 (assert (== (mif ((x y . z) '(a b)) y 'no) 'b))
371 (assert (equal (mif ((x . y) '(a b)) y 'no) '(b)))
372 (assert (equal (mif ((. x) '(a b)) x 'no) '(a b)))
373 (assert (equal (mif (((. x)) '((a b))) x 'no) '(a b)))
374 (assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c)))
375 (assert (== (mif (() '()) 'yes 'no) 'yes))
376 (assert (== (mif (() '(a)) 'yes 'no) 'no))
377
378 ;; Now that we have a somewhat convenient pattern matcher we can write
379 ;; a more convenient macro defining macro:
380 (syntax defmacro
381 (lambda (node compiler)
382 (mif (('defmacro name (. args) . body) node)
383 (begin
384 (printf "defmacro %s ...\n" (str>_ (>str name)))
385 `(syntax ,name
386 (lambda (node compiler)
387 (mif ((',name ,@args) node)
388 (begin ,@body)
389 (! compiler errorSyntax: node)))))
390 (! compiler errorSyntax: node))))
391
392 ;; and an even more convenient pattern matcher:
393 (defmacro mcase (value . clauses)
394 (let ((tmp (gensym)))
395 `(let ((,tmp ,value))
396 ,(mif (() clauses)
397 `(begin (print ,tmp)
398 (error "mcase failed"))
399 (mif (((pattern . body) . more) clauses)
400 `(mif (,pattern ,tmp)
401 (begin ,@(mif (() body) '(0) body))
402 (mcase ,tmp ,@more))
403 (! compiler errorSyntax: clauses))))))
404
405 ;; and some traditional macros
406 (defmacro when (test . body) `(if ,test (begin ,@body)))
407 (defmacro unless (test . body) `(if ,test 0 (begin ,@body)))
408 (defmacro or (. args) ; the built in OR returns 1 on success.
409 (mcase args
410 (() 0)
411 ((e) e)
412 ((e1 . more)
413 (let ((tmp (gensym)))
414 `(let ((,tmp ,e1))
415 (if ,tmp ,tmp (or ,@more)))))))
416
417 (defmacro dotimes_ ((var n) . body)
418 (let ((tmp (gensym)))
419 `(let ((,tmp ,n)
420 (,var 0))
421 (while (< ,var ,tmp)
422 ,@body
423 (set ,var (+ ,var 1))))))
424
425 (defmacro dotimes ((var n) . body)
426 (let ((tmp (gensym)))
427 `(let ((,tmp ,n)
428 (,var '0))
429 (while (< ,var ,tmp)
430 ,@body
431 (set ,var (fx1+ ,var))))))
432
433 ;; DOVEC is like the traditional DOLIST but works on "vectors"
434 ;; i.e. sequences which can be indexed efficently.
435 (defmacro dovec ((var seq) . body)
436 (let ((i (gensym))
437 (max (gensym))
438 (tmp (gensym)))
439 `(let ((,i 0)
440 (,tmp ,seq)
441 (,max (len_ ,tmp)))
442 (while (< ,i ,max)
443 (let ((,var (! ,tmp at: (_>fix ,i))))
444 ,@body
445 (set ,i (+ ,i 1)))))))
446
447 ;; "Packing" is what Lispers usually call "collecting".
448 ;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result))
449 ;; translates to (packing (result) .. (pack x result))
450 (defmacro packing ((var) . body)
451 `(let ((,var (! OrderedCollection new)))
452 ,@body
453 (! ,var asArray)))
454
455 (df pack (elt packer) (! packer addLast: elt))
456
457 (assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p)))
458 '(0 1)))
459
460 (assert (equal (packing (p) (dovec (e '(2 3)) (pack e p)))
461 '(2 3)))
462
463 (assert (equal (packing (p)
464 (let ((a '(2 3)))
465 (dotimes (i (len a))
466 (pack (ref a i) p))))
467 '(2 3)))
468
469 ;; MAPCAR (more or less)
470 (df map (fun col)
471 (packing (r)
472 (dovec (e col)
473 (pack (fun e) r))))
474
475 ;; VEC allocates and initializes a new array.
476 ;; The macro translates (vec x y z) to `(,x ,y ,z).
477 (defmacro vec (. args)
478 `(quasiquote
479 (,@(map (lambda (arg) `(,'unquote ,arg))
480 args))))
481
482 (assert (equal (vec '0 '1) '(0 1)))
483 (assert (equal (vec) '()))
484 (assert (== (len (vec 0 1 2 3 4)) '5))
485
486 ;; Concatenate.
487 (defmacro cat (. args) `(! (vec '"" ,@args) concatenated))
488
489 (assert (equal (cat '"a" '"b" '"c") '"abc"))
490
491 ;; Take a vector of bytes and copy the bytes to a continuous
492 ;; block of memory
493 (df assemble_ (col) (! (! ByteArray withAll: col) _bytes))
494
495 ;; Jolt doesn't seem to have catch/throw or something equivalent.
496 ;; Here I use a pair of assembly routines as substitue.
497 ;; (catch% FUN) calls FUN with the current stack pointer.
498 ;; (throw% VALUE K) unwinds the stack to K and then returns VALUE.
499 ;; catch% is a bit like call/cc.
500 ;;
501 ;; [Would setjmp/longjmp work from Jolt? or does setjmp require
502 ;; C-compiler magic?]
503 ;; [I figure Smalltalk has a way to do non-local-exits but, I don't know
504 ;; how to use that in Jolt.]
505 ;;
506 (define catch%
507 (assemble_
508 '(0x55 ; push %ebp
509 0x89 0xe5 ; mov %esp,%ebp
510 0x54 ; push %esp
511 0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax
512 0xff 0xd0 ; call *%eax
513 0xc9 ; leave
514 0xc3 ; ret
515 )))
516
517 (define throw%
518 (assemble_
519 `(,@'()
520 0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax
521 0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp
522 0xc9 ; leave
523 0xc3 ; ret
524 )))
525
526 (df bar (i k)
527 (if (== i 0)
528 (throw% 100 k)
529 (begin
530 (printf "bar %d\n" i)
531 (bar (- i 1) k))))
532 (df foo (k)
533 (printf "foo.1\n")
534 (printf "foo.2 %d\n" (bar 10 k)))
535
536 ;; Our way to produce closures: we compile a new little function which
537 ;; hardcodes the addresses of the code resp. the data-vector. The
538 ;; nice thing is that such closures can be used called C function
539 ;; pointers. It's probably slow to invoke the compiler for such
540 ;; things, so use with care.
541 (df make-closure (addr state)
542 (int>_
543 (! `(lambda (a b c d)
544 (,(_>int addr) ,(_>int state) a b c d))
545 eval)))
546
547 ;; Return a closure which calls FUN with ARGS and the arguments
548 ;; that the closure was called with.
549 ;; Example: ((curry printf "%d\n") 10)
550 (defmacro curry (fun . args)
551 `(make-closure
552 (lambda (state a b c d)
553 ((ref state '0)
554 ,@(packing (sv)
555 (dotimes (i (len args))
556 (pack `(ref state ',(fx1+ i)) sv)))
557 a b c d))
558 (vec ,fun ,@args)))
559
560 (df parse-closure-arglist (vars)
561 (let ((pos (or (index-of vars '|)
562 (return nil)))
563 (cvars (! vars copyFrom: '0 to: (fx1- pos)))
564 (lvars (! vars copyFrom: (fx1+ pos))))
565 (vec cvars lvars)))
566
567 ;; Create a closure, to-be-closed-over variables must enumerated
568 ;; explicitly.
569 ;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4.
570 ;; The variables before the "|" are captured by the closure.
571 (defmacro closure ((. vars) . body)
572 (mif ((cvars lvars) (parse-closure-arglist vars))
573 `(curry (lambda (,@cvars ,@lvars) ,@body)
574 ,@cvars)
575 (! compiler errorSyntax: vars)))
576
577 ;; The analog for Smalltalkish "blocks".
578 (defmacro block ((. vars) . body)
579 (mif ((cvars lvars) (parse-closure-arglist vars))
580 `(! StaticBlockClosure
581 function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body)
582 ,@cvars)
583 arity_: ,(len lvars))
584 (! compiler errorSyntax: vars)))
585
586 (define %mkstemp (dlsym "mkstemp"))
587 (df make-temp-file ()
588 (let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy))
589 (fd (%mkstemp (! name _stringValue))))
590 (if (== fd -1)
591 (error "mkstemp failed"))
592 `(,fd ,name)))
593 (define %unlink (dlsym "unlink"))
594 (df unlink (filename) (%unlink (! filename _stringValue)))
595
596 (define write (dlsym "write"))
597 (df write-bytes (addr count fd)
598 (let ((written (write fd addr count)))
599 (if (!= written count)
600 (begin
601 (printf "write failed %p %d %d => %d" addr count fd written)
602 (error '"write failed")))))
603
604 (define system (dlsym "system"))
605 (define main (dlsym "main"))
606
607 ;; Starting at address ADDR, disassemble COUNT bytes.
608 ;; This is implemented by writing the memory region to a file
609 ;; and call ndisasm on it.
610 (df disas (addr count)
611 (let ((fd+name (make-temp-file)))
612 (write-bytes addr count (first fd+name))
613 (let ((cmd (str>_ (cat '"ndisasm -u -o "
614 (>str (_>fix addr))
615 '" " (second fd+name)))))
616 (printf "Running: %s\n" cmd)
617 (system cmd))
618 (unlink (second fd+name))))
619
620 (df rep ()
621 (let ((result (! (! CokeScanner read: StdIn) eval)))
622 (puts '"=> " StdOut)
623 (print result)
624 (puts '"\n" StdOut)))
625
626 ;; Perhaps we could use setcontext/getcontext to return from signal
627 ;; handlers (or not).
628 (define +ucontext-size+ 350)
629 (define _getcontext (dlsym "getcontext"))
630 (define _setcontext (dlsym "setcontext"))
631 (df getcontext ()
632 (let ((context (malloc 350)))
633 (_getcontext context)
634 context))
635
636 (define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why?
637
638 (define *top-level-restart* 0)
639 (define *top-level-context* 0)
640 (define *debugger-hook* 0)
641
642 ;; Jolt's error handling strategy is charmingly simple: call exit.
643 ;; We invoke the SLIME debugger from an exit handler.
644 ;; (The handler is registered with atexit, that's a libc function.)
645
646 (df exit-handler (reason arg)
647 (printf "exit-handler 0x%x\n" reason)
648 ;;(backtrace)
649 (on_exit exit-handler nil)
650 (when *debugger-hook*
651 (*debugger-hook* `(exit ,reason)))
652 (cond (*top-level-context*
653 (_setcontext *top-level-context*))
654 (*top-level-restart*
655 (throw% reason *top-level-restart*))))
656
657 (df repl ()
658 (set *top-level-context* (getcontext))
659 (while (not (! (! StdIn readStream) atEnd))
660 (printf "top-level\n")
661 (catch%
662 (lambda (k)
663 (set *top-level-restart* k)
664 (printf "repl\n")
665 (while 1
666 (rep)))))
667 (printf "EOF\n"))
668
669 ;; (repl)
670
671
672 ;;; Socket code. (How boring. Duh, should have used netcat instead.)
673
674 (define strerror (dlsym "strerror"))
675
676 (df check-os-code (value)
677 (if (== value -1)
678 (error (_>str (strerror (fix>_ (! OS errno)))))
679 value))
680
681 ;; For now just hard-code constants which usually reside in header
682 ;; files (just like a Forth guy would do).
683 (define PF_INET 2)
684 (define SOCK_STREAM 1)
685 (define SOL_SOCKET 1)
686 (define SO_REUSEADDR 2)
687 (define socket (dlsym "socket"))
688 (define setsockopt (dlsym "setsockopt"))
689
690 (df set-reuse-address (sock value)
691 (let ((word-size 4)
692 (val (! Object _balloc: (_>fix word-size))))
693 (set-int@ val value)
694 (check-os-code
695 (setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size))))
696
697 (define sockaddr_in/size 16)
698 (define sockaddr_in/sin_family 0)
699 (define sockaddr_in/sin_port 2)
700 (define sockaddr_in/sin_addr 4)
701 (define INADDR_ANY 0)
702 (define AF_INET 2)
703 (define htons (dlsym "htons"))
704 (define bind (dlsym "bind"))
705
706 (df bind-socket (sock port)
707 (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))))
708 (set-short@ (+ addr sockaddr_in/sin_family) AF_INET)
709 (set-short@ (+ addr sockaddr_in/sin_port) (htons port))
710 (set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY)
711 (check-os-code
712 (bind sock addr sockaddr_in/size))))
713
714 (define listen (dlsym "listen"))
715
716 (df create-socket (port)
717 (let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0))))
718 (set-reuse-address sock 1)
719 (bind-socket sock port)
720 (check-os-code (listen sock 1))
721 sock))
722
723 (define accept% (dlsym "accept"))
724 (df accept (sock)
725 (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
726 (len (! OS _balloc: 4)))
727 (set-int@ len sockaddr_in/size)
728 (check-os-code (accept% sock addr len))))
729
730 (define getsockname (dlsym "getsockname"))
731 (define ntohs (dlsym "ntohs"))
732 (df local-port (sock)
733 (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
734 (len (! OS _balloc: 4)))
735 (set-int@ len sockaddr_in/size)
736 (check-os-code
737 (getsockname sock addr len))
738 (ntohs (short@ (+ addr sockaddr_in/sin_port)))))
739
740 (define close (dlsym "close"))
741 (define _read (dlsym "read"))
742
743 ;; Now, after 2/3 of the file we can begin with the actual Swank
744 ;; server.
745
746 (df read-string (fd count)
747 (let ((buffer (! String new: count))
748 (buffer_ (str>_ buffer))
749 (count_ (int>_ count))
750 (start 0))
751 (while (> (- count_ start) 0)
752 (let ((rcount (check-os-code (_read fd
753 (+ buffer_ start)
754 (- count_ start)))))
755 (set start (+ start rcount))))
756 buffer))
757
758 ;; Read and parse a message from the wire.
759 (df read-packet (fd)
760 (let ((header (read-string fd '6))
761 (length (! Integer fromString: header base: '16))
762 (payload (read-string fd length)))
763 (! CokeScanner read: payload)))
764
765 ;; Print a messag to the wire.
766 (df send-to-emacs (event fd)
767 (let ((stream (! WriteStream on: (! String new: '100))))
768 (! stream position: '6)
769 (prin1 event stream)
770 (let ((len (! stream position)))
771 (! stream position: '0)
772 (! (fx+ len '-6) printOn: stream base: '16 width: '6)
773 (write-bytes (str>_ (! stream collection)) (int>_ len) fd))))
774
775 (df add-quotes (form)
776 (mcase form
777 ((fun . args)
778 `(,fun ,@(packing (s)
779 (dovec (e args)
780 (pack `(quote ,e) s)))))))
781
782 (define sldb 0) ;defer
783
784 (df eval-for-emacs (form id fd abort)
785 (let ((old-hook *debugger-hook*))
786 (mcase (catch%
787 (closure (form fd | k)
788 (set *debugger-hook* (curry sldb fd k))
789 `(ok ,(int>_ (! (add-quotes form) eval)))))
790 (('ok value)
791 (set *debugger-hook* old-hook)
792 (send-to-emacs `(:return (:ok ,value) ,id) fd)
793 'ok)
794 (arg
795 (set *debugger-hook* old-hook)
796 (send-to-emacs `(:return (:abort) ,id) fd)
797 (throw% arg abort)))))
798
799 (df process-events (fd)
800 (on_exit exit-handler nil)
801 (let ((done nil))
802 (while (not done)
803 (mcase (read-packet fd)
804 ((':emacs-rex form package thread id)
805 (mcase (catch% (closure (form id fd | abort)
806 (eval-for-emacs form id fd abort)))
807 ('ok)
808 ;;('abort nil)
809 ('top-level)
810 (other
811 ;;(return other) ; compiler breaks with return
812 (set done 1))))))))
813
814 (df next-frame (fp)
815 (let ((next (get-caller-fp fp)))
816 (if (and (!= next fp)
817 (<= next %top-level-fp))
818 next
819 nil)))
820
821 (df nth-frame (n top)
822 (let ((fp top)
823 (i 0))
824 (while fp
825 (if (== i n) (return fp))
826 (set fp (next-frame fp))
827 (set i (+ i 1)))
828 nil))
829
830 (define Dl_info/size 16)
831 (define Dl_info/dli_fname 0)
832 (define Dl_info/dli_sname 8)
833
834 (df get-dl-sym-name (addr)
835 (let ((info (! OS _balloc: (_>fix Dl_info/size))))
836 (when (== (dladdr addr info) 0)
837 (return nil))
838 (let ((sname (long@ (+ info Dl_info/dli_sname)) )
839 (fname (long@ (+ info Dl_info/dli_fname))))
840 (cond ((and sname fname)
841 (cat (_>str sname) '" in " (_>str fname)))
842 (sname (_>str fname))
843 (fname (cat '"<??> " (_>str fname)))
844 (true nil)))))
845
846 ;;(get-dl-sym-name printf)
847
848 (df guess-function-name (ip)
849 (let ((fname (get-function-name ip)))
850 (if fname
851 (_>str fname)
852 (get-dl-sym-name ip))))
853
854 (df backtrace>el (top_ from_ to_)
855 (let ((fp (nth-frame from_ top_))
856 (i from_))
857 (packing (bt)
858 (while (and fp (< i to_))
859 (let ((ip (get-frame-ip fp)))
860 (pack (vec (_>int i)
861 (cat (or (guess-function-name ip) '"(no-name)")
862 '" " ;;(>str (_>int ip))
863 ))
864 bt))
865 (set i (+ i 1))
866 (set fp (next-frame fp))))))
867
868 (df debugger-info (fp msg)
869 (vec `(,(prin1-to-string msg) " [type ...]" ())
870 '(("quit" "Return to top level"))
871 (backtrace>el fp 0 20)
872 '()))
873
874 (define *top-frame* 0)
875 (define *sldb-quit* 0)
876
877 (df debugger-loop (fd args abort)
878 (let ((fp (get-current-fp)))
879 (set *top-frame* fp)
880 (send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd)
881 (while 1
882 (mcase (read-packet fd)
883 ((':emacs-rex form package thread id)
884 (mcase (catch% (closure (form id fd | k)
885 (set *sldb-quit* k)
886 (eval-for-emacs form id fd k)
887 'ok))
888 ('ok nil)
889 (other
890 (send-to-emacs `(:return (:abort) ,id) fd)
891 (throw% other abort))))))))
892
893 (df sldb (fd abort args)
894 (let ((old-top-frame *top-frame*)
895 (old-sldb-quit *sldb-quit*))
896 (mcase (catch% (curry debugger-loop fd args))
897 (value
898 (set *top-frame* old-top-frame)
899 (set *sldb-quit* old-sldb-quit)
900 (send-to-emacs `(:debug-return 0 1 nil) fd)
901 (throw% value abort)))))
902
903 (df swank:backtrace (start end)
904 (backtrace>el *top-frame* (int>_ start) (int>_ end)))
905
906 (df sldb-quit ()
907 (assert *sldb-quit*)
908 (throw% 'top-level *sldb-quit*))
909
910 (df swank:invoke-nth-restart-for-emacs (...) (sldb-quit))
911 (df swank:throw-to-toplevel (...) (sldb-quit))
912
913 (df setup-server (port announce)
914 (let ((sock (create-socket port)))
915 (announce sock)
916 (let ((client (accept sock)))
917 (process-events client)
918 (close client))
919 (printf "Closing socket: %d %d\n" sock (local-port sock))
920 (close sock)))
921
922 (df announce-port (sock)
923 (printf "Listening on port: %d\n" (local-port sock)))
924
925 (df create-server (port) (setup-server port announce-port))
926
927 (df write-port-file (filename sock)
928 (let ((f (! File create: filename)))
929 (! f write: (print-to-string (_>int (local-port sock))))
930 (! f close)))
931
932 (df start-swank (port-file)
933 (setup-server 0 (curry write-port-file (_>str port-file))))
934
935 (define getpid (dlsym "getpid"))
936 (df swank:connection-info ()
937 `(,@'()
938 :pid ,(_>int (getpid))
939 :style nil
940 :lisp-implementation (,@'()
941 :type "Coke"
942 :name "jolt"
943 :version ,(! CodeGenerator versionString))
944 :machine (:instance "" :type ,(! OS architecture) :version "")
945 :features ()
946 :package (:name "jolt" :prompt "jolt")))
947
948 (df swank:listener-eval (string)
949 (let ((result (! (! CokeScanner read: string) eval)))
950 `(:values ,(prin1-to-string (if (or (fix? result)
951 (and (valid-pointer? result)
952 (int? result)))
953 (int>_ result)
954 result))
955 ,(prin1-to-string result))))
956
957 (df swank:interactive-eval (string)
958 (let ((result (! (! CokeScanner read: string) eval)))
959 (cat '"=> " (prin1-to-string (if (or (fix? result)
960 (and (valid-pointer? result)
961 (int? result)))
962 (int>_ result)
963 result))
964 '", " (prin1-to-string result))))
965
966 (df swank:operator-arglist () nil)
967 (df swank:buffer-first-change () nil)
968 (df swank:create-repl (_) '("jolt" "jolt"))
969
970 (df min (x y) (if (<= x y) x y))
971
972 (df common-prefix2 (e1 e2)
973 (let ((i '0)
974 (max (min (len e1) (len e2))))
975 (while (and (< i max)
976 (== (ref e1 i) (ref e2 i)))
977 (set i (fx1+ i)))
978 (! e1 copyFrom: '0 to: (fx1- i))))
979
980 (df common-prefix (seq)
981 (mcase seq
982 (() nil)
983 (_
984 (let ((prefix (ref seq '0)))
985 (dovec (e seq)
986 (set prefix (common-prefix2 prefix e)))
987 prefix))))
988
989 (df swank:simple-completions (prefix _package)
990 (let ((matches (packing (s)
991 (dovec (e (! TheGlobalEnvironment keys))
992 (let ((name (>str e)))
993 (when (! name beginsWith: prefix)
994 (pack name s)))))))
995 (vec matches (or (common-prefix matches) prefix))))
996
997
998 ;; swank-jolt.k ends here

  ViewVC Help
Powered by ViewVC 1.1.5