diff options
Diffstat (limited to 'prec')
| -rw-r--r-- | prec/README | 2 | ||||
| -rw-r--r-- | prec/prec-parse.scm | 253 | ||||
| -rw-r--r-- | prec/prec.scm | 18 | ||||
| -rw-r--r-- | prec/scope.scm | 367 |
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))) + |