annotate lab3/tree.ml @ 1:b5139af1a420 tip basis

Fixed permissions on compile scripts
author Mike Spivey <mike@cs.ox.ac.uk>
date Fri, 13 Oct 2017 17:27:58 +0100
parents bfdcc3820b32
children
rev   line source
mike@0 1 (* lab3/tree.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 open Dict
mike@0 5 open Print
mike@0 6
mike@0 7 (* |name| -- type for applied occurrences with annotations *)
mike@0 8 type name =
mike@0 9 { x_name: ident; (* Name of the reference *)
mike@0 10 x_line: int; (* Line number *)
mike@0 11 mutable x_def: def option } (* Definition in scope *)
mike@0 12
mike@0 13 type expr =
mike@0 14 Constant of int
mike@0 15 | Variable of name
mike@0 16 | Monop of Keiko.op * expr
mike@0 17 | Binop of Keiko.op * expr * expr
mike@0 18 | Call of name * expr list
mike@0 19
mike@0 20 type stmt =
mike@0 21 Skip
mike@0 22 | Seq of stmt list
mike@0 23 | Assign of name * expr
mike@0 24 | Return of expr
mike@0 25 | IfStmt of expr * stmt * stmt
mike@0 26 | WhileStmt of expr * stmt
mike@0 27 | Print of expr
mike@0 28 | Newline
mike@0 29
mike@0 30 type block = Block of ident list * proc list * stmt
mike@0 31
mike@0 32 and proc = Proc of name * ident list * block
mike@0 33
mike@0 34 type program = Program of block
mike@0 35
mike@0 36
mike@0 37 let seq =
mike@0 38 function
mike@0 39 [] -> Skip
mike@0 40 | [s] -> s
mike@0 41 | ss -> Seq ss
mike@0 42
mike@0 43 let makeName x ln =
mike@0 44 { x_name = x; x_line = ln; x_def = None }
mike@0 45
mike@0 46 let get_def x =
mike@0 47 match x.x_def with
mike@0 48 Some d -> d
mike@0 49 | None -> failwith (sprintf "missing def on $" [fStr x.x_name])
mike@0 50
mike@0 51
mike@0 52 (* Pretty printer *)
mike@0 53
mike@0 54 open Print
mike@0 55
mike@0 56 let fTail f xs =
mike@0 57 let g prf = List.iter (fun x -> prf "; $" [f x]) xs in fExt g
mike@0 58
mike@0 59 let fList f =
mike@0 60 function
mike@0 61 [] -> fStr "[]"
mike@0 62 | x::xs -> fMeta "[$$]" [f x; fTail(f) xs]
mike@0 63
mike@0 64 let fName x = fStr x.x_name
mike@0 65
mike@0 66 let rec fExpr =
mike@0 67 function
mike@0 68 Constant n ->
mike@0 69 fMeta "Number_$" [fNum n]
mike@0 70 | Variable x ->
mike@0 71 fMeta "Variable_$" [fName x]
mike@0 72 | Monop (w, e1) ->
mike@0 73 fMeta "Monop_($, $)" [fStr (Keiko.op_name w); fExpr e1]
mike@0 74 | Binop (w, e1, e2) ->
mike@0 75 fMeta "Binop_($, $, $)" [fStr (Keiko.op_name w); fExpr e1; fExpr e2]
mike@0 76 | Call (x, es) ->
mike@0 77 fMeta "Call_($, $)" [fName x; fList(fExpr) es]
mike@0 78
mike@0 79 let rec fStmt =
mike@0 80 function
mike@0 81 Skip ->
mike@0 82 fStr "Skip"
mike@0 83 | Seq ss ->
mike@0 84 fMeta "Seq_$" [fList(fStmt) ss]
mike@0 85 | Assign (x, e) ->
mike@0 86 fMeta "Assign_($, $)" [fName x; fExpr e]
mike@0 87 | Return e ->
mike@0 88 fMeta "Return_($)" [fExpr e]
mike@0 89 | Print e ->
mike@0 90 fMeta "Print_($)" [fExpr e]
mike@0 91 | Newline ->
mike@0 92 fStr "Newline"
mike@0 93 | IfStmt (e, s1, s2) ->
mike@0 94 fMeta "IfStmt_($, $, $)" [fExpr e; fStmt s1; fStmt s2]
mike@0 95 | WhileStmt (e, s) ->
mike@0 96 fMeta "WhileStmt_($, $)" [fExpr e; fStmt s]
mike@0 97
mike@0 98 let rec fBlock (Block (vs, ps, body)) =
mike@0 99 fMeta "Block_($, $, $)" [fList(fStr) vs; fList(fProc) ps; fStmt body]
mike@0 100
mike@0 101 and fProc (Proc (x, fps, body)) =
mike@0 102 fMeta "Proc_($, $, $)" [fName x; fList(fStr) fps; fBlock body]
mike@0 103
mike@0 104 let print_tree fp (Program b) =
mike@0 105 fgrindf fp "" "Program_($)" [fBlock b]