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