1. camlspotter
  2. planck

Commits

camlspotter  committed 529a722

added lexertest

  • Participants
  • Parent commits 4bc30e8
  • Branches default

Comments (0)

Files changed (4)

File ocaml/OMakefile

View file
  • Ignore whitespace
    ocamlyacc
    ocamlyacctest
 
+# MyOCamlProgram(hamkl, $(FILES))
+
 FILES0[] =
    ../planck
    input
    lex
    lextest
 
+MyOCamlProgram(lexer, $(FILES0))
+
 FILES1[] =
    ../planck
    input
    lex
    tokentest
 
+MyOCamlProgram(token, $(FILES1))
+
 FILES2[] =
    ../planck
    input
    plparser
    parsertest
 
+MyOCamlProgram(parser, $(FILES2))
+
+FILES3[] =
+   ../planck
+   input
+   token
+   lex
+   ocaml/utils/misc
+   ocaml/utils/config
+   ocaml/utils/clflags
+   ocaml/utils/warnings
+   ocaml/parsing/linenum
+   ocaml/parsing/location
+   ocaml/parsing/syntaxerr
+
+   ocaml/parsing/lexer
+   ocaml/parsing/longident
+   ocaml/parsing/parser
+
+   lexertest
+
+MyOCamlProgram(lexertest, $(FILES3))
+
 plparser.auto.ml: hamkl.opt ../ocaml/parsing/parser.mly
     ./hamkl.opt ../ocaml/parsing/parser.mly > $@
 
-PROGRAM = hamkl
-PROGRAM0 = lexer
-PROGRAM1 = token
-PROGRAM2 = parser
-
 OCAML_LIBS +=
 OCAML_CLIBS +=
 OCAML_OTHER_LIBS +=
 OCAML_LIB_FLAGS +=
 
-# MyOCamlProgram($(PROGRAM), $(FILES))
-MyOCamlProgram($(PROGRAM0), $(FILES0))
-MyOCamlProgram($(PROGRAM1), $(FILES1))
-MyOCamlProgram($(PROGRAM2), $(FILES2))
+.PHONY: test test2
 
-.PHONY: test
 test: parser
     $(shell bash -c 'for i in test*.ml test*.mli; do ./parser $$i; done') 
 
+test2: parser
+    $(shell bash -c 'for i in test*.ml test*.mli; do ./lexertest $$i; done') 
+
 diff.txt: plparser.auto.ml
     diff -c plparser.auto.ml plparser.ml  > diff.txt

File ocaml/lexertest.ml

View file
  • Ignore whitespace
