Return to process.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / build

Annotation of researchv10no/cmd/sml/src/build/process.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: signature PROCESSFILE =
        !             3: sig
        !             4:   exception Stop
        !             5:   val dumpMap : unit -> unit
        !             6:   val prLambda : unit -> unit
        !             7:   val prFun : int -> unit
        !             8:   val printslots : string -> unit
        !             9:   val timemsg : string -> bool
        !            10:   val process : string * (Lambda.lexp * string -> unit) option -> unit
        !            11:   val load : string -> unit
        !            12:   val reset : unit -> unit
        !            13:   val primeEnv : unit -> unit
        !            14:   val getCore : unit -> int list
        !            15:   val bootEnv : (string -> unit) -> int * int * int
        !            16: end
        !            17: 
        !            18: structure ProcessFile : PROCESSFILE =
        !            19: struct
        !            20: 
        !            21:   open Access Basics PrintUtil EnvAccess
        !            22: 
        !            23:   exception Stop
        !            24: 
        !            25:   fun timemsg (s : string) =
        !            26:     if !System.Control.timings then (print s; newline(); true) else false
        !            27: 
        !            28:   val saveLambda = System.Control.saveLambda
        !            29:   val lambda = ref (Lambda.RECORD [])
        !            30:   (* really needed only for interactive version *)
        !            31:   val _ = System.Control.prLambda := fn () => (MCprint.printLexp (!lambda); newline())
        !            32:   fun prLambda() = (MCprint.printLexp(!lambda); newline())
        !            33:   fun prFun lv = (MCprint.printFun(!lambda) lv; newline())
        !            34: 
        !            35: 
        !            36:  (* debugging aid--print the slots of a structure
        !            37:     -- this belongs somewhere else *)
        !            38: 
        !            39:   fun printslot {name,access=SLOT s} =
        !            40:          (print "Slot "; print s; print " : ";
        !            41:           print(Symbol.name name);
        !            42:           print "\n")
        !            43:     | printslot {name,access=LVAR s} =
        !            44:          (print "Lvar "; print s; print " : ";
        !            45:           print(Symbol.name name);
        !            46:           print "\n")
        !            47:     | printslot {name,access=INLINE s} =
        !            48:          (print "Inline "; print(Prim.inLineName s); print " : ";
        !            49:           print(Symbol.name name);
        !            50:           print "\n")
        !            51:     | printslot {name,access=PATH _} =
        !            52:          (print "Path?? :";
        !            53:           print(Symbol.name name);
        !            54:           print "\n")
        !            55: 
        !            56:   val usl : {name:Symbol.symbol,access:access} list ref = ref nil
        !            57: 
        !            58:   fun buildlist (_,_,VARbind(VALvar{name=[n],access,...})) =
        !            59:                  usl := {name=n,access=access} :: !usl
        !            60:     | buildlist (_,_,STRbind(STRvar{name=[n],access,...})) =
        !            61:                  usl := {name=n,access=access} :: !usl
        !            62:     | buildlist (_,_,CONbind(DATACON{name,rep=(VARIABLE access),...})) =
        !            63:                  usl := {name=name,access=access} :: !usl
        !            64:     | buildlist _ = ()
        !            65: 
        !            66:   fun slotgt ({access=SLOT s1,name},{access=SLOT s2,name=_}) = s1 > s2
        !            67:     | slotgt ({access=SLOT _,...},_) = true
        !            68:     | slotgt ({access=LVAR v1,...},{access=LVAR v2,...}) = v1 > v2
        !            69:     | slotgt ({access=LVAR _,...},_) = true
        !            70:     | slotgt ({access=INLINE i1,...},{access=INLINE i2,...}) =
        !            71:         ErrorMsg.impossible "why do you sort slots" (* i1 > i2 *)
        !            72:     | slotgt ({access=INLINE _,...},_) = true
        !            73:     | slotgt _ = ErrorMsg.impossible "Path access in printslots"
        !            74: 
        !            75:   fun symPath s =
        !            76:     let fun f nil = (nil,nil)
        !            77:          | f ("."::m) =
        !            78:                  let val (s,syms) = f m
        !            79:                  in  (nil,Symbol.symbol(implode s)::syms)
        !            80:                  end
        !            81:          | f (a::m) =
        !            82:                  let val (s,syms) = f m
        !            83:                  in  (a::s,syms)
        !            84:                  end
        !            85:         val (s,syms) = f(explode s)
        !            86:     in  Symbol.symbol(implode s)::syms
        !            87:     end
        !            88: 
        !            89:   fun qid symlist =
        !            90:     let fun getStr([],str) = str
        !            91:          | getStr(id::rest,STRstr{table,env,...}) =
        !            92:              let val STRvar{access=SLOT n,binding,...} = 
        !            93:                      lookSTRinTable(table,id)
        !            94:                      handle Env.UnboundTable =>
        !            95:                      (print ("unbound intermediate structure in path: "
        !            96:                                ^ Symbol.name id ^ "\n"); raise Stop)
        !            97:                  val str = case (binding,env)
        !            98:                             of (INDstr i,REL{s,...}) => s sub i
        !            99:                              | (SHRstr(i::r),REL{s,...}) =>
        !           100:                                   TypesUtil.getEpath(r,s sub i)
        !           101:                              | (STRstr _, _) => binding
        !           102:                              | _ => ErrorMsg.impossible "Process.qid.getStr"
        !           103:               in getStr(rest,str)
        !           104:              end
        !           105:        val firstId::rest = symPath symlist
        !           106:        val STRvar{binding,...} = lookSTR firstId
        !           107:              handle Unbound => (print("unbound structure at head of path: "
        !           108:                                        ^ Symbol.name firstId ^ "\n"); raise Stop)
        !           109:     in  getStr(rest,binding)
        !           110:     end
        !           111: 
        !           112:   fun printslots s =
        !           113:       let val STRstr{table,...} = qid s
        !           114:          val unsortedlist = (usl := nil; IntStrMap.app buildlist table; !usl)
        !           115:          val sortedlist = Sort.sort slotgt unsortedlist
        !           116:       in  print "module "; print s; print "\n";
        !           117:          app printslot sortedlist
        !           118:       end
        !           119:       handle Bind => ErrorMsg.impossible "Weird structure in printslots"
        !           120: 
        !           121: 
        !           122:   open ErrorMsg BareAbsyn Lambda System.Timer
        !           123: 
        !           124:   fun for l f = app f l
        !           125:   val update = System.Stats.update
        !           126:   val printDepth = System.Control.Print.printDepth
        !           127: 
        !           128:   fun opt lam =
        !           129:       let val timer = start_timer()
        !           130:          val lam = if !CGoptions.reduce then Opt.reduce lam else lam
        !           131:          val _ = if !anyErrors then raise Stop else ()
        !           132:          val lam = if !CGoptions.hoist then Opt.hoist lam else lam
        !           133:          val time = check_timer timer
        !           134:       in  update(System.Stats.codeopt,time);
        !           135:          timemsg("codeopt, " ^ makestring time ^ "s")
        !           136:                orelse debugmsg "codeopt";
        !           137:          if !anyErrors then raise Stop else ();
        !           138:          lam
        !           139:       end
        !           140: 
        !           141:   fun parse (lex: Lex.lexer) =
        !           142:       let val ref linenum = ErrorMsg.lineNum
        !           143:          val timer = start_timer()
        !           144:          val _ = debugmsg "about to parse"
        !           145:           val _ = while !(#nextToken lex) = Token.SEMICOLON 
        !           146:                            do (#advance lex)();
        !           147:          val absyn = (anyErrors := false; Parse.interdec lex)
        !           148:          val time = check_timer timer
        !           149:          val lines = !ErrorMsg.lineNum - linenum
        !           150:        in update(System.Stats.parse,time);
        !           151:          System.Stats.lines := !System.Stats.lines + lines;
        !           152:          timemsg("parse, " ^ Integer.makestring lines
        !           153:                        ^ " lines, " ^ makestring time ^ "s")
        !           154:                orelse debugmsg "parse completed";
        !           155:          if !anyErrors then raise Stop else ();
        !           156:          absyn
        !           157:       end
        !           158: 
        !           159:   fun transStrb sb =
        !           160:       let val timer = start_timer()
        !           161:          val (sb,profil) = Prof.instrumStrb sb
        !           162:          val Absyn.STRB{strvar=STRvar{access=LVAR v,...},...} = sb
        !           163:           val lam = Translate.transDec (Absyn.STRdec[sb]) (Lambda.VAR v)
        !           164:          val lam = Prof.bindLambda(lam,profil)
        !           165:          val time = check_timer timer
        !           166:        in update(System.Stats.translate,time);
        !           167:          timemsg("translate, " ^ makestring time ^ "s")
        !           168:                orelse debugmsg "translate";
        !           169:          if !anyErrors then raise Stop else ();
        !           170:          lam
        !           171:       end
        !           172: 
        !           173:   fun transFctb fb =
        !           174:       let val timer = start_timer()
        !           175:          val (fb,profil) = Prof.instrumFctb fb
        !           176:          val Absyn.FCTB{fctvar=FCTvar{access=LVAR v,...},...} = fb
        !           177:           val lam = Translate.transDec (Absyn.FCTdec[fb]) (Lambda.VAR v)
        !           178:          val lam = Prof.bindLambda(lam,profil)
        !           179:          val time = check_timer timer
        !           180:        in update(System.Stats.translate,time);
        !           181:          timemsg("translate, " ^ makestring time ^ "s")
        !           182:                orelse debugmsg "translate";
        !           183:          if !anyErrors then raise Stop else ();
        !           184:          lam
        !           185:       end
        !           186: 
        !           187:   (* lvar -> string environment used by batch compiler to map module
        !           188:      lvars to names of modules *)
        !           189:   exception Modname
        !           190:   val m : string Intmap.intmap = Intmap.new(32, Modname)
        !           191:   val lookup = Intmap.map m
        !           192:   val enterName = Intmap.add m
        !           193:   fun lookupName v =
        !           194:       lookup v 
        !           195:       handle Modname => 
        !           196:        let val s = Access.lvarName v
        !           197:         in ErrorMsg.complain ("Bad free variable: " ^ Access.lvarName v);
        !           198:            s
        !           199:        end
        !           200:   fun dumpMap() =
        !           201:       let fun p(i:int,s:string) = (print i; print " -> "; print s; print "\n")
        !           202:       in  print "lvar -> structure mapping:\n"; Intmap.app p m
        !           203:       end
        !           204: 
        !           205:   val is_core = ref false;
        !           206: 
        !           207:   fun getCore () = if !is_core then [] else tl(!CoreInfo.stringequalPath)
        !           208: 
        !           209:   fun process(fname, gencode) =
        !           210:       let val stream = open_in fname
        !           211:          val lex = Lex.mkLex{stream=stream, interactive=false}
        !           212:           val _ = (ErrorMsg.fileName := fname; ErrorMsg.lineNum := 1;
        !           213:                   System.interactive := false)
        !           214:          val _ = Env.commit()
        !           215:          fun cleanup() = (print("[closing " ^ fname ^ "]\n");
        !           216:                           close_in stream)
        !           217:          fun proc(name,lvar,mkLam) =
        !           218:              (enterName(lvar, name);
        !           219:               case gencode of
        !           220:                 NONE => ()
        !           221:               | SOME gencode =>
        !           222:                 let val lam = Opt.closestr(lookupName,opt(mkLam()), getCore())
        !           223:                 in debugmsg "closed";
        !           224:                    if !saveLambda then lambda := lam else ();
        !           225:                    gencode(lam, name);
        !           226:                    if !anyErrors then raise Stop else ()
        !           227:                 end)
        !           228:          fun loop() =
        !           229:            let val absyn = parse lex
        !           230:            in  case absyn
        !           231:                  of SIGdec _ =>
        !           232:                        (PrintAbsyn.printDec(absyn,0,!printDepth);
        !           233:                         newline())
        !           234:                   | OPENdec _ =>
        !           235:                        (PrintAbsyn.printDec(absyn,0,!printDepth);
        !           236:                         newline())
        !           237:                   | STRdec sbs =>
        !           238:                        for sbs
        !           239:                          (fn sb as
        !           240:                              STRB{strvar=STRvar{name=[n],access=LVAR v,...},...} =>
        !           241:                             (print "structure "; printSym n; newline();
        !           242:                              let val mkLam = fn () => transStrb sb
        !           243:                              in  proc(Symbol.name n, v, mkLam)
        !           244:                              end))
        !           245:                   | ABSdec sbs =>
        !           246:                        for sbs
        !           247:                          (fn sb as
        !           248:                              STRB{strvar=STRvar{name=[n],access=LVAR v,...},...} =>
        !           249:                             (print "abstraction "; printSym n; newline();
        !           250:                              let val mkLam = fn () => transStrb sb
        !           251:                              in  proc(Symbol.name n, v, mkLam)
        !           252:                              end))
        !           253:                   | FCTdec fbs =>
        !           254:                        for fbs
        !           255:                          (fn fb as
        !           256:                              FCTB{fctvar=FCTvar{name,access=LVAR v,...},...} =>
        !           257:                             (print "functor "; printSym name; newline();
        !           258:                              let val mkLam = fn () => transFctb fb
        !           259:                              in  proc(Symbol.name name, v, mkLam)
        !           260:                              end))
        !           261:                    | _ => ErrorMsg.condemn "signature, functor, or structure expected";
        !           262:                loop()
        !           263:            end
        !           264:       in  loop() 
        !           265:            handle Parse.Eof =>
        !           266:                     (cleanup();
        !           267:                      if !anyErrors
        !           268:                      then (Env.restore(); raise Stop)
        !           269:                      else Env.consolidate())
        !           270:                 | e => (Env.restore(); cleanup(); raise e)
        !           271:       end
        !           272: 
        !           273:   fun load fname = process(fname,NONE)
        !           274: 
        !           275:  (* initializing static environment *)
        !           276: 
        !           277:  (* priming structures: PrimTypes and InLine *)
        !           278:   val nameofPT = Symbol.symbol "PrimTypes"
        !           279:   val varofPT = STRvar{name=[nameofPT],access=LVAR 0,binding=Prim.primTypes}
        !           280:   val varofPT' = STRvar{name=[nameofPT],access=PATH[0],binding=Prim.primTypes}
        !           281:   val nameofIL = Symbol.symbol "InLine"
        !           282:   val varofIL = STRvar{name=[nameofIL],access=LVAR 0,binding=Prim.inLine}
        !           283: 
        !           284:   fun reset() =
        !           285:       (Env.reset();
        !           286:        EnvAccess.reset();
        !           287:        Typecheck.reset())
        !           288: 
        !           289:   fun primeEnv() =
        !           290:       (reset();
        !           291:        openStructureVar varofPT';
        !           292:        bindSTR(nameofPT,varofPT);
        !           293:        bindSTR(nameofIL,varofIL);
        !           294:        ())
        !           295: 
        !           296:   fun bootEnv (loader:string -> unit) =
        !           297:       (primeEnv();
        !           298:        load "boot/assembly.sig";
        !           299:        is_core := true;
        !           300:        (loader "boot/core.sml" handle e => (is_core := false; raise e));
        !           301:        is_core := false;
        !           302:        load "boot/dummy.sml";
        !           303:        let val svCore as STRvar{access=PATH[lvCore],...} =
        !           304:                 lookSTR (Symbol.symbol "Core")
        !           305:         in CoreInfo.setCore(svCore);
        !           306:           load "boot/perv.sig";
        !           307:           load "boot/system.sig";
        !           308:           loader "boot/math.sml";
        !           309:           loader "boot/perv.sml";
        !           310:           load "boot/overloads.sml";
        !           311:           let val STRvar{access=PATH[lvMath],...} =
        !           312:                     lookSTR (Symbol.symbol "Math")
        !           313:               and svInitial as STRvar{access=PATH[lvInitial],
        !           314:                                       binding=strInitial as STRstr{table,...},...} =
        !           315:                     lookSTR (Symbol.symbol "Initial")
        !           316:               and STRvar{binding=STRstr{table=otable,...},...} =
        !           317:                     lookSTR (Symbol.symbol "Overloads")
        !           318:               val sigs = map (fn s => lookSIG(Symbol.symbol s))
        !           319:                              ["REF","LIST","ARRAY","BYTEARRAY","BASICIO",
        !           320:                               "IO","BOOL","STRING","INTEGER","REAL","GENERAL"]
        !           321:               val NJsymbol = Symbol.symbol "NewJersey"
        !           322:            in Env.reset();
        !           323:                (* merge overload bindings into Initial's symtable *)
        !           324:               IntStrMap.app (IntStrMap.add table) otable;
        !           325:               openStructureVar(svInitial);
        !           326:               app (fn (sgn as SIGvar{name,...}) => bindSIG(name,sgn))
        !           327:                   sigs;
        !           328:               bindSTR(NJsymbol, STRvar{name=[NJsymbol],access=LVAR(lvInitial),
        !           329:                                        binding=strInitial});
        !           330:               (lvCore,lvInitial,lvMath)
        !           331:           end
        !           332:        end)
        !           333: 
        !           334: end (* structure ProcessFile *)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.