Return to printdec.sml CVS log

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

Annotation of researchv10no/cmd/sml/src/print/printdec.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: (* printdec.sml *)
        !             3: 
        !             4: structure PrintDec : PRINTDEC =
        !             5: struct
        !             6: 
        !             7: structure BareAbsyn = BareAbsyn
        !             8: type object = System.Unsafe.object
        !             9: 
        !            10: open Basics BareAbsyn PrintUtil PrintBasics PrintType PrintVal Access
        !            11: 
        !            12: val printDepth = System.Control.Print.printDepth
        !            13: 
        !            14: val sortBinders = Sort.sort BuildMod.binderGt
        !            15: 
        !            16: fun printFormals 0 = ()
        !            17:   | printFormals 1 = (print "'a "; print " ")
        !            18:   | printFormals n = (printTuple (fn s => (print "'"; print s)) (typeFormals n);
        !            19:                      print " ")
        !            20: 
        !            21: local
        !            22:        fun printVb lookup  (VB{pat,...}) =
        !            23:            let fun printBind(pat) =
        !            24:                    case pat
        !            25:                      of VARpat(VALvar{name=[n],access=LVAR lv,typ=ref ty}) => 
        !            26:                           (print "val "; printSym n; print " = ";
        !            27:                            printVal(lookup lv, ty, !printDepth);
        !            28:                            print " : "; printType ty;
        !            29:                            newline())
        !            30:                       | RECORDpat{pats=ref pl,...} => app printBind pl
        !            31:                       | APPpat(_,pat) => printBind pat
        !            32:                       | CONSTRAINTpat(pat,_) => printBind pat
        !            33:                       | LAYEREDpat(pat1,pat2) => (printBind pat1; printBind pat2)
        !            34:                       | _ => ()
        !            35:             in printBind pat
        !            36:            end
        !            37: 
        !            38:        and printRvb lookup (RVB{var=VALvar{name=[n],access=LVAR lv,typ=ref ty},...}) = 
        !            39:            (print "val "; printSym n; print " = ";
        !            40:             printVal(lookup lv, ty, !printDepth);
        !            41:             print " : "; printType ty; newline())
        !            42: 
        !            43:        and printTb(TB{tyc=ref(TYCON{path=name::_, arity, ...}),def}) =
        !            44:            (print "type "; 
        !            45:             printFormals arity; print " ";
        !            46:             printSym name; print " = "; printType def; newline())
        !            47: 
        !            48:        and printAbsTyc(ref(TYCON{path=name::_, arity, eq, kind=ABStyc, ...})) =
        !            49:            (print(if (!eq=YES) then "eqtype" else "type"); 
        !            50:             printFormals arity; print " ";
        !            51:             printSym name; newline())
        !            52: 
        !            53:        and printDataTyc(ref(TYCON{path=name::_,arity,kind=DATAtyc dcons,...})) =
        !            54:            (print "datatype ";
        !            55:             printFormals arity; print " ";
        !            56:             printSym name; newline();
        !            57:             app (fn DATACON{name,typ,...} => 
        !            58:                     (print "con "; printSym name; print " : ";
        !            59:                      printType(!typ); newline()))
        !            60:                 dcons)
        !            61: 
        !            62:        and printEb(EBgen{exn=DATACON{name,...},etype}) =
        !            63:              (print "exception "; printSym name;
        !            64:               case etype
        !            65:                 of NONE => ()
        !            66:                  | SOME ty' => 
        !            67:                      if BasicTypes.isArrowType ty'
        !            68:                      then (print " of "; printType(BasicTypes.domain ty'))
        !            69:                      else ();
        !            70:               newline())
        !            71:          | printEb(EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =
        !            72:              (print "exception "; printSym name; print " = "; printSym dname;
        !            73:               newline())
        !            74: 
        !            75:        and printSigVar(SIGvar{name,binding}) =
        !            76:            (print "signature "; printSym name;
        !            77:             if !System.Control.Print.signatures
        !            78:             then (print " =\n  sig"; printStr binding; print "\n  end\n")
        !            79:             else newline())
        !            80: 
        !            81:        and printStrVar(STRvar{name,binding,...}) =
        !            82:            (print "structure "; print(formatQid name);
        !            83:             if !System.Control.Print.signatures
        !            84:             then (print " :\n  sig"; printStr binding; print "\n  end\n")
        !            85:             else newline())
        !            86: 
        !            87:        and printStr(str as STRstr{table,env,kind,...}) =
        !            88:            let val tInC = case kind
        !            89:                            of STRkind _ => (fn t => TypesUtil.typeInContext(t,env))
        !            90:                             | SIGkind _ =>  TypesUtil.printableType str
        !            91:                fun printBinder(VARbind(VALvar{name=[n],typ,...})) = 
        !            92:                     (nlindent 4; print "val ";
        !            93:                      printSym n; print " : ";
        !            94:                      printType(tInC(!typ)))
        !            95:                  | printBinder(CONbind(DATACON{name,typ,rep=VARIABLE _,...})) = 
        !            96:                     (nlindent 4; print "exception "; printSym name;
        !            97:                      if BasicTypes.isUnitTy(!typ)
        !            98:                      then ()
        !            99:                      else (print " of "; printType(tInC(!typ))))
        !           100:                  | printBinder(TYCbind(ref(tyc))) = 
        !           101:                      let val TYCON{path=name::_,kind,arity,eq,...} =
        !           102:                              TypesUtil.tyconInContext env tyc
        !           103:                       in nlindent 4;
        !           104:                          case kind
        !           105:                            of DATAtyc dcons =>
        !           106:                                 (print "datatype ";
        !           107:                                  printFormals arity;
        !           108:                                  printSym name; nlindent(6); print "con ";
        !           109:                                  printvseq (6) "con "
        !           110:                                      (fn DATACON{name,typ,...} => 
        !           111:                                          (printSym name; print " : ";
        !           112:                                           printType(tInC(!typ))))
        !           113:                                      dcons)
        !           114:                             | _ =>
        !           115:                                 (if (!eq=YES)
        !           116:                                  then print "eqtype "
        !           117:                                  else print "type ";
        !           118:                                  printFormals arity;
        !           119:                                  printSym(name))
        !           120:                      end
        !           121:                  | printBinder(STRbind(STRvar{name=[n],binding,...})) = 
        !           122:                      (nlindent 4; print "structure ";
        !           123:                       printSym n; print " : sig...end")
        !           124:                  | printBinder(FIXbind(FIXvar{name,binding=INfix(l,r)})) =
        !           125:                      (nlindent 4;
        !           126:                       print "infix "; print l; print " "; print r; print " ";
        !           127:                       printSym name)
        !           128:                  | printBinder _ = ()
        !           129:                val bindlist = ref nil
        !           130:                val _ = IntStrMap.app (fn x => bindlist := x ::(!bindlist)) table
        !           131:                val binders = sortBinders(!bindlist)
        !           132:                val e = Env.current()
        !           133:             in Env.openOld({path=nil,strenv=env},table); (* affects printType *)
        !           134:                app (fn (_,_,b) => printBinder b) binders;
        !           135:                Env.resetEnv e
        !           136:            end
        !           137: 
        !           138:        and printStrb(STRB{strvar,...}) =
        !           139:            printStrVar strvar
        !           140: 
        !           141:        and printFctb(FCTB{fctvar,...}) = 
        !           142:            printFunctorVar fctvar
        !           143: 
        !           144:         and printFunctorVar(FCTvar{name,...}) =
        !           145:            (print "functor "; printSym name; print " : <sig>\n")
        !           146: 
        !           147:        (* not used, because of special top-level open *)
        !           148:        and printOpen(strvl) =  
        !           149:            (print "open ";
        !           150:             printSequence " " (fn STRvar{name,...} => print(formatQid name)) strvl;
        !           151:             newline())
        !           152: 
        !           153:         and printBinding(b: Basics.binding): unit=
        !           154:             case b of
        !           155:              FCTbind(functorVar)=> printFunctorVar functorVar
        !           156:            | SIGbind(signatureVar)=> printSigVar signatureVar
        !           157:            | _ => print "<other binding>\n"
        !           158: 
        !           159: in (* local *)
        !           160: 
        !           161: fun printDec lookup  dec =
        !           162:   let val printDec0 = printDec lookup
        !           163:   in
        !           164:        case (resetPrintType(); dec)
        !           165:          of VALdec vbs => app (printVb lookup) vbs
        !           166:           | VALRECdec rvbs => app (printRvb lookup) rvbs
        !           167:           | TYPEdec tbs => app printTb tbs
        !           168:           | DATATYPEdec{datatycs,withtycs} =>
        !           169:               (app printDataTyc datatycs; app printTb withtycs)
        !           170:           | ABSTYPEdec{abstycs,withtycs,body} =>
        !           171:               (app printAbsTyc abstycs;
        !           172:                app printTb withtycs;
        !           173:                printDec0 body)
        !           174:           | EXCEPTIONdec ebs => app printEb ebs
        !           175:           | STRdec strbs => app printStrb strbs
        !           176:           | FCTdec fctbs => app printFctb fctbs
        !           177:           | SIGdec sigvars => app printSigVar sigvars
        !           178:           | LOCALdec(decIn,decOut) => printDec0 decOut
        !           179:           | SEQdec decs => app printDec0 decs
        !           180:           | OPENdec strvs => printOpen strvs
        !           181:           | IMPORTdec _ => ErrorMsg.impossible "printDec(IMPORT)"
        !           182:           | MARKdec(dec,a,b) => printDec0 dec
        !           183:   end (* fun printDec *)
        !           184: 
        !           185: fun printBindingTbl(tbl: Basics.symtable)=
        !           186:    (let val _ = resetPrintType(); 
        !           187:        val bindlist = ref []
        !           188:        val _ = IntStrMap.app (fn x => bindlist:= x :: (!bindlist)) tbl
        !           189:        val binders = sortBinders (!bindlist)
        !           190:      in app printBinding (map (fn(i,s,b)=> b) binders)
        !           191:     end)
        !           192: end (* local *)
        !           193: 
        !           194: end  (* structure PrintDec *)

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