+open Spotlib.Spot
+open Planck
+
+(* This is required to call Syntaxerr.report_error correctly. *)
+let _ = Location.input_name := ""
+
+let rec parse stream = 
+  match Token.Stream.peek stream with
+  | Some (_, _, stream') -> parse stream'
+  | None -> ()
+
+let parse_orig f =
+  let ic = open_in f in
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf f;
+  let rec loop () = 
+    match Lexer.token lexbuf with
+    | Parser.EOF -> ()
+    | _ -> loop ()
+  in
+  loop ();
+  close_in ic
+
+let _ = 
+  let time_sum_orig = ref 0.0 in
+  let time_sum_planck = ref 0.0 in
+
+  let print_times time_orig time_planck = 
+    let open Unix in
+    Format.eprintf "x%f (original %f, planck %f)@."
+      (time_planck /. time_orig)
+      time_orig time_planck
+  in
+
+  Arg.parse [] (fun path ->
+    let ic = open_in path in
+    let stream = Input.Stream.from_chan ~filename:path ic in
+    let token_stream = Lex.ocaml_token_stream stream in
+
+    Format.eprintf "%s@." path;
+
+    let (), time_orig = with_time parse_orig path in
+    let (), time_planck = with_time parse token_stream in
+    time_sum_orig := !time_sum_orig +. time_orig;
+    time_sum_planck := !time_sum_planck +. time_planck;
+    print_times time_orig time_planck;
+    Format.eprintf "Lexer: %t@." Input.Parser.Profile.format;
+    Input.Parser.Profile.reset ();
+
+    close_in ic;
+  ) "lexertest files";
+  prerr_endline "ALL TEST ENDED";
+  print_times !time_sum_orig !time_sum_planck;
+  Input.Parser.Profile.recover_all ();
+  Format.eprintf "Lexer: %t@." Input.Parser.Profile.format
+
+
+
+

File ocaml/ocamllextest.sh

View file
  • Ignore whitespace
+#!/bin/sh
+for i in `cat OCAMLTESTTARGETS.txt`
+do
+  if [ -f $i ]; then
+    files="$files $i" 
+  fi
+done
+./lexertest $files

File ocaml/plparser.ml

View file
  • Ignore whitespace
 
 (* TYPPPICAL EXAMPLE OF INEFFICIENCY!
   method signature_leftrec v_1 = (dummy
-    <!> case "signature_leftrec_0" (perform
+    <|> case "signature_leftrec_0" (perform
 
            v_2 <-- self#signature_item ;
            token SEMISEMI;
       )
 
   method label_let_pattern = rule "label_let_pattern" (fun () -> dummy
-    <!> case "label_let_pattern_0" (perform
+    <|> case "label_let_pattern_0" (perform
 
            v_1 <-- self#label_var ;
            token COLON;
       )
 
   method let_pattern = rule "let_pattern" (fun () -> dummy
-    <!> case "let_pattern_0" (perform
+    <|> case "let_pattern_0" (perform
 
            v_1 <-- self#pattern ;
            token COLON;
       )
 
   method labeled_simple_expr = rule "labeled_simple_expr" (fun () -> dummy
-    <!> case "labeled_simple_expr_0" (perform
+    <|> case "labeled_simple_expr_0" (perform
 
            v_1 <-- self#label_expr ;
 
       )
 
   method let_binding = rule "let_binding" (fun () -> dummy
-    <!> case "let_binding_0" (perform
+    <|> case "let_binding_0" (perform
 
            v_1 <-- self#val_ident ;
            token COLON;
       )
 
   method fun_binding = rule "fun_binding" (fun () -> dummy
-    <!> case "fun_binding_0" (perform
+    <|> case "fun_binding_0" (perform
 
            v_1 <-- self#type_constraint ;
            token EQUAL;
     ))
 
   method record_expr = rule "record_expr" (fun () -> dummy
-    <!> case "record_expr_0" (perform
+    <|> case "record_expr_0" (perform
 
            v_1 <-- self#simple_expr ;
            token WITH;
            )))
 
   method lbl_expr_list_leftrec v_1 = (dummy
-    <!> case "lbl_expr_list_leftrec_0" (perform
+    <|> case "lbl_expr_list_leftrec_0" (perform
 
            token SEMI;
            v_3 <-- self#label_longident ;
       )
 
   method type_constraint = rule "type_constraint" (fun () -> dummy
-    <!> case "type_constraint_0" (perform
+    <|> case "type_constraint_0" (perform
 
            token COLON;
            v_2 <-- self#core_type ;
   method lbl_pattern_list = leftrec "lbl_pattern_list" self#lbl_pattern_list_nonleftrec self#lbl_pattern_list_leftrec
 
   method lbl_pattern_list_nonleftrec = (dummy
-    <!> case "lbl_pattern_list_nonleftrec_0" (perform
+    <|> case "lbl_pattern_list_nonleftrec_0" (perform
 
            v_1 <-- self#label_longident ;
            token EQUAL;
       )
 
   method lbl_pattern_list_leftrec v_1 = (dummy
-    <!> case "lbl_pattern_list_leftrec_0" (perform
+    <|> case "lbl_pattern_list_leftrec_0" (perform
 
            token SEMI;
            v_3 <-- self#label_longident ;
       )
 
   method record_pattern_end = rule "record_pattern_end" (fun () -> dummy
-    <!> case "record_pattern_end_0" (perform
+    <|> case "record_pattern_end_0" (perform
 
            token SEMI;
            token UNDERSCORE;
       )
 
   method primitive_declaration = rule "primitive_declaration" (fun () -> dummy
-    <!> case "primitive_declaration_0" (perform
+    <|> case "primitive_declaration_0" (perform
 
            v_1 <-- get_STRING;
            v_2 <-- self#primitive_declaration ;
       )
 
   method type_kind = rule "type_kind" (fun () -> dummy
-    <!> case "type_kind_0" (perform
+    <|> case "type_kind_0" (perform
 
            token EQUAL;
            v_2 <-- self#core_type ;
       )
 
   method with_type_binder = rule "with_type_binder" (fun () -> dummy
-    <!> case "with_type_binder_0" (perform
+    <|> case "with_type_binder_0" (perform
 
            token EQUAL;
            token PRIVATE;
       )
 
   method poly_type = rule "poly_type" (fun () -> dummy
-    <!> case "poly_type_0" (perform
+    <|> case "poly_type_0" (perform
 
            v_1 <-- self#typevar_list ;
            token DOT;
       )
 
   method core_type = rule "core_type" (fun () -> dummy
-    <!> case "core_type_0" (perform
+    <|> case "core_type_0" (perform
 
            v_1 <-- self#core_type2 ;
            token AS;
   method core_type2 = leftrec "core_type2" self#core_type2_nonleftrec self#core_type2_leftrec
 
   method core_type2_nonleftrec = (dummy
-    <!> case "core_type2_nonleftrec_0" (perform
+    <|> case "core_type2_nonleftrec_0" (perform
 
            token QUESTION;
            v_2 <-- get_LIDENT;
 
 (* TYPICAL INEFFICIENCY 
   method package_type_cstrs = rule "package_type_cstrs" (fun () -> dummy
-    <!> case "package_type_cstrs_0" (perform
+    <|> case "package_type_cstrs_0" (perform
 
            v_1 <-- self#package_type_cstr ;
            token AND;
       )
 
   method signed_constant = rule "signed_constant" (fun () -> dummy
-    <!> case "signed_constant_0" (perform
+    <|> case "signed_constant_0" (perform
 
            token MINUS;
-           v_2 <-- get_FLOAT;
-
-           return (fun () ->  Const_float("-" ^ v_2) ))
-
-    <!> case "signed_constant_1" (perform
-
-           token MINUS;
-           v_2 <-- get_INT;
-
-           return (fun () ->  Const_int(- v_2) ))
-
-    <!> case "signed_constant_2" (perform
-
-           token MINUS;
-           v_2 <-- get_INT32;
-
-           return (fun () ->  Const_int32(Int32.neg v_2) ))
-
-    <!> case "signed_constant_3" (perform
-
-           token MINUS;
-           v_2 <-- get_INT64;
-
-           return (fun () ->  Const_int64(Int64.neg v_2) ))
-
-    <!> case "signed_constant_4" (perform
-
-           token MINUS;
-           v_2 <-- get_NATIVEINT;
-
-           return (fun () ->  Const_nativeint(Nativeint.neg v_2) ))
-
-    <!> case "signed_constant_5" (perform
+           t <-- take;
+           match t with
+           | FLOAT v_2 -> return (fun () -> Const_float("-" ^ v_2))
+           | INT v_2 -> return (fun () ->  Const_int(- v_2)) 
+           | INT32 v_2 -> return (fun () ->  Const_int32(Int32.neg v_2))
+           | INT64 v_2 -> return (fun () ->  Const_int64(Int64.neg v_2))
+           | NATIVEINT v_2 -> return (fun () ->  Const_nativeint(Nativeint.neg v_2))
+             (* It is only used in pattern, so we do not need to recover the error *)
+           | _ -> error "Expected a number literal")
+
+    <|> case "signed_constant_5" (perform
 
            token PLUS;
-           v_2 <-- get_FLOAT;
-
-           return (fun () ->  Const_float v_2 ))
-
-    <!> case "signed_constant_6" (perform
-
-           token PLUS;
-           v_2 <-- get_INT;
-
-           return (fun () ->  Const_int v_2 ))
-
-    <!> case "signed_constant_7" (perform
-
-           token PLUS;
-           v_2 <-- get_INT32;
-
-           return (fun () ->  Const_int32 v_2 ))
-
-    <!> case "signed_constant_8" (perform
-
-           token PLUS;
-           v_2 <-- get_INT64;
-
-           return (fun () ->  Const_int64 v_2 ))
-
-    <!> case "signed_constant_9" (perform
-
-           token PLUS;
-           v_2 <-- get_NATIVEINT;
-
-           return (fun () ->  Const_nativeint v_2 ))
-
-    <!> case "signed_constant_10" (perform
+           t <-- take;
+           match t with
+           | FLOAT v_2 -> return (fun () -> Const_float(v_2))
+           | INT v_2 -> return (fun () ->  Const_int v_2)
+           | INT32 v_2 -> return (fun () ->  Const_int32 v_2)
+           | INT64 v_2 -> return (fun () ->  Const_int64 v_2)
+           | NATIVEINT v_2 -> return (fun () ->  Const_nativeint v_2)
+             (* It is only used in pattern, so we do not need to recover the error *)
+           | _ -> error "Expected a number literal")
+
+    <|> case "signed_constant_10" (perform
 
            v_1 <-- self#constant ;