;;; Code stored as:  {turing}<3-lisp.problem-sets>arith-parser.3-lisp
;;;                  {phylum}<3-lisp>course>problem-sets>arith-parser.3-lisp


;;;==========================================================================
;;;                   Simple ARITH Expression Parser
;;;==========================================================================
;;;
;;; Parses ARITH expressions.

;;; Built on top of the Lexical Analyser
;;; ------------------------------------

;;; Assumed grammar:  (<token> is the primitive lexical item)
;;;
;;;     <expression> ::= <numeral> | <complex>
;;; 
;;;     <complex>    ::= <operator> "(" <expression> "," <expression> ")"
;;; 
;;;     <operator>   ::= "+" | "-" | "*" | "/"

;;; ARITH-PARSE  Main parsing routine.  Returns a parse tree, or else.
;;; ===========  the string "rejected" if not a well-formed ARITH expression.

(define ARITH-PARSE
   (lambda [string]
      (let [[parse (dynamic-catch
                      (arith-parse-expression (lexical-analysis string)))]]
         (if (null (second parse))
             (first parse)
             "rejected"))))

;;; Ancillary parsing functions:
;;;
;;;    The following procedures call ARITH-ERROR-IN-PARSE immediately upon
;;;    finding a grammatical error of any sort, which does not return (since
;;;    the procedures below are not designed to do anything sensible about
;;;    continuing from errors), but instead does a DYNAMIC-THROW (q.v.).

;;; Each of the parsing routines will return a parse/tail pair;


;;; ARITH-PARSE-EXPRESSION  Attempts to parse an arbitrary ARITH expression.
;;; ======================  

(define ARITH-PARSE-EXPRESSION
   (lambda [tail]
      (append-results ['expression]
           (cond [(member (first tail) ["+" "*" "-" "/"])
                  (arith-parse-args ['complex ['operator (first tail)]]
                                    (rest tail))]
                 [(numeral-expression (first tail))
                  [['numeral-expression (first tail)] (rest tail)]]
                 [$true (arith-error-in-parse)]))))

;;; ARITH-PARSE-ARGS  attempts to recognize an ARITH args expression
;;; ====================

(define ARITH-PARSE-ARGS
   (lambda [new tail]
      (letseq [[parse (append-results new (arith-parse-token "(" tail))]
               [parse (append-results (first parse) (arith-parse-expression (second parse)))]
               [parse (append-results (first parse) (arith-parse-token "," (second parse)))]
               [parse (append-results (first parse) (arith-parse-expression (second parse)))]
               [parse (append-results (first parse) (arith-parse-token ")" (second parse)))]]
          parse)))

(define APPEND-RESULTS
   (lambda [new result]
      [(append new [(first result)]) (second result)]))

(define ARITH-PARSE-TOKEN
   (lambda [token tail]
      (if (and (not (null tail))
               (= token (first tail)))
          [token (rest tail)]
          (arith-error-in-parse))))

;;; ARITH-ERROR-IN-PARSE   Signals an error by sending back the string "rejected".
;;; ====================

(define ARITH-ERROR-IN-PARSE
   (lambda []
      (dynamic-throw [[] ["something"]])))



;;; ========================================================================
;;;   DIFFERENT VERSION USING OBJECTS
;;; ========================================================================

;;; A2-PARSE     Main parsing routine.  Returns "rejected" if <string> is not
;;; ========     a well-formed ARITH expression; otherwise a parse tree.

(define A2-PARSE
   (lambda [string]
      (letseq [[s (lexan-object string)]
               [answer (dynamic-catch (a2-parse-expression s))]]
         (if (and (= (next-token s) 'eot)
                  (sequence answer))
             answer
             "Rejected"))))

;;; Ancillary parsing functions:
;;;
;;;    The following procedures call A2-ERROR-IN-PARSE immediately upon
;;;    finding a grammatical error of any sort, which does not return (since
;;;    the procedures below are not designed to do anything sensible about
;;;    continuing from errors), but instead does a DYNAMIC-THROW (q.v.).

;;; A2-PARSE-EXPRESSION   Attempts to parse an arbitrary ARITH expression.
;;; ===================  .

(define A2-PARSE-EXPRESSION
   (lambda [s]
      ['expression
       (cond [(member (next-token s) ["+" "*" "-" "/"])
              (cons 'complex
                    (cons ['operator (get-token s)]
                          (a2-parse-args s)))]
             [(numeral-expression (next-token s))
              ['numeral-expression (get-token s)]]
             [$true (a2-error-in-parse)])]))

;;; A2-PARSE-ARGS   Attempts to parse an ARITH args expression
;;; =================

(define A2-PARSE-ARGS
   (lambda [s]
      [(a2-parse-token "(" s)
       (a2-parse-expression s)
       (a2-parse-token "," s)
       (a2-parse-expression s)
       (a2-parse-token ")" s)]))

;;; A2-PARSE-TOKEN    Ensures that the next token in s is <token>; returns it
;;; ==============    as the parse.

(define A2-PARSE-TOKEN
   (lambda [token s]
      (if (not (= token (get-token s)))
          (a2-error-in-parse)
          token)))

;;; A2-ERROR-IN-PARSE   Signals an error by sending back something which isn't
;;; =================   a sequence, and therefore cannot be a valid parse.

(define A2-ERROR-IN-PARSE
   (lambda []
      (dynamic-throw 'not-a-sequence)))