home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / basics / conrep.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  1.9 KB  |  61 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (* conrep.sml *)
  3.  
  4. structure ConRep : CONREP =
  5. struct
  6. open Access Types
  7.  
  8. fun count predicate l
  9.   = let fun test (a::rest,acc) = test (rest,if predicate a then 1+acc else acc)
  10.       | test (nil,acc) = acc
  11.      in test (l,0)
  12.     end
  13.  
  14. fun reduce ty =
  15.   case TypesUtil.headReduceType ty
  16.    of POLYty{tyfun=TYFUN{body,...},...} => reduce body
  17.     | ty => ty
  18.  
  19. fun notconst(_,true,_) = false
  20.   | notconst(_,_,CONty(_,[t,_])) = 
  21.         (case (reduce t) of CONty(RECORDtyc nil,_) => false
  22.                           | _ => true)
  23.   | notconst _ = true
  24.  
  25. (*fun show((sym,_,_)::syms, r::rs) = 
  26.   (print(Symbol.name sym); print ":   "; PPBasics.ppRep r; 
  27.    print "\n"; show(syms,rs))
  28.   | show _ = (print "\n")
  29. *)
  30.  
  31. fun boxed ([(_,false,_)]: (Symbol.symbol*bool*ty) list): conrep list = [TRANSPARENT]
  32.   | boxed cons =
  33.       let val multiple = count notconst cons > 1
  34.       fun decide (const_tags,nonconst_tags,(_,true,_)::rest) = 
  35.             CONSTANT const_tags :: 
  36.                     decide(const_tags+1,nonconst_tags,rest)
  37.         | decide (const_tags,nonconst_tags,(_,false,CONty(_,[ty,_]))::rest) =
  38.           (case (reduce ty, multiple)
  39.             of (CONty(RECORDtyc nil,_),_) => 
  40.                    CONSTANT const_tags :: 
  41.                     decide(const_tags+1,nonconst_tags,rest)
  42.              | (CONty(RECORDtyc l, _), true) => 
  43.                    (if !System.Control.CG.newconreps
  44.                 then TAGGEDREC(nonconst_tags,length l) 
  45.                 else TAGGED(nonconst_tags))
  46.                    :: decide(const_tags,nonconst_tags+1,rest)
  47.              | (CONty(RECORDtyc l, _), false) => 
  48.                    UNTAGGEDREC(length l) :: 
  49.                      decide(const_tags,nonconst_tags,rest)
  50.              | (_, true) =>  TAGGED nonconst_tags :: 
  51.                        decide(const_tags,nonconst_tags+1,rest)
  52.              | (_, false) => UNTAGGED :: 
  53.                     decide(const_tags,nonconst_tags,rest))
  54.         | decide (_,_,nil) = []
  55.        in decide(0,0, cons)
  56.       end
  57.  
  58. (*val boxed = fn l => let val l' = boxed l in show(l,l'); l' end*)
  59.  
  60. end (* structure ConRep *)
  61.