Import to github.

1 files changed, 339 insertions, 0 deletions

diff --git a/util/constructors.scm b/util/constructors.scm
new file mode 100644
index 0000000..2fa8bd3
--- /dev/null
+++ b/util/constructors.scm
@@ -0,0 +1,339 @@
+;;; This file contains ast construction functions.  These
+;;; functions are supplied for commonly used ast structures to
+;;; avoid the longer `make' normally required.
+
+;;; Function names are the type names with a `**' prefix.  For reference
+;;; nodes, the /def for builds the node from a definition instead of a name.
+
+;;; Note: maybe these should be made automagicly someday.
+
+;;; from exp-structs:
+
+(define (**lambda args body)
+  (**lambda/pat (map (function **pat) args) body))
+
+(define (**lambda/pat pats body)
+  (if (null? pats)
+      body
+      (make lambda (pats pats) (body body))))
+
+
+
+;;; Make a case expression.
+
+(define (**case exp alts)
+  (make case (exp exp) (alts alts)))
+
+(define (**alt/simple pat exp)
+  (**alt pat 
+	 (list (make guarded-rhs
+		     (guard (make omitted-guard))
+		     (rhs exp)))
+	 '()))
+
+(define (**alt pat rhs-list where-decls)
+  (make alt (pat pat) (rhs-list rhs-list) (where-decls where-decls)))
+
+
+
+
+(define (**let decls body)
+  (if decls
+      (make let (decls decls) (body body))
+      body))
+
+(define (**if test then-exp else-exp)
+  (make if (test-exp test) (then-exp then-exp) (else-exp else-exp)))
+
+(define (**app fn . args)  ; any number of args
+  (**app/l fn args))
+
+(define (**app/l fn args)  ; second args is a list
+  (if (null? args)
+      fn
+      (**app/l (make app (fn fn) (arg (car args)))
+	       (cdr args))))
+
+(define (**var name)
+  (make var-ref (name name) (var (dynamic *undefined-def*)) (infix? '#f)))
+
+(define (**var/def def)  ; arg is an entry
+  (make var-ref (var def) (name (def-name def)) (infix? '#f)))
+	    
+(define (**con/def def)
+  (make con-ref (name (def-name def)) (con def) (infix? '#f)))
+
+(define (**int x)
+  (make integer-const (value x)))
+
+(define (**char x)
+  (make char-const (value x)))
+
+(define (**string x)
+  (make string-const (value x)))
+
+(define (**listcomp exp quals)
+  (make list-comp (exp exp) (quals quals)))
+
+(define (**gen pat exp)
+  (make qual-generator (pat (**pat pat)) (exp exp)))
+
+(define (**omitted-guard)
+  (make omitted-guard))
+
+(define (**con-number exp algdata)
+  (make con-number (type algdata) (value exp)))
+
+(define (**sel con exp i)
+  (make sel (constructor con) (value exp) (slot i)))
+
+(define (**is-constructor exp con)
+  (make is-constructor (value exp) (constructor con)))
+
+;;; From valdef-structs
+
+(define (**signdecl vars type)
+  (make signdecl (vars (map (function **var) vars)) (signature type)))
+
+(define (**signdecl/def vars type)
+  (make signdecl (vars (map (function **var/def) vars)) (signature type)))
+
+(define (**define name args val)
+  (**valdef (**pat name) (map (function **pat) args) val))
+
+(define (**valdef/def var exp)
+  (**valdef/pat (**var-pat/def var) exp))
+
+(define (**valdef/pat pat exp)
+  (**valdef pat '() exp))
+
+(define (**valdef lhs args rhs)
+  (make valdef
+	(lhs lhs)
+	(definitions
+	  (list (make single-fun-def
+		      (args args)
+		      (rhs-list
+		        (list (make guarded-rhs
+				    (guard (**omitted-guard))
+				    (rhs rhs))))
+		      (where-decls '())
+		      (infix? '#f))))))
+
+
+;;; Patterns (still in valdef-structs)
+
+;;; The **pat function converts a very simple lisp-style pattern representation
+;;; into corresponding ast structure.  The conversion:
+;;;   a) _ => wildcard
+;;;   b) a symbol => Var pattern
+;;;   c) an integer / string => const pattern
+;;;   d) a list of pats starting with 'tuple => Pcon
+;;;   e) a list of pats starting with a con definition => Pcon
+
+(define (**pat v)
+  (cond ((eq? v '_) (**wildcard-pat))
+	((symbol? v)
+	 (make var-pat (var (**var v))))
+	((var? v)
+	 (make var-pat (var (**var/def v))))
+	((integer? v)
+	 (make const-pat (value (**int v))))
+	((string? v)
+	 (make const-pat (value (**string v))))
+	((and (pair? v) (eq? (car v) 'tuple))
+	 (**pcon/tuple (map (function **pat) (cdr v))))
+	((and (pair? v) (con? (car v)))
+	 (**pcon/def (car v) (map (function **pat) (cdr v))))
+	(else
+	 (error "Bad pattern in **pat: ~A~%" v))))
+
+(define (**pcon name pats)
+  (make pcon (name (add-con-prefix/symbol name))
+	     (con (dynamic *undefined-def*)) (pats pats) (infix? '#f)))
+
+(define (**pcon/def def pats)
+  (make pcon (name (def-name def)) (con def) (pats pats) (infix? '#f)))
+
+(define (**pcon/tuple pats)
+  (**pcon/def (tuple-constructor (length pats)) pats))
+
+;;; Make a variable pattern from the var
+
+(define (**var-pat/def var)
+  (make var-pat
+	(var (**var/def var))))
+
+(define (**wildcard-pat)
+  (make wildcard-pat))
+
+
+;;; Either make a tuple, or return the single element of a list.
+
+(define (**tuple-pat pats)
+  (cond ((null? pats)
+	 (**pcon/def (core-symbol "UnitConstructor") '()))
+	((null? (cdr pats))
+	 (car pats))
+	(else
+	 (**pcon/tuple pats))))
+
+
+;;; From type-structs.scm
+
+(define (**tycon name args)
+  (make tycon (name name) (args args) (def (dynamic *undefined-def*))))
+
+(define (**tycon/def def args)
+  (make tycon (name (def-name def)) (def def) (args args)))
+
+(define (**tyvar name)
+  (make tyvar (name name)))
+
+(define (**signature context type)
+  (make signature (context context) (type type)))
+
+(define (**class/def def)
+  (make class-ref (name (def-name def)) (class def)))
+
+(define (**context tycls tyvar)
+  (make context (class tycls) (tyvar tyvar)))
+
+;;; From tc-structs
+
+(define (**ntyvar)
+  (make ntyvar (value '#f) (context '()) (dict-params '())))
+
+(define (**ntycon tycon args)
+  (make ntycon (tycon tycon) (args args)))
+
+(define (**arrow . args) 
+  (**arrow/l args))
+
+(define (**arrow/l args)
+  (if (null? (cdr args))
+      (car args)
+      (**ntycon (core-symbol "Arrow")
+		(list (car args) (**arrow/l (cdr args))))))
+
+(define (**arrow/l-2 args final-val)
+  (if (null? args)
+      final-val
+      (**ntycon (core-symbol "Arrow")
+		(list (car args) (**arrow/l-2 (cdr args) final-val)))))
+
+(define (**list-of arg)
+  (**ntycon (core-symbol "List") (list arg)))
+
+(define (**recursive-placeholder var edecls)
+  (make recursive-placeholder (var var) (exp '#f)
+	(enclosing-decls edecls)))
+
+(define (**dict-placeholder class tyvar edecls var)
+  (make dict-placeholder
+	(class class) (exp '#f) (overloaded-var var)
+	(tyvar tyvar) (enclosing-decls edecls)))
+
+(define (**method-placeholder method tyvar edecls var)
+  (make method-placeholder
+	(method method) (exp '#f) (overloaded-var var)
+	(tyvar tyvar) (enclosing-decls edecls)))
+
+;;; Some less primitive stuff
+
+(define (**tuple-sel n i exp)  ;; 0 <= i < n
+  (if (eqv? n 1)
+      exp
+      (**sel (tuple-constructor n) exp i)))
+
+(define (**abort msg)
+  (**app (**var/def (core-symbol "error"))
+	 (**string msg)))
+
+(define (**tuple/l args)
+  (cond ((null? args)
+	 (**con/def (core-symbol "UnitConstructor")))
+	((null? (cdr args))
+	 (car args))
+	(else
+	 (**app/l (**con/def (tuple-constructor (length args)))
+		  args))))
+
+(define (**tuple . args)
+  (**tuple/l args))
+
+(define (**tuple-type/l args)
+  (cond ((null? args)
+	 (**tycon/def (core-symbol "UnitConstructor") '()))
+	((null? (cdr args))
+	 (car args))
+	(else
+	 (**tycon/def (tuple-tycon (length args)) args))))
+
+(define (**tuple-type . args)
+  (**tuple-type/l args))
+
+(define (**arrow-type . args)
+  (**arrow-type/l args))
+
+(define (**arrow-type/l args)
+  (if (null? (cdr args))
+      (car args)
+      (**tycon/def (core-symbol "Arrow") (list (car args)
+					       (**arrow-type/l (cdr args))))))
+
+(define (**fromInteger x)
+  (**app (**var/def (core-symbol "fromInteger")) x))
+
+(define (**fromRational x)
+  (**app (**var/def (core-symbol "fromRational")) x))
+
+(define (**gtyvar n)
+  (make gtyvar (varnum n)))
+
+(define (**gtype context type)
+  (make gtype (context context) (type type)))
+
+(define (**fixity a p)
+  (make fixity (associativity a) (precedence p)))
+
+(define (**ntycon/tuple . args)
+  (let ((arity  (length args)))
+    (**ntycon (tuple-tycon arity) args)))
+
+(define (**ntycon/arrow . args)
+  (**ntycon/arrow-l args))
+
+(define (**ntycon/arrow-l args)
+  (let ((arg (if (integer? (car args))
+		 (**gtyvar (car args))
+		 (car args))))
+    (if (null? (cdr args))
+	arg
+	(**arrow arg (**ntycon/arrow-l (cdr args))))))
+
+(define (**save-old-exp old new)
+  (make save-old-exp (old-exp old) (new-exp new)))
+
+
+
+;;; These are used by the CFN.
+
+(define (**case-block block-name exps)
+  (make case-block
+	(block-name block-name)
+	(exps exps)))
+
+(define (**return-from block-name exp)
+  (make return-from
+	(block-name block-name)
+	(exp exp)))
+
+(define (**and-exp . exps)
+  (cond ((null? exps)
+	 (**con/def (core-symbol "True")))
+	((null? (cdr exps))
+	 (car exps))
+	(else
+	 (make and-exp (exps exps)))))
+