Return to printval.sml CVS log

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

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

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: (* printval.sml *)
        !             3: 
        !             4: structure PrintVal: PRINTVAL =
        !             5: struct
        !             6: 
        !             7: structure Basics = Basics
        !             8: 
        !             9: open System System.Unsafe Basics BasicTypes TypesUtil ErrorMsg PrintUtil
        !            10: 
        !            11: fun gettag obj = int (tuple obj sub 1)
        !            12: 
        !            13: exception Switch
        !            14: 
        !            15: fun switch(obj, TYCON{kind=DATAtyc dcons,...}) =
        !            16:     let fun try ((d as DATACON{rep,...})::r) = 
        !            17:            (case rep
        !            18:               of TAGGED i => if (gettag obj = i handle Boxity => false)
        !            19:                              then d else try r
        !            20:                | CONSTANT i => if (int obj = i handle Boxity => false)
        !            21:                                then d else try r
        !            22:                | TRANSPARENT =>
        !            23:                            if ((tuple obj; true) handle Boxity => false)
        !            24:                            then d else (try r handle Switch => d)
        !            25:                | TRANSB => if ((tuple obj; true) handle Boxity => false)
        !            26:                            then d else try r
        !            27:                | TRANSU => if ((int obj; true) handle Boxity => false)
        !            28:                            then d else try r
        !            29:                | REF => d
        !            30:                | _ => ErrorMsg.impossible "PrintVal.switch: funny datacon")
        !            31:          | try nil = raise Switch
        !            32:     in  try dcons
        !            33:        handle Switch => 
        !            34:          ErrorMsg.impossible "PrintVal.switch: none of the datacons matched"
        !            35:     end
        !            36: 
        !            37: fun decon(obj, DATACON{rep,...}) =
        !            38:     case rep
        !            39:      of UNDECIDED => ErrorMsg.impossible "undecided datacon in decon"
        !            40:       | TAGGED _ => tuple obj sub 0
        !            41:       | CONSTANT _ => ErrorMsg.impossible "constant datacon in decon"
        !            42:       | TRANSPARENT => obj
        !            43:       | TRANSU => obj
        !            44:       | TRANSB => obj
        !            45:       | REF => tuple obj sub 0
        !            46:       | VARIABLE _ => tuple obj sub 0
        !            47: 
        !            48: val noparen = INfix(0,0)
        !            49: 
        !            50: fun printVal(obj: object, ty: ty, depth: int) : unit =
        !            51:       printVal'(obj, ty, depth, noparen, noparen)
        !            52: 
        !            53: and printVal'(_,_,0,_,_) = print "#"
        !            54:   | printVal'(obj: object, ty: ty, depth: int, l: fixity, r: fixity) : unit =
        !            55:     case ty
        !            56:       of VARty(ref(INSTANTIATED t)) => printVal'(obj,t,depth,r,l)
        !            57:        | FLEXRECORDty(ref(CLOSED t)) => printVal'(obj,t,depth,r,l)
        !            58:        | CONty(ref(tyc as TYCON{kind,...}), argtys) => (* wrong!? *)
        !            59:           (case kind
        !            60:              of ABStyc =>
        !            61:                   if eqTycon(tyc,!intTycon) then print(makestring(int obj))
        !            62:                   else if eqTycon(tyc,!realTycon) then print(makestring(real obj))
        !            63:                   else if eqTycon(tyc,!stringTycon) then pr_mlstr(string obj)
        !            64:                   else if eqTycon(tyc,!arrowTycon) then print "fn"
        !            65:                   else print "-"
        !            66:                | DEFtyc _ =>
        !            67:                   printVal'(obj, reduceType ty, depth, l, r)
        !            68:               | DATAtyc _ =>
        !            69:                   if eqTycon(tyc,!listTycon)
        !            70:                     then printList(obj, hd argtys, depth)
        !            71:                     else printDcon(obj, tyc, argtys, depth, l, r)
        !            72:               | RECORDtyc [] => print "()"
        !            73:               | RECORDtyc labels =>
        !            74:                   if Tuples.isTUPLEtyc tyc
        !            75:                     then printTuple(tuple(obj), argtys, depth)
        !            76:                     else printRecord(tuple(obj), labels, argtys, depth))
        !            77:        | POLYty{tyfun=TYFUN{body,...},...} => printVal'(obj,body,depth,l,r)
        !            78:        | _ => print "-"
        !            79: 
        !            80: and printDcon(_,_,_,0,_,_) = print "#"
        !            81:   | printDcon(obj:object, tyc as TYCON{arity,...}, argtys,
        !            82:               depth:int, l:fixity, r:fixity) =
        !            83:     let val dcon as DATACON{name,const,typ,...} = switch(obj,tyc)
        !            84:        val dname = Symbol.name name
        !            85:      in if const
        !            86:        then print dname
        !            87:        else
        !            88:          let val fixity = EnvAccess.lookFIX name  (* may be inaccurate *)
        !            89:              val dom = case !typ
        !            90:                         of CONty(_,dom::_) => dom
        !            91:                          | POLYty{tyfun=TYFUN{body=CONty(_,dom::_),...},...} =>
        !            92:                              applyTyfun(TYFUN{arity=arity,body=dom},argtys)
        !            93:              val dom =  headReduceType(dom)
        !            94:              fun prdcon() =
        !            95:                  case (fixity,dom)
        !            96:                   of (INfix _,CONty(ref(domTyc as TYCON{kind=RECORDtyc _,...}),
        !            97:                                    [tyL,tyR])) =>
        !            98:                        let val twoTuple = tuple(decon(obj,dcon))
        !            99:                         in if Tuples.isTUPLEtyc domTyc
        !           100:                            then (
        !           101:                              printVal'(twoTuple sub 0,tyL,depth-1,NONfix,fixity);
        !           102:                              print " "; print dname; print " ";
        !           103:                              printVal'(twoTuple sub 1,tyR,depth-1,fixity,NONfix))
        !           104:                            else (
        !           105:                              print dname; print " ";
        !           106:                              printVal'(decon(obj,dcon),dom,depth-1,NONfix,NONfix))
        !           107:                        end
        !           108:                    | _ =>
        !           109:                       (print dname; print " ";
        !           110:                        printVal'(decon(obj,dcon),dom,depth-1,NONfix,NONfix))
        !           111:              fun prpardcon() = (print "("; prdcon(); print ")")
        !           112:           in case(l,r,fixity)
        !           113:              of (NONfix,NONfix,_) => prpardcon()
        !           114:               | (INfix _,INfix _,_) => prdcon()
        !           115:                  (* special case: only on first iteration, for no parens *)
        !           116:               | (_,_,NONfix) => prdcon()
        !           117:               | (INfix(_,p1),_,INfix(p2,_)) =>
        !           118:                   if p1 >= p2 then prpardcon()
        !           119:                   else prdcon()
        !           120:               | (_,INfix(p1,_),INfix(_,p2)) =>
        !           121:                   if p1 > p2 then prpardcon()
        !           122:                   else prdcon()
        !           123:          end
        !           124:     end
        !           125: 
        !           126: and printList(obj:object, ty:ty, depth:int) : unit =
        !           127:     let fun printTail(separator, p) =
        !           128:             let val dcon as DATACON{name,...} = switch(p, !listTycon)
        !           129:             in case (Symbol.name name)
        !           130:                  of "nil" => print "]"
        !           131:                   | "::" => 
        !           132:                       let val pair = tuple(decon(p, dcon))
        !           133:                        in print separator;
        !           134:                           printVal(pair sub 0, ty, depth-1);
        !           135:                           printTail (",", pair sub 1)
        !           136:                       end
        !           137:             end
        !           138:      in print "["; printTail("",obj)
        !           139:     end
        !           140: 
        !           141: and printTuple(objs: object array, tys: ty list, depth:int) : unit =
        !           142:     let fun printFields(nf,[ty]) = printVal(objs sub nf,ty,depth-1)
        !           143:          | printFields(nf, ty::restty) = 
        !           144:              (printVal(objs sub nf,ty,depth-1); print(",");
        !           145:               printFields(nf+1,restty))
        !           146:          | printFields(nf,[]) = ()
        !           147:      in print("("); printFields(0,tys); print(")")
        !           148:     end
        !           149: 
        !           150: and printRecord(objs: object array, labels: label list, tys: ty list, depth:int) =
        !           151:     let fun printFields(nf,[l],[ty]) = 
        !           152:              (print(Symbol.name l); print("="); printVal(objs sub nf,ty,depth-1))
        !           153:          | printFields(nf, l::restl, ty::restty) = 
        !           154:              (print(Symbol.name l); print("="); printVal(objs sub nf,ty,depth-1);
        !           155:               print(","); printFields(nf+1,restl,restty))
        !           156:          | printFields(nf,[],[]) = ()
        !           157:      in print("{"); printFields(0,labels,tys); print("}")
        !           158:     end
        !           159: 
        !           160: end (* structure PrintVal *)

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