(module nolife-parser 
  mzscheme
  
  (require (lib "lex.ss" "parser-tools"))
  (require (lib "yacc.ss" "parser-tools"))
  (require (prefix : (lib "lex-sre.ss" "parser-tools")))
  
  (define-lex-abbrevs 
    (const-char-re (:: "'" (char-complement "'") "'"))
    (const-float-re (:: (:or "0" (:: (:/ "1" "9") (:* (:/ "0" "9")))) 
                        "." 
                        (:* (:/ "0" "9"))
                        (:? (:: (:or "e" "E") 
                                (:? (:or "+" "-"))
                                (:or "0" (:: (:/ "1" "9") (:* (:/ "0" "9"))))))))
    (const-int-re (:: (:or "0" (:: (:/ "1" "9") (:* (:/ "0" "9"))))))
    (const-str-re (:: "'" (complement (:: any-string "'" any-string)) "'"))
    (identifier-re (:: alphabetic (:* (:or alphabetic (:/ "0" "9")))))
    (comment-re (:: "{" (complement (:: any-string "}" any-string)) "}"))
    )
  
  (define-tokens nolife-tokens
    (
     TOK_AND
     TOK_ARRAY
     TOK_BEGIN
     TOK_CASE
     TOK_CHARACTER
     TOK_DO
     TOK_ELSE
     TOK_END
     TOK_EOF
     TOK_FLOAT
     TOK_FUNCTION
     TOK_IF
     TOK_INTEGER
     TOK_MOD
     TOK_NOT
     TOK_OF
     TOK_OR
     TOK_PROCEDURE
     TOK_PROGRAM
     TOK_READ
     TOK_RETURN
     TOK_THEN
     TOK_VAR
     TOK_WHILE
     TOK_WRITE
     TOK_LT
     TOK_LE
     TOK_GT
     TOK_GE
     TOK_EQ
     TOK_NE
     TOK_ASSIGN
     TOK_COLON
     TOK_SEMICOLON
     TOK_COMMA
     TOK_LBRACKET
     TOK_RBRACKET
     TOK_LPAREN
     TOK_RPAREN
     TOK_DOTDOT
     TOK_PLUS
     TOK_MINUS
     TOK_TIMES
     TOK_CONST_CHAR
     TOK_CONST_STR
     TOK_CONST_INT
     TOK_CONST_FLOAT
     TOK_WHITESPACE
     TOK_COMMENT
     TOK_IDENTIFIER
     ))
  
  (define nolife-lexer (lambda (inp)
                         (letrec (
                                  (get-nolife-token (lexer
                                                     ("AND" (token-TOK_AND #f))
                                                     ("ARRAY" (token-TOK_ARRAY #f))
                                                     ("BEGIN" (token-TOK_BEGIN #f))
                                                     ("CASE" (token-TOK_CASE #f))
                                                     ("CHARACTER" (token-TOK_CHARACTER #f))
                                                     ("DO" (token-TOK_DO #f))
                                                     ("ELSE" (token-TOK_ELSE #f))
                                                     ("END" (token-TOK_END #f))
                                                     ("FLOAT" (token-TOK_FLOAT #f))
                                                     ("FUNCTION" (token-TOK_FUNCTION #f))
                                                     ("IF" (token-TOK_IF #f))
                                                     ("INTEGER" (token-TOK_INTEGER #f))
                                                     ("MOD" (token-TOK_MOD #f))
                                                     ("NOT" (token-TOK_NOT #f))
                                                     ("OF" (token-TOK_OF #f))
                                                     ("OR" (token-TOK_OR #f))
                                                     ("PROCEDURE" (token-TOK_PROCEDURE #f))
                                                     ("PROGRAM" (token-TOK_PROGRAM #f))
                                                     ("READ" (token-TOK_READ #f))
                                                     ("RETURN" (token-TOK_RETURN #f))
                                                     ("THEN" (token-TOK_THEN #f))
                                                     ("VAR" (token-TOK_VAR #f))
                                                     ("WHILE" (token-TOK_WHILE #f))
                                                     ("WRITE" (token-TOK_WRITE #f))
                                                     ("<=" (token-TOK_LE #f))
                                                     ("<" (token-TOK_LT #f))
                                                     (">=" (token-TOK_GE #f))
                                                     (">" (token-TOK_GT #f))
                                                     ("=" (token-TOK_EQ #f))
                                                     ("<>" (token-TOK_NE #f))
                                                     (":=" (token-TOK_ASSIGN #f))
                                                     (":" (token-TOK_COLON #f))
                                                     (";" (token-TOK_SEMICOLON #f))
                                                     ("," (token-TOK_COMMA #f))
                                                     ("[" (token-TOK_LBRACKET #f))
                                                     ("]" (token-TOK_RBRACKET #f))
                                                     ("(" (token-TOK_LPAREN #f))
                                                     (")" (token-TOK_RPAREN #f))
                                                     (".." (token-TOK_DOTDOT #f))
                                                     ("+" (token-TOK_PLUS #f))
                                                     ("-" (token-TOK_MINUS #f))
                                                     ("*" (token-TOK_TIMES #f))
                                                     (const-char-re (token-TOK_CONST_CHAR lexeme))
                                                     (const-str-re (token-TOK_CONST_STR lexeme))
                                                     (identifier-re (token-TOK_IDENTIFIER lexeme))
                                                     (const-int-re (token-TOK_CONST_INT lexeme))
                                                     (comment-re (token-TOK_COMMENT lexeme))
                                                     ((:* whitespace) (token-TOK_WHITESPACE lexeme))
                                                     (const-float-re (if (equal? #\. (peek-char input-port))
                                                                         (begin
                                                                           (file-position input-port
                                                                                          (- (file-position input-port) 1))
                                                                           (token-TOK_CONST_INT
                                                                            (substring lexeme 
                                                                                       0 
                                                                                       (- (string-length lexeme) 1))))
                                                                         (token-TOK_CONST_FLOAT lexeme)))
                                                     ((eof) (token-TOK_EOF #f))
                                                     (any-char (begin 
                                                                 (raise-user-error (string-append "Lexer error: Unexpected char: '" 
                                                                                         lexeme
                                                                                         "'"))
                                                                 (get-nolife-token input-port)))
                                                     ))
                                  )
                           (lambda () (get-nolife-token inp)))))
  
  (define nolife-parser (let ((display (lambda (x) #t)))
                          (parser
                           (tokens nolife-tokens)  
                           (error (lambda (ok name val) (if ok
                                                            (raise-user-error (string-append "Parser error: Unexpected token: "
                                                                                    (symbol->string name) 
                                                                                    "\n"))
                                                            (raise-user-error "Parser error: Invalid token\n"))))
                           (start PROGRAM)
                           (end TOK_EOF)
                           (precs (left TOK_OR)
                                  (left TOK_AND)
                                  (left TOK_NOT)
                                  (left TOK_LT TOK_LE TOK_GT TOK_GE TOK_NE TOK_EQ)
                                  (left TOK_PLUS TOK_MINUS)
                                  (left TOK_TIMES TOK_MOD))
                           (grammar
                            (PROGRAM ((TOK_PROGRAM ID_S DECLS SUBPROGRAM_DECLS COMPOUND_STMT)
                                      (begin (display "PROGRAM RULE 1\n") (list 'PROG $2 $3 $4 $5)))
                                     ((TOK_PROGRAM ID_S DECLS COMPOUND_STMT) 
                                      (begin (display "PROGRAM RULE 2\n") (list 'PROG $2 $3 '() $4)))
                                     ((TOK_PROGRAM ID_S SUBPROGRAM_DECLS COMPOUND_STMT) 
                                      (begin (display "PROGRAM RULE 3\n") (list 'PROG $2 '() $3 $4)))
                                     ((TOK_PROGRAM ID_S COMPOUND_STMT) 
                                      (begin (display "PROGRAM RULE 4\n") (list 'PROG $2 '() '() $3))))
                            (DECLS ((TOK_VAR DECL_LIST) 
                                    (begin (display "DECLS RULE 1\n") $2)))
                            (DECL_LIST ((IDENTIFIER_LIST_COLON TYPE TOK_SEMICOLON) 
                                        (begin (display "DECL_LIST RULE 1\n") (map (lambda (x) (list $2 x)) $1)))
                                       ((DECL_LIST IDENTIFIER_LIST_COLON TYPE TOK_SEMICOLON) 
                                        (begin (display "DECL_LIST RULE 2\n") (append $1 (map (lambda (x) (list $3 x)) $2)))))
                            (IDENTIFIER_LIST ((IDENTIFIER) 
                                              (begin (display "IDENTIFIER_LIST RULE 1\n") (list $1)))
                                             ((IDENTIFIER_LIST TOK_COMMA IDENTIFIER)
                                              (begin (display "IDENTIFIER_LIST RULE 2\n") (append $1 (list $3)))))
                            (TYPE ((STANDARD_TYPE) 
                                   (begin (display "TYPE RULE 1\n") $1))
                                  ((ARRAY_TYPE) 
                                   (begin (display "TYPE RULE 2\n") $1)))
                            (STANDARD_TYPE ((TOK_INTEGER) 
                                            (begin (display "STANDARD_TYPE RULE 1\n") 'INT))
                                           ((TOK_FLOAT) 
                                            (begin (display "STANDARD_TYPE RULE 2\n") 'FLOAT))
                                           ((TOK_CHARACTER) 
                                            (begin (display "STANDARD_TYPE RULE 3\n") 'CHAR)))
                            (ARRAY_TYPE ((TOK_ARRAY TOK_LBRACKET DIM TOK_RBRACKET TOK_OF STANDARD_TYPE) 
                                         (begin (display "ARRAY_TYPE RULE 1\n") (list 'ARRAY $3 $6))))
                            (DIM ((INTNUM TOK_DOTDOT INTNUM) 
                                  (begin (display "DIM RULE 1\n") (list 'INT (list 'DIM $1 $3))))
                                 ((CHAR_CONST TOK_DOTDOT CHAR_CONST) 
                                  (begin (display "DIM RULE 2\n") (list 'CHAR (list 'DIM $1 $3)))))
                            (SUBPROGRAM_DECLS ((SUBPROGRAM_DECLS SUBPROGRAM_DECL TOK_SEMICOLON) 
                                               (begin (display "SUBPROGRAM_DECLS RULE 1\n") (append $1 (list $2))))
                                              ((SUBPROGRAM_DECL TOK_SEMICOLON) 
                                               (begin (display "SUBPROGRAM_DECLS RULE 2\n") (list $1))))
                            (SUBPROGRAM_DECL ((SUBPROGRAM_HEAD DECLS COMPOUND_STMT) 
                                              (begin (display "SUBPROGRAM_DECL RULE 1\n") (append $1 (list $2) (list $3))))
                                             ((SUBPROGRAM_HEAD COMPOUND_STMT) 
                                              (begin (display "SUBPROGRAM_DECL RULE 2\n") (append $1 '() (list $2))))) 
                            (SUBPROGRAM_HEAD ((TOK_FUNCTION IDENTIFIER ARGUMENTS TOK_COLON STANDARD_TYPE TOK_SEMICOLON) 
                                              (begin (display "SUBPROGRAM_HEAD RULE 1\n") (list 'FUNC (list $5 $2) $3)))
                                             ((TOK_FUNCTION IDENTIFIER TOK_COLON STANDARD_TYPE TOK_SEMICOLON) 
                                              (begin (display "SUBPROGRAM_HEAD RULE 2\n") (list 'FUNC (list $4 $2) '())))
                                             ((TOK_PROCEDURE IDENTIFIER ARGUMENTS TOK_SEMICOLON) 
                                              (begin (display "SUBPROGRAM_HEAD RULE 3\n") (list 'PROC (list 'NULL $2) $3)))
                                             ((TOK_PROCEDURE IDENTIFIER TOK_SEMICOLON) 
                                              (begin (display "SUBPROGRAM_HEAD RULE 4\n") (list 'PROC (list 'NULL $2) '()))))
                            (ARGUMENTS ((TOK_LPAREN PARAMETER_LIST TOK_RPAREN) 
                                        (begin (display "ARGUMENTS RULE 1\n") $2)))
                            (PARAMETER_LIST ((IDENTIFIER_LIST_COLON TYPE)
                                             (begin (display "PARAMETER_LIST RULE 1\n") (map (lambda (x) (list $2 x)) $1)))
                                            ((PARAMETER_LIST TOK_SEMICOLON IDENTIFIER_LIST_COLON TYPE)
                                             (begin (display "PARAMETER_LIST RULE 2\n") (append $1 (map (lambda (x) (list $4 x)) $3)))))
                            (STMT ((ASSIGNMENT) 
                                   (begin (display "STMT RULE 1\n") $1))
                                  ((IF_STMT) 
                                   (begin (display "STMT RULE 2\n") $1))
                                  ((WHILE_STMT) 
                                   (begin (display "STMT RULE 3\n") $1))
                                  ((PROCEDURE_INVOCATION) 
                                   (begin (display "STMT RULE 4\n") $1))
                                  ((IO_STMT) 
                                   (begin (display "STMT RULE 5\n") $1))
                                  ((COMPOUND_STMT) 
                                   (begin (display "STMT RULE 6\n") $1))
                                  ((RETURN_STMT) 
                                   (begin (display "STMT RULE 7\n") $1))
                                  ((CASE_STMT) 
                                   (begin (display "STMT RULE 8\n") $1)))
                            (ASSIGNMENT ((VARIABLE TOK_ASSIGN EXPR) 
                                         (begin (display "ASSIGNMENT RULE 1\n") (list 'ASSIGN $1 $3))))
                            (IF_STMT ((TOK_IF EXPR TOK_THEN RESTRICTED_STMT TOK_ELSE STMT) 
                                      (begin (display "IF_STMT RULE 1\n") (list 'IF $2 $4 $6)))
                                     ((TOK_IF EXPR TOK_THEN STMT) 
                                      (begin (display "IF_STMT RULE 2\n") (list 'IF $2 $4 '()))))
                            (RESTRICTED_STMT ((ASSIGNMENT) 
                                              (begin (display "RESTRICTED_STMT RULE 1\n") $1))
                                             ((WHILE_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 2\n") $1))
                                             ((PROCEDURE_INVOCATION) 
                                              (begin (display "RESTRICTED_STMT RULE 3\n") $1))
                                             ((IO_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 4\n") $1))
                                             ((COMPOUND_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 5\n") $1))
                                             ((RETURN_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 6\n") $1))
                                             ((CASE_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 7\n") $1))
                                             ((TOK_IF EXPR TOK_THEN RESTRICTED_STMT TOK_ELSE RESTRICTED_STMT) 
                                              (begin (display "RESTRICTED_STMT RULE 8\n") (list 'IF $2 $4 $6))))
                            (WHILE_STMT ((TOK_WHILE EXPR TOK_DO RESTRICTED_STMT) 
                                         (begin (display "WHILE_STMT RULE 1\n") (list 'WHILE $2 $4))))
                            (PROCEDURE_INVOCATION ((IDENTIFIER TOK_LPAREN TOK_RPAREN) 
                                                   (begin (display "PROCEDURE_INVOCATION RULE 1\n") (list 'CALL $1 '())))
                                                  ((IDENTIFIER TOK_LPAREN EXPR_LIST TOK_RPAREN) 
                                                   (begin (display "PROCEDURE_INVOCATION RULE 2\n") (list 'CALL $1 $3))))
                            (IO_STMT ((TOK_READ TOK_LPAREN VARIABLE TOK_RPAREN) 
                                      (begin (display "IO_STMT RULE 1\n") (list 'READ $3)))
                                     ((TOK_WRITE TOK_LPAREN EXPR TOK_RPAREN) 
                                      (begin (display "IO_STMT RULE 2\n") (list 'WRITE $3)))
                                     ((TOK_WRITE TOK_LPAREN STRING_CONSTANT TOK_RPAREN) 
                                      (begin (display "IO_STMT RULE 3\n") (list 'WRITE $3))))
                            (COMPOUND_STMT ((TOK_BEGIN STMT_LIST TOK_END) 
                                            (begin (display "COMPOUND_STMT RULE 1\n") $2)))
                            (STMT_LIST ((STMT) 
                                        (begin (display "STMT_LIST RULE 1\n") (list $1)))
                                       ((STMT_LIST TOK_SEMICOLON STMT) 
                                        (begin (display "STMT_LIST RULE 2\n") (append $1 (list $3)))))
                            (RETURN_STMT ((TOK_RETURN EXPR) 
                                          (begin (display "RETURN_STMT RULE 1\n") (list 'RETURN $2))))
                            (CASE_STMT ((TOK_CASE EXPR TOK_OF CASES TOK_END) 
                                        (begin (display "CASE_STMT RULE 1\n") (list 'CASE $2 $4)))
                                       ((TOK_CASE EXPR TOK_OF TOK_END) 
                                        (begin (display "CASE_STMT RULE 2\n") (list 'CASE $2 '()))))
                            (CASES ((CASE_ELEMENT) 
                                    (begin (display "CASES RULE 1\n") (list $1)))
                                   ((CASES TOK_SEMICOLON CASE_ELEMENT) 
                                    (begin (display "CASES RULE 2\n") (append $1 (list $3)))))
                            (CASE_ELEMENT ((CASE_LABELS TOK_COLON STMT) 
                                           (begin (display "CASE_ELEMENT RULE 1\n") (list $1 $3))))
                            (CASE_LABELS ((CONSTANT) 
                                          (begin (display "CASE_LABELS RULE 1\n") (list $1)))
                                         ((CASE_LABELS TOK_COMMA CONSTANT) 
                                          (begin (display "CASE_LABELS RULE 2\n") (append $1 (list $3)))))
                            (EXPR_LIST ((EXPR) 
                                        (begin (display "EXPR_LIST RULE 1\n") (list $1)))
                                       ((EXPR_LIST TOK_COMMA EXPR) 
                                        (begin (display "EXPR_LIST RULE 2\n") (append $1 (list $3)))))
                            (EXPR ((SIMPLE_EXPR) 
                                   (begin (display "EXPR RULE 1\n") $1))
                                  ((EXPR LOGOP SIMPLE_EXPR) 
                                   (begin (display "EXPR RULE 2\n") (list $2 $1 $3)))
                                  ((TOK_NOT SIMPLE_EXPR) 
                                   (begin (display "EXPR RULE 3\n") (list 'NOT $2))))
                            (SIMPLE_EXPR ((ADD_EXPR) 
                                          (begin (display "SIMPLE_EXPR RULE 1\n") $1))
                                         ((SIMPLE_EXPR RELOP ADD_EXPR) 
                                          (begin (display "SIMPLE_EXPR RULE 2\n") (list $2 $1 $3))))
                            (ADD_EXPR ((MUL_EXPR) 
                                       (begin (display "ADD_EXPR RULE 1\n") $1))
                                      ((ADD_EXPR ADDOP MUL_EXPR) 
                                       (begin (display "ADD_EXPR RULE 2\n") (list $2 $1 $3))))
                            (MUL_EXPR ((FACTOR) 
                                       (begin (display "MUL_EXPR RULE 1\n") $1))
                                      ((MUL_EXPR MULOP FACTOR) 
                                       (begin (display "MUL_EXPR RULE 2\n") (list $2 $1 $3))))
                            (FACTOR ((VARIABLE) 
                                     (begin (display "FACTOR RULE 1\n") $1))
                                    ((CONSTANT) 
                                     (begin (display "FACTOR RULE 2\n") $1))
                                    ((CHAR_CONST) 
                                     (begin (display "FACTOR RULE 3\n") $1))
                                    ((TOK_LPAREN EXPR TOK_RPAREN) 
                                     (begin (display "FACTOR RULE 4\n") $2))
                                    ((PROCEDURE_INVOCATION) 
                                     (begin (display "FACTOR RULE 5\n") $1)))
                            (VARIABLE ((IDENTIFIER) 
                                       (begin (display "VARIABLE RULE 1\n") (list 'VAR $1 '())))
                                      ((IDENTIFIER TOK_LBRACKET EXPR TOK_RBRACKET) 
                                       (begin (display "VARIABLE RULE 2\n") (list 'VAR $1 $3))))
                            (ADDOP ((TOK_PLUS) 
                                    (begin (display "ADDOP RULE 1\n") 'ADD))
                                   ((TOK_MINUS) 
                                    (begin (display "ADDOP RULE 2\n") 'SUB)))
                            (MULOP ((TOK_TIMES) 
                                    (begin (display "MULOP RULE 1\n") 'MUL))
                                   ((TOK_MOD) 
                                    (begin (display "MULOP RULE 2\n") 'MOD)))
                            (RELOP ((TOK_LE) 
                                    (begin (display "RELOP RULE 1\n") 'GT))
                                   ((TOK_GE) 
                                    (begin (display "RELOP RULE 2\n") 'GE))
                                   ((TOK_LT) 
                                    (begin (display "RELOP RULE 3\n") 'LT))
                                   ((TOK_GT) 
                                    (begin (display "RELOP RULE 4\n") 'GT))
                                   ((TOK_EQ) 
                                    (begin (display "RELOP RULE 5\n") 'EQ))
                                   ((TOK_NE) 
                                    (begin (display "RELOP RULE 6\n") 'NE)))
                            (LOGOP ((TOK_AND) 
                                    (begin (display "LOGOP RULE 1\n") 'AND))
                                   ((TOK_OR) 
                                    (begin (display "LOGOP RULE 2\n") 'OR)))
                            (IDENTIFIER ((TOK_IDENTIFIER) 
                                         (begin (display "IDENTIFIER RULE 1\n") (string->symbol $1))))
                            (INTNUM ((TOK_CONST_INT) 
                                     (begin (display "INTNUM RULE 1\n") (string->number $1))))
                            (CHAR_CONST ((TOK_CONST_CHAR) 
                                         (begin (display "CHAR_CONST RULE 1\n") (list 'CHAR (list 'CONST (string-ref $1 1))))))
                            (STRING_CONSTANT ((TOK_CONST_STR) 
                                              (begin (display "STRING_CONSTANT RULE 1\n") 
                                                     (list 'STR 
                                                           (list 'CONST 
                                                                 (string-append
                                                                  "\""
                                                                  (substring $1
                                                                             1
                                                                             (- (string-length $1) 1))
                                                                  "\""))))))
                            (CONSTANT ((TOK_CONST_FLOAT) 
                                       (begin (display "CONSTANT RULE 1\n") (list 'FLOAT (list 'CONST (string->number $1)))))
                                      ((TOK_CONST_INT) 
                                       (begin (display "CONSTANT RULE 2\n") (list 'INT (list 'CONST (string->number $1))))))
                            (IDENTIFIER_LIST_COLON ((IDENTIFIER_LIST TOK_COLON) 
                                                    (begin (display "IDENTIFIER_LIST_COLON RULE 1\n") $1)))
                            (ID_S ((IDENTIFIER TOK_SEMICOLON) 
                                   (begin (display "ID_S RULE 1\n") $1))))
                           )))
  
  (define filter-comments (lambda (f) (letrec ((g (lambda () (let ((tok (f))) (if (equal? 'TOK_COMMENT (token-name tok))
                                                                                  (g)
                                                                                  tok))))) g)))
  
  (define nolife-filter-comments filter-comments)
  
  (define filter-whitespace (lambda (f) (letrec ((g (lambda () (let ((tok (f))) (if (equal? 'TOK_WHITESPACE (token-name tok))
                                                                                    (g)
                                                                                    tok))))) g)))
  
  (define nolife-filter-whitespace filter-whitespace)
  
  (define print-tok-stream (lambda (next-tok-f)
                             (let ((next-tok (next-tok-f)))
                               (if (not (equal? 'TOK_EOF (token-name next-tok)))
                                   (begin
                                     (display (string-append (symbol->string (token-name next-tok)) 
                                                             (if (token-value next-tok)
                                                                 (string-append "(" (token-value next-tok) ")")
                                                                 "") "\n"))
                                     (print-tok-stream next-tok-f))))))
  (define nolife-print-tok-stream print-tok-stream)
  
  (define nolife-file->ast (lambda (file) 
                             (nolife-parser (filter-comments (filter-whitespace (nolife-lexer (open-input-file file)))))))
  
  (provide nolife-lexer
           nolife-parser
           nolife-filter-comments
           nolife-filter-whitespace
           nolife-print-tok-stream
           nolife-file->ast))