diff options
author | Yale AI Dept <ai@nebula.cs.yale.edu> | 1993-07-14 13:08:00 -0500 |
---|---|---|
committer | Duncan McGreggor <duncan.mcgreggor@rackspace.com> | 1993-07-14 13:08:00 -0500 |
commit | 4e987026148fe65c323afbc93cd560c07bf06b3f (patch) | |
tree | 26ae54177389edcbe453d25a00c38c2774e8b7d4 /parser/type-parser.scm |
Import to github.
Diffstat (limited to 'parser/type-parser.scm')
-rw-r--r-- | parser/type-parser.scm | 116 |
1 files changed, 116 insertions, 0 deletions
diff --git a/parser/type-parser.scm b/parser/type-parser.scm new file mode 100644 index 0000000..79c5dbf --- /dev/null +++ b/parser/type-parser.scm @@ -0,0 +1,116 @@ +;;; File: type-parser Author: John + +(define (parse-type) + (let ((type (parse-btype))) + (token-case + (-> + (**tycon/def (core-symbol "Arrow") (list type (parse-type)))) + (else type)))) + +(define (parse-btype) + (token-case + (tycon (let* ((tycon (tycon->ast)) + (tycon-args (parse-atype-list))) + (setf (tycon-args tycon) tycon-args) + tycon)) + (else + (parse-atype)))) + +(define (parse-atype-list) + (token-case + (atype-start + (let ((atype (parse-atype))) + (cons atype (parse-atype-list)))) + (else '()))) + +(define (parse-atype) + (token-case + (tyvar (tyvar->ast)) + (tycon (tycon->ast)) + (\( (token-case + (\) (**tycon/def (core-symbol "UnitType") '())) + (else + (let ((type (parse-type))) + (token-case + (\) type) + (\, (let ((types (cons type (parse-type-list)))) + (**tycon/def (tuple-tycon (length types)) types))) + (else + (signal-missing-token "`)' or `,'" "type expression"))))))) + (\[ (let ((type (parse-type))) + (require-token \] (signal-missing-token "`]'" "type expression")) + (**tycon/def (core-symbol "List") (list type)))) + (else + (signal-invalid-syntax "an atype")))) + +(define (parse-type-list) + (let ((type (parse-type))) + (token-case (\, (cons type (parse-type-list))) + (\) (list type)) + (else (signal-missing-token "`)' or `,'" "type expression"))))) + +;;; This is used to determine whether a type is preceded by a context + +(define (has-optional-context?) + (let* ((saved-excursion (save-scanner-state)) + (res (token-case + (conid + (token-case + (varid (eq-token? '=>)) + (else '#f))) + (\( (scan-context)) + (else '#f)))) + (restore-excursion saved-excursion) + res)) + +(define (scan-context) + (token-case + (conid + (token-case + (varid + (token-case + (\) (eq-token? '=>)) + (\, (scan-context)) + (else '#f))) + (else '#f))) + (else '#f))) + +(define (parse-context) + (let ((contexts (token-case + (tycon + (list (parse-single-context))) + (\( (parse-contexts)) + (else + (signal-invalid-syntax "a context"))))) + (require-token => (signal-missing-token "`=>'" "context")) + contexts)) + +(define (parse-single-context) + (let ((class (class->ast))) + (token-case + (tyvar + (let ((tyvar (token->symbol))) + (make context (class class) (tyvar tyvar)))) + (else (signal-missing-token "<tyvar>" "class assertion"))))) + +(define (parse-contexts) + (token-case + (tycon (let ((context (parse-single-context))) + (token-case + (\, (cons context (parse-contexts))) + (\) (list context)) + (else (signal-missing-token "`)' or `,'" "context"))))) + (else (signal-missing-token "<tycon>" "class assertion")))) + +(define (parse-optional-context) + (if (has-optional-context?) + (parse-context) + '())) + +(define (parse-signature) + (let* ((contexts (parse-optional-context)) + (type (parse-type))) + (make signature (context contexts) (type type)))) + + +
\ No newline at end of file |