(* Compile this file with Caml Light version 0.6 or 0.7 *) (* Syntax and semantics: 1. I x -> x S x -> x+1 C x -> 0 Z () -> 0 2. F = G*(H1, ..., Hn) arity: a(F) = a(H1) + ... + a(Hn) F (x11, ..., x1a(H1), ..., xn1, ..., xna(Hn)) = G (H1 (x11, ..., x1a(H1)), ..., Hn (xn1, ..., xna(Hn))) 2ter. F = G[s(1), ..., s(n)]p a(F) = p F (x_1, ..., x_p) = G (x_s(1), ..., x_s(n)) 3bis. F = f(G1, G2) F (x1, ..., xn, 0) = G1 (x1, ..., xn) F (x1, ..., xn, k+1) = G2 (x1, ..., xn, k, F (x1, ..., xn, k)) *** Grammar: ::= 'I | 'S | 'C | 'Z | '* '( ') | '[ '] | 'f '( ', ') ::= empty | | ', ::= empty | | ', Grammar without left-recursion: ::= empty | '* '( ') | '[ '] ::= 'I | 'S | 'C | 'Z | 'f '( ', ') ::= *) #open "genlex";; #open "io";; #open "printf";; #open "stream";; (* The keywords of our language *) let lexer = make_lexer ["I"; "S"; "C"; "Z"; "f"; "*"; "("; ")"; "["; "]"; ","] ;; (* The type of terms (aka programs or functions) of our language *) type RP = RP_I | RP_S | RP_C | RP_Z | RP_f of RP * RP | RP_o of RP * RP list * int list ref | RP_mix of RP * int list * int ;; (* This type corresponds to the production of the non-left-recursive grammar *) type Tail = Tail_o of RP list * Tail | Tail_mix of int list * int * Tail | Tail_end ;; (* Build a RP from a RP and a Tail. This will turn the tail (as parsed by the recursive-descent parser) into a "normal" term (with operations applied to sub-terms). *) let rec reverse_rp h t = match t with Tail_end -> h | Tail_o (rpl, t) -> reverse_rp (RP_o (h, rpl, ref [])) t | Tail_mix (l, i, t) -> reverse_rp (RP_mix (h, l, i)) t ;; (* Parse an expression and return the corresponding RP term. *) let rec parse_rp = function [< parse_rp0 h; parse_rp1 t>] -> reverse_rp h t and parse_rp0 = function [< 'Kwd "I" >] -> RP_I | [< 'Kwd "S" >] -> RP_S | [< 'Kwd "C" >] -> RP_C | [< 'Kwd "Z" >] -> RP_Z | [< 'Kwd "f"; 'Kwd "("; parse_rp g1; 'Kwd ","; parse_rp g2; 'Kwd ")" >] -> RP_f (g1, g2) and parse_rp1 = function [< 'Kwd "*"; 'Kwd "("; parse_rp_list l; 'Kwd ")"; parse_rp1 t >] -> Tail_o (l, t) | [< 'Kwd "["; parse_int_list l; 'Kwd "]"; 'Int i; parse_rp1 t >] -> Tail_mix (l, i, t) | [< >] -> Tail_end and parse_rp_list = function [< parse_rp g; parse_rp_list_tail t >] -> g :: t | [< >] -> [] and parse_rp_list_tail = function [< 'Kwd ","; parse_rp_list t >] -> t | [< >] -> [] and parse_int_list = function [< 'Int i; parse_int_list_tail t >] -> i :: t | [< >] -> [] and parse_int_list_tail = function [< 'Kwd ","; parse_int_list t >] -> t | [< >] -> [] ;; (* This exception is raised when a function is applied to the wrong number of arguments. *) exception Arity_error of string;; (* Compute the number of arguments expected by a function. *) let rec arity f = match f with RP_I -> 1 | RP_S -> 1 | RP_C -> 1 | RP_Z -> 0 | RP_f (g1, g2) -> let n = arity g1 in if arity g2 = n + 2 then n + 1 else raise (Arity_error "f") | RP_o (g, rpl, ar) -> if arity g = list_length rpl then begin ar := map arity rpl; list_it add_int (!ar) 0 end else raise (Arity_error "*") | RP_mix (g, il, a) -> if arity g = list_length il & for_all (fun x -> x <= a) il then a else raise (Arity_error "[]") ;; (* An expr is either a value or a RP applied to a list of expr. We use references to maintain the sharing of subexpressions, so we can do lazy evaluation instead of call-by-name. *) type expr = Val of int | App of RP * expr ref list ;; (* Return the n-th element of a list, starting at 1. *) let rec nth n l = if n = 1 then hd l else nth (n-1) (tl l) ;; (* Cut a list in two after n elements. *) let rec cut n l = if n = 0 then ([], l) else let (first, last) = cut (n-1) (tl l) in (hd l :: first, last) ;; (* Make a list of argument lists from a list of arguments and a list of arities. *) let rec put_args rpl arl argl = match (rpl, arl) with [], [] -> [] | (f::t), (ar::art) -> let (first, last) = cut ar argl in ref (App (f, first)) :: (put_args t art last) ;; (* Evaluate an expr. *) let rec eval e = match !e with Val i -> i | App (f, args) -> let result = apply f args in e := Val result; result and apply f args = match f with RP_I -> eval (hd args) (* list_length args = 1 *) | RP_S -> 1 + eval (hd args) (* list_length args = 1 *) | RP_C -> 0 (* list_length args = 1 *) | RP_Z -> 0 (* list_length args = 0 *) | RP_mix (g, il, a) -> apply g (map (fun n -> nth n args) il) | RP_o (g, rpl, ar) -> apply g (put_args rpl (!ar) args) | RP_f (g1, g2) as f -> let rargs = rev args in match eval (hd rargs) with 0 -> apply g1 (rev (tl rargs)) | k -> let f_arglist = rev (ref (Val(k-1)) :: tl rargs) in apply g2 (rev (ref (App (f, f_arglist)) :: ref (Val (k-1)) :: tl rargs)) ;; (* Apply f to args, after checking the arity. *) let check_apply f args = if list_length args = arity f then apply f (map (fun x -> ref (Val x)) args) else raise (Arity_error "apply: wrong number of arguments") ;; exception Error of string;; (* Build the list of arguments from the array passed from the command line. *) let rec extract v n = if n >= vect_length v then [] else int_of_string v.(n) :: (extract v (n+1)) ;; let usage = "usage: eval ...";; let main () = try if vect_length sys__command_line < 2 then raise (Error usage); try let ch = open_in sys__command_line.(1) in let str = stream_of_channel ch in let f = parse_rp (lexer str) in let args = extract sys__command_line 2 in printf ">>>>>>> %d\n" (check_apply f args); flush stdout with sys__Sys_error s -> raise (Error ("open: " ^ s)) | Parse_failure -> raise (Error "syntax error") | Parse_error -> raise (Error "syntax error") | Failure "int_of_string" -> raise (Error usage) | Arity_error s -> raise (Error ("arity error in " ^ s)) with Error x -> fprintf stderr "%s\n" x; exit 3 ;; main ();;