Import to github.

7 files changed, 964 insertions, 0 deletions

diff --git a/derived/README b/derived/README
new file mode 100644
index 0000000..9b461ac
--- /dev/null
+++ b/derived/README
@@ -0,0 +1,2 @@
+This directory contains code to generate AST structure for derived
+instances.
diff --git a/derived/ast-builders.scm b/derived/ast-builders.scm
new file mode 100644
index 0000000..3a16ee6
--- /dev/null
+++ b/derived/ast-builders.scm
@@ -0,0 +1,273 @@
+;;; These functions build non-trivial ast structure.
+
+;;; Prelude functions: booleans
+
+(define (**== e1 e2)
+  (**app (**var/def (core-symbol "==")) e1 e2))
+
+(define (**<= e1 e2)
+  (**app (**var/def (core-symbol "<=")) e1 e2))
+
+(define (**< e1 e2)
+  (**app (**var/def (core-symbol "<")) e1 e2))
+
+(define (**> e1 e2)
+  (**app (**var/def (core-symbol ">")) e1 e2))
+
+(define (**and e1 e2)
+  (**app (**var/def (core-symbol "&&")) e1 e2))
+
+(define (**or e1 e2)
+  (**app (**var/def (core-symbol "||")) e1 e2))
+
+(define (**true) (**con/def (core-symbol "True")))
+
+(define (**false) (**con/def (core-symbol "False")))
+
+;; Tuples
+
+(define (**tuple2 x y)
+  (**app (**con/def (tuple-constructor 2)) x y))
+
+(define (**tupleN exps)
+  (**app/l (**con/def (tuple-constructor (length exps))) exps))
+
+;; Arithmetic
+
+(define (**+ x y)
+  (**app (**var/def (core-symbol "+")) x y))
+
+(define (**+/Int x y)
+  (**app (**var/def (core-symbol "primPlusInt")) x y))
+
+(define (**- x y)
+  (**app (**var/def (core-symbol "-")) x y))
+
+(define (**1+ x)
+  (**+ x (**int 1)))
+
+;; Lists
+
+(define (**cons x y)
+  (**app (**con/def (core-symbol ":")) x y))
+
+(define (**null)
+  (**con/def (core-symbol "Nil")))
+
+(define (**list . args)
+  (**list/l args))
+
+(define (**list/l args)
+  (if (null? args)
+      (**null)
+      (**cons (car args)
+	      (**list/l (cdr args)))))
+
+(define (**list/pattern pats)
+  (if (null? pats)
+      (**pcon/def (core-symbol "Nil") '())
+      (**pcon/def (core-symbol ":")
+		  (list (car pats) (**list/pattern (cdr pats))))))
+
+(define (**append . lists)
+  (**append/l lists))
+
+(define (**append/l lists)
+  (if (null? (cdr lists))
+      (car lists)
+      (**app (**var/def (core-symbol "++"))
+	     (car lists)
+	     (**append/l (cdr lists)))))
+
+(define (**take n l)
+  (**app (**var/def (core-symbol "take")) n l))
+
+(define (**drop n l)
+  (**app (**var/def (core-symbol "drop")) n l))
+
+;; Functionals
+
+(define (**dot fn . args)
+  (**dot/l fn args))
+
+(define (**dot/l fn args)
+ (if (null? args)
+     fn
+     (**app (**var/def (core-symbol ".")) fn (**dot/l (car args) (cdr args)))))
+
+;; Printing
+
+(define (**showChar x)
+  (**app (**var/def (core-symbol "showChar")) x))
+
+(define (**space)
+  (**showChar (**char #\ )))
+
+(define (**comma)
+  (**showChar (**char #\,)))
+
+(define (**showsPrec x y)
+  (**app (**var/def (core-symbol "showsPrec")) x y))
+
+(define (**shows x)
+  (**app (**var/def (core-symbol "shows")) x))
+
+(define (**showString x)
+  (**app (**var/def (core-symbol "showString")) x))
+
+(define (**showParen x y)
+  (**app (**var/def (core-symbol "showParen")) x y))
+
+;; Reading
+
+(define (**readsPrec x y)
+  (**app (**var/def (core-symbol "readsPrec")) x y))
+
+(define (**lex x)
+  (**app (**var/def (core-symbol "lex")) x))
+
+(define (**readParen bool fn r)
+  (**app (**var/def (core-symbol "readParen")) bool fn r))
+
+(define (**reads s)
+  (**app (**var/def (core-symbol "reads")) s))
+
+;;; Binary
+
+(define (**showBinInt i b)
+  (**app (**var/def (core-symbol "primShowBinInt")) i b))
+
+(define (**readBinSmallInt max b)
+  (**app (**var/def (core-symbol "primReadBinSmallInt")) max b))
+
+(define (**showBin x b)
+  (**app (**var/def (core-symbol "showBin")) x b))
+
+(define (**readBin b)
+  (**app (**var/def (core-symbol "readBin")) b))
+
+;;; Some higher level code generators
+
+;;; foldr  (expanded inline)
+
+(define (**foldr build-fn terms init)
+  (if (null? terms)
+      init
+      (funcall build-fn (car terms) (**foldr build-fn (cdr terms) init))))
+
+;;; Unlike foldr, this uses two sets of args to avoid tupling
+
+(define (**foldr2 build-fn terms1 terms2 init-fn)
+  (if (null? (cdr terms1))
+      (funcall init-fn (car terms1) (car terms2))
+      (funcall build-fn (car terms1) (car terms2)
+	      (**foldr2 build-fn (cdr terms1) (cdr terms2) init-fn))))
+
+;;; Enum
+
+(define (**enumFrom x)
+  (**app (**var/def (core-symbol "enumFrom")) x))
+
+(define (**enumFromThen from then)
+  (**app (**var/def (core-symbol "enumFromThen")) from then))
+
+(define (**enumFromTo from to)
+  (**app (**var/def (core-symbol "enumFromTo")) from to))
+
+(define (**enumFromThenTo from then to)
+  (**app (**var/def (core-symbol "enumFromThenTo")) from then to))
+
+;;; Cast overrides the type system
+
+(define (**cast x)
+  (make cast (exp x)))
+
+;;; Case.  This also generates the alts.  All variants of case generate
+;;; an arm for each constructor in a datatype.  This arm can be selected
+;;; by pattern matching a value of the type, with all fields bound to vars,
+;;; or with numbered or named selections.
+
+;;; The fn always generates the arms given the constructor.  In the /con case,
+;;; the fn also gets the variable list of values bound in the fields.
+
+(define (**case/con alg exp fn)
+  (**case exp
+	  (map (lambda (con)
+		 (let* ((arity (con-arity con))
+			(vars (temp-vars "x" arity)))
+		   (**alt/simple (**pat (cons con vars))
+				 (funcall fn con vars))))
+	       (algdata-constrs alg))))
+
+;;; Selectors are integers (used for Bin)
+
+(define (**case/int alg exp fn)
+  (**case exp
+    (map (lambda (con)
+	   (**alt/simple
+	      (**pat (con-tag con))
+	      (funcall fn con)))
+	 (algdata-constrs alg))))
+
+;;; Selectors are strings (Text)
+
+(define (**case/strings alg exp fn)
+  (**case exp
+    (map (lambda (con)
+	   (**alt/simple
+	    (**pat (remove-con-prefix (symbol->string (def-name con))))
+	    (funcall fn con)))
+	 (algdata-constrs alg))))
+
+;;; Definitions containing multi-body
+
+(define (**multi-define fname alg nullary-fn single-fn
+			          combine-fn else-val)
+  (**define/multiple fname
+    (append
+      (map (lambda (con) (**define/2 con nullary-fn single-fn combine-fn))
+	     (algdata-constrs alg))
+      (if (not (eq? else-val '#f))
+	  `(((_ _) ,(funcall else-val)))
+	  '()))))
+
+(define (**define/2 con nullary-fn single-fn combine-fn)
+  (let* ((arity (con-arity con))
+	 (vars1 (temp-vars "l" arity))
+	 (vars2 (temp-vars "r" arity)))
+    `(((,con ,@vars1) (,con ,@vars2))
+      ,(if (eqv? arity 0)
+	   (funcall nullary-fn)
+	   (**foldr2 combine-fn (suspend-vars vars1) (suspend-vars vars2)
+			   single-fn)))))
+
+(define (**define/multiple fn args)
+  (make valdef
+	(lhs (**pat fn))
+	(definitions
+          (map (lambda (arg)
+		 (make single-fun-def
+		       (args (map (function **pat) (car arg)))
+		       (rhs-list (list (make guarded-rhs
+					     (guard (**omitted-guard))
+					     (rhs (cadr arg)))))
+		       (where-decls '())
+		       (infix? '#f)))
+	       args))))
+
+(define (suspend-vars vars) (map (lambda (v) (lambda () (**var v))) vars))
+
+(define (temp-vars root arity)
+  (temp-vars1 root 1 arity))
+
+(define (temp-vars1 root i arity)
+  (if (> i arity)
+      '()
+      (cons (string->symbol (string-append root (number->string i)))
+	    (temp-vars1 root (1+ i) arity))))
+       
+(define (tuple-con algdata)
+  (car (algdata-constrs algdata)))
+
+(define (con-string x)
+  (remove-con-prefix (symbol->string (def-name x))))
diff --git a/derived/derived-instances.scm b/derived/derived-instances.scm
new file mode 100644
index 0000000..2c65084
--- /dev/null
+++ b/derived/derived-instances.scm
@@ -0,0 +1,255 @@
+
+;;; Basic DI structure:
+;;;  a. Create the set of instances
+;;;  b. Expand the context of each potential instance.
+;;;  c. Once b. reaches a fixpoint, fill in the ast for the generated instances
+
+(define *di-context-changed* '#f)
+
+(define (add-derived-instances modules)
+  (let ((insts '()))
+    (walk-modules modules
+     (lambda () (setf insts (append (find-derivable-instances) insts))))
+    (compute-di-fixpoint insts)
+    (dolist (inst insts)
+      (when (instance-ok? inst)
+        (create-instance-fns inst)
+	(push inst (module-instance-defs
+		    (table-entry *modules*
+				 (def-module (instance-algdata inst)))))))))
+
+(define (compute-di-fixpoint insts)
+  (setf *di-context-changed* '#f)
+  (dolist (inst insts)
+    (propagate-di-context inst))
+  (when *di-context-changed* (compute-di-fixpoint insts)))
+
+;;; Create instance decls for all derived instances in a module.  Filter
+;;; out underivable instances (Ix & Enum only)
+
+(define (find-derivable-instances)
+  (let ((algs (module-alg-defs *module*))
+	(insts '()))
+    (dolist (alg algs)
+      (dolist (class (algdata-deriving alg))
+	 (cond ((memq class (list (core-symbol "Eq")
+				  (core-symbol "Ord")
+				  (core-symbol "Text")
+				  (core-symbol "Binary")))
+		(setf insts (add-derivable-instance insts alg class '#f)))
+	       ((eq? class *printer-class*)
+		(setf insts (add-derivable-instance
+			     insts alg (core-symbol "Text") '#t)))
+	       ((eq? class (core-symbol "Ix"))
+		(if (or (algdata-enum? alg)
+			(algdata-tuple? alg))
+		    (setf insts (add-derivable-instance insts alg class '#f))
+		    (signal-cant-derive-ix alg)))
+	       ((eq? class (core-symbol "Enum"))
+		(if (algdata-enum? alg)
+		    (setf insts (add-derivable-instance insts alg class '#f))
+		    (signal-cant-derive-enum alg)))
+	       (else
+		(signal-not-derivable class)))))
+    insts))
+
+
+(define (signal-cant-derive-ix alg)
+  (phase-error 'cant-derive-IX
+    "An Ix instance for ~A cannot be derived.  It is not an enumeration~%~
+     or single-constructor datatype."
+    alg))
+
+(define (signal-cant-derive-enum alg)
+  (phase-error 'cant-derive-Enum
+    "An Enum instance for ~A cannot be derived.  It is not an enumeration."
+    alg))
+
+(define (signal-not-derivable class)
+  (recoverable-error 'not-derivable
+    "Class ~A is not one of the classes that permits derived instances."
+    class))
+
+
+;; This adds a provisional instance template.  Of course, there may already
+;;; be an instance (error!)
+
+(define (add-derivable-instance insts alg cls sp)
+  (let ((existing-inst (lookup-instance alg cls)))
+    (cond ((eq? existing-inst '#f)
+	   (let ((inst (new-instance cls alg (algdata-tyvars alg))))
+	     (setf (instance-context inst) (algdata-context alg))
+	     (setf (instance-decls inst) '())
+	     (setf (instance-ok? inst) '#t)
+	     (setf (instance-suppress-readers? inst) sp)
+	     (cons inst insts)))
+	  (else
+	   (signal-instance-exists alg cls)
+	   insts))))
+
+(define (signal-instance-exists alg cls)
+  (recoverable-error 'instance-exists
+    "An instance for type ~A in class ~A already exists;~%~
+     the deriving clause is being ignored."
+    alg cls))
+
+;;; This updates all instance contexts for an algdata.  Each derivable
+;;; instance generates a recursive context for every field.  If a
+;;; component cannot satisfy the desired context, the ok? field is set to
+;;; #f to mark the instance as bogus.
+
+(define (propagate-di-context inst)
+  (when (instance-ok? inst)
+    (propagate-constructor-contexts inst
+			   (algdata-constrs (instance-algdata inst)))))
+
+;;; These two functions propagate the context to ever field of every
+;;; constructor
+
+(define (propagate-constructor-contexts inst constrs)
+  (or (null? constrs)
+      (and (propagate-contexts inst (instance-class inst)
+			       (con-types (car constrs)))
+	   (propagate-constructor-contexts inst (cdr constrs)))))
+
+(define (propagate-contexts inst class types)
+  (or (null? types)
+      (and (propagate-type-context inst class (car types))
+	   (propagate-contexts inst class (cdr types)))))
+
+;;; This propagates a context out to a given type.  The type can only contain
+;;; the tyvars which are args to the algdata.
+
+(define (propagate-type-context inst class type)
+  (cond ((tyvar? type)
+	 (cond ((single-ast-context-implies?
+		   (instance-context inst) class (tyvar-name type))
+		'#t)
+	       (else
+		(setf *di-context-changed* '#t)
+		(setf (instance-context inst)
+		      (augment-context (instance-context inst) class
+				       (tyvar-name type)))
+		'#t)))
+	((synonym? (tycon-def type))
+	 (propagate-type-context inst class (expand-synonym type)))
+	(else
+	 (let* ((algdata (tycon-def type))  ; must be a algdata
+	        (args (tycon-args type))
+		(new-inst (lookup-instance algdata class)))
+	   (cond ((or (eq? new-inst '#f)
+		      (not (instance-ok? new-inst)))
+		  (signal-cannot-derive-instance
+		    (instance-class inst) (instance-algdata inst))
+		  (setf (instance-ok? inst) '#f)
+		  (setf *di-context-changed* '#t)
+		  '#f)
+		 (else
+		  (propagate-instance-contexts inst 
+				      (instance-context new-inst)
+				      (instance-tyvars new-inst)
+				      args)))))))
+
+
+(define (single-ast-context-implies? ast-context class tyvar)
+  (cond ((null? ast-context)
+	 '#f)
+	((eq? tyvar (context-tyvar (car ast-context)))
+	 (let ((class1 (class-ref-class (context-class (car ast-context)))))
+	   (or (eq? class1 class)
+	       (memq class (class-super* class1))
+	       (single-ast-context-implies? (cdr ast-context) class tyvar))))
+	(else
+	 (single-ast-context-implies? (cdr ast-context) class tyvar))))
+
+;;; *** This message makes no sense to me.  What is the problem that
+;;; *** makes it impossible to derive the instance?
+
+(define (signal-cannot-derive-instance class alg)
+  (phase-error 'cannot-derive-instance
+    "Instance ~A(~A) cannot be derived."
+    class alg))
+
+
+;;; This propagates contexts into structure components.  The context
+;;; changes due to the context associated with the various instance
+;;; decls encountered.
+
+;;; Here's the plan for expanding Cls(Alg t1 t2 .. tn) using
+;;; instance (Cls1(vx),Cls2(vy),...) => Cls(Alg(v1 v2 .. vn))
+;;;   for each Clsx in the instance context, propagate Clsx to the
+;;;   ti corresponding to vx, where vx must be in the set vi.
+
+(define (propagate-instance-contexts inst contexts tyvars args)
+  (or (null? contexts)
+      (and (propagate-type-context inst
+	      (class-ref-class (context-class (car contexts)))
+	      (find-corresponding-tyvar
+	       (context-tyvar (car contexts)) tyvars args))
+	   (propagate-instance-contexts inst (cdr contexts) tyvars args))))
+
+;;; Given the t(i) and the v(i), return the t corresponding to a v.
+
+(define (find-corresponding-tyvar tyvar tyvars args)
+  (if (eq? tyvar (car tyvars))
+      (car args)
+      (find-corresponding-tyvar tyvar (cdr tyvars) (cdr args))))
+
+;;; 1 level type synonym expansion
+
+(define (expand-synonym type)
+  (let* ((synonym (tycon-def type))
+	 (args (synonym-args synonym))
+	 (body (synonym-body synonym)))
+  (let ((alist (map (lambda (tyvar arg) (tuple tyvar arg))
+		    args (tycon-args type))))
+    (copy-synonym-body body alist))))
+
+(define (copy-synonym-body type alist)
+  (if (tyvar? type)
+      (tuple-2-2 (assq (tyvar-name type) alist))
+      (make tycon (def (tycon-def type))
+	          (name (tycon-name type))
+		  (args (map (lambda (ty)
+			       (copy-synonym-body ty alist))
+			     (tycon-args type))))))
+
+;;; This fills in the body decls for an instance function.
+
+(define (create-instance-fns inst)
+  (let ((class (instance-class inst))
+	(alg (instance-algdata inst)))
+    (cond ((eq? class (core-symbol "Eq"))
+	   (add-instance inst (eq-fns alg)))
+	  ((eq? class (core-symbol "Ord"))
+	   (add-instance inst (ord-fns alg)))
+	  ((eq? class (core-symbol "Ix"))
+	   (add-instance inst (ix-fns alg)))
+	  ((eq? class (core-symbol "Enum"))
+	   (add-instance inst (enum-fns alg)))
+	  ((eq? class (core-symbol "Text"))
+	   (add-instance inst (text-fns alg (instance-suppress-readers? inst))))
+	  ((eq? class (core-symbol "Binary"))
+	   (add-instance inst (binary-fns alg))))))
+
+(define (add-instance inst decls)
+  (setf (instance-decls inst) decls))
+
+;;; Add class(var) to a context, removing any contexts made redundant by
+;;; the new addition.  Example: adding Ord a to (Eq a, Eq b) would yield
+;;; (Ord a,Eq b).
+
+(define (augment-context contexts cl var)
+  (cons (**context (**class/def cl) var)
+	(remove-implied-contexts cl var contexts)))
+
+(define (remove-implied-contexts class1 tyvar1 contexts)
+  (if (null? contexts)
+      '#f
+      (with-slots context (class tyvar) (car contexts)
+	(let ((rest (remove-implied-contexts class1 tyvar1 (cdr contexts)))
+	      (class2 (class-ref-class class)))
+	  (if (and (eq? tyvar1 tyvar)
+		   (memq class2 (class-super* class1)))
+	      rest
+	      (cons (car contexts) rest))))))
diff --git a/derived/derived.scm b/derived/derived.scm
new file mode 100644
index 0000000..975dab6
--- /dev/null
+++ b/derived/derived.scm
@@ -0,0 +1,21 @@
+;;; -- compilation unit definition for derived instances
+;;;
+;;; author :  John
+;;;
+
+(define-compilation-unit derived
+  (source-filename "$Y2/derived/")
+  (require global)
+  (unit derived-instances
+    (source-filename "derived-instances.scm"))
+  (unit ast-builders
+    (source-filename "ast-builders"))
+  (unit eq-ord
+    (source-filename "eq-ord"))
+  (unit ix-enum
+    (source-filename "ix-enum"))
+  (unit text-binary
+    (source-filename "text-binary"))
+  )
+
+
diff --git a/derived/eq-ord.scm b/derived/eq-ord.scm
new file mode 100644
index 0000000..b005b58
--- /dev/null
+++ b/derived/eq-ord.scm
@@ -0,0 +1,69 @@
+;;; ----------------------------------------------------------------
+;;;  Eq
+;;; ----------------------------------------------------------------
+
+(define (Eq-fns algdata)
+  (list
+   (cond ((algdata-enum? algdata)
+	  (**define '== '(|x| |y|)
+		    (**== (**con-number (**var '|x|) algdata)
+			  (**con-number (**var '|y|) algdata))))
+	 (else
+	  (**multi-define '== algdata
+			  ;; For nullary constructors
+			  (function **true)
+			  ;; For unary constructors
+			  (lambda (v1 v2)
+			    (**== (funcall v1) (funcall v2)))
+			  ;; For n-ary constructors
+			  (lambda (v1 v2 bool)
+			    (**and (**== (funcall v1) (funcall v2)) bool))
+			  ;; The else clause in case the constructors do
+			  ;; not match.
+			  (if (algdata-tuple? algdata)
+			      '#f
+			      (function **false)))))))
+
+;;; ----------------------------------------------------------------
+;;;  Ord
+;;; ----------------------------------------------------------------
+
+(define (Ord-fns algdata)
+  (list (ord-fn1 algdata '< (function **<))
+	(ord-fn1 algdata '<= (function **<=))))
+
+(define (Ord-fn1 algdata fn prim)
+  (cond ((algdata-enum? algdata)
+	 (**define fn '(|x| |y|)
+		       (funcall prim (**con-number (**var '|x|) algdata)
+				     (**con-number (**var '|y|) algdata))))
+	((algdata-tuple? algdata)
+	 (**multi-define fn algdata
+		         (function **false)
+			 (lambda (x y) (funcall prim (funcall x) (funcall y)))
+			 (function combine-eq-<)
+			 '#f))
+	(else
+	 (**define fn '(|x| |y|)
+	   (**let
+	    (list 
+	     (**multi-define '|inner| algdata
+			       (if (eq? fn '<) (function **false)
+				               (function **true))
+			       (lambda (x y)
+				 (funcall prim (funcall x) (funcall y)))
+			       (function combine-eq-<)
+			       '#f)
+	     (**define '|cx| '() (**con-number (**var '|x|) algdata))
+	     (**define '|cy| '() (**con-number (**var '|y|) algdata)))
+	    (**or (**< (**var '|cx|) (**var '|cy|))
+		  (**and (**== (**var `|cx|) (**var '|cy|))
+			 (**app (**var '|inner|)
+				(**var '|x|)
+				(**var '|y|)))))))))
+
+(define (combine-eq-< v1 v2 rest)
+  (**or (**< (funcall v1) (funcall v2))
+	(**and (**== (funcall v1) (funcall v2))
+	       rest)))
+
diff --git a/derived/ix-enum.scm b/derived/ix-enum.scm
new file mode 100644
index 0000000..fb9a282
--- /dev/null
+++ b/derived/ix-enum.scm
@@ -0,0 +1,116 @@
+;;; ----------------------------------------------------------------
+;;;  Ix
+;;; ----------------------------------------------------------------
+
+(define (ix-fns algdata)
+  (if (algdata-enum? algdata)
+      (ix-fns/enum algdata)
+      (ix-fns/tuple algdata)))
+
+(define (ix-fns/enum algdata)
+ (list 
+   (**define '|range| '((tuple |l| |u|))
+     (**let
+      (list
+       (**define '|cl| '() (**con-number (**var '|l|) algdata))
+       (**define '|cu| '() (**con-number (**var '|u|) algdata)))
+      (**if (**< (**var '|cu|) (**var '|cl|))
+	    (**null)
+	    (**take (**+ (**- (**var '|cu|) (**var '|cl|)) (**int 1))
+		    (**drop (**var '|cl|)
+		      (**list/l
+		       (map (function **con/def)
+			    (algdata-constrs algdata))))))))
+   (**define '|index| '((tuple |l| |u|) |x|)
+      (**- (**con-number (**var '|x|) algdata)
+	   (**con-number (**var '|l|) algdata)))
+   (**define '|inRange| '((tuple |l| |u|) |x|)
+      (**and (**<= (**con-number (**var '|l|) algdata)
+		   (**con-number (**var '|x|) algdata))
+	     (**<= (**con-number (**var '|x|) algdata)
+		   (**con-number (**var '|u|) algdata))))))
+
+(define (ix-fns/tuple algdata)
+  (let* ((con (tuple-con algdata))
+	 (arity (con-arity con))
+	 (llist (temp-vars "l" arity))
+	 (ulist (temp-vars "u" arity))
+	 (ilist (temp-vars "i" arity)))
+   (list
+    (**define '|range| `((tuple (,con ,@llist) (,con ,@ulist)))
+      (**listcomp (**app/l (**con/def con) (map (function **var) ilist))
+		  (map (lambda (iv lv uv)
+			  (**gen iv
+			       (**app (**var '|range|)
+				      (**tuple2 (**var lv)
+						(**var uv)))))
+			ilist llist ulist)))
+    (**define '|index| `((tuple (,con ,@llist) (,con ,@ulist))
+			 (,con ,@ilist))
+	  (index-body (reverse ilist) (reverse llist) (reverse ulist)))
+    (**define '|inRange| `((tuple (,con ,@llist) (,con ,@ulist))
+			   (,con ,@ilist))
+		(inrange-body ilist llist ulist)))))
+
+(define (index-body is ls us)
+  (let ((i1 (**app (**var '|index|)
+		   (**tuple2 (**var (car ls)) (**var (car us)))
+		   (**var (car is)))))
+    (if (null? (cdr is))
+	i1
+	(**app (**var '|+|)
+	       i1 (**app (**var '|*|)
+			 (**1+ (**app (**var '|index|)
+				      (**tuple2 (**var (car ls))
+						(**var (car us)))
+				      (**var (car us))))
+			 (index-body (cdr is) (cdr ls) (cdr us)))))))
+
+(define (inrange-body is ls us)
+  (let ((i1 (**app (**var '|inRange|)
+		   (**tuple2 (**var (car ls)) (**var (car us)))
+		   (**var (car is)))))
+    (if (null? (cdr is))
+	i1
+	(**app (**var/def (core-symbol "&&"))
+	       i1
+	       (inrange-body (cdr is) (cdr ls) (cdr us))))))
+
+;;; ----------------------------------------------------------------
+;;;  Enum
+;;; ----------------------------------------------------------------
+
+; Enum uses the Int methods since Enums are represented as Ints.
+
+(define (enum-fns algdata)
+  (list
+   (**define '|enumFrom| '(|x|)
+       (**let
+	 (list
+	  (**define '|from'| '(|x'|)
+	      (**if (**> (**var '|x'|)
+			 (**con-number (**con/def (last-con algdata)) algdata))
+		    (**null)
+		    (**cons (**var '|x'|)
+			    (**app (**var '|from'|) (**1+ (**var '|x'|)))))))
+	 (**cast (**app (**var '|from'|)
+			(**con-number (**var '|x|) algdata)))))
+   (**define '|enumFromThen| '(|x| |y|)
+     (**let
+      (list
+       (**define '|step| '()
+	 (**- (**con-number (**var '|y|) algdata)
+	      (**con-number (**var '|x|) algdata)))
+       (**define '|from'| '(|x'|)
+	(**if (**or (**> (**var '|x'|)
+			 (**con-number (**con/def (last-con algdata)) algdata))
+		    (**< (**var '|x'|) (**int 0)))
+	      (**null)
+	      (**cons (**var '|x'|)
+		      (**app (**var '|from'|)
+			     (**+ (**var '|x'|) (**var '|step|)))))))
+      (**cast (**app (**var '|from'|) (**con-number (**var '|x|) algdata)))))))
+
+(define (last-con algdata)
+  (car (reverse (algdata-constrs algdata))))
+
diff --git a/derived/text-binary.scm b/derived/text-binary.scm
new file mode 100644
index 0000000..1779d1a
--- /dev/null
+++ b/derived/text-binary.scm
@@ -0,0 +1,228 @@
+;;; ----------------------------------------------------------------
+;;;  Text
+;;; ----------------------------------------------------------------
+
+(define (text-fns algdata suppress-reader?)
+  (let ((print+read
+	 (cond ((algdata-enum? algdata)
+		(text-enum-fns algdata))
+	       (else
+		(text-general-fns algdata)))))
+    (when suppress-reader?
+      (setf print+read (list (car print+read))))
+    print+read))
+
+(define (text-enum-fns algdata)
+  (list
+   (**define '|showsPrec| '(|d| |x|)
+      (**case/con algdata (**var '|x|)
+		  (lambda (con vars)
+		     (declare (ignore vars))
+		     (**showString (**string (con-string con))))))
+   (**define '|readsPrec| '(|d| |str|)
+     (**listcomp
+      (**var '|s|)
+      (list
+       (**gen '(tuple |tok| |rest|) (**lex (**var '|str|)))
+       (**gen '|s|
+	      (**case (**var '|tok|)
+		      `(,@(map (lambda (con)
+				 (**alt/simple
+				  (**pat (con-string con))
+				  (**list (**tuple2 (**con/def con)
+						    (**var '|rest|)))))
+			       (algdata-constrs algdata))
+			,(**alt/simple (**pat '_) (**null))))))))))
+
+;;; This has been hacked to split up the read function for large
+;;; data types to avoid choking the lisp compiler.
+
+(define (text-general-fns algdata)
+ (let ((split-fn-def? (> (algdata-n-constr algdata) 6)))  ;; pretty arbitrary!
+  (list
+   (**define '|showsPrec| '(|d| |x|)
+       (**case/con algdata (**var '|x|)
+	  (lambda (con vars)
+	    (if (con-infix? con)
+		(show-infix con vars)
+		(show-prefix con vars)))))
+   (**define '|readsPrec| '(|d| |str|)
+     (**append/l
+      (map (lambda (con)
+	     (cond ((con-infix? con)
+		    (read-infix con))
+		   (else
+		    (read-prefix con split-fn-def?))))
+		 (algdata-constrs algdata)))))))
+
+(define (show-infix con vars)
+  (multiple-value-bind (p lp rp) (get-con-fixity con)
+    (**showParen
+     (**< (**Int p) (**var '|d|))
+     (**dot (**showsPrec (**int lp) (**var (car vars)))
+	    (**showString
+	      (**string (string-append " " (con-string con) " ")))
+	    (**showsPrec (**int rp) (**var (cadr vars)))))))
+
+(define (show-prefix con vars)
+  (**showParen
+   (**<= (**int 10) (**var '|d|))
+   (**dot/l (**showString (**string (con-string con)))
+	    (show-fields vars))))
+
+(define (show-fields vars)
+  (if (null? vars)
+      '()
+      `(,(**space) ,(**showsPrec (**int 10) (**var (car vars)))
+	,@(show-fields (cdr vars)))))
+
+(define (read-infix con)
+  (multiple-value-bind (p lp rp) (get-con-fixity con)
+    (**let
+     (list
+      (**define '|readVal| '(|r|) 
+	 (**listcomp
+	  (**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|))
+		    (**var '|s2|))
+	  (list
+	   (**gen '(tuple |u| |s0|)
+		  (**readsPrec (**int lp) (**var '|r|)))
+	   (**gen `(tuple ,(con-string con) |s1|)
+		  (**lex (**var '|s0|)))
+	   (**gen '(tuple |v| |s2|)
+		  (**readsprec (**int rp) (**var '|s1|)))))))
+     (**readParen (**< (**int p) (**var '|d|))
+		  (**var '|readVal|) (**var '|str|)))))
+
+(define (read-prefix con split?)
+  (let ((res (read-prefix-1 con)))
+    (if (not split?)
+	res
+	(dynamic-let ((*module-name* (def-module con)))
+	 (dynamic-let ((*module* (table-entry *modules* *module-name*)))
+  	  (let* ((alg (con-alg con))
+		 (fn (make-new-var
+		      (string-append (symbol->string (def-name alg))
+				     "/read-"
+				     (remove-con-prefix
+				      (symbol->string (def-name con))))))
+		 (new-code (**app (**var/def fn) (**var '|str|) (**var '|d|)))
+		 (def (**define fn '(|str| |d|) res)))
+	  (setf (module-decls *module*) (cons def (module-decls *module*)))
+	  new-code))))))
+
+(define (read-prefix-1 con)
+  (let* ((arity (con-arity con))
+	 (vars (temp-vars "x" arity))
+	 (svars (cons '|rest| (temp-vars "s" arity))))
+    (**let
+     (list
+      (**define '|readVal| '(|r|) 
+        (**listcomp
+	 (**tuple2 (**app/l (**con/def con) (map (function **var) vars))
+		   (**var (car (reverse svars))))
+	 (cons
+	  (**gen `(tuple ,(con-string con) |rest|)
+		 (**lex (**var '|r|)))
+	  (read-fields vars svars (cdr svars))))))
+     (**readParen (**< (**int 9) (**var '|d|))
+		  (**var '|readVal|) (**var '|str|)))))
+
+(define (read-fields vars s0 s1)
+  (if (null? vars)
+      '()
+      (cons
+       (**gen `(tuple ,(car vars) ,(car s1))
+	      (**readsprec (**int 10) (**var (car s0))))
+       (read-fields (cdr vars) (cdr s0) (cdr s1)))))
+
+
+;;; ----------------------------------------------------------------
+;;;  Binary
+;;; ----------------------------------------------------------------
+
+(define (binary-fns algdata)
+ (let ((res
+  (cond ((algdata-enum? algdata)
+	 (binary-enum-fns algdata))
+	((algdata-tuple? algdata)
+	 (binary-tuple-fns algdata))
+	(else
+	 (binary-general-fns algdata)))))
+;   (dolist (x res)
+;       (fresh-line)
+;       (pprint x))
+   res))
+
+
+(define (binary-enum-fns algdata)
+  (list
+    (**define '|showBin| '(|x| |b|)
+	(**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|)))
+    (**define '|readBin| '(|b|)
+      (**let
+       (list
+	(**define '(tuple |n| |b1|) '()
+	   (**readBinSmallInt
+	    (**var '|b|)
+	    (**int (1- (algdata-n-constr algdata))))))
+        (**tuple2
+	 (**case/int algdata (**var '|n|)
+	       (lambda (con)
+		 (**con/def con)))
+	 (**var '|b1|))))))
+
+(define (binary-tuple-fns algdata)
+  (let* ((con (tuple-con algdata))
+	 (arity (con-arity con))
+	 (vars (temp-vars "v" arity)))
+    (list
+      (**define '|showBin| `((,con ,@vars) |b|)
+	  (show-binary-body vars '|b|))
+      (**define '|readBin| '(|b|)
+	  (read-binary-body con)))))
+
+(define (show-binary-body vars b)
+  (**foldr (lambda (new-term prev-terms)
+	       (**showBin new-term prev-terms))
+	   (map (function **var) vars)
+	   (**var b)))
+
+(define (read-binary-body con)
+  (let* ((arity (con-arity con))
+	 (vars (temp-vars "v" arity))
+	 (bvars (cons '|b| (temp-vars "b" arity))))
+    (**let
+     (map (lambda (v b nb)
+	    (**define `(tuple ,v ,nb) '()
+		      (**readBin (**var b))))
+	  vars bvars (cdr bvars))
+     (**tuple2
+      (**app/l (**con/def con)
+	       (map (function **var) vars))
+      (**var (car (reverse bvars)))))))
+
+(define (binary-general-fns algdata)
+  (list
+    (**define '|showBin| '(|x| |b|)
+      (**showBinInt
+       (**con-number (**var '|x|) algdata)
+       (**case/con algdata (**var '|x|)
+	  (lambda (con vars)
+	    (declare (ignore con))
+	    (show-binary-body vars '|b|)))))
+    (**define '|readBin| '(|bin|)
+      (**let
+       (list
+	(**define '(tuple |i| |b|) '()
+	 (**readBinSmallInt (**var '|bin|)
+			    (**int (1- (algdata-n-constr algdata))))))
+       (**case/int algdata (**var '|i|) (function read-binary-body))))))
+
+(define (get-con-fixity con)
+  (let ((fixity (con-fixity con)))
+    (if (not (eq? fixity '#f))
+	(let ((p (fixity-precedence fixity))
+	      (a (fixity-associativity fixity)))
+	  (values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p))))
+	(values 9 10 9))))