annotate lab4/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 (* lab4/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 mutable 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 (* abstract syntax *)
mike@0 14 type program = Prog of block * def list ref
mike@0 15
mike@0 16 and block = Block of decl list * stmt * int ref * int ref
mike@0 17
mike@0 18 and decl =
mike@0 19 ConstDecl of ident * expr
mike@0 20 | VarDecl of def_kind * ident list * typexpr
mike@0 21 | TypeDecl of (ident * typexpr) list
mike@0 22 | ProcDecl of proc_heading * block
mike@0 23 | PParamDecl of proc_heading
mike@0 24
mike@0 25 and proc_heading = Heading of name * decl list * typexpr option
mike@0 26
mike@0 27 and stmt =
mike@0 28 { s_guts: stmt_guts;
mike@0 29 s_line: int }
mike@0 30
mike@0 31 and stmt_guts =
mike@0 32 Skip
mike@0 33 | Seq of stmt list
mike@0 34 | Assign of expr * expr
mike@0 35 | ProcCall of name * expr list
mike@0 36 | Return of expr option
mike@0 37 | IfStmt of expr * stmt * stmt
mike@0 38 | WhileStmt of expr * stmt
mike@0 39 | RepeatStmt of stmt * expr
mike@0 40 | ForStmt of expr * expr * expr * stmt * def option ref
mike@0 41 | CaseStmt of expr * (expr * stmt) list * stmt
mike@0 42
mike@0 43 and expr =
mike@0 44 { e_guts: expr_guts;
mike@0 45 mutable e_type: ptype;
mike@0 46 mutable e_value: int option }
mike@0 47
mike@0 48 and expr_guts =
mike@0 49 Constant of int * ptype
mike@0 50 | Variable of name
mike@0 51 | Sub of expr * expr
mike@0 52 | Select of expr * name
mike@0 53 | Deref of expr
mike@0 54 | String of Optree.symbol * int
mike@0 55 | Nil
mike@0 56 | FuncCall of name * expr list
mike@0 57 | Monop of Optree.op * expr
mike@0 58 | Binop of Optree.op * expr * expr
mike@0 59
mike@0 60 and typexpr =
mike@0 61 TypeName of name
mike@0 62 | Array of expr * typexpr
mike@0 63 | Record of decl list
mike@0 64 | Pointer of typexpr
mike@0 65
mike@0 66 (* |makeExpr| -- construct an expression node with dummy annotations *)
mike@0 67 let makeExpr e =
mike@0 68 { e_guts = e; e_type = voidtype; e_value = None }
mike@0 69
mike@0 70 (* |makeStmt| -- construct a stmt node *)
mike@0 71 let makeStmt (s, n) = { s_guts = s; s_line = n }
mike@0 72
mike@0 73 (* |makeName| -- contruct a name node with dummy annotations *)
mike@0 74 let makeName (x, n) = { x_name = x; x_line = n; x_def = None }
mike@0 75
mike@0 76 let get_def x =
mike@0 77 match x.x_def with
mike@0 78 Some d -> d
mike@0 79 | None -> failwith (sprintf "missing def of $" [fId x.x_name])
mike@0 80
mike@0 81 (* |MakeBlock| -- construct a block node with dummy annotations *)
mike@0 82 let makeBlock (decls, stmts) = Block (decls, stmts, ref 0, ref 0)
mike@0 83
mike@0 84
mike@0 85 (* Grinder *)
mike@0 86
mike@0 87 let fTail f xs =
mike@0 88 let g prf = List.iter (fun x -> prf " $" [f x]) xs in fExt g
mike@0 89
mike@0 90 let fList f =
mike@0 91 function
mike@0 92 [] -> fStr "()"
mike@0 93 | x::xs -> fMeta "($$)" [f x; fTail(f) xs]
mike@0 94
mike@0 95 let fName x = fId x.x_name
mike@0 96
mike@0 97 let rec fBlock (Block (decls, stmts, _, _)) =
mike@0 98 match decls with
mike@0 99 [] -> fMeta "(BLOCK $)" [fStmt stmts]
mike@0 100 | _ -> fMeta "(BLOCK (DECLS$) $)" [fTail(fDecl) decls; fStmt stmts]
mike@0 101
mike@0 102 and fDecl =
mike@0 103 function
mike@0 104 ConstDecl (x, e) ->
mike@0 105 fMeta "(CONST $ $)" [fId x; fExpr e]
mike@0 106 | VarDecl (kind, xs, te) ->
mike@0 107 fMeta "($ $ $)" [fKind kind; fList(fId) xs; fType te]
mike@0 108 | TypeDecl tds ->
mike@0 109 let f (x, te) = fMeta "($ $)" [fId x; fType te] in
mike@0 110 fMeta "(TYPE$)" [fTail(f) tds]
mike@0 111 | ProcDecl (heading, body) ->
mike@0 112 fMeta "(PROC $ $)" [fHeading heading; fBlock body]
mike@0 113 | PParamDecl heading ->
mike@0 114 fMeta "(PROC $)" [fHeading heading]
mike@0 115
mike@0 116 and fKind =
mike@0 117 function
mike@0 118 VarDef -> fStr "VAR"
mike@0 119 | CParamDef -> fStr "PARAM"
mike@0 120 | VParamDef -> fStr "VPARAM"
mike@0 121 | FieldDef -> fStr "FIELD"
mike@0 122 | _ -> fStr "???"
mike@0 123
mike@0 124 and fHeading (Heading (p, fps, te)) =
mike@0 125 let res = match te with Some t -> fType t | None -> fStr "VOID" in
mike@0 126 fMeta "($ $ $)" [fName p; fList(fDecl) fps; res]
mike@0 127
mike@0 128 and fStmt s =
mike@0 129 match s.s_guts with
mike@0 130 Skip -> fStr "(SKIP)"
mike@0 131 | Seq stmts -> fMeta "(SEQ$)" [fTail(fStmt) stmts]
mike@0 132 | Assign (e1, e2) -> fMeta "(ASSIGN $ $)" [fExpr e1; fExpr e2]
mike@0 133 | ProcCall (p, aps) -> fMeta "(CALL $$)" [fName p; fTail(fExpr) aps]
mike@0 134 | Return (Some e) -> fMeta "(RETURN $)" [fExpr e]
mike@0 135 | Return None -> fStr "(RETURN)"
mike@0 136 | IfStmt (test, thenpt, elsept) ->
mike@0 137 fMeta "(IF $ $ $)" [fExpr test; fStmt thenpt; fStmt elsept]
mike@0 138 | WhileStmt (test, body) ->
mike@0 139 fMeta "(WHILE $ $)" [fExpr test; fStmt body]
mike@0 140 | RepeatStmt (body, test) ->
mike@0 141 fMeta "(REPEAT $ $)" [fStmt body; fExpr test]
mike@0 142 | ForStmt (var, lo, hi, body, _) ->
mike@0 143 fMeta "(FOR $ $ $ $)" [fExpr var; fExpr lo; fExpr hi; fStmt body]
mike@0 144 | CaseStmt (sel, arms, deflt) ->
mike@0 145 let fArm (lab, body) = fMeta "($ $)" [fExpr lab; fStmt body] in
mike@0 146 fMeta "(CASE $ $ $)" [fExpr sel; fList(fArm) arms; fStmt deflt]
mike@0 147
mike@0 148 and fExpr e =
mike@0 149 match e.e_guts with
mike@0 150 Constant (n, t) -> fMeta "(CONST $)" [fNum n]
mike@0 151 | Variable x -> fName x
mike@0 152 | Sub (e1, e2) -> fMeta "(SUB $ $)" [fExpr e1; fExpr e2]
mike@0 153 | Select (e1, x) -> fMeta "(SELECT $ $)" [fExpr e1; fName x]
mike@0 154 | Deref e1 -> fMeta "(DEREF $)" [fExpr e1]
mike@0 155 | String (s, _) -> fMeta "(STRING $)" [fStr s]
mike@0 156 | Nil -> fStr "(NIL)"
mike@0 157 | FuncCall (p, aps) ->
mike@0 158 fMeta "(CALL $$)" [fName p; fTail(fExpr) aps]
mike@0 159 | Monop (w, e1) ->
mike@0 160 fMeta "($ $)" [Optree.fOp w; fExpr e1]
mike@0 161 | Binop (w, e1, e2) ->
mike@0 162 fMeta "($ $ $)" [Optree.fOp w; fExpr e1; fExpr e2]
mike@0 163
mike@0 164 and fType =
mike@0 165 function
mike@0 166 TypeName x -> fName x
mike@0 167 | Array (e, t1) -> fMeta "(ARRAY $ $)" [fExpr e; fType t1]
mike@0 168 | Record fields -> fMeta "(RECORD$)" [fTail(fDecl) fields]
mike@0 169 | Pointer t1 -> fMeta "(POINTER $)" [fType t1]
mike@0 170
mike@0 171 let print_tree fp pfx (Prog (body, _)) =
mike@0 172 fgrindf fp pfx "(PROGRAM $)" [fBlock body]