path: root/util/constructors.scm

;;; 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)))))