home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Smlperv.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  7.1 KB  |  283 lines  |  [TEXT/R*ch]
  1. (* Initialization of built-in units *)
  2.  
  3. open List Fnlib Const Smlexc Prim Smlprim Globals Units Types;
  4.  
  5. (* --- Global infix basis --- *)
  6.  
  7. val std_infix_basis =
  8. [
  9.    ("before", INFIXst 0),
  10.    ("o",   INFIXst 3),    (":=",  INFIXst 3),
  11.    ("=",   INFIXst 4),    ("<>",  INFIXst 4),
  12.    ("<",   INFIXst 4),    (">",   INFIXst 4),
  13.    ("<=",  INFIXst 4),    (">=",  INFIXst 4),
  14.    ("@",   INFIXRst 5),   ("::",  INFIXRst 5),
  15.    ("+",   INFIXst 6),    ("-",   INFIXst 6),
  16.    ("^",   INFIXst 6),
  17.    ("div", INFIXst 7),    ("mod", INFIXst 7),
  18.    ("rem", INFIXst 7),    ("quot", INFIXst 7),
  19.    ("*",   INFIXst 7),    ("/",   INFIXst 7)
  20. ];
  21.  
  22. val () =
  23.   app
  24.     (fn(id, status) =>
  25.       Hasht.insert pervasiveInfixTable id status)
  26.     std_infix_basis
  27. ;
  28.  
  29. (* --- Initial constructor basis --- *)
  30.  
  31. val infoFalse = hd(initial_bool_CE)
  32. and infoTrue  = hd(tl initial_bool_CE)
  33. and infoNil   = hd(initial_list_CE)
  34. and infoCons  = hd(tl initial_list_CE)
  35. and infoNONE  = hd(initial_option_CE)
  36. and infoSOME  = hd(tl initial_option_CE)
  37. and infoLESS  = hd(initial_ordering_CE)
  38. and infoEQUAL = hd(tl initial_ordering_CE)
  39. and infoGREATER = hd(tl (tl initial_ordering_CE))
  40. and infoQUOTE      = hd(initial_frag_CE)
  41. and infoANTIQUOTE  = hd(tl initial_frag_CE)
  42. ;
  43.  
  44. val initial_prim_basis =
  45. [
  46.    ("=",       (1, MLPeq)),
  47.    ("<>",      (1, MLPnoteq)),
  48.    ("div",     (1, MLPdiv_int)),
  49.    ("mod",     (1, MLPmod_int)),
  50.    ("quot",    (1, MLPquot_int)),
  51.    ("rem",     (1, MLPrem_int)),
  52.    ("/",       (1, MLPdiv_real)),
  53.    ("floor",   (1, MLPccall(1, "sml_floor"))),
  54.    ("real",    (1, MLPprim(1, Pfloatprim Pfloatofint))),
  55.    ("sqrt",    (1, MLPccall(1, "sml_sqrt"))),
  56.    ("sin",     (1, MLPccall(1, "sml_sin"))),
  57.    ("cos",     (1, MLPccall(1, "sml_cos"))),
  58.    ("arctan",  (1, MLPccall(1, "atan_float"))),
  59.    ("exp",     (1, MLPccall(1, "sml_exp"))),
  60.    ("ln",      (1, MLPccall(1, "sml_ln"))),
  61.    ("^",       (1, MLPconcat)),
  62.    ("size",    (1, MLPprim(1, Pstringlength))),
  63.    ("!",       (1, MLPprim(1, Pfield 0))),
  64.    (":=",      (1, MLPsetref)),
  65.    ("not",     (1, MLPprim(1, Pnot))),
  66.    ("ignore",  (1, MLPprim(1, Patom 0)))
  67. ];
  68.  
  69. val initial_con_basis =
  70. [
  71.    (* --- Constructors --- *)
  72.    ("false",     CONname (#info infoFalse)),
  73.    ("true",      CONname (#info infoTrue)),
  74.    ("nil",       CONname (#info infoNil)),
  75.    ("::",        CONname (#info infoCons)),
  76.    ("NONE",      CONname (#info infoNONE)),
  77.    ("SOME",      CONname (#info infoSOME)),
  78.    ("LESS",      CONname (#info infoLESS)),
  79.    ("EQUAL",     CONname (#info infoEQUAL)),
  80.    ("GREATER",   CONname (#info infoGREATER)),
  81.    ("QUOTE",     CONname (#info infoQUOTE)),
  82.    ("ANTIQUOTE", CONname (#info infoANTIQUOTE)),
  83.    ("ref",   REFname),
  84.    (* --- Overloaded operators --- *)
  85.    ("~",     VARname OVL1NNo),
  86.    ("abs",   VARname OVL1NNo),
  87.    ("+",     VARname OVL2NNNo),
  88.    ("-",     VARname OVL2NNNo),
  89.    ("*",     VARname OVL2NNNo),
  90.    ("<",     VARname OVL2NNBo),
  91.    (">",     VARname OVL2NNBo),
  92.    ("<=",    VARname OVL2NNBo),
  93.    (">=",    VARname OVL2NNBo),
  94.    ("makestring", VARname OVL1NSo)
  95. ];
  96.  
  97. (* *** Initial static environments *** *)
  98.  
  99. (* Typing variable environment *)
  100.  
  101. val sc_bool =
  102.   trivial_scheme type_bool
  103. and sc_ii_i = trivial_scheme
  104.   (type_arrow (type_pair type_int type_int) type_int)
  105. and sc_r_r = trivial_scheme
  106.   (type_arrow type_real type_real)
  107. and sc_s_i = trivial_scheme
  108.   (type_arrow type_string type_int)
  109. and sc_ss_s = trivial_scheme
  110.   (type_arrow (type_pair type_string type_string) type_string)
  111. and sc_exn =
  112.   trivial_scheme type_exn
  113. ;
  114.  
  115. fun VEofCE (CE : ConEnv) =
  116.   map (fn ci => (#id(#qualid ci), #conType(! (#info ci)))) CE
  117. ;
  118.  
  119. val initial_eq_VE =
  120. [
  121.   ("=", scheme_1u_eq (fn a =>
  122.      type_arrow (type_pair a a) type_bool)),
  123.   ("<>", scheme_1u_eq (fn a =>
  124.      type_arrow (type_pair a a) type_bool))
  125. ];
  126.  
  127. val initial_int_VE =
  128. [
  129.   ("div",  sc_ii_i),
  130.   ("mod",  sc_ii_i),
  131.   ("quot", sc_ii_i),
  132.   ("rem",  sc_ii_i)
  133. ];
  134.  
  135. val initial_real_VE =
  136. [
  137.   ("/",      trivial_scheme
  138.                (type_arrow (type_pair type_real type_real) type_real)),
  139.   ("floor",  trivial_scheme (type_arrow type_real type_int)),
  140.   ("real",   trivial_scheme (type_arrow type_int type_real)),
  141.   ("sqrt",   sc_r_r),
  142.   ("sin",    sc_r_r),
  143.   ("cos",    sc_r_r),
  144.   ("arctan", sc_r_r),
  145.   ("exp",    sc_r_r),
  146.   ("ln",     sc_r_r)
  147. ];
  148.  
  149. val initial_string_VE =
  150. [
  151.   ("^",    sc_ss_s),
  152.   ("size", sc_s_i)
  153. ];
  154.  
  155. val initial_ref_VE =
  156. [
  157.   ("ref", scheme_1u_imp (fn a =>
  158.      type_arrow a (type_ref a))),
  159.   ("!", scheme_1u (fn a =>
  160.      type_arrow (type_ref a) a)),
  161.   (":=", scheme_1u (fn a =>
  162.      type_arrow (type_pair (type_ref a) a) type_unit))
  163. ];
  164.  
  165. val sml_initial_VE = concat
  166. [
  167.   initial_eq_VE,
  168.   VEofCE initial_bool_CE,
  169.   initial_int_VE,
  170.   initial_real_VE,
  171.   initial_string_VE,
  172.   VEofCE initial_list_CE,
  173.   VEofCE initial_option_CE,
  174.   VEofCE initial_ordering_CE,
  175.   VEofCE initial_frag_CE,
  176.   initial_ref_VE,
  177.   [("not", trivial_scheme(type_arrow type_bool type_bool))],
  178.   [("ignore", scheme_1u (fn a => type_arrow a type_unit))]
  179. ];
  180.  
  181. val sml_initial_TE =
  182. [
  183.    ("unit",      tyname_unit),
  184.    ("bool",      tyname_bool),
  185.    ("int",       tyname_int),
  186.    ("char",      tyname_char),
  187.    ("real",      tyname_real),
  188.    ("string",    tyname_string),
  189.    ("list",      tyname_list),
  190.    ("vector",    tyname_vector),
  191.    ("option",    tyname_option),
  192.    ("ordering",  tyname_ordering),
  193.    ("frag",      tyname_frag),
  194.    ("ref",       tyname_ref),
  195.    ("exn",       tyname_exn),
  196.    ("ppstream",  tyname_ppstream)
  197. ];
  198.  
  199. val generalExceptions =
  200. [
  201. ];
  202.  
  203. fun mkEmptyInfixBasis() =
  204.     (Hasht.new 23 : (string, InfixStatus) Hasht.t)
  205. ;
  206.  
  207. val () =
  208.   app (fn (id, (arity,prim)) =>
  209.          Hasht.insert
  210.            (#uConBasis unit_General) id
  211.            { qualid={qual="General", id=id},
  212.              info=PRIMname (mkPrimInfo arity prim) })
  213.       initial_prim_basis
  214. ;
  215.  
  216. val () =
  217.   app (fn (id, ci) =>
  218.          Hasht.insert
  219.            (#uConBasis unit_General) id
  220.            { qualid={qual="General", id=id}, info=ci })
  221.       initial_con_basis
  222. ;
  223.  
  224. val () =
  225.   app (fn (id, sc) =>
  226.          Hasht.insert (#uVarEnv unit_General) id sc)
  227.       sml_initial_VE
  228. ;
  229.  
  230. val () =
  231.   app (fn (id, tn) =>
  232.          Hasht.insert (#uTyEnv unit_General) id tn)
  233.       sml_initial_TE
  234. ;
  235.  
  236. fun mkEi q arity =
  237.   let val ei = mkExConInfo() in
  238.     setExConArity ei arity;
  239.     setExConTag ei (SOME (q, 0));
  240.     ei
  241.   end;
  242.  
  243. val () =
  244.   app (fn (id, ((q, stamp), arity)) =>
  245.          let val q = {qual="General", id=id} in
  246.            Hasht.insert
  247.              (#uConBasis unit_General) id
  248.              { qualid=q, info=EXNname(mkEi q arity)}
  249.          end)
  250.       predefExceptions
  251. ;
  252.  
  253. val () =
  254.   app (fn (id, arity, sc) =>
  255.          let val q = {qual="General", id=id} in
  256.            Hasht.insert
  257.              (#uConBasis unit_General) id
  258.              { qualid=q, info=EXNname(mkEi q arity)}
  259.          end)
  260.       generalExceptions
  261.  
  262. ;
  263.  
  264. val sc_str_exn = trivial_scheme (type_arrow type_string type_exn);
  265.  
  266. val () =
  267.   app (fn (id, sc) => Hasht.insert (#uVarEnv unit_General) id sc)
  268.       (map (fn (id, (_, 1)) => (id, sc_str_exn)
  269.              | (id, (_, 0)) => (id, sc_exn)
  270.              | (_, _) => fatalError "smlperv: ill-defined exception")
  271.        predefExceptions)
  272.  
  273. ;
  274.  
  275. val () =
  276.   app (fn (id, arity, sc) => Hasht.insert (#uVarEnv unit_General) id sc)
  277.       generalExceptions
  278. ;
  279.  
  280. val () =
  281.   Hasht.insert pervSigTable "General" unit_General
  282. ;
  283.