Identifier namespaces, and some interesting code for boot.tng.
--- a/etng-r2/boot.tng Sun Jan 18 11:21:10 2009 +0000
+++ b/etng-r2/boot.tng Sun Jan 18 11:22:02 2009 +0000
@@ -1,5 +1,111 @@
+namespace s = "http://eighty-twenty.org/etng/r1/ns/stream#";
+
+define raw_callcc fn ->
+ '%assemble' (fn = fn) { .scheme -> ('call-with-current-continuation'
+ (lambda (k) ('etng-send' fn k))) };
+define callcc fn ->
+ raw_callcc { k -> fn {v -> '%assemble' (v = v, k = k) { .scheme -> (k v) } } };
+
+define extend1 base extension ->
+ '%assemble' (base = base, extension = extension) {
+ .scheme -> ('etng-merge-functions' extension base);
+ };
+
+define :booleanBehaviour = [
+ .not -> '%assemble' (x = self) { .scheme -> (not x) };
+];
+
+define :falseProxy = extend1 [v -> v.:false] :booleanBehaviour;
+define :trueProxy = extend1 [v -> v.:true] :booleanBehaviour;
+
+define < = .<;
+define > = .>;
+
+define :symbolProxy = [
+ msg -> case self {
+ .< -> :messageAccumulator {receiver -> receiver msg};
+ _ -> error("Cannot send message to symbol", msg);
+ };
+];
+
+define :messageAccumulator firstSender -> [
+ .> receiver -> firstSender receiver;
+ secondMsg -> :messageAccumulator {receiver -> firstSender receiver secondMsg};
+];
+
+define false = '%assemble' () { .scheme -> (not (quote nonfalse)) };
+define true = false.not;
+
define + = .+;
+define * = .*;
+define == = .==;
+
+define eq x y -> '%assemble' (x = x, y = y) { .scheme -> ('eq?' x y) };
+
+define write x -> '%assemble' (x = x) { .scheme -> (begin (write x) (newline)) };
+
+define :eq = [
+ .== other -> '%assemble' (a = self, b = other) { .scheme -> ('eqv?' a b) };
+];
+
+define case x options -> options x;
-define numberProxy = [
+define :numberProxy = [
.+ other -> '%assemble' (a = self, b = other) { .scheme -> (+ a b) };
+ .* other -> '%assemble' (a = self, b = other) { .scheme -> (* a b) };
+ .< other -> '%assemble' (a = self, b = other) { .scheme -> (< a b) };
];
+
+define s:empty = [ .s:case v -> v.s:empty ];
+define s:cons(head, tail) -> [ .s:case v -> v.s:next(head, tail) ];
+
+define :tupleProxy = [
+ .length -> '%assemble' (v = self) { .scheme -> ('vector-length' v) };
+ .get(n) -> '%assemble' (v = self, n = n) { .scheme -> ('vector-ref' v n) };
+ .s:case v -> :tupleIterator(self, 0).s:case v;
+];
+
+define :tupleIterator(tuple, index) ->
+ (index < (tuple.length)) {
+ .:true -> [.s:case v -> v.s:next(tuple.get(index), :tupleIterator(tuple, index + 1))];
+ .:false -> [.s:case v -> v.s:empty];
+ };
+
+define s:do stream fn ->
+ stream .s:case {
+ .s:empty -> .ok;
+ .s:next(head, tail) -> do fn(head); s:do tail fn;
+ };
+
+define s:foldl stream knil kons ->
+ stream .s:case {
+ .s:empty -> knil;
+ .s:next(head, tail) -> s:foldl tail (kons(head, knil)) kons;
+ };
+
+define s:foldr stream knil kons ->
+ stream .s:case {
+ .s:empty -> knil;
+ .s:next(head, tail) -> kons(head, s:foldr tail knil kons);
+ };
+
+define s:reverse stream -> s:foldl (s:cons, s:empty) stream;
+define s:append(s1, s2) -> s:foldr (s:cons, s2) s1;
+
+define s:foldlK stream knil kons k ->
+ stream .s:case {
+ .s:empty -> k(knil);
+ .s:next(head, tail) -> kons (head, knil) {newSeed -> s:foldlK tail newSeed kons k};
+ };
+
+define s:foldrK stream knil kons k ->
+ stream .s:case {
+ .s:empty -> k(knil);
+ .s:next(head, tail) -> s:foldr tail knil kons {newSeed -> kons (head, newSeed) k};
+ };
+
+define s:concatenate stream -> s:foldr stream s:empty s:append;
+
+define s:map stream fn -> s:foldr stream s:empty {elt, acc -> s:cons(fn(elt), acc)};
+
+-- s:map (1, 2, 3) {x -> x};
--- a/etng-r2/compile-to-scheme.scm Sun Jan 18 11:21:10 2009 +0000
+++ b/etng-r2/compile-to-scheme.scm Sun Jan 18 11:22:02 2009 +0000
@@ -11,29 +11,63 @@
;---------------------------------------------------------------------------
+(define etng-namespaces '())
+(define implicit-etng-namespace #f)
+
+(define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#")
+
+(define (set-etng-namespace! prefix url)
+ (cond
+ ((assq prefix etng-namespaces) =>
+ (lambda (cell) (set-box! (cdr cell) url)))
+ (else
+ (set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces)))))
+
+(set-etng-namespace! '|| builtin-namespace-url)
+
+(define (mangle-etng-id* url localname)
+ (string->symbol (string-append "etng___" url (symbol->string localname))))
+
(define (mangle-etng-id id)
(cond
- ((qname? id) (error 'implement-qnames-please))
- ((symbol? id) (string->symbol (string-append "etng___" (symbol->string id))))
+ ((qname? id)
+ (cond
+ ((assq (qname-uri id) etng-namespaces) =>
+ (lambda (entry)
+ (mangle-etng-id* (unbox (cdr entry)) (qname-localname id))))
+ (else
+ (error 'unknown-qname-prefix id))))
+ ((symbol? id)
+ (if implicit-etng-namespace
+ (mangle-etng-id* implicit-etng-namespace id)
+ (mangle-etng-id* "" id)))
(else (error 'invalid-etng-id id))))
-(define (etng-send-via-named-proxy receiver name message)
- (etng-send* receiver (namespace-variable-value (mangle-etng-id name)) message))
+(define (etng-send-via-named-proxy receiver localname message)
+ (etng-send* receiver
+ (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
+ message))
+
+(define (etng-lookup receiver via message)
+ (let lookup ((clauses (etng-function-clauses via)))
+ (if (null? clauses)
+ #f
+ ((car clauses) message
+ (lambda (thunk) thunk)
+ (lambda () (lookup (cdr clauses)))))))
(define (etng-send* receiver via message)
(cond
((etng-function? via)
- (let lookup ((clauses (etng-function-clauses via)))
- (if (null? clauses)
- (error 'does-not-understand receiver via message)
- ((car clauses)
- message
- (lambda (thunk)
- (thunk receiver))
- (lambda ()
- (lookup (cdr clauses)))))))
+ (let ((thunk (or (etng-lookup receiver via message)
+ (error 'does-not-understand receiver via message))))
+ (thunk receiver)))
((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
((string? via) (etng-send-via-named-proxy receiver 'stringProxy message))
+ ((symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message))
+ ((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message))
+ ((not via) (etng-send-via-named-proxy receiver 'falseProxy message))
+ ((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message))
(else (error 'illegal-primitive-object receiver via message))))
(define (etng-send receiver message)
@@ -57,6 +91,8 @@
(define (toplevel ast)
(case (car ast)
+ ((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast)))
+ ((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast)))
((define-value) (make-definition (cadr ast) (expr (caddr ast))))
((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast)))))
(else (expr ast))))
@@ -87,7 +123,7 @@
(case (car p)
((discard) on-success)
((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success))
- ((lit) `(if (eqv? ',(cadr p) _arg)
+ ((lit) `(if (equal? ',(cadr p) _arg)
,on-success
,on-failure))
((tuple) `(if (and (vector? _arg)