From 55778599d495f5be50f601285f65fad9d2e6dc77 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Thu, 8 Feb 2024 17:57:33 +0800 Subject: [PATCH] copy FrontC.Cprint to local to make it easier to extend --- lib/back/cprint1.ml | 766 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 766 insertions(+) create mode 100644 lib/back/cprint1.ml diff --git a/lib/back/cprint1.ml b/lib/back/cprint1.ml new file mode 100644 index 0000000..01b6c37 --- /dev/null +++ b/lib/back/cprint1.ml @@ -0,0 +1,766 @@ +(* cprint -- pretty printer of C program from abstract syntax *) + +open Cabs +let version = "Cprint 4.0 Hugues Cassé et al." + +(* +** FrontC Pretty printer +*) +let out = ref stdout +let width = ref 80 +let tab = ref 8 +let max_indent = ref 60 + +let line = ref "" +let line_len = ref 0 +let current = ref "" +let current_len = ref 0 +let spaces = ref 0 +let follow = ref 0 +let roll = ref 0 + +let print_tab size = + output_string !out (String.make (size / 8) '\t'); + output_string !out (String.make (size mod 8) ' ') + +let flush _ = + if !line <> "" then begin + print_tab (!spaces + !follow); + output_string !out !line; + line := ""; + line_len := 0 + end + +let commit _ = + if !current <> "" then begin + if !line = "" then begin + line := !current; + line_len := !current_len + end else begin + line := (!line ^ " " ^ !current); + line_len := !line_len + 1 + !current_len + end; + current := ""; + current_len := 0 + end + +let new_line _ = + commit (); + if !line <> "" then begin + flush (); + output_char !out '\n' + end; + follow := 0 + +let force_new_line _ = + commit (); + flush (); + output_char !out '\n'; + follow := 0 + +let indent _ = + new_line (); + spaces := !spaces + !tab; + if !spaces >= !max_indent then begin + spaces := !tab; + roll := !roll + 1 + end + +let unindent _ = + new_line (); + spaces := !spaces - !tab; + if (!spaces <= 0) && (!roll > 0) then begin + spaces := ((!max_indent - 1) / !tab) * !tab; + roll := !roll - 1 + end + +let space _ = commit () + +let print str = + current := !current ^ str; + current_len := !current_len + (String.length str); + if (!spaces + !follow + !line_len + 1 + !current_len) > !width + then begin + if !line_len = 0 then commit (); + flush (); + output_char !out '\n'; + if !follow = 0 then follow := !tab + end + + +(* +** Useful primitives +*) +let print_commas nl fct lst = + let _ = List.fold_left + (fun com elt -> + if com then begin + print ","; + if nl then new_line () else space () + end else (); + fct elt; + true) + false + lst in + () + + +let escape_string str = + let lng = String.length str in + let conv value = String.make 1 (Char.chr (value + + (if value < 10 then (Char.code '0') else (Char.code 'a' - 10)))) in + let rec build idx = + if idx >= lng then "" + else + let sub = String.sub str idx 1 in + let res = match sub with + "\n" -> "\\n" + | "\"" -> "\\\"" + | "'" -> "\\'" + | "\r" -> "\\r" + | "\t" -> "\\t" + | "\b" -> "\\b" + | "\000" -> "\\0" + | _ -> if sub = (Char.escaped (String.get sub 0)) + then sub + else let code = Char.code (String.get sub 0) in + "\\" + ^ (conv (code / 64)) + ^ (conv ((code mod 64) / 8)) + ^ (conv (code mod 8)) in + res ^ (build (idx + 1)) in + build 0 + +let rec has_extension attrs = + match attrs with + [] -> false + | GNU_EXTENSION::_ -> true + | _::attrs -> has_extension attrs + + +(* +** Base Type Printing +*) +let get_sign si = + match si with + NO_SIGN -> "" + | SIGNED -> "signed " + | UNSIGNED -> "unsigned " + +let get_size siz = + match siz with + NO_SIZE -> "" + | SHORT -> "short " + | LONG -> "long " + | LONG_LONG -> "long long " + +let rec print_base_type typ = + match typ with + NO_TYPE -> () + | VOID -> print "void" + | BOOL -> print "_Bool" + | CHAR sign -> print ((get_sign sign) ^ "char") + | INT (size, sign) -> print ((get_sign sign) ^ (get_size size) ^ "int") + | BITFIELD (sign, _) -> print ((get_sign sign) ^ "int") + | FLOAT size -> print ((if size then "long " else "") ^ "float") + | DOUBLE size -> print ((if size then "long " else "") ^ "double") + | COMPLEX_FLOAT -> print "float _Complex" + | COMPLEX_DOUBLE -> print "double _Complex" + | COMPLEX_LONG_DOUBLE -> print "long double _Complex" + | NAMED_TYPE id -> print id + | ENUM (id, items) -> print_enum id items + | STRUCT (id, flds) -> print_fields ("struct " ^ id) flds + | UNION (id, flds) -> print_fields ("union " ^ id) flds + | PROTO (typ, _, _) -> print_base_type typ + | OLD_PROTO (typ, _, _) -> print_base_type typ + | PTR typ -> print_base_type typ + | RESTRICT_PTR typ -> print_base_type typ + | ARRAY (typ, _) -> print_base_type typ + | CONST typ -> print_base_type typ + | VOLATILE typ -> print_base_type typ + | GNU_TYPE (attrs, typ) -> print_attributes attrs; print_base_type typ + | BUILTIN_TYPE t -> print t + | TYPE_LINE (_, _, _type) -> print_base_type _type + +and print_fields id (flds : name_group list) = + print id; + if flds = [] + then () + else begin + print " {"; + indent (); + List.iter + (fun fld -> print_name_group fld; print ";"; new_line ()) + flds; + unindent (); + print "}" + end + +and print_enum id items = + print ("enum " ^ id); + if items = [] + then () + else begin + print " {"; + indent (); + print_commas + true + (fun (id, exp) -> print id; + if exp = NOTHING then () + else begin + space (); + print "= "; + print_expression exp 1 + end) + items; + unindent (); + print "}"; + end + + +(* +** Declaration Printing +*) +and get_base_type typ = + match typ with + PTR typ -> get_base_type typ + | RESTRICT_PTR typ -> get_base_type typ + | CONST typ -> get_base_type typ + | VOLATILE typ -> get_base_type typ + | ARRAY (typ, _) -> get_base_type typ + | _ -> typ + +and print_pointer typ = + match typ with + PTR typ -> print_pointer typ; print "*" + | RESTRICT_PTR typ -> + print_pointer typ; print "* __restrict"; + space () + | CONST typ -> print_pointer typ; print " const " + | VOLATILE typ -> print_pointer typ; print " volatile " + | ARRAY (typ, _) -> print_pointer typ + | _ -> (*print_base_type typ*) () + +and print_array typ = + match typ with + ARRAY (typ, dim) -> + print_array typ; + print "["; + print_expression dim 0; + print "]" + | _ -> () + +(** Print a type. + @param fct Function called to display the name of the. + @param typ Type to display. +*) +and print_type (fct : unit -> unit) (typ : base_type ) = + let base = get_base_type typ in + match base with + BITFIELD (_, exp) -> fct (); print " : "; print_expression exp 1 + | PROTO (typ', pars, ell) -> + print_type + (fun _ -> + if base <> typ then print "("; + print_pointer typ; + fct (); + print_array typ; + if base <> typ then print ")"; + print "("; + print_params pars ell; + print ")") + typ' + | OLD_PROTO (typ', pars, ell) -> + print_type + (fun _ -> + if base <> typ then print "("; + print_pointer typ; + fct (); + print_array typ; + if base <> typ then print ")"; + print "("; + print_old_params pars ell; + print ")") + typ' + | _ -> print_pointer typ; fct (); print_array typ + +and print_onlytype typ = + print_base_type typ; + print_type (fun _ -> ()) typ + +and print_name ((id, typ, attr, exp) : name) = + print_type (fun _ -> print id) typ; + print_attributes attr; + if exp <> NOTHING then begin + space (); + print "= "; + print_expression exp 1 + end else () + +and get_storage sto = + match sto with + NO_STORAGE -> "" + | AUTO -> "auto" + | STATIC -> "static" + | EXTERN -> "extern" + | REGISTER -> "register" + +and print_name_group (typ, sto, names) = + let extension = List.exists + (fun (_, _, attrs, _) -> has_extension attrs) + names in + if extension then begin + print "__extension__"; + space () + end; + if sto <> NO_STORAGE then begin + print (get_storage sto); + space () + end; + print_base_type typ; + space (); + print_commas false print_name names + +and print_single_name (typ, sto, name) = + if sto <> NO_STORAGE then begin + print (get_storage sto); + space () + end; + print_base_type typ; + space (); + print_name name + +and print_params (pars : single_name list) (ell : bool) = + print_commas false print_single_name pars; + if ell then print (if pars = [] then "..." else ", ...") else () + +and print_old_params pars ell = + print_commas false (fun id -> print id) pars; + if ell then print (if pars = [] then "..." else ", ...") else () + + +(* +** Expression printing +** Priorities +** 16 variables +** 15 . -> [] call() +** 14 ++, -- (post) +** 13 ++ -- (pre) ~ ! - + & *(cast) +** 12 * / % +** 11 + - +** 10 << >> +** 9 < <= > >= +** 8 == != +** 7 & +** 6 ^ +** 5 | +** 4 && +** 3 || +** 2 ? : +** 1 = ?= +** 0 , +*) +and get_operator exp = + match exp with + NOTHING -> ("", 16) + | UNARY (op, _) -> + (match op with + MINUS -> ("-", 13) + | PLUS -> ("+", 13) + | NOT -> ("!", 13) + | BNOT -> ("~", 13) + | MEMOF -> ("*", 13) + | ADDROF -> ("&", 13) + | PREINCR -> ("++", 13) + | PREDECR -> ("--", 13) + | POSINCR -> ("++", 14) + | POSDECR -> ("--", 14)) + | BINARY (op, _, _) -> + (match op with + MUL -> ("*", 12) + | DIV -> ("/", 12) + | MOD -> ("%", 12) + | ADD -> ("+", 11) + | SUB -> ("-", 11) + | SHL -> ("<<", 10) + | SHR -> (">>", 10) + | LT -> ("<", 9) + | LE -> ("<=", 9) + | GT -> (">", 9) + | GE -> (">=", 9) + | EQ -> ("==", 8) + | NE -> ("!=", 8) + | BAND -> ("&", 7) + | XOR -> ("^", 6) + | BOR -> ("|", 5) + | AND -> ("&&", 4) + | OR -> ("||", 3) + | ASSIGN -> ("=", 1) + | ADD_ASSIGN -> ("+=", 1) + | SUB_ASSIGN -> ("-=", 1) + | MUL_ASSIGN -> ("*=", 1) + | DIV_ASSIGN -> ("/=", 1) + | MOD_ASSIGN -> ("%=", 1) + | BAND_ASSIGN -> ("&=", 1) + | BOR_ASSIGN -> ("|=", 1) + | XOR_ASSIGN -> ("^=", 1) + | SHL_ASSIGN -> ("<<=", 1) + | SHR_ASSIGN -> (">>=", 1)) + | QUESTION _ -> ("", 2) + | CAST _ -> ("", 13) + | CALL _ -> ("", 15) + | COMMA _ -> ("", 0) + | CONSTANT _ -> ("", 16) + | VARIABLE _ -> ("", 16) + | EXPR_SIZEOF _ -> ("", 16) + | TYPE_SIZEOF _ -> ("", 16) + | INDEX _ -> ("", 15) + | MEMBEROF _ -> ("", 15) + | MEMBEROFPTR _ -> ("", 15) + | GNU_BODY _ -> ("", 17) + | DESIGNATED _ -> ("", 15) + | EXPR_LINE (expr, _, _) -> get_operator expr + +and print_comma_exps exps = + print_commas false (fun exp -> print_expression exp 1) exps + +and print_expression (exp : expression) (lvl : int) = + let (txt, lvl') = get_operator exp in + let _ = if lvl > lvl' then print "(" else () in + let _ = match exp with + NOTHING -> () + | UNARY (op, exp') -> + (match op with + POSINCR | POSDECR -> + print_expression exp' lvl'; + print txt + | _ -> + print txt; + print_expression exp' lvl') + | BINARY (_, exp1, exp2) -> + (*if (op = SUB) && (lvl <= lvl') then print "(";*) + print_expression exp1 lvl'; + space (); + print txt; + space (); + (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*) + print_expression exp2 (lvl' + 1) + (*if (op = SUB) && (lvl <= lvl') then print ")"*) + | QUESTION (exp1, exp2, exp3) -> + print_expression exp1 2; + space (); + print "? "; + print_expression exp2 2; + space (); + print ": "; + print_expression exp3 2; + | CAST (typ, exp) -> + print "("; + print_onlytype typ; + print ")"; + print_expression exp 15 + | CALL (exp, args) -> + print_expression exp 16; + print "("; + print_comma_exps args; + print ")" + | COMMA exps -> + print_comma_exps exps + | CONSTANT cst -> + print_constant cst + | VARIABLE name -> + print name + | EXPR_SIZEOF exp -> + print "sizeof("; + print_expression exp 0; + print ")" + | TYPE_SIZEOF typ -> + print "sizeof("; + print_onlytype typ; + print ")" + | INDEX (exp, idx) -> + print_expression exp 16; + print "["; + print_expression idx 0; + print "]" + | MEMBEROF (exp, fld) -> + print_expression exp 16; + print ("." ^ fld) + | MEMBEROFPTR (exp, fld) -> + print_expression exp 16; + print ("->" ^ fld) + | GNU_BODY (decs, stat) -> + print "("; + print_statement (BLOCK (decs, stat)); + print ")" + | DESIGNATED (member, exp) -> + print "."; + print member; + print "="; + print_expression exp 16; + | EXPR_LINE (expr, _, _) -> + print_expression expr lvl in + if lvl > lvl' then print ")" else () + +and print_constant cst = + match cst with + CONST_INT i -> + print i + | CONST_FLOAT r -> + print r + | CONST_CHAR c -> + print ("'" ^ (escape_string c) ^ "'") + | CONST_STRING s -> + print ("\"" ^ (escape_string s) ^ "\"") + | CONST_COMPOUND exps -> + begin + print "{"; + print_comma_exps exps; + print "}" + end + + +(* +** Statement printing +*) +and print_statement stat = + match stat with + NOP -> + print ";"; + new_line () + | COMPUTATION exp -> + print_expression exp 0; + print ";"; + new_line () + | BLOCK (defs, stat) -> + new_line (); + print "{"; + indent (); + print_defs defs; + if stat <> NOP then print_statement stat else (); + unindent (); + print "}"; + new_line (); + | SEQUENCE (s1, s2) -> + print_statement s1; + print_statement s2; + | IF (exp, s1, s2) -> + print "if("; + print_expression exp 0; + print ")"; + print_substatement s1; + if s2 = NOP + then () + else begin + print "else"; + print_substatement s2; + end + | WHILE (exp, stat) -> + print "while("; + print_expression exp 0; + print ")"; + print_substatement stat + | DOWHILE (exp, stat) -> + print "do"; + print_substatement stat; + print "while("; + print_expression exp 0; + print ");"; + new_line (); + | FOR (exp1, exp2, exp3, stat) -> + print "for("; + print_expression exp1 0; + print ";"; + space (); + print_expression exp2 0; + print ";"; + space (); + print_expression exp3 0; + print ")"; + print_substatement stat + | BREAK -> + print "break;"; new_line () + | CONTINUE -> + print "continue;"; new_line () + | RETURN exp -> + print "return"; + if exp = NOTHING + then () + else begin + print " "; + print_expression exp 1 + end; + print ";"; + new_line () + | SWITCH (exp, stat) -> + print "switch("; + print_expression exp 0; + print ")"; + print_substatement stat + | CASE (exp, stat) -> + unindent (); + print "case "; + print_expression exp 1; + print ":"; + indent (); + print_substatement stat + | DEFAULT stat -> + unindent (); + print "default :"; + indent (); + print_substatement stat + | LABEL (name, stat) -> + print (name ^ ":"); + space (); + print_substatement stat + | GOTO name -> + print ("goto " ^ name ^ ";"); + new_line () + | ASM desc -> + print ("asm(\"" ^ (escape_string desc) ^ "\");") + | GNU_ASM (desc, output, input, mods) -> + print ("asm(" ^ (escape_string desc) ^ "\""); + print " : "; + print_commas false print_gnu_asm_arg output; + print " : "; + print_commas false print_gnu_asm_arg input; + if mods <> [] then begin + print " : "; + print_commas false print mods + end; + print ");" + | STAT_LINE (stat, _, _) -> + print_statement stat + +and print_gnu_asm_arg (id, desc, exp) = + if id <> "" then print ("[" ^ id ^ "]"); + print ("\"" ^ (escape_string desc) ^ "\"("); + print_expression exp 0; + print ("\"") + +and print_substatement stat = + match stat with + IF _ + | SEQUENCE _ + | DOWHILE _ -> + new_line (); + print "{"; + indent (); + print_statement stat; + unindent (); + print "}"; + new_line (); + | BLOCK _ -> + print_statement stat + | _ -> + indent (); + print_statement stat; + unindent () + + +(* +** GCC Attributes +*) +and print_attributes attrs = + match attrs with + [] -> + () + | [GNU_EXTENSION] -> + () + | _ -> + if attrs <> [] then + begin + print " __attribute__ (("; + print_commas false print_attribute attrs; + print ")) " + end + +and print_attribute attr = + match attr with + GNU_NONE -> + () + | GNU_ID id -> + print id + | GNU_CALL (id, args) -> + print id; + print "("; + print_commas false print_attribute args; + print ")" + | GNU_CST cst -> + print_constant cst + | GNU_EXTENSION -> + print "__extension__" + | GNU_INLINE -> + print "__inline__" + | GNU_TYPE_ARG (typ,sto) -> + if sto <> NO_STORAGE then begin + print (get_storage sto); + space () + end; + print_base_type typ + + +(* +** Declaration printing +*) +and print_defs defs = + let prev = ref false in + List.iter + (fun def -> + (match def with + DECDEF _ -> prev := false + | _ -> + if not !prev then force_new_line (); + prev := true); + print_def def) + defs + +and print_def def = + match def with + + FUNDEF (proto, body) -> + print_single_name proto; + let (decs, stat) = body in print_statement (BLOCK (decs, stat)); + force_new_line (); + + | OLDFUNDEF (proto, decs, body) -> + print_single_name proto; + force_new_line (); + List.iter + (fun dec -> print_name_group dec; print ";"; new_line ()) + decs; + let (decs, stat) = body in print_statement (BLOCK (decs, stat)); + force_new_line (); + + | DECDEF names -> + print_name_group names; + print ";"; + new_line () + + | TYPEDEF (names, attrs) -> + if has_extension attrs then begin + print "__extension__"; + space (); + end; + print "typedef "; + print_name_group names; + print ";"; + new_line (); + force_new_line () + + | ONLYTYPEDEF names -> + print_name_group names; + print ";"; + new_line (); + force_new_line () + + +(* print abstrac_syntax -> () + ** Pretty printing the given abstract syntax program. +*) +let print (result : out_channel) (defs : file) = + out := result; + print_defs defs + +let set_tab t = tab := t +let set_width w = width := w