1 files changed, 86 insertions, 0 deletions
diff --git a/runtime/tuple-prims.scm b/runtime/tuple-prims.scm
new file mode 100644
index 0000000..6eb0cbf
--- /dev/null
+++ b/runtime/tuple-prims.scm
@@ -0,0 +1,86 @@
+;; these primitives support arbitrary sized tuples.
+
+(define (prim.tupleSize x)
+  (vector-length x))
+
+(define (prim.tupleSel tuple i n)
+ (force
+  (if (eqv? n 2)
+      (if (eqv? i 0)
+	  (car tuple)
+	  (cdr tuple))
+      (vector-ref tuple i))))
+
+(define (prim.list->tuple l)
+  (let ((l (haskell-list->list/non-strict l)))
+    (if (null? (cddr l))
+	(cons (car l) (cadr l))
+	(list->vector l))))
+
+(define (haskell-list->list/non-strict l)
+  (if (null? l)
+      '()
+      (cons (car l)
+	    (haskell-list->list/non-strict (force (cdr l))))))
+
+(define (prim.dict-sel dicts i)
+  (force (vector-ref dicts i)))
+
+;;; These generate dictionaries.
+
+(define-local-syntax (create-dict dicts vars other-dicts)
+  `(let ((dict-vector (box (list->vector ,dicts))))
+     (make-tuple
+       ,@(map (lambda (v)
+		`(delay (funcall (dynamic ,v) dict-vector)))
+	   vars)
+       ,@(map (lambda (sd)
+		`(delay (,(car sd)
+			 (map (lambda (d)
+			       (tuple-select ,(cadr sd) ,(caddr sd) (force d)))
+			      ,dicts))))
+	      other-dicts))))
+
+(define prim.tupleEqdict
+  (lambda dicts
+    (tupleEqDict/l dicts)))
+
+(define (tupleEqDict/l dicts)
+  (create-dict dicts
+     (|PreludeTuple:tupleEq| |PreludeTuple:tupleNeq|)
+     ()))
+
+(define prim.tupleOrdDict
+ (lambda dicts
+   (tupleOrdDict/l dicts)))
+
+(define (tupleOrdDict/l d)
+  (create-dict d
+   (|PreludeTuple:tupleLe| |PreludeTuple:tupleLeq|
+    |PreludeTuple:tupleGe| |PreludeTuple:tupleGeq|
+    |PreludeTuple:tupleMax| |PreludeTuple:tupleMin|)
+   ((tupleEqDict/l 7 6))))
+
+(define prim.tupleIxDict
+ (lambda dicts
+   (create-dict dicts
+      (|PreludeTuple:tupleRange| |PreludeTuple:tupleIndex|
+       |PreludeTuple:tupleInRange|)
+      ((tupleEqDict/l 6 3) (tupleTextDict/l 6 4) (tupleOrdDict/l 6 5)))))
+
+(define prim.tupleTextDict
+ (lambda dicts
+   (tupleTextDict/l dicts)))
+
+(define (tupleTextDict/l d)
+  (create-dict d
+     (|PreludeTuple:tupleReadsPrec| |PreludeTuple:tupleShowsPrec|
+      |PreludeTuple:tupleReadList| |PreludeTuple:tupleShowList|)
+     ()))
+
+(define prim.tupleBinaryDict
+ (lambda dicts
+   (create-dict dicts
+    (|PreludeTuple:tupleReadBin| |PreludeTuple:tupleShowBin|)
+    ())))
+