Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
authorTony Garnock-Jones <tonyg@kcbbs.gen.nz>
Thu, 31 Mar 2005 01:25:02 +1200
changeset 0 ea4e1a00864c
child 1 e3e8313b3acc
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Makefile
README
boot.thing
compile.scm
doc/CoreTalk
doc/Joinable
doc/Makefile
doc/SimplestThingThatCouldWork.txt
doc/TODO
doc/ThiNG-kernel.lyx
doc/dotmacros.m4
doc/historical/core.thing
doc/historical/experimental-keyword-syntax.thing
doc/historical/test.thing
doc/hll.experiments
doc/hll.lyx
doc/kernel-graph.dot.m4
doc/layers.lyx
doc/metaoperations.lyx
doc/new-ideas.thing
doc/project-diary.lyx
doc/pseudoambients.lyx
doc/redb.lyx
doc/talk/Makefile
doc/talk/ThiNG_talk.tex
doc/talk/talknotes.txt
experiments/gui.ss
experiments/oo.ss
experiments/oo.tng
experiments/packrat-utils.scm
experiments/parser-combinator.scm
experiments/queue.ss
experiments/stm/cell.scm
experiments/tng-scratch.scm
experiments/tng.scm
experiments/transactions/Makefile
experiments/transactions/old-splay.scm
experiments/transactions/old-world.scm
experiments/transactions/splay-tree.scm
experiments/transactions/splay-tree.so
experiments/transactions/world.scm
image.scm
interp.scm
kernel-methods.scm
kernel.scm
macros.scm
oo.scm
packrat.scm
parsetng.scm
root-hooks.scm
scratch
sdl-events.scm
test.thing
tng.scm
ui.scm
util.scm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,37 @@
+cleaner1=tr '\n' ' ' | tr -s ' ' | sed -e 's/ $$//' -e 's/ / '
+cleaner2=' /g'
+
+# sdlCFLAGS=-C $(shell sdl-config --cflags | $(cleaner1)-C$(cleaner2))
+# sdlLDADD=-L $(shell sdl-config --libs | $(cleaner1)-L$(cleaner2)) \
+# 	-L -lSDL_ttf \
+# 	-L -lSDL_image \
+# 	-L -lSDL_gfx
+
+CSC=csc -syntax -O3 -lambda-lift -no-trace -keyword-style none -prologue macros.scm
+CSCCC=$(CSC) $(sdlCFLAGS)
+CSCLD=$(CSC) $(sdlCFLAGS) $(sdlLDADD)
+
+TARGETS = \
+	util.so \
+	oo.so \
+	kernel.so \
+	packrat.so \
+	parsetng.so \
+	interp.so \
+	image.so
+
+all: $(TARGETS)
+
+%.so: %.scm
+	$(CSCLD) -s -o $@ $<
+#	strip $@
+
+clean:
+	rm -f $(TARGETS)
+	rm -f STACKTRACE
+
+%: %.scm
+	$(CSCLD) -o $@ $<
+
+kernel.scm: root-hooks.scm kernel-methods.scm
+ui.scm: sdl-events.scm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,22 @@
+To start up:
+
+	$ sdl-csi tng.scm
+
+You don't need to compile to .so yet - the interpreted versions work
+fine and we don't yet need the speed.
+
+Roadmap:
+
+image.scm		- image save/load code
+interp.scm		- (empty) will contain bytecode interpreter
+kernel-methods.scm	- primitive definitions
+kernel.scm		- image bootstrap code, primitive table, method glue
+macros.scm		- macros used by more than one file
+morph.scm		- (unfinished) will contain morphic-like UI definitions
+oo.scm			- core object structures and dispatch code
+root-hooks.scm		- include file defining global image structures
+sdl-events.scm		- include file defining available SDL event types
+sugar.scm		- (unfinished) aborted attempt at a macro-based parser
+tng.scm		******* - MAIN FILE - LOAD THIS INTO sdl-csi
+ui.scm			- SDL-interface definitions + main loop
+util.scm		- various utilities
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/boot.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,191 @@
+"-*- slate -*-"
+
+l@(Location traits) addGlobal: name@(Symbol traits) value: val
+[
+  gg := Globals. "look up global 'Globals' outside the block, otherwise we deadlock"
+  gg --> [ :g | gg <-- (g withSlot: name value: val) ].
+  val
+].
+
+"Make globals delegate to Oddball."
+( gg := Globals. ob := Oddball traits.
+  gg --> [ :g | gg <-- (g traits:* ob) ] ).
+
+g@(Globals peek) as: _@(String traits) [ 'Globals' ].
+
+val@(Root traits) ref
+[
+  c := Cell new.
+  c <-- val.
+  c
+].
+
+c@(Cell traits) read
+[
+  p --> [ :v | v ]
+].
+
+c@(Cell traits) update: block
+[
+  c --> [ :v | c <-- (block applyWith: v) ]
+].
+
+c@(Cell traits) push: value
+[
+  c update: [ :cdr | value -> cdr ]
+].
+
+block@(Block traits) fork
+[
+  here ( here fork: block. )
+].
+
+block@(Block traits) loop
+[
+  loop := [ block do. loop do. ].
+  loop do.
+].
+
+p@Nil reverse [ Nil ].
+p@(Pair traits) reverse [
+  loop := [ :p :acc | p  ifNil: [ acc ] ifNotNil: [ loop applyWith: p value with: p key -> acc ] ].
+  loop applyWith: p with: Nil
+].
+
+n1@(Number traits) to: n2@(Number traits) do: block@(Block traits) [
+  loop := [ :n | (n <= n2) ifTrue: [ block applyWith: n. loop applyWith: n + 1 ] ].
+  loop applyWith: n1
+].
+
+_@True ifTrue: b@(Block traits) [ b do ].
+_@False ifTrue: b@(Block traits) [].
+
+_@True ifFalse: b@(Block traits) [].
+_@False ifFalse: b@(Block traits) [ b do ].
+
+_@True ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b1 do ].
+_@False ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b2 do ].
+
+_@Nil ifNil: b1@(Block traits) ifNotNil: b2@(Block traits) [ b1 do ].
+_@(Root traits) ifNil: b1@(Block traits) ifNotNil: b2@(Block traits) [ b2 do ].
+
+_@Nil ifNil: b@(Block traits) [ b do ].
+_@(Root traits) ifNil: b@(Block traits) [].
+
+_@Nil ifNotNil: b@(Block traits) [].
+_@(Root traits) ifNotNil: b@(Block traits) [ b do ].
+
+p@Nil concatenate [ Nil ].
+p@(Pair traits) concatenate [
+  p value
+    ifNil: [ p key ]
+    ifNotNil: [ p key, p value concatenate ]
+].
+
+s1@(String traits) , s2@(String traits)
+[
+  s1 primStringAppend: s2
+].
+
+t@(Tuple traits) printString
+[
+  p := Nil ref.
+  p push: '{'.
+  0 to: (t size - 1) do: [ :index |
+    (index = 0) ifFalse: [ p push: '. ' ].
+    p push: (t at: index) printString.
+  ].
+  p push: '}'.
+  p read reverse concatenate
+].
+
+"I am a parallel map."
+p@Nil map: block [ Nil ].
+p@(Pair traits) map: block [ (block applyWith: p key) -> (p value map: block) ].
+
+"I am a sequential map."
+p@Nil mapInOrder: block [].
+p@(Pair traits) mapInOrder: block [
+  h := (block applyWith: p key).
+  h -> (p value mapInOrder: block)
+].
+
+"I am a sequential for-each."
+p@Nil do: block [].
+p@(Pair traits) do: block [ block applyWith: p key. p value do: block ].
+
+"I am a parallel for-each."
+p@Nil doInParallel: block [].
+p@(Pair traits) doInParallel: block [ [block applyWith: p key] fork. p value doInParallel: block ].
+
+p@(Pair traits) printString
+[
+  '(', p key printString, ' -> ', p value printString, ')'
+].
+
+s@(Symbol traits) printString [ '#', resend ].
+
+_@(Globals peek) shutDownImage
+[
+  ShutdownHooks peek do: [ :hook | hook shutDown do. ].
+  'BOOTSTRAP.image' saveImage.
+  primQuit.
+].
+
+"---------------------------------------------------------------------------"
+
+"
+[
+  ({1. 2. 3. #four} -> ('Hello, world, from ThiNG!' -> (True -> (123 -> ((#a -> #b) -> Nil)))))
+  do: [ :each |
+    each printOn: Console.
+    Console crlf.
+  ].
+] fork.
+"
+
+here (
+  here addGlobal: #TraitsTraits value: (Root traits traits). "!!"
+
+  t := (name := 'ReplServer' traits :* TraitsTraits).
+  here addGlobal: #ReplServer value: (traits :* t serverSocket := Nil).
+).
+
+rs0@(ReplServer traits) newOnPort: port@(Number traits)
+[
+  rs := (rs0 serverSocket := port primListen).
+  [ rs acceptLoop ] fork.
+].
+
+rs@(ReplServer traits) acceptLoop
+[
+  [
+    sock := rs serverSocket accept.
+    sock ifNotNil: [ [ rs replOn: sock ] fork. ].
+  ] loop.
+].
+
+rs@(ReplServer traits) replOn: sock
+[ session (
+  'Welcome to ThiNG!\n' printOn: sock.
+  [
+    'ThiNG> ' printOn: sock.
+    compilationResult := sock compileOneStatement.
+    compilationResult key
+      ifTrue: [ compilationResult value do printOn: sock. ]
+      ifFalse: [
+        'PARSE ERROR\n' printOn: sock.
+        compilationResult value printOn: sock.
+        sock close.
+        session return: Nil.
+      ].
+    '\n' printOn: sock.
+  ] loop.
+)].
+
+here (
+  here addGlobal: #ShutdownHooks value: Nil ref.
+  ShutdownHooks push: (shutDown:=[] startUp:=[ ReplServer newOnPort: 4444 ]).
+  here addGlobal: #BootBlock value: [ ShutdownHooks peek do: [ :hook | hook startUp do. ] ].
+  shutDownImage.
+).
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/compile.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,238 @@
+;; Compile AST to a set of prototype methods and blocks.
+
+(define-record-type compilation-state
+  (make-compilation-state* next-literal rev-literals)
+  compilation-state?
+  (next-literal compilation-state-next-literal)
+  (rev-literals compilation-state-rev-literals))
+
+(define (make-compilation-state)
+  (make-compilation-state* 0 '()))
+
+(define (push-literal state val)
+  (let ((i (compilation-state-next-literal state)))
+    (values i
+	    (make-compilation-state* (+ i 1)
+				     (cons val (compilation-state-rev-literals state))))))
+
+(define (finish-compilation-state state)
+  (list->vector (reverse (compilation-state-rev-literals state))))
+
+(define *all-method-code-prologues* '())
+(define *invocation-count-decay-half-life* 15) ;; seconds
+(define *invocation-count-update-interval* 4) ;; seconds
+(define *recompilation-count-limit* 1000)
+
+(define (instruction->code instr is-closure)
+  (let ((prologue (vector 0 (if is-closure *true* *false*))))
+    (let ((locative (make-weak-locative prologue 0)))
+      (push! *all-method-code-prologues* locative))
+    (cons prologue instr)))
+
+(define (invocation-count-decay-constant)
+  (exp (/ (log 2)
+	  (/ *invocation-count-decay-half-life* *invocation-count-update-interval*))))
+
+(define (decay-invocation-counts!)
+  (debug 0 "Decaying invocation counts...")
+  (let ((decay-constant (invocation-count-decay-constant)))
+    (set! *all-method-code-prologues*
+	  (filter! (lambda (locative)
+		     (let ((prologue (locative->object locative)))
+		       (if prologue
+			   (vector-set! prologue 0 (/ (vector-ref prologue 0) decay-constant)))
+		       prologue))
+		   *all-method-code-prologues*))))
+
+(define (bump-invocation-count! prologue method)
+  (let ((invocation-count (+ (vector-ref prologue 0) 1)))
+    (vector-set! prologue 0 invocation-count)
+    (if (>= invocation-count *recompilation-count-limit*)
+	(begin
+	  (vector-set! prologue 0 0)
+	  (recompile-method! method)))))
+
+(define compile-ThiNG
+  (let ()
+    (define (do-ref cenv state name)
+      (let* ((name (string->symbol name)))
+	(values (cond ((memq name cenv) `#(local ,name))
+		      (else `#(global ,name)))
+		state)))
+
+    (define (compile-tuple cenv state exprs)
+      (let loop ((exprs exprs)
+		 (state state)
+		 (acc '()))
+	(if (null? exprs)
+	    (values (list->vector (reverse acc)) state)
+	    (let*-values (((instr state) (compile cenv state (car exprs))))
+	      (loop (cdr exprs)
+		    state
+		    (cons instr acc))))))
+
+    (define (do-send cenv state selector exprs)
+      (let-values (((selector) (string->symbol selector))
+		   ((instrs state) (compile-tuple cenv state exprs)))
+	(values `#(send ,selector ,instrs)
+		state)))
+
+    (define (do-block cenv state binders statements)
+      (let* ((block (clone-object *block*))
+	     (num-formals (length binders))
+	     (formals (map string->symbol binders))
+	     (formal-cenv (append (cons '_ formals) cenv))
+	     (selector (if (zero? num-formals)
+			   'do
+			   (string->symbol
+			    (string-concatenate (cons "applyWith:"
+						      (make-list (- num-formals 1) "with:")))))))
+	(let*-values (((instr block-state)
+		       (compile formal-cenv (make-compilation-state)
+				`(scope ,*nil* ,statements)))
+		      ((litvec) (finish-compilation-state block-state))
+		      ((method) (define-method! selector (cons '_ formals) (list block)
+				  (instruction->code instr #t)))
+		      ((block-index state) (push-literal state block)))
+	  (set-slot! method 'literals litvec)
+	  (values `#(closure ,block-index)
+		  state))))
+
+    (define (do-scope cenv state name statements)
+      (if (eq? *nil* name)
+	  (let-values (((instrs state) (compile-statements cenv state statements)))
+	    (values `#(begin ,instrs)
+		    state))
+	  (let*-values (((name) (string->symbol name))
+			((instrs state) (compile-statements (cons name cenv) state statements)))
+	    (values `#(scope ,name ,instrs)
+		    state))))
+
+    (define (do-literal cenv state val)
+      (let-values (((index state) (push-literal state val)))
+	(values `#(literal ,index)
+		state)))
+
+    (define (do-update cenv state template-expr updates)
+      (let*-values (((template-instr state) (compile cenv state template-expr))
+		    ((updates state)
+		     (let loop ((updates updates)
+				(state state)
+				(acc '()))
+		       (if (null? updates)
+			   (values (list->vector (reverse acc)) state)
+			   (let*-values (((update) (car updates))
+					 ((update-instr state)
+					  (compile cenv state (caddr update))))
+			     (loop (cdr updates)
+				   state
+				   (cons (vector (car update)
+						 (string->symbol (cadr update))
+						 update-instr)
+					 acc)))))))
+	(values `#(update ,template-instr ,updates)
+		state)))
+
+    (define (do-tuple cenv state exprs)
+      (let-values (((instrs state) (compile-tuple cenv state exprs)))
+	(values `#(tuple ,instrs)
+		state)))
+
+    (define (do-resend cenv state)
+      (values `#(resend)
+	      state))
+
+    (define (do-method cenv state pattern statements)
+      (let* ((selector (string->symbol (cadr pattern)))
+	     (params (caddr pattern))
+	     (formals (map (lambda (entry) (string->symbol (or (non-*false*? (car entry))
+							       "_")))
+			   params)))
+	(let*-values (((specializer-instrs state)
+		       (compile-tuple cenv state (map (lambda (entry)
+							(let ((exp (cadr entry)))
+							  (if (non-*false*? exp)
+							      exp
+							      `(ref "NoRole"))))
+						      params)))
+		      ((body-instr method-state)
+		       (compile formals (make-compilation-state) `(scope ,*nil* ,statements)))
+		      ((method-litvec) (finish-compilation-state method-state)))
+	  (values `#(method ,selector ,formals ,specializer-instrs
+			    ,(instruction->code body-instr #f)
+			    ,method-litvec)
+		  state))))
+
+    (define (compile-statement cenv state statement)
+      (if (and (pair? statement)
+	       (eq? (car statement) 'let))
+	  (let* ((name (string->symbol (cadr statement)))
+		 (expr (caddr statement))
+		 (newenv (cons name cenv)))
+	    (let-values (((instr state) (compile newenv state expr)))
+	      (values `#(bind ,name ,instr)
+		      newenv
+		      state)))
+	  (let-values (((instr state) (compile cenv state statement)))
+	    (values instr cenv state))))
+
+    (define (compile-statements cenv state statements)
+      (let loop ((cenv cenv)
+		 (state state)
+		 (statements statements)
+		 (acc '()))
+	(if (null? statements)
+	    (values (list->vector (reverse acc))
+		    state)
+	    (let-values (((instr cenv state) (compile-statement cenv state (car statements))))
+	      (loop cenv
+		    state
+		    (cdr statements)
+		    (cons instr acc))))))
+
+    (define (compile cenv state ast)
+      (debug 1 "compile "ast" "cenv)
+      (cond
+       ((pair? ast)
+	(apply (cond
+		((assq (car ast) `((ref ,do-ref)
+				   (send ,do-send)
+				   (block ,do-block)
+				   (scope ,do-scope)
+				   (string ,do-literal)
+				   (symbol ,do-literal)
+				   (number ,do-literal)
+				   (update ,do-update)
+				   (tuple ,do-tuple)
+				   (resend ,do-resend)
+				   (method ,do-method)
+				   )) => cadr)
+		(else (error "Unknown ast kind" ast)))
+	       cenv state
+	       (cdr ast)))
+       (else (error "Non-pair ast" ast))))
+
+    (lambda (ast)
+      (let-values (((instr state) (compile '() (make-compilation-state) ast)))
+	(values instr
+		(finish-compilation-state state))))))
+
+(define (instruction-vector-size seed instr-vec)
+  (vector-fold (lambda (instr acc) (+ (instruction-size instr) acc)) seed instr-vec))
+
+(define (instruction-size instr)
+  (case (vector-ref instr 0)
+    ((local global closure literal resend) 1)
+    ((send) (instruction-vector-size 1 (vector-ref instr 2)))
+    ((begin) (instruction-vector-size 0 (vector-ref instr 1)))
+    ((scope) (instruction-vector-size 0 (vector-ref instr 2)))
+    ((update) (instruction-vector-size 1 (vector-ref instr 2)))
+    ((tuple) (instruction-vector-size 1 (vector-ref instr 1)))
+    ((method) 1) ;; not quite correct, but mneh. until the macro is expanded properly, will do.
+    (else (error "Illegal instruction in instruction-size" instr))))
+
+(define (recompile-method! method)
+  (let ((instr (cdr (get-slot method 'code))))
+    (pretty-print `(recompile-method!
+		    (size ,(instruction-size instr))
+		    (instr ,instr)))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/CoreTalk	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,366 @@
+[comment -*- outline -*- ]
+[html <div class="essay_body">]
+
+*** A process language with locations and reflection
+
+**** The Process Calculus
+
+Locations are nested, as in the distributed join calculus
+("Join"). Locations and channels are identified (unlike in
+Join). Channels/locations are restricted with normal scope
+extrusion. Communication happens between locations transparently - any
+unguarded receive and any unguarded send on the same channel will
+occur, no matter the structure of the locations involved.
+
+The main challenge at the moment is to come up with a notion of
+definition site for a channel, so that we have a known location for
+sent messages to migrate to. This is where Join can help out: each
+Join definition both provides a location and a receiver
+definition. The Chemical Abstract Machine semantics for Join provides
+two equivalent views of a collection of processes, one in which the
+hierarchic nesting of locations is reflected in the syntax, and one in
+which each location is shown in a flat multiset of locations, with the
+[i path] to each location annotating the location:
+
+@code
+  m[n[P] | Q] | o[n[R]]		(hierarchy shown)
+
+  P@mn | Q@m | R@on		(exposed processes shown)
+,
+Locations are the unit of reflection granularity. Locations can be
+lifted to a description of the corresponding collection of processes,
+and such a description can be dropped to instantiate the described
+processes. Locations are written
+
+@code
+  m[P]
+
+where 'm' is a channel acting as a 'location tag' for this location.
+
+Processes P, Q:
+
+@code
+	0		stop
+	(x)P		new
+	P | Q		parallel composition
+	µA.P		process variable binding
+	A		process variable reference
+	x<M>		output
+	x(M).P		input
+	x[P]		location
+	lift x		lift
+	drop x		drop (aka eval)
+
+Messages M are a possibly empty sequence of names.
+
+Structural equivalence:
+
+@code
+  m[P] | m[Q]   ===   m[P | Q]
+      m[x<M>]   ===   x<M>
+    m[lift x]   ===   lift x
+         m[0]   ===   0
+
+Reduction:
+
+@code
+      m not used as a location tag in Q
+  -------------------------------------------
+    m[P] | Q | lift m   -->   Q | LIFT(m,P)
+
+where LIFT(m,P) expands into a process description of the process P,
+the channel for interfacing to which is placed on the channel m.
+
+
+@code
+       P   -->   P'
+  ----------------------
+    m[P]   -->   m[P']
+
+@code
+  --------------------------
+    drop x   -->   DROP(x)
+
+where DROP(x) expands into a process which examines the process
+description of a process P that answers to requests on channel x, and
+instantiates P.
+
+Note that lift and drop are asymmetric: lift collects the description
+for an entire location, but drop instantiates the provided description
+into the current location.
+
+Note also that output and lift are continuationless and may freely
+move between locations, where input and drop have continuations
+(implicit, in the case of drop) and may not leave the confines of
+their location. Messages (names) are thus mobile, while processes are
+immobile without explicit use of lift and drop.
+
+
+**** Uses of Lift
+
+Lift can be used to interrupt a running collection of processes for
+inspection in an interactive debugger:
+
+@code
+  m[P] | lift m | m(p).debuggerFactory<"breakpoint",p>
+
+Lift can (sort-of) be used for error handling - each location can be
+used as a 'catch' to which the error condition is 'thrown':
+
+@code
+  m[P | m<"error description">]  |  m(e).(lift m | m(p).debuggerFactory<e,p>)
+
+Nested handlers can be defined:
+
+@code java
+  try {
+    CODE
+  } catch (e, p) {
+    HANDLER
+  }
+
+becomes:
+
+@code
+  (exn)( exn[CODE] | exn(e).(lift exn | exn(p).HANDLER) )
+
+so long as
+
+@code java
+  throw e
+
+is encoded as
+
+@code
+  exn<e>
+
+for the innermost defined 'exn' name. See below for some problems with
+this approach.
+
+**** Variants and challenges
+
+***** Try/Finally clauses
+
+"try/finally" clauses are a challenge, since [code m[0] === 0] and we
+want to detect when [code m[]] has 'stopped'. One way around it might
+be to change the syntax for processes to have instead
+
+@code
+	x[P].Q
+
+for locations, with an altered structural equivalence:
+
+@code
+  m[P].Q | m[P'].Q'   ===   m[P | P'].(Q | Q')
+          m[x<M>].P   ===   m[0].P | x<M>
+        m[lift x].P   ===   m[0].P | lift x
+             m[0].P   =/=   0   (this rule is replaced by a new reduction relation)
+
+and altered reduction rules:
+
+@code
+         m not used as a location tag in Q
+  -------------------------------------------------
+    m[P].P' | Q | lift m   -->   Q | LIFT(m,P,P')
+
+where LIFT(m,P,P') expands into a process description of the processes
+P and P', the channels for interfacing to which (p and p'
+respectively) are placed on the channel m as: [code m<p,p'>]
+
+
+@code
+         P   -->   P'
+  --------------------------
+    m[P].Q   -->   m[P'].Q
+
+
+@code
+    m not used as a location tag in Q
+  -------------------------------------
+        m[0].P | Q   -->   P | Q
+
+***** Dynamic environments
+
+The current exception handler ('exn' above) is a dynamically-scoped
+entity in most languages, but in the discussion of error-handling
+above it is [i lexical] since there is no clear notion of dynamic
+scope. This is unacceptable for use as an error-reporting mechanism.
+
+Note that the current continuation is a dynamic entity as well! Since
+the current continuation is explicitly passed around in encodings of
+lambda calculi into π, there's nothing stopping us passing around
+arbitrary other dynamic entities at the same time, so long as our
+encoding is uniform. This would give rise to a [code
+call-with-current-exception-handler] by analogy with [code
+call-with-current-continuation].
+
+Traditional continuation-passing-style:
+
+@code scheme
+  (lambda (x) (+ x 1))   -->   (lambda (k x) (+ k x 1))
+
+Extended continuation-and-exception-handler-passing-style:
+
+@code scheme
+  (lambda (x) (+ x 1))   -->   (lambda (k h x) (+ k h x 1))
+
+This could be generalised to a (perhaps implicit at the implementation
+level) collection of arbitrary dynamic state.
+
+***** Error or exception reporting, revisited
+
+A dynamic-extent error-reporting channel can be combined with the use
+of [code lift] to give a more acceptable form of exception
+handling. When throwing an exception, care must be taken to select an
+appropriate channel; procedural code can use [code
+call-with-current-error-channel] of course, but raw process code needs
+to be more explicit about the target of the thrown exception.
+
+There are still a few issues: "stack traces" are still missing from
+the picture, for instance. An exception thrown by some library code in
+a different lexical scope will have to be careful to provide
+self-describing restarts as part of the error report message sent down
+the error-reporting channel at the time of the throw. This is
+straightforward in a procedural situation, but in the general case it
+is less obvious how to do this.
+
+One approach might be for each ongoing computation to be partitioned
+into a fresh location:
+
+@code
+  µLOOP .
+    service(k,h,message) .
+      LOOP |
+      (loc) loc[ BODY OF SERVICE |
+                 h<"error description", k, loc> ])
+
+When an error is signalled, the location can be passed (with some
+suitable self-describing convention) along with the error report to
+the waiting handler on the other side of the report channel. The
+location need not be lifted at the time of the throw; whether it was
+lifted at all might be a policy decision made by the error-report
+receiver at the other side. Often the location might be lifted into
+the debugger along with the location that sent the message to the
+library code that caught the error.
+
+***** Capabilities
+
+Channels, so long as they are unforgeable, can be used as capabilities
+in a few different ways. One relies on an equivalence relation between
+names and a comparison process
+
+@code
+  [x=y]{P,Q}
+
+which reduces to [code P] if [code x] and [code y] are the same name,
+and [code Q] otherwise. Names (without processes attached to them
+necessarily) can then be used as permissions.
+
+The dynamic environment idea detailed above can then be used to carry
+around a collection of permissions. A function [code
+call-with-current-permission-map] can be provided, allowing a dynamic
+permissions check in server code. Some means of replacing the current
+permission map within a piece of code can also be provided, allowing
+code to enlarge or reduce its permission map within some scope.
+
+***** A variation on comm
+
+The current comm rules (implied above) are not well pinned down since
+there's a structural equivalence rule equating [code m[x<M>]] with
+[code x<M>]. This means that [code lift m] may or may not capture the
+output on [code x].
+
+We need some way of forcing unguarded sends out of a location at the
+time of lifting that location. One way to approach that might be to
+redefine the lift operation to partition the location's contents:
+
+@code
+         m not used as a location tag in Q
+       no sends on any channel unguarded in P
+  -------------------------------------------------
+    m[P].P' | Q | lift m   -->   Q | LIFT(m,P,P')
+
+[b Alternative:] there are still problems, since now outputs are
+opaque to the reflection primitive, lift. A better way might be to try
+to attach the output messages to the restriction itself, thus
+modelling the message queue directly. The problem then is making any
+unguarded inputs find the messages from the relevant restriction!
+
+***** Dynamic Environments of a different kind
+
+To get lookup on "local services" (eg. java.lang.String etc) perhaps
+lift and drop should be augmented with a second argument: ports equal
+(via name equality) to this argument would be replaced with a special
+piece of syntax in the lift, and in the drop, the special piece of
+syntax would be replaced with the value of the argument. This lets you
+provide eg. a sandbox environment or whatever.
+
+
+**** Integrating lambda with π
+
+See also the "blue calculus" by G. Boudol.
+
+Thinking about evaluating Scheme using an operational semantics:
+evaluate each position in a combination until the positions are values
+rather than expressions. Then apply the combination.
+
+@code scheme
+  (let ((x (lambda (y) (+ y 1))))
+    (x (x 2)))
+  ;==> macroexpands to
+  ((lambda (x) (x (x 2)))
+   (lambda (y) (+ y 1)))
+  ;-->
+  ((lambda (y) (+ y 1)) ((lambda (y) (+ y 1)) 2))
+  ;-->
+  ((lambda (y) (+ y 1)) (+ 2 1))
+  ;-->
+  ((lambda (y) (+ y 1)) (#<primitive+> 2 1))
+  ;-->
+  ((lambda (y) (+ y 1)) 3)
+  ;-->
+  (+ 3 1)
+  ;-->
+  (#<primitive+> 3 1)
+  ;-->
+  4
+
+***** Syntax
+
+Recommend an A-normal form - [code let x = M N in x] (??) - to provide
+linear form. Note that's a let, not a letrec. I guess this is pretty
+similar to Boudol's Blue Calculus?
+
+Also, how about Matthias' well-formedness constraint to ensure
+appropriate use of input capability? How does the input capability
+move with lift and drop? Does the location for the port move with the
+process??
+
+Processes P, Q:
+
+@code
+	0		stop
+	(x)P		new
+	P | Q		parallel composition
+	µA.P		process variable binding
+	A		process variable reference
+	x<M>		output
+	x(M).P		input
+	x[P].Q		location
+	lift x		lift
+	drop x		drop (aka eval)
+
+Messages <M>:
+
+Bindings (M):
+
+Expressions E, F:
+
+Values V, W are 
+
+The rules, then, are
+
+@code
+  \x . 
+
+[html </div>]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/Joinable	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,38 @@
+---------------------------------------------------------------------------
+processes P,Q,R:
+	x<M>		asynchronous message
+	def D in P	local definition
+	P | Q		parallel composition
+	0		inert process
+
+definitions D:
+	J -> P		reaction rule
+	D ^ D'		composition
+	top		void definition
+
+join patterns J:
+	x<M>		message pattern
+	J | J'		synchronization
+
+Figure 1. Syntax for the core join calculus
+---------------------------------------------------------------------------
+
+
+And now we hack on it:
+
+
+processes P,Q,R:
+	x<M>		asynchronous message
+	def D in P	local definition
+	P | Q		parallel composition
+	0		inert process
+
+definitions D:
+	J -> P		reaction rule
+	D ^ D'		composition
+	top		void definition
+
+join patterns J:
+	x<M>		message pattern
+	J | J'		synchronization
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/Makefile	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,11 @@
+%.ps: %.dot
+	dot -Tps $< > $@
+
+%.dot: %.dot.m4
+	m4 dotmacros.m4 $< > $@
+
+%.view: %.ps
+	gv $<
+
+%.edit: %.ps
+	gimp $<
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/SimplestThingThatCouldWork.txt	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,35 @@
+-*- outline -*-
+
+*By version:
+
+**Version 0
+
+***Calculus
+
+***Virtual machine
+
+Probably hacked together in Scheme or some such.
+
+**Version 1
+
+***Virtual machine
+
+****Bytecode
+
+****Bytecode compiler
+
+***Object-oriented language
+
+***I/O
+
+***REPL
+
+***Debugger
+
+***Inspector
+
+**Beyond
+
+***Graphics toolkit
+
+***User interface toolkit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/TODO	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,16 @@
+*** Challenges
+
+ - a definition location for messages to travel to (SOLVED by use of
+   blue calculus with DCHAM-style joinish formulation)
+
+   - model the STORE - this gives nice properties for forwarders,
+     garbage-collection-modelling, forces thought about exception
+     handling and runtime-failure etc etc.
+
+ - a way of lifting all locations with a particular channel in their
+   path (unknown)
+
+ - a means of dynamically scoping certain names, eg. class definitions
+   ("String") and helpers ("MEMOIZE", "ST80DISPATCH")
+
+   - investigate KLAIM - they may have some possible solutions.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/ThiNG-kernel.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,50 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme default
+\graphics default
+\paperfontsize default
+\papersize Default
+\paperpackage a4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+
+\layout Standard
+
+
+\begin_inset Float figure
+wide false
+collapsed false
+
+\layout Standard
+
+
+\begin_inset Graphics
+	filename kernel-graph.ps
+	width 60page%
+	keepAspectRatio
+
+\end_inset 
+
+
+\layout Caption
+
+The ThiNG Kernel
+\end_inset 
+
+
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/dotmacros.m4	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,34 @@
+dnl---------------------------------------------------------------------------
+dnl Basic macros
+dnl---------------------------------------------------------------------------
+dnl
+define(`_Node', `"$1"ifelse($#,1,,` [shift($@)]')')dnl
+define(`_Link', `"$1" -> "$2"ifelse($#,2,,` [shift(shift($@))]')')dnl
+dnl
+define(`_Label', `$1, label="$2"')
+dnl
+define(`_Subgraph', `subgraph cluster_$1 { shift($@) }')dnl
+dnl
+dnl---------------------------------------------------------------------------
+dnl Styles
+dnl---------------------------------------------------------------------------
+dnl
+define(`_Process', `_Node($*, shape=box)')dnl
+define(`_Datastore', `_Node($*, shape=ellipse)')dnl
+define(`_External', `_Node($*, shape=box, style=filled)')dnl
+dnl
+define(`_BoldLink', `_Link($*, style=bold)')dnl
+define(`_DotLink', `_Link($*, style=dotted)')dnl
+define(`_DashLink', `_Link($*, style=dashed)')dnl
+dnl
+dnl---------------------------------------------------------------------------
+dnl Prototypes and Traits
+dnl---------------------------------------------------------------------------
+dnl
+define(`_proto', `_Node(pr_$*, label="$1", shape=ellipse)')dnl
+define(`_traits', `_Node(tr_$*, label="tr. $1", shape=box, style=filled)')dnl
+define(`_delegate', `_Link($1, $2, label="$3", style=bold)')dnl
+define(`_slot', `_Link($1, $2, label="$3")')dnl
+define(`_simple', `_proto($1); _delegate(pr_$1, tr_$1, traits)')dnl
+define(`_simple2', `_proto($1); _delegate(pr_$1, tr_$2, traits)')dnl
+define(`_oddball', `_simple2($1, Oddball)')dnl
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/historical/core.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,80 @@
+"-*- slate -*-"
+
+! [ :expr :tblock :fblock | tblock value ]
+    primDefineMethod: #ifTrue:ifFalse at: { True. Method. Method } !
+
+! ctxt( ctxt globals: (ctxt globals 
+
+[ :self :path :value |
+  (path primDelegatesTo: Symbol)
+    ifTrue:  [ self primAt: path put: value ]
+    ifFalse: [
+      key = path key.
+      rest = path value.
+      ((self primAt: key) == Nil)
+        ifTrue: [ self primAt: key put: EmptyNamespace
+
+! ctxt( ctxt globals: (ctxt globals 
+
+"---------------------------------------------------------------------------"
+" experimental refs "
+!Namespaces addGlobal: #Counter value: (count:= Nil)!
+!Method named: #new at: { #c -> Counter }!
+  (c count:= 0 ref)
+!
+!Method named: #next at: { #c -> Counter }!
+  c count -> [ :value | c count <- value + 1 . value ]
+!
+
+"---------------------------------------------------------------------------"
+" state on methods "
+!Namespaces addGlobal: #Counter value: (generator:= Nil)!
+!Method named: #new at: { #c -> Counter }!
+  (c generator:= !!(v:=0) [ !!(v:=v + 1). v ])
+!
+!Method named: #next at: { #c -> Counter }!
+  (c generator value)
+!
+
+"---------------------------------------------------------------------------"
+!Namespaces addGlobal: #Cell value: (state:= Nil)!
+!Method named: #newWith: at: { #c -> Cell. #v -> NoRole }!
+  (c state:= !!(v:=v) [ :f | !!(v:= f value: v). v ])
+!
+!Method named: #get at: { #c -> Cell }!
+  c state value: [ :v | v ]
+!
+!Method named: #update: at: { #c -> Cell. #f -> Method }!
+  c state value: f
+!
+!Method named: #set: at: { #c -> Cell. #v -> NoRole }!
+  c state value: [ :old | v ]
+!
+
+"---------------------------------------------------------------------------"
+
+!Method named: #doSomething at: { Nil -> Something }!
+  ctxt (
+    importantCondition ifTrue: [ Exception raise: 'oh no!'. ].
+    otherCondition ifTrue: [ ctxt return: 3 ].
+    4
+  )
+!
+
+
+!Method named: #computeFibNotifying: at: { #n -> Integer. #k -> Method }!
+  [ k (n fib) ] fork
+!
+
+
+!Method named: #fork at: { #m -> Method }!
+  ctxt (
+    ctxt fork: m.
+    Nil
+  )
+!
+
+
+!Method named: #fib at: { #n -> Integer }!
+  n < 2 ifTrue: [ n ] ifFalse: [ (n - 1) fib + (n - 2) fib ]
+!
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/historical/experimental-keyword-syntax.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,202 @@
+"-*- slate -*-"
+
+addGlobal @ (loc := Location traits name := Symbol traits value := _)
+[
+  gg := Globals.
+  read(cell := gg block := [ :g |
+    write(cell := gg
+          value := withSlot(obj := g name := name value := value))
+  ]).
+].
+
+"-*-*-*- Nope, I don't like it, I think."
+
+l@(Location traits) addGlobal: name@(Symbol traits) value: val
+[
+  gg := Globals. "look up global 'Globals' outside the block, otherwise we deadlock"
+  gg --> [ :g | gg <-- (g withSlot: name value: val) ].
+  val
+].
+
+"Make globals delegate to Oddball."
+( gg := Globals. ob := Oddball traits.
+  gg --> [ :g | gg <-- (g traits:* ob) ] ).
+
+g@(Globals peek) as: _@(String traits) [ 'Globals' ].
+
+val@(Root traits) ref
+[
+  c := Cell new.
+  c <-- val.
+  c
+].
+
+c@(Cell traits) read
+[
+  p --> [ :v | v ]
+].
+
+c@(Cell traits) update: block
+[
+  c --> [ :v | c <-- (block applyWith: v) ]
+].
+
+c@(Cell traits) push: value
+[
+  c update: [ :cdr | value -> cdr ]
+].
+
+block@(Block traits) fork
+[
+  here ( here fork: block. )
+].
+
+block@(Block traits) loop
+[
+  loop := [ block do. loop do. ].
+  loop do.
+].
+
+p@Nil reverse [ Nil ].
+p@(Pair traits) reverse [
+  loop := [ :p :acc | p  ifNil: [ acc ] ifNotNil: [ loop applyWith: p value with: p key -> acc ] ].
+  loop applyWith: p with: Nil
+].
+
+n1@(Number traits) to: n2@(Number traits) do: block@(Block traits) [
+  loop := [ :n | (n <= n2) ifTrue: [ block applyWith: n. loop applyWith: n + 1 ] ].
+  loop applyWith: n1
+].
+
+_@True ifTrue: b@(Block traits) [ b do ].
+_@False ifTrue: b@(Block traits) [].
+
+_@True ifFalse: b@(Block traits) [].
+_@False ifFalse: b@(Block traits) [ b do ].
+
+_@True ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b1 do ].
+_@False ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b2 do ].
+
+_@Nil ifNil: b1@(Block traits) ifNotNil: b2@(Block traits) [ b1 do ].
+_@(Root traits) ifNil: b1@(Block traits) ifNotNil: b2@(Block traits) [ b2 do ].
+
+_@Nil ifNil: b@(Block traits) [ b do ].
+_@(Root traits) ifNil: b@(Block traits) [].
+
+_@Nil ifNotNil: b@(Block traits) [].
+_@(Root traits) ifNotNil: b@(Block traits) [ b do ].
+
+p@Nil concatenate [ Nil ].
+p@(Pair traits) concatenate [
+  p value
+    ifNil: [ p key ]
+    ifNotNil: [ p key, p value concatenate ]
+].
+
+s1@(String traits) , s2@(String traits)
+[
+  s1 primStringAppend: s2
+].
+
+t@(Tuple traits) printString
+[
+  p := Nil ref.
+  p push: '{'.
+  0 to: (t size - 1) do: [ :index |
+    (index = 0) ifFalse: [ p push: '. ' ].
+    p push: (t at: index) printString.
+  ].
+  p push: '}'.
+  p read reverse concatenate
+].
+
+"I am a parallel map."
+p@Nil map: block [ Nil ].
+p@(Pair traits) map: block [ (block applyWith: p key) -> (p value map: block) ].
+
+"I am a sequential map."
+p@Nil mapInOrder: block [].
+p@(Pair traits) mapInOrder: block [
+  h := (block applyWith: p key).
+  h -> (p value mapInOrder: block)
+].
+
+"I am a sequential for-each."
+p@Nil do: block [].
+p@(Pair traits) do: block [ block applyWith: p key. p value do: block ].
+
+"I am a parallel for-each."
+p@Nil doInParallel: block [].
+p@(Pair traits) doInParallel: block [ [block applyWith: p key] fork. p value doInParallel: block ].
+
+p@(Pair traits) printString
+[
+  '(', p key printString, ' -> ', p value printString, ')'
+].
+
+s@(Symbol traits) printString [ '#', resend ].
+
+_@(Globals peek) shutDownImage
+[
+  ShutdownHooks peek do: [ :hook | hook shutDown do. ].
+  'BOOTSTRAP.image' saveImage.
+  primQuit.
+].
+
+"---------------------------------------------------------------------------"
+
+"
+[
+  ({1. 2. 3. #four} -> ('Hello, world, from ThiNG!' -> (True -> (123 -> ((#a -> #b) -> Nil)))))
+  do: [ :each |
+    each printOn: Console.
+    Console crlf.
+  ].
+] fork.
+"
+
+here (
+  here addGlobal: #TraitsTraits value: (Root traits traits). "!!"
+
+  t := (name := 'ReplServer' traits :* TraitsTraits).
+  here addGlobal: #ReplServer value: (traits :* t serverSocket := Nil).
+).
+
+rs0@(ReplServer traits) newOnPort: port@(Number traits)
+[
+  rs := (rs0 serverSocket := port primListen).
+  [ rs acceptLoop ] fork.
+].
+
+rs@(ReplServer traits) acceptLoop
+[
+  [
+    sock := rs serverSocket accept.
+    sock ifNotNil: [ [ rs replOn: sock ] fork. ].
+  ] loop.
+].
+
+rs@(ReplServer traits) replOn: sock
+[ session (
+  'Welcome to ThiNG!\n' printOn: sock.
+  [
+    'ThiNG> ' printOn: sock.
+    compilationResult := sock compileOneStatement.
+    compilationResult key
+      ifTrue: [ compilationResult value do printOn: sock. ]
+      ifFalse: [
+        'PARSE ERROR\n' printOn: sock.
+        compilationResult value printOn: sock.
+        sock close.
+        session return: Nil.
+      ].
+    '\n' printOn: sock.
+  ] loop.
+)].
+
+here (
+  here addGlobal: #ShutdownHooks value: Nil ref.
+  ShutdownHooks push: (shutDown:=[] startUp:=[ ReplServer newOnPort: 4444 ]).
+  here addGlobal: #BootBlock value: [ ShutdownHooks peek do: [ :hook | hook startUp do. ] ].
+  shutDownImage.
+).
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/historical/test.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,46 @@
+"-*- slate -*-"
+
+Namespaces addGlobal: #Counter value: (generator:= Nil).
+
+loop(count:= 0) [ ^ count. loop(count:= count + 1). ].
+
+[ :a :b | c = a + b. ^ c. ].
+
+[ :a :b | ^ (a + b). ].
+
+_@(Integer traits) ++ _@(Integer traits)
+[
+  'ho ho ho'
+].
+
+a@(Integer traits) plus: b@(Integer traits)
+[
+  ^ a + b.
+].
+
+c@Counter new
+[
+  "a comment"
+  'a string'.
+  generator = loop(count:= 0) [ ^ count. loop(count:= count + 1) ].
+  ^ (c generator:= generator).
+].
+
+c@Counter next
+[
+  1 + 2 plus: 3 + 4 .
+  ^ (c generator value).
+].
+
+_@True ifTrue: block@(Block traits) [ ^ block value ].
+_@False ifTrue: block@(Block traits) [ ^ False ].
+_@True ifFalse: block@(Block traits) [ ^ True ].
+_@False ifFalse: block@(Block traits) [ ^ block value ].
+
+_@True ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ ^ b1 value ].
+_@False ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ ^ b2 value ].
+
+[ results = Array with: 29 fib with: 30 fib with: 31 fib.
+  Console printLn: (results at: 0).
+  Console printLn: (results at: 1).
+]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/hll.experiments	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,74 @@
+-*- slate -*-
+
+(to (handle-event (e (mouse-button-down (events sdl))))
+    (let ((s2 (render-text-blended (system-font sdl)
+				   "(click)"
+				   (make (color sdl) 255 255 255))))
+      (blit s2
+	    (nil (rect sdl))
+	    (video-surface sdl)
+	    (make (rect sdl) (x e) (y e) 0 0))
+      (free s2)
+      (flip (video-surface sdl))
+      (resend)))
+
+[ counter:= 0 | ->. ^ counter. counter:= counter + 1 ]
+
+
+[ -> a b. c = a + b. ^ c. ]
+
+[ -> a b. ^ (a + b). ]
+
+
+! e@(SDL EventTraits MouseButtonDown) handle !
+
+  s2 = SDL SystemFont renderText: "(click)" color: (SDL Color White).
+  s2 blitOn: SDL VideoSurface location: (SDL Rectangle x:= e x y:= e y).
+  s2 free.
+  SDL VideoSurface flip.
+  ^ resend.
+!!
+
+addGlobal: #Counter value: (generator:= Nil).
+
+! c@Counter new !
+  generator = [ loop(count:= 0) { ->. ^ count. loop(count:= count + 1) } ].
+  ^ (c generator:= generator).
+!!
+
+! c@Counter next !
+  ^ (c generator <- ).
+!!
+
+
+! _@0 isEven ! ^ True.  !!
+! _@0 isOdd  ! ^ False. !!
+
+! i@(Integer traits) isEven ! ^ (i - 1) isOdd.  !!
+! i@(Integer traits) isOdd  ! ^ (i - 1) isEven. !!
+
+
+{
+  x = y ifTrue: [
+}
+
+
+"---------------------------------------------------------------------------"
+
+loop(count:= 0) [ ^ count. loop(count:= count + 1). ].
+
+[ :a :b | c = a + b. ^ c. ]
+
+[ :a :b | ^ (a + b). ]
+
+addGlobal: #Counter value: (generator:= Nil).
+
+! c@Counter new !
+  generator = loop(count:= 0) [ ^ count. loop(count:= count + 1) ].
+  ^ (c generator:= generator).
+!!
+
+! c@Counter next !
+  ^ (c generator value).
+!!
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/hll.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,82 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme default
+\graphics default
+\paperfontsize default
+\papersize Default
+\paperpackage a4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+The ThiNG High-Level Language
+\layout Author
+
+Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
+\layout Date
+
+18 November, 2004
+\layout Standard
+
+
+\begin_inset Float figure
+wide false
+collapsed false
+
+\layout Standard
+
+
+\begin_inset Formula \begin{eqnarray*}
+\textrm{exp} & \leftarrow & \textrm{(lambda var exp)}\\
+ &  & \textrm{(exp exp)}\\
+ &  & \textrm{(if exp exp exp)}\\
+ &  & \textrm{var}\\
+ &  & \textrm{(set! var exp)}\end{eqnarray*}
+
+\end_inset 
+
+
+\layout Caption
+
+Core Scheme
+\end_inset 
+
+
+\begin_inset Float figure
+wide false
+collapsed false
+
+\layout Standard
+
+
+\begin_inset Formula \begin{eqnarray*}
+\textrm{exp} & \leftarrow & \textrm{(selector exp exp ...)}\\
+ &  & \textrm{[ :var | exp ... ]}\\
+\\\\\end{eqnarray*}
+
+\end_inset 
+
+
+\layout Caption
+
+Core ThiNG
+\end_inset 
+
+
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/kernel-graph.dot.m4	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,57 @@
+digraph SlateKernel {
+	_traits(Root); _simple(Root);
+
+	_Node(tr_Traits, label="tr. Traits", shape=box);
+	_delegate(tr_Traits, tr_Root, root);
+
+	_traits(Oddball); _simple(Oddball);
+	_delegate(tr_Oddball, tr_Root, root);
+
+	_traits(Character);
+	_delegate(tr_Character, tr_Oddball, oddball);
+
+	_traits(Symbol);
+	_delegate(tr_Symbol, tr_Oddball, oddball);
+
+	_oddball(nil);
+	_oddball(NoRole);
+
+	_traits(Boolean);
+	_delegate(tr_Boolean, tr_Oddball, oddball);
+	_simple2(True, Boolean);
+	_simple2(False, Boolean);
+
+	_traits(Derivable); _simple(Derivable);
+	_delegate(tr_Derivable, tr_Root, root);
+
+	_traits(Cloneable); _simple(Cloneable);
+	_delegate(tr_Cloneable, tr_Derivable, derivable);
+
+	_traits(Number); _simple(Number);
+	_delegate(tr_Number, tr_Derivable, derivable);
+
+	_traits(Integer);
+	_delegate(tr_Integer, tr_Number, number);
+
+	_traits(Float);
+	_delegate(tr_Float, tr_Number, number);
+
+	_traits(Array);
+	_delegate(tr_Array, tr_Cloneable, collection);
+
+	_traits(ByteArray);
+	_delegate(tr_ByteArray, tr_Cloneable, collection);
+
+	_traits(WordArray);
+	_delegate(tr_WordArray, tr_Cloneable, collection);
+
+	_traits(String);
+	_delegate(tr_String, tr_Cloneable, collection);
+
+	_traits(Method); _simple(Method);
+	_delegate(tr_Method, tr_Cloneable, cloneable);
+	_slot(pr_Method, [code], code);
+	_slot(pr_Method, [arguments], arguments);
+	_slot(pr_Method, [accessor], accessor);
+	_slot(pr_Method, [selector], selector);
+}
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/layers.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,96 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme default
+\graphics default
+\paperfontsize default
+\papersize Default
+\paperpackage a4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+Layering Functionality in ThiNG
+\layout Standard
+
+To begin with, we're going to have a simple interpreter of ThiNG code.
+ All the advanced features will come in later revisions - we may even bootstrap
+ before we've implemented some of them!
+\layout Standard
+
+The features we're particularly interested in include:
+\layout Itemize
+
+Reflection
+\layout Itemize
+
+Locations
+\layout Itemize
+
+Transactions + Exceptions
+\layout Itemize
+
+Concurrency
+\layout Itemize
+
+Object Orientation
+\layout Itemize
+
+Distribution
+\layout Standard
+
+Reflection comes in three flavours, for ThiNG: behavioural, structural,
+ and lexical.
+ Behavioural reflection will be planned for but not actually implemented
+ in the first few iterations.
+ Structural reflection is a must - generic treatment of objects is required
+ for definition of useful tools such as object explorers etc.
+ Lexical reflection can wait until we need it for transactions and distribution.
+\layout Standard
+
+Locations are important - they are what, in ThiNG, allows access to meta-level
+ facilities.
+ A computation may stop an entire location and (non-locally) return to its
+ creator either a successful result or an exception.
+ The first iterations will have support for locations.
+\layout Standard
+
+Transactions and exceptions are closely related.
+ To begin with, we'll be implementing just exceptions - transactions can
+ wait for proper persistence.
+ Exceptions will be implemented using the rudimentary meta-level location
+ structures we'll require for normal non-local returns.
+\layout Standard
+
+Concurrency will be implemented in the first iterations.
+ A variant on the continuation-passing transform will be used to compute
+ arguments to a message send concurrently.
+\layout Standard
+
+Object-orientation will be implemented in the first iterations, although
+ not in the way we'll ultimately have it.
+ The goal is to have the lookup phase of OO dispatch go via the location
+ (= the meta-object), but for the first few iterations we'll hardcode the
+ lookup.
+ Allowing customisable lookup comes under the category of behavioural reflection.
+\layout Standard
+
+Distributed programming will be supported only once we have the rest sufficientl
+y pinned down.
+ It depends on lexical reflection.
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/metaoperations.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,238 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme default
+\graphics default
+\paperfontsize default
+\spacing single 
+\papersize a4paper
+\paperpackage widemarginsa4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+Metaoperations in ThiNG
+\layout Author
+
+Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
+\layout Section
+
+Metaprotocol
+\layout Standard
+
+
+\emph on 
+Q: 
+\emph default 
+What is bytecode?
+\emph on 
+ A: 
+\emph default 
+A coding for a list of messages sent to the current location.
+\layout Standard
+
+Viewing bytecode this way leads to a definition of a 3-LISP style tower-of-inter
+preters.
+ The location is the interpreter running at phase1, interpreting code at
+ phase0.
+ The location's location is at phase2, and so on.
+ Each location runs bytecode - a sequence of messages sent to the phase
+ above.
+\layout Standard
+
+Here are the bytecode operations in use in the dummy ThiNG prototype:
+\layout Itemize
+
+local - load a value from a lexically-scoped variable
+\layout Itemize
+
+global - load a value from a per-location variable.
+ This translates to a slot access on the contents of the locations' global
+ cell, ie.
+ a unary method invocation on the globals object.
+ Adjusting the contents of the cell and updating the location with new cells
+ gives quite fine-grained thread-group-local control over global variables,
+ a.k.a.
+ ambient capabilities.
+\layout Itemize
+
+send - computes a number of values (in parallel), tuples them up with a
+ selector, and sends them through the dispatch+apply mechanism in the metaobject.
+\layout Itemize
+
+closure - takes a literal block object, cloning it with the current environment,
+ thus making a closure.
+\layout Itemize
+
+begin - performs a sequence of instructions.
+\layout Itemize
+
+scope - introduces a fresh named location, essentially starting a new sub-thread
+-group.
+ Eventually this will be modified to allow object-code-level control over
+ the shape of the new location - within limits.
+\layout Itemize
+
+literal - loads a literal object from the code object's literal vector
+\layout Itemize
+
+update - clones an existing object, adding or updating slots according to
+ the recipe attached to the instruction.
+\layout Itemize
+
+tuple - computes a number of values in parallel, and entuples them before
+ handing the tuple back to its continuation
+\layout Itemize
+
+resend - reinvokes the dispatch mechanism, starting from the current method.
+\layout Itemize
+
+method - should be syntactic sugar for a number of reflective operations,
+ although currently is hardcoded since the necessary location-manipulation
+ isn't even implemented, let alone exposed as reflective primitives to the
+ object level.
+\layout Standard
+
+Now, with luck once the compiler gets clever enough to inline away some
+ temporary object construction, we will be able to remove tuples - the replaceme
+nt will simply be the construction of a results object via normal update:
+ 
+\family typewriter 
+(r1 := val1 r2 := val2 ...)
+\family default 
+.
+ This introduces an asymmetry: function 
+\emph on 
+arguments
+\emph default 
+ will be passed using anonymous (ie.
+ indexed) tuples, but function 
+\emph on 
+results
+\emph default 
+ will be passed using named tuples.
+\begin_inset Foot
+collapsed false
+
+\layout Standard
+
+Perhaps it's worth thinking about how we might get named tuples for function
+ calls, too? One way might be to use selector fragments for positional arguments
+, although that leaves the question of naming the leftmost argument (eg.
+ in a unary message-send).
+ It's interesting, though, because one might be able to make the argument-record
+ a step in the delegation-chain for the running frame.
+\end_inset 
+
+
+\layout Standard
+
+Execution can be viewed as a kind of fold over a sequence of operations,
+ accumulating a changed interpreter (location) state.
+ The operations folded over, then, are stack manipulations (for computing
+ arguments), delay, promise and cell operations, and:
+\layout Itemize
+
+
+\family typewriter 
+loc\SpecialChar ~
+loadLocal:\SpecialChar ~
+#
+\emph on 
+name
+\layout Itemize
+
+
+\family typewriter 
+loc globals peek 
+\emph on 
+name
+\layout Itemize
+
+
+\family typewriter 
+loc send:\SpecialChar ~
+#
+\emph on 
+selector
+\emph default 
+ to:\SpecialChar ~
+{
+\emph on 
+arg
+\emph default 
+.
+\emph on 
+\SpecialChar ~
+arg
+\emph default 
+.\SpecialChar ~
+...}
+\layout Itemize
+
+
+\family typewriter 
+loc close: 
+\emph on 
+blocktemplate
+\layout Itemize
+
+
+\family typewriter 
+loc evaluate: 
+\emph on 
+bytecode
+\emph default 
+ in: 
+\emph on 
+freshlocationtemplate
+\layout Itemize
+
+
+\family typewriter 
+loc loadLiteral: 
+\emph on 
+literalvalue
+\layout Itemize
+
+
+\family typewriter 
+loc update: 
+\emph on 
+expr
+\emph default 
+ by: 
+\emph on 
+updatetemplate
+\layout Itemize
+
+
+\family typewriter 
+loc resend1 
+\begin_inset Quotes eld
+\end_inset 
+
+avoid keyword
+\begin_inset Quotes erd
+\end_inset 
+
+
+\layout Section
+
+Maps and Traits in functional prototype objects
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/new-ideas.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,91 @@
+Use monads to structure the passing of state??
+ do { var <- expr
+    ; some action in the monad of choice
+    ; return value }
+
+-- ????
+expr >>= \var . some_action >>= \dummy . return value
+
+ [ ch1 <- next. ch2 <- next. return: foo ] `with: s.
+
+ [ {socket:. state:. len:. index:} <- read.
+   ???
+
+in s { ch1 <- next
+     ; ch2 <- next
+     ; return foo }
+
+
+
+
+
+SocketCharProvider <- {socket: Nil. state: ''. len: 0. index: 0}.
+
+self@SocketCharProvider newOn: socket [
+  self \ { socket: socket }.
+].
+
+self@SocketCharProvider next [
+  {socket:. state:. len:. index:} <- self.
+  state == EOF ifTrue: [ ^ {state. self} ].
+  index >= len ifFalse: [ ^ {state at: index. self \ {index: index + 1}} ].
+
+  newState <- socket read.
+  newState
+    ifNil: [ (self \ {state: EOF. len: 0. index: 0}) next ]
+    ifNotNil: [ (self \ {state: newState. len: newState size. index: 0}) next ].
+]
+
+{ch1. s} <- s next.
+{ch2. s} <- s next.
+
+
+
+
+
+SocketCharProvider <- {socket: Nil. state: Nil}.
+
+self@SocketCharProvider newOn: socket [
+  self \ { socket: socket. state: {buf: ''. len: 0. index: 0} ref }.
+].
+
+self@SocketCharProvider next [
+  {socket:. state:.} <- self.
+  [
+    [
+      {buf:. len:. index:.} <- state read.
+      buf == EOF ifTrue: [ ^ buf ].
+      index >= len ifFalse: [ state write: state peek \ { index: index + 1 }. ^ buf at: index ].
+
+      newState <- socket read.
+      newState
+        ifNil: [ state write: {buf: EOF. len: 0. index: 0} ]
+        ifNotNil: [ state write: {buf: newState. len: newState size. index: 0} ].
+    ] loop.
+  ] transaction.
+]
+
+ch1 <- s next.
+ch2 <- s next.
+
+
+
+Globals at: #ThingSDL put: {super*: SDL.}.
+
+self@ThingSDL delay: ms
+[
+  nextEventTime <- Time now + (ms / 1000.0).
+  result <- SDLNet checkSockets (self socketSet) 0.
+  (result isNotNil and: [result isPositive])
+    ifTrue: [
+      {ready. unready} <- self activeSockets partition: [ record | record key isReady ].
+      self activeSockets: unready.
+      ready do: [ record |
+        sock <- record key.
+        suspension <- record value.
+        self socketSet delSocket: sock.
+        metalevel resume: suspension with: sock
+      ]
+    ].
+  metalevel runRunnableSuspensionsUntil: nextEventTime.
+]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/project-diary.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,61 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme default
+\graphics default
+\paperfontsize default
+\papersize Default
+\paperpackage a4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+ThiNG Project Diary
+\layout Standard
+
+
+\emph on 
+tonyg, 12 Dec 2004:
+\emph default 
+ Today Matthias Radestock emailed through a link to a website about the
+ L programming language (and operating system).
+ The project is being run by a Tony Hannan, a PhD student at Georgia Tech.
+ The language is really quite similar to ThiNG.
+ We've been working faster, though 
+\family typewriter 
+;-)
+\family default 
+.
+\layout Standard
+
+He seems to have Baker's shallow-bound-transaction idea at the core of the
+ language, along with extremely restricted mutable state.
+ He's still using single-dispatch, though.
+ Also, his metaobjects are the lexical scope and the dynamic state of the
+ code, where ThiNG is based on locations and explicit reflection.
+ Actually, I have a feeling ThiNG is going to end up 
+\emph on 
+completely
+\emph default 
+ reflective, with very little hardwired behaviour.
+\layout Standard
+
+The paper he's writing about L gets into a lot of the mathematical structure
+ we haven't formalised yet, which is nice, since we can look at how he's
+ done it for when we want to write down our formalisms.
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/pseudoambients.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,154 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme palatino
+\graphics default
+\paperfontsize default
+\spacing single 
+\papersize a4paper
+\paperpackage widemarginsa4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 2
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+Pseudo-ambients
+\layout Author
+
+Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
+\layout Date
+
+1 November 2004
+\layout Standard
+
+The idea is to take a calculus much like Cardelli's Mobile Ambients, and
+ short-circuit the routing so that paths are one element long and always
+ take you directly to the given port.
+ 
+\begin_inset Formula $\nu$
+\end_inset 
+
+ is interpreted as allocation; the store holds allocated ports.
+ Ports/locations have exactly one parent, except for the top location, 
+\begin_inset Formula $\top$
+\end_inset 
+
+, which has no parent.
+ The parent of a location is the location at which the 
+\begin_inset Formula $\nu$
+\end_inset 
+
+ was executed.
+ This gives rise to a tree of locations.
+ Ports do not move once they are defined, and are garbage collected when
+ no longer referenced, in the usual manner.
+\layout Standard
+
+
+\begin_inset Formula \begin{eqnarray*}
+\nu x.P &  & \textrm{allocation}\\
+P\vert Q &  & \textrm{par}\\
+\left\langle \tilde{x}\right\rangle  &  & \textrm{output message}\\
+(\widetilde{x}).P &  & \textrm{input message}\\
+!(\widetilde{x}).P &  & \textrm{replicated input}\\
+x[P] &  & \textrm{relocation}\\
+\mathbf{lift}\, x(y).P &  & \textrm{reflection}\\
+\mathbf{eval}\, x &  & \textrm{evaluation}\end{eqnarray*}
+
+\end_inset 
+
+
+\layout Standard
+
+Processes are written with an environment 
+\begin_inset Formula \[
+\mathcal{E}\subset\{ x\mapsto a\,\vert\, x,a\in\mathcal{L}\}\]
+
+\end_inset 
+
+with ports/locations 
+\begin_inset Formula $a,b,c,\top\in\mathcal{L}$
+\end_inset 
+
+, and processes 
+\begin_inset Formula $P$
+\end_inset 
+
+, 
+\begin_inset Formula $Q$
+\end_inset 
+
+, 
+\begin_inset Formula $R$
+\end_inset 
+
+:
+\layout Standard
+
+
+\begin_inset Formula \[
+\mathcal{E}\vdash a[P]\,\Vert\, b[Q]\,\Vert\, c[R]\]
+
+\end_inset 
+
+
+\layout Standard
+
+so reduction proceeds as in figure 
+\begin_inset LatexCommand \ref{cap:Reduction-rules}
+
+\end_inset 
+
+, where 
+\begin_inset Formula $\sigma$
+\end_inset 
+
+ are appropriate substitutions.
+ Note that the rule for lift is currently not very well defined.
+\layout Standard
+
+
+\begin_inset Float figure
+wide true
+collapsed false
+
+\layout Standard
+
+
+\begin_inset Formula \begin{align*}
+\mathcal{E}\vdash a[\nu x.P] & \rightarrow\mathcal{E}\cup\{ x\mapsto a\}\vdash a[P] & \textrm{R-alloc}\\
+\mathcal{E}\vdash a[P\vert Q] & \rightarrow\mathcal{E}\vdash a[P]\Vert a[Q] & \textrm{R-par}\\
+\mathcal{E}\vdash a[\langle\tilde{x}\rangle]\,\Vert\, a[(\tilde{y}).P] & \rightarrow\mathcal{E}\vdash a[P\sigma] & \textrm{R-comm}\\
+\mathcal{E}\vdash a[\langle\tilde{x}\rangle]\,\Vert\, a[!(\tilde{y}).P] & \rightarrow\mathcal{E}\vdash a[P\sigma]\,\Vert\, a[!(\tilde{y}).P] & \textrm{R-repcomm}\\
+\mathcal{E}\vdash a[x[P]] & \rightarrow\mathcal{E}\vdash x[P] & \textrm{R-reloc}\\
+\frac{\alpha=\{ a\vert a\mapsto x\in\mathcal{E}\},\,\mathbf{P}=x[P_{0}]\,\Vert\,{\displaystyle \prod_{a\in\alpha}}a[P_{a}]}{\mathcal{E}\lyxlock\vdash a[\mathbf{lift\,}x(y).P]\,\Vert\,\mathbf{P}} & \rightarrow\mathcal{E}\cup\{ y\mapsto a\}\vdash a[P\sigma]\,\Vert\,\left\lceil \mathbf{P}\right\rceil ^{y} & \textrm{R-reflect}\end{align*}
+
+\end_inset 
+
+
+\layout Caption
+
+
+\begin_inset LatexCommand \label{cap:Reduction-rules}
+
+\end_inset 
+
+Reduction rules
+\end_inset 
+
+
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/redb.lyx	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,285 @@
+#LyX 1.3 created this file. For more info see http://www.lyx.org/
+\lyxformat 221
+\textclass article
+\language english
+\inputencoding auto
+\fontscheme palatino
+\graphics default
+\paperfontsize default
+\spacing single 
+\papersize a4paper
+\paperpackage widemarginsa4
+\use_geometry 0
+\use_amsmath 0
+\use_natbib 0
+\use_numerical_citations 0
+\paperorientation portrait
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\defskip medskip
+\quotes_language english
+\quotes_times 2
+\papercolumns 2
+\papersides 1
+\paperpagestyle default
+
+\layout Title
+
+A Reflective, Eager, Distributed Blue Calculus
+\layout Author
+
+Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
+\newline 
+Michael Bridgen <mikeb@squaremobius.net>
+\layout Date
+
+17 October, 2004
+\layout Abstract
+
+Boudol's blue calculus (the 
+\begin_inset Formula $\pi^{*}$
+\end_inset 
+
+-calculus) allows a natural embedding of both the call-by-name 
+\begin_inset Formula $\lambda$
+\end_inset 
+
+-calculus and Milner's 
+\begin_inset Formula $\pi$
+\end_inset 
+
+-calculus.
+ We extend the blue calculus with eager (call-by-value) parallel evaluation,
+ a notion of evaluation location similar to that of the distributed join
+ calculus, and basic lexical reflection facilities to arrive at an implementable
+ distributed process language rich enough to act as the virtual machine
+ for a Self-like object-oriented environment.
+\layout Section
+
+Introduction
+\layout Standard
+
+Our goal is an implementable, reflective, dynamic, efficient concurrent
+ process language that can readily support object-oriented features in the
+ style of Self 
+\begin_inset LatexCommand \cite{ungar91self}
+
+\end_inset 
+
+ or SmallTalk 
+\begin_inset LatexCommand \cite{goldberg83smalltalk}
+
+\end_inset 
+
+ while not precluding the use of ML-like functional features.
+ The language should be rich enough to support its own development and runtime
+ environment, like SmallTalk, but should be as concurrent as the 
+\begin_inset Formula $\pi$
+\end_inset 
+
+-calculus 
+\begin_inset LatexCommand \cite{milner91polyadicpi}
+
+\end_inset 
+
+.
+ 
+\begin_inset Marginal
+collapsed false
+
+\layout Standard
+
+Mention Obliq?
+\end_inset 
+
+Like the distributed join calculus 
+\begin_inset LatexCommand \cite{join-tutorial}
+
+\end_inset 
+
+, our language should provide a notion of the location in which a computation
+ is proceeding, and an idea of the location to which messages sent along
+ a name should be directed.
+\layout Standard
+
+SmallTalk and Self both, to a point, provide a completely uniform universe
+ of objects to the programmer.
+ The illusion breaks down once the programmer starts to examine the details
+ of the virtual-machine such as call frames, processes, methods, blocks
+ and bytecodes.
+ The innermost parts of a Self or SmallTalk system cease being data (objects),
+ and start being programs (processes).
+ The line between the two levels is quite sharply defined.
+ SmallTalk-like virtual machines are very similar to traditional sequential
+ stack-based computers, in that they have a stack and a small set of registers,
+ and in that any multiprocessing is a construction layered atop the basic
+ sequential machine.
+ Our language is intended to provide a replacement for the low-level virtual
+ machine part of a SmallTalk-like system that does well what SmallTalk virtual
+ machines do poorly - that is, integrate concurrent and distributed features
+ with traditional object-oriented and functional programming - and provides
+ a definition
+\begin_inset Marginal
+collapsed false
+
+\layout Standard
+
+a description?
+\end_inset 
+
+ of the lowest-level behaviour of the language that is amenable to various
+ kinds of formal analysis.
+\layout Standard
+
+While SmallTalk provides an almost uniform object-oriented universe at levels
+ above the virtual machine, our language is to provide a uniform process-oriente
+d universe at the virtual machine level.
+ An object-oriented description of the system can then be built atop the
+ virtual machine in exactly the way current SmallTalk and Self systems build
+ on their virtual machines.
+\layout Standard
+
+We begin in section 
+\begin_inset LatexCommand \ref{sec:The-Blue-Calculus}
+
+\end_inset 
+
+ by briefly reviewing Boudol's blue calculus.
+ Section !!! alters the basic calculus to perform call-by-value evaluation.
+ Section !!! further extends the calculus to evaluate subexpressions of
+ a combination in parallel.
+ Section !!! adds a notion of location to the calculus.
+ Section !!! introduces a few small features essential to reflection, which
+ is finally introduced in section !!!.
+ Section 
+\begin_inset LatexCommand \ref{sec:Related-Work}
+
+\end_inset 
+
+ touches on related work, and section 
+\begin_inset LatexCommand \ref{sec:Conclusion}
+
+\end_inset 
+
+ concludes the paper.
+\layout Section
+
+The Blue Calculus
+\layout Standard
+
+
+\begin_inset LatexCommand \label{sec:The-Blue-Calculus}
+
+\end_inset 
+
+Boudol's blue calculus (the 
+\begin_inset Formula $\pi^{*}$
+\end_inset 
+
+-calculus) 
+\begin_inset LatexCommand \cite{boudol97picalculus}
+
+\end_inset 
+
+ allows a natural embedding of both the call-by-name 
+\begin_inset Formula $\lambda$
+\end_inset 
+
+-calculus and Milner's 
+\begin_inset Formula $\pi$
+\end_inset 
+
+-calculus.
+ It makes a good foundation for our language - it supports both functional
+ and process-oriented styles of computation, provides a syntactic distinction
+ avoiding the problem of full distributed input capability, and can be readily
+ extended with lexical reflection and with locations in the style of the
+ distributed join calculus.
+\layout Section
+
+Related Work
+\layout Standard
+
+
+\begin_inset LatexCommand \label{sec:Related-Work}
+
+\end_inset 
+
+Several candidate systems besides the blue calculus were examined as potential
+ starting points for this work.
+ Cardelli's mobile ambients 
+\begin_inset LatexCommand \cite{CardelliGordon98:ambients}
+
+\end_inset 
+
+ provide a suitable notion of location that could be extended with reflective
+ capabilities, but the language leaves the routing of messages in the hands
+ of the programmer, which seems too low-level for simple efficient implementatio
+n.
+ Cardelli's Obliq system 
+\begin_inset LatexCommand \cite{cardelli95language}
+
+\end_inset 
+
+ provides a high-level account of distributed object-oriented computation,
+ but does not map well to a simple implementation - it is too high-level.
+ Fournet's distributed join calculus 
+\begin_inset LatexCommand \cite{FournetGonthier96,join-tutorial,Fournet98:PhD}
+
+\end_inset 
+
+ provides a good treatment of message routing and process location while
+ also providing an Actor-like 
+\begin_inset LatexCommand \cite{agha86actors}
+
+\end_inset 
+
+ semantics, but ties together the notion of name definition and message
+ reception in a way that makes reflection difficult.
+\layout Standard
+
+[[Current work in the SmallTalk community 
+\begin_inset LatexCommand \cite{salzman04pmd,ingalls97squeak}
+
+\end_inset 
+
+ is based on traditional virtual machines.]] Even Slate, a 
+\begin_inset Quotes eld
+\end_inset 
+
+clean-slate SmallTalk
+\begin_inset Quotes erd
+\end_inset 
+
+, is based around an ad-hoc byte-coded virtual machine, despite its stated
+ goals of integrated concurrent and distributed programming.
+\begin_inset Marginal
+collapsed false
+
+\layout Standard
+
+check the goals!
+\end_inset 
+
+
+\layout Section
+
+Conclusion
+\layout Standard
+
+
+\begin_inset LatexCommand \label{sec:Conclusion}
+
+\end_inset 
+
+
+\layout Standard
+
+
+\begin_inset LatexCommand \BibTeX[acm]{/Users/tonyg/Documents/tonyg}
+
+\end_inset 
+
+
+\the_end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/talk/Makefile	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,48 @@
+PDFNAME=ThiNG_talk
+TARGETS=$(PDFNAME).pdf
+
+TEXINPUTS:=$(TEXINPUTS):./prosper:./prosper/img
+
+LATEX=TEXINPUTS=$(TEXINPUTS) latex
+DVIPS=TEXINPUTS=$(TEXINPUTS) dvips
+
+%.eps: %.dot
+	dot -Tps -o $@ $<
+
+%.view: %.eps
+	gv $<
+
+%.view: %.ps
+	gv $<
+
+%.pdfview: %.pdf
+	acroread $<
+
+%.xpdfview: %.pdf
+	xpdf $<
+
+%.ps: %.dvi
+	$(DVIPS) -o $@ $<
+
+%.pdf: %.ps
+	ps2pdf13 $<
+
+%.dvi: %.tex
+	-$(LATEX) "\\batchmode\\input{$<}"
+	-$(LATEX) "\\batchmode\\input{$<}"
+	$(LATEX) $<
+#	Three is a magic number.
+
+%.force: %.tex
+	-$(LATEX) "\\batchmode\\input{$<}"
+	-$(LATEX) "\\batchmode\\input{$<}"
+	-$(LATEX) "\\batchmode\\input{$<}"
+	$(DVIPS) -o $*.ps $*.dvi
+	gv $*.ps
+
+all: $(TARGETS)
+
+clean:
+	rm -f $(PDFNAME).{aux,bbl,blg,idx,log,toc,dvi,ps,pdf,out}
+
+.PRECIOUS: %.pdf %.ps %.dvi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/talk/ThiNG_talk.tex	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,501 @@
+%%
+%% INSTRUCTIONS FOR COMPILING THIS DOCUMENT
+%%
+%% Choose one of the two ``documentclass'' declarations below.
+%% Use the ``ps'' one for printing; and the ``pdf'' one for an
+%% online slideshow PDF format.
+%%
+%% You will need a tarball of the ``prosper'' software untarred
+%% into a directory called ``prosper'' in this directory. You
+%% can download prosper from prosper.sourceforge.net.
+%%
+%%
+\documentclass[ps,azure]{prosper}
+%%\documentclass[pdf,slideColor,azure]{prosper}
+
+\hypersetup{pdfpagemode=FullScreen}
+
+\title{The Next Big ThiNG}
+\subtitle{A Reflective, Transactional, Concurrent, Functional, Object-Oriented, Distributed Programming Language}
+\author{Tony Garnock-Jones (tonyg@kcbbs.gen.nz)\\
+Michael Bridgen (mikeb@squaremobius.net)}
+
+\date{30 November 2004}
+
+\begin{document}
+\maketitle
+
+\begin{slide}{Introduction}
+  This talk will cover
+  \begin{itemize}
+  \item An introduction to process languages
+  \item Applications
+  \end{itemize}
+\end{slide}
+
+\part{Introduction to Process Languages}
+
+\overlays{5}{
+\begin{slide}{What is a process language?}
+  A {\bf process language} describes a group of simultaneously
+  executing programs and how they communicate.
+
+  \begin{itemstep}
+  \item Parallel -- not sequential
+  \item Allows solid reasoning about concurrency
+  \item Strong mathematical foundations can allow you to {\bf prove}
+    that your program behaves in certain ways
+  \item This is something traditional languages are poor at -- using
+    threads is a nightmare; no math in sight!
+  \item Not a panacea -- deadlock still possible, etc.
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Why use a process language?}
+  Process languages are a natural fit for event-based systems:
+  \begin{itemstep}
+  \item server-side web applications
+  \item telecommunications
+  \item operating system kernels
+  \item GUIs
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{5}{
+\begin{slide}{Why use a process language?}
+  They work well in more general settings, too:
+  \begin{itemstep}
+  \item coordination of general distributed computing
+    \begin{itemize}
+    \item SOAP, XML-RPC
+    \item CORBA
+    \end{itemize}
+  \item general modeling of processes
+  \item coordination of general business processes (BizTalk)
+  \end{itemstep}
+\end{slide}
+}
+
+\begin{slide}{The $\pi$-calculus}
+  There are many kinds of process language. I am most familiar with
+  the $\pi$-calculus, so that will be the foundation for this talk.
+
+  \begin{itemize}
+  \item {\bf Milner, Parrow and Walker} developed the $\pi$-calculus,
+    working from the foundation of {\it CCS}
+  \item See the papers ``A Calculus of Mobile Processes'', parts I and
+    II (available online)
+  \item Also interesting: ``Functions as Processes'' by Milner
+  \end{itemize}
+\end{slide}
+
+\overlays{7}{
+\begin{slide}{The $\pi$-calculus}
+  \begin{itemstep}
+  \item Same level as the $\lambda$-calculus
+    \begin{itemize}
+    \item Both Turing-equivalent
+    \item $\lambda$ datatype: the {\it function}
+    \item $\pi$ datatype: the {\it name} (or {\it port})
+    \end{itemize}
+  \item Where $\lambda$ {\it applies} functions (to functions), $\pi$
+    {\it sends} names (down names).
+  \item Neither language needs other types to be complete
+  \item However: practical implementations include strings, ints,
+    floats, structures, lists, vectors etc.
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{6}{
+\begin{slide}{$\lambda$-calculus combinators}
+  The $\lambda$-calculus has two combinators:
+  \begin{itemstep}
+  \item abstraction:
+    \begin{itemize}
+    \item $\lambda x . M$
+    \item {\tt (lambda (x) M)}
+    \end{itemize}
+  \item application (curried):
+    \begin{itemize}
+    \item $M N$
+    \item {\tt (M N)}
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{6}{
+\begin{slide}{$\pi$-calculus combinators}
+  The $\pi$-calculus has six combinators:
+  \begin{itemstep}
+  \item new port: $(\nu p) . P$
+  \item read: $p(x) . P$
+  \item write: $\bar p\left<x\right> . P$
+  \item repeat: $\mathbf{!}P$
+  \item parallel: $P~|~Q~|~...$
+  \item choice (``sum''): $P~+~Q~+~...$
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{10}{
+\begin{slide}{Hidden Machinery}
+  \begin{itemstep}
+  \item All those combinators!
+  \item $\pi$ {\it seems} more complicated, but...
+  \item $\lambda$ is hiding a {\bf lot} of machinery
+    \begin{itemize}
+    \item CPS conversion
+    \item replication of process bodies
+    \item order of application -- $\lambda _v$ vs $\lambda _n$
+    \end{itemize}
+  \item compare $\pi$, where it's all in the open
+    \begin{itemize}
+    \item no analogue to direct-style $\leftrightarrow$ CPS
+    \item replication explicit (with `$\mathbf{!}$')
+    \item no direct-style $\rightarrow$ no assumptions
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Getting $\lambda$ from $\pi$}
+  Sequential languages ($\lambda$) are a {\it restriction} of parallel
+  languages ($\pi$) -- easy to get to $\lambda$ from $\pi$!
+
+  \begin{itemstep}
+  \item {\it closures} map to {\it names} -- the body of the closure
+    is translated into a repeated-read from the name
+  \item many slightly different ways of embedding $\lambda$ in $\pi$
+    \begin{itemize}
+    \item the precise calculus makes a difference: $\lambda _ v$ vs $\lambda _ n$ etc.
+    \item specific details have a large effect on efficiency
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{3}{
+\begin{slide}{$\pi$ is fine-grained}
+  \begin{itemstep}
+  \item $\lambda$ reifies {\it some} aspects of control -- after
+    conversion to continuation-passing-style!
+  \item $\pi$ reifies {\it all} aspects of control -- no rewriting
+    required or possible!
+  \item $\pi$ also copes naturally with parallelism -- not a layer on
+    top
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{7}{
+\begin{slide}{Getting $\pi$ from $\lambda$}
+  \begin{itemstep}
+  \item Scheme is essentially $\lambda _v$ made real
+  \item Scheme + small framework + macros $\longrightarrow \pi$
+  \item Required:
+    \begin{itemize}
+    \item A port data structure
+    \item A scheduler
+    \item Macros that expand into calls on the above
+    \item Unification (optional, for complex data)
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\part{Applications}
+
+\overlays{5}{
+\begin{slide}{Web programming}
+  \begin{itemstep}
+  \item Concurrency -- each request is a separate thread
+  \item Using threads complex; inverted flow-of-control
+  \item Two potential solutions:
+    \begin{itemize}
+    \item Scheme-defined {\tt call/cc} microthreads
+    \item Use a $\pi$-calculus-based language!
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{$\pi$ on the web}
+  Using a $\pi$-calculus based language for web programming:
+
+  \begin{itemstep}
+  \item Each {\it session} is a process on the server
+  \item Each web {\it client} is just another port
+  \item Any {\it databases} are just ports
+  \item A {\it well-known-port} is used to start sessions
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{3}{
+\begin{slide}{Telco -- Switching}
+  Important requirements:
+  \begin{itemstep}
+  \item Massively parallel -- $\geq 10000$ active calls
+  \item Highly available -- ``five-nines''
+  \item Realtime
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{6}{
+\begin{slide}{Telco -- Switching}
+  $\pi$ addresses these requirements:
+  \begin{itemstep}
+  \item Massively parallel -- $\pi$ processes lightweight
+  \item Highly available -- $\pi$ can be strongly typed
+    \begin{itemize}
+    \item behavioural types capture a protocol definition
+    \item programs can be proven to conform to a protocol (cf. threads)
+    \end{itemize}
+  \item Realtime -- that depends!
+    \begin{itemize}
+    \item usually waiting for outside databases anyway...
+    \end{itemize}
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Telco -- IN}
+  \begin{itemstep}
+  \item Specific telephony application: ``Intelligent Networking'' (IN)
+  \item Advanced network functionality -- voicemail, menus, recharge,
+    roaming, call gapping, 3-way calls ...
+  \item Many interlocking, massively-parallel pieces
+  \item Protocol-driven design (perfect for $\pi$!)
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{8}{
+\begin{slide}{Telco -- IN}
+  \begin{itemstep}
+  \item Many components in an IN network:
+    \begin{itemize}
+    \item SSP -- the switch
+    \item SCP -- application host
+    \item SMP -- management
+    \item IP -- peripheral (announcements etc.)
+    \item BE -- billing engines
+    \end{itemize}
+  \item Each one with many open calls
+  \item Each one (usually) with a state-machine per call
+  \end{itemstep}
+\end{slide}
+}
+
+\begin{slide}{Example Call}
+  Complicated protocols -- I don't remember full detail!
+  \begin{itemize}
+  \item IDP from SSP $\longrightarrow$ SCP
+  \item call gapping may count the IDP
+  \item may connect to IP for voice prompts, collect digits
+  \item complex applications may be built
+  \item may connect to databases, external BEs for credit checks
+  \item may either connect, disconnect or reroute the call
+  \end{itemize}
+\end{slide}
+
+\begin{slide}{Telco -- IN}
+  Programming models:
+  \begin{itemize}
+  \item State machines using C, C++ etc
+    \begin{itemize}
+    \item traditional
+    \item error-prone
+    \item unintuitive
+    \item not compositional
+    \item does not distribute
+    \end{itemize}
+  \end{itemize}
+\end{slide}
+
+\begin{slide}{Telco -- IN}
+  Programming models:
+  \begin{itemize}
+  \item Threading
+    \begin{itemize}
+    \item doesn't scale
+    \item error-prone (preemptive threads)
+    \item intuitive (modulo locking)
+    \item coarse-grained, heavyweight
+    \item does not distribute
+    \end{itemize}
+  \end{itemize}
+\end{slide}
+
+\begin{slide}{Telco -- IN}
+  Programming models:
+  \begin{itemize}
+  \item Scheme {\small (or Python!)} microthreads
+    \begin{itemize}
+    \item scalable
+    \item intuitive
+    \item medium-fine-grained, lightweight
+    \item slightly awkward -- layer on top
+    \item does not distribute trivially
+    \end{itemize}
+  \end{itemize}
+\end{slide}
+
+\begin{slide}{Telco -- IN}
+  Programming models:
+  \begin{itemize}
+  \item $\pi$
+    \begin{itemize}
+    \item scalable
+    \item intuitive
+    \item fine-grained, lightweight
+    \item naturally concurrent
+    \item distributes for free!
+    \end{itemize}
+  \end{itemize}
+\end{slide}
+
+\overlays{5}{
+\begin{slide}{$\pi$ as a kernel}
+  \begin{itemstep}
+  \item Very close to the hardware
+  \item Safe -- behavioural types
+  \item Massively multithreaded -- SMP
+  \item Message passing -- distribution -- plug and play supercomputer!
+  \item IRQ handling sketch
+  \end{itemstep}
+\end{slide}
+}
+
+\begin{slide}{Using $\pi$ for GUIs}
+  \begin{itemize}
+  \item Similar to web programming
+  \item A little more fine grained, slightly different focus
+  \item M-V-C coordination
+  \end{itemize}
+\end{slide}
+
+\overlays{2}{
+\begin{slide}{Coordination}
+  $\pi$ scales from micro- to macro-programming. It has a place in:
+  \begin{itemize}
+  \item protocols at the IRQ level
+  \item protocols at the OS level
+  \item protocols at the network level
+  \item protocols at the application level
+  \end{itemize}
+
+  \FromSlide{2}
+  ... so why not protocols between applications, too?
+  \begin{itemize}
+  \item glue between local apps
+  \item glue across the internet
+  \end{itemize}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Local $\pi$ glue}
+  The ultimate scripting language -- sequential when required,
+  parallel when you like!
+
+  \begin{itemstep}
+  \item {\tt expect}
+  \item Local CORBA or COM
+  \item Calling out to .NET
+  \item Interoperating with local Java
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Remote $\pi$ glue}
+  Synchronising and scheduling many distributed applications in the
+  right order -- ``unified messaging''
+  \begin{itemstep}
+  \item Encode business logic
+  \item Remote CORBA or DCOM
+  \item SOAP, XML-RPC
+  \item .NET remoting -- similar in ambition?
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{4}{
+\begin{slide}{Modeling using $\pi$}
+  The $\pi$-calculus naturally covers an impressive subset of the jobs
+  UML is used for:
+
+  \begin{itemstep}
+  \item It's fine-grained $\therefore$ everything is explicit
+  \item Normal code sequential -- highlights control flow
+  \item You can {\it reproject} code to highlight dataflow
+  \item Message sequence diagrams can be derived automatically
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{3}{
+\begin{slide}{B2B}
+  Extend the scope of the model to include ``real-world'' processes
+  \begin{itemstep}
+  \item mail-order
+  \item project management processes
+  \item paper-based records
+  \end{itemstep}
+\end{slide}
+}
+
+\overlays{3}{
+\begin{slide}{B2B}
+  B2B systems based on, or related to process-language ideas:
+  \begin{itemstep}
+  \item BizTalk (Microsoft) -- XML-based B2B glue
+  \item WSDL (W3C, IBM, Microsoft) -- another XML-based B2B glue
+  \item others? {\small (not my field...)}
+  \end{itemstep}
+\end{slide}
+}
+
+\part{The End}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\part{Backup}
+
+\begin{slide}{Getting $\lambda$ from $\pi$}
+  One way of translating abstraction:
+
+ \[
+ \left[\lambda x.M \right]_k
+ \longrightarrow
+ (\nu f)~\mathbf{!}f(k',x) . \left( \left[M\right]_{k'} | \bar k \left<f\right> \right)
+ \]
+
+ Translating application is different for $\lambda _v$ vs $\lambda _n$.
+
+ {\small (This is just to convey the flavour an embedding has -- this
+   particular definition may not be 100\% correct in all situations!)}
+\end{slide}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%% \overlays{1}{
+%% \begin{slide}{}
+
+%%   \begin{itemstep}
+%%   \item foo
+%%   \end{itemstep}
+%% \end{slide}
+%% }
+
+\end{document}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc/talk/talknotes.txt	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,46 @@
+-*- outline -*-
+
+The Next Big ThiNG
+
+
+* Overview of the language
+
+** Reflective
+*** Behavioural
+*** Structural
+*** Lexical
+
+** Transactions + Exceptions
+** Concurrent
+** Functional
+** Object-Oriented (PMD)
+** Distributed
+
+* Influences
+
+** Languages
+
+*** Self
+*** Scheme
+*** SmallTalk
+*** Slate
+*** Mobile Ambients
+
+** Techniques
+
+*** Malenfant et al. Reflection in Prototype Languages
+
+* Parser
+
+** Packrat
+
+Ford's thesis, other papers
+
+** Extensibility
+
+let-syntax and define-syntax can be layered atop, with a small
+interpreter
+
+(Not currently extensible for ThiNG)
+
+* Efficiency
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/gui.ss	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,397 @@
+; GUI.SS  Graphical User Interface for LISP2
+;
+; (C) 1995 Tony Garnock-Jones
+; tonyg@kcbbs.gen.nz
+;
+
+;----------------------------------------------------------------------------;
+; Graphics toolbox calls.
+;----------------------------------------------------------------------------;
+
+(require 'form)
+
+(define (rectangle rule thickness x y w h)
+    (apply BitBlt screen-form '() '() rule
+                  x y thickness h
+                  (append clipping-rectangle '(0 0)))
+    (apply BitBlt screen-form '() '() rule
+                  x y w thickness
+                  (append clipping-rectangle '(0 0)))
+    (apply BitBlt screen-form '() '() rule
+                  (+ x (- w thickness)) y thickness h
+                  (append clipping-rectangle '(0 0)))
+    (apply BitBlt screen-form '() '() rule
+                  x (+ y (- h thickness)) w thickness
+                  (append clipping-rectangle '(0 0))))
+
+(define (fill-rect shade rule x y w h)
+    (apply BitBlt screen-form '() shade rule
+                  x y w h
+                  (append clipping-rectangle '(0 0))))
+
+;----------------------------------------------------------------------------;
+; The window system proper.
+;----------------------------------------------------------------------------;
+
+;;; Class <rectangle>
+;;;
+;;; Represents a rectangle; used in screen geometry calculations.
+
+(define-class <rectangle> <object> (x y w h))
+
+;;; (<rectangle> new: x y w h)
+;;;
+;;; Creates and returns a rectangle with the specified coordinates.
+
+(define-class-method <rectangle> (self new: x y w h)
+    (let ((n (self new)))
+        (n set: <rectangle> x x)
+        (n set: <rectangle> y y)
+        (n set: <rectangle> w w)
+        (n set: <rectangle> h h)
+        n))
+
+;;; (rect x2)
+;;; (rect y2)
+;;;
+;;; Return the coordinates of the right-hand lower corner of the rectangle.
+
+(define-method <rectangle> (self x2)
+    (+ (self : <rectangle> x) (self : <rectangle> w)))
+
+(define-method <rectangle> (self y2)
+    (+ (self : <rectangle> y) (self : <rectangle> h)))
+
+;;; (rect write-to: port)
+;;; (rect display-to: port)
+;;;
+;;; Displays the textual representation of a rectangle to the given IO port.
+
+(let ((method
+        (lambda (self port)
+            (display-to port "#<rectangle ")
+            (display-to port (self : <rectangle> x)) (display-to port " ")
+            (display-to port (self : <rectangle> y)) (display-to port " ")
+            (display-to port (self : <rectangle> w)) (display-to port " ")
+            (display-to port (self : <rectangle> h))
+            (display-to port ">"))))
+    (<rectangle> add-method: 'write-to: method)
+    (<rectangle> add-method: 'display-to: method))
+
+;;; (rect contains? x y)
+;;;
+;;; Returns true if the rectangle contains the point (x, y); otherwise
+;;; returns false.
+
+(define-method <rectangle> (self contains? x y)
+    (and (>= x (self : <rectangle> x))
+         (>= y (self : <rectangle> y))
+         (<= (- x (self : <rectangle> x)) (self : <rectangle> w))
+         (<= (- y (self : <rectangle> y)) (self : <rectangle> h))))
+
+;;; (min a b)
+;;; (max a b)
+;;;
+;;; Return the minimum/maximum of the two arguments.
+
+(define (min a b)
+    (if (< a b) a b))
+
+(define (max a b)
+    (if (> a b) a b))
+
+;;; (rect intersect: rect2)
+;;;
+;;; Returns either a new rectangle, which is the area common to both arguments,
+;;; or #f if there is no overlap.
+
+(define-method <rectangle> (self intersect: other)
+    (let ((result (<rectangle> new:
+                    (max (self : <rectangle> x) (other : <rectangle> x))
+                    (max (self : <rectangle> y) (other : <rectangle> y))
+                    (min (self x2) (other x2))
+                    (min (self y2) (other y2)))))
+        (result set: <rectangle> w
+            (- (result : <rectangle> w) (result : <rectangle> x)))
+        (result set: <rectangle> h
+            (- (result : <rectangle> h) (result : <rectangle> y)))
+        (if (or (<= (result : <rectangle> w) 0)
+                (<= (result : <rectangle> h) 0))
+            #f
+            result)))
+
+;;; (rect not)
+;;;
+;;; Returns a list of rectangles, which when taken together cover all of a
+;;; 640x480 screen excluding the area covered by the argument.
+
+(define-method <rectangle> (self not)
+    (list
+        (<rectangle> new: 0                       (self : <rectangle> y)
+                          (self : <rectangle> x)  (self : <rectangle> h))
+        (<rectangle> new: (self x2)               (self : <rectangle> y)
+                          (- 640 (self x2))       (self : <rectangle> h))
+        (<rectangle> new: 0                       0
+                          640                     (self : <rectangle> y))
+        (<rectangle> new: 0                       (self y2)
+                          640                     (- 480 (self y2))      )))
+
+;;; (rect ->list)
+;;;
+;;; Returns a list containing x, y, w and h.
+
+(define-method <rectangle> (self ->list)
+    (list
+        (self : <rectangle> x)
+        (self : <rectangle> y)
+        (self : <rectangle> w)
+        (self : <rectangle> h)))
+
+;;; (rect grow: xdelta ydelta)
+;;;
+;;; Changes size of rect by adding/subtracting xdelta or ydelta to/from each
+;;; coordinate.
+
+(define-method <rectangle> (self grow: x y)
+    (self set: <rectangle> x (- (self : <rectangle> x) x))
+    (self set: <rectangle> y (- (self : <rectangle> y) y))
+    (self set: <rectangle> w (+ (self : <rectangle> w) (* x 2)))
+    (self set: <rectangle> h (+ (self : <rectangle> h) (* y 2))))
+
+;;; (rect move: xdelta ydelta)
+;;;
+;;; Changes position of rect by adding xdelta or ydelta to each coordinate.
+
+(define-method <rectangle> (self move: x y)
+    (self set: <rectangle> x (+ (self : <rectangle> x) x))
+    (self set: <rectangle> y (+ (self : <rectangle> y) y)))
+
+;;; (rect copy)
+;;;
+;;; Returns a new <rectangle> identical to the argument.
+
+(define-method <rectangle> (self copy)
+    (apply ((self class) get-class-method: 'new:) (self class) (self ->list)))
+
+;;; (rect top-left)
+;;; (rect bottom-right)
+;;;
+;;; Return coordinates of the corner requested.
+
+(define-method <rectangle> (self top-left)
+    (list
+        (self : <rectangle> x)
+        (self : <rectangle> y)))
+
+(define-method <rectangle> (self bottom-right)
+    (list
+        (self x2)
+        (self y2)))
+
+;----------------------------------------------------------------------------;
+
+;;; Class <view>
+;;;
+;;; Abstract windowable (displayable) object.
+;;; Instance variables:
+;;;     bounds      The rectangle representing the area of the screen covered
+;;;                 by the view.
+;;;     owner       The view under which this view is logically grouped.
+;;;     children    Views logically grouped under this view.
+
+(define-class <view> <object> (bounds owner children))
+
+;;; (<view> new: x y w h owner)
+;;;
+;;; Creates and returns a view with the given coordinates, and the given
+;;; logical owning view.
+
+(define-class-method <view> (self new: x y w h owner)
+    (let ((n (self new)))
+        (n set: <view> bounds (<rectangle> new: x y w h))
+        (n set: <view> children '())
+        (unless (null? owner)
+            (owner add-child: n))
+        n))
+
+;;; (view destroy)
+;;;
+;;; Cleans up as a view is removing itself from the windowing system.
+
+(define-method <view> (self destroy)
+    (unless (null? (self : <view> owner))
+        ((self : <view> owner) remove-child: self)))
+
+;;; (view has-focus?)
+;;;
+;;; Returns true if this view has the input focus.
+
+(define-method <view> (self has-focus?)
+    (eq? (desktop : <desktop> focus) self))
+
+;;; (view paint: rect)
+;;;
+;;; Sets up the graphics system to draw stuff in the area specified by rect.
+
+(define-method <view> (self paint: area)
+    (set! clipping-rectangle (area ->list)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (view draw: rect)
+;;;
+;;; Repaints the areas of view and its children which are contained within the
+;;; region of the screen represented by rect.
+;;;
+;;; WARNING: The primitive form of this method relies on the structure of the
+;;; classes <view> and <rectangle>. Be careful when changing those classes to
+;;; also update the information used by this method.
+
+(<view> add-method: 'draw: %%draw-method-for-<view>-objects)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (view add-child: child)
+;;; (view remove-child: child)
+;;;
+;;; Add or remove child views from a view.
+
+(define-method <view> (self add-child: child)
+    (unless (member child (self : <view> children))
+        (child set: <view> owner self)
+        (self set: <view> children
+            (cons child (self : <view> children)))))
+
+(define-method <view> (self remove-child: child)
+    (let ((l (member child (self : <view> children))))
+        (when l
+            (child set: <view> owner '())
+            (if (null? (cdr l))
+                (set-car! l #f)
+                (begin
+                    (set-car! l (cadr l))
+                    (set-cdr! l (cddr l)))))))
+
+;----------------------------------------------------------------------------;
+
+;;; Class <desktop>
+;;;
+;;; The root view in the windowing system is an instance of class <desktop>.
+
+(define-class <desktop> <view> (focus))
+
+;;; (<desktop> new)
+;;;
+;;; Creates a new desktop, setting its logical boundaries to the screen size.
+
+(define-class-method <desktop> (self new)
+    (let ((n (self as: <view> new)))
+        (n set: <view> bounds
+            (<rectangle> new: 0 0 640 480))
+        (n set: <desktop> focus '())
+        n))
+
+;;; (desktop paint: area)
+;;;
+;;; Redraws areas of the desktop.
+
+(define-method <desktop> (self paint: area)
+    (self as: <view> paint: area)
+    (apply fill-rect grey-25 3 ((self : <view> bounds) ->list)))
+
+;;; (desktop draw)
+;;;
+;;; Refresh the entire screen.
+
+(define-method <desktop> (self draw)
+    (self draw: (self : <view> bounds)))
+
+;----------------------------------------------------------------------------;
+
+;;; Class <window>
+;;;
+;;; This is pretty self-evident :-)
+
+(define-class <window> <view> (title flags))
+
+;;; (<window> new: x y w h owner title)
+;;;
+;;; Creates and returns a window with the specified attributes.
+
+(define-class-method <window> (self new: x y w h owner title)
+    (let ((n (self as: <view> new: x y w h owner)))
+        (n set: <window> title title)
+        n))
+
+;;; (window paint: area)
+;;;
+;;; Refresh areas of the window.
+
+(define-method <window> (self paint: area)
+    (self as: <view> paint: area)
+    (let ((bounds ((self : <view> bounds) copy)))
+        (apply fill-rect '() 15 (bounds ->list))
+        (apply rectangle 0 2 (bounds ->list))
+        (bounds grow: -2 -2)
+        (bounds set: <rectangle> h (+ (gui-font : <font> height) 2))
+        (screen-form print-string:
+            (self : <window> title)
+            (+ (bounds : <rectangle> x) 2)
+            (+ (bounds : <rectangle> y) 2)
+            gui-font 4)
+        (apply BitBlt screen-form '() '() 0
+                      (bounds : <rectangle> x) (bounds y2)
+                      (bounds : <rectangle> w) 2
+                      (append clipping-rectangle '(0 0)))
+        (if (self has-focus?)
+            (apply BitBlt screen-form '() '() 10
+                          (append (bounds ->list)
+                                  clipping-rectangle
+                                  '(0 0)))
+            (apply BitBlt screen-form '() grey-25 4
+                          (append (bounds ->list)
+                                  clipping-rectangle
+                                  '(0 0))))))
+
+;----------------------------------------------------------------------------;
+
+;;; desktop
+;;;
+;;; The system-wide desktop.
+
+(define desktop (<desktop> new))
+
+(desktop add-child: (<window> new: 100 100 (- 200 100) (- 200 100) desktop "Title 2"))
+(desktop add-child: (<window> new: 370 300 (- 620 370) (- 460 300) desktop "Title 3"))
+(desktop add-child: (<window> new: 320 50 (- 420 320) (- 450 50) desktop "Title 4"))
+(desktop add-child: (<window> new: 120 160 (- 500 120) (- 400 160) desktop "Title 5"))
+(desktop add-child: (<window> new: 140 120 (- 400 140) (- 300 120) desktop "Title 9"))
+(desktop add-child: (<window> new: 50 140 (- 550 50) (- 350 140) desktop "Title 7"))
+(desktop add-child: (<window> new: 150 150 (- 250 150) (- 250 150) desktop "Title 14"))
+
+(define gui-font smalthin-font) ;modernb-font)
+
+(define (test-gui)
+    (graphics-mode)
+    (desktop draw)
+    (let ((background (<form> new: 8 16)))
+        (let loop ((state (get-mouse)))
+            (let ((x (list-ref state 0))
+                  (y (list-ref state 1))
+                  (b (list-ref state 2)))
+                (unless (= b 7)
+                    (if (= b 3)
+                        (desktop draw))
+                    (set! clipping-rectangle '(0 0 640 480))
+                    (BitBlt background screen-form '() 3
+                            0 0 8 16
+                            0 0 8 16
+                            x y)
+                    (screen-form print-string: "" x y system-font 4)
+                    (BitBlt screen-form background '() 3
+                            x y 8 16
+                            0 0 640 480
+                            0 0)
+                    (loop (get-mouse))))))
+    (text-mode))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/oo.ss	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,102 @@
+;;; OO.SS   Support for object-oriented programming
+
+(let ((cell (assq 'add-method: (<class> : <class> methods))))
+    (let ((oldmeth (cdr cell)))
+        (set-cdr! cell
+            (lambda (self name func)
+                (cond
+                    ((assq name (self : <class> methods)) =>
+                        (lambda (cell)
+                            (set-cdr! cell func)
+                            self))
+                    (else
+                        (oldmeth self name func)))))))
+
+(define-method <class> (self add-class-method: name lambda)
+    (self set: <class> class-methods
+        (cons (cons name lambda)
+              (self : <class> class-methods))))
+
+(define define-class-method
+    (macro (class template . body)
+        `(,class add-class-method: ',(cadr template)
+            (lambda ,(cons (car template) (cddr template))
+                ,@body))))
+
+(define-class-method <class> (self new: super ivars print-name)
+    (let ((new (self new)))
+        (new set: <class> super super)
+        (new set: <class> ivars ivars)
+        (new set: <class> numivars
+            (+ (super : <class> numivars) (length ivars)))
+        (new set: <class> print-name print-name)
+        new))
+
+; (define-class name super (ivar1 ...))
+
+(define define-class
+    (macro (name super ivars)
+        `(define ,name (<class> new: ,super ',ivars ',name))))
+
+; (class get-method: name)
+
+(define-method <class> (self get-method: name)
+    (let ((methods (self : <class> methods)))
+        (cond
+            ((assq name methods) => cdr)
+            (else #f))))
+
+; (class get-class-method: name)
+
+(define-method <class> (self get-class-method: name)
+    (let ((methods (self : <class> class-methods)))
+        (cond
+            ((assq name methods) => cdr)
+            (else #f))))
+
+(define-method <class> (self write-to: port)
+    (display "#<class ")
+    (display (self : <class> print-name))
+    (display ">"))
+
+(define-method <class> (self display-to: port)
+    (display "#<class ")
+    (display (self : <class> print-name))
+    (display ">"))
+
+(define-method <object> (self dissect-to: port)
+    (for-each (lambda (x) (display-to port x))
+        (list
+            "An instance of class " ((self class) : <class> print-name) ".\n"
+            "Instance variables:\n"))
+    (let loop ((class (self class)))
+        (unless (or (null? class) (eq? class <object>))
+            (display-to port "--------")
+            (display-to port (class : <class> print-name))
+            (display-to port "\n")
+            (for-each (lambda (ivar)
+                            (display-to port "\t")
+                            (display-to port ivar)
+                            (display-to port "\t\t")
+                            (if (and (eq? class <class>)
+                                     (memq ivar '(methods class-methods)))
+                                (display-to port
+                                    (map car
+                                        (self get-ivar-by-name: ivar class)))
+                                (display-to port
+                                    (self get-ivar-by-name: ivar class)))
+                            (display-to port "\n"))
+                (class : <class> ivars))
+            (loop (class : <class> super)))))
+
+(define-method <object> (self dissect)
+    (self dissect-to: %%stdout))
+
+(define-method <object> (self instance-of? class)
+    (let loop ((c (self class)))
+        (cond
+            ((null? c) #f)
+            ((eq? c class) #t)
+            (else
+                (loop (c : <class> super))))))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/oo.tng	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,49 @@
+<class> methods at: #subClass:instanceVariables:classVariables: put:
+  [ self aName ivars cvars ->
+    n = self class new.
+    n super: self.
+    n printName: aName.
+    n instanceVariables: ivars.
+    n classVariables: cvars.
+    n ].
+
+<class> methods at: #inheritanceChain put:
+  [ self ->
+    cond super isNil => nil
+       | super :: super inheritanceChain ]
+
+<class> methods at: #writeOn: put:
+  [ self port -> {'#<class ', self printName, '>'} sequence: [ x -> port display: x ] ].
+
+<class> methods at: #displayOn: put:
+  [ self port -> self writeOn: port ].
+
+!<object> methodsFor: 'printing'
+!dissectOn: port
+
+    print = [ x -> port display: x ].
+
+    {'An instance of class ', self class printName, '.\n', 'Instance variables:\n'}
+      sequence: print.
+
+    loop = [ class ->
+    	     cond class isNil => nil
+	        | class == <object> => nil
+	        | ({'--------', class printName, '\n'} sequence: print.
+	     	   class instanceVariables sequence:
+	       	     [ ivar ->
+	       	       {'\t', ivar, '\t\t', self instanceVariableAt: ivar, '\n'} sequence: print ].
+	     	   loop (class super)) ].
+    loop (self class)
+].
+
+<object> methods at: #dissect put:
+  [ self -> self dissectOn: System stdout ].
+
+<object> methods at: #isInstanceOf: put:
+  [ self aClass ->
+    loop = [ c ->
+    	     cond c isNil => False
+	        | c == aClass => True
+		| loop (c super) ].
+    loop (self class) ].
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/packrat-utils.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,165 @@
+(require 'srfi-1)
+
+(define (rule-matcher nonterminal)
+  (lambda (b) (eq? (car b) nonterminal)))
+
+(define (list->lset = l)
+  (apply lset-adjoin = '() l))
+
+(define nonterminal-firsts
+  (let ()
+    (define (rule-firsts rule)
+      (if rule
+	  (list->lset eq? (map car (filter pair? (cdr rule))))
+	  '()))
+
+    (lambda (nonterminal grammar)
+      (let loop ((seen '())
+		 (work (list (rule-firsts (assq nonterminal grammar)))))
+	(if (null? work)
+	    seen
+	    (let ((firsts (car work))
+		  (remaining-work (cdr work)))
+	      (loop (apply lset-adjoin eq? seen firsts)
+		    (fold (lambda (rule acc)
+			    (if (memq rule seen)
+				acc
+				(let ((f (rule-firsts (assq rule grammar))))
+				  (if (null? f)
+				      acc
+				      (cons f acc)))))
+			  remaining-work
+			  firsts))))))))
+
+(define (rule-left-recursive? nonterminal grammar)
+  (if (memq nonterminal (nonterminal-firsts nonterminal grammar))
+      #t
+      #f))
+
+(define (rule-degenerate? nonterminal terminals grammar)
+  (let ((firsts (nonterminal-firsts nonterminal grammar)))
+    (and (memq nonterminal firsts)
+	 (null? (lset-intersection eq? terminals firsts)))))
+
+(define (factor-left-recursion grammar)
+  (let* ((nonterminals (list->lset eq? (map car grammar)))
+	 (allnames (apply lset-union eq? nonterminals (map cddr grammar)))
+	 (terminals (lset-difference eq? allnames nonterminals))
+
+	 (grammar (map (lambda (nonterminal)
+			 (cons nonterminal
+			       (map cddr (filter (rule-matcher nonterminal) grammar))))
+		       nonterminals)))
+    (for-each (lambda (nonterminal)
+		(display "----------------------------------------")
+		(newline)
+		(display (list nonterminal '-->first (nonterminal-firsts nonterminal grammar)))
+		(newline)
+		(display (list nonterminal '-->rec (rule-left-recursive? nonterminal grammar)))
+		(newline)
+		(display (list nonterminal '-->degen
+			       (rule-degenerate? nonterminal terminals grammar)))
+		(newline))
+	      nonterminals)
+    'nothing))
+
+(define g
+  (map butlast
+       '((toplevel --> expr dot toplevel (0 . 2))
+	 (toplevel --> expr dot (0))
+	 (toplevel --> expr (0))
+
+	 (expr --> method-definition 0)
+	 (expr --> nary 0)
+	 (expr --> caret expr (reply 1))
+
+	 (nary --> binary nary-args ,fixup-nary)
+	 (nary --> binary)
+	 (nary-args --> selector binary nary-args ((0 1) . 2))
+	 (nary-args --> selector binary ((0 1)))
+
+	 (binary --> binary binaryop unary (send 1 (0 2)))
+	 (binary --> unary 0)
+	 (binaryop --> punct 0)
+
+	 (unary --> unary identifier (send 1 (0)))
+	 (unary --> value 0)
+
+	 (value --> simple-value 0)
+	 (value --> oparen expr cparen 1)
+	 (value --> oparen updates cparen (update #f 1))
+	 (value --> oparen expr pipe updates cparen (update 1 3))
+
+	 (simple-value --> identifier (ref 0))
+	 (simple-value --> identifier oparen updates cparen stateful-block
+		       (stateful-block 0 2 . 4))
+	 (simple-value --> stateless-block 0)
+	 (simple-value --> string (string 0))
+	 (simple-value --> symbol (symbol 0))
+	 (simple-value --> integer (number 0))
+
+	 (updates --> update updates (0 . 1))
+	 (updates --> update (0))
+	 (update --> identifier colonequal value (0 2))
+
+	 (stateful-block --> obrack binders stateful-expr-seq cbrack (1 2))
+	 (stateful-expr-seq --> stateful-expr dot stateful-expr-seq (0 . 2))
+	 (stateful-expr-seq --> stateful-expr (0))
+	 (stateful-expr-seq --> ())
+	 (stateful-expr --> identifier oparen updates cparen (loop 0 2))
+	 (stateful-expr --> expr 0)
+
+	 (stateless-block --> obrack binders expr-seq cbrack (block 1 2))
+	 (expr-seq --> let-expr dot expr-seq (0 . 2))
+	 (expr-seq --> let-expr (0))
+	 (expr-seq --> ())
+	 (let-expr --> identifier equal expr (let 0 2))
+	 (let-expr --> expr 0)
+
+	 (binders --> binders+ pipe 0)
+	 (binders --> ())
+	 (binders+ --> binder binders+ (0 . 1))
+	 (binders+ --> binder (0))
+	 (binder --> colon identifier 1)
+
+	 (method-definition --> method-params obrack expr-seq cbrack (method 0 2))
+	 (method-params --> method-param identifier (send 1 (0)))
+	 (method-params --> method-param binaryop method-param (send 1 (0 2)))
+	 (method-params --> method-param method-nary ,fixup-nary)
+	 (method-param --> underscore at value (#f 2))
+	 (method-param --> identifier at value (0 2))
+
+	 (method-nary --> selector method-param method-nary ((0 1) . 2))
+	 (method-nary --> selector method-param ((0 1)))
+	 )))
+
+(define g '((a --> d)
+	    (a --> a d)
+	    (b --> d)
+	    (b --> b d)
+	    (d --> e)
+	    (e --> f d)
+	    (e --> g)))
+
+(define g '((t --> a m)
+	    (t --> b n)
+	    (a --> c)
+	    (b --> c)
+	    (c --> d)
+	    (c --> a)))
+
+(define g
+  (map butlast
+       '((sum --> sum + val ,(lambda (a b c) (+ a c)))
+	 (sum --> val val ,(lambda (a b) a))
+	 (val --> num ,(lambda (a) a)))))
+
+(define g
+  (map butlast
+       '((sum --> val val sumk ,(lambda (a b k) (k a)))
+	 (val --> num ,(lambda (a) a))
+	 (sumk --> + val ,(lambda (b c) (lambda (a) (+ a c))))
+	 (sumk --> ,(lambda () (lambda (a) a))))))
+
+(pretty-print (factor-left-recursion g))
+(exit)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/parser-combinator.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,132 @@
+;; Simple Parser Combinator Library
+
+;;;; UNFINISHED and currently in a more-or-less broken state
+
+(require 'srfi-1)
+(require 'srfi-13)
+
+(define-record-type stream-methods
+  (make-stream-methods head tail pos)
+  stream-methods?
+  (head stream-head)
+  (tail stream-tail)
+  (pos stream-pos))
+
+(define (parser-transform handler)
+  (lambda (methods stream sv)
+    ;;(print (list 'transform stream sv))
+    (values #t stream (handler ((stream-pos methods) stream) sv))))
+
+(define (parser-inject value)
+  (parser-transform (lambda (pos sv) value)))
+
+(define (parser-literal pred?)
+  (lambda (methods stream sv)
+    ;;(print (list 'literal stream sv))
+    (let ((token ((stream-head methods) stream)))
+      (if (pred? token)
+	  (values #t ((stream-tail methods) stream) token)
+	  (values #f `(expected ,token) sv)))))
+
+(define (parser-shift handler parser)
+  (lambda (methods stream sv)
+    (let-values (((success next-or-error sv1) (parser methods stream sv)))
+      (if success
+	  (values #t next-or-error (handler sv1 sv))
+	  (values #f next-or-error sv1)))))
+
+(define (parser-fold kons knil parsers)
+  (lambda (methods stream sv0)
+    (let loop ((parsers parsers)
+	       (stream stream)
+	       (sv sv0))
+      (if (null? parsers)
+	  (values #t stream sv)
+	  (let-values (((success next-or-error sv1) ((car parsers) methods stream sv)))
+	    (if success
+		(loop (cdr parsers) next-or-error (kons sv1 sv))
+		(values #f next-or-error sv0)))))))
+
+(define (parser-fold* kons knil . parsers)
+  (parser-fold kons knil parsers))
+
+(define (parser-and parsers)
+  (parser-fold (lambda (tok sv) tok) #t parsers))
+
+(define (parser-and* . parsers)
+  (parser-and parsers))
+
+(define (parser-or parsers)
+  (lambda (methods stream sv0)
+    (let loop ((parsers parsers)
+	       (stream stream)
+	       (sv sv0))
+      (if (null? parsers)
+	  (values #f `(parser-or) sv)
+	  (let-values (((success next-or-error sv1) ((car parsers) methods stream sv)))
+	    (if success
+		(values #t next-or-error sv1)
+		(loop (cdr parsers) stream sv)))))))
+
+(define (parser-or* . parsers)
+  (parser-or parsers))
+
+(define (parser-repeat minrep maxrep parser)
+  (lambda (methods stream sv0)
+    (let loop ((count 0)
+	       (stream stream)
+	       (sv sv0))
+      (let-values (((success next-or-error sv1) (parser methods stream sv)))
+	(if success
+	    (if (and maxrep (>= count maxrep))
+		(values #f `(too-many-repeats ,count ,maxrep) sv0)
+		(loop (+ count 1) next-or-error sv1))
+	    (if (and minrep (>= count minrep))
+		(values #t next-or-error sv1)
+		(values #f `(too-few-repeats ,count ,minrep) sv0)))))))
+
+(define (scan-string literal-string)
+  (let ((chars (string->list literal-string)))
+    (parser-and*
+     (parser-fold cons
+		  '()
+		  (map (lambda (ch) (parser-literal (lambda (tok) (eqv? tok ch)))) chars))
+     (parser-transform (lambda (pos sv)
+			 (print (list 'scan-string sv))
+			 (list->string (reverse sv)))))))
+
+(define (string-stream-methods str)
+  (let ((len (string-length str)))
+    (values (make-stream-methods (lambda (i) (if (>= i len) #f (string-ref str i)))
+				 (lambda (i) (if (>= i len) #f (+ i 1)))
+				 (lambda (i) i))
+	    0)))
+
+(define (build-parser spec)
+  (cond
+   ((pair? spec)
+    (case (car spec)
+      ((/) (parser-or (map build-parser (cdr spec))))
+      ((seq) (parser-and (map build-parser (cdr spec))))
+      ((fold) (parser-fold (cadr spec) (caddr spec) (map build-parser (cdddr spec))))
+      ((transform) (parser-transform (cadr spec)))
+      ((inject) (parser-inject (cadr spec)))
+      ((repeat) (parser-repeat (cadr spec) (caddr spec) (build-parser (cadddr spec))))
+      ((+) (parser-repeat 1 #f (build-parser (cadr spec))))
+      ((*) (parser-repeat 0 #f (build-parser (cadr spec))))
+      (else (error "Invalid parser spec" spec))))
+   ((string? spec)
+    (scan-string spec))
+   ((procedure? spec)
+    spec)
+   (else (error "Invalid parser spec" spec))))
+
+(define (test)
+  (let-values (((m s) (string-stream-methods "goodbye, world")))
+    (let ((parser (build-parser `(seq (fold ,cons ()
+					    (/ "hello"
+					       (fold ,cons () "good" "bye")
+					       "goodbye")
+					    ", world")
+				      (transform ,(lambda (pos sv) (reverse sv)))))))
+      (parser m s '()))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/queue.ss	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,52 @@
+;;; <queue.ss> ---- Excessively simple queue implementation.
+;;; Copyright (C) 2004 by Tony Garnock-Jones.
+
+;;; This is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+
+;;; This software is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+
+;;; Author: Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
+
+(module queue mzscheme
+  (provide make-q enq! deq! q->list list->q q-empty?)
+
+  (define (make-q)
+    (cons '() '()))
+
+  (define (enq! q e)
+    (let ((cell (cons e '())))
+      (if (null? (car q))
+	  (set-car! q cell)
+	  (set-cdr! (cdr q) cell))
+      (set-cdr! q cell)))
+
+  (define (deq! q)
+    (if (null? (car q))
+	#f
+	(let ((v (caar q)))
+	  (set-car! q (cdar q))
+	  (if (null? (car q))
+	      (set-cdr! q '()))
+	  v)))
+
+  (define (q->list q)
+    (car q))
+
+  (define (list->q lst)
+    (let ((q (make-q)))
+      (for-each (lambda (x) (enq! q x)) lst)
+      q))
+
+  (define (q-empty? q)
+    (null? (car q)))
+)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/stm/cell.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,107 @@
+;;
+;; Issues remaining:
+;;
+;; - pending-thunks need to be able to remove their thread from all cells pended-upon
+;; - retries need to merge transaction-logs in proper nested fashion
+;; - need to implement orelse
+;;
+
+(define-record-type cell
+  (make-cell* owner pending value)
+  cell?
+  (owner cell-owner set-cell-owner!)
+  (pending cell-pending set-cell-pending!)
+  (value cell-value set-cell-value!))
+
+(define-record-type transaction
+  (make-transaction* parent restart abort-catcher log)
+  transaction?
+  (parent transaction-parent)
+  (restart transaction-restart)
+  (abort-catcher transaction-abort-catcher)
+  (log transaction-log set-transaction-log!))
+
+(define-record-type log-entry
+  (make-log-entry cell previous-owner initial-value next)
+  log-entry?
+  (cell log-entry-cell)
+  (previous-owner log-entry-previous-owner)
+  (initial-value log-entry-initial-value)
+  (next log-entry-next))
+
+;---------------------------------------------------------------------------
+
+(define (make-cell initial-value)
+  (make-cell* #f '() initial-value))
+
+;---------------------------------------------------------------------------
+
+(define tasklist '())
+
+(define (spawn thunk)
+  ...)
+
+;---------------------------------------------------------------------------
+
+(define current-transaction (make-parameter #f))
+
+(define (require-transaction where)
+  (or (current-transaction)
+      (error "transaction required" where)))
+
+(define (cell-unlocked? cell requesting-transaction)
+  (let ((owner (cell-owner cell)))
+    (or (not owner)
+	(let loop ((txn requesting-transaction))
+	  (cond ((not txn) #f)
+		((eq? txn owner) #t)
+		(else (loop (transaction-parent txn))))))))
+
+(define (access-cell! cell action-thunk)
+  (let ((transaction (require-transaction 'access-cell!))
+	(previous-owner (cell-owner cell)))
+    (cond
+     ((eq? transaction previous-owner) (action-thunk))
+     ((cell-unlocked? cell transaction)
+      (let ((new-log (make-log-entry cell
+				     previous-owner
+				     (cell-value cell)
+				     (transaction-log transaction))))
+	(set-transaction-log! transaction new-log)
+	(set-cell-owner! cell transaction)
+	(action-thunk)))
+     (else
+      (internal-retry (cons cell (map log-entry-cell (transaction-log transaction))))))))
+
+(define (get-cell cell)
+  (access-cell! cell (lambda () (cell-value cell))))
+
+(define (set-cell! cell value)
+  (access-cell! cell (lambda () (set-cell-value! cell value))))
+
+(define (retry)
+  (internal-retry (map log-entry-cell (transaction-log (require-transaction 'retry)))))
+
+(define (abort-transaction result)
+  ((transaction-abort-catcher (require-transaction 'abort-transaction)) result)
+  ;; Paranoia:
+  (error "transaction-abort-catcher returned!"))
+
+(define (internal-retry accessed-cells)
+  ...)
+
+(define (with-transaction thunk)
+  (call-with-current-continuation
+   (lambda (return-from-transaction)
+     (let* ((abort-transaction (lambda (result)
+				 ...))
+	    (restart (lambda ()
+		       ...))
+	    (transaction (make-transaction* (current-transaction)
+					    restart
+					    abort-transaction
+					    #f)))
+       (parameterize ((current-transaction transaction))
+	 (let ((result (thunk)))
+	   ...
+	   result))))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/tng-scratch.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,138 @@
+(require (lib "9.ss" "srfi")
+	 (lib "1.ss" "srfi")
+	 "queue.ss")
+
+(define *runq* (make-q))
+
+(define (schedule thunk)
+  (enq! *runq* thunk))
+
+(define *throw-to-mainloop* '*throw-to-mainloop-not-initialised*)
+
+(define (mainloop)
+  (begin
+    (call-with-current-continuation (lambda (cc) (set! *throw-to-mainloop* cc)))
+    (if (q-empty? *runq*)
+	(wait-for-events)
+	(begin
+	  ((deq! *runq*))
+	  (mainloop)))))
+
+(define (throw-to-mainloop)
+  (*throw-to-mainloop* #f))
+
+(define (wait-for-events) ;; %%%
+  (display "Waiting for events.")
+  (newline)
+  (exit))
+
+(define-record-type 
+
+(define-record-type oop
+  (make-oop outputs input slots)
+  oop?
+  (outputs oop-outputs set-oop-outputs!)
+  (input oop-input set-oop-input!)
+  (slots oop-slots set-oop-slots!))
+
+(define-record-type input-handler
+  (make-input-handler next proc datum)
+  input-handler?
+  (next input-handler-next)
+  (proc input-handler-proc)
+  (datum input-handler-datum))
+
+(define *nil* '*nil*)
+
+(define (primitive-new n)
+  (make-oop (make-q) #f (make-vector n *nil*)))
+
+(define (oop-ref o n)
+  (vector-ref (oop-slots o) n))
+
+(define (oop-set! o n x)
+  (vector-set! (oop-slots o) n x))
+
+(define (oop-length o)
+  (vector-length (oop-slots o)))
+
+(define (oop-send-full! oop message)
+  (let ((handler (oop-input oop)))
+    (if (not handler)
+	(enq! (oop-outputs oop) message)
+	(schedule (lambda () ((input-handler-proc handler)
+			      (input-handler-datum handler)
+			      #f
+			      message))))))
+
+;; Channel send
+;;   - RPC service ready
+;;     (A) - if (isa message <message>),
+;;              call service with selector+args, collect result, send to continuation
+;;              else ERROR <message> expected
+;;   - reader ready
+;;     (B) - schedule reader action
+;;   - none ready
+;;     (C) - enqueue message
+;; Channel receive
+;;   - RPC client ready
+;;     - as for (B)
+;;   - sender ready
+;;     - as for (B)
+;;   - none ready
+;;     (D) - enqueue reader
+;; RPC client
+;;   - RPC service ready
+;;     (E) - call service with selector+args, returning result directly
+;;   - reader ready
+;;     (F) - build message and schedule reader action
+;;   - none ready
+;;     (G) - build message and enqueue
+;; RPC service
+;;   - RPC client ready
+;;     - as for (A)
+;;   - sender ready
+;;     - as for (A)
+;;   - none ready
+;;     (H) - enqueue RPC service
+
+(define (oop-send-fast! oop selector argv)
+  (let ((handler (oop-input oop)))
+    (if (not handler)
+	(call-with-current-continuation
+	 (lambda (k)
+	   (let ((message (make-message k selector argv)))
+	     (enq! (oop-outputs oop) message)
+	     (throw-to-mainloop))))
+	((input-handler-proc handler)
+	 (input-handler-datum handler)
+	 selector
+	 argv))))
+
+(define (*restoring-handler* datum selector message)
+  (set-oop-input! (vector-ref datum 0)
+		  (vector-ref datum 1))
+  ((vector-ref datum 2)
+   (vector-ref datum 3)
+   selector
+   message))
+
+(define (oop-hook-oneshot-input! oop handler-proc handler-datum)
+  (let ((outputs (oop-outputs oop)))
+    (if (q-empty? outputs)
+	(let ((old-handler (oop-input oop)))
+	  (set-oop-input! oop (make-input-handler *restoring-handler*
+						  (vector oop
+							  old-handler
+							  handler-proc
+							  handler-datum))))
+	(let ((message (deq! outputs)))
+	  (schedule
+	  (handler-proc
+	   handler-datum
+	   #f
+	   message)
+
+(define (oop-hook-repeating-input! oop handler-proc handler-datum)
+  (set-oop-input! oop (make-input-handler handler-proc
+					  handler-datum)))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/tng.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,56 @@
+(require (lib "9.ss" "srfi")
+	 (lib "1.ss" "srfi")
+	 "queue.ss")
+
+(define *runq* (make-q))
+
+(define (schedule thunk)
+  (enq! *runq* thunk))
+
+(define *throw-to-mainloop* '*throw-to-mainloop-not-initialised*)
+
+(define (mainloop)
+  (begin
+    (call-with-current-continuation (lambda (cc) (set! *throw-to-mainloop* cc)))
+    (if (q-empty? *runq*)
+	(wait-for-events)
+	(begin
+	  ((deq! *runq*))
+	  (mainloop)))))
+
+(define (throw-to-mainloop)
+  (*throw-to-mainloop* #f))
+
+(define (wait-for-events) ;; %%%
+  (display "Waiting for events.")
+  (newline)
+  (exit))
+
+;; Boudol's Blue Calculus
+;;---------------------------------------------------------------------------
+
+;; P = A | D | (P|P) | (u)P
+;; A = u | \u.P | Pu
+;; D = u:=P | u==P
+;; E = [] | Eu | (E|P) | (P|E) | (u)E
+
+;; STRUCTURAL EQUIVALENCE
+;;---------------------------------------------------------------------------
+;; equivalence, containing alpha-conversion
+;; par commutative, associative
+;; (u)P | Q  ===  (u)(P | Q)  when u not free in Q
+;;   (P|Q)u  ===  (Pu | Qu)
+;;  ((u)P)v  ===  (u)(Pv)     when u <> v
+;;       Du  ===  D
+;;     u==P  ===  u:=(P | u==P)
+;; equivalence of processes implies equivalence of evaluation contexts E
+
+;; REDUCTION
+;;---------------------------------------------------------------------------
+;;  (\u.P)v  -->  P{v/u}      small beta reduction
+;; u | u:=P  -->  P           rho - resource fetching
+;;
+;; P-->P' => E[P]-->E[P']     context
+;;
+;; P-->P' & Q===P => Q-->P'   structural
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/transactions/Makefile	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,7 @@
+all: splay-tree.so
+
+clean:
+	rm -f splay-tree.so
+
+%.so: %.scm
+	csc -O3 -s $<
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/transactions/old-splay.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,46 @@
+;; Splay tree partitioning, from Okasaki's book:
+(define (splay-tree-partition cmp-pivot t k)
+  (let walk ((t t)
+	     (k k))
+    (if (null? t)
+	(k '() '())
+	(let ((element (bst-node-element t))
+	      (left (bst-node-left t))
+	      (right (bst-node-right t)))
+	  (if (negative? (cmp-pivot element))
+	      (if (null? left)
+		  (k '() t)
+		  (let ((le (bst-node-element left))
+			(ll (bst-node-left left))
+			(lr (bst-node-right left)))
+		    (if (negative? (cmp-pivot le))
+			(walk ll (lambda (small big)
+				   (k small
+				      (make-bst-node le big (make-bst-node element lr right)))))
+			(walk lr (lambda (small big)
+				   (k (make-bst-node le ll small)
+				      (make-bst-node element big right)))))))
+	      (if (null? right)
+		  (k t '())
+		  (let ((re (bst-node-element right))
+			(rl (bst-node-left right))
+			(rr (bst-node-right right)))
+		    (if (negative? (cmp-pivot re))
+			(walk rl (lambda (small big)
+				   (k (make-bst-node element left small)
+				      (make-bst-node re big rr))))
+			(walk rr (lambda (small big)
+				   (k (make-bst-node re (make-bst-node element left rl) small)
+				      big)))))))))))
+
+(define (splay-tree-insert cmp t x)
+  (splay-tree-partition (binary-curry cmp x)
+			t
+			(lambda (smaller bigger)
+			  (make-bst-node x smaller bigger))))
+
+(define (splay-tree-find predcmp t)
+  (splay-tree-partition predcmp
+			t
+			(lambda (smaller bigger)
+			  (
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/transactions/old-world.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,134 @@
+;; An implementation of transactional world state, after Henry Baker's
+;; ideas in "Worlds in Collision: A Mostly Functional Model of
+;; Concurrency Control and Recovery" (Unpublished memo, 1990).
+
+;; Ada database package specification, [Baker90] p6:
+; package database is
+;   type page is private;
+;   subtype index is 0 .. (N-1);
+;   type world is private;
+;   null_world: constant world;
+;   function lookup(i: index; w: world) return page;
+;   function update(i: index; p: page; w: world) return world;
+;   procedure assign_world(w: out world; w: world);
+;   procedure nupdate(i: index; p: page; w: in out world);
+; end database;
+
+;; This implementation:
+;; - page == object
+;; - index == symbol
+;; - world == opaque map from index to page
+
+(require 'splay-tree)
+
+(define-record-type world
+  (make-world map)
+  world?
+  (map world-map set-world-map!))
+
+(define (entry-cmp ea eb)
+  (let ((a (car ea))
+	(b (car eb)))
+    (cond
+     ((eq? a b) 0)
+     ((string<? (symbol->string a) (symbol->string b)) -1)
+     (else 1))))
+
+(define (entry-cmp1 a)
+  (let ((sa (symbol->string a)))
+    (lambda (eb)
+      (let ((b (car eb)))
+	(cond
+	 ((eq? a b) 0)
+	 ((string<? sa (symbol->string b)) -1)
+	 (else 1))))))
+
+(define (deep-binding)
+  ;; switching from world-to-world: O(1)
+  ;; lookup: O(M)
+  ;; update/world-create: O(1)
+  (let ()
+    (define null-world (make-world '()))
+
+    (define (lookup i w default-page)
+      (cond
+       ((assq i (world-map w)) => cdr)
+       (else default-page)))
+
+    (define (update i p w)
+      (make-world (cons (cons i p) (world-map w))))
+
+    (define (assign-world w1 w2)
+      (set-world-map! w1 (world-map w2)))
+
+    (define (nupdate i p w)
+      (assign-world w (update i p w)))
+
+    (values null-world
+	    lookup
+	    update
+	    assign-world
+	    nupdate)))
+
+(define (deep-binding/splay-tree)
+  ;; switching from world-to-world: O(1)
+  ;; lookup: O(log N)
+  ;; update/world-create: O(log N)
+  (let ()
+    (define null-world (make-world '()))
+
+    (define (lookup i w default-page)
+      (let ((cmp (entry-cmp1 i)))
+	(splay-tree-find cmp
+			 (world-map w)
+			 (lambda (new-map)
+			   (set-world-map! w new-map)
+			   (cdr (bst-node-element new-map)))
+			 (lambda (new-map)
+			   (set-world-map! w new-map)
+			   default-page))))
+
+    (define (update i p w)
+      (let ((cmp (entry-cmp1 i)))
+	(make-world (splay-tree-insert/replace cmp
+					       (world-map w)
+					       (cons i p)))))
+
+    (define (assign-world w1 w2)
+      (set-world-map! w1 (world-map w2)))
+
+    (define (nupdate i p w)
+      (assign-world w (update i p w)))
+
+    (values null-world
+	    lookup
+	    update
+	    assign-world
+	    nupdate)))
+
+(define (shallow-binding)
+  (let ()
+    (define null-world (make-world '()))
+
+    (define (onestep nw ow)
+      (set-cdr! (
+
+    (define (lookup i w default-page)
+      (cond
+       ((assq i (world-map w)) => cdr)
+       (else default-page)))
+
+    (define (update i p w)
+      (make-world (cons (cons i p) (world-map w))))
+
+    (define (assign-world w1 w2)
+      (set-world-map! w1 (world-map w2)))
+
+    (define (nupdate i p w)
+      (assign-world w (update i p w)))
+
+    (values null-world
+	    lookup
+	    update
+	    assign-world
+	    nupdate)))
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/transactions/splay-tree.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,288 @@
+;; Splay trees, partly from Chris Okasaki's "Purely Functional Data
+;; Structures" but mostly from Tom Lord's "Hackerlab" C library
+;; implementation.
+;;
+;; The Hackerlab implementation is a bit buggy (eg. the implementation
+;; of delete-root and raise) so its been useful mainly as an
+;; implementation template - I've had to reverify the actual
+;; algorithms from scratch to make sure they're correct here.
+
+;; Algebraic data type; we use '() as the empty tree.
+(define-record-type bst-node
+  (make-bst-node element left right)
+  bst-node?
+  (element bst-node-element)
+  (left bst-node-left)
+  (right bst-node-right))
+
+(define (bst? t)
+  (or (null? t)
+      (bst-node? t)))
+
+(define (binary-curry f a)
+  (lambda (b)
+    (f a b)))
+
+;; Suggested API, from Tom Lord's Hackerlab splay trees:
+;;
+;; (splay-tree-singleton x)
+;; (splay-tree-find-raw predcmp tree)
+;; (splay-tree-find-min tree)
+;; (splay-tree-find-max tree)
+;; (splay-tree-raise predcmp tree)
+;; (splay-tree-raise-min tree)
+;; (splay-tree-raise-max tree)
+;; (splay-tree-insert-after tree x)
+;; (splay-tree-insert-before tree x)
+;; (splay-tree-delete-root tree)
+
+(define (splay-tree-singleton x)
+  (make-bst-node x '() '()))
+
+;; Non-splaying search: returns a bst node, or #f
+(define (splay-tree-find-raw predcmp tree)
+  (let walk ((tree tree))
+    (if (null? tree)
+	#f
+	(let ((order (predcmp (bst-node-element tree))))
+	  (cond
+	   ((negative? order) (walk (bst-node-left tree)))
+	   ((positive? order) (walk (bst-node-right tree)))
+	   (else tree))))))
+
+(define (splay-tree-find-min tree)
+  (if (null? tree)
+      #f
+      (let walk ((tree tree))
+	(let ((left (bst-node-left tree)))
+	  (if (null? left)
+	      tree
+	      (walk left))))))
+
+(define (splay-tree-find-max tree)
+  (if (null? tree)
+      #f
+      (let walk ((tree tree))
+	(let ((right (bst-node-right tree)))
+	  (if (null? right)
+	      tree
+	      (walk right))))))
+
+(define (splay-tree-raise cmp-pivot tree)
+  (if (null? tree)
+      tree
+      (let walk ((tree tree))
+	(let* ((element (bst-node-element tree))
+	       (left (bst-node-left tree))
+	       (right (bst-node-right tree))
+	       (order (cmp-pivot element)))
+	  (cond
+	   ((negative? order)
+	    (if (null? left)
+		tree
+		(let* ((element2 (bst-node-element left))
+		       (left2 (bst-node-left left))
+		       (right2 (bst-node-right left))
+		       (order2 (cmp-pivot element2)))
+		  (cond
+		   ((and (negative? order2) (bst-node? left2))
+		    (let ((new2 (walk left2)))
+		      (make-bst-node (bst-node-element new2)
+				     (bst-node-left new2)
+				     (make-bst-node element2
+						    (bst-node-right new2)
+						    (make-bst-node element right2 right)))))
+		   ((and (positive? order2) (bst-node? right2))
+		    (let ((new2 (walk right2)))
+		      (make-bst-node (bst-node-element new2)
+				     (make-bst-node element2 left2 (bst-node-left new2))
+				     (make-bst-node element (bst-node-right new2) right))))
+		   (else (make-bst-node element2 left2 (make-bst-node element right2 right)))))))
+	   ((positive? order)
+	    (if (null? right)
+		tree
+		(let* ((element2 (bst-node-element right))
+		       (left2 (bst-node-left right))
+		       (right2 (bst-node-right right))
+		       (order2 (cmp-pivot element2)))
+		  (cond
+		   ((and (negative? order2) (bst-node? left2))
+		    (let ((new2 (walk left2)))
+		      (make-bst-node (bst-node-element new2)
+				     (make-bst-node element left (bst-node-left new2))
+				     (make-bst-node element2 (bst-node-right new2) right2))))
+		   ((and (positive? order2) (bst-node? right2))
+		    (let ((new2 (walk right2)))
+		      (make-bst-node (bst-node-element new2)
+				     (make-bst-node element2
+						    (make-bst-node element left left2)
+						    (bst-node-left new2))
+				     (bst-node-right new2))))
+		   (else (make-bst-node element2 (make-bst-node element left left2) right2))))))
+	   (else tree))))))
+
+(define (splay-tree-raise-min tree)
+  (splay-tree-raise (lambda (v) -1) tree))
+
+(define (splay-tree-raise-max tree)
+  (splay-tree-raise (lambda (v) 1) tree))
+
+(define (splay-tree-insert-after tree x)
+  (cond
+   ((null? tree) (splay-tree-singleton x))
+   (else (make-bst-node x
+			(make-bst-node (bst-node-element tree)
+				       (bst-node-left tree)
+				       '())
+			(bst-node-right tree)))))
+
+(define (splay-tree-insert-before tree x)
+  (cond
+   ((null? tree) (splay-tree-singleton x))
+   (else (make-bst-node x
+			(bst-node-left tree)
+			(make-bst-node (bst-node-element tree)
+				       '()
+				       (bst-node-right tree))))))
+
+;; Well, I invented this algorithm. Chances are it's inefficient, or
+;; it doesn't work, or both.
+(define (splay-tree-delete-root tree)
+  (if (null? tree)
+      (error "Cannot delete root of empty splay tree")
+      (let* ((left (bst-node-left tree))
+	     (right (bst-node-right tree))
+	     (new-left (splay-tree-raise-max left)))
+	(if (null? new-left)
+	    right
+	    (if (null? (bst-node-right new-left))
+		(let ((new-tree (make-bst-node (bst-node-element new-left)
+					       (bst-node-left new-left)
+					       right)))
+		  ;;(pretty-print (list 'DEL
+		  ;;(bst->alist tree)
+		  ;;(bst->alist new-tree)))
+		  new-tree)
+		(error "Invariant violation: need null right on max-raised splay tree"
+		       (list (bst->alist left)
+			     (bst->alist new-left))))))))
+
+(define (splay-tree-insert cmp-pivot tree x)
+  (if (null? tree)
+      (splay-tree-singleton x)
+      (let ((new-tree (splay-tree-raise cmp-pivot tree)))
+	(if (positive? (cmp-pivot (bst-node-element new-tree)))
+	    (splay-tree-insert-after new-tree x)
+	    (splay-tree-insert-before new-tree x)))))
+
+(define (splay-tree-insert/replace cmp-pivot tree x)
+  (if (null? tree)
+      (splay-tree-singleton x)
+      (let* ((new-tree (splay-tree-raise cmp-pivot tree))
+	     (order (cmp-pivot (bst-node-element new-tree))))
+	(cond
+	 ((negative? order) (splay-tree-insert-before new-tree x))
+	 ((positive? order) (splay-tree-insert-after new-tree x))
+	 (else (make-bst-node x (bst-node-left new-tree) (bst-node-right new-tree)))))))
+
+(define (splay-tree-find predcmp tree k-found k-notfound)
+  (if (null? tree)
+      (k-notfound tree)
+      (let ((new-tree (splay-tree-raise predcmp tree)))
+	(if (zero? (predcmp (bst-node-element new-tree)))
+	    (k-found new-tree)
+	    (k-notfound new-tree)))))
+
+(define (splay-tree-delete predcmp tree k-found . opt-k-notfound)
+  (let ((k-notfound (if (null? opt-k-notfound) k-found (car opt-k-notfound))))
+    (if (null? tree)
+	(k-notfound tree)
+	(let ((new-tree (splay-tree-raise predcmp tree)))
+	  (if (zero? (predcmp (bst-node-element new-tree)))
+	      (k-found (splay-tree-delete-root new-tree))
+	      (k-notfound new-tree))))))
+
+(define (bst->list t)
+  (let walk ((t t)
+	     (acc '()))
+    (if (null? t)
+	acc
+	(walk (bst-node-left t)
+	      (cons (bst-node-element t)
+		    (walk (bst-node-right t) acc))))))
+
+(define (bst->alist t)
+  (let ((v (let walk ((t t))
+	     (if (null? t)
+		 (cons 0 t)
+		 (let ((l (walk (bst-node-left t)))
+		       (r (walk (bst-node-right t))))
+		   (list (+ (max (car l) (car r)) 1)
+			 (bst-node-element t)
+			 (cdr l)
+			 (cdr r)))))))
+    `((height ,(car v))
+      (tree ,(cdr v)))))
+
+(define (bst-height t)
+  (if (null? t)
+      0
+      (+ (max (bst-height (bst-node-left t))
+	      (bst-height (bst-node-right t)))
+	 1)))
+
+(define (bst-size t)
+  (if (null? t)
+      0
+      (+ (bst-size (bst-node-left t))
+	 (bst-size (bst-node-right t))
+	 1)))
+
+(define (splay-tree-tests)
+  (define (test)
+    (let ((remove (lambda (i t)
+		    (splay-tree-delete (binary-curry - i) t
+				       (lambda (t)
+					 (pretty-print (list 'FOUND i (bst->alist t)))
+					 t)
+				       (lambda (t)
+					 (pretty-print (list 'NOTFOUND i (bst->alist t)))
+					 t)))))
+      (let* ((t '())
+	     (t (do ((i 0 (+ i 1))
+		     (t t (splay-tree-insert (lambda (b) (- (- 50 i) b))
+					     (splay-tree-insert - t i)
+					     (- 50 i))))
+		    ((= i 10)
+		     (pretty-print (list 'FINALINS (bst->alist t)))
+		     t)
+		  (pretty-print (list 'INTERIM i (bst->alist t)))))
+	     (t (do ((i 0 (+ i 2))
+		     (t t (remove i (remove (- 50 i 1) t))))
+		    ((> i 50)
+		     (pretty-print (list 'FINALDEL (bst->alist t)))
+		     t))))
+	'done)))
+  (require 'srfi-1)
+  (define (test2)
+    (let ((t (time (do ((i 0 (+ i 1))
+			(t '() (let ((v (random 10000)))
+				 (splay-tree-insert (lambda (b) (- v b)) t v))))
+		       ((= i 10000) t)))))
+      (pretty-print (bst-height t))
+      (let* ((oldt t)
+	     (t (time (do ((i 0 (+ i 1))
+			   (t t (splay-tree-find (binary-curry - (random 10000))
+						 t
+						 (lambda (t) t)
+						 (lambda (t) t))))
+			  ((= i 50000) t)))))
+	(pretty-print (bst-height t))
+	(pretty-print (eq? t oldt))
+	(time
+	 (let loop ((t t))
+	   (if (null? t)
+	       (pretty-print (bst-height t))
+	       (let ((new-t (splay-tree-raise-min t)))
+		 (loop (splay-tree-delete-root new-t)))))))))
+  (test2))
Binary file experiments/transactions/splay-tree.so has changed
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/transactions/world.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,158 @@
+;; An implementation of transactional world state, after Henry Baker's
+;; ideas in "Worlds in Collision: A Mostly Functional Model of
+;; Concurrency Control and Recovery" (Unpublished memo, 1990).
+
+;; NOTE: Not safe for preemptive concurrent use, yet - no locking
+;; protocols have been implemented. However, this code is safe for use
+;; in non-preemptive (coroutining) systems.
+
+;; Ada database package specification, [Baker90] p6:
+; package database is
+;   type page is private;
+;   subtype index is 0 .. (N-1);
+;   type world is private;
+;   null_world: constant world;
+;   function lookup(i: index; w: world) return page;
+;   function update(i: index; p: page; w: world) return world;
+;   procedure assign_world(w: out world; w: world);
+;   procedure nupdate(i: index; p: page; w: in out world);
+; end database;
+
+;;---------------------------------------------------------------------------
+;; World Trees
+
+(define-record-type world
+  (make-world binding parent)
+  world?
+  (binding world-binding set-world-binding!)
+  (parent world-parent set-world-parent!))
+
+(define *database* (make-hash-table))
+(define *default-page* #f)
+
+(define (read-database i)
+  (hash-table-ref *database* i *default-page*))
+
+(define (write-database! i p)
+  (hash-table-set! *database* i p))
+
+(define (deep-binding)
+  (let ()
+    (define *null-world* '())
+
+    (define (lookup i w)
+      (let walk ((w w))
+	(cond
+	 ((or (null? w) (null? (world-parent w))) (read-database i))
+	 ((eq? (car (world-binding w)) i) (cdr (world-binding w)))
+	 (else (walk (world-parent w))))))
+
+    (define (update i p w)
+      (make-world (cons i p) w))
+
+    (define (move-to w)
+      w)
+
+    (values *null-world*
+	    lookup
+	    update
+	    move-to)))
+
+(define (shallow-binding)
+  (let ()
+    (define *null-world* (make-world 'no-binding '()))
+
+    (define (onestep nw ow)
+      (set-world-parent! nw '())
+      (set-world-parent! ow nw)
+      (let* ((nbinding (world-binding nw))
+	     (old-page (read-database (car nbinding))))
+	(write-database! (car nbinding) (cdr nbinding))
+	(set-cdr! nbinding old-page)
+	(set-world-binding! nw (world-binding ow))
+	(set-world-binding! ow nbinding))
+      nw)
+
+    (define (reroot w)
+      (cond
+       ((null? (world-parent w)) w)
+       (else (onestep w (reroot (world-parent w))))))
+
+    (define (lookup i w)
+      (assert (null? (world-parent w)) "failed shallow assumption in lookup")
+      (read-database i))
+
+    (define (update i p w)
+      (assert (null? (world-parent w)) "failed shallow assumption in update")
+      (onestep (make-world (cons i p) w) w))
+
+    (define (move-to w)
+      (reroot w))
+
+    (values *null-world*
+	    lookup
+	    update
+	    move-to)))
+
+(define (lazy-shallow-binding)
+  (let ()
+    (define *null-world* (make-world 'no-binding '()))
+
+    (define (onestep nw ow)
+      (set-world-parent! nw '())
+      (set-world-parent! ow nw)
+      (let* ((nbinding (world-binding nw))
+	     (old-page (read-database (car nbinding))))
+	(write-database! (car nbinding) (cdr nbinding))
+	(set-cdr! nbinding old-page)
+	(set-world-binding! nw (world-binding ow))
+	(set-world-binding! ow nbinding))
+      nw)
+
+    (define (reroot w)
+      (cond
+       ((null? (world-parent w)) w)
+       (else (onestep w (reroot (world-parent w))))))
+
+    (define (lookup i w)
+      (cond
+       ((null? (world-parent w)) (read-database i))
+       ((eq? (car (world-binding w)) i) (lookup i (reroot w)))
+       (else (lookup i (world-parent w)))))
+
+    (define (update i p w)
+      (reroot (make-world (cons i p) w)))
+
+    (define (move-to w)
+      (reroot w))
+
+    (values *null-world*
+	    lookup
+	    update
+	    move-to)))
+
+;;---------------------------------------------------------------------------
+;; Transactions
+
+(define-values (*null-world*
+		lookup
+		update
+		move-to)
+  (lazy-shallow-binding))
+
+(define-syntax nupdate
+  (syntax-rules ()
+    ((_ i p w)
+     (set! w (move-to (update i p w))))))
+
+(define *current-world* *null-world*)
+
+(define (non-nested-transaction body)
+  (let* ((start-world (move-to *current-world*))
+	 (commit (lambda (end-world)
+		   (if (eq? *current-world* start-world)
+		       (begin
+			 (set! *current-world* end-world)
+			 #t)
+		       #f))))
+    (body start-world commit)))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/image.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,210 @@
+(define (serialize-image!)
+  (define seen (make-hash-table eq?))
+  (define counter 0)
+
+  (define (lookup o)
+    (hash-table-ref seen o))
+
+  (define (store! o)
+    (let ((ref counter))
+      (set! counter (+ counter 1))
+      (hash-table-set! seen o ref)
+      ref))
+
+  (define (reference o walker)
+    (cond
+     ((lookup o))
+     (else (let ((ref (store! o)))
+	     (vector ref (walker o))))))
+
+  (define (walk-primitive o)
+    o)
+
+  (define (walk o)
+    (cond
+     ((object? o) (reference o walk-object))
+
+     ((or (number? o)
+	  (char? o)
+	  (symbol? o)
+	  (string? o)
+	  (boolean? o)
+	  (null? o))
+      (reference o walk-primitive))
+
+     ((pair? o) (reference o walk-pair))
+     ((vector? o) (reference o walk-vector))
+
+     (else
+      (if (not (procedure? o))
+	  (debug 1 "Pinching off primitive reference: "o))
+      (reference '() walk-primitive))))
+
+  (define (walk-pair o)
+    (let* ((a (walk (car o)))
+	   (d (walk (cdr o))))
+      (cons a d)))
+
+  (define (walk-vector o)
+    (list->vector (cons 'v (map-in-order walk (vector->list o)))))
+
+  (define (walk-object o)
+    (let* ((layout (reference (object-layout o) walk-layout))
+	   (slots (map-in-order walk (vector->list (object-slots o))))
+	   (category (cond
+		      ((and (has-slot? o 'traits)
+			    (eq? (get-slot o 'traits) *traits-method*))
+		       (cond
+			((not (eq? (get-slot o 'primitive) *nil*)) 'p)
+			((not (eq? (get-slot o 'accessor) *nil*)) 'a)
+			(else 'o)))
+		      (else 'o))))
+      (vector category layout slots)))
+
+  (define (walk-layout layout)
+    (let ((answer '()))
+      (layout-for-each layout
+		       (lambda (slot-name slot)
+			 (push! answer (reference slot walk-slot))))
+      (reverse answer)))
+
+  (define (walk-slot slot)
+    (list (slot-name slot)
+	  (slot-index slot)
+	  (slot-delegating? slot)
+	  (slot-kind slot)
+	  (map-in-order walk-role (slot-roles slot))))
+
+  (define (walk-role role)
+    (list (bitset->list (role-positions role))
+	  (bitset->list (role-requirements role))
+	  (walk (role-method role))))
+
+  (store-globals-to-image!)
+
+  (let ((literals '())
+	(roots (map-in-order (lambda (entry)
+			       (cons (car entry)
+				     (walk (cdr entry))))
+			     (hash-table->list *image-root*))))
+    (for-each-literal-object (lambda (literal object)
+			       (when (or (lookup literal)
+					 (assq literal *root-literals*))
+				 (let* ((l (walk literal))
+					(o (walk object)))
+				   (push! literals (cons l o))))))
+    (cons roots
+	  (reverse literals)))
+)
+
+;---------------------------------------------------------------------------
+
+(define (deserialize-image! image)
+  (define seen (make-hash-table eq?))
+  (define fixups '())
+
+  (define (lookup x)
+    (or (hash-table-ref seen x)
+	(error "Image format error: out-of-order reference" x)))
+
+  (define (store! n shell fixup)
+    (hash-table-set! seen n shell)
+    (fixup shell)
+    shell)
+
+  (define (dereference x loader)
+    (cond
+     ((number? x)
+      (lookup x))
+     ((not (vector? x)) (error "Image format error: bad definition" x))
+     (else (loader (vector-ref x 1)
+		   (lambda (shell fixup)
+		     (store! (vector-ref x 0)
+			     shell
+			     fixup))))))
+
+  (define (load x)
+    (dereference x
+		 (lambda (y k)
+		   (cond
+		    ((vector? y)
+		     (case (vector-ref y 0)
+		       ((o p a) (k (make-object* #f #f)
+				   (make-object-fixup (vector-ref y 0)
+						      (vector-ref y 1)
+						      (vector-ref y 2))))
+		       ((v) (k (make-vector (- (vector-length y) 1))
+			       (lambda (shell)
+				 (do ((i 0 (+ i 1)))
+				     ((= i (vector-length shell)))
+				   (vector-set! shell i
+						(load (vector-ref y (+ i 1))))))))
+		       (else (error "Image format error: illegal compound" y))))
+		    ((pair? y) (k (cons #f #f)
+				  (lambda (shell)
+				    (set-car! shell (load (car y)))
+				    (set-cdr! shell (load (cdr y))))))
+		    (else (k y (lambda (shell) shell)))))))
+
+  (define (make-object-fixup category layout slots)
+    (lambda (shell)
+      (set-object-layout! shell (dereference layout load-layout))
+      (set-object-slots! shell (list->vector (map-in-order load slots)))
+      (case category
+	((p) (push! fixups
+		    (lambda ()
+		      (set-slot! shell 'code (lookup-primitive (get-slot shell 'primitive))))))
+	((a) (push! fixups
+		    (lambda ()
+		      (set-slot! shell 'code
+				 (let ((name (get-slot shell 'accessor)))
+				   (if (eq? (get-slot shell 'selector) name)
+				       (build-getter-body name)
+				       (build-setter-body name)))))))
+	(else 'pass))))
+
+  (define (load-layout x k)
+    (k (make-layout*)
+       (lambda (layout)
+	 (for-each (lambda (slot)
+		     (layout-set! layout (slot-name slot) slot))
+		   (map-in-order load-slot x))
+	 layout)))
+
+  (define (load-slot x)
+    (dereference x
+		 (lambda (y k)
+		   (let*-structure (((name index delegating? kind roles) y))
+		     (k (make-slot* name index #f delegating? kind)
+			(lambda (shell)
+			  (set-slot-roles! shell (map-in-order load-role roles))))))))
+
+  (define (load-role x)
+    (let*-structure (((positions requirements method) x))
+      (make-role* (list->bitset positions)
+		  (list->bitset requirements)
+		  (load method))))
+
+  (set! *image-root* (make-hash-table eq?))
+  (flush-literal-objects-table!)
+
+  (let ((roots (car image))
+	(literals (cdr image)))
+    (for-each (lambda (entry)
+		(debug 1 "--- ROOT "(car entry))
+		(hash-table-set! *image-root*
+				 (car entry)
+				 (load (cdr entry))))
+	      roots)
+    (for-each (lambda (entry)
+		(debug 1 "--- LITERAL "entry)
+		(let ((literal (load (car entry)))
+		      (object (load (cdr entry))))
+		  (install-object-for-literal! literal object)))
+	      literals))
+
+  (run-hooks! fixups)
+  (debug 1 "Done.")
+
+  (load-globals-from-image!)
+)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interp.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,302 @@
+(require 'srfi-1)
+
+(require 'util)
+(require 'parsetng)
+
+;; This is just documentation. It's not used anywhere.
+(define %location-protocol
+  '(namespace-traits
+    (loc at: sym)
+    (loc at: sym put: val)
+
+    continuation-traits
+    (loc return: val)
+    (loc raise: exn)
+
+    required-continuation-traits
+    (loc continuation-cell)
+
+    concurrency-traits
+    (loc parent)
+    (loc children-cell)))
+
+(define runnable-suspensions '())
+;;(define runnable-suspension-counter 0)
+(define current-location #f)
+
+(define (metalevel-work-available?)
+  (not (null? runnable-suspensions)))
+
+(define (metalevel-resume-thread! suspension value)
+  ;;(set! runnable-suspension-counter (+ runnable-suspension-counter 1))
+  (push! runnable-suspensions (lambda () (suspension value))))
+
+(define (metalevel-location-alive? location)
+  (or (eq? *nil* location)
+      (*false*? (get-slot location 'dead))))
+
+(define (metalevel-unsuspend location thunk)
+  (if (metalevel-location-alive? location)
+      (begin
+	(set! current-location location)
+	(thunk))
+      (metalevel-schedule!!)))
+
+(define (metalevel-spawn location thunk)
+  ;;(set! runnable-suspension-counter (+ runnable-suspension-counter 1))
+  (push! runnable-suspensions (lambda () (metalevel-unsuspend location thunk))))
+
+(define (metalevel-suspend-thread receiver)
+  (call-with-current-continuation
+   (lambda (k)
+     (let ((location current-location))
+       (receiver (lambda (v) (metalevel-unsuspend location (lambda () (k v)))))
+       (metalevel-schedule!!)))))
+
+(define metalevel-root-continuation #f)
+(define (metalevel-schedule!!)
+  (metalevel-root-continuation 'throw))
+
+(define -metalevel-running #t)
+(define (metalevel-stop!)
+  (set! -metalevel-running #f))
+(define (metalevel-stopped?)
+  (not -metalevel-running))
+
+(define (metalevel-run-runnable-suspensions next-event-time)
+  (call-with-current-continuation
+   (lambda (restart-mainloop)
+     (set! metalevel-root-continuation restart-mainloop)))
+  ;;(write (list "Suspensions: "runnable-suspension-counter))(newline)
+  (do ()
+      ((or (and next-event-time (>= (get-time-of-day) next-event-time))
+	   (not -metalevel-running)
+	   (not (metalevel-work-available?))))
+    (let ((suspension (car runnable-suspensions)))
+      ;;(set! runnable-suspension-counter (- runnable-suspension-counter 1))
+      (set! runnable-suspensions (cdr runnable-suspensions))
+      (suspension)))
+  (let ((now (get-time-of-day)))
+    (if (and next-event-time
+	     (< now next-event-time))
+	(sdl-delay (truncate (* (- next-event-time now) 1000.0))))))
+
+(define (metalevel-suspend-on-cell c)
+  (metalevel-suspend-thread
+   (lambda (suspension)
+     (set-slot! c 'queue (cons suspension (get-slot c 'queue))))))
+
+(define (metalevel-peek-cell-value c)
+  (let ((val (get-slot c '_pvt_value)))
+    (if (eq? val *no-role*)
+	(let ((newval (metalevel-suspend-on-cell c)))
+	  (set-slot! c '_pvt_value newval)
+	  newval)
+	val)))
+
+(define (metalevel-extract-cell-value c)
+  (let ((val (get-slot c '_pvt_value)))
+    (if (eq? val *no-role*)
+	(metalevel-suspend-on-cell c)
+	(begin
+	  (set-slot! c '_pvt_value *no-role*)
+	  val))))
+
+(define (metalevel-inject-cell-value c v)
+  (if (eq? (get-slot c '_pvt_value) *no-role*)
+      (let ((q (get-slot c 'queue)))
+	(if (pair? q)
+	    (let ((suspension (car q))
+		  (remainder (cdr q)))
+	      (set-slot! c 'queue remainder)
+	      (metalevel-resume-thread! suspension v))
+	    (set-slot! c '_pvt_value v))
+	*nil*)
+      (metalevel-raise-exception (list 'cellOverflow c))))
+
+(define (extend-env name val env)
+  (cons (cons name val) env))
+
+(define metalevel-raise-exception error)
+
+(define metalevel-interpret
+  (let ()
+    (define (do-local resend env lit instr)
+      (cdr (assq (vector-ref instr 1) env)))
+
+    (define (do-global resend env lit instr)
+      (let ((dict (metalevel-peek-cell-value *globals*)))
+	(send/previous-method #f (vector-ref instr 1) (vector dict))))
+
+    (define (eval-in-par thunk)
+      (let* ((cell (clone-object *cell*))
+	     (loc (clone-object *location*)))
+	(set-slot! loc 'continuation cell)
+	(set-slot! loc 'parent current-location)
+	(set-slot! current-location 'children (cons loc (get-slot current-location 'children)))
+	(metalevel-spawn loc (lambda () (metalevel-inject-cell-value cell (thunk))))
+	cell))
+
+    (define (eval-tuple resend env lit instrs)
+      (let ((num-instrs (vector-length instrs)))
+	(if (= num-instrs 1)
+	    (vector (vm resend env lit (vector-ref instrs 0)))
+	    (let ((vals (make-vector num-instrs))
+		  (flags (make-vector num-instrs)))
+	      (do ((index 0 (+ index 1)))
+		  ((= index num-instrs))
+		(let* ((instr (vector-ref instrs index))
+		       (kind (vector-ref instr 0))
+		       (flag (or (eq? kind 'local)
+				 (eq? kind 'literal))))
+		  (vector-set! flags index flag)
+		  (vector-set! vals index
+			       (if flag
+				   (vm resend env lit instr)
+				   (eval-in-par (lambda () (vm resend env lit instr)))))))
+	      (do ((index 0 (+ index 1)))
+		  ((= index num-instrs))
+		(if (not (vector-ref flags index))
+		    (vector-set! vals index
+				 (metalevel-peek-cell-value (vector-ref vals index)))))
+	      vals))))
+
+    (define (do-send resend env lit instr)
+      (let ((selector (vector-ref instr 1))
+	    (vals (eval-tuple resend env lit (vector-ref instr 2))))
+	(debug 2 --> 0 "Send "selector" "vals)
+	(let ((result (send/previous-method #f selector vals)))
+	  (debug 2 --> 0 "Rslt "selector" "vals" ==> "result)
+	  result)))
+
+    (define (do-closure resend env lit instr)
+      (let* ((block (clone-object (vector-ref lit (vector-ref instr 1)))))
+	(set-slot! block 'environment env)
+	block))
+
+    (define (do-begin resend env lit instr)
+      (eval-statements resend env lit (vector-ref instr 1)))
+
+    (define (do-scope resend env lit instr)
+      (let* ((name (vector-ref instr 1))
+	     (cell (eval-in-par (lambda ()
+				  (let ((newenv (extend-env name current-location env)))
+				    (eval-statements resend newenv lit (vector-ref instr 2)))))))
+	(metalevel-peek-cell-value cell)))
+
+    (define (do-literal resend env lit instr)
+      (vector-ref lit (vector-ref instr 1)))
+
+    (define (do-update resend env lit instr)
+      (let* ((o (clone-object (vm resend env lit (vector-ref instr 1))))
+	     (updates (vector-ref instr 2))
+	     (n (vector-length updates)))
+	(do ((i 0 (+ i 1)))
+	    ((= i n))
+	  (let ((update (vector-ref updates i)))
+	    (let ((delegating (eq? (vector-ref update 0) *true*))
+		  (name (vector-ref update 1))
+		  (update-instr (vector-ref update 2)))
+	      (let ((val (vm resend env lit update-instr)))
+		(if (has-slot? o name)
+		    (set-slot! o name val)
+		    (add-slot! o name val delegating 'immutable))))))
+	o))
+
+    (define (do-tuple resend env lit instr)
+      (eval-tuple resend env lit (vector-ref instr 1)))
+
+    (define (do-resend resend env lit instr)
+      (resend))
+
+    (define (do-method resend env lit instr)
+      (let ((selector (vector-ref instr 1))
+	    (formals (vector-ref instr 2))
+	    (specializer-instrs (vector-ref instr 3))
+	    (body-object (vector-ref instr 4))
+	    (method-litvec (vector-ref instr 5)))
+	(let* ((specializers (map (lambda (specializer-instr)
+				    (vm resend env lit specializer-instr))
+				  (vector->list specializer-instrs)))
+	       (method (define-method! selector formals specializers body-object)))
+	  (set-slot! method 'literals method-litvec)
+	  *nil*)))
+
+    (define (eval-statement resend env lit statement k)
+      (if (eq? (vector-ref statement 0) 'bind)
+	  (let* ((name (vector-ref statement 1))
+		 (instr (vector-ref statement 2))
+		 (newenv (extend-env name *nil* env))
+		 (value (vm resend newenv lit instr)))
+	    (set-cdr! (car newenv) value)
+	    (k newenv value))
+	  (k env (vm resend env lit statement))))
+
+    (define (eval-statements resend env lit statements)
+      (let ((n (vector-length statements)))
+	(let loop ((env env)
+		   (i 0)
+		   (acc *nil*))
+	  (if (= i n)
+	      acc
+	      (eval-statement resend env lit (vector-ref statements i)
+			      (lambda (newenv value)
+				(loop newenv (+ i 1) value)))))))
+
+    (define optable (make-hash-table eq?))
+
+    (define (vm resend env lit instr)
+      (debug 1 --> 0 "Eval "instr)
+      (debug 2 --> 0 "Env= "env)
+      (let ((result ((hash-table-ref optable (vector-ref instr 0)
+				     (lambda _ (error "Unknown instruction" instr)))
+		     resend env lit instr)))
+	(debug 2 --> 0 "Done "instr" ==> "result)
+	result))
+
+    (hash-table-set! optable 'local do-local)
+    (hash-table-set! optable 'global do-global)
+    (hash-table-set! optable 'send do-send)
+    (hash-table-set! optable 'closure do-closure)
+    (hash-table-set! optable 'begin do-begin)
+    (hash-table-set! optable 'scope do-scope)
+    (hash-table-set! optable 'literal do-literal)
+    (hash-table-set! optable 'update do-update)
+    (hash-table-set! optable 'tuple do-tuple)
+    (hash-table-set! optable 'resend do-resend)
+    (hash-table-set! optable 'method do-method)
+
+    vm))
+
+(define (metalevel-eval-method code method argv)
+  (let* ((litvec (get-slot method 'literals))
+	 (prologue (car code))
+	 (instruction (cdr code))
+	 (need-block-environment? (eq? *true* (vector-ref prologue 1))))
+    (bump-invocation-count! prologue method)
+    (metalevel-interpret (if need-block-environment?
+			     #f
+			     (lambda ()
+			       (send/previous-method method (get-slot method 'selector) argv)))
+			 (fold extend-env
+			       (if need-block-environment?
+				   (get-slot (vector-ref argv 0) 'environment)
+				   '())
+			       (get-slot method 'arguments)
+			       (vector->list argv))
+			 litvec
+			 instruction)))
+
+(define (metalevel-eval ast)
+  (let-values (((instr litvec) (compile-ThiNG ast)))
+    (metalevel-interpret #f '() litvec instr)))
+
+(define (ThiNG-load-file filename)
+  (let-values (((success ast) (call-with-input-file filename
+				(lambda (port)
+				  (parse-ThiNG filename
+					       ThiNG-parser
+					       (lambda () (read-char port)))))))
+    (if success
+	(cons *true* (metalevel-eval `(scope ,*nil* ,ast)))
+	(cons *false* ast))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel-methods.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,230 @@
+;; This file is included in a couple of different contexts to
+;; initialise the primitive table and to build a bootstrap image, and
+;; should only contain define-method forms.
+
+(define-method (primListen (port *traits-number*)) primListenSocket
+  (or (sdl-net-tcp-open (make-sdl-ip-address 0 0 0 0 port))
+      *nil*))
+
+(define-method (primConnect: (hostname *traits-string*) (port *traits-number*)) primConnectSocket
+  (or (sdl-net-tcp-open (sdl-net-resolve-host hostname port))
+      *nil*))
+
+(define-method (accept (sock *traits-socket*)) primSocketAccept
+  (or (accept-from-socket sock)
+      *nil*))
+
+(define-method (primPeerAddress (sock *traits-socket*)) primSocketPeerAddress
+  (or (and-let* ((ipa (sdl-net-tcp-get-peer-address sock))
+		 (hostname (sdl-net-resolve-ip ipa)))
+	(vector hostname (sdl-ip-address-port ipa)))
+      *nil*))
+
+(define-method (close (sock *traits-socket*)) primSocketClose
+  (sdl-net-tcp-close sock)
+  *nil*)
+
+(define-method (printOn: o (out *traits-socket*)) displayPrintString
+  (let ((string-port (open-output-string)))
+    (display (send/previous-method/missing-handler #f
+						   (lambda (argv) "#<OBJECT>")
+						   'printString
+						   (vector o))
+	     string-port)
+    (let ((representation (get-output-string string-port)))
+      (sdl-net-tcp-send-string out representation)
+      *nil*)))
+
+(define-method (printString (x *traits-root*)) rootPrintString
+  (send as: x *traits-string*))
+
+(define-method (primStringAppend: (s1 *traits-string*) (s2 *traits-string*)) primStringAppend
+  (string-append s1 s2))
+
+(define-method (- (n1 *traits-number*) (n2 *traits-number*)) numSub (- n1 n2))
+(define-method (+ (n1 *traits-number*) (n2 *traits-number*)) numPlus (+ n1 n2))
+(define-method (* (n1 *traits-number*) (n2 *traits-number*)) numTimes (* n1 n2))
+(define-method (/ (n1 *traits-number*) (n2 *traits-number*)) numDiv (/ n1 n2))
+
+(define-method (< (n1 *traits-number*) (n2 *traits-number*)) numLT (< n1 n2))
+(define-method (> (n1 *traits-number*) (n2 *traits-number*)) numGT (> n1 n2))
+(define-method (<= (n1 *traits-number*) (n2 *traits-number*)) numLE (<= n1 n2))
+(define-method (>= (n1 *traits-number*) (n2 *traits-number*)) numGE (>= n1 n2))
+
+(define-method (= (x *traits-root*) (y *traits-root*)) primEgal
+  (let egal ((x x) (y y))
+    (or (eq? x y)
+	(cond
+	 ((and (object? x) (object? y))
+	  (let ((lx (object-layout x)) (sx (object-slots x))
+		(ly (object-layout y)) (sy (object-slots y)))
+	    (and (eq? lx ly)
+		 (call-with-current-continuation
+		  (lambda (escape)
+		    (layout-for-each lx
+				     (lambda (slot-name slot)
+				       (case (slot-kind slot)
+					 ((mutable) (escape #f))
+					 ((immutable)
+					  (let ((index (slot-index slot)))
+					    (if (not (egal (vector-ref sx index)
+							   (vector-ref sy index)))
+						(escape #f))))
+					 ((method) 'ignore-methods)
+					 (else (error "Unknown slot kind in egal"
+						      (slot-kind slot))))))
+		    #t)))))
+	 ((and (pair? x) (pair? y))
+	  (and (egal (car x) (car y))
+	       (egal (cdr x) (cdr y))))
+	 ((and (vector? x) (vector? y))
+	  (let ((len (vector-length x)))
+	    (and (= len (vector-length y))
+		 (let loop ((i 0))
+		   (if (= i len)
+		       #t
+		       (and (egal (vector-ref x i)
+				  (vector-ref y i))
+			    (loop (+ i 1))))))))
+	 ((and (number? x) (number? y))
+	  (= x y))
+	 (else #f)))))
+
+(define-method (as: x (y *traits-string*)) rootAsString
+  (if (eq? x *no-role*)
+      "NoRole"
+      (send name x)))
+
+(define-method (as: (x '()) (y *traits-string*)) nilAsString "Nil")
+(define-method (as: (x '#t) (y *traits-string*)) trueAsString "True")
+(define-method (as: (x '#f) (y *traits-string*)) falseAsString "False")
+
+(define-method (as: (x *traits-traits*) (y *traits-string*)) traitsAsString
+  (string-append "#<"(send name x)" traits>"))
+
+(define-method (as: (x *traits-string*) (y *traits-string*)) stringAsString
+  (if (string? x)
+      x
+      (resend)))
+
+(define-method (as: (x *traits-symbol*) (y *traits-string*)) symbolAsString
+  (if (symbol? x)
+      (symbol->string x)
+      (resend)))
+
+(define-method (as: (x *traits-number*) (y *traits-string*)) numberAsString
+  (if (number? x)
+      (number->string x)
+      (resend)))
+
+(define-method (new (c *traits-cell*)) newCell
+  (clone-object *cell*))
+
+(define-method (key (o *traits-pair*)) pairCar
+  (car o))
+
+(define-method (value (o *traits-pair*)) pairCdr
+  (cdr o))
+
+(define-method (size (v *traits-tuple*)) tupleSize
+  (vector-length v))
+
+(define-method (at: (v *traits-tuple*) (n *traits-number*)) tupleAt
+  (vector-ref v n))
+
+(define-method (-> (x *traits-root*) y) pairCons
+  (cons x y))
+
+(define-method (--> (c *traits-cell*) (m *traits-block*)) cellExtract
+  (send applyWith: m (metalevel-extract-cell-value c)))
+
+(define-method (peek (c *traits-cell*)) cellPeek
+  (metalevel-peek-cell-value c))
+
+(define-method (<-- (c *traits-cell*) v) cellInject
+  (metalevel-inject-cell-value c v))
+
+(define-method (withSlot:value: template (name *traits-symbol*) val) primAddSlot
+  (let ((o (clone-object template)))
+    (if (has-slot? o name)
+	(set-slot! o name val)
+	(add-slot! o name val #f 'immutable))
+    o))
+
+(define-method (fork: (loc *traits-location*) (block *traits-block*)) forkBlockInLocation
+  (metalevel-spawn loc (lambda () (send do block)))
+  *nil*)
+
+(define-method (fileIn (filename *traits-string*)) stringFileIn
+  (ThiNG-load-file filename))
+
+(define-method (compileOneStatement (sock *traits-socket*)) primCompileOneStatement
+  (let-values (((success ast) (parse-ThiNG (external-representation sock)
+					   ThiNG-topexpr-parser
+					   (make-char-provider-thunk-for-socket sock))))
+    (if success
+	(cons *true* (metalevel-eval `(block () (,ast))))
+	(cons *false* ast))))
+
+(define-method (saveImage (filename *traits-string*)) primSaveImage
+  (debug 0 "Saving image...")
+  (call-with-output-file filename
+    (lambda (port)
+      (write (serialize-image!) port)
+      (newline port))))
+
+(define-method (primQuit (r *traits-root*)) primQuit
+  (shutdown-sdl!)
+  *nil*)
+
+;---------------------------------------------------------------------------
+
+(define-method (handle (e *traits-sdl-event*)) handleBasicSdlEvent
+  #t)
+
+(define-method (handle (e (traits-for-sdl-event-type SDL_QUIT))) handleQuitSdlEvent
+  (metalevel-stop!)
+  #f)
+
+(define-method (handle (e (traits-for-sdl-event-type SDL_MOUSEBUTTONDOWN))) handleSdlClick
+  (let ((s2 (ttf-render-text-blended *system-font*
+				     "(click)"
+				     (make-sdl-color 255 255 255))))
+    (sdl-blit-surface s2 #f
+		      *video-surface* (make-sdl-rect (sdl-event-x e)
+						     (sdl-event-y e)
+						     0 0))
+    (sdl-free-surface s2))
+  (sdl-flip *video-surface*)
+  (resend))
+
+(define-method (handle (e (traits-for-sdl-event-type SDL_VIDEORESIZE))) handleSdlVideoResize
+  (let ((w (sdl-event-w e))
+	(h (sdl-event-h e)))
+    (display (list 'resize w h))
+    (newline)
+    (sdl-set-video-mode w h 0 (+ SDL_HWSURFACE
+				 SDL_HWPALETTE
+				 SDL_RESIZABLE
+				 SDL_DOUBLEBUF)))
+  (sdl-fill-rect *video-surface*
+		 (make-sdl-rect 0 0
+				(sdl-surface-width *video-surface*)
+				(sdl-surface-height *video-surface*))
+		 (sdl-map-rgb (sdl-surface-pixel-format *video-surface*) 0 0 64))
+  (let ((s2 (ttf-render-text-blended *system-font*
+				     "Hello, world!"
+				     (make-sdl-color 255 255 255))))
+    (sdl-blit-surface s2 #f *video-surface* (make-sdl-rect 0 0 0 0))
+    (sdl-free-surface s2))
+  (sdl-flip *video-surface*)
+  (resend))
+
+(define-method (handle (e (traits-for-sdl-event-type SDL_KEYDOWN))) handleSdlKeydown
+  (let* ((i (sdl-event-sym e))
+	 (c (integer->char i)))
+    (if (or (= i 27) (memv c '(#\q #\Q)))
+	(shutdown-sdl!)
+	(begin (display (list 'got-key c))
+	       (newline))))
+  (resend))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/kernel.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,282 @@
+(require 'srfi-1)
+(require 'oo)
+
+;---------------------------------------------------------------------------
+
+(define (describe-object! o description)
+    (for-each (lambda (entry)
+		(let* ((delegating? (vector? entry))
+		       (entry (if delegating? (vector->list entry) entry))
+		       (name (car entry))
+		       (value (cadr entry))
+		       (kind (if (null? (cddr entry)) 'immutable (caddr entry))))
+		  (add-slot! o name value delegating? kind)))
+	      description)
+    o)
+
+(define (make-basic-object description)
+  (let ((o (make-object* (make-layout*) (vector))))
+    (describe-object! o description)))
+
+(define (make-named-object name description)
+  (let ((o (make-basic-object description)))
+    (add-slot! o 'name name #f 'immutable)))
+
+(define (make-method* selector formal-names body-exp)
+  (let ((m (clone-object *method*)))
+    (set-slot! m 'selector selector)
+    (set-slot! m 'arguments formal-names)
+    (set-slot! m 'code body-exp)
+    m))
+
+(define (build-getter-body name)
+  (lambda (method self)
+    (get-slot self name)))
+
+(define (build-setter-body name)
+  (lambda (method self value)
+    (set-slot! self name value)))
+
+(define (make-getter-method-for name)
+  (let ((m (make-method* name '#(self) (build-getter-body name))))
+    (set-slot! m 'accessor name)
+    m))
+
+(define (make-setter-method-for name mutator-name)
+  (let ((m (make-method* mutator-name '#(self value) (build-setter-body name))))
+    (set-slot! m 'accessor name)
+    m))
+
+(define (make-traits name description)
+  (let ((t (make-named-object name `(#(traits ,*traits-traits*)))))
+    (describe-object! t description)
+    t))
+
+(define primitive-traits-hook
+  (make-parameter
+   (lambda (o)
+     (error "Cannot compute primitive traits" o))))
+
+(define (traits-for-primitive o)
+  (cond
+   ((number? o) *traits-number*)
+   ((char? o) *traits-character*)
+   ((symbol? o) *traits-symbol*)
+   ((vector? o) *traits-tuple*)
+   ((pair? o) *traits-pair*)
+   ((string? o) *traits-string*)
+   ((boolean? o) *traits-boolean*)
+   ((null? o) *nil*)
+   (else ((primitive-traits-hook) o))))
+
+;---------------------------------------------------------------------------
+
+(define *image-root* 'uninitialised-image-root)
+
+(let-syntax ((def (syntax-rules () ((_ (v n) ...) (begin (define v '(uninitialised v)) ...)))))
+  (include "root-hooks.scm"))
+
+(define (compute-roots-globals)
+  (let-syntax ((def (syntax-rules ()
+			 ((_ (v n) ...)
+			  (filter car (list (list 'n v) ...))))))
+    (include "root-hooks.scm")))
+
+(define *primitive-table* 'uninitialised-primitive-table)
+
+(define (store-primitive! key body-procedure)
+  (cond
+   ((assoc key *primitive-table*) =>
+    (lambda (cell)
+      (debug 0 "Warning: replacing primitive: "key)
+      (set-cdr! cell body-procedure)))
+   (else
+    (set! *primitive-table* (cons (cons key body-procedure) *primitive-table*)))))
+
+(define (lookup-primitive key)
+  (cond
+   ((assoc key *primitive-table*) => cdr)
+   (else (error "Missing primitive" key))))
+
+(define (reset-primitive-table!)
+  (set! *primitive-table* '())
+  (let-syntax ((define-method
+		 (lambda (x)
+		   (syntax-case x ()
+		     ((_ (selector arg ...) primitive-name body ...)
+		      (with-syntax ((((name role) ...)
+				     (map (syntax-rules ()
+					    ((_ (name role)) (name role))
+					    ((_ name) (name *no-role*)))
+					  (syntax ((x arg) ...))))
+				    (resend (datum->syntax-object (syntax selector) 'resend)))
+			(syntax
+			 (begin
+			   (debug 1 "Define-method (primitive-side) "'primitive-name
+				  " "'selector" "'(role ...))
+			   (store-primitive! 'primitive-name
+					     (lambda (current-method name ...)
+					       (let ((resend (lambda ()
+							       (debug 2 "Resending "'selector)
+							       (send/previous-method current-method
+										     'selector
+										     (vector
+										      name ...)))))
+						 body ...)))))))))))
+    (include "kernel-methods.scm")))
+
+(define global-store-hooks '())
+(define global-load-hooks '())
+
+(define (store-globals-to-image!)
+  (set! *image-root* (make-hash-table eq?))
+  (let-syntax ((def (syntax-rules ()
+		      ((_ (v n) ...)
+		       (begin (hash-table-set! *image-root* 'v v) ...)))))
+    (include "root-hooks.scm"))
+  (run-hooks! global-store-hooks))
+
+(define (load-globals-from-image!)
+  (let-syntax ((def (syntax-rules ()
+		      ((_ (v n) ...)
+		       (begin (set! v (hash-table-ref *image-root* 'v)) ...)))))
+    (include "root-hooks.scm"))
+  (run-hooks! global-load-hooks))
+
+;---------------------------------------------------------------------------
+
+(define *root-literals* 'uninitialised-root-literals)
+(let-syntax ((def-root-literals (syntax-rules ()
+				  ((_ (lit ob) ...)
+				   (set! *root-literals*
+				     `((,lit ,(lambda () ob)) ...))))))
+  (def-root-literals
+    (() *nil*)
+    (#t *true*)
+    (#f *false*)))
+
+(define bootstrap-hooks '())
+
+(define (bootstrap-image!)
+  (set! *nil* (make-basic-object `()))
+  (set! *no-role* (make-basic-object `()))
+
+  (set! *traits-method* (make-basic-object `()))
+  (set! *method* (make-basic-object `()))
+
+  (let ((m *method*))
+    (add-slot! m 'traits *traits-method* #t 'immutable #f)
+    (add-slot! m 'code *nil* #f 'immutable #f)
+    (add-slot! m 'arguments *nil* #f 'immutable #f)
+    (add-slot! m 'accessor *nil* #f 'immutable #f)
+    (add-slot! m 'primitive *nil* #f 'immutable #f)
+    (add-slot! m 'selector *nil* #f 'immutable #f)
+    (add-slot! m 'literals *nil* #f 'immutable #f)
+
+    (add-accessors! m 'traits #t)
+    (add-accessors! m 'code #t)
+    (add-accessors! m 'arguments #t)
+    (add-accessors! m 'accessor #t)
+    (add-accessors! m 'primitive #t)
+    (add-accessors! m 'selector #t)
+    (add-accessors! m 'literals #t)
+
+    (add-slot! *nil* 'name "Nil" #f 'immutable)
+    (add-slot! *no-role* 'name "NoRole" #f 'immutable)
+    (add-slot! *traits-method* 'name "Method" #f 'immutable))
+
+  (set! *traits-traits* (make-named-object "Traits" `()))
+
+  (set! *traits-root* (make-traits "Root" `()))
+  (set! *root* (make-basic-object `(#(traits ,*traits-root*))))
+  (describe-object! *traits-traits* `(#(root ,*traits-root*)))
+  (describe-object! *traits-method* `(#(traits ,*traits-traits*)))
+
+  (set! *traits-oddball* (make-traits "Oddball" `(#(root ,*traits-root*))))
+  (set! *traits-derivable* (make-traits "Derivable" `(#(root ,*traits-root*))))
+  (set! *traits-cloneable* (make-traits "Cloneable" `(#(derivable ,*traits-derivable*))))
+  (describe-object! *traits-method* `(#(cloneable ,*traits-cloneable*)))
+
+  (set! *oddball* (make-basic-object `(#(traits ,*traits-oddball*))))
+  (describe-object! *nil* `(#(traits ,*traits-oddball*)))
+  (describe-object! *no-role* `(#(traits ,*traits-oddball*)))
+
+  (set! *derivable* (make-basic-object `(#(traits ,*traits-derivable*))))
+  (set! *cloneable* (make-basic-object `(#(traits ,*traits-cloneable*))))
+
+  (set! *traits-number* (make-traits "Number" `(#(derivable ,*traits-derivable*))))
+  (set! *traits-character* (make-traits "Character" `(#(oddball ,*traits-oddball*))))
+  (set! *traits-boolean* (make-traits "Boolean" `(#(oddball ,*traits-oddball*))))
+  (set! *traits-symbol* (make-traits "Symbol" `(#(oddball ,*traits-oddball*))))
+  (set! *traits-tuple* (make-traits "Tuple" `(#(cloneable ,*traits-cloneable*))))
+  (set! *traits-pair* (make-traits "Pair" `(#(cloneable ,*traits-cloneable*))))
+  (set! *traits-string* (make-traits "String" `(#(cloneable ,*traits-cloneable*))))
+
+  (set! *traits-socket* (make-traits "Socket" `(#(derivable ,*traits-derivable*))))
+  (set! *traits-sdl-surface* (make-traits "SDL_Surface" `(#(oddball ,*traits-oddball*))))
+  (set! *traits-sdl-event* (make-traits "SDL_Event" `(#(oddball ,*traits-oddball*))))
+  (set! *traits-ttf-font* (make-traits "TTF_Font" `(#(oddball ,*traits-oddball*))))
+
+  (set! *true* (make-basic-object `(#(traits ,*traits-boolean*))))
+  (set! *false* (make-basic-object `(#(traits ,*traits-boolean*))))
+
+  (set! *tuple* '#())
+  (set! *string* "")
+  (set! *symbol* 'Symbol)
+  (set! *number* 0)
+  (set! *pair* (cons *nil* *nil*))
+
+  (set! *traits-block* (make-traits "Block" `(#(cloneable ,*traits-cloneable*))))
+  (set! *block* (make-basic-object `(#(traits ,*traits-block*)
+				     (environment ,*nil*))))
+
+  ;; Language-specific -----------
+  (set! *traits-cell* (make-traits "Cell" `(#(cloneable ,*traits-cloneable*))))
+  (set! *cell* (make-basic-object `(#(traits ,*traits-cell*)
+				    (_pvt_value ,*no-role* mutable)
+				    (queue () mutable))))
+  (set! *traits-location* (make-traits "Location" `(#(cloneable ,*traits-cloneable*))))
+  (set! *location* (make-basic-object `(#(traits ,*traits-location*)
+					(continuation ,*nil*)
+					(parent ,*nil*)
+					;;
+					;; Need to delegate to parent,
+					;; to get exn handler, globals
+					;; etc.
+					;;
+					(children () mutable)
+					(dead ,*false* mutable))))
+  (set! *boot-block* (metalevel-eval `(block () ((send "fileIn" ((string "boot.thing")))))))
+
+  (set! *globals* (clone-object *cell*))
+  (metalevel-inject-cell-value
+   *globals*
+   (make-basic-object (compute-roots-globals)))
+  ;; -----------------------------
+
+  (run-hooks! bootstrap-hooks)
+  (flush-literal-objects-table!)
+
+  (for-each (lambda (entry)
+	      (install-object-for-literal! (car entry)
+					   ((cadr entry))))
+	    *root-literals*)
+
+  (let-syntax ((define-method
+		 (lambda (x)
+		   (syntax-case x ()
+		     ((_ (selector arg ...) primitive-name body ...)
+		      (with-syntax ((((name role) ...)
+				     (map (syntax-rules ()
+					    ((_ (name role)) (name role))
+					    ((_ name) (name *no-role*)))
+					  (syntax ((x arg) ...)))))
+			(syntax
+			 (begin
+			   (debug 1 "Define-method (image-side) "'primitive-name
+				  " "'selector" "'(role ...))
+			   (let ((method (define-method! 'selector '(name ...) `(,role ...)
+					   (lookup-primitive 'primitive-name))))
+			     (set-slot! method 'primitive 'primitive-name))))))))))
+    (include "kernel-methods.scm"))
+)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/macros.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,84 @@
+(keyword-style '#:none)
+
+(define-syntax compile-if
+  (syntax-rules ()
+    ((_ #f tb fb) fb)
+    ((_ #t tb fb) tb)
+    ((_ #f tb) 'conditionally-compiled-away)
+    ((_ #t tb) tb)))
+
+(compile-if #t
+	    (begin
+	      (define-syntax begin/debug-indent
+		(syntax-rules ()
+		  ((_ body ...)
+		   (fluid-let ((*debug-indent* (+ *debug-indent* 2)))
+		     (begin body ...)))))
+
+	      (define-syntax debug
+		(syntax-rules (-->)
+		  ((_ level --> l2 exp ...)
+		   (when (>= *debug-level* level)
+		     (let ((old-level *debug-level*))
+		       (set! *debug-level* l2)
+		       (if (positive? *debug-indent*)
+			   (display (make-string *debug-indent* #\space)))
+		       (display exp) ...
+		       (newline)
+		       (set! *debug-level* old-level))))
+		  ((_ level exp ...)
+		   (when (>= *debug-level* level)
+		     (if (positive? *debug-indent*)
+			 (display (make-string *debug-indent* #\space)))
+		     (display exp) ...
+		     (newline))))))
+
+	    (begin
+	      (define-syntax begin/debug-indent
+		(syntax-rules ()
+		  ((_ body ...)
+		   (begin body ...))))
+
+	      (define-syntax debug
+		(syntax-rules (-->)
+		  ((_ level --> l2 exp ...)
+		   'conditionally-compiled-away)
+		  ((_ level exp ...)
+		   'conditionally-compiled-away)))))
+
+(define-syntax send
+  (syntax-rules ()
+    ((_ selector arg ...)
+     (send/previous-method #f 'selector (vector arg ...)))))
+
+(define-syntax push!
+  (syntax-rules ()
+    ((_ variable value)
+     (set! variable (cons value variable)))))
+
+(define-syntax let*-structure
+  (syntax-rules ()
+    ;; minor optimisation - removes a layer of (let)
+    ((_ () body)
+     body)
+
+    ((_ () body ...)
+     (let () body ...))
+
+    ((_ ((pattern value) more ...) body ...)
+     (let ((temp value))
+       (let*-structure "ONE" pattern temp (more ...) (begin body ...))))
+
+    ((_ "ONE" () value more continuation)
+     (if (null? value)
+	 (let*-structure more continuation)
+	 (error "Pattern mismatch" () value)))
+
+    ((_ "ONE" (left . right) value more continuation)
+     (let ((l (car value))
+	   (r (cdr value)))
+       (let*-structure "ONE" left l () (let*-structure "ONE" right r more continuation))))
+
+    ((_ "ONE" var value more continuation)
+     (let ((var value))
+       (let*-structure more continuation)))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/oo.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,609 @@
+(require 'srfi-1)
+
+;---------------------------------------------------------------------------
+
+(define-record-type slot
+  (make-slot* name index roles delegating? kind)
+  slot?
+  (name slot-name)			;; symbol
+  (index slot-index set-slot-index!)	;; #f, or integer offset into object-slots vector
+  (roles slot-roles set-slot-roles!)	;; list of roles
+  (delegating? slot-delegating?)	;; boolean
+  (kind slot-kind))			;; 'method, 'immutable, or 'mutable
+
+(define-record-type object
+  (make-object* layout slots)
+  object?
+  (layout object-layout set-object-layout!)
+  (slots object-slots set-object-slots!))
+
+(define-record-type role
+  (make-role* positions requirements method)
+  role?
+  (positions role-positions set-role-positions!)
+  (requirements role-requirements)
+  (method role-method set-role-method!))
+
+(define-record-type layout
+  (make-layout** hash map)
+  layout?
+  (hash layout-hash)
+  (map layout-map))
+
+(define layout-hash-factory
+  (let ((counter 0))
+    (lambda ()
+      (let ((v counter))
+	(set! counter (bitwise-and (+ counter 1) #xFFFFFF)) ;; some arbitrary wraparound
+	v))))
+
+(define (make-layout*)
+  (make-layout** (layout-hash-factory)
+		 (make-hash-table eq?)))
+
+(define (layout-ref layout slot-name def)
+  (hash-table-ref (layout-map layout) slot-name def))
+
+(define (layout-set! layout slot-name value)
+  (hash-table-set! (layout-map layout) slot-name value))
+
+(define (layout-for-each layout fn)
+  (hash-table-for-each fn (layout-map layout)))
+
+(define (layout-remove! layout slot-name)
+  (hash-table-remove! (layout-map layout) slot-name))
+
+;---------------------------------------------------------------------------
+
+(define *literal-objects* 'uninitialised-literal-objects)
+
+(define (flush-literal-objects-table!)
+  (set! *literal-objects* (make-hash-table eq?)))
+
+(define (object-for-literal! x)
+  (or (hash-table-ref *literal-objects* x #f)
+      (let* ((ob (make-object* (make-layout*) (vector)))
+	     (t (traits-for-primitive x)))
+	(add-slot! ob 'traits (traits-for-primitive x) #t 'immutable)
+	(hash-table-set! *literal-objects* x ob)
+	ob)))
+
+(define (install-object-for-literal! x ob)
+  (unless (hash-table-ref *literal-objects* x #f)
+    (hash-table-set! *literal-objects* x ob)))
+
+(define (for-each-literal-object fn)
+  (hash-table-for-each fn *literal-objects*))
+
+(define (ensure-object! x)
+  (if (object? x)
+      x
+      (object-for-literal! x)))
+
+(define (object-or-false x)
+  (if (object? x)
+      x
+      (hash-table-ref *literal-objects* x #f)))
+
+(define-syntax ensure-object-var/create!
+  (syntax-rules ()
+    ((_ var)
+     (begin
+       (unless (object? var)
+	 (set! var (object-for-literal! var)))))))
+
+(define-syntax ensure-object-var/traits
+  (syntax-rules ()
+    ((_ var)
+     (begin
+       (unless (object? var)
+	 (set! var (or (hash-table-ref *literal-objects* var #f)
+		       (traits-for-primitive var))))))))
+
+;---------------------------------------------------------------------------
+
+(define (clone-object o)
+  (let* ((o-slots (object-slots o))
+	 (new-slots (make-vector (vector-length o-slots))))
+    (vector-copy! o-slots new-slots)
+    (make-object* (object-layout o)
+		  new-slots)))
+
+(define (clone-layout layout)
+  (let ((new-layout (make-layout*)))
+    (layout-for-each layout
+		     (lambda (slot-name slot)
+		       (layout-set! new-layout slot-name slot)))
+    new-layout))
+
+(define (clone-slot slot)
+  (make-slot* (slot-name slot)
+	      (slot-index slot)
+	      (slot-roles slot)
+	      (slot-delegating? slot)
+	      (slot-kind slot)))
+
+(define (merge-slot-kinds current new)
+  (if (kind-is-non-slot? current)
+      new
+      current))
+
+(define (kind-is-slot? kind)
+  (not (eq? kind 'method)))
+
+(define (kind-is-non-slot? kind)
+  (eq? kind 'method))
+
+(define (add-slot! o name value delegating? kind . should-add-accessors)
+  (ensure-object-var/create! o)
+  (debug 1 "Add-slot: "o" "name" "value" "delegating?" "kind" "should-add-accessors)
+  (let* ((layout (clone-layout (object-layout o)))
+	 (old-slot (layout-ref layout name #f))
+	 (slot (if old-slot
+		   (make-slot* name
+			       (slot-index old-slot)
+			       (slot-roles old-slot)
+			       (or (slot-delegating? old-slot) delegating?)
+			       (merge-slot-kinds (slot-kind old-slot) kind))
+		   (make-slot* name
+			       #f
+			       '()
+			       delegating?
+			       kind))))
+    (layout-set! layout name slot)
+    (set-object-layout! o layout)
+    (let ((index (slot-index slot)))
+      (if (not index)
+	  (let* ((new-index (vector-length (object-slots o)))
+		 (new-slots (make-vector (+ new-index 1))))
+	    (vector-copy! (object-slots o) new-slots)
+	    (vector-set! new-slots new-index value)
+	    (set-slot-index! slot new-index)
+	    (set-object-slots! o new-slots))
+	  (vector-set! (object-slots o) index value)))
+    (when (and (or (null? should-add-accessors) (car should-add-accessors))
+	       (kind-is-slot? kind)
+	       (or (not old-slot)
+		   (kind-is-non-slot? (slot-kind old-slot))))
+      (add-accessors! o name (eq? kind 'immutable)))
+    o))
+
+(define (mutator-name-for name)
+  (string->symbol (string-append (symbol->string name) ":")))
+
+(define (add-accessors! o name immutable?)
+  (debug 2 "Adding getter for "name" on "o)
+  (add-roles!* name #f (make-getter-method-for name) (list o))
+  (if (not immutable?)
+      (let ((mutator-name (mutator-name-for name)))
+	(debug 2 "Adding setter for "name" ("mutator-name") on "o)
+	(add-roles!* mutator-name #f (make-setter-method-for name mutator-name)
+		     ;; You'd think we'd need a two-element list here,
+		     ;; but we don't. This is because of the sparse
+		     ;; encoding of roles. Essentially, setter methods
+		     ;; only have a constraint on their first
+		     ;; argument, so we don't have to bother about the
+		     ;; second argument at all.
+		     (list o))))
+  o)
+
+(define (collect-bitset filter specialisers)
+  (fold-left/index (lambda (index specialiser acc)
+		     (if (filter specialiser)
+			 (set-bit acc index)
+			 acc))
+		   *empty-bitset* specialisers))
+
+(define (not-no-role? specialiser)
+  (not (eq? specialiser *no-role*)))
+
+(define (add-roles!* name clone-existing-slot? method specialisers)
+  (let ((requirements (collect-bitset not-no-role? specialisers)))
+    (for-each/index
+     (lambda (index specialiser)
+       (when (not-no-role? specialiser)
+	 (add-role! specialiser name clone-existing-slot? index requirements method)))
+     specialisers)))
+
+(define (add-role! o name clone-existing-slot? index requirements method)
+  (ensure-object-var/create! o)
+  (let* ((layout (clone-layout (object-layout o)))
+	 (old-slot (layout-ref layout name #f))
+	 (slot (if old-slot
+		   (if clone-existing-slot? (clone-slot old-slot) old-slot)
+		   (make-slot* name
+			       #f
+			       '()
+			       #f
+			       'method))))
+    (layout-set! layout name slot)
+    (set-object-layout! o layout)
+    (let update-roles ((roles (slot-roles slot)))
+      (if (null? roles)
+	  (set-slot-roles! slot
+			   (cons (make-role* (set-bit *empty-bitset* index) requirements method)
+				 (slot-roles slot)))
+	  (let ((role (car roles)))
+	    (if (eq? (role-method role) method)
+		(set-role-positions! role (set-bit (role-positions role) index))
+		(update-roles (cdr roles))))))
+    (invalidate-method-cache!)
+    o))
+
+(define remove-slot!
+  (let ()
+    (define (splice-out-slot-value! o removed-index)
+      (let* ((old-slots (object-slots o))
+	     (old-slots-length (vector-length old-slots))
+	     (new-slots (make-vector (- old-slots-length 1))))
+	(do ((i 0 (+ i 1)))
+	    ((= i removed-index))
+	  (vector-set! new-slots i (vector-ref old-slots i)))
+	(do ((i (+ removed-index 1) (+ i 1)))
+	    ((= i old-slots-length))
+	  (vector-set! new-slots (- i 1) (vector-ref old-slots i)))
+	(set-object-slots! o new-slots)
+	(vector-ref old-slots removed-index)))
+
+    (define (fixup-other-slot-indices! layout removed-index)
+      (layout-for-each layout
+		       (lambda (slot-name slot)
+			 (if (> (slot-index slot) removed-index)
+			     (set-slot-index! slot (- (slot-index slot) 1))))))
+
+    (define (remove-mutator-role! layout name)
+      (let* ((mutator-name (mutator-name-for name))
+	     (mutator-slot (layout-ref layout mutator-name #f)))
+	(if mutator-slot
+	    (let* ((new-slot (clone-slot mutator-slot)))
+	      (set-slot-roles! new-slot
+			       ;; Ought this to just remove *one*? Can there ever be more than one?
+			       (filter (lambda (role)
+					 (not (eq? (get-slot (role-method role) 'accessor) name)))
+				       (slot-roles new-slot)))
+	      (if (null? (slot-roles new-slot))
+		  (layout-remove! layout mutator-name)
+		  (layout-set! layout mutator-name new-slot))))))
+
+    (lambda (o name)
+      (and-let* ((o (object-or-false o)))
+	(let* ((layout (clone-layout (object-layout o)))
+	       (removed-slot (layout-ref layout name #f))
+	       (removed-index (slot-index removed-slot)))
+	  (set-object-layout! o layout)
+	  (let ((old-value (splice-out-slot-value! o removed-index)))
+	    (fixup-other-slot-indices! layout removed-index)
+	    (layout-remove! layout name)
+	    (if (eq? (slot-kind removed-slot) 'mutable)
+		(remove-mutator-role! layout name))
+	    (invalidate-method-cache!)
+	    old-value))))))
+
+(define replace-method!
+  (let ()
+    (define (find-specific-method name specialisers)
+      (let ((requirements (collect-bitset not-no-role? specialisers)))
+	(let loop ((found-methods #f)
+		   (specialisers specialisers)
+		   (index 0))
+	  (cond
+	   ((null? found-methods) #f)
+	   ((null? specialisers)
+	    (cond
+	     ((not found-methods) #f)
+	     ((pair? (cdr found-methods))
+	      (error 'too-many-matches-candidates (list name specialisers)))
+	     (else (car found-methods))))
+	   (else
+	    (and-let* ((specialiser (object-or-false (car specialisers))))
+	      (if (not-no-role? specialiser)
+		  (and-let* ((slot (layout-ref (object-layout specialiser) name #f)))
+		    (let ((new-methods (map role-method
+					    (filter (lambda (role)
+						      (and (bit-set? (role-positions role)
+								     index)
+							   (bitset=? (role-requirements role)
+								     requirements)))
+						    (slot-roles slot)))))
+		      (loop (if found-methods
+				(lset-intersection eq? found-methods new-methods)
+				new-methods)
+			    (cdr specialisers)
+			    (+ index 1))))
+		  (loop found-methods (cdr specialisers) (+ index 1)))))))))
+
+    (lambda (name specialisers new-method)
+      (and-let* ((found-method (find-specific-method name specialisers)))
+	(for-each (lambda (specialiser)
+		    (let ((specialiser (object-or-false specialiser)))
+		      (when (not-no-role? specialiser)
+			(let* ((slot (clone-slot (layout-ref (object-layout specialiser)
+							     name #f))))
+			  (layout-set! (object-layout specialiser) slot)
+			  (for-each (lambda (role)
+				      (if (eq? (role-method role) found-method)
+					  (set-role-method! role new-method)))
+				    (slot-roles slot))))))
+		  specialisers)
+	found-method))))
+
+(define (has-slot? object-or-primitive name)
+  (let ((o (object-or-false object-or-primitive)))
+    (if o
+	(layout-ref (object-layout o) name #f)
+	(eq? name 'traits))))
+
+(define (get-slot object-or-primitive name)
+  (let ((o (object-or-false object-or-primitive)))
+    (if o
+	(and-let* ((slot (layout-ref (object-layout o) name #f))
+		   (index (slot-index slot)))
+	  (vector-ref (object-slots o) index))
+	(and (eq? name 'traits)
+	     (traits-for-primitive object-or-primitive)))))
+
+(define (set-slot! object-or-primitive name value)
+  (and-let* ((o (object-or-false object-or-primitive))
+	     (slot (layout-ref (object-layout o) name #f))
+	     (index (slot-index slot)))
+    (let* ((slots (object-slots o))
+	   (old-value (vector-ref slots index)))
+      (vector-set! slots index value)
+      old-value)))
+
+(define (add-roles! name method specialisers)
+  (if (replace-method! name specialisers method)
+      method
+      (let ((requirements (collect-bitset not-no-role? specialisers)))
+	(for-each/index (lambda (index specialiser)
+			  (when (not-no-role? specialiser)
+			    (add-role! specialiser name #f index requirements method)))
+			specialisers))))
+
+;; (define-method! (union symbol string)
+;;                 (list-of symbol)
+;;                 (list-of object) - use *no-role* in this list if needed
+;;                 procedure)
+;;  -> method
+;;
+(define (define-method! name formal-names formal-specialisers body)
+  (let* ((selector (if (string? name) (string->symbol name) name))
+	 (method (make-method* selector formal-names body)))
+    (add-roles!* selector #t method formal-specialisers)
+    (invalidate-method-cache!)
+    method))
+
+;---------------------------------------------------------------------------
+
+(define-record-type method-cache-entry
+  (make-method-cache-entry selector layouts method)
+  method-cache-entry?
+  (selector method-cache-entry-selector)
+  (layouts method-cache-entry-layouts)
+  (method method-cache-entry-method))
+
+(define *method-cache-length* 512)
+
+(define *method-cache* 'uninitialised-method-cache)
+(define (invalidate-method-cache!)
+  (set! *method-cache* (make-vector *method-cache-length* '())))
+(invalidate-method-cache!)
+
+(define (object-layout-for-cache x)
+  (object-layout (cond
+		  ((object? x) x)
+		  ((hash-table-ref *literal-objects* x #f))
+		  (else (traits-for-primitive x)))))
+
+(define (object-layout-hash-for-cache x)
+  (layout-hash (object-layout-for-cache x)))
+
+(define (probe-for-cache selector args)
+  (bitwise-and (bitwise-xor (hash selector *method-cache-length*)
+			    (object-layout-hash-for-cache (vector-ref args 0)))
+	       (- *method-cache-length* 1)))
+
+(define (check-method-cache selector args)
+  (let* ((probe (probe-for-cache selector args))
+	 (entry (vector-ref *method-cache* probe)))
+    (and (method-cache-entry? entry)
+	 (eq? (method-cache-entry-selector entry) selector)
+	 (let ((n (vector-length args))
+	       (layouts (method-cache-entry-layouts entry)))
+	   (and (= n (vector-length layouts))
+		(let loop ((i 0))
+		  (cond
+		   ((= i n) (method-cache-entry-method entry))
+		   ((eq? (object-layout-for-cache (vector-ref args i)) (vector-ref layouts i))
+		    (loop (+ i 1)))
+		   (else #f))))))))
+
+(define (cache-method! method selector args)
+  (let* ((n (vector-length args))
+	 (layouts (make-vector n))
+	 (probe (probe-for-cache selector args)))
+    (do ((i 0 (+ i 1)))
+	((= i n))
+      (vector-set! layouts i (object-layout-for-cache (vector-ref args i))))
+    (vector-set! *method-cache* probe (make-method-cache-entry selector
+							       layouts
+							       method))))
+
+;---------------------------------------------------------------------------
+
+(define-record-type bitset
+  (make-bitset* bits)
+  bitset?
+  (bits bitset-bits))
+
+(define *bitset-capacity* 31)
+
+(define-record-printer (bitset b out)
+  (for-each (lambda (x) (display x out))
+            (list "#<bitset "(bitset->list b)">")))
+
+(define (bit-set? bitset n)
+  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-bit-set?))
+  (not (zero? (bitwise-and (bitset-bits bitset) (arithmetic-shift 1 n)))))
+
+(define (set-bit bitset n)
+  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-set-bit))
+  (make-bitset* (bitwise-ior (bitset-bits bitset) (arithmetic-shift 1 n))))
+
+(define (clear-bit bitset n)
+  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-clear-bit))
+  (make-bitset* (bitwise-and (bitset-bits bitset) (bitwise-not (arithmetic-shift 1 n)))))
+
+(define (bitset=? b1 b2)
+  (= (bitset-bits b1)
+     (bitset-bits b2)))
+
+(define (bitset->list b)
+  (filter (lambda (n) (bit-set? b n))
+	  (iota *bitset-capacity*)))
+
+(define (list->bitset l)
+  (fold (lambda (bit acc) (set-bit acc bit))
+	*empty-bitset*
+	l))
+
+(define *empty-bitset* (make-bitset* 0))
+
+;---------------------------------------------------------------------------
+;; Rank vectors.
+;;
+;; Representation: bitfield, 28 bits wide; bits numbered >= 28 must be zero.
+;;  - room for 7 arguments numbered 0 through 6, inclusive
+;;  - bits [4n, 4n+3] are the delegation-depth at the (6-n)th argument
+;; Thus:
+;;   33222222222211111111110000000000
+;;   10987654321098765432109876543210
+;;   --------------------------------
+;;   xxxx0000111122223333444455556666
+
+(define *illegal-rank-vector-bits* (arithmetic-shift -1 (* 4 7)))
+(define *max-rank-vector* (bitwise-not *illegal-rank-vector-bits*))
+
+(define (rank-vector-update rv delegation-depth arg-index)
+  (let ((result (if (or (> delegation-depth 15)
+			(> arg-index 6))
+		    (error 'out-of-range-in-rank-vector-update (list delegation-depth arg-index))
+		    (let ((offset (* 4 (- 6 arg-index))))
+		      (bitwise-ior (bitwise-and rv
+						*max-rank-vector*
+						(bitwise-not (arithmetic-shift #xF offset)))
+				   (arithmetic-shift delegation-depth offset))))))
+    (debug 4 "rank-vector-update "(number->string rv 16)" "delegation-depth" "arg-index
+	   " --> "(number->string result 16))
+    (if (not (zero? (bitwise-and rv *illegal-rank-vector-bits*)))
+	(error "Illegal rank vector"))
+    result))
+
+(define rank-vector<?
+  (lambda (a b)
+    (let ((result (< a b)))
+      (debug 4 "rank-vector<? "(number->string a 16)" "(number->string b 16)" --> "result)
+      result)))
+(define rank-vector>?
+  (lambda (a b)
+    (let ((result (> a b)))
+      (debug 4 "rank-vector>? "(number->string a 16)" "(number->string b 16)" --> "result)
+      result)))
+
+;---------------------------------------------------------------------------
+
+(define (role-active-at-position? role position)
+  (bit-set? (role-positions role) position))
+
+(define (role-requirements-filled? role positions)
+  (bitset=? positions (role-requirements role)))
+
+;---------------------------------------------------------------------------
+
+(define (dispatch ignored-method selector args)
+  (or (and (not ignored-method)
+	   (check-method-cache selector args))
+      (if ignored-method
+	  (dispatch* ignored-method selector args)
+	  (and-let* ((method (dispatch* ignored-method selector args)))
+	    (cache-method! method selector args)
+	    method))))
+
+(define (dispatch* ignored-method selector args)
+  (debug 3 --> 0 "Dispatch "selector" "(vector-length args))
+  (let* ((num-args (vector-length args))
+	 (most-specific-method #f)
+; 	 (DEBUG-ids (make-hash-table eq?))
+; 	 (DEBUG-counter 10000)
+; 	 (DEBUG-id (lambda (x) (or (hash-table-ref DEBUG-ids x)
+; 				   (let ((c DEBUG-counter))
+; 				     (set! DEBUG-counter (+ c 1))
+; 				     (hash-table-set! DEBUG-ids x c)
+; 				     c))))
+	 (accessor-target #f)
+	 (candidate-status (make-hash-table eq?))
+	 (delegations-seen (make-hash-table eq?))
+	 (rank-table (make-hash-table eq?))
+	 (rank-vector-for (lambda (method deft) (hash-table-ref rank-table method deft))))
+    (do ((arg-index 0 (+ arg-index 1)))
+	((= arg-index num-args))
+      (let search-delegates ((delegates (list (vector-ref args arg-index)))
+			     (delegation-depth 0))
+	(unless (null? delegates)
+	  (let* ((maybe-primitive-delegate (car delegates))
+		 (delegate (let ((d maybe-primitive-delegate))
+			     (ensure-object-var/traits d)
+			     d))
+		 (remaining-delegates (cdr delegates))
+		 (delegate-layout (object-layout delegate))
+		 (selected-slot (layout-ref delegate-layout selector #f)))
+;	    (debug 1 --> 0 "Inspecting "maybe-primitive-delegate" resolving to "delegate)
+;	    (debug 6 --> 0 "Inspecting "(DEBUG-id delegate)
+;		   " slot "selected-slot" depth "delegation-depth" arg index "arg-index)
+	    (when selected-slot
+	      (for-each (lambda (role)
+			  (when (role-active-at-position? role arg-index)
+			    (let* ((method (role-method role))
+				   (rankvec0 (rank-vector-for method *max-rank-vector*))
+				   (rankvec (rank-vector-update
+					     rankvec0 delegation-depth arg-index))
+				   (positions0 (hash-table-ref
+						candidate-status method *empty-bitset*))
+				   (positions (set-bit positions0 arg-index)))
+			      (hash-table-set! rank-table method rankvec)
+			      (hash-table-set! candidate-status method positions)
+			      (when (and (role-requirements-filled? role positions)
+					 (or (not ignored-method)
+					     (rank-vector>? rankvec
+							    (rank-vector-for ignored-method -1)))
+					 (or (not most-specific-method)
+					     (rank-vector<? rankvec
+							    (rank-vector-for
+							     most-specific-method -1))))
+				(cond
+				 ((eq? (get-slot method 'accessor) *nil*)
+				  (set! accessor-target #f))
+				 ((= arg-index 0)
+				  (set! accessor-target maybe-primitive-delegate)))
+				(set! most-specific-method method)))))
+			(slot-roles selected-slot)))
+	    (layout-for-each delegate-layout
+	     (lambda (slot-name slot)
+	       (and-let* ((_		(slot-delegating? slot))
+			  (new-delegate	(vector-ref (object-slots delegate) (slot-index slot)))
+			  (_		(not (eq? new-delegate *nil*)))
+			  (seen-in-positions (hash-table-ref delegations-seen new-delegate
+							     *empty-bitset*))
+			  (_		(not (bit-set? seen-in-positions arg-index))))
+		 (hash-table-set! delegations-seen new-delegate
+				  (set-bit seen-in-positions arg-index))
+;		 (debug 6 --> 0 "Delegating via "slot-name" of "(DEBUG-id delegate)
+;			" to "(DEBUG-id new-delegate) " at level "delegation-depth" pos "arg-index)
+		 (set! remaining-delegates (cons new-delegate remaining-delegates)))))
+	    (search-delegates remaining-delegates (+ delegation-depth 1))))))
+    (if most-specific-method
+	(begin
+	  (when accessor-target
+	    (vector-set! args 0 accessor-target))
+	  most-specific-method)
+	#f)))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/packrat.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,285 @@
+;; Packrat Parser Library
+
+(require 'srfi-1)
+
+(define-record-type parse-result
+  (make-parse-result successful? semantic-value next error)
+  parse-result?
+  (successful? parse-result-successful?)
+  (semantic-value parse-result-semantic-value)
+  (next parse-result-next) ;; #f, if eof or error; otherwise a parse-results
+  (error parse-result-error)
+  ;; ^^ #f if none, but usually a parse-error structure
+  )
+
+(define-record-type parse-results
+  (make-parse-results position base next map)
+  parse-results?
+  (position parse-results-position) ;; a parse-position or #f if unknown
+  (base parse-results-base) ;; a value, #f indicating 'none' or 'eof'
+  (next parse-results-next* set-parse-results-next!)
+  ;; ^^ a parse-results, or a nullary function delivering same, or #f for nothing next (eof)
+  (map parse-results-map set-parse-results-map!)
+  ;; ^^ an alist mapping a nonterminal to a parse-result
+  )
+
+(define-record-type parse-error
+  (make-parse-error position expected-strings messages)
+  parse-error?
+  (position parse-error-position) ;; a parse-position or #f if unknown
+  (expected-strings parse-error-expected-strings) ;; set of strings (lset)
+  (messages parse-error-messages) ;; list of strings
+  )
+
+(define-record-type parse-position
+  (make-parse-position file line column)
+  parse-position?
+  (file parse-position-file)
+  (line parse-position-line)
+  (column parse-position-column))
+
+(define (top-parse-position filename)
+  (make-parse-position filename 1 0))
+
+(define (update-parse-position pos ch)
+  (if (not pos)
+      #f
+      (let ((file (parse-position-file pos))
+	    (line (parse-position-line pos))
+	    (column (parse-position-column pos)))
+	(cond
+	 ((eq? ch #\return) (make-parse-position file line 0))
+	 ((eq? ch #\newline) (make-parse-position file (+ line 1) 0))
+	 ((eq? ch #\tab) (make-parse-position file line (* (quotient (+ column 8) 8) 8)))
+	 (else (make-parse-position file line (+ column 1)))))))
+
+(define (parse-position->string pos)
+  (if (not pos)
+      "<??>"
+      (string-append (parse-position-file pos) ":"
+		     (number->string (parse-position-line pos)) ":"
+		     (number->string (parse-position-column pos)))))
+
+(define (empty-results pos)
+  (make-parse-results pos #f #f '()))
+
+(define (make-results pos base next-generator)
+  (make-parse-results pos base next-generator '()))
+
+(define (make-error-expected pos str)
+  (make-parse-error pos (list str) '()))
+
+(define (make-error-message pos msg)
+  (make-parse-error pos '() (list msg)))
+
+(define (make-result semantic-value next)
+  (make-parse-result #t semantic-value next #f))
+
+(define (make-expected-result pos str)
+  (make-parse-result #f #f #f (make-error-expected pos str)))
+
+(define (make-message-result pos msg)
+  (make-parse-result #f #f #f (make-error-message pos msg)))
+
+(define (prepend-base pos base next)
+  (make-parse-results pos base next '()))
+
+(define (prepend-semantic-value pos key result next)
+  (make-parse-results pos #f #f
+		      (list (cons key (make-result result next)))))
+
+(define (base-generator->results generator)
+  ;; Note: applies first next-generator, to get first result
+  (define (results-generator)
+    (let-values (((pos base) (generator)))
+      (if (not base)
+	  (empty-results pos)
+	  (make-results pos base results-generator))))
+  (results-generator))
+
+(define (parse-results-next results)
+  (let ((next (parse-results-next* results)))
+    (if (procedure? next)
+	(let ((next-value (next)))
+	  (set-parse-results-next! results next-value)
+	  next-value)
+	next)))
+
+(define (results->result results key fn)
+  (let ((results-map (parse-results-map results)))
+    (cond
+     ((assq key results-map) => cdr)
+     (else (let ((result (fn)))
+	     (set-parse-results-map! results (cons (cons key result) results-map))
+	     result)))))
+
+(define (parse-position>? a b)
+  (cond
+   ((not a) #f)
+   ((not b) #t)
+   (else (let ((la (parse-position-line a)) (lb (parse-position-line b)))
+	   (or (> la lb)
+	       (and (= la lb)
+		    (> (parse-position-column a) (parse-position-column b))))))))
+
+(define (parse-error-empty? e)
+  (and (null? (parse-error-expected-strings e))
+       (null? (parse-error-messages e))))
+
+(define (merge-parse-errors e1 e2)
+  (cond
+   ((not e1) e2)
+   ((not e2) e1)
+   (else
+    (let ((p1 (parse-error-position e1))
+	  (p2 (parse-error-position e2)))
+      (cond
+       ((or (parse-position>? p1 p2) (parse-error-empty? e2)) e1)
+       ((or (parse-position>? p2 p1) (parse-error-empty? e1)) e2)
+       (else (make-parse-error p1
+			       (lset-union string=?
+					   (parse-error-expected-strings e1)
+					   (parse-error-expected-strings e2))
+			       (append (parse-error-messages e1) (parse-error-messages e2)))))))))
+
+(define (merge-result-errors result errs)
+  (make-parse-result (parse-result-successful? result)
+		     (parse-result-semantic-value result)
+		     (parse-result-next result)
+		     (merge-parse-errors (parse-result-error result) errs)))
+
+;---------------------------------------------------------------------------
+
+(define (parse-results-token-kind results)
+  (let ((base (parse-results-base results)))
+    (and base (car base))))
+
+(define (parse-results-token-value results)
+  (let ((base (parse-results-base results)))
+    (and base (cdr base))))
+
+(define (packrat-check-base token-kind k)
+  (lambda (results)
+    (let ((base (parse-results-base results)))
+      (if (eq? (and base (car base)) token-kind)
+	  ((k (and base (cdr base))) (parse-results-next results))
+	  (make-expected-result (parse-results-position results)
+				(if (not token-kind)
+				    "end-of-file"
+				    (symbol->string token-kind)))))))
+
+(define (packrat-check parser k)
+  (lambda (results)
+    (let ((result (parser results)))
+      (if (parse-result-successful? result)
+	  (merge-result-errors ((k (parse-result-semantic-value result))
+				(parse-result-next result))
+			       (parse-result-error result))
+	  result))))
+
+(define (packrat-or p1 p2)
+  (lambda (results)
+    (let ((result (p1 results)))
+      (if (parse-result-successful? result)
+	  result
+	  (merge-result-errors (p2 results)
+			       (parse-result-error result))))))
+
+(define (packrat-unless explanation p1 p2)
+  (lambda (results)
+    (let ((result (p1 results)))
+      (if (parse-result-successful? result)
+	  (make-message-result (parse-results-position results)
+			       explanation)
+	  (p2 results)))))
+
+;---------------------------------------------------------------------------
+
+(define (object->external-representation o)
+  (let ((s (open-output-string)))
+    (write o s)
+    (get-output-string s)))
+
+(define-syntax packrat-parser
+  (syntax-rules (<- quote ! @ /)
+    ((_ start (nonterminal (alternative body0 body ...) ...) ...)
+     (let ()
+       (define nonterminal
+	 (lambda (results)
+	   (results->result results 'nonterminal
+			    (lambda ()
+			      ((packrat-parser #f "alts" nonterminal
+					       ((begin body0 body ...) alternative) ...)
+			       results)))))
+       ...
+       start))
+
+    ((_ #f "alts" nt (body alternative))
+     (packrat-parser #f "altD" nt body alternative))
+
+    ((_ #f "alts" nt (body alternative) rest0 rest ...)
+     (packrat-or (packrat-parser #f "altD" nt body alternative)
+		 (packrat-parser #f "alts" nt rest0 rest ...)))
+
+    ((_ #f "altD" nt body alternative)
+     (lambda (results)
+       ;;(write (list (parse-position->string (parse-results-position results))
+       ;;'trying- 'nt 'alternative))
+       ;;(newline)
+       (let ((result ((packrat-parser #f "alt" nt body alternative) results)))
+	 ;;(write (list (parse-position->string
+	 ;;(parse-results-position results))
+	 ;;(if (parse-result-successful? result)
+	 ;;'success
+	 ;;'failing)
+	 ;;'nt 'alternative))
+	 ;;(newline)
+	 result)))
+
+    ((_ #f "alt" nt body ())
+     (lambda (results) (make-result body results)))
+
+    ((_ #f "alt" nt body ((! fails ...) rest ...))
+     (packrat-unless (string-append "Nonterminal " (symbol->string 'nt)
+				    " expected to fail "
+				    (object->external-representation '(fails ...)))
+		     (packrat-parser #f "alt" nt #t (fails ...))
+		     (packrat-parser #f "alt" nt body (rest ...))))
+
+    ((_ #f "alt" nt body ((/ alternative ...) rest ...))
+     (packrat-check (packrat-parser #f "alts" nt (#t alternative) ...)
+		    (lambda (result) (packrat-parser #f "alt" nt body (rest ...)))))
+
+    ((_ #f "alt" nt body (var <- 'val rest ...))
+     (packrat-check-base 'val
+			 (lambda (var)
+			   (packrat-parser #f "alt" nt body (rest ...)))))
+
+    ((_ #f "alt" nt body (var <- @ rest ...))
+     (lambda (results)
+       (let ((var (parse-results-position results)))
+	 ((packrat-parser #f "alt" nt body (rest ...)) results))))
+
+    ((_ #f "alt" nt body (var <- val rest ...))
+     (packrat-check val
+		    (lambda (var)
+		      (packrat-parser #f "alt" nt body (rest ...)))))
+
+    ((_ #f "alt" nt body ('val rest ...))
+     (packrat-check-base 'val
+			 (lambda (dummy)
+			   (packrat-parser #f "alt" nt body (rest ...)))))
+
+    ((_ #f "alt" nt body (val rest ...))
+     (packrat-check val
+		    (lambda (dummy)
+		      (packrat-parser #f "alt" nt body (rest ...)))))))
+
+(define (x)
+  (sc-expand
+   '(packrat-parser expr
+		    (expr ((a <- 'num '+ b <- 'num)
+			   (+ a b))
+			  ((a <- mulexp) a))
+		    (mulexp ((a <- 'num '* b <- 'num)
+			     (* a b))))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/parsetng.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,350 @@
+(require 'srfi-1) ; list
+(require 'srfi-13) ; string
+(require 'srfi-14) ; charset
+
+(eval-when (compile) (load "packrat.scm"))
+(require 'util)
+(require 'packrat)
+
+;---------------------------------------------------------------------------
+;; utilities
+
+(define (transform-grammar grammar)
+  (map (lambda (clause)
+	 (let ((v (last clause))
+	       (front (butlast clause)))
+	   (if (procedure? v)
+	       clause
+	       (append front (list (lambda args
+				     (debug 3 'reducing clause args)
+				     (let walk ((formal v))
+				       (cond
+					((null? formal) '())
+					((pair? formal) (cons (walk (car formal))
+							      (walk (cdr formal))))
+					((procedure? formal) (apply formal args))
+					((number? formal) (list-ref args formal))
+					(else formal)))))))))
+       grammar))
+
+;---------------------------------------------------------------------------
+;; lex0: categorising characters
+
+(define (lex0-ThiNG char-provider-thunk)
+  (let ((char (char-provider-thunk)))
+    (and (not (eof-object? char))
+	 (cons (cond
+		((char-set-contains? char-set:letter char) 'letter)
+		((char-set-contains? char-set:digit char) 'digit)
+		((or (char-whitespace? char)
+		     (char-set-contains? char-set:blank char))
+		 'whitespace)
+		(else (case char
+			((#\() 'oparen)
+			((#\)) 'cparen)
+			((#\[) 'obrack)
+			((#\]) 'cbrack)
+			((#\{) 'obrace)
+			((#\}) 'cbrace)
+			((#\+) 'plus)
+			((#\-) 'minus)
+			((#\=) 'equal)
+			((#\") 'doublequote)
+			((#\') 'quote)
+			((#\.) 'dot)
+			((#\:) 'colon)
+			((#\|) 'pipe)
+			((#\@) 'at)
+			((#\#) 'hash)
+			((#\\) 'backslash)
+			((#\_) 'underscore)
+			((#\*) 'star)
+			(else 'misc))))
+	       char))))
+
+(define (unfold-lex0-ThiNG port)
+  (unfold (lambda (dummy) (eof-object? (peek-char port)))
+	  lex0-ThiNG
+	  (lambda (token) token)
+	  (lambda () (read-char port))))
+
+;---------------------------------------------------------------------------
+;; lex1: building tokens from categorised character stream
+;;
+;; compound (pseudo-)token kinds:
+;;   identifier   [a-zA-Z][a-zA-Z0-9]*:?
+;;   symbol       [^ ]+
+;;   integer      [-+]?[0-9]+/[^.]
+;;   comment      "([^"\\]|\\"|\\\\])*"
+;;   string       '([^'\\]|\\'|\\\\])*'
+;;   :=
+
+(define (make-lex1-ThiNG filename char-provider-thunk)
+  (let* ((pushback* '())
+	 (position (top-parse-position filename))
+	 (prev-position position))
+    (define (next!)
+      (if (null? pushback*)
+	  (let* ((newval (lex0-ThiNG char-provider-thunk)))
+	    (if newval
+		(begin
+		  (set! prev-position position)
+		  (set! position (update-parse-position position (cdr newval)))))
+	    newval)
+	  (let ((v (car pushback*)))
+	    (set! pushback* (cdr pushback*))
+	    (set! prev-position position)
+	    (set! position (cdr v))
+	    (car v))))
+
+    (define (pushback! x)
+      (set! pushback* (cons (cons x position) pushback*))
+      (set! position prev-position))
+
+    (define (go fn . data)
+      (dispatch* (next!) fn data))
+
+    (define (dispatch token fn . data)
+      (dispatch* token fn data))
+
+    (define emit-k 'emit-k)
+
+    (define (dispatch* token fn data)
+      (if token
+	  (apply fn token (car token) (cdr token) data)
+	  (emit-k #f)))
+
+    (define (emit kind sv)
+      (emit-k (cons prev-position (cons kind sv))))
+
+    (define (lex token kind sv)
+      (case kind
+	((whitespace) (go lex))
+	((minus plus) (go lex-sign token))
+	((digit) (pushback! token) (go lex-number #f 0))
+	((letter) (go lex-identifier (list sv)))
+	((colon) (go lex-colon token))
+	((doublequote) (go lex-string token '() (lambda (result) (go lex))))
+	((quote) (go lex-string token '() (lambda (result) (emit 'string result))))
+	((hash) (go lex-symbol '()))
+	((misc equal star) (go lex-punct (list sv)))
+	(else (emit kind sv))))
+
+    (define (lex-sign token kind sv sign-token)
+      (pushback! token)
+      (if (eq? kind 'digit)
+	  (go lex-number (car sign-token) 0)
+	  (go lex-punct (list (cdr sign-token)))))
+
+    (define (lex-punct token kind sv acc)
+      (case kind
+	((misc equal star plus minus) (go lex-punct (cons sv acc)))
+	(else
+	 (pushback! token)
+	 (emit 'punct (list->string (reverse acc))))))
+
+    (define (lex-number token kind sv sign acc)
+      (case kind
+	((digit) (go lex-number sign (+ (* acc 10)
+					(- (char->integer sv)
+					   (char->integer #\0)))))
+	((dot) (go lex-decimal sign acc token))
+	(else
+	 (pushback! token)
+	 (finish-integer sign acc))))
+
+    (define (lex-decimal token kind sv sign acc dot-token)
+      (case kind
+	((digit) (error "Illegal syntax - floating-point literals not supported"))
+	(else
+	 (pushback! token)
+	 (pushback! dot-token)
+	 (finish-integer sign acc))))
+
+    (define (finish-integer sign acc)
+      (emit 'integer (* (if (eq? sign 'minus) -1 1) acc)))
+
+    (define (lex-identifier token kind sv acc)
+      (case kind
+	((letter digit) (go lex-identifier (cons sv acc)))
+	((colon) (go lex-selector-identifier token acc))
+	(else
+	 (pushback! token)
+	 (finish-identifier 'identifier acc))))
+
+    (define (lex-selector-identifier token kind sv colon-token acc)
+      (pushback! token)
+      (if (memq kind '(equal star))
+	  (begin
+	    (pushback! colon-token)
+	    (finish-identifier 'identifier acc))
+	  (finish-identifier 'selector (cons #\: acc))))
+
+    (define (lex-symbol token kind sv acc)
+      (case kind
+	((letter digit misc equal star plus minus) (go lex-symbol (cons sv acc)))
+	(else
+	 (pushback! token)
+	 (finish-identifier 'symbol acc))))
+
+    (define (finish-identifier kind acc)
+      (let ((idstr (list->string (reverse acc))))
+	(if (and (eq? kind 'identifier)
+		 (string=? idstr "resend"))
+	    (emit 'resend 'resend)
+	    (emit kind idstr))))
+
+    (define (lex-colon token kind sv colon-token)
+      (case kind
+	((equal) (emit 'colonequal #f))
+	((star) (emit 'colonstar #f))
+	(else
+	 (pushback! token)
+	 (emit 'colon (cdr colon-token)))))
+
+    (define (lex-string token kind sv terminator acc k)
+      (if (eq? kind (car terminator))
+	  (k (list->string (reverse acc)))
+	  (case kind
+	    ((backslash) (go (lambda (token2 kind2 sv2)
+			       (go lex-string 
+				   terminator
+				   (cons (case sv2
+					   ((#\n) #\newline)
+					   ((#\t) #\tab)
+					   (else sv2))
+					 acc)
+				   k))))
+	    (else (go lex-string terminator (cons sv acc) k)))))
+
+    (lambda ()
+      (call-with-current-continuation
+       (lambda (k)
+	 (set! emit-k k)
+	 (error "Value returned without emit from lexer" (go lex)))))))
+
+(define (unfold-lex1-ThiNG port)
+  (let ((lexer (make-lex1-ThiNG (lambda () (read-char port))))
+	(done #f))
+    (unfold (lambda (dummy) done)
+	    (lambda (dummy)
+	      (let ((result (lexer)))
+		(if (not result)
+		    (set! done #t))
+		result))
+	    (lambda (token) token)
+	    'dummy1)))
+
+;---------------------------------------------------------------------------
+;; parsing
+
+(define (fixup-nary first-val args)
+  (let* ((selectors (map car args))
+	 (vals (map cadr args))
+	 (selector (string-concatenate selectors)))
+    `(send ,selector ,(cons first-val vals))))
+
+(define-values (ThiNG-parser ThiNG-topexpr-parser)
+  (packrat-parser
+   (values toplevel topexpr)
+
+   (toplevel ((a <- topexpr 'dot b <- toplevel) (cons a b))
+	     ((a <- topexpr 'dot '#f) (list a))
+	     ((a <- topexpr '#f) (list a)))
+
+   (topexpr ((a <- method-definition) a)
+	    ((a <- expr) a))
+
+   (expr ((a <- nary) a))
+
+   (nary ((a <- binary args <- nary-args) (fixup-nary a args))
+	 ((a <- binary) a))
+
+   (nary-args ((sel <- selector b <- binary rest <- nary-args) (cons (list sel b) rest))
+	      ((sel <- selector b <- binary) (list (list sel b))))
+
+   (binary ((u1 <- unary k <- binaryk) (k u1)))
+   (binaryk ((op <- binaryop u2 <- unary k <- binaryk)
+	     (lambda (u1) (k `(send ,op (,u1 ,u2)))))
+	    (()
+	     (lambda (u1) u1)))
+
+   (binaryop ((p <- 'punct) p))
+
+   (unary ((v <- value k <- unaryk) (k v)))
+   (unaryk ((i <- id (! (/ ('colonequal) ('colonstar))) k <- unaryk)
+	    (lambda (v) (k `(send ,i (,v)))))
+	   (()
+	    (lambda (v) v)))
+
+   (value ((i <- id 'oparen s <- stmt-seq 'cparen) `(scope ,i ,s))
+	  ((i <- id) `(ref ,i))
+	  ((b <- block) `(block . ,b))
+	  ((s <- 'string) `(string ,s))
+	  ((s <- 'symbol) `(symbol ,(string->symbol s)))
+	  ((i <- 'integer) `(number ,i))
+	  (('resend) `(resend))
+	  (('oparen e <- expr u <- updates+ 'cparen) `(update ,e ,u))
+	  (('oparen u <- updates 'cparen) `(update (ref "Root") ,u))
+	  (('oparen e <- expr 'cparen) e)
+	  (('oparen s <- stmt-seq 'cparen) `(scope ,*nil* ,s))
+	  (('obrace ee <- expr-seq 'cbrace) `(tuple ,ee)))
+
+   (updates+ ((u <- update uu <- updates) (cons u uu)))
+   (updates ((u <- update uu <- updates) (cons u uu))
+	    (() '()))
+
+   (update ((i <- id 'colonequal e <- expr) (list *false* i e))
+	   ((i <- id 'colonstar e <- expr) (list *true* i e)))
+
+   (block (('obrack b <- binders s <- stmt-seq 'cbrack) (list b s)))
+
+   (expr-seq ((e <- expr 'dot ee <- expr-seq) (cons e ee))
+	     ((e <- expr) (list e))
+	     (() '()))
+
+   (stmt-seq ((e <- stmt 'dot s <- stmt-seq) (cons e s))
+	     ((e <- stmt) (list e))
+	     (() '()))
+
+   (stmt ((i <- id 'colonequal e <- expr) `(let ,i ,e))
+	 ((e <- expr) e))
+
+   (binders ((b <- binders+ 'pipe) b)
+	    (() '()))
+   (binders+ ((b <- binder bb <- binders+) (cons b bb))
+	     ((b <- binder) (list b)))
+   (binder (('colon i <- id) i))
+
+   (method-definition ((p <- method-params 'obrack ee <- stmt-seq 'cbrack) `(method ,p ,ee)))
+
+   (method-params ((p1 <- method-param op <- binaryop p2 <- method-param) `(send ,op (,p1 ,p2)))
+		  ((p1 <- method-param n <- method-nary) (fixup-nary p1 n))
+		  ((p <- method-param i <- id) `(send ,i (,p))))
+
+   (method-param (('underscore 'at v <- value) (list *false* v))
+		 (('underscore) (list *false* *false*))
+		 ((i <- id 'at v <- value) (list i v))
+		 ((i <- id) (list i *false*)))
+
+   (method-nary ((s <- selector p <- method-param r <- method-nary) (cons (list s p) r))
+		((s <- selector p <- method-param) (list (list s p))))
+
+   (selector ((s <- 'selector) s))
+   (id ((i <- 'identifier) i))))
+
+(define (parse-ThiNG filename parser char-provider-thunk)
+  (let* ((lexer (make-lex1-ThiNG filename char-provider-thunk))
+	 (result (parser (base-generator->results
+			  (lambda ()
+			    (let ((r (lexer)))
+			      (if r
+				  (values (car r) (cdr r))
+				  (values #f #f))))))))
+    (if (parse-result-successful? result)
+	(values #t (parse-result-semantic-value result))
+	(let ((e (parse-result-error result)))
+	  (values #f (list 'parse-error
+			   (parse-position->string (parse-error-position e))
+			   (parse-error-expected-strings e)
+			   (parse-error-messages e)))))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/root-hooks.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,57 @@
+;; This file is included with a local macro definition for def
+;; in kernel.scm.
+
+(def (*nil* Nil)
+     (*no-role* NoRole)
+
+     (*traits-method* #f)
+     (*method* Method)
+
+     (*traits-traits* Traits)
+
+     (*traits-root* #f)
+     (*root* Root)
+
+     (*traits-oddball* #f)
+     (*traits-derivable* #f)
+     (*traits-cloneable* #f)
+
+     (*oddball* Oddball)
+
+     (*derivable* Derivable)
+     (*cloneable* Cloneable)
+
+     (*traits-number* #f)
+     (*traits-character* #f)
+     (*traits-boolean* #f)
+     (*traits-symbol* #f)
+     (*traits-tuple* #f)
+     (*traits-pair* #f)
+     (*traits-string* #f)
+
+     (*traits-socket* #f)
+     (*traits-sdl-surface* #f)
+     (*traits-sdl-event* #f)
+     (*traits-ttf-font* #f)
+
+     (*true* True)
+     (*false* False)
+
+     (*tuple* Tuple)
+     (*string* String)
+     (*symbol* Symbol)
+     (*number* Number)
+     (*pair* Pair)
+
+     (*traits-block* #f)
+     (*block* Block)
+
+     ;; Language-specific -----------
+     (*traits-cell* #f)
+     (*cell* Cell)
+     (*traits-location* #f)
+     (*location* Location)
+     (*boot-block* BootBlock)
+     (*globals* Globals)
+     ;; -----------------------------
+)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/scratch	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,29 @@
+1 to: 100 do: [:i|].
+
+** Pure interpretation:
+Hits: 407 Misses: 214
+Hits: 411 Misses: 210
+Hits: 409 Misses: 212
+
+** After compilation to vector-instructions:
+Hits: 610 Misses: 11
+Hits: 618 Misses: 3
+Hits: 618 Misses: 3
+
+
+
+n@(Number traits) fib [
+  (n < 2)
+    ifTrue: [ n ]
+    ifFalse: [ (n - 1) fib + (n - 2) fib ]
+].
+
+
+csi> (time (do ((i 0 (+ i 1))) ((= i 10)) (fib 20)))
+    0.59 seconds elapsed
+    0.09 seconds in (major) GC
+       1 mutations
+     111 minor GCs
+      21 major GCs
+
+.... ThiNG took 112 seconds for a (20 fib).
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sdl-events.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,18 @@
+(def-sdl-event-type
+  (*traits-sdl-noevent* SDL_NOEVENT)
+  (*traits-sdl-activeevent* SDL_ACTIVEEVENT)
+  (*traits-sdl-keydown* SDL_KEYDOWN)
+  (*traits-sdl-keyup* SDL_KEYUP)
+  (*traits-sdl-mousemotion* SDL_MOUSEMOTION)
+  (*traits-sdl-mousebuttondown* SDL_MOUSEBUTTONDOWN)
+  (*traits-sdl-mousebuttonup* SDL_MOUSEBUTTONUP)
+  (*traits-sdl-joyaxismotion* SDL_JOYAXISMOTION)
+  (*traits-sdl-joyballmotion* SDL_JOYBALLMOTION)
+  (*traits-sdl-joyhatmotion* SDL_JOYHATMOTION)
+  (*traits-sdl-joybuttondown* SDL_JOYBUTTONDOWN)
+  (*traits-sdl-joybuttonup* SDL_JOYBUTTONUP)
+  (*traits-sdl-quit* SDL_QUIT)
+  (*traits-sdl-syswmevent* SDL_SYSWMEVENT)
+  (*traits-sdl-videoresize* SDL_VIDEORESIZE)
+  (*traits-sdl-videoexpose* SDL_VIDEOEXPOSE)
+  (*traits-sdl-userevent* SDL_USEREVENT))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test.thing	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,50 @@
+"-*- slate -*-"
+
+Namespaces addGlobal: #Counter value: (count:= Nil).
+
+[ :a :b | c = a + b. c ].
+
+[ :a :b | a + b ].
+
+_@(Integer traits) ++ _@(Integer traits)
+[
+  'ho ho ho'
+].
+
+a@(Integer traits) plus: b@(Integer traits)
+[
+  a + b
+].
+
+c@Counter new
+[
+  "a comment"
+  'a string'.
+  (c count:= 0 ref)
+].
+
+c@Counter next
+[
+  c count -> [ :value | c count <- value + 1 . value ]
+].
+
+_@True ifTrue: block@(Block traits) [ block value ].
+_@False ifTrue: block@(Block traits) [ False ].
+_@True ifFalse: block@(Block traits) [ True ].
+_@False ifFalse: block@(Block traits) [ block value ].
+
+_@True ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b1 value ].
+_@False ifTrue: b1@(Block traits) ifFalse: b2@(Block traits) [ b2 value ].
+
+_@Integer trySomethingWith: other
+[ results = Array with: 29 fib with: 30 fib with: 31 fib.
+  Console printLn: (results at: 0).
+  Console printLn: (results at: 1).
+  resend
+].
+
+[ ctxt (
+    True ifTrue: [ ctxt return: 3 ].
+    (123 . 234 . 345)
+  )
+].
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tng.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,49 @@
+;; ---------------------------------------------------------------------------
+;; tng.scm - ThiNG main file. Load this with sdl-csi.
+;; ---------------------------------------------------------------------------
+
+;; The following is required because chicken by default has
+;; trailing-':' keyword mode, which makes literal symbols that end
+;; with ':' behave wrongly. If you don't set the keyword-style to
+;; #:none, then you get this:
+;;
+;; (eq? 'a: (string->symbol "a:")) ==> #f
+;;
+(require 'extras)
+
+(load "macros.scm")
+(require 'util)
+(require 'oo)
+(require 'kernel)
+(require 'parsetng)
+(require 'compile)
+(require 'interp)
+(require 'ui)
+(require 'image)
+
+(reset-primitive-table!)
+
+(define boot-image-name "BOOTSTRAP.image")
+
+(if (file-exists? boot-image-name)
+    (call-with-input-file boot-image-name
+      (lambda (port)
+	(let ((image (read port)))
+	  (deserialize-image! image))))
+    (bootstrap-image!))
+
+;; Be careful not to invoke any methods before the image is prepared!
+;; If you turn on debug, and the image-loader or -bootstrapper prints
+;; any objects, and the following record-printer is installed, then
+;; things break.
+;;
+(define-record-printer (object o out)
+  (display (send/previous-method/missing-handler #f
+						 (lambda (argv) "#<OBJECT>")
+						 'printString
+						 (vector o))
+	   out))
+
+(metalevel-spawn *nil* (lambda () (metalevel-eval `(send "do" ((ref "BootBlock"))))))
+(ui-mainloop)
+(exit 0)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ui.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,193 @@
+(require 'srfi-1)
+(require 'sdl)
+
+(if (zero? (sdl-was-init SDL_INIT_VIDEO))
+    (error "Please initialise SDL (use sdl-csi)."))
+
+(ttf-init)
+(sdl-net-init)
+
+(define *system-font*
+  (or (ttf-open-font "/sw/lib/X11/fonts/applettf/Monaco.ttf" 11)
+      (ttf-open-font "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMono.ttf" 11)))
+
+(define *event-type-map* (make-hash-table eq?))
+
+(define (traits-for-sdl-event-type t)
+  (or (hash-table-ref *event-type-map* t #f)
+      (error "No traits for event type" t)))
+
+(let-syntax ((def-sdl-event-type
+	       (syntax-rules ()
+		 ((_ (global-var sdl-event-type) ...)
+		  (begin
+		    (define global-var '*) ...)))))
+  (include "sdl-events.scm"))
+
+(define (update-sdl-event-type-map!)
+  (let-syntax ((def-sdl-event-type
+		 (syntax-rules ()
+		   ((_ (global-var sdl-event-type) ...)
+		    (begin
+		      (hash-table-set! *event-type-map* sdl-event-type global-var) ...)))))
+    (include "sdl-events.scm")))
+
+(push! global-load-hooks
+       (lambda ()
+	 (let-syntax ((def-sdl-event-type
+			(syntax-rules ()
+			  ((_ (global-var sdl-event-type) ...)
+			   (begin
+			     (set! global-var (hash-table-ref *image-root* 'global-var)) ...
+			     (update-sdl-event-type-map!))))))
+	   (include "sdl-events.scm"))))
+
+(push! global-store-hooks
+       (lambda ()
+	 (let-syntax ((def-sdl-event-type
+			(syntax-rules ()
+			  ((_ (global-var sdl-event-type) ...)
+			   (begin
+			     (hash-table-set! *image-root* 'global-var global-var) ...)))))
+	   (include "sdl-events.scm"))))
+
+(push! bootstrap-hooks
+       (lambda ()
+	 (let-syntax ((def-sdl-event-type
+			(syntax-rules ()
+			  ((_ (global-var sdl-event-type) ...)
+			   (begin
+			     (set! global-var (make-traits (symbol->string 'sdl-event-type)
+							   `(#(sdlEvent ,*traits-sdl-event*)
+							     (sdlEventNumber ,sdl-event-type))))
+			     ...
+			     (update-sdl-event-type-map!))))))
+	   (include "sdl-events.scm"))))
+
+(let ((old-hook (primitive-traits-hook)))
+  (primitive-traits-hook
+   (lambda (o)
+     (cond
+      ((sdl-tcp-socket? o) *traits-socket*)
+      ((sdl-surface? o) *traits-sdl-surface*)
+      ((sdl-event? o) (traits-for-sdl-event-type (sdl-event-type o)))
+      ((ttf-font? o) *traits-ttf-font*)
+      (else (old-hook o))))))
+
+(sdl-wm-set-caption "ThiNG" "ThiNG")
+
+(define (shutdown-sdl!)
+  (let ((e (make-sdl-event)))
+    (sdl-event-type-set! e SDL_QUIT)
+    (sdl-push-event e)))
+
+(define *socket-set* (sdl-net-alloc-socket-set 100))
+(define *active-sockets* '())
+(define *the-eof-object* (read-char (open-input-string "")))
+
+(define (activate-socket! sock suspension)
+  (push! *active-sockets* (cons sock suspension))
+  (debug 1 "Adding "sock" to set "*socket-set*)
+  (sdl-net-tcp-add-socket! *socket-set* sock))
+
+(define (wait-for-socket-activity! sock)
+  (metalevel-suspend-thread
+   (lambda (suspension)
+     (activate-socket! sock suspension))))
+
+(define (read-from-socket sock)
+  (wait-for-socket-activity! sock)
+  (sdl-net-tcp-recv-string sock 4096))
+
+(define (accept-from-socket sock)
+  (wait-for-socket-activity! sock)
+  (sdl-net-tcp-accept sock))
+
+(define (make-char-provider-thunk-for-socket sock)
+  (let ((state "")
+	(len 0)
+	(index 0))
+    (define (provider)
+      (cond
+       ((eof-object? state) state)
+       ((>= index len)
+	(let ((new-state (read-from-socket sock)))
+	  (if (string? new-state)
+	      (begin
+		(set! state new-state)
+		(set! len (string-length state))
+		(set! index 0)
+		(provider))
+	      (begin
+		(set! state *the-eof-object*)
+		(set! len 0)
+		(set! index 0)
+		(provider)))))
+       (else
+	(let ((result (string-ref state index)))
+	  (set! index (+ index 1))
+	  result))))
+    provider))
+
+(define (check-socket-set/delay delay-ms)
+  (let ((next-event-time (+ (get-time-of-day) (/ delay-ms 1000.0)))
+	(result (sdl-net-check-sockets *socket-set* 0)))
+    (if (and result (positive? result))
+	(let-values (((ready unready) (partition (lambda (record)
+						   (sdl-net-socket-ready? (car record)))
+						 *active-sockets*)))
+	  (set! *active-sockets* unready)
+	  (for-each (lambda (record)
+		      (let ((sock (car record))
+			    (suspension (cdr record)))
+			(debug 1 "Removing "sock" from set "*socket-set*)
+			(sdl-net-tcp-del-socket! *socket-set* sock)
+			(metalevel-resume-thread! suspension sock)))
+		    ready)))
+    (metalevel-run-runnable-suspensions next-event-time)))
+
+(define *video-surface* #f)
+
+(define (discover-best-resolution!)
+  (let loop ((resolutions '(
+			    ;;(1600 1200) (1280 1024) (1024 768) (800 600)
+			    (640 480))))
+    (if (null? resolutions)
+	(error "No resolution supported.")
+	(let* ((res (car resolutions))
+	       (maxx (car res))
+	       (maxy (cadr res))
+	       (s (sdl-set-video-mode maxx maxy 0 (+ SDL_HWSURFACE
+						     ;;SDL_FULLSCREEN
+						     SDL_HWPALETTE
+						     SDL_RESIZABLE
+						     SDL_DOUBLEBUF))))
+	  (if (not (sdl-surface-pointer s))
+	      (loop (cdr resolutions))
+	      (set! *video-surface* s))))))
+
+(define (ui-mainloop)
+  (discover-best-resolution!)
+  (sdl-fill-rect *video-surface*
+		 (make-sdl-rect 0 0
+				(sdl-surface-width *video-surface*)
+				(sdl-surface-height *video-surface*))
+		 (sdl-map-rgb (sdl-surface-pixel-format *video-surface*) 0 0 255))
+  (sdl-flip *video-surface*)
+
+  (let ((start-time (get-time-of-day)))
+    (let loop ((count 1))
+      (sdl-add-absolute-timer! (+ start-time (* count *invocation-count-update-interval*))
+			       (lambda ()
+				 (decay-invocation-counts!)
+				 (loop (+ count 1))))))
+
+  (do ()
+      ((metalevel-stopped?))
+    (let ((event (make-sdl-event)))
+      (sdl-wait-event!* check-socket-set/delay event)
+      (metalevel-spawn *nil* (lambda () (send handle event)))))
+
+  (sdl-net-quit)
+  (ttf-quit)
+  (sdl-quit))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/util.scm	Thu Mar 31 01:25:02 2005 +1200
@@ -0,0 +1,86 @@
+(define *debug-level* 0)
+(define *debug-indent* 0)
+
+(define (external-representation o)
+  (let ((p (open-output-string)))
+    (write o p)
+    (get-output-string p)))
+
+(define (fold-left/index fn acc lis)
+  (let loop ((index 0)
+	     (lis lis)
+	     (acc acc))
+    (if (null? lis)
+	acc
+	(loop (+ index 1)
+	      (cdr lis)
+	      (fn index (car lis) acc)))))
+
+(define (for-each/index fn lis)
+  (let loop ((index 0)
+	     (lis lis))
+    (unless (null? lis)
+      (fn index (car lis))
+      (loop (+ index 1) (cdr lis)))))
+
+(define (describe-object o . pretty)
+  (let ((description (map (lambda (entry)
+			    (let ((key (car entry))
+				  (val (cdr entry)))
+			      (list (slot-name val)
+				    (slot-index val)
+				    (slot-delegating? val)
+				    (slot-kind val)
+				    (map (lambda (role)
+					   (list (role-positions role)
+						 (role-requirements role)
+						 (role-method role)))
+					 (slot-roles val)))))
+			  (hash-table->list (object-layout o)))))
+    (if (or (null? pretty) (car pretty))
+	(pretty-print description))
+    description))
+
+(define (send/previous-method/missing-handler previous-method missing-handler selector argv)
+  (let* ((method (dispatch previous-method selector argv)))
+    (debug 2 --> 0 "Dispatching to method "method)
+    (if method
+	(let ((code (get-slot method 'code)))
+	  (if (procedure? code)
+	      (apply code method (vector->list argv))
+	      (metalevel-eval-method code method argv)))
+	(missing-handler argv))))
+
+(define (send/previous-method previous-method selector argv)
+  (send/previous-method/missing-handler previous-method
+					(lambda (argv)
+					  (send/previous-method/missing-handler
+					   #f
+					   (lambda (inner-argv)
+					     (error "Dispatch failed"
+						    `(send ,selector ,@(vector->list argv))))
+					   'notFoundOn:
+					   (vector selector argv)))
+					selector
+					argv))
+
+(define (run-hooks! hooklist)
+  (for-each (lambda (hook) (hook)) (reverse hooklist)))
+
+(define (curry f . vs)
+  (lambda rest
+    (apply f (append vs rest))))
+
+(define (non-*false*? x)
+  (if (eq? x *false*)
+      #f
+      x))
+
+(define (*false*? x)
+  (eq? x *false*))
+
+(define (vector-fold fn seed v)
+  (let ((len (vector-length v)))
+    (do ((i 0 (+ i 1))
+	 (seed seed (fn (vector-ref v i) seed)))
+	((= i len) seed))))