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/exp-parser.scm | 230 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 230 insertions(+) create mode 100644 parser/exp-parser.scm (limited to 'parser/exp-parser.scm') diff --git a/parser/exp-parser.scm b/parser/exp-parser.scm new file mode 100644 index 0000000..6f941ae --- /dev/null +++ b/parser/exp-parser.scm @@ -0,0 +1,230 @@ +;;; File: expr-parser Author: John + +(define (parse-exp) + (trace-parser exp + (parse-exp-0))) + +(define (parse-exp-0) ;; This picks up expr type signatures + (let ((exp (parse-exp-i))) + (token-case + (\:\: (let ((signature (parse-signature))) + (make exp-sign (exp exp) (signature signature)))) + (else exp)))) + +(define (parse-exp-i) ;; This collects a list of exps for later prec parsing + (let ((exps (parse-infix-exps))) + (if (null? (cdr exps)) + (car exps) + (make pp-exp-list (exps exps))))) + +(define (parse-infix-exps) + (token-case + (- (cons (make negate) (parse-infix-exps))) + (\\ (list (parse-lambda))) + (|let| (list (parse-let))) + (|if| (list (parse-if))) + (|case| (parse-possible-app (parse-case))) + (else (let ((aexp (parse-aexp))) + (parse-possible-app aexp))))) + +(define (parse-possible-app exp) + (token-case + (aexp-start + (let ((exp2 (parse-aexp))) + (parse-possible-app (make app (fn exp) (arg exp2))))) + (varop + (let ((varop (varop->ast))) + (if (eq-token? '\)) + (list exp varop) + `(,exp ,varop ,@(parse-infix-exps))))) + (conop + (let ((conop (conop->ast))) + (if (eq-token? '\)) + (list exp conop) + `(,exp ,conop ,@(parse-infix-exps))))) + (else (list exp)))) + +(define (parse-lambda) + (trace-parser lambda + (save-parser-context + (let ((pats (parse-apat-list))) + (require-token -> (signal-missing-token "`->'" "lambda expression")) + (let ((exp (parse-exp))) + (make lambda (pats pats) (body exp))))))) + +(define (parse-let) + (trace-parser let + (save-parser-context + (let ((decls (parse-decl-list))) + (require-token |in| (signal-missing-token "`in'" "let expression")) + (let ((exp (parse-exp))) + (make let (decls decls) (body exp))))))) + +(define (parse-if) + (trace-parser if + (save-parser-context + (let ((test-exp (parse-exp))) + (require-token |then| (signal-missing-token "`then'" "if expression")) + (let ((then-exp (parse-exp))) + (require-token |else| (signal-missing-token "`else'" "if expression")) + (let ((else-exp (parse-exp))) + (make if (test-exp test-exp) + (then-exp then-exp) + (else-exp else-exp)))))))) + +(define (parse-case) + (trace-parser case + (save-parser-context + (let ((exp (parse-exp))) + (require-token |of| (signal-missing-token "`of'" "case expression")) + (let ((alts (start-layout (function parse-alts)))) + (make case (exp exp) (alts alts))))))) + +(define (parse-alts in-layout?) + (token-case + (pat-start + (let ((alt (parse-alt))) + (token-case + (\; (cons alt (parse-alts in-layout?))) + (else (close-layout in-layout?) + (list alt))))) + (else + (close-layout in-layout?) + '()))) + +(define (parse-alt) + (trace-parser alt + (let* ((pat (parse-pat)) + (rhs-list (token-case + (-> (let ((exp (parse-exp))) + (list (make guarded-rhs (guard (make omitted-guard)) + (rhs exp))))) + (\| (parse-guarded-alt-rhs)) + (else (signal-missing-token "`->' or `|'" "rhs of alt")))) + (decls (parse-where-decls))) + (make alt (pat pat) (rhs-list rhs-list) (where-decls decls))))) + +(define (parse-guarded-alt-rhs) + (let ((guard (parse-exp))) + (require-token -> (signal-missing-token "`->'" "alt")) + (let* ((exp (parse-exp)) + (res (make guarded-rhs (guard guard) (rhs exp)))) + (token-case + (\| (cons res (parse-guarded-alt-rhs))) + (else (list res)))))) + +(define (parse-aexp) + (trace-parser aexp + (token-case + (var (save-parser-context (var->ast))) + (con (save-parser-context (con->ast))) + (literal (literal->ast)) + (\( + (token-case + (\) (**con/def (core-symbol "UnitConstructor"))) + ((no-advance -) (parse-exp-or-tuple)) + (varop + (let ((varop (varop->ast))) + (make-right-section varop))) + (conop + (let ((conop (conop->ast))) + (make-right-section conop))) + (else + (parse-exp-or-tuple)))) + (\[ + (token-case + (\] (make list-exp (exps '()))) + (else + (let ((exp (parse-exp))) + (token-case + (\, (let ((exp2 (parse-exp))) + (token-case + (\] (make list-exp (exps (list exp exp2)))) + (\.\. (token-case + (\] (make sequence-then (from exp) (then exp2))) + (else + (let ((exp3 (parse-exp))) + (require-token + \] + (signal-missing-token + "`]'" "sequence expression")) + (make sequence-then-to (from exp) (then exp2) + (to exp3)))))) + (else + (make list-exp + (exps `(,exp ,exp2 ,@(parse-exp-list)))))))) + (\.\. (token-case + (\] (make sequence (from exp))) + (else + (let ((exp2 (parse-exp))) + (require-token + \] + (signal-missing-token "`]'" "sequence expression")) + (make sequence-to (from exp) (to exp2)))))) + (\] (make list-exp (exps (list exp)))) + (\| (parse-list-comp exp)) + (else + (signal-invalid-syntax + "a list, sequence, or list comprehension"))))))) + (else + (signal-invalid-syntax "an aexp"))))) + +(define (make-right-section op) + (let ((exps (parse-infix-exps))) + (token-case + (\) (make pp-exp-list (exps (cons op exps)))) + (else (signal-missing-token "`)'" "right section expression"))))) + +(define (parse-exp-list) + (token-case + (\] '()) + (\, (let ((exp (parse-exp))) (cons exp (parse-exp-list)))) + (else (signal-missing-token "`]' or `,'" "list expression")))) + +(define (parse-exp-or-tuple) + (let ((exp (parse-exp))) + (token-case + (\) exp) ; Note - sections ending in an op are parsed elsewhere + (else (make-tuple-cons (cons exp (parse-tuple-exp))))))) + +(define (parse-tuple-exp) + (token-case + (\) '()) + (\, (let ((exp (parse-exp))) (cons exp (parse-tuple-exp)))) + (else (signal-missing-token + "`)' or `,'" "tuple or parenthesized expression")))) + +;;; List comprehensions + +;;; Assume | has been consumed + +(define (parse-list-comp exp) + (save-parser-context + (let ((quals (parse-qual-list))) + (make list-comp (exp exp) (quals quals))))) + +(define (parse-qual-list) + (let ((qual (parse-qual))) + (token-case + (\, (cons qual (parse-qual-list))) + (\] (list qual)) + (else (signal-missing-token "`]' or `,'" "list comprehension"))))) + +(define (parse-qual) + (trace-parser qual + (save-parser-context + (let* ((saved-excursion (save-scanner-state)) + (is-gen? (and (scan-pat) (eq-token? '<-)))) + (restore-excursion saved-excursion) + (cond (is-gen? + (let ((pat (parse-pat))) + (advance-token) ; past the <- + (let ((exp (parse-exp))) + (make qual-generator (pat pat) (exp exp))))) + (else + (let ((exp (parse-exp))) + (make qual-filter (exp exp))))))))) + +(define (make-tuple-cons args) + (let ((tuple-con (**con/def (tuple-constructor (length args))))) + (**app/l tuple-con args))) -- cgit v1.2.3