Update hw4 to a newer version.

Signed-off-by: jmug <u.g.a.mariano@gmail.com>

hw4/lib/util/assert.ml

@@ -0,0 +1,195 @@
+(* CIS341 Assertion Testing and Grading Infrastructure *)
+(* Author: Steve Zdancewic                             *)
+
+(* Do NOT modify this file -- we will overwrite it     *)
+(* with our own version when testing your code.        *)
+
+(* An assertion is just a unit->unit function that either *)
+(* succeeds silently or throws an Failure exception.       *)
+type assertion = unit -> unit
+
+type 'a test =
+  | GradedTest of string * int * (string * 'a) list
+  | Test of string * (string * 'a) list
+
+type suite = assertion test list
+
+(**************)
+(* Assertions *)
+
+let assert_eq v1 v2 : assertion =
+ fun () -> if v1 <> v2 then failwith "not equal" else ()
+
+
+let assert_eqf f v2 : assertion =
+ fun () -> if f () <> v2 then failwith "not equal" else ()
+
+
+let assert_eqfs f v2 : assertion =
+ fun () ->
+  let s1 = f () in
+  if s1 <> v2
+  then failwith @@ Printf.sprintf "not equal\n\texpected:%s\n\tgot:%s\n" v2 s1
+  else ()
+
+
+let assert_fail : assertion = fun () -> failwith "assert fail"
+
+exception Timeout
+
+let timeout_assert (time : int) (a : assertion) : assertion =
+ fun () ->
+  let handler = Sys.Signal_handle (fun _ -> raise Timeout) in
+  let old = Sys.signal Sys.sigalrm handler in
+  let reset_sigalrm () = Sys.set_signal Sys.sigalrm old in
+  ignore (Unix.alarm time) ;
+  try
+    a () ;
+    reset_sigalrm ()
+  with
+  | Timeout ->
+      reset_sigalrm () ;
+      failwith @@ Printf.sprintf "Timed out after %d seconds" time
+  | exc ->
+      reset_sigalrm () ;
+      raise exc
+
+
+let timeout_test (time : int) (t : assertion test) : assertion test =
+  let map_timeout l = List.map (fun (i, a) -> (i, timeout_assert time a)) l in
+  match t with
+  | GradedTest (s, i, ls) ->
+      GradedTest (s, i, map_timeout ls)
+  | Test (s, ls) ->
+      Test (s, map_timeout ls)
+
+
+let timeout_suite (time : int) (s : suite) : suite =
+  List.map (timeout_test time) s
+
+
+(***************************)
+(* Generating Test Results *)
+
+type result =
+  | Pass
+  | Fail of string
+
+type outcome = result test list
+
+let run_assertion (f : assertion) : result =
+  try
+    f () ;
+    Pass
+  with
+  | Failure m ->
+      Fail m
+  | e ->
+      Fail ("test threw exception: " ^ Printexc.to_string e)
+
+
+let run_test (t : assertion test) : result test =
+  let run_case (cn, f) = (cn, run_assertion f) in
+  match t with
+  | GradedTest (n, s, cases) ->
+      Printf.eprintf "Running test %s\n%!" n ;
+      GradedTest (n, s, List.map run_case cases)
+  | Test (n, cases) ->
+      Printf.eprintf "Running test %s\n%!" n ;
+      Test (n, List.map run_case cases)
+
+
+let run_suite (s : suite) : outcome = List.map run_test s
+
+(***********************)
+(* Reporting functions *)
+
+let result_test_to_string (name_pts : string) (r : result test) : string =
+  let string_of_case (name, res) =
+    match res with
+    | Pass ->
+        "passed - " ^ name
+    | Fail msg ->
+        "FAILED - " ^ name ^ ": " ^ msg
+  in
+  match r with
+  | GradedTest (_, _, cases) | Test (_, cases) ->
+      name_pts
+      ^ List.fold_left
+          (fun rest case -> rest ^ "\n" ^ string_of_case case)
+          ""
+          cases
+
+
+(* Number of digits of precision for a float x. Argument p is the number of decimal places desired (must be at least 1) *)
+let prec_digits p x = (int_of_float @@ floor @@ log10 x) + (1 + p)
+
+(* returns (name_pts, passed, failed, total, points_earned, max_given, max_hidden) *)
+let get_results (t : result test) =
+  let num_passed cases =
+    List.fold_left
+      (fun cnt (_, r) -> match r with Pass -> cnt + 1 | _ -> cnt)
+      0
+      cases
+  in
+  let num_failed cases =
+    List.fold_left
+      (fun cnt (_, r) -> match r with Fail _ -> cnt + 1 | _ -> cnt)
+      0
+      cases
+  in
+  match t with
+  | GradedTest (name, pts, cases) ->
+      let passed = num_passed cases in
+      let failed = num_failed cases in
+      let total = List.length cases in
+      if total > 0 
+      then
+        let points_earned = ((float_of_int passed) /. (float_of_int total)) *. (float_of_int pts) in
+        let name_pts = 
+          Printf.sprintf "%s (%1.*g/%d points = %d/%d tests)" name (prec_digits 1 points_earned) points_earned pts passed total 
+        in
+        (name_pts, passed, failed, total, points_earned, pts, 0)
+      else
+        let name_pts = Printf.sprintf "%s (?/%d points)" name pts in
+        (name_pts, passed, failed, total, 0.0, 0, pts)
+  | Test (name, cases) ->
+      let total = List.length cases in
+      let passed = num_passed cases in
+      let failed = num_failed cases in
+      (name, passed, failed, total, 0.0, 0, 0)
+
+
+let outcome_to_string (o : outcome) : string =
+  let sep = "\n---------------------------------------------------\n" in
+  let helper (passed, failed, total, pts, maxg, maxh, str) (t : result test) =
+    let name_pts, p, f, tot, s, mg, mh = get_results t in
+    ( passed + p
+    , failed + f
+    , total + tot
+    , s +. pts
+    , maxg + mg
+    , maxh + mh
+    , str
+      ^ "\n"
+      ^
+      if f > 0
+      then result_test_to_string name_pts t
+      else if tot > 0
+      then name_pts ^ ":\n  OK"
+      else name_pts ^ ":\n  Hidden" )
+  in
+  let p, f, tot, pts, maxg, maxh, str =
+    List.fold_left helper (0, 0, 0, 0.0, 0, 0, "") o
+  in
+  str
+  ^ sep
+  ^ Printf.sprintf
+      "Passed: %d/%d\n\
+       Failed: %d/%d\n\
+       Score: %1.1f/%d (given)\n\
+      \       ?/%d (hidden)"
+      p tot
+      f tot
+      pts maxg
+      maxh

hw4/lib/util/assert.mli

@@ -0,0 +1,57 @@
+(* CIS341 Assertion Testing and Grading Infrastructure *)
+(* Author: Steve Zdancewic                             *)
+
+(* Do NOT modify this file -- we will overwrite it     *)
+(* with our own version when testing your code.        *)
+
+exception Timeout
+
+(* An assertion is just a unit->unit function that either *)
+(* succeeds silently or throws an Failure exception.       *)
+type assertion = unit -> unit
+
+type 'a test =
+  | GradedTest of string * int * (string * 'a) list
+  | Test of string * (string * 'a) list
+
+type suite = assertion test list
+
+(**************)
+(* Assertions *)
+
+val assert_eq : 'a -> 'a -> assertion
+
+val assert_eqf : (unit -> 'a) -> 'a -> assertion
+
+val assert_eqfs : (unit -> string) -> string -> assertion
+
+val assert_fail : assertion
+
+val timeout_assert : int -> assertion -> assertion
+
+val timeout_test : int -> assertion test -> assertion test
+
+val timeout_suite : int -> suite -> suite
+
+(***************************)
+(* Generating Test Results *)
+
+type result =
+  | Pass
+  | Fail of string
+
+type outcome = result test list
+
+val run_assertion : assertion -> result
+
+val run_test : assertion test -> result test
+
+val run_suite : suite -> outcome
+
+(***********************)
+(* Reporting functions *)
+
+val result_test_to_string : string -> result test -> string
+
+(* val get_results result test -> (string * int * int * int * float * int * int) *)
+val outcome_to_string : outcome -> string

hw4/lib/util/dune

@@ -0,0 +1,3 @@
+(library
+  (name util)
+  (libraries str unix))

hw4/lib/util/platform.ml

@@ -0,0 +1,237 @@
+(* -------------------------------------------------------------------------- *)
+(** Assembling and linking for X86.  Depends on the underlying OS platform    *)
+
+open Printf
+open Unix
+
+exception PlatformError of string * string
+
+(* paths -------------------------------------------------------------------- *)
+let path_sep = "/"
+
+let bin_path = "./bin"
+
+let dot_path = "./"
+
+let executable_name = ref "a.out"
+
+let output_path = ref "output"
+
+let libs = ref []
+
+let lib_paths = ref []
+
+let lib_search_paths = ref []
+
+let include_paths = ref []
+
+(* unix utility scripts ----------------------------------------------------- *)
+let pp_cmd = ref "cpp -E "
+
+let rm_cmd = ref "rm -rf "
+
+(* -------------------------------------------------------------------------- *)
+(* Platform specific configuration: Unix/Linux vs. Mac OS X                   *)
+
+let os =
+  let ic = Unix.open_process_in "uname -s" in
+  let uname = input_line ic in
+  let () = close_in ic in
+  uname
+
+let cpu = 
+  let ic = Unix.open_process_in "uname -m" in
+  let cpuname = input_line ic in
+  let () = close_in ic in
+  cpuname
+
+(* One of "Darwin" or "Linux" *)
+
+let linux = ref false
+
+let mangle name = if !linux then name else "_" ^ name
+
+let osx_target_triple = "x86_64-apple-macosx10.13.0"
+
+let linux_target_triple = "x86_64-unknown-linux"
+
+let target_triple = ref osx_target_triple
+
+let platform_flags = ref ""
+
+(* Set the link commands properly, ensure output directory exists *)
+let configure_os () =
+  if os = "Linux"
+  then (
+    linux := true ;
+    target_triple := linux_target_triple ;
+    platform_flags := "" )
+  else if os = "Darwin"
+  then (
+    linux := false ;
+    target_triple := osx_target_triple ;
+    platform_flags := "-fno-asynchronous-unwind-tables -mstackrealign" )
+  else failwith @@ "Unsupported OS detected: " ^ os
+
+
+(* verbose compiler output -------------------------------------------------- *)
+let verbose = ref false
+
+let verb msg =
+  if !verbose
+  then (
+    print_string msg ;
+    flush Stdlib.stdout )
+
+
+let verb_os () =
+  verb
+  @@ Printf.sprintf
+       "* PLATFORM: %s TRIPLE: %s FLAGS %s\n"
+       os
+       !target_triple
+       !platform_flags
+
+
+let enable_verbose () =
+  verbose := true ;
+  verb_os ()
+
+
+(* create the output directory, which is assumed to exist *)
+let create_output_dir () =
+  try ignore (stat !output_path) with
+  | Unix_error (ENOENT, _, _) ->
+      verb @@ Printf.sprintf "creating output directory: %s\n" !output_path ;
+      mkdir !output_path 0o755
+
+
+(* clang invocation stuff --------------------------------------------------- *)
+let common_flags = "-Wno-override-module"
+
+let link_flags = "-Wno-unused-command-line-argument -mstackrealign"
+
+let clang_ll_mode = "-S"
+
+let as_mode = "-c"
+
+let rosetta_prefix = "arch -x86_64 "
+
+let prefix = if cpu = "arm64" then rosetta_prefix else ""
+
+let opt_level = ref "-O1 -Wall"
+
+let clang args = Printf.sprintf "%sclang %s -o " prefix (String.concat " " args)
+
+let clang_cmd () =
+  clang [ clang_ll_mode; !opt_level; common_flags; !platform_flags ]
+
+
+let as_cmd () = clang [ as_mode; !opt_level; common_flags; !platform_flags ]
+
+let link_cmd () = clang [ common_flags; !opt_level; !platform_flags; link_flags ]
+
+(* filename munging --------------------------------------------------------- *)
+let path_to_basename_ext (path : string) : string * string =
+  (* The path is of the form ... "foo/bar/baz/<file>.ext" *)
+  let paths = Str.split (Str.regexp_string path_sep) path in
+  let _ =
+    if List.length paths = 0 then failwith @@ sprintf "bad path: %s" path
+  in
+  let filename = List.hd (List.rev paths) in
+  match Str.split (Str.regexp_string ".") filename with
+  | [ root ] ->
+      (root, "")
+  | [ root; ext ] ->
+      (root, ext)
+  | _ ->
+      failwith @@ sprintf "bad filename: %s" filename
+
+
+(* compilation and shell commands-------------------------------------------- *)
+
+(* Platform independent shell command *)
+let sh (cmd : string) (ret : string -> int -> 'a) : 'a =
+  verb (sprintf "* %s\n" cmd) ;
+  match system cmd with
+  | WEXITED i ->
+      ret cmd i
+  | WSIGNALED i ->
+      raise (PlatformError (cmd, sprintf "Signaled with %d." i))
+  | WSTOPPED i ->
+      raise (PlatformError (cmd, sprintf "Stopped with %d." i))
+
+(* Platform independent shell command with a timeout (in seconds) *)
+let timeout_sh (time: int)(cmd : string) (ret : string -> int -> 'a) : 'a =
+  let timeout_cmd = sprintf "%s/timeout3 -t %d %s" bin_path time cmd in
+  verb (sprintf "* %s\n" timeout_cmd) ;
+  match system timeout_cmd with
+  | WEXITED i ->
+      ret cmd i
+  | WSIGNALED i ->
+      if i == Sys.sigterm
+      then raise (PlatformError (cmd, sprintf "Timed-out after %d s" time))
+      else raise (PlatformError (cmd, sprintf "Signaled with %d." i))
+  | WSTOPPED i ->
+      raise (PlatformError (cmd, sprintf "Stopped with %d." i))
+
+
+(* Generate a file name that does not already exist.
+   basedir includes the path separator
+*)
+let gen_name (basedir : string) (basen : string) (baseext : string) : string =
+  let rec nocollide ofs =
+    let nfn =
+      sprintf
+        "%s/%s%s%s"
+        basedir
+        basen
+        (if ofs = 0 then "" else "_" ^ string_of_int ofs)
+        baseext
+    in
+    try
+      ignore (stat nfn) ;
+      nocollide (ofs + 1)
+    with
+    | Unix_error (ENOENT, _, _) ->
+        nfn
+  in
+  nocollide 0
+
+
+let raise_error cmd i =
+  if i <> 0 then raise (PlatformError (cmd, sprintf "Exited with status %d." i))
+
+
+let ignore_error _ _ = ()
+
+let preprocess (dot_oat : string) (dot_i : string) : unit =
+  sh
+    (sprintf
+       "%s%s %s %s"
+       !pp_cmd
+       (List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
+       dot_oat
+       dot_i)
+    raise_error
+
+
+let clang_compile (dot_ll : string) (dot_s : string) : unit =
+  sh (sprintf "%s%s %s" (clang_cmd ()) dot_s dot_ll) raise_error
+
+
+let assemble (dot_s : string) (dot_o : string) : unit =
+  sh (sprintf "%s%s %s" (as_cmd ()) dot_o dot_s) raise_error
+
+
+let link (mods : string list) (out_fn : string) : unit =
+  sh
+    (sprintf
+       "%s%s %s %s %s %s"
+       (link_cmd ())
+       out_fn
+       (String.concat " " (mods @ !lib_paths))
+       (List.fold_left (fun s i -> s ^ " -L" ^ i) "" !lib_search_paths)
+       (List.fold_left (fun s i -> s ^ " -I" ^ i) "" !include_paths)
+       (List.fold_left (fun s l -> s ^ " -l" ^ l) "" !libs))
+    raise_error

hw4/lib/util/range.ml

@@ -0,0 +1,56 @@
+open Lexing
+
+type pos = int * int (* Line number and column *)
+
+type t = string * pos * pos
+
+let line_of_pos (l, _) = l
+
+let col_of_pos (_, c) = c
+
+let mk_pos line col = (line, col)
+
+let file_of_range (f, _, _) = f
+
+let start_of_range (_, s, _) = s
+
+let end_of_range (_, _, e) = e
+
+let mk_range f s e = (f, s, e)
+
+let valid_pos (l, c) = l >= 0 && c >= 0
+
+let merge_range ((f, s1, e1) as r1) ((f', s2, e2) as r2) =
+  if f <> f'
+  then
+    failwith
+    @@ Printf.sprintf "merge_range called on different files: %s and %s" f f'
+  else if not (valid_pos s1)
+  then r2
+  else if not (valid_pos s2)
+  then r1
+  else mk_range f (min s1 s2) (max e1 e2)
+
+
+let string_of_range (f, (sl, sc), (el, ec)) =
+  Printf.sprintf "%s:[%d.%d-%d.%d]" f sl sc el ec
+
+
+let ml_string_of_range (f, (sl, sc), (el, ec)) =
+  Printf.sprintf "(\"%s\", (%d, %d), (%d, %d))" f sl sc el ec
+
+
+let norange = ("__internal", (0, 0), (0, 0))
+
+(* Creates a Range.pos from the Lexing.position data *)
+let pos_of_lexpos (p : position) : pos =
+  mk_pos p.pos_lnum (p.pos_cnum - p.pos_bol)
+
+
+let mk_lex_range (p1 : position) (p2 : position) : t =
+  mk_range p1.pos_fname (pos_of_lexpos p1) (pos_of_lexpos p2)
+
+
+(* Expose the lexer state as a Range.t value *)
+let lex_range lexbuf : t =
+  mk_lex_range (lexeme_start_p lexbuf) (lexeme_end_p lexbuf)

hw4/lib/util/range.mli

@@ -0,0 +1,53 @@
+(* Ranges and utilities on ranges. *)
+
+(* A range represents a segment of text in a given file; it has a
+ * beginning and ending position specified in terms of line and column
+ * numbers. A range is associated with tokens during lexing to allow
+ * the compiler to give better error messages during lexing and
+ * parsing.  
+ *)
+
+(* a position in the source file; line number and column *)
+type pos = int * int
+
+(* a range of positions in a particular file *)
+type t = string * pos * pos
+
+(* line of position *)
+val line_of_pos : pos -> int
+
+(* column of position *)
+val col_of_pos : pos -> int
+
+(* new position with given line and col *)
+val mk_pos : int -> int -> pos
+
+(* the filename a range is in *)
+val file_of_range : t -> string
+
+(* the beginning of the range *)
+val start_of_range : t -> pos
+
+(* the end of the range *)
+val end_of_range : t -> pos
+
+(* create a new range from the given filename and start, end positions *)
+val mk_range : string -> pos -> pos -> t
+
+(* merge two ranges together *)
+val merge_range : t -> t -> t
+
+(* pretty-print a range *)
+val string_of_range : t -> string
+
+(* print a range as an ocaml value *)
+val ml_string_of_range : t -> string
+
+(* use to tag generated AST nodes where range does not apply *)
+val norange : t
+
+val pos_of_lexpos : Lexing.position -> pos
+
+val mk_lex_range : Lexing.position -> Lexing.position -> t
+
+val lex_range : Lexing.lexbuf -> t