From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- parser/decl-parser.scm | 175 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 175 insertions(+) create mode 100644 parser/decl-parser.scm (limited to 'parser/decl-parser.scm') diff --git a/parser/decl-parser.scm b/parser/decl-parser.scm new file mode 100644 index 0000000..bf924b5 --- /dev/null +++ b/parser/decl-parser.scm @@ -0,0 +1,175 @@ +;;; File: decl-parser Author: John + +(define (parse-decl) + (let ((decl-type (find-decl-type))) + (cond ((eq? decl-type 'signdecl) + (parse-signdecl)) + ((eq? decl-type 'pat-or-op) + (parse-pat-or-op)) + ((eq? decl-type 'fundef) + (parse-fundef)) + ((eq? decl-type 'plus-def) + (parse-plus-def)) + ((eq? decl-type 'annotation) + (make annotation-decls (annotations (parse-annotations))))))) + +;;; This looks at the first tokens in a definition to determine it's type. +;;; var (:: | ,) - signdecl +;;; var apat-start - function definition +;;; (var | _) + - definition of infix + +;;; anything alse - pattern binding or infix definition + +(define (find-decl-type) + (let* ((saved-excursion (save-scanner-state)) + (decl-type + (token-case + (var (scan-var) + (token-case + ((\, \:\:) 'signdecl) + (apat-start 'fundef) + (+ 'plus-def) + (else 'pat-or-op))) + (_ (token-case + (+ 'plus-def) + (else 'pat-or-op))) + (begin-annotation 'annotation) + (else 'pat-or-op)))) + (restore-excursion saved-excursion) + decl-type)) + +;;; These are the different flavors of decl parsers + +(define (parse-signdecl) + (save-parser-context + (trace-parser signdecl + (let ((vars (parse-signdecl-vars))) + (require-token \:\: + (signal-missing-token "`::'" "signature declaration")) + (let ((signature (parse-signature))) + (make signdecl (vars vars) (signature signature))))))) + +(define (parse-signdecl-vars) + (token-case + (var (let ((var (var->ast))) + (token-case (\, (cons var (parse-signdecl-vars))) + (else (list var))))) + (else (signal-missing-token "" "signature declaration")))) + +(define (parse-pat-or-op) + (trace-parser patdef + (let* ((line-number (capture-current-line)) + (pat (parse-pat))) + (token-case + (varop (parse-infix-def pat line-number)) + (else (add-rhs pat '() '#f line-number)))))) + +(define (parse-infix-def pat1 line-number) + (let* ((op (make var-pat (var (varop->ast)))) + (pat2 (parse-pat))) + (add-rhs op (list pat1 pat2) '#t line-number))) + +(define (parse-fundef) + (trace-parser fundef + (let* ((start-line (capture-current-line)) + (fn (parse-apat)) ; must be a single variable + (args (parse-apat-list))) + (add-rhs fn args '#f start-line)))) + +(define (parse-plus-def) + (trace-parser plus-def + (let* ((start-line (capture-current-line)) + (var (parse-apat))) + (parse-infix-def var start-line)))) + +(define (add-rhs pat args infix? start-line) + (let* ((rhs (parse-rhs)) + (decls (parse-where-decls)) + (single (make single-fun-def + (args args) + (rhs-list rhs) + (where-decls decls) + (infix? infix?))) + (valdef (make valdef (lhs pat) (definitions (list single))))) + (setf (ast-node-line-number single) start-line) + (setf (ast-node-line-number valdef) start-line) + valdef)) + +(define (parse-rhs) + (token-case + (= (let ((rhs (parse-exp))) + (list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs))))) + (\| (parse-guarded-rhs)) + (else + (signal-missing-token "`=' or `|'" "rhs of valdef")))) + +(define (parse-guarded-rhs) ; assume just past | + (trace-parser guard + (let ((guard (parse-exp-i))) ; 1.2 change + (require-token = (signal-missing-token "`='" "guarded rhs")) + (let* ((exp (parse-exp)) + (res (make guarded-rhs (guard guard) (rhs exp)))) + (token-case + (\| (cons res (parse-guarded-rhs))) + (else (list res))))))) + +(define (parse-where-decls) + (token-case + (|where| + (parse-decl-list)) + (else '()))) + +(define (parse-decl-list) + (start-layout (function parse-decl-list-1))) + +(define (parse-decl-list-1 in-layout?) + (token-case + ((apat-start begin-annotation) + (let ((decl (parse-decl))) + (token-case + (\; (decl-cons decl (parse-decl-list-1 in-layout?))) + (else (close-layout in-layout?) + (list decl))))) + (else + (close-layout in-layout?) + '()))) + +;;; This adds a new decl to a decl list. Successive decls for the same fn +;;; are combined. + +(define (decl-cons decl decl-list) + (cond ((null? decl-list) + (list decl)) + (else (nconc (combine-decls decl (car decl-list)) (cdr decl-list))))) + +(define (decl-push decl decl-stack) + (cond ((null? decl-stack) + (list decl)) + (else (nconc (nreverse (combine-decls (car decl-stack) decl)) + (cdr decl-stack))))) + +(define (combine-decls decl1 decl2) + (if (and (is-type? 'valdef decl1) + (is-type? 'valdef decl2) + (same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2))) + (if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1)))) + (length (single-fun-def-args (car (valdef-definitions decl2))))) + (begin + (setf (valdef-definitions decl1) + (nconc (valdef-definitions decl1) + (valdef-definitions decl2))) + (list decl1)) + (signal-multiple-definitions-arity-mismatch (valdef-lhs decl1))) + (list decl1 decl2))) + +(define (same-decl-var? pat1 pat2) + (and (is-type? 'var-pat pat1) + (is-type? 'var-pat pat2) + (eq? (var-ref-name (var-pat-var pat1)) + (var-ref-name (var-pat-var pat2))))) + +(define (signal-multiple-definitions-arity-mismatch pat) + (parser-error 'multiple-definitions-arity-mismatch + "Definition of ~a does not match arity of previous definition." + pat)) + + -- cgit v1.2.3