; These are the functions for implementing the recursive descent
;   parser of Assignment 2, CS 152, Fall 2000.  The top-level
;   functions are "parse", "traverse", and "yield", as documented
;   in the test file "a2test.scm".


; The "parse" function attempts to parse the text given in the file
;   "filename".  It calls the "compile" function which merely reads
;   the first input token and passes it to the function responsible
;   for processing the nonterminal corresponding to the start symbol
;   "Conditional".  This function returns a boolean value.
  
; The "parse" function returns the value found by the "compile"
;   function, unless
;      (1) there was text left over in the file after the parse, or
;      (2) the parse failed.
; In each of these cases, the value #f will be returned after the
;   printing of an appropriate error message.
; A nonexistent file will result in an error.

; The variables "current-token" and "port" are global variables 
;   defined below.

(define (parse filename)
  
  (define (compile)
    (set! current-token (read port))
    (conditional?))
  
  (set! port (open-input-file filename))
  (if port 		
      (let ((result (compile)))
        (close-input-port port)
        (if result
            (if (eof-object? current-token)
                result
                (begin
                  (display "UNEXPECTED TEXT AT END OF FILE")
                  (newline)
                  #f))
            #f))
      (begin (display "can't find file")
             #f)))





; The following variables contain the current input port and the
;   most recently read token, respectively.  Their initial values
;   are dummies.

(define port #f)            ;      "
(define current-token #f)   ; to be redefined during parsing


 
; This is the "first" function used in recursive-descent parsing.  For this
;   grammar, it only needs to be defined for the "Statement" nonterminal.

(define (first x) 
  (cond ((eq? x 'statement) '(x y z))
        (else '())))



;;;;;;;;;;;;;;;;; some i/o and text utility functions ;;;;;;;;;;;;;;;;


; This boolean valued function determines whether the current token 
;   matches a target token.

(define (match-token target)
  (eq? current-token target))



; This function gets the next token from the input port

(define (consume-token)
  (let ((result current-token))
    (set! current-token (read port))
    result))
 

; This function gets the next token from the input port,
;   if the current token is the same as the target.
; Otherwise it prints an error message describing the
;   mismatch, and returns #f.

(define (match-and-consume-token target)
  (if (match-token  target)
      (consume-token)
      (begin (display "ERROR: TOKEN ")
             (display current-token)
             (display " FOUND, TOKEN ")
             (display target)
             (display " EXPECTED")
             (newline)
             #f)))


; This function generates an error message to the effect
;   that the current token is not expected.

(define (unexpected-token)
  (display "UNEXPECTED TOKEN ")
  (display current-token)
  (display " FOUND")
  (newline)
  #f)



;;;;;;;;;; functions for parse trees and grammar symbols ;;;;;;;;;;;

; This function processes the list "symbols" of processing functions
;   corresponding to symbols on the RHS of a rule whose LHS is the 
;   given nonterminal.
; The function to process to next symbol on the RHS is found in 
;   (car symbols).  Its value is found and saved in "result0".  If
;   this value is #f (that is, if an error arises in its processing)
;   then this value is returned immediately to the caller.  Otherwise
;   the processing functions corresponding to the rest of the RHS
;   are processed recursively.  If this is done without error, a 
;   parse tree node is returned.  This node is represented by a list
;   whose CAR is the nonterminal and whose CDR is a list of the 
;   results of processing the symbols on the RHS.  In case of error
;   in the recursive processing, #f is returned.

(define (process nonterminal symbols)
  (define (process-symbols symbols)
    (cond ((null? symbols) '())
          (else (let ((result0 (eval (car symbols))))
                        (if result0
                            (let ((result1 (process-symbols (cdr symbols))))
                              (if result1
                                  (cons result0 result1)
                                  #f))
                            #f)))))
  (let ((result (process-symbols symbols)))
    (if result
        (make-tree nonterminal result)
        #f)))


; selectors for parse trees

(define (data tree) (if (pair? tree) (car tree) tree))
(define first-child cadr)
(define children cdr)
(define (leaf? tree) (not (pair? tree)))

; the constructor for parse trees.  It takes a root and
;   a list of child trees.  Note that leaves are represented
;   as symbols.

(define (make-tree root childlist) (cons root childlist))
  
  
; selectors and a predicate for parse trees.  The function
;  "data" returns the data in the root.

(define (data tree) (if (pair? tree) (car tree) tree))
(define first-child cadr)
(define children cdr)
(define (leaf? tree) (not (pair? tree)))


; The tree traversal function simply prints the nodes of the tree
;   from left to right, with each node indented proportional to
;   its level in the tree.  An error message is printed if the tree
;   is ill-formed (has value #f).
; The function calls a recursive helper function that takes a tree
;   to be traversed, and the string of spaces of the appropriate
;   length that is to be printed before its root.

(define (traverse tree)
  (define (helper tree indenting)
    (display indenting)
    (display (data tree))
    (newline)
    (if (not (leaf? tree))
        (for-each (lambda (x) 
                    (helper x (string-append "  " indenting)))
                            (children tree))))
  (if tree 
      (helper tree "")
      (display "no tree to traverse")))


; The function to return the yield of a parse tree (i.e., the list of
;   leaf values from left to right) proceeds in two stages.  First,
;   the nonterminals are removed from the tree.  This is done
;   recursively by "strip-nonterminals".  Then the resulting tree,
;   represented by a nested list, is flattened to give a list of tokens.
;   This is done by the function "flatten".

(define (yield tree)
  (define (strip-nonterminals tree)
    (cond ((leaf? tree) tree)
          ((pair? tree) (map yield (children tree)))
          (else tree)))
  (define (flatten ls)
    (cond ((null? ls) '())
          ((not (pair? ls)) ls)
          ((pair? (car ls)) (append (flatten (car ls)) (flatten (cdr ls))))
          (else (cons (car ls) (flatten (cdr ls))))))
  (if (null? tree) 
      (begin (display "no tree for yield") (newline) #f)
      (flatten (strip-nonterminals tree))))



;;;;;;;;;;;;;;;;; FUNCTIONS TO PROCESS NONTERMINALS ;;;;;;;;;;;;;;;;;


; Each function handling the rules for a nonterminal is defined in 
;   terms of a "process" function, whose arguments are
;     (1) a Scheme symbol representing the nonterminal, and 
;     (2) a list of functions to be executed
;   in the processing of the nonterminal.  Each such function 
;   corresponds to a symbol on the RHS of a rule
; This mechanism is used to simplify error handling.  After an error,
;   an appropriate error message is printed and the value #f is 
;   propagated to the top-level parse function.

;;;;;;;;;;;;;;;; Process the nonterminal "Conditional" ;;;;;;;;;;;;;;

(define (conditional?)
  (process 'Conditional
           '((short-if?)
             (rest-if?))))
      


;;;;;;;;;;;;;;;; Process the nonterminal "Short-if" ;;;;;;;;;;;;;;

(define (short-if?)
  (process 'ShortIf
           '((match-and-consume-token  'if)
             (test?)
             (match-and-consume-token  'then)
             (block?))))
       
      

;;;;;;;;;;;;;;;; Process the nonterminal "Rest-if" ;;;;;;;;;;;;;;

(define (rest-if?)
  (cond ((match-token  'endif) 
         (process 'RestIf
                  '((consume-token))))
        ((match-token 'else)
         (process 'RestIf
                  '((consume-token)
                    (block?)
                    (match-and-consume-token  'endif))))
        (else (unexpected-token))))
      


;;;;;;;;;;;;;;;; Process the nonterminal "Test" ;;;;;;;;;;;;;;;;;;

(define (test?)
  (process 'Test
           '((match-and-consume-token  '<)
             (var?)
             (op?)
             (var?)
             (match-and-consume-token  '>))))
      


;;;;;;;;;;;;;;;; Process the nonterminal "Block" ;;;;;;;;;;;;;;

(define (block?)
  (process 'Block
           '((match-and-consume-token  'begin)
             (rest-block?))))
      


;;;;;;;;;;;;;;;; Process the nonterminal "RestBlock" ;;;;;;;;;;;;;;
; Note that the call to "first" is unnecessary here, but for more
;   general grammars such a call will be required.
  
(define (rest-block?)
  (cond ((match-token  'end)
         (process 'RestBlock
                  '((consume-token))))
        ((member current-token (first 'statement))
         (process 'RestBlock
                  '((statement?)
                    (statements?))))
        (else (unexpected-token))))
      

;;;;;;;;;;;;;;;; Process the nonterminal "Statements" ;;;;;;;;;;;;;;
; Note that the call to "first" is unnecessary here, but for more
;   general grammars such a call will be required.

(define (statements?)
  (cond ((match-token  'end)
         (process 'Statements
                  '((consume-token))))
        ((member current-token (first 'statement))
         (process 'Statements
                  '((statement?)
                    (statements?))))
        (else (unexpected-token))))


;;;;;;;;;;;;;;;;; Process the nonterminal "Statement"  ;;;;;;;;;;;;;;;;

(define (statement?)
  (process 'Statement
           '((var?) 
             (match-and-consume-token  ':=)
             (var?))))
      

;;;;;;;;;;;;;;;;; Process the nonterminal "Var"  ;;;;;;;;;;;;;;;;

(define (var?)
  (cond ((match-token  'x) 
         (process 'Var
                  '((consume-token))))
        ((match-token  'y) 
         (process 'Var
                  '((consume-token))))
        ((match-token  'z) 
         (process 'Var
                  '((consume-token))))
        (else (unexpected-token))))
      

;;;;;;;;;;;;;;;;; Process the nonterminal "Op"  ;;;;;;;;;;;;;;;;

(define (op?)
  (cond ((match-token  '=) 
         (process 'Op
                  '((consume-token))))
        ((match-token  '/=) 
         (process 'Op
                  '((consume-token))))
        (else (unexpected-token))))