[MLton-commit] r5323

Matthew Fluet fluet at mlton.org
Sun Feb 25 14:16:36 PST 2007


Merge trunk revisions 5269:5322 into x86_64 branch
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun
U   mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sig
U   mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml
U   mlton/branches/on-20050822-x86_64-branch/doc/changelog
U   mlton/branches/on-20050822-x86_64-branch/ide/emacs/def-use-mode.el
U   mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-du-mlton.el
U   mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el
U   mlton/branches/on-20050822-x86_64-branch/mlnlffigen/gen.sml
U   mlton/branches/on-20050822-x86_64-branch/regression/exnHistory.ok
U   mlton/branches/on-20050822-x86_64-branch/regression/exnHistory3.ok

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig	2007-02-25 22:15:53 UTC (rev 5323)
@@ -31,11 +31,13 @@
 
       type array
 
+      val unsafeFromArray: array -> vector
+      val unsafeSub: vector * int -> elem
+
       val append: vector * vector -> vector
       val concatWith: vector -> vector list -> vector
       val duplicate: vector -> vector
       val fields: (elem -> bool) -> vector -> vector list
-      val fromArray: array -> vector
       val isPrefix: (elem * elem -> bool) -> vector -> vector -> bool
       val isSubvector: (elem * elem -> bool) -> vector -> vector -> bool
       val isSuffix: (elem * elem -> bool) -> vector -> vector -> bool
@@ -43,7 +45,6 @@
       val tokens: (elem -> bool) -> vector -> vector list
       val translate: (elem -> vector) -> vector -> vector
       val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a
-      val unsafeSub: vector * int -> elem
       val vector: int * elem -> vector
    end
 

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig	2007-02-25 22:15:53 UTC (rev 5323)
@@ -34,7 +34,7 @@
       include VECTOR
       structure VectorSlice: VECTOR_SLICE_EXTRA 
 
-      val fromArray: 'a array -> 'a vector
+      val unsafeFromArray: 'a array -> 'a vector
       val unsafeSub: 'a vector * int -> 'a
 
       (* Used to implement Substring/String functions *)

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -57,7 +57,7 @@
 
       val isSubvector = isSubsequence
 
-      val fromArray = Primitive.Vector.fromArray
+      val unsafeFromArray = Primitive.Vector.fromArray
 
       val vector = new
 

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun	2007-02-25 22:15:53 UTC (rev 5323)
@@ -16,7 +16,7 @@
       structure PrimIO: PRIM_IO
       structure Vector: sig 
                            include MONO_VECTOR
-                           val fromArray: Array.array -> vector
+                           val unsafeFromArray: Array.array -> vector
                         end
       structure VectorSlice: MONO_VECTOR_SLICE
       sharing type Array.array
@@ -396,7 +396,7 @@
                             val i = loop size
                          in
                             if i = n
-                               then V.fromArray inp
+                               then V.unsafeFromArray inp
                             else AS.vector (AS.slice (inp, 0, SOME i))
                          end)
                 | Stream s =>

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -589,7 +589,7 @@
 
 fun getVec (a, n, bytesRead) =
    if n = bytesRead
-      then Word8Vector.fromArray a
+      then Word8Vector.unsafeFromArray a
    else Word8ArraySlice.vector (Word8ArraySlice.slice (a, 0, SOME bytesRead))
 
 fun recvVec' (sock, n, in_flags) =

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -240,7 +240,7 @@
             in 
                fromVector
                (if n = bytesRead
-                   then Vector.fromArray buf
+                   then Vector.unsafeFromArray buf
                    else ArraySlice.vector (ArraySlice.slice (buf, 0, SOME bytesRead)))
             end
          fun writeArr (fd, sl): int =

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -49,13 +49,13 @@
       updA (a, i, r)
    end
 
