Import to github.

14 files changed, 1442 insertions, 0 deletions

diff --git a/top/README b/top/README
new file mode 100644
index 0000000..6657292
--- /dev/null
+++ b/top/README
@@ -0,0 +1,12 @@
+This directory contains the top level of the compiler.
+Files found here:
+
+phases - the top level calls to the compiler phases; compilation init code
+errors - general error handlers
+globals - global variable definitions
+core-symbols - defines core symbols
+system-init - code to run once after the compiler is loaded.
+driver - top level functions which drive the compiler.  There are called
+         from the command interface or directly from the user.
+
+
diff --git a/top/core-definitions.scm b/top/core-definitions.scm
new file mode 100644
index 0000000..e86b355
--- /dev/null
+++ b/top/core-definitions.scm
@@ -0,0 +1,149 @@
+;;; This file defines core symbols - those in PreludeCore and
+;;; other Prelude symbols used in compilation.
+
+;;; This part is constructed from the export table of PreludeCore
+;;; by 'top/prelude-core-syms' and has been pasted in here.
+
+
+(DEFINE *haskell-prelude-vars*
+  '((CLASSES "Num"
+             "Integral"
+             "Eq"
+             "Text"
+             "Fractional"
+             "RealFloat"
+             "RealFrac"
+             "Enum"
+             "Ix"
+             "Floating"
+             "Ord"
+             "Real"
+             "Binary")
+    (METHODS "fromInteger"
+             "signum"
+             "abs"
+             "negate"
+             "*"
+             "-"
+             "+"
+             "toInteger"
+             "odd"
+             "even"
+             "divMod"
+             "quotRem"
+             "mod"
+             "div"
+             "rem"
+             "quot"
+             "/="
+             "=="
+             "showList"
+             "readList"
+             "showsPrec"
+             "readsPrec"
+             "fromRational"
+             "recip"
+             "/"
+             "scaleFloat"
+             "significand"
+             "exponent"
+             "encodeFloat"
+             "decodeFloat"
+             "floatRange"
+             "floatDigits"
+             "floatRadix"
+             "floor"
+             "ceiling"
+             "round"
+             "truncate"
+             "properFraction"
+             "enumFromThenTo"
+             "enumFromTo"
+             "enumFromThen"
+             "enumFrom"
+             "inRange"
+             "index"
+             "range"
+             "atanh"
+             "acosh"
+             "asinh"
+             "tanh"
+             "cosh"
+             "sinh"
+             "atan"
+             "acos"
+             "asin"
+             "tan"
+             "cos"
+             "sin"
+             "logBase"
+             "**"
+             "sqrt"
+             "log"
+             "exp"
+             "pi"
+             "min"
+             "max"
+             ">"
+             ">="
+             "<="
+             "<"
+             "toRational"
+             "showBin"
+             "readBin")
+    (TYPES "Char"
+           "Complex"
+           "Integer"
+           "Double"
+           "Bin"
+           "Array"
+           "Float"
+           "Bool"
+           "Int"
+           "Assoc"
+           "Ratio"
+           "SystemState"
+           "IOResult")
+    (CONSTRUCTORS ":+" "True" "False" ":=" ":")
+    (SYNONYMS "ShowS" "ReadS" "String" "Rational" "IO")
+    (VALUES)))
+
+;;; Non PreludeCore stuff
+
+;;; This table defines all symbols in the core used internally by the
+;;; compiler.
+
+(define *haskell-noncore-vars* '(
+  (types 
+     "List"
+     "Arrow"
+     "Request"
+     "Response"
+     "UnitType"
+     "TupleDicts")
+  (constructors 
+     "MkFloat"
+     "MkDouble"
+     "MkChar"
+     "MkInteger"
+     "MkInt"
+     "Nil"
+     "UnitConstructor")
+  (values
+    "&&"  "||"  "primPlusInt"
+    "++" "take" "drop" "." "showChar" "shows" "showString"
+    "showParen" "lex" "readParen" "reads"
+    "primShowBinInt" "primReadBinSmallInt"
+    "error"
+    "primIntegerToInt" "primIntToInteger"
+    "primRationalToFloat" "primRationalToDouble"
+    "primNegInt" "primNegInteger" "primNegFloat" "primNegDouble" 
+    "foldr" "build" "inlineFoldr" "inlineBuild" 
+    "primAppend" "primStringEq"
+    "dictSel" "tupleEqDict" "tupleOrdDict" "tupleIxDict"
+    "tupleTextDict" "tupleBinaryDict")))
+
+
+
+
+
diff --git a/top/core-init.scm b/top/core-init.scm
new file mode 100644
index 0000000..7ba9fa1
--- /dev/null
+++ b/top/core-init.scm
@@ -0,0 +1,14 @@
+
+
+(define *core-symbols* '())
+(define *prelude-core-symbols* '())
+
+; expands into lots of (define *core-??* '())
+
+(define-core-variables)
+
+(define (init-core-symbols)
+  (setf *core-symbols* (make-table))
+  (setf *prelude-core-symbols* (make-table))
+  (create-core-globals))
+
diff --git a/top/core-symbols.scm b/top/core-symbols.scm
new file mode 100644
index 0000000..f43de93
--- /dev/null
+++ b/top/core-symbols.scm
@@ -0,0 +1,126 @@
+;;; This defines all core symbols.
+
+;;; Core symbols are stored in global variables.  The core-symbol
+;;; macro just turns a string into a variable name.
+
+(define-syntax (core-symbol str)
+  (make-core-symbol-name str))
+
+(define (make-core-symbol-name str)
+  (string->symbol (string-append "*core-" str "*")))
+
+(define (symbol->core-var name)
+  (make-core-symbol-name (symbol->string name)))
+
+(define (get-core-var-names vars type)
+  (let ((res (assq type vars)))
+    (if (eq? res '#f)
+	'()
+	(map (function string->symbol) (tuple-2-2 res)))))
+
+;;; This is just used to create a define for each var without a
+;;; value.
+
+(define-syntax (define-core-variables)
+  `(begin
+     ,@(define-core-variables-1 *haskell-prelude-vars*)
+     ,@(define-core-variables-1 *haskell-noncore-vars*)))
+
+(define (define-core-variables-1 vars)
+  (concat (map (lambda (ty)
+		 (map (function init-core-symbol)
+		      (get-core-var-names vars ty)))
+	       '(classes methods types constructors synonyms values))))
+
+(define (init-core-symbol sym)
+  `(define ,(symbol->core-var sym) '()))
+
+(define-syntax (create-core-globals)
+  `(begin
+     (begin ,@(create-core-defs *haskell-prelude-vars* '#t))
+     (begin ,@(create-core-defs *haskell-noncore-vars* '#f))))
+
+(define (create-core-defs defs prelude-core?)
+  `(,@(map (lambda (x) (define-core-value x prelude-core?))
+	   (get-core-var-names defs 'values))
+     ,@(map (lambda (x) (define-core-method x prelude-core?))
+	   (get-core-var-names defs 'methods))
+     ,@(map (lambda (x) (define-core-synonym x prelude-core?))
+	   (get-core-var-names defs 'synonyms))
+     ,@(map (lambda (x) (define-core-class x prelude-core?))
+	   (get-core-var-names defs 'classes))
+     ,@(map (lambda (x) (define-core-type x prelude-core?))
+	    (get-core-var-names defs 'types))
+     ,@(map (lambda (x) (define-core-constr x prelude-core?))
+	    (get-core-var-names defs 'constructors))))
+
+
+(define (define-core-value name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-value-definition ',name ',pc?)))
+
+(define (make-core-value-definition name pc?)
+  (install-core-sym
+    (make var (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (define-core-method name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-method-definition ',name ',pc?)))
+
+(define (make-core-method-definition name pc?)
+  (install-core-sym
+    (make method-var (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (define-core-class name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-class-definition ',name ',pc?)))
+
+(define (make-core-class-definition name pc?)
+  (install-core-sym
+    (make class (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (define-core-synonym name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-synonym-definition ',name ',pc?)))
+
+(define (make-core-synonym-definition name pc?)
+  (install-core-sym
+    (make synonym (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (define-core-type name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-type-definition ',name ',pc?)))
+
+(define (make-core-type-definition name pc?)
+  (install-core-sym
+    (make algdata (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (define-core-constr name pc?)
+    `(setf ,(symbol->core-var name)
+	   (make-core-constr-definition ',name ',pc?)))
+
+(define (make-core-constr-definition name pc?)
+  (setf name (add-con-prefix/symbol name))
+  (install-core-sym
+    (make con (name name) (module '|*Core|) (unit '|*Core|))
+    name
+    pc?))
+
+(define (install-core-sym def name preludecore?)
+  (setf (def-core? def) '#t)
+  (when preludecore? 
+    (setf (def-prelude? def) '#t))
+  (setf (table-entry (dynamic *core-symbols*) name) def)
+  (when preludecore?
+    (setf (table-entry (dynamic *prelude-core-symbols*) name) def))
+  def)
diff --git a/top/errors.scm b/top/errors.scm
new file mode 100644
index 0000000..06a2f66
--- /dev/null
+++ b/top/errors.scm
@@ -0,0 +1,119 @@
+;;; This file contains general error handling routines.
+
+;;; This is the general error handler.  It has three arguments: an
+;;; id, error type, and an error message.  The message is a list of
+;;; format, arglist combinations.
+
+;;; The error types are:
+;;;   warning       -> control returns and compilation proceeds
+;;;                    The message may be suppressed
+;;;   recoverable   -> control returns and compilation proceeds
+;;;   phase         -> control returns but compilation is aborted
+;;;                         after the phase in *abort-point*.
+;;;   fatal         -> control goes back to the top level
+;;;   internal      -> enters the break loop or does a fatal error
+
+;;; Two globals control error behavior:
+;;;   *break-on-error?* enter the break loop on any error
+;;;   *never-break?* never enter the break loop, even for internal errors.
+
+;;; The global *error-output-port* controls where errors are printer.
+
+;;; The strategy here is to first write a banner message based on the id and
+;;; type, write out the messages, and then take action depending on the type.
+
+(define *in-error-handler?* '#f)
+
+(define (haskell-error id type messages)
+  (format *error-output-port* "~&[~A] ~A in phase ~A:~%"
+	  id (err-type->banner type) (dynamic *phase*))
+  (dolist (m messages)
+    (apply (function format) *error-output-port* m)
+    (fresh-line *error-output-port*))
+  (maybe-show-context (dynamic *context*))
+  (if (dynamic *in-error-handler?*)
+      (error "Recursive error in haskell-error.")
+      (begin
+        (dynamic-let ((*in-error-handler?*  '#t))
+	  (cond (*break-on-error?*
+		 (haskell-breakpoint))
+		((eq? type 'internal)
+		 (if *never-break?*
+		     (abort-compilation)
+		     (haskell-breakpoint)))
+		((eq? type 'fatal)
+		 (abort-compilation))
+		((eq? type 'phase)
+		 (halt-compilation))))
+	(when (and (memq type '(recoverable phase))
+		   (dynamic *recoverable-error-handler*))
+	  (funcall (dynamic *recoverable-error-handler*)))
+	'ok)))
+
+(define (err-type->banner err-type)
+  (cond ((eq? err-type 'warning)
+	 "Warning")
+	((eq? err-type 'recoverable)
+	 "Recoverable error")
+	((eq? err-type 'phase)
+	 "Phase error")
+	((eq? err-type 'fatal)
+	 "Fatal error")	
+	((eq? err-type 'internal)
+	 "Internal-error")
+	(else "???")))
+
+(define (maybe-show-context context)
+  (when context
+    (with-slots source-pointer (line file) (ast-node-line-number context)
+      (fresh-line *error-output-port*)
+      (format *error-output-port* "Error occurred at line ~A in file ~A.~%"
+         line (filename-name file)))))
+
+;;; A few entry points into the error system.
+;;; As a matter of convention, there should be a signaling function defined
+;;; for each specific error condition that calls one of these functions.
+;;; Error messages should be complete sentences with proper punctuation
+;;; and capitalization.  The signaling function should use the message
+;;; to report the error and not do any printing of its own.
+
+(define (fatal-error id . msg)
+ (haskell-error id 'fatal (list msg)))
+
+(define (haskell-warning id . msg)
+ (haskell-error id 'warning (list msg)))
+
+(define (recoverable-error id . msg)
+ (haskell-error id 'recoverable (list msg)))
+
+(define (compiler-error id . msg)
+ (haskell-error id 'internal (list msg)))
+
+(define (phase-error id . msg)
+ (haskell-error id 'phase (list msg)))
+
+;;; This function puts the compiler into the lisp breakloop.  this may
+;;; want to fiddle the programming envoronment someday.
+
+(define (haskell-breakpoint)
+ (error "Haskell breakpoint."))
+
+
+;;; This deals with error at runtime
+
+(define (haskell-runtime-error msg)
+  (format '#t "~&Haskell runtime abort.~%~A~%" msg)
+  (funcall (dynamic *runtime-abort*)))
+
+;; Some common error handlers
+
+(define (signal-unknown-file-type filename)
+  (fatal-error 'unknown-file-type
+    "The filename ~a has an unknown file type."
+    filename))
+
+(define (signal-file-not-found filename)
+  (fatal-error 'file-not-found
+    "The file ~a doesn't exist."
+    filename))
+                                                       
diff --git a/top/globals.scm b/top/globals.scm
new file mode 100644
index 0000000..eba139b
--- /dev/null
+++ b/top/globals.scm
@@ -0,0 +1,75 @@
+;;; These are global variables used throughout the compiler.
+
+;;; Configuration stuff
+
+(define *prelude-unit-filename* "$PRELUDE/Prelude.hu")
+
+(define *haskell-compiler-version* "Y2.0.5")
+(define *haskell-compiler-update* "")
+
+
+;;; Control over the init process
+(define *haskell-initialized?* '#f)
+
+;;; Error control
+(define *break-on-error?* '#f)
+(define *never-break?* '#f)
+
+(define *runtime-abort* '())
+
+(define *recoverable-error-handler* '())
+(define *error-output-port* '())  ; initialized later
+
+(define *context* '#f)  ; ast node being compiled.
+
+(define *unit* '())
+
+(define *standard-module-default* '())
+
+(define *undefined-def* '())
+(define *printer-class* '())
+(define *printers* '(phase-time))
+
+(define *all-printers*
+  '(phase-time time compiling loading reading extension
+    parse import type-decl scope depend
+    type cfn depend2
+    flic optimize optimize-extra strictness codegen codegen-flic
+    dumper dump-stat))
+
+;;; Global context stuff 
+;;; ***This variable is actually only used by the parser.
+
+(define *current-file* '())
+
+(define *printed-tyvars* '())
+
+
+;;; Used by the symbol table routines
+
+(define *modules* '())  ; maps module name -> module structure
+(define *module* '())   ; current module
+(define *module-name* '())
+(define *symbol-table* '())  ; part of the current module
+(define *inverted-symbol-table* '())  ; maps def -> localname
+(define *fixity-table* '())  ; name -> fixity
+(define *suffix-table* '())  ; name -> int (for uniquifying names)
+
+(define *special-parse-for-type-macros* '#f)
+
+;;; These are for diagnostic purposes only
+
+(define *big-let* '())
+
+(define *show-end-of-phase* '#f)
+
+;;; This is used to configure error messages & responses.
+
+(define *emacs-mode* '#f)
+
+;;; This is used to stash the Prelude symbol environment
+
+(define *prelude-symbol-table* '())
+(define *prelude-fixity-table* '())
+(define *prelude-inverted-symbol-table* '())
+
diff --git a/top/has-macros.scm b/top/has-macros.scm
new file mode 100644
index 0000000..2c75730
--- /dev/null
+++ b/top/has-macros.scm
@@ -0,0 +1,57 @@
+;;; General macros for the Haskell compiler
+
+(define-syntax (remember-context exp . body)
+  (let ((temp  (gensym)))
+    `(let ((,temp  ,exp))
+       (dynamic-let ((*context* (if (ast-node-line-number ,temp)
+				    ,temp 
+				    (dynamic *context*))))
+         ,@body))))
+
+(define-syntax (maybe-remember-context exp . body)
+  (let ((temp  (gensym)))
+    `(let ((,temp  ,exp))
+       (if (ast-node-line-number ,temp)
+	   (dynamic-let ((*context* ,temp)) ,@body)
+	   (begin ,@body)))))
+
+(define-syntax (recover-errors error-value . body)
+  (let ((local-handler (gensym)))
+    `(let/cc ,local-handler
+       (dynamic-let ((*recoverable-error-handler*
+		       (lambda () (funcall ,local-handler ,error-value))))
+         ,@body))))
+
+;;; This is for iterating a list of contexts over a list of types.
+
+(define-syntax (do-contexts cbinder tbinder . body)
+  (let ((cvar (car cbinder))
+	(cinit (cadr cbinder))
+	(tvar (car tbinder))
+	(tinit (cadr tbinder))
+	(cv (gensym))
+	(tv (gensym)))
+    `(do ((,cv ,cinit (cdr ,cv))
+	  (,tv ,tinit (cdr ,tv)))
+	 ((null? ,cv))
+       (let ((,tvar (car ,tv)))
+	 (dolist (,cvar (car ,cv))
+	   ,@body)))))
+
+;; dolist for 2 lists at once.
+
+(define-syntax (dolist2 a1 a2 . body)
+  (let ((a1var (car a1))
+	(a1init (cadr a1))
+	(a2var (car a2))
+	(a2init (cadr a2))
+	(a1l (gensym))
+	(a2l (gensym)))
+    `(do ((,a1l ,a1init (cdr ,a1l))
+	  (,a2l ,a2init (cdr ,a2l)))
+	 ((null? ,a1l))
+       (let ((,a1var (car ,a1l))
+	     (,a2var (car ,a2l)))
+	 ,@body))))
+
+  
\ No newline at end of file
diff --git a/top/has-utils.scm b/top/has-utils.scm
new file mode 100644
index 0000000..62a0c3f
--- /dev/null
+++ b/top/has-utils.scm
@@ -0,0 +1,21 @@
+;;; These utilities are specific to the Haskell language.
+
+(define (add-con-prefix str)  ; should be in some utility file
+  (string-append ";" str))
+
+(define (remove-con-prefix string)
+  (substring string 1 (string-length string)))
+
+(define (has-con-prefix? string)
+  (char=? (string-ref string 0) '#\;))
+
+(define (add-con-prefix/symbol sym)
+  (string->symbol (add-con-prefix (symbol->string sym))))
+
+(define (remove-con-prefix/symbol sym)
+  (string->symbol (remove-con-prefix (symbol->string sym))))
+
+(define (has-con-prefix/symbol? sym)
+  (has-con-prefix? (symbol->string sym)))
+
+
diff --git a/top/phases.scm b/top/phases.scm
new file mode 100644
index 0000000..706c541
--- /dev/null
+++ b/top/phases.scm
@@ -0,0 +1,226 @@
+
+;;; This is the top-level phase structure of the compiler.
+
+;;; Compilation phase support
+
+(define *phase* '#f)
+(define *abort-phase* '#f)         ; abort when this phase completes
+(define *abort-compilation*
+  (lambda ()
+    (error "No error continuation defined here!")))
+
+(define *module-asts* '())   ; a global only for debugging purposes
+
+;;; Later add the printing and timing stuff here
+
+(define-local-syntax (phase-body phase-name body printer)
+  `(dynamic-let ((*phase*       ',phase-name))
+     (when (memq ',phase-name (dynamic *printers*))
+       (format '#t "~%Phase ~a:~%" ',phase-name)
+       (force-output))
+     (let* ((phase-start-time (get-run-time))
+	    (result ,body)
+	    (current-time  (get-run-time)))
+       (when (eq? (dynamic *abort-phase*) ',phase-name)
+	 (abort-compilation))
+       ,@(if (eq? printer '#f)
+	     '()
+	     `((when (memq ',phase-name (dynamic *printers*))
+		 (funcall ,printer result)
+		 (force-output))))
+       (when (memq 'phase-time *printers*)
+	 (let ((elapsed-time (- current-time phase-start-time)))
+	   (format '#t "~&~A complete: ~A seconds~%"
+		   ',phase-name elapsed-time)
+	   (force-output)))
+       result)))
+
+
+
+;;; Returns 2 values: module ast's and lisp code.
+
+(define (compile-haskell-files files)
+  (dynamic-let ((*abort-phase*                '#f))
+     (let ((all-mods       (haskell-parse-files files))
+	   (interface-mods '())
+	   (regular-mods   '()))
+       (dolist (m all-mods)
+	 (if (eq? (module-type m) 'interface)
+	     (push m interface-mods)
+	     (push m regular-mods)))
+       (dynamic-let ((*unit*  (module-name (car all-mods))))
+	 (values
+	   all-mods
+	   `(begin
+	      ,(if interface-mods
+		   (compile-interface-modules (nreverse interface-mods))
+		   '#f)
+	      ,(if regular-mods
+		   (compile-modules (nreverse regular-mods))
+		   '#f))
+	   )))))
+
+
+
+(define (compile-modules mods)
+  (dynamic-let ((*context*                    '#f)
+		(*recoverable-error-handler*  '#f)
+		(*abort-phase*                '#f)
+		(*unique-name-counter*        1)
+		(*suffix-table*               (make-table)))
+  	  (haskell-import-export mods '#f)
+	  (haskell-process-type-declarations mods)
+	  (haskell-scope mods)
+	  (let ((big-let (haskell-dependency-analysis mods)))
+	    (cond ((not (void? big-let))
+		   (haskell-type-check big-let mods)
+		   (setf big-let (haskell-cfn big-let))
+		   (setf big-let (haskell-dependency-reanalysis big-let))
+		   (setf big-let (haskell-ast-to-flic big-let))
+		   (setf big-let (haskell-optimize big-let))
+		   (setf big-let (haskell-strictness big-let))
+		   (haskell-codegen big-let mods))
+		  (else
+		   ''#f)
+		  ))))
+
+
+(define (modules->lisp-code modules)
+  (dynamic-let ((*unit* (module-name (car modules))))
+    (compile-modules modules)))
+
+
+(predefine (notify-error))  ; in command-interface/command-utils.scm
+
+(define (abort-compilation)
+  (notify-error)
+  (funcall (dynamic *abort-compilation*)))
+
+(define (halt-compilation)
+  (setf (dynamic *abort-phase*) (dynamic *phase*)))
+
+
+;;; Here are the actual phase bodies
+
+(predefine (parse-files files))
+
+(define (haskell-parse-files filenames)
+  (phase-body parse
+    (let ((mods (parse-files filenames)))
+      mods)
+    #f))
+
+(predefine (import-export modules))  ; in import-export/import-export.scm
+(predefine (import-export/interface modules))
+
+(define (haskell-import-export modules interface?)
+  (phase-body import
+    (if interface?
+	(import-export/interface modules)
+	(import-export modules))
+    #f))
+
+
+(predefine (process-type-declarations modules)) 
+    ; in tdecl/type-declaration-analysis.scm
+
+(define (haskell-process-type-declarations modules)
+  (phase-body type-decl
+    (begin
+      (process-type-declarations modules))
+    #f))
+
+
+(predefine (scope-modules x))  ; in prec/scope.scm
+(predefine (print-full-module x . maybe-stream)) ; in the printers
+
+(define (haskell-scope modules)
+  (phase-body scope
+    (scope-modules modules)
+    (lambda (result)
+      (declare (ignore result))
+      (dolist (m modules) (print-full-module m)))
+    ))
+
+
+(predefine (do-dependency-analysis x))  ; in depend/dependency-analysis.scm
+
+(define (haskell-dependency-analysis modules)
+  (phase-body depend
+    (do-dependency-analysis modules)
+    (function pprint*)))
+
+
+(predefine (do-haskell-type-check big-let mods))
+
+(define (haskell-type-check big-let modules)
+  (phase-body type
+    (do-haskell-type-check big-let modules)
+    #f))
+
+(predefine (cfn-ast x))  ; in cfn/main.scm
+
+(define (haskell-cfn big-let)
+  (phase-body cfn
+    (cfn-ast big-let)
+    (function pprint*)))
+
+
+(predefine (analyze-dependency-top x))  ; in depend/dependency-analysis.scm
+
+(define (haskell-dependency-reanalysis big-let)
+  (phase-body depend2
+    (begin
+      (analyze-dependency-top big-let)
+      big-let)
+    (function pprint*)))
+
+
+(predefine (ast-to-flic x))		; in flic/ast-to-flic.scm
+
+(define (haskell-ast-to-flic big-let)
+  (phase-body flic
+    (ast-to-flic big-let)
+    (function pprint*)))
+
+
+(predefine (optimize-top x))  ; in backend/optimize.scm
+
+(define (haskell-optimize big-let)
+  (phase-body optimize
+    (optimize-top big-let)
+    (function pprint*)))
+
+(predefine (strictness-analysis-top x)) ; in backend/strictness.scm
+(predefine (strictness-analysis-printer x))
+
+(define (haskell-strictness big-let)
+  (phase-body strictness
+    (strictness-analysis-top big-let)
+    (function strictness-analysis-printer)))
+
+
+(predefine (codegen-top x))  ; in backend/codegen.scm
+(predefine (codegen-exported-types x)) ; "
+(predefine (codegen-prim-entries x))  ; ditto
+
+(define (haskell-codegen big-let mods)
+  (phase-body codegen
+    `(begin
+       ,(codegen-exported-types mods)
+       ,(codegen-top big-let))
+    #f))
+
+	       
+;;; This is for interface modules.
+
+(predefine (haskell-codegen/interface mods))
+
+(define (compile-interface-modules mods)
+ (dynamic-let ((*context*                    '#f)
+	       (*recoverable-error-handler*  '#f)
+	       (*abort-phase*                '#f))
+     (haskell-import-export mods '#t)
+     (haskell-process-type-declarations mods)
+     (haskell-scope mods)
+     (haskell-codegen/interface mods)))
diff --git a/top/prelude-core-syms.scm b/top/prelude-core-syms.scm
new file mode 100644
index 0000000..ddae21f
--- /dev/null
+++ b/top/prelude-core-syms.scm
@@ -0,0 +1,57 @@
+;;; This should be used to create core symbols for every name exported
+;;; by PreludeCore.  This only needs to run when the Prelude definition
+;;; changes.  
+
+(define (def->name-string x)
+  (symbol->string (def-name x)))
+
+
+(define (generate-prelude-core-symbols)
+  (initialize-compilation)
+  (load-compilation-unit *prelude-unit-filename* '#t '#f '#f '#f)
+  (let* ((core (table-entry *modules* '|PreludeCore|))
+	 (export-table (module-export-table core))
+	 (vars '())
+	 (classes '())
+	 (types '())
+	 (constrs '())
+	 (syns '())
+	 (methods '()))
+    (table-for-each
+      (lambda (k v)
+	(declare (ignore k))
+	(let ((def (tuple-2-2 (car v))))
+	  (cond ((var? def)
+		 (push (def->name-string def) vars))
+		((synonym? def)
+		 (push (def->name-string def) syns))
+		((algdata? def)
+		 (push (def->name-string def) types)
+		 (dolist (x (cdr v))
+		     (push (remove-con-prefix (def->name-string (tuple-2-2 x)))
+			   constrs)))
+		((class? def)
+		 (push (def->name-string def) classes)
+		 (dolist (x (cdr v))
+		     (push (def->name-string (tuple-2-2 x))
+			   methods)))
+		(else (error "? strange def")))))
+      export-table)
+  (call-with-output-file "/tmp/prelude-syms"
+      (lambda (port)
+	(pprint `(define *haskell-prelude-vars*
+		   '((classes ,@classes)
+		     (methods ,@methods)
+		     (types ,@types)
+		     (constructors ,@constrs)
+		     (synonyms ,@syns)
+		     (values ,@vars)))
+		port)))))
+
+
+
+(define (create-prelude-init-code defs)
+  (let* ((name (def-name def))
+	 (sym-name (make-core-symbol-name name)))
+    `(define sym-name '())))
+
diff --git a/top/symbol-table.scm b/top/symbol-table.scm
new file mode 100644
index 0000000..499bfb8
--- /dev/null
+++ b/top/symbol-table.scm
@@ -0,0 +1,412 @@
+;;; These routines deal with the global symbol table.  The symbol table
+;;; is represented in two stages: a module table which maps module names
+;;; onto module structures and local tables within each module which
+;;; map names (symbols) to definitions.
+
+;;; The following functions deal with the module table (*modules*):
+
+;;;  (initialize-module-table) - this clears out all modules from the
+;;;      symbol table.  Every compilation should start with this.
+;;;  (add-module-to-module-table module) - this takes a module ast,
+;;;      either from a .exp file or previous compilation with the same
+;;;      incarnation of the compiler and adds it to the set of `known'
+;;;      modules.  Incomplete module ast's in the process of compilation
+;;;      are also added to this table.
+
+
+(define (initialize-module-table)
+  (setf *modules* (make-table)))
+
+(define (add-module-to-symbol-table module)
+  (let* ((name (module-name module))
+	 (old-module (table-entry *modules* name)))
+    (when (not (eq? old-module '#f))
+      (if (eq? *unit* (module-unit old-module))
+	  (signal-module-double-definition name)
+	  (signal-module-already-defined name)))
+    (setf (table-entry *modules* name) module)))
+
+(define (remove-module-from-symbol-table module)
+  (let ((name (module-name module)))
+    (setf (table-entry *modules* name) '#f)))
+
+(define (locate-module name)
+  (table-entry *modules* name))
+
+;;;  (walk-modules fn mod-list) - this calls fn for each module in the
+;;;      mod-list.  It also binds the global variable *module* to the
+;;;      current module, *symbol-table* to the local symbol
+;;;      table.  The fixity table is also placed in a global.
+
+(define (walk-modules mods fn)
+  (dolist (mod mods)
+    (dynamic-let ((*module* mod)
+		  (*module-name* (module-name mod))
+		  (*symbol-table* (module-symbol-table mod))
+		  (*fixity-table* (module-fixity-table mod))
+		  (*inverted-symbol-table* (module-inverted-symbol-table mod)))
+       (funcall fn))))
+
+;;; create-definition makes a new definition object 
+
+(define (create-definition module name type)
+  (cond ((module-prelude? module)
+	 (let ((def (table-entry *core-symbols* name)))
+	   (cond ((eq? def '#f)
+		  (create-definition/non-core module name type))
+		 (else
+		  (setf (def-unit def) *unit*)
+		  (setf (def-module def) (module-name module))
+		  ;; *** Should any other properties be reinitialized here?
+		  (cond ((or (eq? type 'var) (eq? type 'method-var))
+			 (setf (var-fixity def) '#f)
+			 (setf (var-signature def) '#f))
+			((eq? type 'con)
+			 (setf (con-fixity def) '#f)))
+		  def))))
+	(else (create-definition/non-core module name type))))
+
+;(define (create-definition/non-core module name type)
+;  (create-definition/new module name type)
+;      (let* ((interface (module-interface-module module))
+;	     (old-def (table-entry (module-symbol-table interface) name)))
+;	(if (eq? old-def '#f)
+;	    (create-definition/new module name type)
+;	    (cond ((eq? type 'var)
+;		   (unless (var? old-def)	
+;		       (def-conflict module name type old-def))
+;		   (setf (var-interface-type old-def) (var-type old-def)))
+;		  ((eq? type 'con)
+;		   (unless (con? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'synonym)
+;		   (unless (synonym? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'algdata)
+;		   (unless (algdata? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'class)
+;		   (unless (class? old-def)
+;		      (def-conflict module name type old-def)))
+;		  ((eq? type 'method-var)
+;		   (unless (method-var? old-def)
+;		      (def-conflict module name type old-def)))))
+;	(setf (def-unit old-def) *unit*)
+;	old-def)))
+;
+;(define (def-conflict module name type def)
+;  (phase-error 'interface-conflict
+;    "The ~A ~A in module ~A was defined as a ~A in an interface."
+;    (cond ((var? def) "variable")
+;	  ((class? def) "class")
+;	  ((algdata? def) "data type")
+;	  ((synonym? def) "synonym")
+;	  ((con? def) "constructor")
+;	  (else "widgit"))
+;    name (module-name module) type))    
+
+(define (create-definition/non-core module name type)
+  (let ((mname  (module-name module)))
+    (when (eq? (module-type *module*) 'interface)
+       (mlet (((mod name1) (rename-interface-symbol name)))
+         (setf mname mod)
+	 (setf name name1)))
+    (create-definition/inner mname name type)))
+
+(define (create-definition/inner mname name type)
+    (cond ((eq? type 'var)
+	   (make var (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'con)
+	   (make con (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'synonym)
+	   (make synonym (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'algdata)
+	   (make algdata (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'class)
+	   (make class (name name) (module mname) (unit *unit*)))
+	  ((eq? type 'method-var)
+	   (make method-var (name name) (module mname) (unit *unit*)))
+	  (else
+	   (error "Bad type argument ~s." type))))
+
+
+(define (create-top-definition name type)
+  (let ((def (create-definition *module* name type)))
+    (insert-top-definition name def)
+    def))
+
+;;; Interfaces have a special table which resolves imports in the
+;;; interface.  Given a name in an interface module this returns the
+;;; corresponding full name: a (module,original-name) pair.  Symbols not
+;;; imported are assumed to be defined in the interface.
+
+(define (rename-interface-symbol name)
+  (let ((res (assq name (module-interface-imports *module*))))
+    (if (eq? res '#f)
+	(values *module-name* name)
+	(values (tuple-2-1 (tuple-2-2 res))
+		(tuple-2-2 (tuple-2-2 res))))))
+
+;;; This creates a locally defined var node.
+
+(define (create-local-definition name)
+  (let ((var     (make var (name name) (module *module-name*) (unit *unit*))))
+    (setf (var-fixity var) (table-entry *fixity-table* name))
+    var))
+
+
+;;; This function creates a new variable. 
+;;; The "root" may be either a symbol or a string.
+;;; *unit* defines the home module of the variable.
+
+;;; *** Maybe it would be possible to hack this so that it doesn't
+;;; *** create any symbol at all until the name is demanded by something,
+;;; *** but that seems like a rather sweeping change.
+
+(define (create-temp-var root)
+  (let* ((name   (gensym (if (symbol? root) (symbol->string root) root)))
+	 (module  *unit*))
+    (make var (name name) (module module) (unit *unit*))))
+
+
+;;; The following routines install top level definitions into the symbol
+;;; table.
+
+(predefine (signal-multiple-name-conflict name old-local-name def))
+    ; in import-export/ie-errors.scm
+
+(define (insert-top-definition name def)
+  (let ((old-definition (resolve-toplevel-name name)))
+    (cond ((eq? old-definition '#f)
+	   (when (not (def-prelude? def))
+	       (setf (table-entry *symbol-table* name) def))
+	   (when (and (var? def) (not (eq? (var-fixity def) '#f)))
+             (setf (table-entry *fixity-table* name)
+		   (var-fixity def)))
+	   (when (and (con? def) (not (eq? (con-fixity def) '#f)))
+             (setf (table-entry *fixity-table* name)
+		   (con-fixity def)))
+	   (when (not (def-prelude? def))
+ 	    (if (eq? (local-name def) '#f)
+		(setf (table-entry *inverted-symbol-table* def) name)
+		(signal-multiple-name-conflict name (local-name def) def))))
+	  ((eq? old-definition def)
+	   'OK)
+	  ((def-prelude? old-definition)
+	   (signal-core-redefinition name))
+	  ((and (module-uses-standard-prelude? *module*)
+		(table-entry *prelude-symbol-table* name))
+	   (if (eq? (def-module def) *module-name*)
+	       (signal-prelude-redefinition name)
+	       (signal-prelude-reimport name (def-module def))))
+	  ((eq? (def-module def) *module-name*)
+	   (signal-multiple-definition-in-module name *module-name*))
+	  ((eq? (def-module old-definition) *module-name*)
+	   (signal-redefinition-by-imported-symbol name *module-name*))
+	  (else
+	   (signal-multiple-import name *module-name*)))))
+
+;;; Gets the fixity of a name.
+
+(define (get-local-fixity name)
+  (table-entry *fixity-table* name))
+
+;;; These routines support general scoping issues.  Only vars have local
+;;; definitions - all other names are resolved from the global symbol table.
+
+;;; This is used when the name must be in the top symbols.
+
+(define (fetch-top-def name type)
+  (let ((def (resolve-toplevel-name name)))
+    (cond ((eq? def '#f)
+	   (cond ((eq? (module-type *module*) 'interface)
+		  (mlet (((mod name1) (rename-interface-symbol name)))
+		    (if (eq? mod *module-name*)
+			(undefined-topsym name)
+			(let ((new-def (create-definition/inner
+					mod name1 type)))
+			  (insert-top-definition name1 new-def)
+			  (cond ((algdata? new-def)
+				 (setf (algdata-n-constr new-def) 0)
+				 (setf (algdata-constrs new-def) '())
+				 (setf (algdata-context new-def) '())
+				 (setf (algdata-tyvars new-def) '())
+				 (setf (algdata-classes new-def) '#f)
+				 (setf (algdata-enum? new-def) '#f)
+				 (setf (algdata-tuple? new-def) '#f)
+				 (setf (algdata-real-tuple? new-def) '#f)
+				 (setf (algdata-deriving new-def) '()))
+				((class? new-def)
+				 (setf (class-method-vars new-def) '())
+				 (setf (class-super new-def) '())
+				 (setf (class-super* new-def) '())
+				 (setf (class-tyvar new-def) '|a|)
+				 (setf (class-instances new-def) '())
+				 (setf (class-kind new-def) 'other)
+				 (setf (class-n-methods new-def) 0)
+				 (setf (class-dict-size new-def) 0)
+				 (setf (class-selectors new-def) '()))) 
+			  new-def))))
+		 (else
+		  (undefined-topsym name))))
+	  (else def))))
+
+(define (undefined-topsym name)
+  (signal-undefined-symbol name)
+  *undefined-def*)
+
+
+(define (resolve-toplevel-name name)
+  (let ((pc (table-entry *prelude-core-symbols* name)))
+    (cond ((not (eq? pc '#f))
+	   pc)
+	  ((module-uses-standard-prelude? *module*)
+	   (let ((res (table-entry *prelude-symbol-table* name)))
+	     (if (eq? res '#f)
+		 (resolve-toplevel-name-1 name)
+		 res)))
+	  (else
+	   (resolve-toplevel-name-1 name)))))
+
+(define (resolve-toplevel-name-1 name)
+  (cond ((eq? (module-inherited-env *module*) '#f)
+	 (table-entry *symbol-table* name))
+	(else
+	 (let ((res (search-inherited-tables
+		     name (module-inherited-env *module*))))
+	   (if (eq? res '#f)
+	       (table-entry *symbol-table* name)
+	       res)))))
+
+(define (search-inherited-tables name mod)
+  (if (eq? mod '#f)
+      '#f
+      (let ((res (table-entry (module-symbol-table mod) name)))
+	(if (eq? res '#f)
+	    (search-inherited-tables name (module-inherited-env mod))
+	    res))))
+
+;;; Con-ref's are special in that the naming convention (;Name) ensures
+;;; that if a def is found it must be a con.
+
+(define (resolve-con con-ref)
+  (when (eq? (con-ref-con con-ref) *undefined-def*)
+    (remember-context con-ref
+      (let ((def (fetch-top-def (con-ref-name con-ref) 'con)))
+	(setf (con-ref-con con-ref) def)))))
+
+(define (resolve-class class-ref)
+  (when (eq? (class-ref-class class-ref) *undefined-def*)
+    (remember-context class-ref
+      (let ((def (fetch-top-def (class-ref-name class-ref) 'class)))
+	(when (not (class? def))
+	  (signal-class-name-required def (class-ref-name class-ref)))
+	(setf (class-ref-class class-ref) def)))))
+
+
+(define (resolve-tycon tycon)
+  (when (eq? (tycon-def tycon) *undefined-def*)
+    (remember-context tycon
+      (let ((def (fetch-top-def (tycon-name tycon) 'algdata)))
+	(when (class? def)
+	  (signal-tycon-name-required (tycon-name tycon)))
+	(setf (tycon-def tycon) def)))))
+
+
+;;; This should be used after the local environment has been searched.
+;;; Other routines dealing with variable scoping are elsewhere.
+
+(define (resolve-var var-ref)
+  (when (eq? (var-ref-var var-ref) *undefined-def*)
+    (remember-context var-ref
+      (let ((def (fetch-top-def (var-ref-name var-ref) 'var)))
+	(setf (var-ref-var var-ref) def)))))
+
+
+;;; *** The inverted-symbol-table is the only table in the whole
+;;; *** system that is not keyed off of symbols.  If this is a problem,
+;;; *** things that use it could probably be rewritten to do something
+;;; *** else, like store an a-list on the def itself.
+
+;;; This does not need to consult the inherited-env flag because when this
+;;; is used in extensions only new symbols get inserted.
+
+(define (local-name def)
+  (cond ((def-prelude? def)
+	 (def-name def))
+	((module-uses-standard-prelude? *module*)
+	 (let ((res (table-entry *prelude-inverted-symbol-table* def)))
+	   (if (eq? res '#f)
+	    (table-entry *inverted-symbol-table* def)
+	    res)))
+	(else
+	 (table-entry *inverted-symbol-table* def))))
+    
+(define (print-name x)
+  (let ((res (local-name x)))
+    (if (eq? res '#f)
+	(def-name x)
+	res)))
+
+
+;;; Error signalling routines.
+
+(define (signal-module-double-definition name)
+  (fatal-error 'module-double-definition
+    "Module ~s is defined more than once."
+    name))
+
+(define (signal-module-already-defined name)
+  (fatal-error 'module-already-defined
+    "Module ~a is defined more than once in the current unit."
+    name))
+
+(define (signal-multiple-definition-in-module name modname)
+ (if (eq? (module-type *module*) 'extension)
+     (phase-error 'cant-redefine-in-extension
+        "An extension for module ~A cannot redefine the symbol ~A"
+	modname name)
+     (phase-error 'multiple-definition-in-module
+        "There is more than one definition for the name ~a in module ~a."
+	name modname)))
+
+(define (signal-redefinition-by-imported-symbol name modname)
+  (phase-error 'redefinition-by-imported-symbol
+    "The name ~a is defined in module ~a, and cannot be imported."
+    name modname))
+
+(define (signal-core-redefinition name)
+  (phase-error 'prelude-redefinition
+    "The name ~a is defined in the prelude core and cannot be redefined."
+    name))
+
+(define (signal-prelude-redefinition name)
+  (phase-error 'prelude-redefinition
+    "The name ~a is defined in the prelude.~%You must hide it if you wish to use this name."
+    name))
+
+(define (signal-prelude-reimport name modname)
+  (phase-error 'prelude-redefinition
+    "The name ~a is both imported from ~A and defined in the prelude.~%"
+    name modname))
+
+(define (signal-multiple-import name modname)
+  (phase-error 'multiple-import
+    "The name ~a is imported into module ~a multiple times."
+    name modname))
+
+(define (signal-undefined-symbol name)
+  (phase-error 'undefined-symbol
+    "The name ~A is undefined."
+    name))
+
+(define (signal-class-name-required name def)
+  (phase-error 'class-name-required
+    "The name ~A defines a ~A, but a class name is required."
+    name
+    (if (synonym? def) "synonym" "data type")))
+
+(define (signal-tycon-name-required name)
+  (phase-error 'tycon-required
+    "The name ~A defines a class, but a type constructor name is required."
+    name))
diff --git a/top/system-init.scm b/top/system-init.scm
new file mode 100644
index 0000000..4c06cb5
--- /dev/null
+++ b/top/system-init.scm
@@ -0,0 +1,41 @@
+
+(define (initialize-haskell-system)
+  (when (not *haskell-initialized?*)
+    (initialize-haskell-system/forced))
+  'haskell-ready)
+
+(predefine (**tycon/def def args))  ; in util/constructors.scm
+(predefine (init-cse-structs))      ; in csys/dump-cse.scm
+
+(define (initialize-haskell-system/forced)
+  (setf *haskell-initialized?* '#t)
+  (setf *error-output-port* (current-output-port))
+  (init-core-symbols)
+  (init-tuples)
+  (setf *standard-module-default*
+	(make default-decl
+	      (types (list
+		      (**tycon/def (core-symbol "Int") '())
+		      (**tycon/def (core-symbol "Double") '())))))
+  (setf *undefined-def*
+	(make def
+	      (name '*undefined*)
+	      (unit '*undefined*)
+	      (module '*undefined*)))
+  (setf *printer-class*
+	(make class
+	      (name '|Printers|)
+	      (module '|*Core|) (unit '|*Core|)))
+  (init-cse-structs))
+
+;;; This should be called in the system restart code generated by a
+;;; disk save
+
+(define (load-init-files)
+ (load-init-file "$HASKELL/.yhaskell")
+ (load-init-file "~/.yhaskell"))
+
+(define (load-init-file name)
+  (when (file-exists? name)
+    (load name)))
+
diff --git a/top/top.scm b/top/top.scm
new file mode 100644
index 0000000..1a63923
--- /dev/null
+++ b/top/top.scm
@@ -0,0 +1,46 @@
+;;; top.scm -- compilation unit definition for the top level
+
+;;; Global includes the ast definitions and all global data structures
+;;; used in the compiler.
+
+(define-compilation-unit global
+  (source-filename "$Y2/top/")
+  (require ast)
+  (unit has-utils
+    (source-filename "has-utils.scm"))
+  (unit core-definitions
+    (require has-utils)
+    (source-filename "core-definitions.scm"))
+  (unit core-symbols
+    (require core-definitions)
+    (source-filename "core-symbols.scm"))
+  (unit core-init
+    (require core-symbols)
+    (source-filename "core-init.scm"))
+  (unit globals
+    (require core-init)
+    (source-filename "globals.scm"))
+  (unit has-macros
+    (source-filename "has-macros.scm"))
+  )
+
+
+;;; These files do not need to be required by other units  
+
+(define-compilation-unit top-level
+  (source-filename "$Y2/top/")
+  (require global)
+  (unit phases
+    (source-filename "phases.scm"))
+  (unit system-init
+    (source-filename "system-init.scm"))
+  (unit errors
+    (source-filename "errors.scm"))
+  (unit tuple
+    (source-filename "tuple.scm"))
+  (unit symbol-table
+    (source-filename "symbol-table.scm"))
+  )
+     
+
+
diff --git a/top/tuple.scm b/top/tuple.scm
new file mode 100644
index 0000000..b736ee2
--- /dev/null
+++ b/top/tuple.scm
@@ -0,0 +1,87 @@
+;;; This file creates type definitions for tuples of arbitrary size.
+
+(define *tuple-definitions* '())
+
+(define (init-tuples)
+  (setf *tuple-definitions* '()))
+
+(define (tuple-tycon k)
+  (let ((tycon (assq k *tuple-definitions*)))
+    (if (eq? tycon '#f)
+	(new-tuple-tycon k)
+	(tuple-2-2 tycon))))
+
+(define (tuple-constructor k)
+  (car (algdata-constrs (tuple-tycon k))))
+
+(define (is-tuple-constructor? x)
+  (and (con? x) (is-tuple-tycon? (con-alg x))))
+
+(define (is-tuple-tycon? x)
+  (and (algdata? x) (algdata-real-tuple? x)))
+
+(define (tuple-constructor-arity x)
+  (con-arity x))
+
+(predefine (ast->gtype c t))          ; in util/type-utils.scm
+(predefine (**arrow-type/l args))     ; in util/constructors.scm
+(predefine (**tyvar x))               ; in util/constructors.scm
+
+(define (new-tuple-tycon k)
+  (cond ((eqv? k 0)
+	 (core-symbol "UnitType"))
+	(else
+	 (let* ((name (string->symbol (format '#f "Tuple~A" k)))
+		(cname (string->symbol (format '#f ";MkTuple~A" k)))
+		(dummy-vars (gen-dummy-names k))
+		(algdata (make algdata
+			       (name name)
+			       (module '*core*)
+			       (unit '*core*)
+			       (exported? '#t)
+			       (arity k)
+			       (n-constr 1)
+			       (context '())
+			       (tyvars dummy-vars)
+			       (classes '())  ;; filled in later
+			       (enum? '#f)
+			       (tuple? '#t)
+			       (real-tuple? '#t)
+			       (deriving '())))
+		(constr (make con
+			      (name cname)
+			      (module '*core*)
+			      (unit '*core*)
+			      (exported? '#t)
+			      (arity k)
+			      (types (map (function **tyvar) dummy-vars))
+			      (tag 0)
+			      (alg algdata)
+			      (slot-strict? '())
+			      (infix? '#f)))
+		(tyvars (map (function **tyvar) dummy-vars))
+		(tuple-type (**tycon/def algdata tyvars)))
+	   (dotimes (i k)
+	      (push '#f (con-slot-strict? constr)))
+	   (setf (algdata-signature algdata)
+		 (ast->gtype '() tuple-type))
+	   (setf (con-signature constr)
+		 (ast->gtype '() (**arrow-type/l
+				  (append tyvars (list tuple-type)))))
+	   (setf (algdata-constrs algdata)
+		 (list constr))
+	   (push (tuple k algdata) *tuple-definitions*)
+	   algdata))))
+
+(define (gen-dummy-names n)
+  (gen-dummy-names-1 n '()))
+
+(define (gen-dummy-names-1 n l)
+  (if (eqv? n 0)
+      l
+      (gen-dummy-names-1 (1- n)
+			 (cons (string->symbol (format '#f "a~A" n)) l))))
+
+
+
+