(***********************************************************)
    (*       LISP Interpreter                                  *)
    (*                                                         *)
    (*       Your Name Here                                    *)
    (*       Reference Skeleton, CSCI 350                      *)
    (*                                                         *)
    (***********************************************************)
     
     
    open Printf;;
    open Stream;;
     
    exception ParseError of string;;
    exception ParseFailure of string;;
    exception ParseOK;;
    exception ParseEOF;;
    exception EvalError of string;;
    exception UnboundVar;;
    exception ParameterMismatch;;
     
     
    (***********************************************************)
    (* type declarations                                       *)
    (***********************************************************)
     
    type sign =
        Plus
      | Minus
    ;;
     
    type atom =
        T
      | NIL
      | Int of int
      | Ident of string
    ;;
     
    type token =
        Lparen
      | Rparen
      | Dot
      | Sign of sign
      | Atom of atom
    ;;
     
    type sexp =
        AtomExp of atom
      | Sexp of sexp * sexp
    ;;
     
     
    (***********************************************************)
    (* globals                                                 *)
    (***********************************************************)
    let lineno = ref 1;;
    let top_level = ref true;;
     
    let dlist = ref (AtomExp(NIL));;
     
     
    (***********************************************************)
    (* printing functions                                      *)
    (***********************************************************)
     
    (* function: print_tokens - prints out a token stream  *)
    let rec print_tokens ts =
      match ts with parser
        [< 'Lparen; _ >] -> printf("Lparen "); print_tokens ts
      | [< 'Rparen; _ >] -> printf("Rparen "); print_tokens ts
      | [< 'Dot; _ >]    -> printf("Dot ");    print_tokens ts
      | [< 'Sign s; _ >] -> (match s with
          Plus  -> printf("Plus ");            print_tokens ts
        | Minus -> printf("Minus ");           print_tokens ts)
      | [< 'Atom a; _ >] -> (match a with
          T       ->   printf("Atom(T) ");     print_tokens ts
        | NIL     ->   printf("Atom(NIL) ");   print_tokens ts
        | Int n   ->   printf("Atom(Int(%d)) ") n;     print_tokens ts
        | Ident s ->   printf("Atom(Ident(%s)) ") s;   print_tokens ts)
     
      | [< >] -> printf("\n")
    ;;
     
     
    (* function: string_of_op -  converts an operator token to a string *)
    let string_of_op o =
      match o with
        Plus -> "+"
      | Minus -> "-"
    ;;
     
    (* function: is_list - predicate function returning true if s-expression is a list *)
    let rec is_list s =
      match s with
        Sexp(h, AtomExp(NIL)) -> true
      | Sexp(h, t) -> is_list t
      | _ -> false
    ;;
     
    (* function: string_of_atom - converts a primitive atom to a string *)
    let string_of_atom a =
      match a with
        T -> "t"
      | NIL -> "nil"
      | Int(i) -> string_of_int i
      | Ident(i) -> i
    ;;
     
    (* function: string_of_token - converts a lexer token to a string *)
    let string_of_token t =
      match t with
        Lparen -> "("
      | Rparen -> ")"
      | Dot -> "."
      | Sign(o) -> string_of_op o
      | Atom(a) -> string_of_atom a
    ;;
     
     
    (* function: print_list - prints an s-expression in list format *)
    let rec print_list s =
      match s with
        AtomExp(NIL) -> ()
      | AtomExp(a) -> printf("%s") (string_of_atom a)
      | Sexp(h,AtomExp(NIL)) -> print_sexp h
      | Sexp(h,t) ->
            (print_sexp h;
             printf(" ");
             print_list t)
     
    (* function: print_sexp - prints an s-expression in either dotted or list format *)
    and print_sexp s =
      if (is_list s) then
        (printf("(");
         print_list s;
         printf(")");)
      else
        (match s with
          AtomExp(a) -> printf("%s") (string_of_atom a)
        | Sexp(h,t) ->
            (printf("(");
             print_sexp h;
             printf(" . ");
             print_sexp t;
             printf(")")))
    ;;
     
     
    (***********************************************************)
    (* lexer implementation                                    *)
    (***********************************************************)
     
    let rec spaces s =
      match s with parser
        [< '' '|'\t'; _ >] -> spaces s
      | [< ''\n' ; _ >] -> incr lineno; spaces s
      | [< >] -> ()
    ;;
     
    let rec lexid str s =
      match s with parser
        [< ''a'..'z'|'A'..'Z'|'0'..'9' as c ; _ >] -> lexid (str ^ (Char.escaped c)) s
      | [< >] -> str
    ;;
     
     
    let rec lexint v s =
      match s with parser
        [< ''0'..'9' as n; _ >] -> lexint ((10*v)+(int_of_string (Char.escaped n))) s
      | [< >] -> v
    ;;
     
     
    let rec lexer s =
      match s with parser
        [< ''(' ; _ >] -> [< 'Lparen ; lexer s >]
      | [< '')' ; _ >] -> [< 'Rparen ; lexer s >]
      | [< ''.' ; _ >] -> [< 'Dot    ; lexer s >]
      | [< ''-' ; _ >] -> [< 'Sign(Minus) ; lexer s >]
      | [< ''+' ; _ >] -> [< 'Sign(Plus) ; lexer s >]
      | [< ''a'..'z'|'A'..'Z' as c; _ >] -> [< 'Atom(Ident(lexid (Char.escaped c) s)); lexer s >]
      | [< ''0'..'9' as n; _ >] -> [< 'Atom(Int(lexint (int_of_string (Char.escaped n)) s)); lexer s >]
      | [< '' '|'\t' ; _ >] -> spaces s; [< lexer s >]
      | [< ''\n' ; _ >] -> incr lineno; spaces s; [< lexer s >]
      | [< 'c >] -> printf("ERROR: Illegal character on line %d: %c\n") !lineno c; lexer s
    ;;
     
    (***********************************************************)
    (* parser implementation                                   *)
    (***********************************************************)
     
    (* function: eat - consumes next value in token stream *)
    let eat ts = try next ts; () with Stream.Failure -> ();;
     
    (* function: check_sign - both validates and combines sign and integer token pairs *)
    let check_sign s ts =
      let lookahead = peek ts in
      match lookahead with
        Some t ->
          (match t with
            Atom a ->
              (match a with
                Int a ->
                  if (s=Minus) then
                    (eat ts; AtomExp(Int(-a)))
                  else
                    (eat ts; AtomExp(Int(a)))
              | _ -> raise (ParseError("+/- sign may only be used with integer literals")))
          | _ -> raise (ParseError("+/- sign may only be used with integer literals")))
      | None -> raise (ParseError("EOF found before complete parsing of integer literal"))
    ;;
     
     
    (* function: check_atom - converts identifiers to internal primitives, nested defun check *)
    let check_atom a =
      match a with
        Ident i -> (
          match i with
            "T" | "t" -> AtomExp(T)
          | "NIL" | "nil" -> AtomExp(NIL)
          | "DEFUN" | "defun" ->
              if !top_level = true then
                AtomExp(a)
              else
                raise (ParseError("DEFUN used outside of top-level"))
          | _ -> AtomExp(a))
      | _ -> AtomExp(a)
    ;;
     
     
     
    (* function: parse_sexp - top-level parser: takes stream of tokens, returns sexp-tree *)
    (* S ::= E *)
    let rec parse_sexp ts =
      try
        top_level := true;
        let lookahead = (peek ts) in
        match lookahead with
          Some cur -> parse_exp ts
        | None -> raise ParseOK
      with
        Stream.Failure -> raise ParseOK
      | ParseFailure msg -> raise (ParseError(msg))
      | ParseEOF -> raise (ParseError("found EOF before complete s-expression parsing"))
     
    (* E ::= atom | '(' X          *)
    and parse_exp ts =
      try
        let lookahead = (peek ts) in
        match lookahead with
          Some cur ->
            (match cur with
              Lparen -> eat ts; parse_x ts
            | Sign(s) -> eat ts; check_sign s ts
            | Atom(a) -> eat ts; check_atom a
            | _ -> raise (ParseFailure("parser expected '(' or an atom expression")))
        | None -> raise (ParseFailure("parse ended expecting '(' or an atom expression"))
      with
        Stream.Failure -> raise (ParseFailure("found EOF before complete s-expression parsing"))
     
    (* X ::= E Y | ')'   *)
    and parse_x ts =
      try
        let lookahead = (peek ts) in
        match lookahead with
          Some cur ->
            (match cur with
              Rparen -> eat ts; AtomExp(NIL) (* handle '()' *)
            | _ -> let e = parse_exp ts in
                     let y = parse_y ts in
                     Sexp(e,y))
        | None -> raise (ParseFailure("parser ended expecting ')' or an s-expression"))
      with
        Stream.Failure -> raise (ParseFailure("found EOF before complete s-expression parsing"))
     
    (* Y ::= '.' E ')' | R ')'    *)
    and parse_y ts =
      try
        let lookahead = (peek ts) in
        match lookahead with
          Some cur ->
            (match cur with
              Dot ->
                eat ts;
                let e = parse_exp ts in
                  parse_rparen ts; e
            | _ -> let r = parse_r ts in
                  parse_rparen ts; r)
        | None -> raise (ParseFailure("parser ended expecting '.' or an s-expression"))
      with
        Stream.Failure -> raise (ParseFailure("found EOF before complete s-expression parsing"))
     
    (* R ::= E R | empty  *)
    and parse_r ts =
        let lookahead = (peek ts) in
        match lookahead with
          Some cur ->
            (match cur with
              Lparen|Sign(_)|Atom(_) ->
                let e = parse_exp ts in
                let r = parse_r ts in
                Sexp(e,r)
            | _ -> AtomExp(NIL))
        | None -> raise (ParseFailure("parser ended expecting ')' or an s-expression"))
     
    (* convenience production for right parens *)
    and parse_rparen ts =
      try
        let lookahead = (peek ts) in
        match lookahead with
          Some cur ->
            (match cur with
              Rparen -> eat ts;
            | _ -> raise (ParseFailure("expected ')'")))
        | None -> raise (ParseFailure("parser ended expecting ')'"))
      with
        Stream.Failure -> raise (ParseFailure("found EOF before complete s-expression parsing"))
    ;;      
     
     
    (*****************************************)
    (* interpretation functions              *)
    (*****************************************)
     
    (* function: bound - checks that referenced variables are bound in a-list *)
    (*                   returns true if found, false otherwise  x is a string             *)
    let rec bound x alist =
       match alist with
        Sexp(AtomExp(Ident(group)),threst) ->
          if x == group then true else bound x threst
         |_ -> false
    ;;
     
    (* function: getval - returns the value of a variable from the a-list & d-list  name is a string*)
    let rec getval name alist =
        match alist with
        Sexp(Sexp(AtomExp(Ident(group)), var),threst) ->
            if (name == group) then var else (getval name threst)
        |_-> raise(EvalError("Dick jones says I know."))
       
    ;;
     
    (* function: eval_defun - checks defun usage and adds function def to the global d-list *)
    (*                         returns unit                                                 *)
    let eval_defun s a d =
      (* modifies !d / d:= Sexp() *)
      match s with
      Sexp(AtomExp(Ident(name)),Sexp(AtomExp(Ident(formals)),Sexp(AtomExp(Ident(body)),AtomExp(NIL)))) ->
        Sexp(Sexp(AtomExp(Ident(name)),Sexp(AtomExp(Ident(formals)),AtomExp(Ident(body)))),!d)
      |_ -> AtomExp(NIL)
    ;;
     
     
    (* function: check_formal - checks function parameters from matching T or NIL *)
    let check_formal x =
      match x with
        AtomExp(T) -> raise (EvalError("Formal parameters may not be 'T'"))
      | AtomExp(NIL) -> raise (EvalError("Formal parameters may not be 'NIL'"))
      | _ -> ()
    ;;
     
     
    (* function: addpairs - checks function parameters and binds formals to actuals *)
    (*                   returns an s-expression                                    *)
    let rec addpairs xlist ylist z =
      (* calls check_formal *)
      match xlist with
         Sexp(Sexp(AtomExp(xy), t), Sexp(AtomExp(yl), v)) -> addpairs t v (Sexp(z,(Sexp(AtomExp(xy), AtomExp(yl)))))
        |_-> z
    ;;
     
    (* function: eval - top-level s-expression evaluation loop           *)
    (*                   returns an s-expression                         *)
    let rec eval exp a d =
        match exp with
          AtomExp(T) -> AtomExp(T)
         |AtomExp(NIL) -> AtomExp(NIL)
         |AtomExp(Int(_)) -> exp
         |AtomExp(Ident(s)) -> if ((bound s a) ==true) then (getval s a) else raise (EvalError ("You done goof'd"))
         |_-> (match exp with
              Sexp(AtomExp(Ident("QUOTE")), Sexp(h,r)) -> if (r <> AtomExp(NIL))
                            then (raise (EvalError("Honey badger says you can't quote"))) else h
             |Sexp(AtomExp(Ident("COND")), r) -> evcon r a d
             |Sexp(AtomExp(Ident("DEFUN")), r) -> eval_defun r a d
             |Sexp(h, t) ->   apply h (evlist t a d) a d
             |_ -> raise(EvalError("Hide your kids, Hide your wives")))
               
         
    (* function: evcon - evaluates a COND statement                      *)
    (*                   returns an s-expression                         *)
    and evcon x a d =
      match x with
        AtomExp(NIL) -> raise(EvalError("Nyan cat does not approve"))
       |Sexp(Sexp(h,j), Sexp(q, t))-> Sexp((eval h a d), (eval q a d))
       |Sexp(h, t) -> evcon t a d
       |_-> raise(EvalError("Y u No Cons Right?"))
     
    (* function: evlist - evaluates a list of expressions and returns a list of results *)
    (*                   returns an s-expression                                        *)
    and evlist sexp a d =
      match sexp with
       Sexp(h,t) -> Sexp((eval h a d),(evlist t a d))
       |_ -> raise(EvalError("No can do mon"))  
       
    (* function: apply - performs function application, handles built-ins *)
    (*                   returns an s-expression                
       Takes a car of an sexp, an sexp, a-list, d-list          *)
    and apply f x a d =
       match f with
            Sexp(AtomExp(Ident("CAR")),_) ->
                    match x with
                      Sexp(Sexp(fh,ft),Sexp(sh,st)) -> fh
                      |_-> raise(EvalError("Stars Wars Kid can code better than this"))
            |Sexp(AtomExp(Ident("CDR")),_) ->
                    match x with
                      Sexp(Sexp(fh,ft),Sexp(sh,st)) -> ft
                      |_-> raise(EvalError("Professor Oak says your not a girl or boy"))
            |Sexp(AtomExp(Ident("CONS")),_) ->
                    match x with
                      Sexp(car,Sexp(sh,st)) -> Sexp(car,sh)
                      |_-> raise(EvalError("Change major while you still can"))
            |Sexp(AtomExp(Ident("ATOM")),_) ->
                    match x with
                      Sexp(car, cdr) -> car
                      |_-> raise(EvalError("Ash Ketchum GO STD'S"))
            |Sexp(AtomExp(Ident("EQ")), _) ->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) ->
                            if first <> sec then AtomExp(NIL) else AtomExp(T)
                      |_-> raise(EvalError("Epic Baby FAIL"))
            |Sexp(AtomExp(Ident("INT")),_) ->
                    match x with
                      Sexp(AtomExp(Ident(first)),AtomExp(NIL)) -> AtomExp(NIL)
                      |Sexp(AtomExp(Int(first)),AtomExp(NIL)) -> AtomExp(T)
                      |_-> raise(EvalError("Awkward Penguin 0_o"))
            |Sexp(AtomExp(Ident("NULL")),_) ->
                    match x with
                      Sexp(AtomExp(NIL), AtomExp(NIL)) -> AtomExp(T)
                      |Sexp(AtomExp(_),AtomExp(NIL)) -> AtomExp(NIL)
                      |_ -> raise(EvalError("You can't nill, null, nor read instructions son"))
            |Sexp(AtomExp(Ident("PLUS")),_)->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> AtomExp(Int(first+sec))
                      |_-> raise(EvalError("Trololol"))
            |Sexp(AtomExp(Ident("MINUS")),_)->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> AtomExp(Int(first-sec))
                      |_-> raise(EvalError("Tech Something Mother FAIL"))
            |Sexp(AtomExp(Ident("TIMES")),_)->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> AtomExp(Int(first*sec))
                      |_-> raise(EvalError("Music Obvious Eighth Grader says B flat"))
            |Sexp(AtomExp(Ident("QUOTIENT")),_)->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> if sec == 0 then raise(EvalError("YOU BLEW UP THE WORLD"))
                         else AtomExp(Int(first/sec))
                      |_-> raise(EvalError("Pickup Line Panda says Hi"))
            |Sexp(AtomExp(Ident("REMAINDER")),_) ->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> AtomExp(Int((first mod sec)))
                      |_-> raise(EvalError("Forever Alone"))
            |Sexp(AtomExp(Ident("LESS")),_) ->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> if first < sec then
                        AtomExp(T) else AtomExp(NIL)
                      |_-> raise(EvalError("Lesser Soul Crystal Needed"))
            |Sexp(AtomExp(Ident("GREATER")),_) ->
                    match x with
                      Sexp(AtomExp(Int(first)), AtomExp(Int(sec))) -> if first > sec then
                        AtomExp(T) else AtomExp(NIL)
                      |_-> raise(EvalError("Nothings is Greater than Chuck Norris"))
            |_ -> match f with
                 Sexp(AtomExp(Ident(fname)), _) -> if ((bound fname !d) == true)
                   then
                     let
                      stuffz = (getval fname !d)
                        in
                        match stuffz with
                          Sexp(h,t) -> (eval t (addpairs h x a) d)
                          |_-> raise(EvalError("Hey stop that!"))
           
                       else raise(EvalError("Nope! Chuck Testa."))
                 |_-> raise(EvalError("Don't look at me"))
       
           
    ;;
     
    (*****************************************)
    (* helper routines                       *)
    (*****************************************)
     
    (* function: get_sexp - wrapper function around parser to catch stream failures *)
    let get_sexp s =
      try
        let sexplist = parse_sexp s in
        sexplist
      with
        Stream.Failure -> AtomExp(NIL)
    ;;
     
    (* function: next_sexp - recursive function which tries to evaluate as much as possible *)
    let rec next_sexp ts =
      try
        let e = (eval (get_sexp ts) (AtomExp(NIL)) dlist) in
        print_sexp e; printf("\n"); next_sexp ts
      with
        ParseError e -> printf("Parse Error: %s\n") e
      | EvalError e -> printf("Evaluation Error: %s\n") e; next_sexp ts
      | ParseOK -> exit 0
    ;;
     
     
    (*****************************************)
    (* main                                  *)
    (*****************************************)
    let ts = lexer (Stream.of_channel stdin) in
    try
     (* read/evaluate/print loop *)
     (print_sexp(eval (get_sexp ts) (AtomExp(NIL)) dlist);
      printf("\n");
      next_sexp ts)
    with
      ParseError e -> printf("Parse Error: %s\n") e
    | EvalError e -> printf("Evaluation Error: %s\n") e; next_sexp ts
    | ParseOK -> exit 0
    ;;