During the darcs->hg conversion, some "darcs mv" were turned into "hg rm"!
This commit restores the files that were wrongly deleted.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/etng-r1/old/parse-etng.scm Mon Jan 19 06:06:28 2009 +0000
@@ -0,0 +1,310 @@
+(define parse-etng
+ (let* ((nonquote (lambda (ch) (not (eqv? ch #\"))))
+ (non-string-quote (lambda (ch) (not (eqv? ch #\'))))
+
+ (stream-ns-uri "http://eighty-twenty.org/etng/r1/ns/stream")
+ (string-ns-uri "http://eighty-twenty.org/etng/r1/ns/string")
+
+ (stream-cons-name (make-qname stream-ns-uri 'cons))
+ (stream-cons-ref (make-node 'core-ref 'name stream-cons-name))
+ (stream-nil-name (make-qname stream-ns-uri 'nil))
+ (stream-nil-ref (make-node 'core-ref 'name stream-nil-name))
+ (expand-stream
+ (lambda (prefix suffix)
+ (fold-right (lambda (p acc)
+ (make-node 'core-send
+ 'receiver stream-cons-ref
+ 'message (make-node 'core-tuple
+ 'elements (list p acc))))
+ (or suffix stream-nil-ref)
+ prefix)))
+
+ (stream-next-name (make-qname stream-ns-uri 'next))
+ (stream-next-lit (make-node 'pat-lit 'value stream-next-name))
+ (stream-empty-name (make-qname stream-ns-uri 'empty))
+ (stream-empty-message
+ (make-node 'pat-message
+ 'parts (list (make-node 'pat-lit 'value stream-empty-name))))
+ (expand-stream-pattern
+ (lambda (prefix suffix)
+ (fold-right (lambda (p acc)
+ (make-node 'pat-message
+ 'parts (list stream-next-lit
+ (make-node 'pat-tuple
+ 'elements (list p acc)))))
+ (or suffix stream-empty-message)
+ prefix)))
+
+ (string->u8vector/utf-8
+ (lambda (str)
+ (list->u8vector (bytes->list (string->bytes/utf-8 str)))))
+
+ (string-stream-name (make-qname string-ns-uri 'stream))
+ (string-stream-ref (make-node 'core-ref 'name string-stream-name))
+ (stream-over-string
+ (lambda (str)
+ (let ((bytes (string->u8vector/utf-8 str)))
+ (make-node 'core-send
+ 'receiver string-stream-ref
+ 'message (make-node 'core-lit 'value bytes)))))
+
+ (parser
+ (packrat-parse
+ `(
+
+ (toplevel (ws semis (m <- command semis)+ #f ,(packrat-lambda (m) m)))
+ (toplevel1 (ws semis m <- command #\; ,(packrat-lambda (m) m)))
+
+ (command (/ (def <- namespace-declaration
+ ,(packrat-lambda (def)
+ (make-node 'command-define-namespace
+ 'prefix (car def)
+ 'uri (cdr def))))
+ (DEFINE p <- tuple-pattern EQ e <- expr
+ ,(packrat-lambda (p e)
+ (make-node 'command-define-values
+ 'pattern p
+ 'value e)))
+ (DEFINE n <- qname (args <- pattern)* EQ e <- expr
+ ,(packrat-lambda (n args e)
+ (make-node 'command-define-object
+ 'name n
+ 'args args
+ 'body e)))
+ (e <- expr
+ ,(packrat-lambda (e)
+ (make-node 'command-exp
+ 'value e)))))
+
+ (namespace-declaration (NAMESPACE prefix <- id EQ uri <- string
+ ,(packrat-lambda (prefix uri)
+ (cons prefix uri))))
+
+ (expr (/ sequence
+ tuple-value))
+
+ (tuple-value (es <- comma-separated-exprs
+ ,(packrat-lambda (es)
+ (if (and (pair? es)
+ (null? (cdr es)))
+ (car es)
+ (make-node 'core-tuple 'elements es)))))
+
+ (comma-separated-exprs (/ (e <- send (#\, ws es <- send)*
+ ,(packrat-lambda (e es) (cons e es)))
+ ,(packrat-lambda () '())))
+
+ (send ((e <- simple-expr)+ ,(packrat-lambda (e)
+ (fold (lambda (operand operator)
+ (make-node 'core-send
+ 'receiver operator
+ 'message operand))
+ (car e)
+ (cdr e)))))
+
+ (simple-expr (/ object
+ function
+ message
+ stream
+ meta
+ (SELF ,(packrat-lambda () (make-node 'core-self)))
+ (NEXTMETHOD ,(packrat-lambda () (make-node 'core-next-method)))
+ (q <- qname ,(packrat-lambda (q) (make-node 'core-ref 'name q)))
+ (l <- literal ,(packrat-lambda (l) (make-node 'core-lit 'value l)))
+ ;; Bug: no corresponding string pattern-match syntax.
+ (s <- string ,(packrat-lambda (s) (stream-over-string s)))
+ (OPAREN e <- expr CPAREN ,(packrat-lambda (e) e))))
+
+ (literal (/ (#\. ws q <- qname-nooperator ,(packrat-lambda (q) q))
+ (o <- operator ,(packrat-lambda (o) o))
+ (w <- word ,(packrat-lambda (w) w))))
+
+ (object (OBRACK (m <- member)* CBRACK
+ ,(packrat-lambda (m) (make-node 'core-object 'methods m))))
+
+ (function (/ (OBRACE (m <- member)* CBRACE
+ ,(packrat-lambda (m) (make-node 'core-function 'methods m)))
+ (OBRACE e <- expr semis CBRACE
+ ,(packrat-lambda (e)
+ (let ((pat (make-node 'pat-tuple 'elements '())))
+ (make-node 'core-function
+ 'methods (list (make-node 'core-method
+ 'patterns (list pat)
+ 'body e))))))))
+
+ (message (OANGLE (es <- message-component)* CANGLE
+ ,(packrat-lambda (es) (make-node 'core-message 'parts es))))
+
+ (message-component ((! #\>) simple-expr))
+
+ (stream (OBRACK p <- comma-separated-exprs s <- stream-suffix
+ ,(packrat-lambda (p s) (expand-stream p s))))
+
+ (stream-suffix (/ (CBRACK ,(packrat-lambda () #f))
+ (PIPE CBRACK ,(packrat-lambda () #f))
+ (PIPE e <- send CBRACK ,(packrat-lambda (e) e))))
+
+ (meta (META s <- sexp ,(packrat-lambda (s) (make-node 'core-meta 'sexp s))))
+
+ (member (/ constant-member
+ method-member))
+
+ (constant-member (ps <- patterns EQ e <- expr semis
+ ,(packrat-lambda (ps e) (make-node 'core-constant
+ 'patterns ps 'body e))))
+ (method-member (ps <- patterns ARROW e <- expr semis
+ ,(packrat-lambda (ps e) (make-node 'core-method
+ 'patterns ps 'body e))))
+
+ (sequence (/ (def <- namespace-declaration semis e <- expr
+ ,(packrat-lambda (def)
+ (make-node 'core-namespace
+ 'prefix (car def)
+ 'uri (cdr def)
+ 'value e)))
+ (LET p <- tuple-pattern EQ e <- expr semis b <- expr
+ ,(packrat-lambda (p e b)
+ (make-node 'core-let
+ 'pattern p
+ 'value e
+ 'body b)))
+ (DO head <- expr semis tail <- expr
+ ,(packrat-lambda (head tail)
+ (make-node 'core-do
+ 'head head
+ 'tail tail)))))
+
+ (patterns (/ ((ps <- pattern)* (! #\,) ,(packrat-lambda (ps) ps))
+ (p <- tuple-pattern ,(packrat-lambda (p) (list p)))))
+
+ (pattern (/ (p1 <- simple-pattern HASH p2 <- pattern
+ ,(packrat-lambda (p1 p2) (make-node 'pat-and 'left p1 'right p2)))
+ simple-pattern))
+
+ (simple-pattern (/ message-pattern
+ stream-pattern
+ (#\_ ws ,(packrat-lambda () (make-node 'pat-discard)))
+ (l <- literal ,(packrat-lambda (l) (make-node 'pat-lit 'value l)))
+ (q <- qname ,(packrat-lambda (q) (make-node 'pat-binding 'name q)))
+ (OPAREN p <- tuple-pattern CPAREN ,(packrat-lambda (p) p))))
+
+ (tuple-pattern (ps <- comma-separated-patterns
+ ,(packrat-lambda (ps)
+ (if (and (pair? ps)
+ (null? (cdr ps)))
+ (car ps)
+ (make-node 'pat-tuple 'elements ps)))))
+
+ (message-pattern (OANGLE (ps <- message-pattern-component)* CANGLE
+ ,(packrat-lambda (ps) (make-node 'pat-message 'parts ps))))
+
+ (message-pattern-component ((! #\>) pattern))
+
+ (stream-pattern (OBRACK p <- comma-separated-patterns s <- stream-pattern-suffix
+ ,(packrat-lambda (p s) (expand-stream-pattern p s))))
+
+ (stream-pattern-suffix (/ (CBRACK ,(packrat-lambda () #f))
+ (PIPE CBRACK ,(packrat-lambda () #f))
+ (PIPE p <- pattern CBRACK ,(packrat-lambda (p) p))))
+
+ (comma-separated-patterns (/ (p <- pattern (#\, ws ps <- pattern)*
+ ,(packrat-lambda (p ps) (cons p ps)))
+ ,(packrat-lambda () '())))
+
+ (sexp (/ (#\. ws s <- sexp ,(packrat-lambda (s) (list 'quote s)))
+ id
+ literal
+ string
+ (OPAREN (s <- sexp)* CPAREN ,(packrat-lambda (s) s))))
+
+ ;;---------------------------------------------------------------------------
+
+ (semis (SEMI *))
+
+ (qname (/ qname-nooperator
+ (OPARENnows o <- operator CPAREN ,(packrat-lambda (o)
+ (make-qname #f o)))))
+
+ (qname-nooperator
+ (/ (prefix <- id #\: localname <- id
+ ,(packrat-lambda (prefix localname)
+ (make-qname prefix localname)))
+ (uri <- string #\: localname <- id
+ ,(packrat-lambda (uri localname)
+ (make-qname uri localname)))
+ (#\: localname <- id
+ ,(packrat-lambda (localname)
+ (make-qname (string->symbol "") localname)))
+ (localname <- id
+ ,(packrat-lambda (localname)
+ (make-qname #f localname)))))
+
+ (id ((! #\_) (a <- id-alpha) (r <- (/ id-alpha digit))* ws
+ ,(packrat-lambda (a r) (string->symbol (list->string (cons a r))))))
+
+ (string (#\' (cs <- (/: ,non-string-quote "string character"))* #\' ws
+ ,(packrat-lambda (cs) (list->string cs))))
+
+ (operator ((! reserved-operator)
+ a <- op-punct-init (r <- (/ op-punct digit alpha))* ws
+ ,(packrat-lambda (a r) (string->symbol (list->string (cons a r))))))
+
+ (word (/ positive-word
+ (#\- ws w <- positive-word ,(packrat-lambda (w) (- w)))))
+ (positive-word ((d <- digit)+ ws
+ ,(packrat-lambda (d) (string->number (list->string d)))))
+
+ (id-alpha (/ alpha #\_ #\$))
+ (op-punct (/: "!%&*+/<=>?@\\^-~#:|"))
+ (op-punct-init (/: "!%&*+/<=>?@\\^-~"))
+
+ (ws (/ ((/: ,char-whitespace? "whitespace")+ ws)
+ (#\" (/: ,nonquote "comment character")* #\" ws)
+ ()))
+ (digit (/: ,char-numeric? "digit"))
+ (alpha (/: ,char-alphabetic? "letter"))
+
+ (reserved-operator (/ ARROW
+ COLONEQ
+ EQ
+ HASH
+ PIPE))
+
+ (ARROW ("->" (! op-punct) ws))
+ (COLONEQ (":=" (! op-punct) ws))
+ (EQ (#\= (! op-punct) ws))
+ (HASH (#\# (! op-punct) ws))
+
+ (SEMI (#\; ws))
+ (OPAREN (OPARENnows ws))
+ (OPARENnows #\()
+ (CPAREN (#\) ws))
+ (OBRACK (#\[ ws))
+ (CBRACK (#\] ws))
+ (OANGLE (#\< ws))
+ (CANGLE (#\> ws))
+ (OBRACE (#\{ ws))
+ (CBRACE (#\} ws))
+ (PIPE (#\| ws))
+
+ (DEFINE ("define"ws))
+ (NAMESPACE ("namespace"ws))
+ (SELF ("self"ws))
+ (NEXTMETHOD ("nextMethod"ws))
+ (LET ("let"ws))
+ (DO ("do"ws))
+ (META ("meta"ws))
+
+ ))))
+ (lambda (results k-ok k-fail)
+ (try-packrat-parse-pattern
+ (parser 'toplevel1) '() results
+ (lambda (bindings result) (k-ok (parse-result-semantic-value result)
+ (parse-result-next result)))
+ (lambda (err) (k-fail (list (parse-position->string (parse-error-position err))
+ (parse-error-expected err)
+ (parse-error-messages err))))))))
+
+;;; Local Variables:
+;;; eval: (put 'packrat-lambda 'scheme-indent-function 1)
+;;; End:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/r1/Makefile Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/README Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/boot.thing Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/compile.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/image.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/interp.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/kernel-methods.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/kernel.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/macros.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/oo.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/parsetng.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/root-hooks.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/scratch Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/sdl-events.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/test.thing Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/tng.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/ui.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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/r1/util.scm Mon Jan 19 06:06:28 2009 +0000
@@ -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))))