(***********************************************************)
(* 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
;;
