Import to github.

4 files changed, 640 insertions, 0 deletions

diff --git a/prec/README b/prec/README
new file mode 100644
index 0000000..ea455c4
--- /dev/null
+++ b/prec/README
@@ -0,0 +1,2 @@
+This directory contains the code walker for the scoping and
+precedence parsing phase of the compiler.
diff --git a/prec/prec-parse.scm b/prec/prec-parse.scm
new file mode 100644
index 0000000..9df06a6
--- /dev/null
+++ b/prec/prec-parse.scm
@@ -0,0 +1,253 @@
+;;; prec-parse.scm -- do precedence parsing of expressions and patterns
+;;;
+;;; author :  John & Sandra
+;;; date   :  04 Feb 1992
+;;;
+;;;
+
+
+;;; ==================================================================
+;;; Handling for pp-exp-list
+;;; ==================================================================
+
+;;; This function is called during the scope phase after all of the
+;;; exps in a pp-exp-list have already been walked.  Basically, the
+;;; purpose is to turn the original pp-exp-list into something else.
+;;; Look for the section cases first and treat them specially.
+
+;;; Sections are handled by inserting a magic cookie (void) into the
+;;; list where the `missing' operand of the section would be and then
+;;; making sure the cookie stays at the top.
+
+;;; Unary minus needs checking to avoid things like a*-a.
+
+(define (massage-pp-exp-list exps)
+ (let* ((first-term (car exps))
+        (last-term (car (last exps)))
+        (type (cond ((infix-var-or-con? first-term) 'section-l)
+		    ((infix-var-or-con? last-term) 'section-r)
+		    (else 'exp)))
+	(exps1 (cond ((eq? type 'section-l)
+		      (cons (make void) exps))
+		     ((eq? type 'section-r)
+		      (append exps (list (make void))))
+		     (else exps)))
+	(parsed-exp (parse-pp-list '#f exps1)))
+   (if (eq? type 'exp)
+       parsed-exp
+       (if (or (not (app? parsed-exp))
+	       (not (app? (app-fn parsed-exp))))
+	   (begin
+	     (signal-section-precedence-conflict
+	      (if (eq? type 'section-l) first-term last-term))
+	     (make void))
+	   (let ((rhs (app-arg parsed-exp))
+		 (op (app-fn (app-fn parsed-exp)))
+		 (lhs (app-arg (app-fn parsed-exp))))
+	     (if (eq? type 'section-l)
+		 (if (void? lhs)
+		     (make section-l (op op) (exp rhs))
+		     (begin
+		       (signal-section-precedence-conflict first-term)
+		       (make void)))
+		 (if (void? rhs)
+		     (make section-r (op op) (exp lhs))
+		     (begin
+		       (signal-section-precedence-conflict last-term)
+		       (make void)))))))))
+
+
+;;; ==================================================================
+;;; Handling for pp-pat-list
+;;; ==================================================================
+
+;;; In this case, we have to do an explicit walk of the pattern looking
+;;; at all of its subpatterns.
+;;;  ** This is a crock - the scope walker needs fixing.
+
+(define (massage-pattern pat)
+  (cond ((is-type? 'as-pat pat)
+	 (setf (as-pat-pattern pat) (massage-pattern (as-pat-pattern pat)))
+	 pat)
+	((is-type? 'irr-pat pat)
+	 (setf (irr-pat-pattern pat) (massage-pattern (irr-pat-pattern pat)))
+	 pat)
+	((is-type? 'plus-pat pat)
+	 (setf (plus-pat-pattern pat) (massage-pattern (plus-pat-pattern pat)))
+	 pat)
+	((is-type? 'pcon pat)
+	 (when (eq? (pcon-con pat) *undefined-def*)
+	   (setf (pcon-con pat) (lookup-toplevel-name (pcon-name pat))))
+	 (setf (pcon-pats pat) (massage-pattern-list (pcon-pats pat)))
+	 pat)
+	((is-type? 'list-pat pat)
+	 (setf (list-pat-pats pat) (massage-pattern-list (list-pat-pats pat)))
+	 pat)
+	((is-type? 'pp-pat-list pat)
+	 (parse-pp-list '#t (massage-pattern-list (pp-pat-list-pats pat))))
+	(else
+	 pat)))
+
+(define (massage-pattern-list pats)
+  (map (function massage-pattern) pats))
+
+
+;;; ==================================================================
+;;; Shared support
+;;; ==================================================================
+
+;;; This is the main routine.
+
+(define (parse-pp-list pattern? l)
+  (mlet (((stack terms) (push-pp-stack '() l)))
+    (pp-parse-next-term pattern? stack terms)))
+
+(define (pp-parse-next-term pattern? stack terms)
+  (if (null? terms)
+      (reduce-complete-stack pattern? stack)
+      (let ((stack (reduce-stronger-ops pattern? stack (car terms))))
+	(mlet (((stack terms)
+		(push-pp-stack (cons (car terms) stack) (cdr terms))))
+	   (pp-parse-next-term pattern? stack terms)))))
+
+(define (reduce-complete-stack pattern? stack)
+  (if (pp-stack-op-empty? stack)
+      (car stack)
+      (reduce-complete-stack pattern? (reduce-pp-stack pattern? stack))))
+
+(define (reduce-pp-stack pattern? stack)
+  (let ((term (car stack))
+	(op (cadr stack)))
+    (if pattern?
+	(cond ((pp-pat-plus? op)
+	       (let ((lhs (caddr stack)))
+		 (cond ((or (not (const-pat? term))
+			    (and (not (var-pat? lhs))
+				 (not (wildcard-pat? lhs))))
+			(signal-plus-precedence-conflict term)
+			(cddr stack))
+		       (else
+			(cons (make plus-pat (pattern lhs)
+				             (k (integer-const-value
+						 (const-pat-value term))))
+			      (cdddr stack))))))
+	      ((pp-pat-negated? op)
+	       (cond ((const-pat? term)
+		      (let ((v (const-pat-value term)))
+			(if (integer-const? v)
+			    (setf (integer-const-value v)
+				  (- (integer-const-value v)))
+			    (setf (float-const-numerator v)
+				  (- (float-const-numerator v)))))
+		      (cons term (cddr stack)))
+		     (else
+		      (signal-minus-precedence-conflict term)
+		      (cons term (cddr stack)))))
+	      (else
+	       (setf (pcon-pats op) (list (caddr stack) term))
+	       (cons op (cdddr stack))))
+	(cond ((negate? op)
+	       (cons (**app (**var/def (core-symbol "negate")) term)
+		     (cddr stack)))
+	      (else
+	       (cons (**app op (caddr stack) term) (cdddr stack)))))))
+
+(define (pp-stack-op-empty? stack)
+  (null? (cdr stack)))
+
+(define (top-stack-op stack)
+  (cadr stack))
+
+(define (push-pp-stack stack terms)
+  (let ((term (car terms)))
+    (if (or (negate? term) (pp-pat-negated? term))
+	(begin
+	  (when (and stack (stronger-op? (car stack) term))
+	      (unary-minus-prec-conflict term))
+	  (push-pp-stack (cons term stack) (cdr terms)))
+	(values (cons term stack) (cdr terms)))))
+
+(define (reduce-stronger-ops pattern? stack op)
+  (cond ((pp-stack-op-empty? stack) stack)
+	((stronger-op? (top-stack-op stack) op)
+	 (reduce-stronger-ops pattern? (reduce-pp-stack pattern? stack) op))
+	(else stack)))
+
+(define (stronger-op? op1 op2)
+  (let ((fixity1 (get-op-fixity op1))
+	(fixity2 (get-op-fixity op2)))
+    (cond ((> (fixity-precedence fixity1) (fixity-precedence fixity2))
+	   '#t)
+	  ((< (fixity-precedence fixity1) (fixity-precedence fixity2))
+	   '#f)
+	  (else
+	   (let ((a1 (fixity-associativity fixity1))
+		 (a2 (fixity-associativity fixity2)))
+	     (if (eq? a1 a2)
+		 (cond ((eq? a1 'l)
+			'#t)
+		       ((eq? a1 'r)
+			'#f)
+		       (else
+			(signal-precedence-conflict op1 op2)
+			'#t))
+		 (begin
+		   (signal-precedence-conflict op1 op2)
+		   '#t))))
+	  )))
+	     
+(define (get-op-fixity op)
+  (cond ((var-ref? op)
+	 (pp-get-var-fixity (var-ref-var op)))
+	((con-ref? op)
+	 (pp-get-con-fixity (con-ref-con op)))
+	((pcon? op)
+	 (pp-get-con-fixity (pcon-con op)))
+	((or (negate? op) (pp-pat-negated? op))
+	 (pp-get-var-fixity (core-symbol "-")))
+	((pp-pat-plus? op)
+	 (pp-get-var-fixity (core-symbol "+")))
+	(else
+	 (error "Bad op ~s in pp-parse." op))))
+
+(define (pp-get-var-fixity def)
+  (if (eq? (var-fixity def) '#f)
+      default-fixity
+      (var-fixity def)))
+
+(define (pp-get-con-fixity def)
+  (if (eq? (con-fixity def) '#f)
+      default-fixity
+      (con-fixity def)))
+
+;;; Error handlers
+
+(define (signal-section-precedence-conflict op)
+  (phase-error 'section-precedence-conflict
+    "Operators in section body have lower precedence than section operator ~A."
+   op))
+
+(define (signal-precedence-conflict op1 op2)
+  (phase-error 'precedence-conflict
+    "The operators ~s and ~s appear consecutively, but they have the same~%~
+     precedence and are not either both left or both right associative.~%
+     You must add parentheses to avoid a precedence conflict."
+    op1 op2))
+
+(define (signal-plus-precedence-conflict term)
+  (phase-error 'plus-precedence-conflict
+    "You need to put parentheses around the plus-pattern ~a~%~
+     to avoid a precedence conflict."
+    term))
+
+(define (signal-minus-precedence-conflict arg)
+  (phase-error 'minus-precedence-conflict
+    "You need to put parentheses around the negative literal ~a~%~
+     to avoid a precedence conflict."
+    arg))
+
+(define (unary-minus-prec-conflict arg)
+  (recoverable-error 'minus-precedence-conflict
+     "Operator ~A too strong for unary minus - add parens please!~%"
+     arg))
+
diff --git a/prec/prec.scm b/prec/prec.scm
new file mode 100644
index 0000000..a7948f2
--- /dev/null
+++ b/prec/prec.scm
@@ -0,0 +1,18 @@
+;;; prec.scm -- module definition for scoping/precedence-parsing phase
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  13 Feb 1992
+;;;
+
+
+(define-compilation-unit prec
+  (source-filename "$Y2/prec/")
+  (require ast haskell-utils)
+  (unit scope
+	(source-filename "scope.scm"))
+  (unit prec-parse
+	(source-filename "prec-parse.scm")))
+
+
+	
+
diff --git a/prec/scope.scm b/prec/scope.scm
new file mode 100644
index 0000000..e57ed64
--- /dev/null
+++ b/prec/scope.scm
@@ -0,0 +1,367 @@
+;;; scope.scm -- variable scoping and precedence parsing phase
+;;; 
+;;; author :  John & Sandra
+;;; date   :  11 Feb 1992
+;;;
+;;;
+
+
+;;;===================================================================
+;;; Basic support
+;;;===================================================================
+
+(define (scope-modules modules)
+  (walk-modules modules
+    (lambda ()
+      (setf (module-decls *module*) (scope-ast-decls (module-decls *module*)))
+      (dolist (a (module-annotations *module*))
+;;; This is currently bogus since it assumes only vars are annotated.	      
+	 (when (annotation-decl? a)
+	   (dolist (n (annotation-decl-names a))
+	      (let ((v (table-entry *symbol-table* n)))
+		(when (or (eq? v '#f) (not (var? v)))
+		  (fatal-error 'unknown-annotation-name
+			       "~A: not a var in annotation decl~%" n))
+		(when (not (eq? (def-module v) *module-name*))
+		  (fatal-error 'non-local-name-in-annotation
+			       "~A: not a local var in annotation decl~%" n))
+		(setf (var-annotations v)
+		      (append (var-annotations v)
+			      (annotation-decl-annotations a))))))))))
+
+;;; Define the basic walker and some helper functions.
+
+(define-walker scope ast-td-scope-walker)
+
+(define (scope-ast-1 x env)
+;  (call-walker scope x env))
+  (remember-context x
+    (call-walker scope x env)))
+
+
+(define (scope-ast/list l env)
+  (scope-ast/list-aux l env)
+  l)
+
+(define (scope-ast/list-aux l env)
+  (when (not (null? l))
+    (setf (car l) (scope-ast-1 (car l) env))
+    (scope-ast/list-aux (cdr l) env)))
+
+;;; This filters out signdecls from decl lists.  These declarations are moved
+;;; into the var definitions.
+
+(define (scope-ast/decl-list l env)
+  (if (null? l)
+      '()
+      (let ((x (scope-ast-1 (car l) env))
+	    (rest (scope-ast/decl-list (cdr l) env)))
+	(if (or (annotation-decls? x)
+		(and (signdecl? x)
+		     (not (eq? (module-type *module*) 'interface))))
+	    rest
+	    (begin
+	      (setf (car l) x)
+	      (setf (cdr l) rest)
+	      l)))))
+
+;;; This is the main entry point.  It is called by the driver
+;;; on each top-level decl in the module.
+
+(define (scope-ast-decls x)
+  (let ((result  (scope-ast/decl-list x '())))
+;    (pprint result)   ;*** debug
+    result))
+
+
+;;; All top-level names are entered in the *symbol-table* hash table.
+;;; This is done by the import/export phase of the compiler before
+;;; we get here.
+;;; The env is a list of a-lists that associates locally-defined names with
+;;; their definitions.  Each nested a-list corresponds to a "level" or
+;;; scope.
+;;; *** If many variables are being added in each scope, it might be
+;;; *** better to use a table instead of an alist to represent each contour.
+
+(define (lookup-name name env)
+  (if (null? env)
+      (lookup-toplevel-name name)
+      (let ((info  (assq name (car env))))
+	(if info
+	    (cdr info)
+	    (lookup-name name (cdr env))))))
+
+
+;;; Some kinds of names (e.g. type definitions) appear only at top-level,
+;;; so use this to look for them directly.
+
+(define (lookup-toplevel-name name)
+  (or (resolve-toplevel-name name)
+      (begin
+        (signal-undefined-symbol name)
+	*undefined-def*)))
+
+
+;;; Some kinds of lookups (e.g., matching a signature declaration)
+;;; require that the name be defined in the current scope and not
+;;; an outer one.  Use this function.
+
+(define (lookup-local-name name env)
+  (if (null? env)
+      (lookup-toplevel-name name)
+      (let ((info  (assq name (car env))))
+	(if info
+	    (cdr info)
+	    (begin
+	      (signal-undefined-local-symbol name)
+	      *undefined-def*)))))
+
+
+;;; Add local declarations to the environment, returning a new env.
+;;; Do not actually walk the local declarations here.
+
+(define *scope-info* '())
+
+(define (add-local-declarations decls env)
+  (if (null? decls)
+      env
+      (let ((contour   '()))
+	(dolist (d decls)
+	  (if (is-type? 'valdef d)
+	      (setf contour
+		    (add-bindings (collect-pattern-vars (valdef-lhs d))
+				  contour))))
+	(cons contour env))))
+
+
+;;; Similar, but for adding lambda and function argument bindings to the
+;;; environment.
+
+(define (add-pattern-variables patterns env)
+  (if (null? patterns)
+      env
+      (let ((contour   '()))
+	(dolist (p patterns)
+	  (setf contour (add-bindings (collect-pattern-vars p) contour)))
+	(cons contour env))))
+
+
+;;; Given a list of var-refs, create defs for them and add them to
+;;; the local environment.
+;;; Also check to see that there are no duplicates.
+
+(define (add-bindings var-refs contour)
+  (dolist (v var-refs)
+   (when (eq? (var-ref-var v) *undefined-def*)
+    (let* ((name     (var-ref-name v))
+	   (def      (create-local-definition name)))
+      (setf (var-ref-var v) def)
+      (if (assq name contour)
+	  (signal-multiple-bindings name)
+	  (push (cons name def) contour)))))
+  contour)
+
+
+;;; Error signalling utilities.
+
+(define (signal-undefined-local-symbol name)
+  (phase-error 'undefined-local-symbol
+    "The name ~a has no definition in the current scope."
+    name))
+
+(define (signal-multiple-signatures name)
+  (phase-error 'multiple-signatures
+    "There are multiple signatures for the name ~a."
+    name))
+
+(define (signal-multiple-bindings name)
+  (phase-error 'multiple-bindings
+    "The name ~a appears more than once in a function or pattern binding."
+    name))
+  
+
+
+;;;===================================================================
+;;; Default traversal methods
+;;;===================================================================
+
+
+(define-local-syntax (make-scope-code slot type)
+  (let ((stype  (sd-type slot))
+	(sname  (sd-name slot)))
+    (cond ((and (symbol? stype)
+		(or (eq? stype 'exp)
+		    (subtype? stype 'exp)))
+	   `(setf (struct-slot ',type ',sname object)
+		  (scope-ast-1 (struct-slot ',type ',sname object) env)))
+	  ((and (pair? stype)
+		(eq? (car stype) 'list)
+		(symbol? (cadr stype))
+		(or (eq? (cadr stype) 'exp)
+		    (subtype? (cadr stype) 'exp)))
+	   `(setf (struct-slot ',type ',sname object)
+		  (scope-ast/list (struct-slot ',type ',sname object) env)))
+	  (else
+;	   (format '#t "Scope: skipping slot ~A in ~A~%"
+;		   (sd-name slot)
+;		   type)
+	   '#f))))
+
+
+(define-modify-walker-methods scope
+  (guarded-rhs  ; exp slots
+   if           ; exp slots
+   app          ; exp slots
+   integer-const float-const char-const string-const  ; no slots
+   list-exp     ; (list exp) slot
+   sequence sequence-to sequence-then sequence-then-to ; exp slots
+   section-l section-r ; exp slots
+   omitted-guard overloaded-var-ref ; no slots
+   negate ; no slots
+   sel
+   prim-definition
+   con-number cast
+   )
+  (object env)
+  make-scope-code)
+
+
+;;;===================================================================
+;;; valdef-structs
+;;;===================================================================
+
+
+;;; Signature declarations must appear at the same level as the names
+;;; they apply to.  There must not be more than one signature declaration
+;;; applying to a given name.
+
+(define-walker-method scope signdecl (object env)
+  (let ((signature  (signdecl-signature object)))
+    (resolve-signature signature)
+    (let ((gtype (ast->gtype (signature-context signature)
+			     (signature-type signature))))
+      (dolist (v (signdecl-vars object))
+	(when (eq? (var-ref-var v) *undefined-def*)
+	      (setf (var-ref-var v)
+		    (lookup-local-name (var-ref-name v) env)))
+	(let ((def  (var-ref-var v)))
+	  (when (not (eq? def *undefined-def*))
+	    ;; The lookup-local-name may fail if there is a program error.
+	    ;; In that case, skip this.
+	    (if (var-signature def)
+		(signal-multiple-signatures (var-ref-name v))
+		(setf (var-signature def) gtype))))))
+    object))
+
+;;; This attaches annotations to locally defined vars in the same
+;;; manner as signdecl annotations.
+
+(define-walker-method scope annotation-decls (object env)
+  (let ((anns (annotation-decls-annotations object)))
+    (dolist (a anns)
+      (cond ((annotation-value? a)
+	     (recoverable-error 'unknown-annotation "Unknown annotation: ~A" a))
+	    ((annotation-decl? a)
+	     (dolist (v (annotation-decl-names a))
+	       (let ((name (lookup-local-name v env)))
+		 (when (not (eq? name *undefined-def*))
+		   (setf (var-annotations name)
+			 (append (var-annotations name)
+			      (annotation-decl-annotations a))))))))))
+  object)
+
+(define-walker-method scope exp-sign (object env)
+  (resolve-signature (exp-sign-signature object))
+  (setf (exp-sign-exp object) (scope-ast-1 (exp-sign-exp object) env))
+  object)
+
+;;; By the time we get to walking a valdef, all the variables it
+;;; declares have been entered into the environment.  All we need to
+;;; do is massage the pattern and recursively walk the definitions.
+
+(define-walker-method scope valdef (object env)
+  (setf (valdef-module object) *module-name*)
+  (setf (valdef-lhs object) (massage-pattern (valdef-lhs object)))
+  (setf (valdef-definitions object)
+	(scope-ast/list (valdef-definitions object) env))
+  object)
+
+
+;;; For a single-fun-def, do the where-decls first, and then walk the
+;;; rhs in an env that includes both the where-decls and the args.
+
+(define-walker-method scope single-fun-def (object env)
+  (setf env (add-pattern-variables (single-fun-def-args object) env))
+  (setf env (add-local-declarations (single-fun-def-where-decls object) env))
+  (setf (single-fun-def-where-decls object)
+	(scope-ast/decl-list (single-fun-def-where-decls object) env))
+  (setf (single-fun-def-args object)
+	(massage-pattern-list (single-fun-def-args object)))
+  (setf (single-fun-def-rhs-list object)
+	(scope-ast/list (single-fun-def-rhs-list object) env))
+  object)
+
+
+;;;===================================================================
+;;; exp-structs
+;;;===================================================================
+
+(define-walker-method scope lambda (object env)
+  (setf env (add-pattern-variables (lambda-pats object) env))
+  (setf (lambda-pats object) (massage-pattern-list (lambda-pats object)))
+  (setf (lambda-body object) (scope-ast-1 (lambda-body object) env))
+  object)
+
+(define-walker-method scope let (object env)
+  (setf env (add-local-declarations (let-decls object) env))
+  (setf (let-decls object) (scope-ast/decl-list (let-decls object) env))
+  (setf (let-body object) (scope-ast-1 (let-body object) env))
+  object)
+
+
+;;; Case alts are treated very much like single-fun-defs.
+
+(define-walker-method scope case (object env)
+  (setf (case-exp object) (scope-ast-1 (case-exp object) env))
+  (dolist (a (case-alts object))
+    (let ((env  (add-pattern-variables (list (alt-pat a)) env)))
+      (setf env (add-local-declarations (alt-where-decls a) env))
+      (setf (alt-where-decls a)
+	    (scope-ast/decl-list (alt-where-decls a) env))
+      (setf (alt-pat a) (massage-pattern (alt-pat a)))
+      (setf (alt-rhs-list a)
+	    (scope-ast/list (alt-rhs-list a) env))))
+  object)
+
+
+(define-walker-method scope var-ref (object env)
+  (when (eq? (var-ref-var object) *undefined-def*)
+	(setf (var-ref-var object)
+	      (lookup-name (var-ref-name object) env)))
+  object)
+
+(define-walker-method scope con-ref (object env)
+  (declare (ignore env))
+  (when (eq? (con-ref-con object) *undefined-def*)
+	(setf (con-ref-con object)
+	      (lookup-toplevel-name (con-ref-name object))))
+  object)
+
+(define-walker-method scope list-comp (object env)
+  (dolist (q (list-comp-quals object))
+    (cond ((is-type? 'qual-generator q)
+	   (setf (qual-generator-exp q)
+		 (scope-ast-1 (qual-generator-exp q) env))
+	   (setf env
+		 (add-pattern-variables (list (qual-generator-pat q)) env))
+	   (setf (qual-generator-pat q)
+		 (massage-pattern (qual-generator-pat q))))
+	  ((is-type? 'qual-filter q)
+	   (setf (qual-filter-exp q)
+		 (scope-ast-1 (qual-filter-exp q) env)))))
+  (setf (list-comp-exp object) (scope-ast-1 (list-comp-exp object) env))
+  object)
+
+(define-walker-method scope pp-exp-list (object env)
+  (massage-pp-exp-list (scope-ast/list (pp-exp-list-exps object) env)))
+