[slime-cvs] CVS slime/contrib
CVS User heller
heller at common-lisp.net
Thu Oct 23 21:33:53 UTC 2008
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv22327
Modified Files:
ChangeLog
Added Files:
swank-jolt.k
Log Message:
* swank-jolt.k: New backend.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:28:03 1.136
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:33:49 1.137
@@ -1,5 +1,8 @@
2008-10-23 Helmut Eller <heller at common-lisp.net>
+ * swank-jolt.k: New backend.
+
+2008-10-23 Helmut Eller <heller at common-lisp.net>
* swank-asdf.lisp (operate-on-system-for-emacs): Always T to
collect-notes. Reported by Mark Evenson.
--- /project/slime/cvsroot/slime/contrib/swank-jolt.k 2008/10/23 21:33:54 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-jolt.k 2008/10/23 21:33:54 1.1
;;; 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] , at 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
;; 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 , at args) node)
(begin , at body)
(! compiler errorSyntax: node)))))
[608 lines skipped]
More information about the slime-cvs
mailing list