summaryrefslogtreecommitdiff
path: root/util
diff options
context:
space:
mode:
Diffstat (limited to 'util')
-rw-r--r--util/README2
-rw-r--r--util/annotation-utils.scm41
-rw-r--r--util/constructors.scm339
-rw-r--r--util/haskell-utils.scm22
-rw-r--r--util/instance-manager.scm161
-rw-r--r--util/pattern-vars.scm40
-rw-r--r--util/prec-utils.scm115
-rw-r--r--util/signature.scm90
-rw-r--r--util/type-utils.scm308
-rw-r--r--util/walk-ast.scm156
10 files changed, 1274 insertions, 0 deletions
diff --git a/util/README b/util/README
new file mode 100644
index 0000000..a39e4bc
--- /dev/null
+++ b/util/README
@@ -0,0 +1,2 @@
+This directory contains random utilities that are used in various places
+around the compiler.
diff --git a/util/annotation-utils.scm b/util/annotation-utils.scm
new file mode 100644
index 0000000..8e2baf2
--- /dev/null
+++ b/util/annotation-utils.scm
@@ -0,0 +1,41 @@
+
+;;; Some general utilities for dealing with annotations
+
+;;; Lookup an annotation on a var
+
+(define (lookup-annotation var aname)
+ (lookup-annotation-1 (var-annotations var) aname))
+
+(define (lookup-annotation-1 a aname)
+ (if (null? a)
+ '#f
+ (if (eq? aname (annotation-value-name (car a)))
+ (car a)
+ (lookup-annotation-1 (cdr a) aname))))
+
+;;; This parses a string denoting a strictness property into a list
+;;; of booleans. "S,N,S" -> (#t #f #t)
+
+(define (parse-strictness str)
+ (parse-strictness-1 str 0))
+
+(define (parse-strictness-1 str i)
+ (if (>= i (string-length str))
+ (signal-bad-strictness-annotation str)
+ (let* ((ch (char-downcase (string-ref str i)))
+ (s (cond ((char=? ch '#\s)
+ '#t)
+ ((char=? ch '#\n)
+ '#f)
+ (else
+ (signal-bad-strictness-annotation str)))))
+ (cond ((eqv? (1+ i) (string-length str))
+ (list s))
+ ((char=? (string-ref str (1+ i)) '#\,)
+ (cons s (parse-strictness-1 str (+ i 2))))
+ (else
+ (signal-bad-strictness-annotation str))))))
+
+(define (signal-bad-strictness-annotation str)
+ (fatal-error 'bad-strictness "Bad strictness annotation: ~A~%" str))
+
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)))))
+
diff --git a/util/haskell-utils.scm b/util/haskell-utils.scm
new file mode 100644
index 0000000..c851cda
--- /dev/null
+++ b/util/haskell-utils.scm
@@ -0,0 +1,22 @@
+(define-compilation-unit haskell-utils
+ (source-filename "$Y2/util/")
+ (require global)
+ (unit constructors
+ (source-filename "constructors.scm"))
+ (unit prec-utils
+ (source-filename "prec-utils.scm"))
+ (unit walk-ast
+ (source-filename "walk-ast.scm"))
+ (unit pattern-vars
+ (source-filename "pattern-vars.scm")
+ (require walk-ast))
+ (unit instance-manager
+ (source-filename "instance-manager.scm"))
+ (unit signature
+ (source-filename "signature.scm"))
+ (unit type-utils
+ (source-filename "type-utils.scm"))
+ (unit annotation-utils
+ (source-filename "annotation-utils.scm"))
+ )
+
diff --git a/util/instance-manager.scm b/util/instance-manager.scm
new file mode 100644
index 0000000..231e27d
--- /dev/null
+++ b/util/instance-manager.scm
@@ -0,0 +1,161 @@
+
+;;; This file has some random utilities dealing with instances.
+
+;;; Right now, this is a linear search off the class.
+
+(define (lookup-instance alg-def class-def)
+ (let ((res (lookup-instance-1 alg-def (class-instances class-def))))
+ (if (and (eq? res '#f) (algdata-real-tuple? alg-def))
+ (lookup-possible-tuple-instances alg-def class-def)
+ res)))
+
+(define (lookup-instance-1 alg-def instances)
+ (cond ((null? instances)
+ '#f)
+ ((eq? (instance-algdata (car instances)) alg-def)
+ (if (instance-ok? (car instances))
+ (car instances)
+ '#f))
+ (else
+ (lookup-instance-1 alg-def (cdr instances)))))
+
+(define (lookup-possible-tuple-instances alg-def class-def)
+ (cond ((eq? class-def (core-symbol "Eq"))
+ (get-tuple-eq-instance alg-def))
+ ((eq? class-def (core-symbol "Ord"))
+ (get-tuple-ord-instance alg-def))
+ ((eq? class-def (core-symbol "Ix"))
+ (get-tuple-ix-instance alg-def))
+ ((eq? class-def (core-symbol "Text"))
+ (get-tuple-text-instance alg-def))
+ ((eq? class-def (core-symbol "Binary"))
+ (get-tuple-binary-instance alg-def))
+ (else '#f)))
+
+(define *saved-eq-instances* '())
+(define *saved-ord-instances* '())
+(define *saved-ix-instances* '())
+(define *saved-text-instances* '())
+(define *saved-binary-instances* '())
+
+(define (get-tuple-eq-instance tpl)
+ (let ((res (assq tpl *saved-eq-instances*)))
+ (if (not (eq? res '#f))
+ (tuple-2-2 res)
+ (let ((inst (make-tuple-instance
+ tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
+ (push (tuple tpl inst) *saved-eq-instances*)
+ inst))))
+
+(define (get-tuple-ord-instance tpl)
+ (let ((res (assq tpl *saved-ord-instances*)))
+ (if (not (eq? res '#f))
+ (tuple-2-2 res)
+ (let ((inst (make-tuple-instance
+ tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
+ (push (tuple tpl inst) *saved-ord-instances*)
+ inst))))
+
+(define (get-tuple-ix-instance tpl)
+ (let ((res (assq tpl *saved-ix-instances*)))
+ (if (not (eq? res '#f))
+ (tuple-2-2 res)
+ (let ((inst (make-tuple-instance
+ tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
+ (push (tuple tpl inst) *saved-ix-instances*)
+ inst))))
+
+(define (get-tuple-text-instance tpl)
+ (let ((res (assq tpl *saved-text-instances*)))
+ (if (not (eq? res '#f))
+ (tuple-2-2 res)
+ (let ((inst (make-tuple-instance
+ tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
+ (push (tuple tpl inst) *saved-text-instances*)
+ inst))))
+
+(define (get-tuple-binary-instance tpl)
+ (let ((res (assq tpl *saved-binary-instances*)))
+ (if (not (eq? res '#f))
+ (tuple-2-2 res)
+ (let ((inst (make-tuple-instance
+ tpl (core-symbol "Binary")
+ (core-symbol "tupleBinaryDict"))))
+ (push (tuple tpl inst) *saved-binary-instances*)
+ inst))))
+
+(define (make-tuple-instance algdata class dict)
+ (let* ((size (tuple-size algdata))
+ (tyvars (gen-symbols size))
+ (context (map (lambda (tyvar)
+ (**context (**class/def class) tyvar))
+ tyvars))
+ (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
+ (gcontext (gtype-context (ast->gtype context sig))))
+ (make instance
+ (algdata algdata)
+ (tyvars tyvars)
+ (class class)
+ (context context)
+ (gcontext gcontext)
+ (methods '())
+ (dictionary dict)
+ (ok? '#t)
+ (special? '#t))))
+
+;;; I know these are somewhere else too ...
+
+(define (tuple-size alg)
+ (con-arity (car (algdata-constrs alg))))
+
+(define (gen-symbols n)
+ (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
+ |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
+
+(define (gen-symbols-1 n vars)
+ (if (eqv? n 0)
+ '()
+ (if (null? vars)
+ (cons (string->symbol (format '#f "x~A" n))
+ (gen-symbols-1 (1- n) '()))
+ (cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
+
+;;; This handles the dynamic linking of instances into classes
+
+(define (link-instances modules)
+ (dolist (m modules)
+ ;; clear out any instances sitting around from old compiles
+ (dolist (class (module-class-defs m))
+ (setf (class-instances class) '())))
+ (dolist (m modules)
+ (dolist (inst (module-instance-defs m))
+ (link-instance inst)))
+ )
+
+(define (link-instance inst) ; links an instance into the associated class
+ (push inst (class-instances (instance-class inst))))
+
+;;; This creates a new instance object and installs it.
+
+(predefine (make-new-var name)) ; in tdecl/tdecl-utils.scm
+
+(define (new-instance class algdata tyvars)
+ (let* ((dict-name
+ (string-append "dict-"
+ (symbol->string (print-name class)) "-"
+ (symbol->string (print-name algdata))))
+ (inst (make instance (algdata algdata)
+ (tyvars tyvars)
+ (class class)
+ (gcontext '())
+ (context '())
+ (dictionary (make-new-var dict-name)))))
+ (link-instance inst)
+ inst))
+
+
+
+
+
+
+
diff --git a/util/pattern-vars.scm b/util/pattern-vars.scm
new file mode 100644
index 0000000..78cb361
--- /dev/null
+++ b/util/pattern-vars.scm
@@ -0,0 +1,40 @@
+;;; This collects the vars bound in a pattern.
+
+(define-walker collect-pattern-vars ast-td-collect-pattern-vars-walker)
+
+(define (collect-pattern-vars x)
+ (collect-pattern-vars-1 x '()))
+
+(define (collect-pattern-vars-1 x vars-so-far)
+ (call-walker collect-pattern-vars x vars-so-far))
+
+(define (collect-pattern-vars/list l vars-so-far)
+ (if (null? l)
+ vars-so-far
+ (collect-pattern-vars/list (cdr l)
+ (collect-pattern-vars-1 (car l) vars-so-far))))
+
+(define-local-syntax (collect-pattern-vars-processor
+ slot type object-form accum-form)
+ (let ((stype (sd-type slot))
+ (sname (sd-name slot)))
+ (cond ((eq? stype 'var-ref)
+ `(cons (struct-slot ',type ',sname ,object-form) ,accum-form))
+ ((eq? stype 'pattern)
+ `(collect-pattern-vars-1
+ (struct-slot ',type ',sname ,object-form)
+ ,accum-form))
+ ((equal? stype '(list pattern))
+ `(collect-pattern-vars/list
+ (struct-slot ',type ',sname ,object-form) ,accum-form))
+ (else
+; (format '#t "Collect-pattern-vars: skipping slot ~A in ~A~%"
+; sname
+; type)
+ accum-form)
+ )))
+
+(define-collecting-walker-methods collect-pattern-vars
+ (as-pat irr-pat var-pat wildcard-pat const-pat plus-pat pcon list-pat
+ pp-pat-list pp-pat-plus pp-pat-negated)
+ collect-pattern-vars-processor)
diff --git a/util/prec-utils.scm b/util/prec-utils.scm
new file mode 100644
index 0000000..6ff7a1a
--- /dev/null
+++ b/util/prec-utils.scm
@@ -0,0 +1,115 @@
+;;; prec-util.scm -- utilities for precedence parsing and printing of
+;;; expressions
+;;;
+;;; author : Sandra Loosemore
+;;; date : 15 Feb 1992
+;;;
+;;; The functions in this file are used by the expression printers
+;;; and by precedence parsing.
+
+
+;;; Uncurry the function application, looking for a con-ref as the
+;;; actual function being applied. Return the con-ref-con and a list
+;;; of the arguments.
+
+(define (extract-constructor fn args)
+ (cond ((is-type? 'con-ref fn)
+ (values (con-ref-con fn) args))
+ ((is-type? 'app fn)
+ (extract-constructor (app-fn fn) (cons (app-arg fn) args)))
+ (else
+ (values '#f '()))))
+
+
+;;; If this is an infix operator application, there are really two nested
+;;; applications that we handle at once. The "fn" on the outer app
+;;; points to a nested app which is a var-ref or con-ref with the infix?
+;;; slot set to T.
+;;; Returns three values: the fixity info, the operator, and the first
+;;; argument (the arg to the outer application is the second argument).
+
+(define (extract-infix-operator fn)
+ (if (is-type? 'app fn)
+ (let* ((new-fn (app-fn fn))
+ (arg (app-arg fn))
+ (fixity (operator-fixity new-fn)))
+ (if fixity
+ (values fixity new-fn arg)
+ (values '#f '#f '#f)))
+ (values '#f '#f '#f)))
+
+
+;;; Return the fixity info for a reference to a var or con.
+;;; If it doesn't have an explicit fixity, use the default of
+;;; left associativity and precedence 9.
+
+(define default-fixity
+ (make fixity (associativity 'l) (precedence 9)))
+
+(define (operator-fixity fn)
+ (if (is-type? 'save-old-exp fn)
+ (operator-fixity (save-old-exp-old-exp fn))
+ (or (and (is-type? 'var-ref fn)
+ (var-ref-infix? fn)
+ (or (and (var-ref-var fn)
+ (not (eq? (var-ref-var fn) *undefined-def*))
+ (var-fixity (var-ref-var fn)))
+ default-fixity))
+ (and (is-type? 'con-ref fn)
+ (con-ref-infix? fn)
+ (or (and (con-ref-con fn)
+ (not (eq? (con-ref-con fn) *undefined-def*))
+ (con-fixity (con-ref-con fn)))
+ default-fixity))
+ (and (is-type? 'pcon fn)
+ (pcon-infix? fn)
+ (or (and (pcon-con fn)
+ (not (eq? (pcon-con fn) *undefined-def*))
+ (con-fixity (pcon-con fn)))
+ default-fixity))
+ '#f)))
+
+
+
+;;; Determine the precedence of an expression.
+;;; *** What about unary -?
+
+(define (precedence-of-exp exp associativity)
+ (cond ((is-type? 'save-old-exp exp)
+ (precedence-of-exp (save-old-exp-old-exp exp) associativity))
+ ((is-type? 'aexp exp) 10)
+ ((is-type? 'app exp)
+ (multiple-value-bind (fixity op arg1)
+ (extract-infix-operator (app-fn exp))
+ (declare (ignore op arg1))
+ (if fixity
+ (if (eq? associativity (fixity-associativity fixity))
+ (1+ (fixity-precedence fixity))
+ (fixity-precedence fixity))
+ 10)))
+ ((is-type? 'lambda exp) 10)
+ ((is-type? 'let exp) 10)
+ ((is-type? 'if exp) 10)
+ ((is-type? 'case exp) 10)
+ ((pp-exp-list-section? exp) 10)
+ ((is-type? 'negate exp) 10) ; hack, hack
+ (else
+ 0)))
+
+
+;;; Determine whether a pp-exp-list is really a section -- the
+;;; first or last exp in the list is really an infix op.
+
+(define (pp-exp-list-section? object)
+ (if (is-type? 'pp-exp-list object)
+ (let ((exps (pp-exp-list-exps object)))
+ (or (infix-var-or-con? (car exps))
+ (infix-var-or-con? (list-ref exps (1- (length exps))))))
+ '#f))
+
+(define (infix-var-or-con? object)
+ (or (and (is-type? 'var-ref object)
+ (var-ref-infix? object))
+ (and (is-type? 'con-ref object)
+ (con-ref-infix? object))))
+
diff --git a/util/signature.scm b/util/signature.scm
new file mode 100644
index 0000000..aea41eb
--- /dev/null
+++ b/util/signature.scm
@@ -0,0 +1,90 @@
+;;; This file handles the scoping and error checking of signatures.
+
+;;; Possible errors:
+;;; Wrong arity in a tycon
+;;; Ambiguous context
+
+;;; Other errors may be present; these are detected at a higher level.
+;;; The list of variables used in the signature is returned.
+
+(define (resolve-signature signature)
+ (with-slots signature (context type) signature
+ (let ((tyvars (resolve-type type)))
+ (resolve-signature-aux tyvars context)
+ tyvars)))
+
+(define (resolve-signature-aux tyvars context)
+ (dolist (ctxt context)
+ (with-slots context (class tyvar) ctxt
+ (when (not (memq tyvar tyvars))
+ (signal-ambiguous-context tyvar))
+ (resolve-class class))))
+
+(define (resolve-type type)
+ (resolve-type-1 type '()))
+
+(define (resolve-type-1 type vars)
+ (cond ((tyvar? type)
+ (cons (tyvar-name type) vars))
+ (else
+ (resolve-tycon type)
+ (with-slots tycon (name def args) type
+ (when (not (eq? def *undefined-def*))
+ (if (eqv? (tycon-def-arity def) -1)
+ (setf (tycon-def-arity def) (length args))
+ (when (not (eqv? (length args) (tycon-def-arity def)))
+ (signal-tycon-arity name type))))
+ (resolve-type/list args vars)))))
+
+(define (resolve-type/list args vars)
+ (if (null? args)
+ vars
+ (resolve-type/list (cdr args) (resolve-type-1 (car args) vars))))
+
+;;; This returns the names of the tyvars in a simple tycon
+
+(define (simple-tyvar-list simple)
+ (remember-context simple
+ (let* ((res (map (lambda (x) (tyvar-name x)) (tycon-args simple)))
+ (dups (find-duplicates res)))
+ (when (not (null? dups))
+ (signal-non-linear-type-vars simple))
+ res)))
+
+;;; This is used to build the class dictionary signature.
+
+(define (substitute-tyvar type tyvar new)
+ (cond ((tyvar? type)
+ (if (eq? (tyvar-name type) tyvar)
+ new
+ (**tyvar (tyvar-name type))))
+ ((tycon? type)
+ (with-slots tycon (name def args) type
+ (make tycon (name name) (def def)
+ (args (map (lambda (x) (substitute-tyvar x tyvar new))
+ args)))))
+ (else
+ (**signature (signature-context type)
+ (substitute-tyvar (signature-type type) tyvar new)))))
+
+
+
+;;; Error signalling routines
+
+(define (signal-ambiguous-context tyvar)
+ (phase-error 'ambiguous-context
+ "~a is referenced in a context, but is not bound as a type variable."
+ tyvar))
+
+(define (signal-tycon-arity name type)
+ (phase-error 'tycon-arity
+ "The wrong number of arguments are supplied to the constructor ~a~%~
+ in the type ~a."
+ name type))
+
+
+(define (signal-non-linear-type-vars simple)
+ (phase-error 'non-linear-type-vars
+ "There are duplicate type variables in ~s."
+ simple))
+
diff --git a/util/type-utils.scm b/util/type-utils.scm
new file mode 100644
index 0000000..c9b4504
--- /dev/null
+++ b/util/type-utils.scm
@@ -0,0 +1,308 @@
+
+;;; The `prune' function removes instantiated type variables at the
+;;; top level of a type.
+
+;;; It returns an uninstantiated type variable or a type constructor.
+
+(define-integrable (prune ntype)
+ (if (ntyvar? ntype)
+ (if (instantiated? ntype)
+ (prune-1 (ntyvar-value ntype))
+ ntype)
+ ntype))
+
+;;; This is because lucid can't hack inlining recursive fns.
+
+(define (prune-1 x) (prune x))
+
+(define-integrable (instantiated? ntyvar)
+ (ntyvar-value ntyvar))
+; (not (eq? (ntyvar-value ntyvar) '#f))) ;*** Lucid compiler bug?
+
+(define (prune/l l)
+ (map (function prune) l))
+
+
+;;; These functions convert between AST types and gtypes. Care is taken to
+;;; ensure that the gtyvars are in the same order that they appear in the
+;;; context. This is needed to make dictionary conversion work right.
+
+(define (ast->gtype context type)
+ (mlet (((gcontext env) (context->gcontext context '() '()))
+ ((type env1) (type->gtype type env))
+ (gcontext-classes (arrange-gtype-classes env1 gcontext)))
+ (**gtype gcontext-classes type)))
+
+;;; This is similar except that the ordering of the tyvars is as defined in
+;;; the data type. This is used only for instance declarations and allows
+;;; for simple context implication checks. It also used by the signature
+;;; of the dictionary variable.
+
+(define (ast->gtype/inst context type)
+ (mlet (((type env) (type->gtype type '()))
+ ((gcontext env1) (context->gcontext context '() env))
+ (gcontext-classes (arrange-gtype-classes env1 gcontext)))
+ (**gtype gcontext-classes type)))
+
+;;; This converts a context into gtype form [[class]]: a list of classes
+;;; for each gtyvar. This returns the context and the gtyvar environment.
+
+(define (context->gcontext context gcontext env)
+ (if (null? context)
+ (values gcontext env)
+ (mlet ((sym (context-tyvar (car context)))
+ (class (class-ref-class (context-class (car context))))
+ ((n new-env) (ast->gtyvar sym env))
+ (old-context (get-gtyvar-context n gcontext))
+ (new-context (merge-single-class class old-context))
+ (new-gcontext (cons (tuple n new-context) gcontext)))
+ (context->gcontext (cdr context) new-gcontext new-env))))
+
+;;; This assigns a gtyvar number to a tyvar name.
+
+(define (ast->gtyvar sym env)
+ (let ((res (assq sym env)))
+ (if (eq? res '#f)
+ (let ((n (length env)))
+ (values n (cons (tuple sym n) env)))
+ (values (tuple-2-2 res) env))))
+
+(define (get-gtyvar-context n gcontext)
+ (cond ((null? gcontext)
+ '())
+ ((eqv? n (tuple-2-1 (car gcontext)))
+ (tuple-2-2 (car gcontext)))
+ (else (get-gtyvar-context n (cdr gcontext)))))
+
+(define (type->gtype type env)
+ (if (tyvar? type)
+ (mlet (((n env1) (ast->gtyvar (tyvar-name type) env)))
+ (values (**gtyvar n) env1))
+ (mlet (((types env1) (type->gtype/l (tycon-args type) env)))
+ (values (**ntycon (tycon-def type) types) env1))))
+
+(define (type->gtype/l types env)
+ (if (null? types)
+ (values '() env)
+ (mlet (((type env1) (type->gtype (car types) env))
+ ((other-types env2) (type->gtype/l (cdr types) env1)))
+ (values (cons type other-types) env2))))
+
+(define (arrange-gtype-classes env gcontext)
+ (arrange-gtype-classes-1 0 (length env) env gcontext))
+
+(define (arrange-gtype-classes-1 m n env gcontext)
+ (if (equal? m n)
+ '()
+ (cons (get-gtyvar-context m gcontext)
+ (arrange-gtype-classes-1 (1+ m) n env gcontext))))
+
+;;; These routines convert gtypes back to ordinary types.
+
+(define (instantiate-gtype g)
+ (mlet (((gtype _) (instantiate-gtype/newvars g)))
+ gtype))
+
+(define (instantiate-gtype/newvars g)
+ (if (null? (gtype-context g))
+ (values (gtype-type g) '())
+ (let ((new-tyvars (create-new-tyvars (gtype-context g))))
+ (values (copy-gtype (gtype-type g) new-tyvars) new-tyvars))))
+
+(define (create-new-tyvars ctxts)
+ (if (null? ctxts)
+ '()
+ (let ((tyvar (**ntyvar)))
+ (setf (ntyvar-context tyvar) (car ctxts))
+ (cons tyvar (create-new-tyvars (cdr ctxts))))))
+
+(define (copy-gtype g env)
+ (cond ((ntycon? g)
+ (**ntycon (ntycon-tycon g)
+ (map (lambda (g1) (copy-gtype g1 env))
+ (ntycon-args g))))
+ ((ntyvar? g)
+ g)
+ ((gtyvar? g)
+ (list-ref env (gtyvar-varnum g)))
+ ((const-type? g)
+ (const-type-type g))))
+
+;;; ntypes may contain synonyms. These are expanded here. Only the
+;;; top level synonym is expanded.
+
+(define (expand-ntype-synonym type)
+ (if (and (ntycon? type)
+ (synonym? (ntycon-tycon type)))
+ (let ((syn (ntycon-tycon type)))
+ (expand-ntype-synonym
+ (expand-ntype-synonym-1 (synonym-body syn)
+ (map (lambda (var val)
+ (tuple var val))
+ (synonym-args syn)
+ (ntycon-args type)))))
+ type))
+
+(define (expand-ntype-synonym-1 type env)
+ (if (tyvar? type)
+ (tuple-2-2 (assq (tyvar-name type) env))
+ (**ntycon (tycon-def type)
+ (map (lambda (ty) (expand-ntype-synonym-1 ty env))
+ (tycon-args type)))))
+
+;;; This is used in generalization. Note that ntyvars will remain when
+;;; non-generic tyvars are encountered.
+
+(define (ntype->gtype ntype)
+ (mlet (((res _) (ntype->gtype/env ntype '())))
+ res))
+
+(define (ntype->gtype/env ntype required-vars)
+ (mlet (((gtype env) (ntype->gtype-1 ntype required-vars)))
+ (values
+ (make gtype (type gtype) (context (map (lambda (x) (ntyvar-context x))
+ env)))
+ env)))
+
+(define (ntype->gtype-1 ntype env)
+ (let ((ntype (prune ntype)))
+ (cond ((ntycon? ntype)
+ (mlet (((args env1) (ntype->gtype/l (ntycon-args ntype) env)))
+ (values (**ntycon (ntycon-tycon ntype) args) env1)))
+ (else
+ (ntyvar->gtyvar ntype env)))))
+
+(define (ntype->gtype/l types env)
+ (if (null? types)
+ (values '() env)
+ (mlet (((type env1) (ntype->gtype-1 (car types) env))
+ ((types2 env2) (ntype->gtype/l (cdr types) env1)))
+ (values (cons type types2) env2))))
+
+(define (ntyvar->gtyvar ntyvar env)
+ (if (non-generic? ntyvar)
+ (values ntyvar env)
+ (let ((l (list-pos ntyvar env)))
+ (if (eq? l '#f)
+ (values (**gtyvar (length env)) (append env (list ntyvar)))
+ (values (**gtyvar l) env)))))
+
+(define (list-pos x l)
+ (list-pos-1 x l 0))
+
+(define (list-pos-1 x l n)
+ (cond ((null? l)
+ '#f)
+ ((eq? x (car l))
+ n)
+ (else
+ (list-pos-1 x (cdr l) (1+ n)))))
+
+
+;;; These utils are used in dictionary conversion.
+
+(define (**dsel/method class method dict-code)
+ (let ((pos (locate-in-list method (class-method-vars class) 0)))
+ (**tuple-sel (class-dict-size class) pos dict-code)))
+
+(define (**dsel/dict class dict-class dict-code)
+ (let ((pos (locate-in-list
+ dict-class (class-super* class) (class-n-methods class))))
+ (**tuple-sel (class-dict-size class) pos dict-code)))
+
+(define (locate-in-list var l pos)
+ (if (null? l)
+ (error "Locate in list failed")
+ (if (eq? var (car l))
+ pos
+ (locate-in-list var (cdr l) (1+ pos)))))
+
+;;; These routines deal with contexts. A context is a list classes.
+
+;;; A context is normalized whenever class is a superclass of another.
+
+(define (merge-contexts ctxt1 ctxt2)
+ (if (null? ctxt1)
+ ctxt2
+ (merge-single-class (car ctxt1) (merge-contexts (cdr ctxt1) ctxt2))))
+
+;;; This could perhaps avoid some consing but I don't imagine it would
+;;; make much difference.
+
+(define (merge-single-class class ctxt)
+ (cond ((null? ctxt)
+ (list class))
+ ((eq? class (car ctxt))
+ ctxt)
+ ((memq class (class-super* (car ctxt)))
+ ctxt)
+ ((memq (car ctxt) (class-super* class))
+ (merge-single-class class (cdr ctxt)))
+ (else
+ (cons (car ctxt) (merge-single-class class (cdr ctxt))))))
+
+;;; This determines if ctxt2 is contained in ctxt1.
+
+(define (context-implies? ctxt1 ctxt2)
+ (or (null? ctxt2)
+ (and (single-class-implies? ctxt1 (car ctxt2))
+ (context-implies? ctxt1 (cdr ctxt2)))))
+
+(define (single-class-implies? ctxt class)
+ (and (not (null? ctxt))
+ (or (memq class ctxt)
+ (super-class-implies? ctxt class))))
+
+(define (super-class-implies? ctxt class)
+ (and (not (null? ctxt))
+ (or (memq class (class-super* (car ctxt)))
+ (super-class-implies? (cdr ctxt) class))))
+
+;;; This looks at the context of a full signature.
+
+(define (full-context-implies? ctxt1 ctxt2)
+ (or (null? ctxt1)
+ (and (context-implies? (car ctxt1) (car ctxt2))
+ (full-context-implies? (cdr ctxt1) (cdr ctxt2)))))
+
+;;; This is used to avoid type circularity on unification.
+
+(define (occurs-in-type tyvar type) ; Cardelli algorithm
+ (let ((type (prune type)))
+ (if (ntyvar? type)
+ (eq? type tyvar)
+ (occurs-in-type/l tyvar (ntycon-args type)))))
+
+; Does a tyvar occur in a list of types?
+(define (occurs-in-type/l tyvar types)
+ (if (null? types)
+ '#f
+ (or (occurs-in-type tyvar (car types))
+ (occurs-in-type/l tyvar (cdr types)))))
+
+(define-integrable (non-generic? tyvar)
+ (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*)))
+
+(define (collect-tyvars ntype)
+ (collect-tyvars-1 ntype '()))
+
+(define (collect-tyvars-1 ntype vars)
+ (let ((ntype (prune ntype)))
+ (if (ntyvar? ntype)
+ (if (or (memq ntype vars) (non-generic? ntype))
+ vars
+ (cons ntype vars))
+ (collect-tyvars/l-1 (ntycon-args ntype) vars))))
+
+(define (collect-tyvars/l types)
+ (collect-tyvars/l-1 types '()))
+
+(define (collect-tyvars/l-1 types vars)
+ (if (null? types)
+ vars
+ (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars))))
+
+;;; Random utilities
+
+(define (decl-var decl)
+ (var-ref-var (var-pat-var (valdef-lhs decl))))
diff --git a/util/walk-ast.scm b/util/walk-ast.scm
new file mode 100644
index 0000000..aecffc6
--- /dev/null
+++ b/util/walk-ast.scm
@@ -0,0 +1,156 @@
+;;; walk-ast.scm -- general-purpose walkers for AST structures.
+;;;
+;;; author : Sandra & John
+;;; date : 30 Jan 1992
+;;;
+;;;
+
+;;;=====================================================================
+;;; Basic support, macros
+;;;=====================================================================
+
+
+;;; Here is a macro for accessing the walker function for a particular
+;;; type.
+;;; The walk-type names the walker.
+;;; If an accessor argument is provided, it must name a SETF'able function
+;;; or macro that takes a type descriptor as an argument. This is used to
+;;; do the lookup of the walker function for the given type.
+;;; If no explicit accessor is provided, one will be created. It will
+;;; use a hash table keyed off the type names to store the walker functions.
+;;; In either case, the mapping between the walker name and accessor is
+;;; stored in the hash table ast-walker-table.
+
+(define ast-walker-table (make-table))
+
+(define-syntax (define-walker walk-type . maybe-accessor)
+ (let ((accessor-name (if (null? maybe-accessor)
+ (symbol-append walk-type '-walker)
+ (car maybe-accessor))))
+ (setf (table-entry ast-walker-table walk-type) accessor-name)
+ `(begin
+ ,@(if (null? maybe-accessor)
+ (let ((accessor-table (symbol-append '* walk-type '-table*)))
+ `((define ,accessor-table (make-table))
+ (define-syntax (,accessor-name td)
+ (list 'table-entry
+ ',accessor-table
+ (list 'td-name td)))))
+ '())
+ (setf (table-entry ast-walker-table ',walk-type)
+ ',accessor-name)
+ ',walk-type)))
+
+(define-syntax (ast-walker walk-type td)
+ (let ((accessor (table-entry ast-walker-table walk-type)))
+ `(,accessor ,td)))
+
+
+;;; This macro dispatches a walker on an object of type ast-node.
+
+(define-syntax (call-walker walk-type object . args)
+ (let ((temp (gensym "OBJ")))
+ `(let ((,temp ,object))
+ (funcall (or (ast-walker ,walk-type (struct-type-descriptor ,temp))
+ (walker-not-found-error ',walk-type ,temp))
+ ,temp
+ ,@args))
+ ))
+
+(define (walker-not-found-error walk-type object)
+ (error "There is no ~a walker for structure ~A defined."
+ walk-type (td-name (struct-type-descriptor object))))
+
+
+
+;;; Define an individual walker for a particular type. The body should
+;;; return either the original object or a replacement for it.
+
+(define-syntax (define-walker-method walk-type type args . body)
+ (let ((function-name (symbol-append walk-type '- type)))
+ `(begin
+ (define (,function-name ,@args) ,@body)
+ (setf (ast-walker ,walk-type (lookup-type-descriptor ',type))
+ (function ,function-name))
+ ',function-name)))
+
+
+
+;;;=====================================================================
+;;; Support for default walker methods
+;;;=====================================================================
+
+;;; Two kinds of walkers are supported: a collecting walker, which
+;;; walks over a tree collecting some sort of returned result while
+;;; not changing the tree itself, and a rewriting walker which maps
+;;; ast to ast.
+
+;;; The basic template for a collecting walk is:
+;;; (define-walker-method walk-type type (object accum)
+;;; (sf1 (sf2 object ... (sfn accum)))
+;;; where sfi = slot function for the ith slot.
+;;;
+;;; The slot-processor should be the name of a macro that is called with four
+;;; arguments: a slot descriptor, the object type name, a form
+;;; representing the object being traversed, and a form representing the
+;;; accumulated value.
+;;; If the slot does not participate in the walk, this last argument should
+;;; be returned unchanged as the expansion of the macro.
+
+(define-syntax (define-collecting-walker-methods walk-type types
+ slot-processor)
+ `(begin
+ ,@(map (lambda (type)
+ (make-collecting-walker-method walk-type type slot-processor))
+ types)))
+
+(define (make-collecting-walker-method walk-type type slot-processor)
+ `(define-walker-method ,walk-type ,type (object accum)
+ object ; prevent possible unreferenced variable warning
+ ,(make-collecting-walker-method-body
+ 'accum
+ type
+ (td-slots (lookup-type-descriptor type))
+ slot-processor)))
+
+(define (make-collecting-walker-method-body base type slots slot-processor)
+ (if (null? slots)
+ base
+ `(,slot-processor ,(car slots) ,type object
+ ,(make-collecting-walker-method-body
+ base type (cdr slots) slot-processor))))
+
+
+
+;;; A rewriting walker traverses the ast modifying various subtrees.
+;;; The basic template here is:
+;;; (define-walker-method walker type (object . args)
+;;; (setf (slot1 object) (walk (slot1 object)))
+;;; (setf (slot2 object) (walk (slot2 object)))
+;;; ...
+;;; object)
+
+;;; The basic macro to generate default walkers is as above except
+;;; that the slot-processor macro is called with only
+;;; two arguments, the slot and object type.
+;;; The `args' is the actual lambda-list for the methods, and bindings
+;;; can be referenced inside the code returned by the macro.
+;;; If a slot participates in the walk, the macro should return code
+;;; to SETF the slot, as in the template above. Otherwise, the macro
+;;; should just return #f.
+
+(define-syntax (define-modify-walker-methods walk-type types args
+ slot-processor)
+ `(begin
+ ,@(map (lambda (type)
+ (make-modify-walker-method walk-type type args
+ slot-processor))
+ types)))
+
+(define (make-modify-walker-method walk-type type args slot-processor)
+ `(define-walker-method ,walk-type ,type ,args
+ ,@(cdr args) ; prevent possible unreferenced variable warnings
+ ,@(map (lambda (slot)
+ `(,slot-processor ,slot ,type))
+ (td-slots (lookup-type-descriptor type)))
+ ,(car args)))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 01:03:35 +0000