Tuples

fn/curry.fn

@@ -1,5 +1,5 @@
 let
     fn add3(a, b, c) { a + b + c }
 in
-    add3(1)(2)(3)
+    print(add3(1)(2)(3))
 

fn/liars.fn

@@ -27,6 +27,41 @@ let
         }
     }
 
+    fn sortBy(predicate, lst) {
+        let
+            fn full_sort {
+                ([]) { [] }
+                (first @ rest) {
+                    partition(first, rest, fn (lesser, greater) {
+                        partial_sort(lesser, first @ full_sort(greater))
+                    })
+                }
+            }
+            fn partial_sort {
+                (first @ rest, already_sorted) {
+                    partition(first, rest, fn (lesser, greater) {
+                        partial_sort(lesser, first @ partial_sort(greater, already_sorted))
+                    })
+                }
+                ([], sorted) { sorted }
+            }
+            fn partition(key, lst, kont) {
+                let fn helper {
+                    ([], lesser, greater) { kont(lesser, greater) }
+                    (first @ rest, lesser, greater) {
+                        if (predicate(key, first) == lt) {
+                            helper(rest, lesser, first @ greater)
+                        } else {
+                            helper(rest, first @ lesser, greater)
+                        }
+                    }
+                }
+                in helper(lst, [], [])
+            }
+        in
+            full_sort(lst)
+    }
+
     fn liars() {
         let
             ranks = [1, 2, 3, 4, 5];
@@ -41,7 +76,16 @@ let
             require((joan == 3) xor (ethel == 5));
             require((kitty == 2) xor (mary == 4));
             require((mary == 4) xor (betty == 1));
-            [betty, ethel, joan, kitty, mary]
+            sortBy(
+                fn (#(_, a), #(_, b)) { a <=> b },
+                [
+                    #("Betty", betty),
+                    #("Ethel", ethel),
+                    #("Joan", joan),
+                    #("Kitty", kitty),
+                    #("Mary", mary)
+                ]
+            )
     }
 in
     print(liars())

fn/listutils.fn

@@ -146,7 +146,7 @@ let
         }
     }
 
