summaryrefslogtreecommitdiff
path: root/top
diff options
context:
space:
mode:
Diffstat (limited to 'top')
-rw-r--r--top/README12
-rw-r--r--top/core-definitions.scm149
-rw-r--r--top/core-init.scm14
-rw-r--r--top/core-symbols.scm126
-rw-r--r--top/errors.scm119
-rw-r--r--top/globals.scm75
-rw-r--r--top/has-macros.scm57
-rw-r--r--top/has-utils.scm21
-rw-r--r--top/phases.scm226
-rw-r--r--top/prelude-core-syms.scm57
-rw-r--r--top/symbol-table.scm412
-rw-r--r--top/system-init.scm41
-rw-r--r--top/top.scm46
-rw-r--r--top/tuple.scm87
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))))
+
+
+
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 00:58:38 +0000