smalltalk-tng

view etng-r2/boot.tng-modules @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents
children
line source
1 define Continuation platform ->
2 rec Continuation {
3 .raw_callcc fn ->
4 '%assemble' (fn = fn) { .scheme -> ('call-with-current-continuation'
5 (lambda (k) ('etng-send' fn (list k)))) };
6
7 .callcc fn ->
8 Continuation.raw_callcc { k -> fn {v -> '%assemble' (v = v, k = k) { .scheme -> (k v) } } };
9 }
10 };
11
12 define extends platform extension base ->
13 '%assemble' (extension = extension, base = base) {
14 .scheme -> ('etng-merge-functions' extension base);
15 };
16
17 define as platform receiver via message ->
18 '%assemble' (receiver = receiver, via = via, message = message) {
19 -- FIXME: need some form of apply here, now we are n-ary instead of unary!
20 .scheme -> ('etng-send*' receiver via (list message))
21 };
22
23 define :booleanBehaviour = rec {
24 .not -> '%assemble' (x = self) { .scheme -> (not x) };
25 };
26
27 define :falseProxy = :booleanBehaviour |extends {v -> v.:false};
28 define :trueProxy = :booleanBehaviour |extends {v -> v.:true};
29
30 define case x options -> options x;
31
32 define < = .<;
33 define > = .>;
34
35 define :symbolProxy = rec {
36 msg -> case self {
37 .< -> :messageAccumulator {receiver -> receiver} msg;
38 _ -> error("Cannot send message to symbol", msg);
39 };
40 };
41
42 define :messageAccumulator firstSender -> {
43 .> receiver -> firstSender receiver;
44 secondMsg -> :messageAccumulator {receiver -> firstSender receiver secondMsg};
45 };
46
47 define <> = < >;
48
49 define false = '%assemble' () { .scheme -> (not (quote nonfalse)) };
50 define true = false.not;
51
52 define + = .+;
53 define * = .*;
54 define == = .==;
55
56 define eq x y -> '%assemble' (x = x, y = y) { .scheme -> ('eq?' x y) };
57
58 define write x -> '%assemble' (x = x) { .scheme -> (begin (write x) (newline)) };
59
60 define :eq = rec {
61 .== other -> '%assemble' (a = self, b = other) { .scheme -> ('eqv?' a b) };
62 };
63
64 define :numberProxy = rec {
65 .+ other -> '%assemble' (a = self, b = other) { .scheme -> (+ a b) };
66 .* other -> '%assemble' (a = self, b = other) { .scheme -> (* a b) };
67 .< other -> '%assemble' (a = self, b = other) { .scheme -> (< a b) };
68 };
69
70 define s:empty = { .s:case v -> v.s:empty };
71 define s:cons(head, tail) -> { .s:case v -> v.s:next(head, tail) };
72
73 define :tupleProxy = rec {
74 .length -> '%assemble' (v = self) { .scheme -> ('vector-length' v) };
75 .get(n) -> '%assemble' (v = self, n = n) { .scheme -> ('vector-ref' v n) };
76 .s:case v -> :tupleIterator(self, 0).s:case v;
77 };
78
79 define :tupleIterator(tuple, index) ->
80 (index < (tuple.length)) {
81 .:true -> {.s:case v -> v.s:next(tuple.get(index), :tupleIterator(tuple, index + 1))};
82 .:false -> {.s:case v -> v.s:empty};
83 };
84
85 define s:do stream fn ->
86 stream .s:case {
87 .s:empty -> .ok;
88 .s:next(head, tail) -> do fn(head); s:do tail fn;
89 };
90
91 define s:foldl stream knil kons ->
92 stream .s:case {
93 .s:empty -> knil;
94 .s:next(head, tail) -> s:foldl tail (kons(head, knil)) kons;
95 };
96
97 define s:foldr stream knil kons ->
98 stream .s:case {
99 .s:empty -> knil;
100 .s:next(head, tail) -> kons(head, s:foldr tail knil kons);
101 };
102
103 define s:reverse stream -> s:foldl stream s:empty s:cons;
104 define s:append s1 s2 -> s:foldr s1 s2 s:cons;
105
106 define s:foldlK stream knil kons k ->
107 stream .s:case {
108 .s:empty -> k(knil);
109 .s:next(head, tail) -> kons (head, knil) {newSeed -> s:foldlK tail newSeed kons k};
110 };
111
112 define s:foldrK stream knil kons k ->
113 stream .s:case {
114 .s:empty -> k(knil);
115 .s:next(head, tail) -> s:foldrK tail knil kons {newSeed -> kons (head, newSeed) k};
116 };
117
118 define s:concatenate stream -> s:foldr stream s:empty s:append;
119
120 define s:map stream fn -> s:foldr stream s:empty {elt, acc -> s:cons(fn(elt), acc)};
121
122 -- s:map (1, 2, 3) {x -> x};
123 -- (1, 2, 3) | s:foldr s:empty s:cons | s:do write;
124 -- (1, 2) | s:append (3, 4) | s:do write;
125 -- (| s:append (3, 4) | s:do write) (1, 2);
126
127 -- define xyz = { .x .y .z -> .w ;
128 -- .x .y .w -> .a ;
129 -- .x .a .z -> 345 };
130 -- define xx = xyz.x;
131 -- define xy = xx.y;
132 -- xx (xy (xy.z)) .z;