-    fn sort(lst) {
+    fn sortBy(predicate, lst) {
         let
             fn full_sort {
                 ([]) { [] }
@@ -168,7 +168,7 @@ let
                 let fn helper {
                     ([], lesser, greater) { kont(lesser, greater) }
                     (first @ rest, lesser, greater) {
-                        if (key < first) {
+                        if (predicate(key, first) == lt) {
                             helper(rest, lesser, first @ greater)
                         } else {
                             helper(rest, first @ lesser, greater)
@@ -181,5 +181,7 @@ let
             full_sort(lst)
     }
 
+    sort = sortBy(fn (a, b) { a <=> b });
+
 in
     print(concat(take(3, ["well", " ", "hi", " ", "there"])))

fn/triple.fn

@@ -0,0 +1,8 @@
+let
+    typedef T(#a, #b, #c) { triple(#a, #b, #c) }
+    fn testTriple {
+        (triple(1, c, d)) { c * d }
+        (triple(2, c, d)) { c + d }
+    }
+in
+    true

fn/tuple.fn

@@ -0,0 +1,7 @@
+let
+    fn testTuple {
+        (#(1, c, d)) { #(c, d, 'h', c * d) }
+        (#(2, c, d)) { #(c, d, 'h', c + d) }
+    }
+in
+    print(testTuple(#(1, 2, 3)))

fn/tuple2.fn

@@ -0,0 +1 @@
+print(#(1, 2, 3))

src/anf_normalize.c

@@ -87,6 +87,8 @@ static CexpCondCases *normalizeCondCases(LamCondCases *cases);
 static CexpLetRec *replaceCexpLetRec(CexpLetRec *cexpLetRec,
                                      LamLetRecBindings *lamLetRecBindings);
 static Exp *normalizeConstruct(LamConstruct *construct, Exp *tail);
+static Exp *normalizeMakeTuple(LamList *tuple, Exp *tail);
+static Exp *normalizeTupleIndex(LamTupleIndex *construct, Exp *tail);
 static Exp *normalizeDeconstruct(LamDeconstruct *deconstruct, Exp *tail);
 static Exp *normalizeTag(LamExp *tag, Exp *tail);
 
@@ -132,6 +134,8 @@ static Exp *normalize(LamExp *lamExp, Exp *tail) {
             return normalizePrint(lamExp->val.print, tail);
         case LAMEXP_TYPE_LETREC:
             return normalizeLetRec(lamExp->val.letrec, tail);
+        case LAMEXP_TYPE_TUPLE_INDEX:
+            return normalizeTupleIndex(lamExp->val.tuple_index, tail);
         case LAMEXP_TYPE_DECONSTRUCT:
             return normalizeDeconstruct(lamExp->val.deconstruct, tail);
         case LAMEXP_TYPE_CONSTRUCT:
@@ -152,10 +156,12 @@ static Exp *normalize(LamExp *lamExp, Exp *tail) {
             return normalizeBack(tail);
         case LAMEXP_TYPE_ERROR:
             return normalizeError(tail);
+        case LAMEXP_TYPE_MAKE_TUPLE:
+            return normalizeMakeTuple(lamExp->val.make_tuple, tail);
         case LAMEXP_TYPE_COND_DEFAULT:
             cant_happen("normalize encountered cond default");
         default:
-            cant_happen("unrecognized type %d in normalize", lamExp->type);
+            cant_happen("unrecognized type %s", lamExpTypeName(lamExp->type));
     }
     LEAVE(normalize);
 }
@@ -274,6 +280,27 @@ static Exp *normalizeDeconstruct(LamDeconstruct *deconstruct, Exp *tail) {
     return res;
 }
 
+static LamPrimApp *tupleIndexToPrimApp(LamTupleIndex *tupleIndex) {
+    LamExp *index =
+        newLamExp(LAMEXP_TYPE_STDINT, LAMEXP_VAL_STDINT(tupleIndex->vec));
+    int save = PROTECT(index);
+    LamPrimApp *res =
+        newLamPrimApp(LAMPRIMOP_TYPE_VEC, index, tupleIndex->exp);
+    UNPROTECT(save);
+    return res;
+}
+
+static Exp *normalizeTupleIndex(LamTupleIndex *index, Exp *tail) {
+    ENTER(noramaalizeTupleIndex);
+    LamPrimApp *primApp = tupleIndexToPrimApp(index);
+    int save = PROTECT(primApp);
+    Exp *res = normalizePrim(primApp, tail);
+    UNPROTECT(save);
+    LEAVE(noramaalizeTupleIndex);
+    return res;
+}
+
+
 static Exp *normalizeTag(LamExp *tagged, Exp *tail) {
     ENTER(noramaalizeTag);
     LamPrimApp *primApp = tagToPrimApp(tagged);
@@ -414,10 +441,7 @@ static Exp *normalizeMakeVec(LamMakeVec *lamMakeVec, Exp *tail) {
 }
 
 static LamMakeVec *constructToMakeVec(LamConstruct *construct) {
-    int nargs = 0;
-    for (LamList *args = construct->args; args != NULL; args = args->next) {
-        nargs++;
-    }
+    int nargs = countLamList(construct->args);
     LamExp *newArg =
         newLamExp(LAMEXP_TYPE_STDINT, LAMEXP_VAL_STDINT(construct->tag));
     int save = PROTECT(newArg);
@@ -428,6 +452,12 @@ static LamMakeVec *constructToMakeVec(LamConstruct *construct) {
     return res;
 }
 
+static LamMakeVec *tupleToMakeVec(LamList *tuple) {
+    int nargs = countLamList(tuple);
+    LamMakeVec *res = newLamMakeVec(nargs, tuple);
+    return res;
+}
+
 static Exp *normalizeConstruct(LamConstruct *construct, Exp *tail) {
     ENTER(normalizeConstruct);
     LamMakeVec *makeVec = constructToMakeVec(construct);
@@ -438,6 +468,14 @@ static Exp *normalizeConstruct(LamConstruct *construct, Exp *tail) {
     return res;
 }
 
+static Exp *normalizeMakeTuple(LamList *tuple, Exp *tail) {
+    LamMakeVec *makeVec = tupleToMakeVec(tuple);
+    int save = PROTECT(makeVec);
+    Exp *res = normalizeMakeVec(makeVec, tail);
+    UNPROTECT(save);
+    return res;
+}
+
 // sequences are not covered by the algorithm
 // however the algorithm states that "All non-atomic
 // (complex) expressions must be let-bound or appear
@@ -912,13 +950,13 @@ static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements) {
         case LAMEXP_TYPE_AND:
         case LAMEXP_TYPE_OR:
         case LAMEXP_TYPE_AMB:
+        case LAMEXP_TYPE_MAKE_TUPLE:
             res = replaceLamCexp(lamExp, replacements);
             break;
         case LAMEXP_TYPE_COND_DEFAULT:
             cant_happen("replaceLamExp encountered cond default");
         default:
-            cant_happen("unrecognised type %d in replaceLamExp",
-                        lamExp->type);
+            cant_happen("unrecognised type %s", lamExpTypeName(lamExp->type));
     }
     LEAVE(replaceLamExp);
     return res;

src/anf_pp.c

@@ -45,6 +45,22 @@ void ppAexpVarList(AexpVarList *x) {
     eprintf(")");
 }
 
+static void ppChar(char c) {
+    switch(c) {
+        case '\n':
+            eprintf("\"\\n\"");
+            break;
+        case '\t':
+            eprintf("\"\\t\"");
+            break;
+        case '\"':
+            eprintf("\"\\\"\"");
+            break;
+        default:
+            eprintf("\"%c\"", c);
+    }
+}
+
 void ppAexpVar(HashSymbol *x) {
     eprintf("%s", x->name);
 }
@@ -99,8 +115,11 @@ void ppAexpPrimApp(AexpPrimApp *x) {
         case AEXPPRIMOP_TYPE_MOD:
             eprintf("mod ");
             break;
+        case AEXPPRIMOP_TYPE_CMP:
+            eprintf("cmp ");
+            break;
         default:
-            cant_happen("unrecognized op in ppAexpPrimApp (%d)", x->type);
+            cant_happen("unrecognized op %s", aexpPrimOpName(x->type));
     }
     ppAexp(x->exp1);
     if (x->exp2 != NULL) {
@@ -228,7 +247,9 @@ void ppCexpIntCondCases(CexpIntCondCases *x) {
 
 void ppCexpCharCondCases(CexpCharCondCases *x) {
     while (x != NULL) {
-        eprintf("('%c' ", x->option);
+        eprintf("(");
+        ppChar(x->option);
+        eprintf(" ");
         ppExp(x->body);
         eprintf(")");
         if (x->next) {
@@ -357,7 +378,7 @@ void ppAexp(Aexp *x) {
             eprintf("%d", x->val.littleinteger);
             break;
         case AEXP_TYPE_CHARACTER:
-            eprintf("'%c'", x->val.character);
+            ppChar(x->val.character);
             break;
         case AEXP_TYPE_PRIM:
             ppAexpPrimApp(x->val.prim);

src/ast.yaml

@@ -148,6 +148,7 @@ unions:
         unpack: AstUnpack
         number: BigInt
         character: char
+        tuple: AstArgList
 
     AstExpression:
         back: void_ptr
@@ -160,6 +161,7 @@ unions:
         nest: AstNest
         iff: AstIff
         print: AstPrint
+        tuple: AstExpressions
 
 arrays:
     AstCharArray:

src/cekf.h

@@ -107,6 +107,8 @@ void setFrame(Stack *stack, int nargs);
 void clearFrame(Stack *stack);
 void copyTosToEnv(Stack *s, Env *e, int n);
 void copyValues(Value *to, Value *from, int size);
+// safe version of copyValues:
+void moveValues(Value *to, Value *from, int size);
 
 extern Snapshot noSnapshot;
 
@@ -135,5 +137,6 @@ void markEnv(Env *x);
 void markKont(Kont *x);
 void markFail(Fail *x);
 void markVec(Vec *x);
+void dumpStack(Stack *stack);
 
 #endif

src/common.h

@@ -25,34 +25,35 @@
 #  define DEBUG_ANY
 
 #  ifdef DEBUG_ANY
-// #define DEBUG_STACK
-// #define DEBUG_STEP
+// #    define DEBUG_STACK
+// #    define DEBUG_STEP
 // if DEBUG_STEP is defined, this sleeps for 1 second between each machine step
-// #define DEBUG_SLOW_STEP
+// #    define DEBUG_SLOW_STEP
 // define this to cause a GC at every malloc (catches memory leaks early)
 #    define DEBUG_STRESS_GC
-// #define DEBUG_LOG_GC
-// #define DEBUG_GC
+// #    define DEBUG_LOG_GC
+// #    define DEBUG_GC
 // #    define DEBUG_TPMC_MATCH
 // #    define DEBUG_TPMC_TRANSLATE
 // #    define DEBUG_TPMC_LOGIC
-// #define DEBUG_ANNOTATE
-// #define DEBUG_DESUGARING
-// #define DEBUG_HASHTABLE
-// #define DEBUG_TIN_SUBSTITUTION
-// #define DEBUG_TIN_INSTANTIATION
-// #define DEBUG_TIN_UNIFICATION
-// #define DEBUG_BYTECODE
+// #    define DEBUG_TPMC_COMPARE
+// #    define DEBUG_ANNOTATE
+// #    define DEBUG_DESUGARING
+// #    define DEBUG_HASHTABLE
+// #    define DEBUG_TIN_SUBSTITUTION
+// #    define DEBUG_TIN_INSTANTIATION
+// #    define DEBUG_TIN_UNIFICATION
+// #    define DEBUG_BYTECODE
 // define this to make fatal errors dump core (if ulimit allows)
 #    define DEBUG_DUMP_CORE
 // #    define DEBUG_TC
 // #    define DEBUG_LAMBDA_CONVERT
-// #define DEBUG_LAMBDA_SUBSTITUTE
-// #define DEBUG_LEAK
-// #define DEBUG_ANF
-// #define DEBUG_ALLOC
-// #define DEBUG_PRINT_GENERATOR
-// #define DEBUG_PRINT_COMPILER
+// #    define DEBUG_LAMBDA_SUBSTITUTE
+// #    define DEBUG_LEAK
+// #    define DEBUG_ANF
+// #    define DEBUG_ALLOC
+// #    define DEBUG_PRINT_GENERATOR
+// #    define DEBUG_PRINT_COMPILER
 // define this to turn on additional safety checks for things that shouldn't but just possibly might happen
 #    define SAFETY_CHECKS
 #  endif