Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/compiler/MiscUtil/print/pptable.sml
ViewVC logotype

View of /sml/trunk/src/compiler/MiscUtil/print/pptable.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 224 - (download) (annotate)
Sat Apr 17 16:27:01 1999 UTC (21 years, 4 months ago) by monnier
File size: 2376 byte(s)
This commit was generated by cvs2svn to compensate for changes in r223,
which included commits to RCS files with non-trunk default branches.
(* Copyright 1992 by AT&T Bell Laboratories *)
(* pptable.sml *)

signature PPTABLE =
sig
  exception PP_NOT_INSTALLED
  val pp_object : PrettyPrint.ppstream -> Stamps.stamp -> Unsafe.Object.object
                  -> unit
  val install_pp : string list -> 
                   (PrettyPrint.ppstream -> Unsafe.Object.object -> unit) -> unit
end

structure PPTable : PPTABLE =
struct

(* The following code implements automatic prettyprinting of values. *)
(* The user defines a datatype d, then defines a prettyprinter       *)
(*                                                                   *)
(*     dp : ppstream -> d -> unit                                    *)
(*                                                                   *)
(* over d, perhaps using the Oppen primitives. Then dp is installed  *)
(* in the "pp table" via install_pp. Subsequently, when a value of   *)
(* type d comes to be printed out, we look in the table, find dp and *)
(* apply it to the value. If it is not found, we print the value in  *)
(* the default manner.                                               *)

  type object = Unsafe.Object.object

  exception PP_NOT_INSTALLED

  fun error msg = 
        (ErrorMsg.errorNoFile (ErrorMsg.defaultConsumer(),ref false) (0,0) 
			      ErrorMsg.COMPLAIN
			      msg
			      ErrorMsg.nullErrorBody;
	 raise ErrorMsg.Error)

  val global_pp_table: (PrettyPrint.ppstream->object->unit) Stamps.stampMap =
      Stamps.newMap(PP_NOT_INSTALLED)

  fun make_path([s],p) = SymPath.SPATH(rev(Symbol.tycSymbol(s)::p))
    | make_path(s::r,p) = make_path(r,Symbol.strSymbol(s)::p)
    | make_path _ = error "install_pp: empty path" 

  fun install_pp (path_names: string list)
                 (p: PrettyPrint.ppstream -> object -> unit) =
      let val sym_path = make_path(path_names,[])
	  val tycon = Lookup.lookTyc ((#static(EnvRef.combined())),
		sym_path,
		ErrorMsg.errorNoFile(ErrorMsg.defaultConsumer(),ref false) (0,0))
       in case tycon
	    of Types.GENtyc{stamp,...} => Stamps.updateMap global_pp_table (stamp,p)
	     | _ => error "install_pp: nongenerative type constructor"
      end

  fun pp_object ppstrm (s: Stamps.stamp) (obj:object) =
      Stamps.applyMap(global_pp_table,s) ppstrm obj

end (* structure PPTABLE *)

(*
 * $Log: pptable.sml,v $
 * Revision 1.1.1.1  1998/04/08 18:39:16  george
 * Version 110.5
 *
 *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0