[MLton-commit] r7536
Matthew Fluet
fluet at mlton.org
Sat Jun 4 07:33:59 PDT 2011
Remove support for .cm files as input.
The ML Basis system provides much better infrastructure for
"programming in the very large" than the (very) limited support for
CM. The cm2mlb tool (available in the source distribution) can be
used to convert CM projects to MLB projects, preserving the CM scoping
of module identifiers.
----------------------------------------------------------------------
U mlton/trunk/doc/changelog
D mlton/trunk/mlton/cm/cm.sig
D mlton/trunk/mlton/cm/cm.sml
D mlton/trunk/mlton/cm/lexer.sig
D mlton/trunk/mlton/cm/lexer.sml
D mlton/trunk/mlton/cm/parse.sig
D mlton/trunk/mlton/cm/parse.sml
D mlton/trunk/mlton/cm/sources.cm
D mlton/trunk/mlton/cm/sources.mlb
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/mlton/main/sources.cm
U mlton/trunk/mlton/main/sources.mlb
----------------------------------------------------------------------
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/doc/changelog 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,5 +1,8 @@
Here are the changes from version 2010608 to version YYYYMMDD.
+* 2011-06-04
+ - Remove support for .cm files as input.
+
* 2011-05-03
- Fixed a bug with the treatment of as-patterns, which should not
allow the redefinition of constructor status.
Deleted: mlton/trunk/mlton/cm/cm.sig
===================================================================
--- mlton/trunk/mlton/cm/cm.sig 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/cm.sig 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,15 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-signature CM =
- sig
- (* cmfile can be relative or absolute.
- * The resulting list of files will have the same path as cmfile.
- *)
- val cm: {cmfile: File.t} -> File.t list
- end
Deleted: mlton/trunk/mlton/cm/cm.sml
===================================================================
--- mlton/trunk/mlton/cm/cm.sml 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/cm.sml 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,101 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure CM: CM =
-struct
-
-val maxAliasNesting: int = 32
-
-fun cm {cmfile: File.t} =
- let
- val files = ref []
- (* The files in seen are absolute. *)
- val seen = String.memoize (fn _ => ref false)
- fun loop (cmfile: File.t,
- nesting: int,
- relativize: Dir.t option): unit =
- let
- val relativize =
- case relativize of
- NONE => NONE
- | _ => if OS.Path.isAbsolute cmfile
- then NONE
- else relativize
- val {dir, file} = OS.Path.splitDirFile cmfile
- in
- Dir.inDir
- (if dir = "" then "." else dir, fn () =>
- let
- val cwd = Dir.current ()
- fun abs f = OS.Path.mkAbsolute {path = f, relativeTo = cwd}
- fun finalize f =
- case relativize of
- NONE => abs f
- | SOME d =>
- OS.Path.mkRelative {path = f,
- relativeTo = d}
- fun region () =
- let
- val sourcePos =
- SourcePos.make {column = 0,
- file = finalize cmfile,
- line = 0}
- in
- Region.make {left = sourcePos, right = sourcePos}
- end
- fun fail msg =
- Control.error (region (), Layout.str msg, Layout.empty)
- datatype z = datatype Parse.result
- in
- case Parse.parse {cmfile = file} of
- Alias f =>
- if nesting > maxAliasNesting
- then fail "alias nesting too deep."
- else loop (f, nesting + 1, relativize)
- | Bad s => fail (concat ["bad CM file: ", s])
- | Members members =>
- List.foreach
- (members, fn m =>
- let
- val m' = abs m
- val seen = seen m'
- in
- if !seen
- then ()
- else let
- val _ = seen := true
- fun sml () =
- List.push (files, finalize m')
- in
- Control.checkFile
- (m,
- {fail = fail,
- name = m,
- ok = fn () =>
- case File.suffix m of
- SOME "cm" =>
- loop (m, 0, relativize)
- | SOME "sml" => sml ()
- | SOME "sig" => sml ()
- | SOME "fun" => sml ()
- | SOME "ML" => sml ()
- | _ =>
- fail (concat ["MLton can't process ",
- m])})
- end
- end)
- end)
- end
- val d = Dir.current ()
- val _ = loop (cmfile, 0, SOME d)
- val files = rev (!files)
- in
- files
- end
-
-end
Deleted: mlton/trunk/mlton/cm/lexer.sig
===================================================================
--- mlton/trunk/mlton/cm/lexer.sig 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/lexer.sig 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,57 +0,0 @@
-(* Based on the file entity/lexer.sig in the SML/NJ CM sources. *)
-
-(*
- * entity/lexer.sig: lexical analysis of description files
- *
- * Copyright (c) 1995 by AT&T Bell Laboratories
- *
- * author: Matthias Blume (blume at cs.princeton.edu)
- *)
-signature CM_LEXER = sig
-
- exception LexicalError of string * string
- exception SyntaxError of string * string
- exception UserError of string * string
-
- datatype keyword =
- K_GROUP | K_LIBRARY | K_ALIAS | K_IS
- | K_SIGNATURE | K_STRUCTURE | K_FUNSIG | K_FUNCTOR
- | K_IF | K_ELIF | K_ELSE | K_ENDIF | K_DEFINED
- | K_ERROR
-
- datatype lconn = L_AND | L_OR | L_NOT
-
- datatype arith = A_PLUS | A_MINUS | A_TIMES | A_DIV | A_MOD
-
- datatype compare = C_LT | C_LE | C_GT | C_GE | C_EQ | C_NE
-
- datatype token =
- T_COLON
- | T_HASH
- | T_KEYWORD of keyword
- | T_SYMBOL of string
- | T_STRING of string
- | T_NUMBER of int
- | T_LPAREN
- | T_RPAREN
- | T_ARITH of arith
- | T_LCONN of lconn
- | T_COMPARE of compare
- | T_NL
- | T_EOF
-
- type mode
-
- val NORMAL: mode
- val MEMBERS: mode
-
- val lexer: {
- strdef: string -> bool,
- sigdef: string -> bool,
- fctdef: string -> bool,
- fsigdef: string -> bool,
- symval: string -> int option
- } ->
- string * In.t -> mode -> token
-
-end
Deleted: mlton/trunk/mlton/cm/lexer.sml
===================================================================
--- mlton/trunk/mlton/cm/lexer.sml 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/lexer.sml 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,539 +0,0 @@
-(* Based on the file entity/lexer.sml in the SML/NJ CM sources. *)
-
-(*
- * entity/lexer.sml: lexical analysis of description files
- *
- * Copyright (c) 1995 by AT&T Bell Laboratories
- *
- * author: Matthias Blume (blume at cs.princeton.edu)
- *)
-structure CMLexer: CM_LEXER = struct
-
- exception LexicalError of string * string
- exception UserError of string * string
- exception SyntaxError of string * string
- exception LexerBug
-
- datatype keyword =
- K_GROUP | K_LIBRARY | K_ALIAS | K_IS
- | K_SIGNATURE | K_STRUCTURE | K_FUNSIG | K_FUNCTOR
- | K_IF | K_ELIF | K_ELSE | K_ENDIF | K_DEFINED
- | K_ERROR
-
- datatype lconn = L_AND | L_OR | L_NOT
-
- datatype arith = A_PLUS | A_MINUS | A_TIMES | A_DIV | A_MOD
-
- datatype compare = C_LT | C_LE | C_GT | C_GE | C_EQ | C_NE
-
- datatype token =
- T_COLON
- | T_HASH
- | T_KEYWORD of keyword
- | T_SYMBOL of string
- | T_STRING of string
- | T_NUMBER of int
- | T_LPAREN
- | T_RPAREN
- | T_ARITH of arith
- | T_LCONN of lconn
- | T_COMPARE of compare
- | T_NL
- | T_EOF
-
- datatype mode = NORMAL | PREPROC | MEMBERS | ERRORMSG
-
- fun lexer { strdef, sigdef, fctdef, fsigdef, symval } (fname, stream) = let
-
- fun lexerr s = raise LexicalError (fname, s)
- fun synerr s = raise SyntaxError (fname, s)
- fun usererr s = raise UserError (fname, s)
-
- val lookahead: char list ref = ref []
-
- fun getc () =
- case !lookahead of
- [] => let
- val new = String.explode (In.input stream)
- in
- case new of
- [] => NONE
- | h :: t => (lookahead := t; SOME h)
- end
- | h :: t => (lookahead := t; SOME h)
-
- fun ungetc c = (lookahead := (c :: (!lookahead)))
-
- fun skip_white mode = let
-
- fun skip_scheme_comment () =
- case getc () of
- NONE => ()
- | SOME #"\n" => (ungetc #"\n")
- | _ => skip_scheme_comment ()
-
- fun skip_ml_comment () = let
- fun incomplete () = lexerr "incomplete ML-style comment"
- in
- case getc () of
- SOME #"*" =>
- (case getc () of
- SOME #")" => ()
- | NONE => incomplete ()
- | SOME c => (ungetc c; skip_ml_comment ()))
- | SOME #"(" =>
- (case getc () of
- SOME #"*" =>
- (skip_ml_comment (); skip_ml_comment ())
- | NONE => incomplete ()
- | SOME c => (ungetc c; skip_ml_comment ()))
- (*| SOME #";" => (skip_scheme_comment (); skip_ml_comment ())*)
- | NONE => incomplete ()
- | SOME _ => skip_ml_comment ()
- end
-
- fun skip () = let
- fun done () = ()
- fun preproc_nl thunk =
- (if mode = PREPROC orelse mode = ERRORMSG then
- ungetc #"\n"
- else thunk ())
- in
- case getc () of
- NONE => ()
- | SOME #";" => (skip_scheme_comment (); skip ())
- | SOME #"\n" =>
- (case getc () of
- NONE => preproc_nl done
- | SOME #"#" => (ungetc #"#"; preproc_nl done)
- | SOME c => (ungetc c; preproc_nl skip))
- | SOME #"(" =>
- (case getc () of
- NONE => ungetc #"("
- | SOME #"*" => (skip_ml_comment (); skip ())
- | SOME c => (ungetc c; ungetc #"("))
- | SOME c =>
- if Char.isSpace c then skip () else ungetc c
- end
- in
- skip
- end
-
- fun rawlex mode = let
-
- val skip = skip_white mode
-
- fun getc_nonwhite () = (skip (); getc ())
-
- fun getnum c = let
- fun loop (n, c) = let
- val n = 10 * n + Char.ord c - Char.ord #"0"
- in
- case getc () of
- NONE => n
- | SOME c => if Char.isDigit c then loop (n, c)
- else (ungetc c; n)
- end
- in
- loop (0, c) handle Overflow => lexerr "arithmetic overflow"
- end
-
- fun expect (c, t) =
- if getc () = SOME c then t
- else lexerr (concat ["expecting ", String.implode [c]])
-
- fun ifnext (c, ty, tn) =
- case getc () of
- NONE => tn
- | SOME c1 =>
- if c = c1 then ty else (ungetc c1; tn)
-
- fun getsym (c, delim) = let
- fun loop (accu, c) = let
- val accu = c :: accu
- in
- case getc () of
- NONE => String.implode (rev accu)
- | SOME c =>
- if Char.isSpace c orelse String.contains(delim, c)
- then (ungetc c; String.implode (rev accu))
- else loop (accu, c)
- end
- in
- loop ([], c)
- end
-
- fun getline c = let
- fun loop accu =
- case getc () of
- NONE => String.implode (rev accu)
- | SOME #"\n" => String.implode (rev accu)
- | SOME c => loop (c :: accu)
- in
- loop [c]
- end
-
- val preproc_delim = "():;#+-*/%&!|><="
- val non_preproc_delim = "():;#"
-
- fun preproc_sym "if" = T_KEYWORD K_IF
- | preproc_sym "elif" = T_KEYWORD K_ELIF
- | preproc_sym "else" = T_KEYWORD K_ELSE
- | preproc_sym "endif" = T_KEYWORD K_ENDIF
- | preproc_sym "defined" = T_KEYWORD K_DEFINED
- | preproc_sym "structure" = T_KEYWORD K_STRUCTURE
- | preproc_sym "signature" = T_KEYWORD K_SIGNATURE
- | preproc_sym "functor" = T_KEYWORD K_FUNCTOR
- | preproc_sym "funsig" = T_KEYWORD K_FUNSIG
- | preproc_sym "error" = T_KEYWORD K_ERROR
- | preproc_sym s = T_SYMBOL s
-
- fun normal_sym "group" = T_KEYWORD K_GROUP
- | normal_sym "Group" = T_KEYWORD K_GROUP
- | normal_sym "GROUP" = T_KEYWORD K_GROUP
- | normal_sym "library" = T_KEYWORD K_LIBRARY
- | normal_sym "Library" = T_KEYWORD K_LIBRARY
- | normal_sym "LIBRARY" = T_KEYWORD K_LIBRARY
- | normal_sym "alias" = T_KEYWORD K_ALIAS
- | normal_sym "Alias" = T_KEYWORD K_ALIAS
- | normal_sym "ALIAS" = T_KEYWORD K_ALIAS
- | normal_sym "is" = T_KEYWORD K_IS
- | normal_sym "IS" = T_KEYWORD K_IS
- | normal_sym "structure" = T_KEYWORD K_STRUCTURE
- | normal_sym "signature" = T_KEYWORD K_SIGNATURE
- | normal_sym "functor" = T_KEYWORD K_FUNCTOR
- | normal_sym "funsig" = T_KEYWORD K_FUNSIG
- | normal_sym s = T_SYMBOL s
-
- fun string () = let
- fun collect l =
- case getc () of
- NONE => lexerr "missing string delimiter"
- | SOME #"\"" =>
- (case getc () of
- SOME #"\"" => collect (#"\"" :: l)
- | SOME c => (ungetc c; String.implode (rev l))
- | NONE => String.implode (rev l))
- | SOME c => collect (c :: l)
- in
- collect []
- end
-
- in
- if mode = ERRORMSG then
- T_SYMBOL (case getc_nonwhite () of
- NONE => "error"
- | SOME #"\n" => "error"
- | SOME c => getline c)
- else
- case getc_nonwhite () of
- NONE => T_EOF
- | SOME #":" => T_COLON
- | SOME #"\n" => T_NL
- | SOME #"#" => T_HASH
- | SOME #"\"" =>
- (case mode of
- NORMAL => T_STRING (string ())
- | MEMBERS => T_STRING (string ())
- | _ =>
- synerr "quoted string in wrong context")
- | SOME c =>
- if mode = PREPROC then
- case c of
- #"(" => T_LPAREN
- | #")" => T_RPAREN
- | #"+" => T_ARITH A_PLUS
- | #"-" => T_ARITH A_MINUS
- | #"*" => T_ARITH A_TIMES
- | #"/" => T_ARITH A_DIV
- | #"%" => T_ARITH A_MOD
- | #"&" => expect (#"&", T_LCONN L_AND)
- | #"|" => expect (#"|", T_LCONN L_OR)
- | #"!" =>
- ifnext (#"=", T_COMPARE C_NE, T_LCONN L_NOT)
- | #">" =>
- ifnext (#"=", T_COMPARE C_GE, T_COMPARE C_GT)
- | #"<" =>
- ifnext (#"=", T_COMPARE C_LE, T_COMPARE C_LT)
- | #"=" => expect (#"=", T_COMPARE C_EQ)
- | _ =>
- if Char.isDigit c then
- T_NUMBER (getnum c)
- else if Char.isAlpha c then
- preproc_sym (getsym (c, preproc_delim))
- else
- synerr "illegal preprocessor line"
- else let
- val s = getsym (c, non_preproc_delim)
- in
- if mode = NORMAL then
- normal_sym s
- else
- T_SYMBOL s
- end
- end
-
- val lex = let
-
- val lookahead: token list ref = ref []
-
- fun gett () =
- case !lookahead of
- [] => rawlex PREPROC
- | (h :: t) => (lookahead := t; h)
-
- fun ungett t = lookahead := (t :: (!lookahead))
-
- fun leftrec (f, tokf) = let
- fun loop accu = let
- val nt = gett ()
- in
- case tokf nt of
- NONE => (ungett nt; accu)
- | SOME c => loop (c (accu, f ()))
- end
- in
- loop (f ())
- end
-
- fun nonassoc (f, tokf) = let
- val lhs = f ()
- val nt = gett ()
- in
- case tokf nt of
- NONE => (ungett nt; lhs)
- | SOME c => c (lhs, f ())
- end
-
- fun expect (t, m) =
- if gett () = t then () else synerr (concat ["missing ", m])
-
- fun intbool f (x: unit -> int, y: unit -> int) =
- fn () => if f (x (), y ()) then 1 else 0
-
- fun orf (x, y) =
- fn () => if (x () <> 0) orelse (y () <> 0) then 1 else 0
- fun andf (x, y) =
- fn () => if (x () <> 0) andalso (y () <> 0) then 1 else 0
- fun notf x = fn () => if x () <> 0 then 0 else 1
- val eqf = intbool (op =)
- val nef = intbool (op <>)
- val gtf = intbool (op >)
- val gef = intbool (op >=)
- val ltf = intbool (op <)
- val lef = intbool (op <=)
-
- fun binaryf binop (x: unit -> int, y: unit -> int) =
- fn () => (binop (x (), y ()))
- fun unaryf uop (x: unit -> int) =
- fn () => uop (x ())
-
- val plusf = binaryf (op +)
- val minusf = binaryf (op -)
- val timesf = binaryf (op * )
- val divf = binaryf (op div)
- val modf = binaryf (op mod)
- val negatef = unaryf ~
-
- fun expression () = disjunction ()
-
- and disjunction () = let
- fun tokf (T_LCONN L_OR) = SOME orf
- | tokf _ = NONE
- in
- leftrec (conjunction, tokf)
- end
-
- and conjunction () = let
- fun tokf (T_LCONN L_AND) = SOME andf
- | tokf _ = NONE
- in
- leftrec (equivalence, tokf)
- end
-
- and equivalence () = let
- fun tokf (T_COMPARE C_EQ) = SOME eqf
- | tokf (T_COMPARE C_NE) = SOME nef
- | tokf _ = NONE
- in
- nonassoc (comparison, tokf)
- end
-
- and comparison () = let
- fun tokf (T_COMPARE C_GT) = SOME gtf
- | tokf (T_COMPARE C_GE) = SOME gef
- | tokf (T_COMPARE C_LT) = SOME ltf
- | tokf (T_COMPARE C_LE) = SOME lef
- | tokf _ = NONE
- in
- nonassoc (sum, tokf)
- end
-
- and sum () = let
- fun tokf (T_ARITH A_PLUS) = SOME plusf
- | tokf (T_ARITH A_MINUS) = SOME minusf
- | tokf _ = NONE
- in
- leftrec (product, tokf)
- end
-
- and product () = let
- fun tokf (T_ARITH A_TIMES) = SOME timesf
- | tokf (T_ARITH A_DIV) = SOME divf
- | tokf (T_ARITH A_MOD) = SOME modf
- | tokf _ = NONE
- in
- leftrec (unary, tokf)
- end
-
- and unary () =
- case gett () of
- T_LCONN L_NOT => notf (unary ())
- | T_ARITH A_MINUS => negatef (unary ())
- | nt => (ungett nt; primary ())
-
- and primary () =
- case gett () of
- T_LPAREN =>
- expression ()
- before expect (T_RPAREN, "right parenthesis")
- | T_NUMBER n => (fn () => n)
- | T_SYMBOL s =>
- (fn () =>
- (case symval s of
- NONE => synerr (concat ["undefined symbol: ", s])
- | SOME v => v))
- | T_KEYWORD K_DEFINED => let
- val _ = expect (T_LPAREN, "left parenthesis")
- in
- case gett () of
- T_KEYWORD k => let
- val look =
- case k of
- K_STRUCTURE => strdef
- | K_SIGNATURE => sigdef
- | K_FUNCTOR => fctdef
- | K_FUNSIG => fsigdef
- | _ => synerr "unexpected keyword"
- in
- case gett () of
- T_SYMBOL s =>
- (expect (T_RPAREN,
- "right parenthesis");
- fn () => if look s then 1 else 0)
- | _ => synerr "missing symbol"
- end
- | T_SYMBOL s =>
- (expect (T_RPAREN, "right parenthesis");
- fn () => (case symval s of
- NONE => 0
- | SOME _ => 1))
- | _ => synerr "illegal `defined' construct"
- end
- | _ => synerr "unexpected token"
-
- datatype localstate =
- T_C | T | E_C | E
-
- datatype cmd =
- IF of unit -> int
- | ELIF of unit -> int
- | ELSE
- | ENDIF
-
- type state = localstate * bool
-
- fun iscopying s =
- case s of
- [] => true
- | (_, copying) :: _ => copying
-
- fun transform (IF c, s) =
- if iscopying s andalso c () <> 0 then
- (T_C, true) :: s
- else
- (T, false) :: s
- | transform (ELIF _, (T_C, _) :: s) = (T_C, false) :: s
- | transform (ELIF c, (T, _) :: s) =
- if iscopying s andalso c () <> 0 then
- (T_C, true) :: s
- else
- (T, false) :: s
- | transform (ELIF _, _) = synerr "unexpected #elif"
- | transform (ELSE, (T_C, _) :: s) = (E, false) :: s
- | transform (ELSE, (T, _) :: s) = (E_C, iscopying s) :: s
- | transform (ELSE, _) = synerr "unexpected #else"
- | transform (ENDIF, []) = synerr "unexpected #endif"
- | transform (ENDIF, _ :: s) = s
-
- val state: state list ref = ref []
-
- fun checklook () =
- case !lookahead of
- [] => ()
- | _ => raise LexerBug
-
- fun condition () = let
- val e = expression ()
- in
- fn () =>
- (e ()
- handle Overflow => synerr "arithmetic overflow in condition"
- | Div => synerr "divide by zero in condition")
- end
-
- fun nexttoken mode =
- case rawlex mode of
- T_HASH =>
- (case rawlex PREPROC of
- T_KEYWORD K_IF => let
- val c = condition ()
- val _ = expect (T_NL, "line break (#if)")
- val _ = checklook ()
- in
- state := transform (IF c, !state);
- nexttoken mode
- end
- | T_KEYWORD K_ELSE =>
- (expect (T_NL, "line break (#else)");
- checklook ();
- state := transform (ELSE, !state);
- nexttoken mode)
- | T_KEYWORD K_ELIF => let
- val c = condition ()
- val _ = expect (T_NL, "line break (#elif)")
- val _ = checklook ()
- in
- state := transform (ELIF c, !state);
- nexttoken mode
- end
- | T_KEYWORD K_ENDIF =>
- (expect (T_NL, "line break (#endif)");
- checklook ();
- state := transform (ENDIF, !state);
- nexttoken mode)
- | T_KEYWORD K_ERROR => let
- val msg =
- case rawlex ERRORMSG of
- T_SYMBOL msg => msg
- | _ => raise LexerBug
- in
- if iscopying (!state) then
- usererr msg
- else
- (checklook (); nexttoken mode)
- end
- | _ => synerr "illegal preprocessor line")
- | T_EOF =>
- if (!state) = [] then T_EOF
- else synerr "missing #endif"
- | t => if iscopying (!state) then t else nexttoken mode
-
- in
- nexttoken
- end
-
- in
- lex
- end
-end
Deleted: mlton/trunk/mlton/cm/parse.sig
===================================================================
--- mlton/trunk/mlton/cm/parse.sig 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/parse.sig 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,22 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-signature PARSE =
- sig
- datatype result =
- Alias of File.t
- | Bad of string (* error message *)
- | Members of File.t list
-
- (* Pre: cmfile must not contain any path, i.e. it must be in the
- * current directory.
- * The resulting members are either absolute or relative to the current
- * directory.
- *)
- val parse: {cmfile: string} -> result
- end
Deleted: mlton/trunk/mlton/cm/parse.sml
===================================================================
--- mlton/trunk/mlton/cm/parse.sml 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/parse.sml 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,130 +0,0 @@
-(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-(* Based on the file entity/description.sml in the SML/NJ CM sources. *)
-
-(*
- * entity/description.sml: Entity description file parser.
- *
- * Copyright (c) 1995 by AT&T Bell Laboratories
- *
- * author: Matthias Blume (blume at cs.princeton.edu)
- *)
-structure Parse: PARSE =
-struct
-
-val fail = Process.fail
-
-structure Lexer = CMLexer
-
-datatype result =
- Alias of File.t
- | Bad of string
- | Members of File.t list
-
-(* The main read function for CM entities. *)
-fun parse {cmfile: string} =
- Exn.withEscape
- (fn escape =>
- let
- fun bad m = (ignore (escape (Bad m)); raise Fail "impossible")
- in
- File.withIn
- (cmfile, fn ins =>
- let
- fun no _ = false
- val lex =
- Lexer.lexer {strdef = no,
- sigdef = no,
- fctdef = no,
- fsigdef = no,
- symval = fn _ => NONE}
- (cmfile, ins)
- val lex =
- fn m =>
- lex m
- handle Lexer.LexicalError (_, s) => bad s
- | Lexer.SyntaxError (_, s) => bad s
- | Lexer.UserError (_, s) => bad s
- val lookahead: Lexer.token list ref = ref []
- fun normal () =
- case !lookahead of
- [] => lex Lexer.NORMAL
- | h :: t => (lookahead := t; h)
- fun member () =
- case !lookahead of
- [] => lex Lexer.MEMBERS
- | h :: t => (lookahead := t; h)
- fun unget t = lookahead := (t :: (!lookahead))
- fun readExport () =
- let
- fun name () =
- (case normal () of
- Lexer.T_SYMBOL _ => ()
- | Lexer.T_STRING _ => ()
- | _ => bad "missing exported name"
- ; SOME ())
- in case normal () of
- Lexer.T_KEYWORD Lexer.K_SIGNATURE => name ()
- | Lexer.T_KEYWORD Lexer.K_STRUCTURE => name ()
- | Lexer.T_KEYWORD Lexer.K_FUNCTOR => name ()
- | Lexer.T_KEYWORD Lexer.K_FUNSIG => name ()
- | x => (unget x; NONE)
- end
- fun readList readItem =
- let
- fun loop ac =
- case readItem () of
- NONE => rev ac
- | SOME i => loop (i :: ac)
- in loop []
- end
- fun getFileName () =
- case member () of
- Lexer.T_SYMBOL name => SOME name
- | Lexer.T_STRING name => SOME name
- | t => (unget t; NONE)
- fun readMember () =
- case getFileName () of
- NONE => NONE
- | SOME f =>
- (case member () of
- Lexer.T_COLON =>
- (case member () of
- Lexer.T_SYMBOL _ => ()
- | Lexer.T_STRING _ => ()
- | _ => bad "missing class name")
- | t => unget t
- ; SOME f)
- fun readMembers () =
- case normal () of
- Lexer.T_KEYWORD Lexer.K_IS =>
- (if !lookahead <> [] then fail "Bug in parser" else ()
- ; readList readMember)
- | _ => bad "missing keyword 'is'"
- fun parseAlias () =
- case getFileName () of
- NONE => bad "alias name missing"
- | SOME f => let val _ = In.close ins
- in Alias f
- end
- fun parseGroup () =
- let
- val _ = readList readExport
- val members = readMembers ()
- val _ = In.close ins
- in Members members
- end
- in case normal () of
- Lexer.T_KEYWORD Lexer.K_GROUP => parseGroup ()
- | Lexer.T_KEYWORD Lexer.K_LIBRARY => parseGroup ()
- | Lexer.T_KEYWORD Lexer.K_ALIAS => parseAlias ()
- | _ => bad "expected 'group' or 'library'"
- end)
- end)
-
-end
Deleted: mlton/trunk/mlton/cm/sources.cm
===================================================================
--- mlton/trunk/mlton/cm/sources.cm 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/sources.cm 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,22 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-Group
-
-structure CM
-
-is
-
-../../lib/mlton/sources.cm
-../control/sources.cm
-lexer.sig
-lexer.sml
-parse.sig
-parse.sml
-cm.sig
-cm.sml
Deleted: mlton/trunk/mlton/cm/sources.mlb
===================================================================
--- mlton/trunk/mlton/cm/sources.mlb 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/cm/sources.mlb 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,21 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-local
- ../../lib/mlton/sources.mlb
- ../control/sources.mlb
-
- lexer.sig
- lexer.sml
- parse.sig
- parse.sml
- cm.sig
- cm.sml
-in
- structure CM
-end
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/main/main.fun 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2010 Matthew Fluet.
+(* Copyright (C) 2010-2011 Matthew Fluet.
* Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -16,11 +16,10 @@
structure Place =
struct
- datatype t = CM | Files | Generated | MLB | O | OUT | SML | TypeCheck
+ datatype t = Files | Generated | MLB | O | OUT | SML | TypeCheck
val toInt: t -> int =
- fn CM => 1
- | MLB => 1
+ fn MLB => 1
| SML => 1
| Files => 2
| TypeCheck => 4
@@ -29,8 +28,7 @@
| OUT => 7
val toString =
- fn CM => "cm"
- | Files => "files"
+ fn Files => "files"
| SML => "sml"
| MLB => "mlb"
| Generated => "g"
@@ -828,7 +826,7 @@
end
val mainUsage =
- "mlton [option ...] file.{c|cm|mlb|o|sml} [file.{c|o|s|S} ...]"
+ "mlton [option ...] file.{c|mlb|o|sml} [file.{c|o|s|S} ...]"
val {parse, usage} =
Popt.makeUsage {mainUsage = mainUsage,
@@ -1151,7 +1149,6 @@
datatype z = datatype Place.t
in
loop [(".mlb", MLB, false),
- (".cm", CM, false),
(".sml", SML, false),
(".c", Generated, true),
(".o", O, true)]
@@ -1455,23 +1452,9 @@
mkCompileSrc {listFiles = Compile.sourceFilesMLB,
elaborate = Compile.elaborateMLB,
compile = Compile.compileMLB}
- fun compileCM (file: File.t) =
- let
- val _ =
- if !Control.warnDeprecated
- then
- Out.output
- (Out.error,
- "Warning: .cm input files are deprecated. Use .mlb input files.\n")
- else ()
- val files = CM.cm {cmfile = file}
- in
- compileSML files
- end
fun compile () =
case start of
- Place.CM => compileCM input
- | Place.SML => compileSML [input]
+ Place.SML => compileSML [input]
| Place.MLB => compileMLB input
| Place.Generated => compileCSO (input :: csoFiles)
| Place.O => compileCSO (input :: csoFiles)
Modified: mlton/trunk/mlton/main/sources.cm
===================================================================
--- mlton/trunk/mlton/main/sources.cm 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/main/sources.cm 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -18,7 +18,6 @@
../atoms/sources.cm
../backend/sources.cm
../closure-convert/sources.cm
-../cm/sources.cm
../codegen/sources.cm
../control/sources.cm
../core-ml/sources.cm
Modified: mlton/trunk/mlton/main/sources.mlb
===================================================================
--- mlton/trunk/mlton/main/sources.mlb 2011-05-27 15:00:21 UTC (rev 7535)
+++ mlton/trunk/mlton/main/sources.mlb 2011-06-04 14:33:53 UTC (rev 7536)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -13,7 +13,6 @@
../atoms/sources.mlb
../backend/sources.mlb
../closure-convert/sources.mlb
- ../cm/sources.mlb
../codegen/sources.mlb
../control/sources.mlb
../core-ml/sources.mlb
More information about the MLton-commit
mailing list