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