1(* Parsspec -- parse Moscow ML signature files. 2 3*) 4 5open BasicIO List 6 7(* Lexer of stream *) 8 9fun createLexerStream (is : instream) = 10 Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n) 11; 12 13fun parsePhraseAndClear parsingFun lexingFun lexbuf = 14 let val phr = 15 parsingFun lexingFun lexbuf 16 handle x => (Parsing.clearParser(); raise x) 17 in 18 Parsing.clearParser(); 19 phr 20 end; 21 22val parseSpec = 23 parsePhraseAndClear Parser.SigFile Lexer.Token; 24 25fun processSpec is str ((Location.Loc(pos1, pos2), spec), res) = 26 let fun getline line pos = 27 if pos < pos1 then 28 case Nonstdio.input_char is of 29 #"\^Z" => raise Fail "Parsspec.processSpec: internal error" 30 | #"\n" => getline (line+1) (pos+1) 31 | _ => getline line (pos+1) 32 else line 33 val lineno = (Nonstdio.seek_in is 0; getline 0 0) 34 open Asynt Database 35 fun getId ({qualid = {id, ...}, ...} : IdInfo) = hd id 36 fun valdesc ((idInfo, ty), res) = 37 {comp = Val (getId idInfo), file = str, line = lineno} :: res 38 fun pvaldesc ((idInfo, ty, arity, cfun), res) = 39 {comp = Val (getId idInfo), file = str, line = lineno} :: res 40 fun typdesc ((tyvars, idInfo), res) = 41 {comp = Typ (getId idInfo), file = str, line = lineno} :: res 42 fun typbind ((tyvars, idInfo, ty), res) = 43 {comp = Typ (getId idInfo), file = str, line = lineno} :: res 44 fun conbind ((ConBind(idInfo, tyOpt)), res) = 45 {comp = Con (getId idInfo), file = str, line = lineno} :: res 46 fun datbind ((tyvars, idInfo, cbs), res) = 47 {comp = Typ (getId idInfo), file = str, line = lineno} 48 :: foldl conbind res cbs 49 fun datrep (idInfo, res) = 50 {comp = Typ (getId idInfo), file = str, line = lineno} :: res 51 fun exdesc ((idInfo, tyOpt), res) = 52 {comp = Exc (getId idInfo), file = str, line = lineno} :: res 53 in 54 case spec of 55 VALspec vs => foldl valdesc res vs 56 | PRIM_VALspec pvs => foldl pvaldesc res pvs 57 | TYPEDESCspec (tnEqu, tyds) => foldl typdesc res tyds 58 | TYPEspec tybs => foldl typbind res tybs 59 | DATATYPEspec (dbs, tybsOpt) => 60 foldl datbind (foldl typbind res (getOpt(tybsOpt, []))) dbs 61 | DATATYPErepspec (ty, _) => datrep (ty, res) 62 | EXCEPTIONspec eds => foldl exdesc res eds 63 | LOCALspec (spec1, spec2) => processSpec is str (spec2, res) 64 | OPENspec strs => res 65 | EMPTYspec => res 66 | SEQspec (spec1, spec2) => 67 processSpec is str (spec2, processSpec is str (spec1, res)) 68 | STRUCTUREspec moddescs => res (* TODO: add link *) 69 end 70 71fun parseAndProcess dir str res = 72 let val filename = Path.joinDirFile 73 {dir=dir, file = Path.joinBaseExt{base = str, ext = SOME "sig"}} 74 val _ = print("Parsing " ^ filename ^ " ... "); 75 val resLength = length res 76 val is = open_in filename 77 val lexbuf = createLexerStream is 78 val specs = case parseSpec lexbuf of 79 Asynt.NamedSig {specs, ...} => specs 80 | Asynt.AnonSig specs => specs; 81 val initialbase = {comp = Database.Str, file = str, line = 0} :: res 82 val res = foldl (processSpec is str) initialbase specs 83 val _ = print ("processed " ^ Int.toString (length res - resLength) 84 ^ " entries.\n") 85 in 86 close_in is; res 87 end 88 handle exn as Parsing.ParseError _ => 89 (print ("Parseerror in signature " ^ str ^ ".\n"); raise exn) 90 91(* To parse the signature of unit `filename' and prepend the 92 * entries to the list res: 93 *) 94 95fun processfile stoplist dir (filename, res) = 96 let val {base, ext} = Path.splitBaseExt filename 97 in 98 case ext of 99 SOME "sig" => 100 if List.exists (fn name => base = name) stoplist then 101 res 102 else 103 parseAndProcess dir base res 104 | _ => res 105 end 106