diff options
Diffstat (limited to 'tools/scrapelabels.ml')
| -rw-r--r-- | tools/scrapelabels.ml | 289 |
1 files changed, 0 insertions, 289 deletions
diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml deleted file mode 100644 index 26512e0a05..0000000000 --- a/tools/scrapelabels.ml +++ /dev/null @@ -1,289 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Lexer301 - -let input_buffer = Buffer.create 16383 -let input_function ic buf len = - let len = input ic buf 0 len in - Buffer.add_substring input_buffer buf 0 len; - len - -let output_buffer = Buffer.create 16383 - -let modified = ref false - -let modules = - ref [ "Arg"; "BigArray"; "Buffer"; "Condition"; "Dbm"; "Digest"; "Dynlink"; - "Event"; "Filename"; "Format"; "Gc"; "Genlex"; "Graphics"; - "Lexing"; "Marshal"; "Mutex"; "Parsing"; "Pervasives"; "Queue"; - "Sort"; "Stack"; "Str"; "Stream"; "Sys"; - "Thread"; "ThreadUnix"; "Weak" ] - -let stdlabels = ["Array"; "List"; "String"] -let morelabels = ["Hashtbl"; "Map"; "Set"] -let alllabels = ref false -let noopen = ref false - -exception Closing of token - -let convert_impl buffer = - let input_pos = ref 0 in - let copy_input stop = - Buffer.add_substring output_buffer (Buffer.contents input_buffer) - !input_pos (stop - !input_pos); - input_pos := stop - in - let next_token () = - let token = Lexer301.token buffer - and start = Lexing.lexeme_start buffer - and stop = Lexing.lexeme_end buffer in - match token with - RPAREN | RBRACKET |BARRBRACKET | GREATERRBRACKET | END - | RBRACE | GREATERRBRACE -> - raise (Closing token) - | EOF -> - raise End_of_file - | _ -> - (token, start, stop) - in - let openunix = ref None and openstd = ref None and openmore = ref None in - let rec may_start (token, s, e) = - match token with - LIDENT _ -> search_start (dropext (next_token ())) - | UIDENT m when List.mem m !modules -> - may_discard (dropext (next_token ())) - | UIDENT m -> - List.iter ~f: - (fun (set,r) -> - if !r = None && List.mem m ~set then r := Some true) - [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore]; - search_start (next_token ()) - | _ -> search_start (token, s, e) - - and dropext (token, s, e) = - match token with - DOT -> - let (token, s, e) = next_token () in - begin match token with - LPAREN | LBRACKET | LBRACE -> - process_paren (token, s, e); - dropext (next_token ()) - | UIDENT _ | LIDENT _ -> - dropext (next_token ()) - | _ -> - prerr_endline ("bad index at position " ^ string_of_int s); - (token, s, e) - end - | _ -> - (token, s, e) - - and may_discard (token, s, e) = - match token with - TILDE | LABEL _ -> - modified := true; - copy_input s; input_pos := e; - may_discard (next_token ()) - | _ when !alllabels -> - may_discard (next_token ()) - | LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN - | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT-> - process_paren (token, s, e); - may_discard (next_token ()) - | PREFIXOP _ -> - may_discard (next_token ()) - | LIDENT _ | UIDENT _ -> - may_discard (dropext (next_token ())) - | BACKQUOTE -> - ignore (next_token ()); - may_discard (next_token ()) - | INT _ | CHAR _ | STRING _ | FLOAT _ | FALSE | TRUE -> - may_discard (next_token ()) - | _ -> - search_start (token, s, e) - - and search_start (token, s, e) = - match token with - LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN - | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> - process_paren (token, s, e); - search_start (next_token ()) - | EQUAL | SEMI | SEMISEMI | MINUSGREATER | LESSMINUS | COMMA - | IF | THEN | ELSE | WHILE | TO | DOWNTO | DO | IN | MATCH | TRY - | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ | INFIXOP4 _ - | PLUS | MINUS | MINUSDOT | STAR | LESS | GREATER - | OR | BARBAR | AMPERSAND | AMPERAMPER | COLONEQUAL -> - may_start (next_token ()) - | OPEN -> - begin match next_token () with - | UIDENT m, _, _ -> - List.iter - ~f:(fun (set,r) -> if List.mem m ~set then r := Some false) - [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore] - | _ -> () - end; - search_start (next_token ()) - | _ -> - search_start (next_token ()) - - and process_paren (token, s, e) = - try match token with - LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN -> - may_start (next_token ()) - | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> - search_start (next_token ()) - | _ -> - assert false - with Closing last -> - match token, last with - LPAREN, RPAREN - | (LBRACKET|LBRACKETBAR|LBRACKETLESS), - (RBRACKET|BARRBRACKET|GREATERRBRACKET) - | (BEGIN|STRUCT|SIG|OBJECT), END - | LBRACE, RBRACE - | LBRACELESS, GREATERRBRACE -> () - | _ -> raise (Closing last) - in - let first = next_token () in - try - if !alllabels then may_discard first else may_start first - with End_of_file -> - copy_input (Buffer.length input_buffer); - if not !alllabels - && List.exists (fun r -> !r = Some true) [openstd; openunix; openmore] - then begin - modified := true; - let text = Buffer.contents output_buffer in - Buffer.clear output_buffer; - let (token, s, _) = first in - Buffer.add_substring output_buffer text 0 s; - List.iter ~f: - (fun (r, s) -> - if !r = Some true then Buffer.add_string output_buffer s) - [ openstd, "open StdLabels\n"; openmore, "open MoreLabels\n"; - openunix, "module Unix = UnixLabels\n" ]; - let sep = - if List.mem token [CLASS; EXTERNAL; EXCEPTION; FUNCTOR; LET; - MODULE; FUNCTOR; TYPE; VAL] - then "\n" - else if token = OPEN then "" else ";;\n\n" - in - Buffer.add_string output_buffer sep; - Buffer.add_substring output_buffer text s (String.length text - s) - end - | Closing _ -> - prerr_endline ("bad closing token at position " ^ - string_of_int (Lexing.lexeme_start buffer)); - modified := false - -type state = Out | Enter | In | Escape - -let convert_intf buffer = - let input_pos = ref 0 in - let copy_input stop = - Buffer.add_substring output_buffer (Buffer.contents input_buffer) - !input_pos (stop - !input_pos); - input_pos := stop - in - let last = ref (EOF, 0, 0) in - let state = ref Out in - try while true do - let token = Lexer301.token buffer - and start = Lexing.lexeme_start buffer - and stop = Lexing.lexeme_end buffer - and last_token, last_start, last_stop = !last in - begin match token with - | EXCEPTION | CONSTRAINT -> - state := In - | VAL | EXTERNAL | CLASS | METHOD | TYPE | AND -> - state := Enter - | EQUAL when !state = Enter -> - state := In - | COLON -> - begin match !state, last_token with - | In, LIDENT _ -> - modified := true; - copy_input last_start; - input_pos := stop - | Enter, _ -> - state := In - | Escape, _ -> - state := In - | _ -> - state := Out - end - | LBRACE | SEMI | QUESTION when !state = In -> - state := Escape - | SEMISEMI | SIG | STRUCT | END | OBJECT | OPEN | INCLUDE | MODULE -> - state := Out - | EOF -> raise End_of_file - | _ -> () - end; - last := (token, start, stop) - done with - End_of_file -> - copy_input (Buffer.length input_buffer) - -let convert_file ~intf name = - let ic = open_in name in - Buffer.clear input_buffer; - Buffer.clear output_buffer; - modified := false; - begin - let convert = if intf then convert_intf else convert_impl in - try convert (Lexing.from_function (input_function ic)); close_in ic - with exn -> close_in ic; raise exn - end; - if !modified then begin - let backup = name ^ ".bak" in - if Sys.file_exists backup then Sys.remove name - else Sys.rename name backup; - let oc = open_out name in - Buffer.output_buffer oc output_buffer; - close_out oc - end - else prerr_endline ("No changes in " ^ name) - -let _ = - let files = ref [] and intf = ref false - and keepstd = ref false and keepmore = ref false in - Arg.parse - [ "-intf", Arg.Set intf, - " remove all non-optional labels from an interface;\n" ^ - " other options are ignored"; - "-all", Arg.Set alllabels, - " remove all labels, possibly including optional ones!"; - "-keepstd", Arg.Set keepstd, - " keep labels for Array, List, String and Unix"; - "-keepmore", Arg.Set keepmore, - " keep also labels for Hashtbl, Map and Set; implies -keepstd"; - "-m", Arg.String (fun s -> modules := s :: !modules), - "<module> remove also labels for <module>"; - "-noopen", Arg.Set noopen, - " do not insert `open' statements for -keepstd/-keepmore" ] - (fun s -> files := s :: !files) - ("Usage: scrapelabels <options> <source files>\n" ^ - " Remove labels from function arguments in standard library modules.\n" ^ - " With -intf option below, can also process interfaces.\n" ^ - " Old files are renamed to <file>.bak if there is no backup yet.\n" ^ - "Options are:"); - if !keepmore then keepstd := true; - if not !keepstd then modules := "Unix" :: stdlabels @ !modules; - if not !keepmore then modules := morelabels @ !modules; - List.iter (List.rev !files) ~f: - begin fun name -> - prerr_endline ("Processing " ^ name); - Printexc.catch (convert_file ~intf:!intf) name - end |