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/module-parser.scm | 312 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 312 insertions(+) create mode 100644 parser/module-parser.scm (limited to 'parser/module-parser.scm') diff --git a/parser/module-parser.scm b/parser/module-parser.scm new file mode 100644 index 0000000..2ffa391 --- /dev/null +++ b/parser/module-parser.scm @@ -0,0 +1,312 @@ +;;; File: module-parser Author: John + +;;; This is for using the parser to parse strings. + +(define (parse-from-string string parse-proc filename) + (dynamic-let ((*current-file* filename)) + (call-with-input-string string + (lambda (port) + (let ((tokens (lex-port port '#f))) + (init-token-stream tokens) + (let ((res (funcall parse-proc))) + (if (not (eq-token? 'eof)) + (signal-leftover-tokens) + res))))))) + +(define (signal-leftover-tokens) + (fatal-error 'leftover-tokens + "Leftover tokens after parsing.")) + + +;;; This file deals with the basic structure of a module. It also adds +;;; the `module Main where' required by abbreviated modules. + +(define (parse-tokens tokens) + (init-token-stream tokens) + (let ((mod (token-case + (|module| (parse-module)) + (else (parse-modules/named '|Main| '()))))) + (cons mod (parse-module-list)))) + +(define (parse-module) + (token-case + (modid (let* ((mod-name (token->symbol)) + (exports (parse-exports))) + (require-token + |where| + (signal-missing-token "`where'" "module definition")) + (parse-modules/named mod-name exports))) + (else (signal-missing-token "" "module definition")))) + +(define (parse-module-list) + (token-case + (|module| + (let ((mod (parse-module))) + (cons mod (parse-module-list)))) + (eof '()) + (else (signal-missing-module)))) + +(define (signal-missing-module) + (parser-error 'missing-module + "Missing `module', or leftover junk after module definition.")) + +(define (parse-exports) + (token-case + (\( (parse-export-list)) + (else '()))) + +(define (parse-export-list) + (let ((entity (parse-entity 'export))) + (token-case + (\) (list entity)) + (\, (cons entity (parse-export-list))) + (else (signal-missing-token "`)' or ','" "export list"))))) + +(define (parse-modules/named mod-name exports) + (trace-parser module + (let ((mod-ast (make module + (name mod-name) + (type 'standard) + (exports exports) + (default *standard-module-default*)))) + (start-layout (lambda (in-layout?) + (parse-module-decls mod-ast in-layout? 'import)))))) + +;;; The mod-ast fields are kept in non-reversed order by appending +;;; each decl to the end of the appropriate list. This loses for +;;; value decls, so these are in reversed order!! + +(define (parse-module-decls mod-ast in-layout? state) + (token-case + (|import| (let ((import (parse-import))) + (if (eq? state 'import) + (push-decl-list import (module-imports mod-ast)) + (signal-misplaced-import))) + (terminate-topdecl mod-ast in-layout? state)) + (|infix| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'n mod-ast state))) + (|infixl| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'l mod-ast state))) + (|infixr| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'r mod-ast state))) + (|data| (let ((data-decl (parse-type-decl '#f))) + (push-decl-list data-decl (module-algdatas mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|type| (let ((synonym-decl (parse-synonym-decl))) + (push-decl-list synonym-decl (module-synonyms mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|class| (let ((class-decl (parse-class-decl))) + (push-decl-list class-decl (module-classes mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|instance| (let ((instance-decl (parse-instance-decl '#f))) + (push-decl-list instance-decl (module-instances mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|default| (let ((types + (token-case + (\( (token-case (\) '()) + (else (parse-type-list)))) + (else (list (parse-type)))))) + (if (eq? (module-default mod-ast) *standard-module-default*) + (setf (module-default mod-ast) + (make default-decl (types types))) + (signal-multiple-defaults))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + ((begin-annotation no-advance) + (let ((annotations (parse-annotations))) + (setf (module-annotations mod-ast) + (append (module-annotations mod-ast) annotations))) + (terminate-topdecl mod-ast in-layout? state)) + (pat-start (let ((decl (parse-decl))) + (setf (module-decls mod-ast) + (decl-push decl (module-decls mod-ast)))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (else + (maybe-end-module mod-ast in-layout? state)))) + +(define (signal-misplaced-import) + (parser-error 'misplaced-import + "The import declaration is misplaced.")) + +(define (signal-multiple-defaults) + (parser-error 'multiple-defaults + "There are multiple default declarations.")) + +(define (terminate-topdecl mod-ast in-layout? state) + (token-case + (\; (parse-module-decls mod-ast in-layout? state)) + (else (maybe-end-module mod-ast in-layout? state)))) + +(define (maybe-end-module mod-ast in-layout? state) + (declare (ignore state)) + (cond ((or (eq-token? '|module|) (eq-token? 'eof) (eq-token? '\}) + (eq-token? '$\})) + (close-layout in-layout?) + (wrapup-module mod-ast) + mod-ast) + (else + (signal-invalid-syntax "a topdecl")))) + +(define (wrapup-module mod-ast) + (setf (module-decls mod-ast) + (nreverse (module-decls mod-ast))) + (when (and (null? (module-imports mod-ast)) + (null? (module-decls mod-ast)) + (null? (module-algdatas mod-ast)) + (null? (module-synonyms mod-ast)) + (null? (module-instances mod-ast)) + (null? (module-classes mod-ast))) + (signal-empty-module))) + +(define (signal-empty-module) + (parser-error 'empty-module "Module definition is empty.")) + +(define (parse-import) + (save-parser-context + (token-case + (modid (let ((mod (token->symbol)) + (mode 'all) + (specs '())) + (token-case + (\( (setf mode 'by-name) + (token-case + (\) (setf specs '())) + (else (setf specs (parse-import-list))))) + (|hiding| (require-token + \( + (signal-missing-token "`('" "hiding clause")) + (setf specs (parse-import-list))) + (else '())) + (let ((renamings (token-case (|renaming| + (require-token + \( + (signal-missing-token + "`('" "renaming clause")) + (parse-renamings)) + (else '())))) + (make import-decl (module-name mod) (mode mode) (specs specs) + (renamings renamings))))) + (else + (signal-missing-token "" "import declaration"))))) + +(define (parse-import-list) + (let ((import (parse-entity 'import))) + (token-case + (\, (cons import (parse-import-list))) + (\) (list import)) + (else (signal-missing-token "`)' or `,'" "import list"))))) + +(define (parse-renamings) + (let ((renaming + (save-parser-context + (token-case + (var (let ((name1 (var->symbol))) + (require-token + |to| + (signal-missing-token "`to'" "import renaming clause")) + (token-case + (var (let ((name2 (var->symbol))) + (make renaming (from name1) (to name2) + (referenced? '#f)))) + (else (signal-invalid-syntax "import renaming clause"))))) + (con (let ((name1 (con->symbol))) + (require-token + |to| + (signal-missing-token "`to'" "import renaming clause")) + (token-case + (con (let ((name2 (con->symbol))) + (make renaming (from name1) (to name2) + (referenced? '#f)))) + (else (signal-invalid-syntax "import renaming clause"))))) + (else (signal-invalid-syntax "import renaming clause")))))) + (token-case (\, (cons renaming (parse-renamings))) + (\) (list renaming))))) + +(define (parse-fixity associativity mod-ast state) + (let ((fixity-decl + (save-parser-context + (let* ((prec (token-case + (k (let ((p (token->integer))) + (cond ((<= p 9) + p) + (else + (signal-bad-fixity) + 9)))) + (else 9))) + (ops (parse-op-list)) + (fixity (make fixity (associativity associativity) + (precedence prec)))) + (make fixity-decl (fixity fixity) (names ops)))))) + (push-decl-list fixity-decl (module-fixities mod-ast)) + (cond ((or (eq? state 'import) + (eq? state 'fixity)) + 'fixity) + (else + (signal-misplaced-fixity) + state)))) + + +(define (signal-bad-fixity) + (parser-error 'bad-fixity + "Expecting fixity value of 0 - 9.")) + +(define (signal-misplaced-fixity) + (parser-error 'misplaced-fixity "The fixity declaration is misplaced.")) + +(define (parse-op-list) + (let ((name (token-case + (op (op->symbol)) + (else (signal-missing-token "" "fixity declaration"))))) + (token-case + (\, (cons name (parse-op-list))) + (else (list name))))) + +(define (parse-entity context) + (trace-parser entity + (save-parser-context + (token-case + (var (var->entity)) + (tycon + (let ((name (token->symbol))) + (token-case + (\( (token-case + (\.\. (require-token + '\) + (signal-missing-token "`)'" "class or datatype entity")) + (make entity-abbreviated (name name))) + (var (parse-entity-class name)) + (con (parse-entity-datatype name)) + (\) (make entity-class (name name) (methods '()))) + (else (signal-invalid-syntax "an entity")))) + (\.\. (if (eq? context 'export) + (make entity-module (name name)) + (signal-invalid-syntax "an entity"))) + (else + (make entity-con (name name)))))) + (else (signal-invalid-syntax "an entity")))))) + +(define (parse-entity-class class-name) + (let ((vars (parse-var-list))) + (make entity-class (name class-name) (methods vars)))) + +(define (parse-entity-datatype type-name) + (let ((constrs (parse-con-list))) + (make entity-datatype (name type-name) (constructors constrs)))) + +(define (parse-var-list) + (token-case + (var (let ((name (var->symbol))) + (token-case + (\) (list name)) + (\, (cons name (parse-var-list))) + (else + (signal-missing-token "`)' or `,'" "class entity"))))) + (else (signal-missing-token "" "class entity")))) + +(define (parse-con-list) + (token-case + (con (let ((name (con->symbol))) + (token-case + (\) (list name)) + (\, (cons name (parse-con-list))) + (else (signal-missing-token "`)' or `,'" "datatype entity"))))) + (else (signal-missing-token "" "datatype entity")))) -- cgit v1.2.3