-local
-   val a = Array.arrayUninit bytesPerElem
-in
-   fun toBytes (r: real): Word8Vector.vector =
+fun toBytes (r: real): Word8Vector.vector =
+   let
+      val a = Array.arrayUninit bytesPerElem
+   in
       (updA (a, 0, r)
-       ; Word8Vector.fromPoly (Vector.fromArray a))
-end
+       ; Word8Vector.fromPoly (Array.vector a))
+   end
 
 local
    fun make (sub, length, toPoly) (s, i) =

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -338,7 +338,7 @@
                   val i = upd (i, #"E")
                   val i = CharVector.foldl (fn (c, i) => upd (i, c)) i exp
                   val _ = upd (i, #"\000")
-                  val x = Vector.fromArray a
+                  val x = Vector.unsafeFromArray a
                   val x = Prim.strto (NullString.fromString x)
                in
                   if sign

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sig	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sig	2007-02-25 22:15:53 UTC (rev 5323)
@@ -46,7 +46,8 @@
       include STRING
       type array
       
-      val fromArray: array -> string
+      val unsafeFromArray: array -> string
+
       val new: int * char -> string
       val nullTerm: string -> string
       val tabulate: int * (int -> char) -> string

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -65,7 +65,7 @@
                toArrayOfLength (cs, sub, n)
 
             fun toStringOfLength (cs, n) =
-               String.fromArray 
+               String.unsafeFromArray 
                (CharArray.fromPoly (toCharArrayOfLength (cs, n)))
 
             fun toString cs = toStringOfLength (cs, length cs)

Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog	2007-02-25 22:15:53 UTC (rev 5323)
@@ -4,6 +4,10 @@
    - Removed expert command line switch -coalesce <n>.
    - Added expert command line switch -chunkify {coalesce<n>|func|one}.
 
+* 2007-02-20
+   - Fixed bug in PackReal<N>.toBytes.  Thanks to Eric McCorkle for the
+     bug report.
+
 * 2007-02-18
    - Added command line switch -profile-val, to profile the evaluation of
      val bindings; this is particularly useful with exception history for

Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/def-use-mode.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/def-use-mode.el	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/def-use-mode.el	2007-02-25 22:15:53 UTC (rev 5323)
@@ -30,14 +30,21 @@
   :group 'matching)
 
 (defface def-use-def-face
-  '((((class color)) (:background "paleturquoise3"))
+  '((((class color)) (:background "darkseagreen3"))
     (t (:background "gray")))
   "Face for highlighting definitions."
   :group 'faces
   :group 'def-use)
 
+(defface def-use-unused-def-face
+  '((((class color)) (:background "pink"))
+    (t (:background "gray")))
+  "Face for highlighting definitions that have no uses."
+  :group 'faces
+  :group 'def-use)
+
 (defface def-use-use-face
-  '((((class color)) (:background "darkseagreen3"))
+  '((((class color)) (:background "paleturquoise3"))
     (t (:background "gray")))
   "Face for highlighting uses."
   :group 'faces
@@ -204,16 +211,15 @@
 (defun def-use-jump-to-def (&optional other-window)
   "Jumps to the definition of the symbol under the cursor."
   (interactive "P")
-  (ring-insert def-use-marker-ring (point-marker))
   (let ((sym (def-use-current-sym)))
     (if (not sym)
         (message "%s" def-use-apology)
+      (ring-insert def-use-marker-ring (point-marker))
       (def-use-goto-ref (def-use-sym-ref sym) other-window))))
 
 (defun def-use-jump-to-next (&optional other-window reverse)
   "Jumps to the next use (or def) of the symbol under the cursor."
   (interactive "P")
-  (ring-insert def-use-marker-ring (point-marker))
   (let* ((ref (def-use-current-ref))
          (sym (def-use-sym-at-ref ref)))
     (if (not sym)
@@ -222,12 +228,12 @@
              (refs (if reverse (reverse refs) refs))
              (refs (append refs refs)))
         (while (not (equal (pop refs) ref)))
+        (ring-insert def-use-marker-ring (point-marker))
         (def-use-goto-ref (car refs) other-window)))))
 
 (defun def-use-jump-to-prev (&optional other-window)
   "Jumps to the prev use (or def) of the symbol under the cursor."
   (interactive "P")
-  (ring-insert def-use-marker-ring (point-marker))
   (def-use-jump-to-next other-window t))
 
 (defun def-use-goto-ref (ref &optional other-window)
@@ -449,7 +455,10 @@
             (when buffer
               (set-buffer buffer)
               (def-use-highlight-ref
-                length (def-use-ref-pos ref) 'def-use-def-face))))))))
+                length (def-use-ref-pos ref)
+                (if (def-use-sym-to-uses sym)
+                    'def-use-def-face
+                  'def-use-unused-def-face)))))))))
 
 (defun def-use-highlight-current ()
   "Highlights the symbol at the point."

Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-du-mlton.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-du-mlton.el	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-du-mlton.el	2007-02-25 22:15:53 UTC (rev 5323)
@@ -7,7 +7,7 @@
 (require 'bg-job)
 (require 'esml-util)
 
-;; XXX Detect when the same ref is both a use and a def and act appropriately.
+;; XXX Fix race condition when (re)loading def-use file that is being written.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Customization
@@ -69,17 +69,48 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Move to symbol
 
+(defun esml-du-character-class (c)
+  (cond
+   ((find c esml-sml-symbolic-chars)
+    'symbolic)
+   ((find c esml-sml-alphanumeric-chars)
+    'alphanumeric)))
+
+(defun esml-du-extract-following-symbol (chars)
+  (save-excursion
+    (let ((start (point)))
+      (skip-chars-forward chars)
+      (buffer-substring start (point)))))
+
 (defun esml-du-move-to-symbol-start ()
-  "Moves to the start of the SML symbol at point."
-  (let ((limit (def-use-point-at-current-line)))
-    (when (zerop (skip-chars-backward esml-sml-alphanumeric-chars limit))
-      (skip-chars-backward esml-sml-symbolic-chars limit))))
+  "Moves to the start of the SML symbol at point.  If the point is between
+two symbols, one symbolic and other alphanumeric (e.g. !x) the symbol
+following the point is preferred.  This ensures that the symbol does not
+change surprisingly after a jump."
+  (let ((bef (esml-du-character-class (char-before)))
+        (aft (esml-du-character-class (char-after))))
+    (cond
+     ((and (eq bef 'alphanumeric) (eq aft 'symbolic)
+           (find (esml-du-extract-following-symbol esml-sml-symbolic-chars)
+                 esml-sml-symbolic-keywords
+                 :test 'equal))
+      (skip-chars-backward esml-sml-alphanumeric-chars))
+     ((and (eq bef 'symbolic) (eq aft 'alphanumeric)
+           (find (esml-du-extract-following-symbol esml-sml-alphanumeric-chars)
+                 esml-sml-alphanumeric-keywords
+                 :test 'equal))
+      (skip-chars-backward esml-sml-symbolic-chars))
+     ((and (eq bef 'symbolic) (not (eq aft 'alphanumeric)))
+      (skip-chars-backward esml-sml-symbolic-chars))
+     ((and (eq bef 'alphanumeric) (not (eq aft 'symbolic)))
+      (skip-chars-backward esml-sml-alphanumeric-chars)))))
 
 (add-to-list 'def-use-mode-to-move-to-symbol-start-alist
              (cons 'sml-mode (function esml-du-move-to-symbol-start)))
 
 (defun esml-du-move-to-symbol-end ()
-  "Moves to the end of the SML symbol at point."
+  "Moves to the end of the SML symbol at point assuming that we are at the
+beginning of the symbol."
   (let ((limit (def-use-point-at-next-line)))
     (when (zerop (skip-chars-forward esml-sml-alphanumeric-chars limit))
       (skip-chars-forward esml-sml-symbolic-chars limit))))
@@ -191,23 +222,40 @@
           (esml-du-ctx-attr ctx))
     (esml-du-load ctx)))
 
+(defun esml-du-try-to-read-symbol-at-ref-once (ref ctx)
+  (when (search-forward (esml-du-ref-to-appx-syntax ref) nil t)
+    (when (eq 'lazy esml-du-background-parsing)
+      (esml-du-parse ctx))
+    (beginning-of-line)
+    (while (= ?\  (char-after))
+      (forward-line -1))
+    (esml-du-read-one-symbol ctx)))
+
+(defun esml-du-try-to-read-all-symbols-at-ref (ref ctx)
+  (let ((syms nil))
+    (goto-char 1)
+    (while (let ((sym (esml-du-try-to-read-symbol-at-ref-once ref ctx)))
+             (when sym
+               (push sym syms))))
+    syms))
+
 (defun esml-du-try-to-read-symbol-at-ref (ref ctx)
-  "Tries to read the symbol at the specified ref from the duf."
+  "Tries to read the symbol at the specified ref from the duf.  Returns
+non-nil if something was actually read."
   (let ((buffer (esml-du-ctx-buf ctx)))
     (when buffer
+      (bury-buffer buffer)
       (with-current-buffer buffer
-        (goto-char 1)
-        (when (search-forward (esml-du-ref-to-appx-syntax ref) nil t)
-          (when (eq 'lazy esml-du-background-parsing)
-            (esml-du-parse ctx))
-          (beginning-of-line)
-          (while (= ?\  (char-after))
-            (forward-line -1))
-          (let ((start (point)))
-            (esml-du-read-one-symbol ctx)
-            (setq buffer-read-only nil)
-            (delete-backward-char (- (point) start))
-            (setq buffer-read-only t)))))))
+        (let ((syms (esml-du-try-to-read-all-symbols-at-ref ref ctx)))
+          (when syms
+            (while syms
+              (let* ((sym (pop syms))
+                     (more-syms
+                      (esml-du-try-to-read-all-symbols-at-ref
+                       (def-use-sym-ref sym) ctx)))
+                (when more-syms
+                  (setq syms (nconc more-syms syms)))))
+            t))))))
 
 (defun esml-du-ref-to-appx-syntax (ref)
   (let ((pos (def-use-ref-pos ref)))
@@ -217,9 +265,10 @@
      (int-to-string (1+ (def-use-pos-col pos))))))
 
 (defun esml-du-read-one-symbol (ctx)
-  "Reads one symbol from the current buffer starting at the current
-point."
-  (let* ((ref-to-sym (esml-du-ctx-ref-to-sym-table ctx))
+  "Reads one symbol from the current buffer starting at the current point.
+Returns the symbol read and deletes the read symbol from the buffer."
+  (let* ((start (point))
+         (ref-to-sym (esml-du-ctx-ref-to-sym-table ctx))
          (sym-to-uses (esml-du-ctx-sym-to-uses-table ctx))
          (class (def-use-intern (esml-du-read "^ " " ")))
          (name (def-use-intern (esml-du-read "^ " " ")))
@@ -231,16 +280,33 @@
          (sym (def-use-sym class name ref
                 (cdr (assoc class esml-du-classes))))
          (uses nil))
-    (puthash ref sym ref-to-sym)
+    (let ((old-sym (gethash ref ref-to-sym)))
+      (when old-sym
+        (setq sym old-sym))
+      (puthash ref sym ref-to-sym))
     (while (< 0 (skip-chars-forward " "))
       (let* ((src (def-use-file-truename (esml-du-read "^ " " ")))
              (line (string-to-int (esml-du-read "^." ".")))
              (col (1- (string-to-int (esml-du-read "^\n" "\n"))))
              (pos (def-use-pos line col))
              (ref (def-use-ref src pos)))
-        (puthash ref sym (esml-du-ctx-ref-to-sym-table ctx))
+        (let ((old-sym (gethash ref ref-to-sym)))
+          (when old-sym
+            (let ((old-uses (gethash old-sym sym-to-uses)))
+              (remhash old-sym sym-to-uses)
+              (mapc
+               (function
+                (lambda (ref)
+                  (puthash ref sym ref-to-sym)))
+               old-uses)
+              (setq uses (nconc uses old-uses)))))
+        (puthash ref sym ref-to-sym)
         (push ref uses)))
-    (puthash sym uses sym-to-uses)))
+    (puthash sym uses sym-to-uses)
+    (setq buffer-read-only nil)
+    (delete-backward-char (- (point) start))
+    (setq buffer-read-only t)
+    sym))
 
 (defun esml-du-load (ctx)
   "Loads the def-use file to a buffer for parsing and performing queries."
@@ -290,10 +356,7 @@
       (lambda (ctx)
         (with-current-buffer (esml-du-ctx-buf ctx)
           (goto-char 1)
-          (esml-du-read-one-symbol ctx)
-          (setq buffer-read-only nil)
-          (delete-backward-char (1- (point)))
-          (setq buffer-read-only t))))
+          (esml-du-read-one-symbol ctx))))
      (function
       (lambda (ctx)
         (esml-du-stop-parsing ctx)

Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el	2007-02-25 22:15:53 UTC (rev 5323)
@@ -17,6 +17,20 @@
   "A string of all Standard ML alphanumeric characters as defined in
 section 2.4 of the Definition.")
 
+(defconst esml-sml-symbolic-keywords '("#" "*" "->" ":" "::" ":>" "=" "=>" "|")
+  "A list of symbolic keywords or reserved words as defined in sections
+2.1 and section 3.1 and including the special symbol * mentioned in 2.4 as
+well as the symbol :: mentioned in section 2.9 of the Definition.")
+
+(defconst esml-sml-alphanumeric-keywords
+  '("_" "abstype" "and" "andalso" "as" "case" "datatype" "do" "else" "end"
+    "eqtype" "exception" "false" "fn" "fun" "functor" "handle" "if" "in"
+    "include" "infix" "infixr" "let" "local" "nil" "nonfix" "of" "op" "open"
+    "orelse" "raise" "rec" "ref" "sharing" "sig" "signature" "struct"
+    "structure" "then" "true" "type" "val" "where" "while" "with" "withtype")
+  "A list of alphanumeric keywords or reserved words as well as
+non-bindable identifiers defined in various sections of the Definition")
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Some general purpose Emacs Lisp utility functions
 

Modified: mlton/branches/on-20050822-x86_64-branch/mlnlffigen/gen.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlnlffigen/gen.sml	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/mlnlffigen/gen.sml	2007-02-25 22:15:53 UTC (rev 5323)
@@ -410,9 +410,21 @@
    in
       fun smlFileAndExport (file,export,do_export) = 
          let
-            (* we don't want apostrophes in file names -> turn them into minuses *)
-            val file = Vector.map (file, fn #"'" => #"-" | c => c)
-            val file = OS.Path.joinBaseExt {base = file, ext = SOME "sml"}
+            (* We don't want apostrophes in file names -> turn them into minuses.
+             * We also want to use only lowercase characters as some file systems
+             * are case insensitive.
+             *)
+            val base = Vector.map (file, fn #"'" => #"-" | c => Char.toLower c)
+            fun pick i = let
+               val file = OS.Path.joinBaseExt
+                             {base = if i=0 then base
+                                     else concat [base, "-", Int.toString i],
+                              ext = SOME "sml"}
+            in
+               if List.exists (!files, fn f => f = file) then pick (i+1)
+               else file
+            end
+            val file = pick 0
             val result = OS.Path.joinDirFile {dir = dir, file = file}
          in
             checkDir ()

Modified: mlton/branches/on-20050822-x86_64-branch/regression/exnHistory.ok
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/regression/exnHistory.ok	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/regression/exnHistory.ok	2007-02-25 22:15:53 UTC (rev 5323)
@@ -1,4 +1,4 @@
-f.raise exnHistory.sml 3.18
+f.<raise> exnHistory.sml 3.18
 f exnHistory.sml 1.5
 f exnHistory.sml 1.5
 f exnHistory.sml 1.5
@@ -10,3 +10,4 @@
 f exnHistory.sml 1.5
 f exnHistory.sml 1.5
 f exnHistory.sml 1.5
+<main>

Modified: mlton/branches/on-20050822-x86_64-branch/regression/exnHistory3.ok
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/regression/exnHistory3.ok	2007-02-25 22:00:41 UTC (rev 5322)
+++ mlton/branches/on-20050822-x86_64-branch/regression/exnHistory3.ok	2007-02-25 22:15:53 UTC (rev 5323)
@@ -1,4 +1,4 @@
-f.raise exnHistory3.sml 5.18
+f.<raise> exnHistory3.sml 5.18
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
@@ -10,8 +10,9 @@
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
+<main>
 ZZZ
-f.raise exnHistory3.sml 5.18
+f.<raise> exnHistory3.sml 5.18
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
@@ -23,3 +24,4 @@
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
 f exnHistory3.sml 3.5
+<main>




More information about the MLton-commit mailing list