mlton-commit — [MLton-commit] Code commits

[MLton-commit] r5013

[Vesa K. <ve...@ml...>]

Simplified.
----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h

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

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h	2006-12-31 02:01:21 UTC (rev 5012)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h	2006-12-31 02:43:51 UTC (rev 5013)
@@ -4,12 +4,12 @@
  * See the LICENSE file or http://mlton.org/License for details.
  */
 
-#define STATIC_ASSERT(c)                                        \
-extern void static_assert(int static_assert[(c) ? 1 : -1])
+#define STATIC_ASSERT(c)                        \
+extern int static_assert[(c) ? 1 : -1]
 
 #define ASSERT_EXISTS(name, type)                                       \
-extern int exists_##name(type* assert_exists);                          \
-extern void exists_aux_##name(int assert_exists[sizeof(exists_##name(&name))]);
+extern type* assert_exists_##name;                                      \
+extern int assert_exists[1+0*sizeof(assert_exists_##name = &name)];
 
 #define CONSTANT(name, type)                    \
 STATIC_ASSERT(sizeof(type) == sizeof(name));    \

[MLton-commit] r5012

[Vesa K. <ve...@ml...>]

Changed approach.  The public headers are now macroized and used both as
inputs to mlnlffigen and to gcc (to generate C-side stubs).  When the
public headers are compiled with gcc, some static checks are being
performed to help ensure consistency.

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

U   mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
D   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/
U   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/declare.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h
U   mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb
_U  mltonlib/trunk/org/mlton/vesak/libc/unstable/public/
D   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/errno.h
U   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/string.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/time.h

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

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-31 02:01:21 UTC (rev 5012)
@@ -8,18 +8,18 @@
 target_id   := $(target_arch)-$(target_os)
 
 lib_file    := libc-nlffi-$(target_id).a
-mlb_file    := libc.mlb
 
-config_h    := public/config-$(target_id).h
-cc_opts     := -Wall -std=c99
+config_h    := public/config/$(target_id).h
+cc_opts     := -Wall -Werror -pedantic -std=c99
 
 bin_dir     := .bin/$(target_id)
 gen_dir     := generated/$(target_id)
 
-c_dir       := detail/c
-c_files     := $(wildcard $(c_dir)/*.c)
-o_files     := $(patsubst $(c_dir)/%.c,$(bin_dir)/%.o,$(c_files))
+dummy_c     := generated/dummy.c
 
+std_h_files := $(wildcard public/*.h)
+all_h_files := $(wildcard detail/*.h) $(config_h) $(std_h_files)
+
 .PHONY : all clean help
 
 help :
@@ -28,27 +28,45 @@
 	@echo "    clean    Removes generated files"
 	@echo "    help     Prints this message"
 
-all : $(gen_dir)/$(mlb_file) $(lib_file)
+all : $(gen_dir)/config/lib.mlb $(gen_dir)/std/lib.mlb $(lib_file)
 
 clean :
-	rm -rf $(gen_dir) $(bin_dir) $(config_h) $(lib_file)
+	rm -rf           \
+	   $(bin_dir)    \
+	   $(config_h)   \
+	   $(dummy_c)    \
+	   $(gen_dir)    \
+	   $(lib_file)
 
 $(config_h) : detail/config-gen.c
-	mkdir -p $(bin_dir)
+	@mkdir -p $(bin_dir) $(@D)
 	gcc $(cc_opts) -o $(bin_dir)/config-gen $<
 	$(bin_dir)/config-gen > $@
 
-$(gen_dir)/$(mlb_file) : $(config_h) $(wildcard public/*.h)
-	mkdir -p $(gen_dir)
-	mlnlffigen -dir $(gen_dir)                                         \
-	           -mlbfile $(mlb_file)                                    \
-	           -cppopt '-U$(target_arch) -DTARGET_ARCH=$(target_arch)' \
-	           -cppopt '-U$(target_os) -DTARGET_OS=$(target_os)'       \
-	           -linkage static $^
+$(gen_dir)/config/lib.mlb : $(config_h) $(gen_dir)
+	mlnlffigen -dir $(@D)                          \
+	           -mlbfile $(@F)                      \
+	           -linkage static $(config_h)
 
-$(lib_file) : $(o_files)
-	ar cr $@ $^
+$(gen_dir)/std/lib.mlb : $(all_h_files) $(gen_dir)
+	mlnlffigen -dir $(@D)                          \
+	           -mlbfile $(@F)                      \
+	           -cppopt '-include detail/declare.h' \
+	           -cppopt '-include $(config_h)'      \
+	           -linkage static $(std_h_files)
 
-$(bin_dir)/%.o : $(c_dir)/%.c
-	mkdir -p $(bin_dir)
-	gcc $(cc_opts) -c -o $@ $<
+$(lib_file) : $(all_h_files) $(dummy_c)
+	gcc $(cc_opts)                                         \
+	    -c                                                 \
+	    -o $(bin_dir)/libc-nlffi.o                         \
+	    $(patsubst public/%.h,-include %.h,$(std_h_files)) \
+	    -include detail/define.h                           \
+	    $(patsubst %.h,-include %.h,$(std_h_files))        \
+	    $(dummy_c)
+	ar cr $@ $(bin_dir)/libc-nlffi.o
+
+$(dummy_c) :
+	@touch $@
+
+$(gen_dir) :
+	@mkdir -p $@

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c	2006-12-31 02:01:21 UTC (rev 5012)
@@ -21,6 +21,7 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
+#include <time.h>
 
 /************************************************************************/
 
@@ -48,18 +49,18 @@
 choose_integer_type(const size_t size, const integer_kind kind) {
   switch (kind) {
   case signed_integer:
-    if (sizeof(signed char) == size) return "signed char";
+    if (sizeof(signed char) == size) return "char";
     if (sizeof(short) == size) return "short";
     if (sizeof(int) == size) return "int";
     if (sizeof(long) == size) return "long";
     if (sizeof(long long) == size) return "long long";
     break;
   case unsigned_integer:
-    if (sizeof(unsigned char) == size) return "unsigned char";
-    if (sizeof(unsigned short) == size) return "unsigned short";
-    if (sizeof(unsigned int) == size) return "unsigned int";
-    if (sizeof(unsigned long) == size) return "unsigned long";
-    if (sizeof(unsigned long long) == size) return "unsigned long long";
+    if (sizeof(unsigned char) == size) return "char";
+    if (sizeof(unsigned short) == size) return "short";
+    if (sizeof(unsigned int) == size) return "int";
+    if (sizeof(unsigned long) == size) return "long";
+    if (sizeof(unsigned long long) == size) return "long long";
     break;
   }
   fail("Couldn't find a %s type of %zd bytes.",
@@ -71,10 +72,7 @@
 
 static void
 print_header(void) {
-  printf("#ifndef CONFIG_H\n"
-         "#define CONFIG_H\n"
-         "\n"
-         "/* THIS FILE IS GENERATED.  DO NOT EDIT! */\n");
+  printf("/* THIS FILE IS GENERATED.  DO NOT EDIT! */\n");
 }
 
 static void
@@ -89,13 +87,14 @@
 print_integer_type(const size_t size,
                    const integer_kind kind,
                    const char *name) {
-  printf("typedef %s %s;\n", choose_integer_type(size, kind), name);
+  printf("typedef %8s %-12s %s;\n",
+         kind == signed_integer ? "signed" : "unsigned",
+         choose_integer_type(size, kind),
+         name);
 }
 
 static void
 print_footer(void) {
-  printf("\n"
-         "#endif\n");
 }
 
 /************************************************************************/
@@ -151,6 +150,11 @@
   INTEGER_TYPE(intmax_t);
   INTEGER_TYPE(uintmax_t);
 
+  print_separator("time.h");
+
+  INTEGER_TYPE(clock_t);
+  INTEGER_TYPE(time_t);
+
   print_separator("wchar.h");
 
   INTEGER_TYPE(wchar_t);

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/declare.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/declare.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/declare.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -0,0 +1,27 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#define CONSTANT(name, type)                    \
+extern const type name##_;
+
+#define FUNCTION(name, result, args)            \
+result name args;
+
+#define PSEUDO_CONSTANT(name, type)             \
+type name##_get(void);
+
+#define PSEUDO_VARIABLE(name, type)             \
+type name##_get(void);                          \
+void name##_set(type name##_);
+
+#define ABSTRACT_STRUCT(name)                   \
+struct name;
+
+#define ABSTRACT_TYPE(name)                     \
+typedef struct name name;
+
+/* mlnlffigen can't parse restrict */
+#define restrict


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/declare.h
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -0,0 +1,33 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#define STATIC_ASSERT(c)                                        \
+extern void static_assert(int static_assert[(c) ? 1 : -1])
+
+#define ASSERT_EXISTS(name, type)                                       \
+extern int exists_##name(type* assert_exists);                          \
+extern void exists_aux_##name(int assert_exists[sizeof(exists_##name(&name))]);
+
+#define CONSTANT(name, type)                    \
+STATIC_ASSERT(sizeof(type) == sizeof(name));    \
+const type name##_ = name;
+
+#define FUNCTION(name, result, args)            \
+typedef result name##_type args;                \
+ASSERT_EXISTS(name, name##_type)
+
+#define PSEUDO_CONSTANT(name, type)             \
+STATIC_ASSERT(sizeof(type) == sizeof(name));    \
+type name##_get(void) {return name;}
+
+#define PSEUDO_VARIABLE(name, type)             \
+STATIC_ASSERT(sizeof(type) == sizeof(name));    \
+type name##_get(void) {return name;}            \
+void name##_set(type name##_) {name = name##_;}
+
+#define ABSTRACT_STRUCT(name)
+
+#define ABSTRACT_TYPE(name)


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/define.h
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb	2006-12-31 02:01:21 UTC (rev 5012)
@@ -4,4 +4,5 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-generated/$(TARGET_ARCH)-$(TARGET_OS)/libc.mlb
+generated/$(TARGET_ARCH)-$(TARGET_OS)/config/lib.mlb
+generated/$(TARGET_ARCH)-$(TARGET_OS)/std/lib.mlb


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public
___________________________________________________________________
Name: svn:ignore
   - config-*-*.h

   + config


Deleted: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -1,21 +0,0 @@
-#ifndef COMMON_H
-#define COMMON_H
-
-/* Copyright (C) 2006 Vesa Karvonen
- *
- * This code is released under the MLton license, a BSD-style license.
- * See the LICENSE file or http://mlton.org/License for details.
- */
-
-#if !defined(TARGET_ARCH) || !defined(TARGET_OS)
-#error TARGET_ARCH and TARGET_OS must be defined
-#endif
-
-#define STRINGIFY(x) STRINGIFY_DELAY(x)
-#define STRINGIFY_DELAY(x) #x
-
-#include STRINGIFY(config-TARGET_ARCH-TARGET_OS.h)
-
-#define restrict /* mlnlffigen can't parse restrict ATM */
-
-#endif

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/errno.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/errno.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/errno.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -0,0 +1,11 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+CONSTANT(EDOM   , int)
+CONSTANT(EILSEQ , int)
+CONSTANT(ERANGE , int)
+
+PSEUDO_VARIABLE(errno   , int)


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/errno.h
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -1,80 +1,75 @@
-#ifndef STDIO_H
-#define STDIO_H
-
 /* Copyright (C) 2006 Vesa Karvonen
  *
  * This code is released under the MLton license, a BSD-style license.
  * See the LICENSE file or http://mlton.org/License for details.
  */
 
-#include "common.h"
+ABSTRACT_TYPE(FILE)
+ABSTRACT_TYPE(fpos_t)
 
-typedef struct FILE FILE;
-typedef struct fpos_t fpos_t;
+CONSTANT(BUFSIZ         , size_t)
+CONSTANT(EOF            , int)
+CONSTANT(FILENAME_MAX   , int)
+CONSTANT(FOPEN_MAX      , int)
+CONSTANT(L_tmpnam       , int)
+CONSTANT(SEEK_CUR       , int)
+CONSTANT(SEEK_END       , int)
+CONSTANT(SEEK_SET       , int)
+CONSTANT(TMP_MAX        , int)
+CONSTANT(_IOFBF         , int)
+CONSTANT(_IOLBF         , int)
+CONSTANT(_IONBF         , int)
 
-extern const int EOF_;
-extern const int FILENAME_MAX_;
-extern const int FOPEN_MAX_;
-extern const int L_tmpnam_;
-extern const int SEEK_CUR_;
-extern const int SEEK_END_;
-extern const int SEEK_SET_;
-extern const int TMP_MAX_;
-extern const int _IOFBF_;
-extern const int _IOLBF_;
-extern const int _IONBF_;
-extern const size_t BUFSIZ_;
+PSEUDO_CONSTANT(stderr  , FILE *)
+PSEUDO_CONSTANT(stdin   , FILE *)
+PSEUDO_CONSTANT(stdout  , FILE *)
 
-FILE *stderr_(void);
-FILE *stdin_(void);
-FILE *stdout_(void);
+FUNCTION(clearerr   , void      , (FILE *stream))
+FUNCTION(fclose     , int       , (FILE *stream))
+FUNCTION(feof       , int       , (FILE *stream))
+FUNCTION(ferror     , int       , (FILE *stream))
+FUNCTION(fflush     , int       , (FILE *stream))
+FUNCTION(fgetc      , int       , (FILE *stream))
+FUNCTION(fgetpos    , int       , (FILE * restrict stream, fpos_t * restrict pos))
+FUNCTION(fgets      , char *    , (char * restrict s, int n, FILE * restrict stream))
+FUNCTION(fopen      , FILE *    , (const char * restrict filename, const char * restrict mode))
+FUNCTION(fputc      , int       , (int c, FILE *stream))
+FUNCTION(fputs      , int       , (const char * restrict s, FILE * restrict stream))
+FUNCTION(fread      , size_t    , (void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream))
+FUNCTION(freopen    , FILE *    , (const char * restrict filename, const char * restrict mode, FILE * restrict stream))
+FUNCTION(fseek      , int       , (FILE *stream, long int offset, int whence))
+FUNCTION(fsetpos    , int       , (FILE *stream, const fpos_t *pos))
+FUNCTION(ftell      , long      , (FILE *stream))
+FUNCTION(fwrite     , size_t    , (const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream))
+FUNCTION(getc       , int       , (FILE *stream))
+FUNCTION(getchar    , int       , (void))
+FUNCTION(gets       , char *    , (char *s))
+FUNCTION(perror     , void      , (const char *s))
+FUNCTION(putc       , int       , (int c, FILE *stream))
+FUNCTION(putchar    , int       , (int c))
+FUNCTION(puts       , int       , (const char *s))
+FUNCTION(remove     , int       , (const char *filename))
+FUNCTION(rename     , int       , (const char *old, const char *new))
+FUNCTION(rewind     , void      , (FILE *stream))
+FUNCTION(setbuf     , void      , (FILE * restrict stream, char * restrict buf))
+FUNCTION(setvbuf    , int       , (FILE * restrict stream, char * restrict buf, int mode, size_t size))
+FUNCTION(tmpfile    , FILE *    , (void))
+FUNCTION(tmpnam     , char *    , (char *s))
+FUNCTION(ungetc     , int       , (int c, FILE *stream))
 
-int remove(const char *filename);
-int rename(const char *old, const char *new);
-FILE *tmpfile(void);
-char *tmpnam(char *s);
-int fclose(FILE *stream);
-int fflush(FILE *stream);
-FILE *fopen(const char * restrict filename, const char * restrict mode);
-FILE *freopen(const char * restrict filename, const char * restrict mode,
-FILE * restrict stream);
-void setbuf(FILE * restrict stream, char * restrict buf);
-int setvbuf(FILE * restrict stream, char * restrict buf, int mode, size_t size);
-/* int fprintf(FILE * restrict stream, const char * restrict format, ...); */
-/* int fscanf(FILE * restrict stream, const char * restrict format, ...); */
-/* int printf(const char * restrict format, ...); */
-/* int scanf(const char * restrict format, ...); */
-/* int snprintf(char * restrict s, size_t n, const char * restrict format, ...); */
-/* int sprintf(char * restrict s, const char * restrict format, ...); */
-/* int sscanf(const char * restrict s, const char * restrict format, ...); */
-/* int vfprintf(FILE * restrict stream, const char * restrict format, va_list arg); */
-/* int vfscanf(FILE * restrict stream, const char * restrict format, va_list arg); */
-/* int vprintf(const char * restrict format, va_list arg); */
-/* int vscanf(const char * restrict format, va_list arg); */
-/* int vsnprintf(char * restrict s, size_t n, const char * restrict format, va_list arg); */
-/* int vsprintf(char * restrict s, const char * restrict format, va_list arg); */
-/* int vsscanf(const char * restrict s, const char * restrict format, va_list arg); */
-int fgetc(FILE *stream);
-char *fgets(char * restrict s, int n, FILE * restrict stream);
-int fputc(int c, FILE *stream);
-int fputs(const char * restrict s, FILE * restrict stream);
-int getc(FILE *stream);
-int getchar(void);
-char *gets(char *s);
-int putc(int c, FILE *stream);
-int putchar(int c);
-int puts(const char *s);
-int ungetc(int c, FILE *stream);
-size_t fread(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream);
-size_t fwrite(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream);
-int fgetpos(FILE * restrict stream, fpos_t * restrict pos);
-int fseek(FILE *stream, long int offset, int whence);
-int fsetpos(FILE *stream, const fpos_t *pos);
-long int ftell(FILE *stream);
-void rewind(FILE *stream);
-void clearerr(FILE *stream);
-int feof(FILE *stream);
-int ferror(FILE *stream);
-void perror(const char *s);
-
+#if 0
+FUNCTION(fprintf    , int       , (FILE * restrict stream, const char * restrict format, ...))
+FUNCTION(fscanf     , int       , (FILE * restrict stream, const char * restrict format, ...))
+FUNCTION(printf     , int       , (const char * restrict format, ...))
+FUNCTION(scanf      , int       , (const char * restrict format, ...))
+FUNCTION(snprintf   , int       , (char * restrict s, size_t n, const char * restrict format, ...))
+FUNCTION(sprintf    , int       , (char * restrict s, const char * restrict format, ...))
+FUNCTION(sscanf     , int       , (const char * restrict s, const char * restrict format, ...))
+FUNCTION(vfprintf   , int       , (FILE * restrict stream, const char * restrict format, va_list arg))
+FUNCTION(vfscanf    , int       , (FILE * restrict stream, const char * restrict format, va_list arg))
+FUNCTION(vprintf    , int       , (const char * restrict format, va_list arg))
+FUNCTION(vscanf     , int       , (const char * restrict format, va_list arg))
+FUNCTION(vsnprintf  , int       , (char * restrict s, size_t n, const char * restrict format, va_list arg))
+FUNCTION(vsprintf   , int       , (char * restrict s, const char * restrict format, va_list arg))
+FUNCTION(vsscanf    , int       , (const char * restrict s, const char * restrict format, va_list arg))
 #endif

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/string.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/string.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/string.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -0,0 +1,28 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+FUNCTION(memchr     , void *    , (const void *s, int c, size_t n))
+FUNCTION(memcmp     , int       , (const void *s1, const void *s2, size_t n))
+FUNCTION(memcpy     , void *    , (void * restrict s1, const void * restrict s2, size_t n))
+FUNCTION(memmove    , void *    , (void *s1, const void *s2, size_t n))
+FUNCTION(memset     , void *    , (void *s, int c, size_t n))
+FUNCTION(strcat     , char *    , (char * restrict s1, const char * restrict s2))
+FUNCTION(strchr     , char *    , (const char *s, int c))
+FUNCTION(strcmp     , int       , (const char *s1, const char *s2))
+FUNCTION(strcoll    , int       , (const char *s1, const char *s2))
+FUNCTION(strcpy     , char *    , (char * restrict s1, const char * restrict s2))
+FUNCTION(strcspn    , size_t    , (const char *s1, const char *s2))
+FUNCTION(strerror   , char *    , (int errnum))
+FUNCTION(strlen     , size_t    , (const char *s))
+FUNCTION(strncat    , char *    , (char * restrict s1, const char * restrict s2, size_t n))
+FUNCTION(strncmp    , int       , (const char *s1, const char *s2, size_t n))
+FUNCTION(strncpy    , char *    , (char * restrict s1, const char * restrict s2, size_t n))
+FUNCTION(strpbrk    , char *    , (const char *s1, const char *s2))
+FUNCTION(strrchr    , char *    , (const char *s, int c))
+FUNCTION(strspn     , size_t    , (const char *s1, const char *s2))
+FUNCTION(strstr     , char *    , (const char *s1, const char *s2))
+FUNCTION(strtok     , char *    , (char * restrict s1, const char * restrict s2))
+FUNCTION(strxfrm    , size_t    , (char * restrict s1, const char * restrict s2, size_t n))


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/string.h
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/time.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/time.h	2006-12-30 08:28:52 UTC (rev 5011)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/time.h	2006-12-31 02:01:21 UTC (rev 5012)
@@ -0,0 +1,30 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+ABSTRACT_STRUCT(tm)
+
+CONSTANT(CLOCKS_PER_SEC     , clock_t)
+
+FUNCTION(asctime    , char *        , (const struct tm *timeptr))
+FUNCTION(clock      , clock_t       , (void))
+FUNCTION(ctime      , char *        , (const time_t *timer))
+FUNCTION(difftime   , double        , (time_t time1, time_t time0))
+FUNCTION(gmtime     , struct tm *   , (const time_t *timer))
+FUNCTION(localtime  , struct tm *   , (const time_t *timer))
+FUNCTION(mktime     , time_t        , (struct tm *timeptr))
+FUNCTION(strftime   , size_t        , (char * restrict s, size_t maxsize, const char * restrict format, const struct tm * restrict timeptr))
+FUNCTION(time       , time_t        , (time_t *timer))
+
+#if 0
+ABSTRACT_STRUCT(tmx)
+
+CONSTANT(_LOCALTIME         , int)
+CONSTANT(_NO_LEAP_SECONDS   , int)
+
+FUNCTION(mkxtime    , time_t        , (struct tmx *timeptr))
+FUNCTION(strfxtime  , size_t        , (char * restrict s, size_t maxsize, const char * restrict format, const struct tmx * restrict timeptr))
+FUNCTION(zonetime   , struct tmx *  , (const time_t *timer))
+#endif


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/time.h
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5011

[Stephen W. <sw...@ml...>]

Fixed bug, introduced in r3901, which change had caused extra "new"
types to be created when instantiating a constructor pattern.  These
new types would then be generalized over (not occuring freely in the
environment), and appear as unused type arguments.  This didn't
actually cause bad code -- but it did cause larger and larger lists of
type variable list to be created, which would cause performance
problems during elaboration of large programs.  (e.g. I saw over a
million tyvar arguments to a single var when elaborating a 300k line
program)


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

U   mlton/trunk/mlton/elaborate/elaborate-core.fun
U   mlton/trunk/mlton/elaborate/type-env.fun
U   mlton/trunk/mlton/elaborate/type-env.sig

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

Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun	2006-12-29 22:42:15 UTC (rev 5010)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun	2006-12-30 08:28:52 UTC (rev 5011)
@@ -658,10 +658,7 @@
                                            val {args, instance} =
                                               Scheme.instantiate s
                                         in
-                                           if Type.canUnify
-                                              (instance,
-                                               Type.arrow (Type.new (),
-                                                           Type.new ()))
+                                           if Type.isArrow instance
                                               then
                                                  (Control.error
                                                   (region,

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2006-12-29 22:42:15 UTC (rev 5010)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2006-12-30 08:28:52 UTC (rev 5011)
@@ -720,6 +720,8 @@
       fun new () = unknown {canGeneralize = true,
                             equality = Equality.unknown ()}
 
+      val new = Trace.trace ("TypeEnv.Type.new", Unit.layout, layout) new
+
       fun newFlex {fields, spine} =
          newTy (FlexRecord {fields = fields,
                             spine = spine},
@@ -776,6 +778,11 @@
 
       val unit = tuple (Vector.new0 ())
 
+      fun isArrow t =
+         case toType t of
+            Con (c, _) => Tycon.equals (c, Tycon.arrow)
+          | _ => false
+
       fun isBool t =
          case toType t of
             Con (c, _) => Tycon.isBool c
@@ -1654,7 +1661,7 @@
                                        Time.layout (!time),
                                        str " where getTime is ",
                                        Time.layout genTime],
-                                  Out.standard)
+                                  Out.error)
                       end
              in
                 if not (Time.<= (genTime, !time))

Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig	2006-12-29 22:42:15 UTC (rev 5010)
+++ mlton/trunk/mlton/elaborate/type-env.sig	2006-12-30 08:28:52 UTC (rev 5011)
@@ -38,6 +38,7 @@
                           record: 'a SortedRecord.t -> 'a,
                           replaceSynonyms: bool,
                           var: Tyvar.t -> 'a} -> 'a
+            val isArrow: t -> bool
             val isBool: t -> bool
             val isCharX: t -> bool
             val isExn: t -> bool

[MLton-commit] r5010

[Vesa K. <ve...@ml...>]

Fixed trunk to compile after the change to mlton/ast/prim-tycons.* in
r5008.

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

U   mlton/trunk/mlton/elaborate/elaborate-env.fun

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

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2006-12-29 20:05:19 UTC (rev 5009)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2006-12-29 22:42:15 UTC (rev 5010)
@@ -688,7 +688,7 @@
               uses = uses}))
    end
 
-val allTycons: Tycon.t list ref = ref (List.map (Tycon.prims, #1))
+val allTycons: Tycon.t list ref = ref (List.map (Tycon.prims, #tycon))
 val newTycons: (Tycon.t * Kind.t * Region.t) list ref = ref []
 
 val newTycon: string * Kind.t * AdmitsEquality.t * Region.t -> Tycon.t =

[MLton-commit] r5009

[Vesa K. <ve...@ml...>]

Added code to query path variables by running a command.

Removed additional annotations as those can be (and are) obtained
automatically by running a command.

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

U   mlton/trunk/ide/emacs/esml-mlb-mode.el

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

Modified: mlton/trunk/ide/emacs/esml-mlb-mode.el
===================================================================
--- mlton/trunk/ide/emacs/esml-mlb-mode.el	2006-12-29 19:31:55 UTC (rev 5008)
+++ mlton/trunk/ide/emacs/esml-mlb-mode.el	2006-12-29 20:05:19 UTC (rev 5009)
@@ -38,6 +38,10 @@
 ;; - find-binding-occurance (of a basid)
 ;; - support doc strings in mlb files
 
+;; TBD:
+;; - fix indentation bugs
+;; - use something more robust than `shell-command' to run shell commands
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Prelude
 
@@ -57,27 +61,18 @@
 Unrecognized
 - annotations (see `esml-mlb-show-annotations-command' and
                    `esml-mlb-additional-annotations'),
-- path variables (see `esml-mlb-mlb-path-map-files' and
+- path variables (see `esml-mlb-show-path-map-command',
+                      `esml-mlb-mlb-path-map-files', and
                       `esml-mlb-additional-path-variables'), and
 - path name suffices (see `esml-mlb-path-suffix-regexp') are
 highlighed as warnings."
   :group 'sml)
 
 (defcustom esml-mlb-additional-annotations
-  '(("allowConstant" "false" "true")
-    ("allowFFI" "false" "true")
-    ("allowOverload" "false" "true")
-    ("allowPrim" "false" "true")
-    ("allowRebindEquals" "false" "true")
-    ("deadCode" "false" "true")
-    ("ffiStr" "<longstrid>")
-    ("forceUsed")
-    ("nonexhaustiveExnMatch" "default" "ignore")
-    ("nonexhaustiveMatch" "warn" "ignore" "error")
-    ("redundantMatch" "warn" "ignore" "error")
-    ("sequenceNonUnit" "ignore" "error" "warn")
-    ("warnUnused" "false" "true"))
-  "Additional annotations accepted by your compiler(s)."
+  '()
+  "Additional annotations accepted by your compiler(s).  Note that ML
+Basis mode runs the `esml-mlb-show-annotations-command' to query available
+annotations automatically."
   :type '(repeat (cons :tag "Annotation"
                        (string :tag "Name")
                        (repeat :tag "Values starting with the default"
@@ -86,9 +81,10 @@
   :group 'esml-mlb)
 
 (defcustom esml-mlb-additional-path-variables
-  '(("LIB_MLTON_DIR" . "/usr/lib/mlton"))
+  '()
   "Additional path variables that can not be found in the path map files
-specified by `esml-mlb-mlb-path-map-files'."
+specified by `esml-mlb-mlb-path-map-files' or by running the command
+`esml-mlb-show-path-map-command'."
   :type '(repeat (cons (string :tag "Name") (string :tag "Value")))
   :set 'esml-mlb-set-custom-and-update
   :group 'esml-mlb)
@@ -136,7 +132,7 @@
 
 (defcustom esml-mlb-show-annotations-command
   "mlton -expert true -show anns"
-  "Shell command used to determine the annotations accepted by a compiler."
+  "Shell command used to query the available annotations."
   :type 'string
   :set 'esml-mlb-set-custom-and-update
   :group 'esml-mlb)
@@ -149,6 +145,13 @@
   :type 'string
   :group 'esml-mlb)
 
+(defcustom esml-mlb-show-path-map-command
+  "mlton -expert true -show path-map"
+  "Shell command used to query the available path variables."
+  :type 'string
+  :set 'esml-mlb-set-custom-and-update
+  :group 'esml-mlb)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Faces
 
@@ -195,21 +198,28 @@
   "An association list of known path variables. This variable is updated
 by `esml-mlb-update'.")
 
+(defun esml-mlb-parse-path-variables-from-string (path-map-string)
+  (mapcar (function
+           (lambda (s) (apply 'cons (esml-split-string s "[ \t]+"))))
+          (esml-split-string path-map-string "[ \t]*\n+[ \t]*")))
+
 (defun esml-mlb-parse-path-variables ()
   (setq esml-mlb-path-variables
         (remove-duplicates
          (sort (append
                 esml-mlb-additional-path-variables
+                (esml-mlb-parse-path-variables-from-string
+                 (with-temp-buffer
+                   (save-window-excursion
+                     (shell-command
+                      esml-mlb-show-path-map-command
+                      (current-buffer))
+                     (buffer-string))))
                 (loop for file in esml-mlb-mlb-path-map-files
-                  append (mapcar (function
-                                  (lambda (s)
-                                    (apply 'cons
-                                           (esml-split-string s "[ \t]+"))))
-                                 (esml-split-string
-                                  (with-temp-buffer
-                                    (insert-file-contents file)
-                                    (buffer-string))
-                                  "[ \t]*\n+[ \t]*"))))
+                  append (esml-mlb-parse-path-variables-from-string
+                          (with-temp-buffer
+                            (insert-file-contents file)
+                            (buffer-string)))))
                (function
                 (lambda (a b)
                   (string-lessp (car a) (car b)))))

[MLton-commit] r5008

[Stephen W. <sw...@ml...>]

Changed PrimTycons.all to be a list of records instead of tuples and
added a "name" field so that no code (in particular compile.fun)
depends on the originalName of a tycon (or any other id).

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

U   mlton/trunk/mlton/ast/prim-tycons.fun
U   mlton/trunk/mlton/ast/prim-tycons.sig
U   mlton/trunk/mlton/atoms/tycon.fun
U   mlton/trunk/mlton/elaborate/type-env.fun
U   mlton/trunk/mlton/main/compile.fun
U   mlton/trunk/mlton/xml/monomorphise.fun

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

Modified: mlton/trunk/mlton/ast/prim-tycons.fun
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.fun	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/ast/prim-tycons.fun	2006-12-29 19:31:55 UTC (rev 5008)
@@ -15,26 +15,26 @@
 
 type tycon = t
 
-val array = fromString "array"
-val arrow = fromString "->"
-val bool = fromString "bool"
-val exn = fromString "exn"
-val intInf = fromString "intInf"
-val list = fromString "list"
-val pointer = fromString "pointer"
-val reff = fromString "ref"
-val thread = fromString "thread"
-val tuple = fromString "*"
-val vector = fromString "vector"
-val weak = fromString "weak"
+local
+   fun make s = (s, fromString s)
+in
+   val array = make "array"
+   val arrow = make "->"
+   val bool = make "bool"
+   val exn = make "exn"
+   val intInf = make "intInf"
+   val list = make "list"
+   val pointer = make "pointer"
+   val reff = make "ref"
+   val thread = make "thread"
+   val tuple = make "*"
+   val vector = make "vector"
+   val weak = make "weak"
+end
 
 datatype z = datatype Kind.t
 datatype z = datatype AdmitsEquality.t
 
-val isBool = fn c => equals (c, bool)
-val isExn = fn c => equals (c, exn)
-val isPointer = fn c => equals (c, pointer)
-
 local
    fun 'a make (prefix: string,
                 all: 'a list,
@@ -45,22 +45,31 @@
       let
          val all =
             Vector.fromListMap
-            (all, fn s =>
-             (fromString (concat [prefix, Bits.toString (bits s)]), s))
+            (all, fn s => let
+               val name = concat [prefix, Bits.toString (bits s)]
+            in
+               {name = name,
+                size = s,
+                tycon = fromString name}
+            end)
          val fromSize =
             memo
             (fn s =>
-             case Vector.peek (all, fn (_, s') => equalsA (s, s')) of
+             case Vector.peek (all, fn {size = s', ...} => equalsA (s, s')) of
                 NONE => Error.bug "PrimTycons.make.fromSize"
-              | SOME (tycon, _) => tycon)
-         fun is t = Vector.exists (all, fn (t', _) => equals (t, t'))
+              | SOME {tycon, ...} => tycon)
+         fun is t = Vector.exists (all, fn {tycon = t', ...} => equals (t, t'))
          fun de t = 
-            case Vector.peek (all, fn (t', _) => equals (t, t')) of
+            case Vector.peek (all, fn {tycon = t', ...} => equals (t, t')) of
                NONE => Error.bug "PrimTycons.make.de"
-             | SOME (_, s') => s'
+             | SOME {size, ...} => size
          val prims =
-            Vector.toListMap (all, fn (tycon, _) =>
-                              (tycon, Arity 0, admitsEquality))
+            Vector.toListMap (all, fn {name, tycon, ...} =>
+                              {admitsEquality = admitsEquality,
+                               kind = Arity 0,
+                               name = name,
+                               tycon = tycon})
+         val all = Vector.map (all, fn {tycon, size, ...} => (tycon, size))
       in
          (fromSize, all, is, de, prims)
       end
@@ -91,6 +100,39 @@
       end
 end
 
+val prims =
+   List.map ([(array, Arity 1, Always),
+              (arrow, Arity 2, Never),
+              (bool, Arity 0, Sometimes),
+              (exn, Arity 0, Never),
+              (intInf, Arity 0, Sometimes),
+              (list, Arity 1, Sometimes),
+              (pointer, Arity 0, Always),
+              (reff, Arity 1, Always),
+              (thread, Arity 0, Never),
+              (tuple, Nary, Sometimes),
+              (vector, Arity 1, Sometimes),
+              (weak, Arity 1, Never)],
+             fn ((name, tycon), kind, admitsEquality) =>
+             {admitsEquality = admitsEquality,
+              kind = kind,
+              name = name,
+              tycon = tycon})
+   @ primChars @ primInts @ primReals @ primWords
+
+val array = #2 array
+val arrow = #2 arrow
+val bool = #2 bool
+val exn = #2 exn
+val intInf = #2 intInf
+val list = #2 list
+val pointer = #2 pointer
+val reff = #2 reff
+val thread = #2 thread
+val tuple = #2 tuple
+val vector = #2 vector
+val weak = #2 weak
+
 val defaultChar = fn () => 
    case !Control.defaultChar of
       "char8" => char CharSize.C8
@@ -116,24 +158,12 @@
     | "word64" => word (WordSize.fromBits (Bits.fromInt 64))
     | _ => Error.bug "PrimTycons.defaultWord"
 
+val isBool = fn c => equals (c, bool)
+val isExn = fn c => equals (c, exn)
+val isPointer = fn c => equals (c, pointer)
 val isIntX = fn c => equals (c, intInf) orelse isIntX c
 val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
 
-val prims =
-   [(array, Arity 1, Always),
-    (arrow, Arity 2, Never),
-    (bool, Arity 0, Sometimes),
-    (exn, Arity 0, Never),
-    (intInf, Arity 0, Sometimes),
-    (list, Arity 1, Sometimes),
-    (pointer, Arity 0, Always),
-    (reff, Arity 1, Always),
-    (thread, Arity 0, Never),
-    (tuple, Nary, Sometimes),
-    (vector, Arity 1, Sometimes),
-    (weak, Arity 1, Never)]
-   @ primChars @ primInts @ primReals @ primWords
-
 fun layoutApp (c: t,
                args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
    let

Modified: mlton/trunk/mlton/ast/prim-tycons.sig
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.sig	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/ast/prim-tycons.sig	2006-12-29 19:31:55 UTC (rev 5008)
@@ -61,7 +61,10 @@
          -> Layout.t * {isChar: bool, needsParen: bool}
       val list: tycon
       val pointer: tycon
-      val prims: (tycon * Kind.t * AdmitsEquality.t) list
+      val prims: {admitsEquality: AdmitsEquality.t,
+                  kind: Kind.t,
+                  name: string,
+                  tycon: tycon} list
       val real: RealSize.t -> tycon
       val reals: (tycon * RealSize.t) vector
       val reff: tycon

Modified: mlton/trunk/mlton/atoms/tycon.fun
===================================================================
--- mlton/trunk/mlton/atoms/tycon.fun	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/atoms/tycon.fun	2006-12-29 19:31:55 UTC (rev 5008)
@@ -35,7 +35,7 @@
       open Layout
    in
       align
-      (List.map (prims, fn (c, _, _) =>
+      (List.map (prims, fn {tycon = c, ...} =>
                  seq [layout c, str " size is ",
                       Int.layout (MLton.size c),
                       str " plist length is ",

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2006-12-29 19:31:55 UTC (rev 5008)
@@ -124,7 +124,8 @@
                      region = ref NONE,
                      time = ref (Time.now ())})
 
-val _ = List.foreach (Tycon.prims, fn (c, _, a) => initAdmitsEquality (c, a))
+val _ = List.foreach (Tycon.prims, fn {tycon = c, admitsEquality = a, ...} =>
+                      initAdmitsEquality (c, a))
 
 structure Equality:>
    sig

Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/main/compile.fun	2006-12-29 19:31:55 UTC (rev 5008)
@@ -242,10 +242,9 @@
             let
                val _ =
                   List.foreach
-                  (Tycon.prims, fn (tycon, kind, _) =>
+                  (Tycon.prims, fn {kind, name, tycon, ...} =>
                    extendTycon
-                   (E, Ast.Tycon.fromSymbol (Symbol.fromString
-                                             (Tycon.originalName tycon),
+                   (E, Ast.Tycon.fromSymbol (Symbol.fromString name,
                                              Region.bogus),
                     TypeStr.tycon (tycon, kind),
                     {forceUsed = false, isRebind = false}))

Modified: mlton/trunk/mlton/xml/monomorphise.fun
===================================================================
--- mlton/trunk/mlton/xml/monomorphise.fun	2006-12-29 17:52:05 UTC (rev 5007)
+++ mlton/trunk/mlton/xml/monomorphise.fun	2006-12-29 19:31:55 UTC (rev 5008)
@@ -94,7 +94,7 @@
          Property.destGetSet (Tycon.plist,
                               Property.initRaise ("mono", Tycon.layout))
       val _ =
-         List.foreach (Tycon.prims, fn (t, _, _) =>
+         List.foreach (Tycon.prims, fn {tycon = t, ...} =>
                        setTycon (t, fn ts => Stype.con (t, ts)))
       val {set = setTyvar, get = getTyvar: Tyvar.t -> Stype.t, ...} =
          Property.getSet (Tyvar.plist,

[MLton-commit] r5007

[Vesa K. <ve...@ml...>]

Use the new option -show anns to get annotations.

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

U   mlton/trunk/ide/emacs/esml-mlb-mode.el

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

Modified: mlton/trunk/ide/emacs/esml-mlb-mode.el
===================================================================
--- mlton/trunk/ide/emacs/esml-mlb-mode.el	2006-12-29 11:14:05 UTC (rev 5006)
+++ mlton/trunk/ide/emacs/esml-mlb-mode.el	2006-12-29 17:52:05 UTC (rev 5007)
@@ -135,7 +135,7 @@
   :group 'esml-mlb)
 
 (defcustom esml-mlb-show-annotations-command
-  "mlton -expert true -show-anns true"
+  "mlton -expert true -show anns"
   "Shell command used to determine the annotations accepted by a compiler."
   :type 'string
   :set 'esml-mlb-set-custom-and-update

[MLton-commit] r5006

[Vesa K. <ve...@ml...>]

Just doc tweaks.
----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/libc/unstable/README

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

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/README
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/README	2006-12-29 01:09:14 UTC (rev 5005)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/README	2006-12-29 11:14:05 UTC (rev 5006)
@@ -35,7 +35,7 @@
       defined by the compiler.  For example, with the mlton compiler
       running the command
 
-         mlton -show-path-map true | grep TARGET
+         mlton -show path-map | grep TARGET
 
       shows the variables.
 
@@ -46,7 +46,7 @@
 
    libc.mlb
 
-      This the MLB-file for the SML part of the libc interface.
+      This is the MLB-file for the SML part of the libc interface.
 
    detail/
 
@@ -56,6 +56,6 @@
 About Motivation and Scope
 --------------------------
 
-   The main motivation of this library is to make it easier to implement
-   bindings to C libraries.  This library should eventually include all
-   parts of libc that make sense from that perspective.
+   The main motivation behind this library is to make it easier to
+   implement bindings to C libraries.  This library should eventually
+   include all parts of libc that make sense from that perspective.

[MLton-commit] r5005

[Vesa K. <ve...@ml...>]

Use the new -show path-map switch.
----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile

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

Modified: mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-29 00:53:36 UTC (rev 5004)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-29 01:09:14 UTC (rev 5005)
@@ -3,10 +3,8 @@
 # This code is released under the MLton license, a BSD-style license.
 # See the LICENSE file or http://mlton.org/License for details.
 
-target_arch := $(shell mlton -show-path-map true | \
-                       awk '/^TARGET_ARCH/ {print $$2}')
-target_os   := $(shell mlton -show-path-map true | \
-                       awk '/^TARGET_OS/ {print $$2}')
+target_arch := $(shell mlton -show path-map | awk '/^TARGET_ARCH/ {print $$2}')
+target_os   := $(shell mlton -show path-map | awk '/^TARGET_OS/ {print $$2}')
 target_id   := $(target_arch)-$(target_os)
 
 lib_file    := libc-nlffi-$(target_id).a

[MLton-commit] r5004

[Vesa K. <ve...@ml...>]

Added command line switch -show {anns|path-map} and deprecated command
line switch -show-anns {false|true}.  Use -show path-map to see the
complete MLB path map as seen by the compiler.

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

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/control/control-flags.sig
U   mlton/trunk/mlton/control/control-flags.sml
U   mlton/trunk/mlton/front-end/mlb-front-end.fun
U   mlton/trunk/mlton/main/main.fun

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

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/doc/changelog	2006-12-29 00:53:36 UTC (rev 5004)
@@ -1,5 +1,15 @@
 Here are the changes since version 20051202.
 
+* 2006-12-29
+   - Added command line switch -show {anns|path-map} and deprecated command
+     line switch -show-anns {false|true}.  Use -show path-map to see the
+     complete MLB path map as seen by the compiler.
+
+* 2006-12-20
+   - Changed the output of command line switch -stop f to include mlb-files.
+     This is useful for generating Makefile dependencies.  The old output is
+     easy to recover if necessary (e.g. grep -v '\.mlb$').
+
 * 2006-12-8
    - Added command line switches -{,target}-{as,cc,link}-opt-quote, which
      pass their argument as a single argument to gcc (i.e., without

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sig	2006-12-29 00:53:36 UTC (rev 5004)
@@ -195,6 +195,8 @@
       val maxFunctionSize: int ref
 
       val mlbPathMaps: string list ref
+      val mlbPathMap: unit -> {var: string,
+                               path: string} list
 
       structure Native:
          sig

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sml	2006-12-29 00:53:36 UTC (rev 5004)
@@ -991,6 +991,49 @@
                         default = Linux,
                         toString = MLton.Platform.OS.toString}
 
+local
+   fun make (file: File.t) =
+      if not (File.canRead file) then
+         Error.bug (concat ["can't read MLB path map file: ", file])
+      else
+         List.keepAllMap
+         (File.lines file, fn line =>
+          if String.forall (line, Char.isSpace)
+             then NONE
+          else
+             case String.tokens (line, Char.isSpace) of
+                [var, path] => SOME {var = var, path = path}
+              | _ => Error.bug (concat ["strange mlb path mapping: ",
+                                        file, ":: ", line]))
+in
+   fun mlbPathMap () =
+      List.rev
+         (List.concat
+             [[{var = "LIB_MLTON_DIR",
+                path = !libDir},
+               {var = "TARGET_ARCH",
+                path = String.toLower (MLton.Platform.Arch.toString
+                                       (!targetArch))},
+               {var = "TARGET_OS",
+                path = String.toLower (MLton.Platform.OS.toString
+                                       (!targetOS))},
+               {var = "OBJPTR_REP",
+                path = "objptr-rep32.sml"},
+               {var = "HEADER_WORD",
+                path = "header-word32.sml"},
+               {var = "SEQINDEX_INT",
+                path = "seqindex-int32.sml"},
+               {var = "DEFAULT_CHAR",
+                path = concat ["default-", !defaultChar, ".sml"]},
+               {var = "DEFAULT_INT",
+                path = concat ["default-", !defaultInt, ".sml"]},
+               {var = "DEFAULT_REAL",
+                path = concat ["default-", !defaultReal, ".sml"]},
+               {var = "DEFAULT_WORD",
+                path = concat ["default-", !defaultWord, ".sml"]}],
+              List.concat (List.map (!mlbPathMaps, make))])
+end
+
 val typeCheck = control {name = "type check",
                          default = false,
                          toString = Bool.toString}

Modified: mlton/trunk/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/trunk/mlton/front-end/mlb-front-end.fun	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/front-end/mlb-front-end.fun	2006-12-29 00:53:36 UTC (rev 5004)
@@ -84,46 +84,8 @@
       val psi : (File.t * Ast.Basdec.t Promise.t) HashSet.t =
          HashSet.new {hash = String.hash o #1}
       local
-         fun make (file: File.t) =
-            if not (File.canRead file) then
-               Error.bug (concat ["can't read MLB path map file: ", file])
-            else
-               List.keepAllMap
-               (File.lines file, fn line =>
-                if String.forall (line, Char.isSpace)
-                   then NONE
-                else 
-                   case String.tokens (line, Char.isSpace) of
-                      [var, path] => SOME {var = var, path = path}
-                    | _ => Error.bug (concat ["strange mlb path mapping: ", 
-                                              file, ":: ", line]))
          val pathMap =
-            List.rev
-            (List.concat
-             [[{var = "LIB_MLTON_DIR", 
-                path = !Control.libDir},
-               {var = "TARGET_ARCH",
-                path = String.toLower (MLton.Platform.Arch.toString
-                                       (!Control.targetArch))},
-               {var = "TARGET_OS",
-                path = String.toLower (MLton.Platform.OS.toString
-                                       (!Control.targetOS))},
-               {var = "OBJPTR_REP",
-                path = "objptr-rep32.sml"},
-               {var = "HEADER_WORD",
-                path = "header-word32.sml"},
-               {var = "SEQINDEX_INT",
-                path = "seqindex-int32.sml"},
-               {var = "DEFAULT_CHAR",
-                path = concat ["default-", !Control.defaultChar, ".sml"]},
-               {var = "DEFAULT_INT",
-                path = concat ["default-", !Control.defaultInt, ".sml"]},
-               {var = "DEFAULT_REAL",
-                path = concat ["default-", !Control.defaultReal, ".sml"]},
-               {var = "DEFAULT_WORD",
-                path = concat ["default-", !Control.defaultWord, ".sml"]}],
-              List.concat (List.map (!Control.mlbPathMaps, make))])
-
+             Control.mlbPathMap ()
          fun peekPathMap var' =
             case List.peek (pathMap, fn {var,...} =>
                             var = var') of

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/main/main.fun	2006-12-29 00:53:36 UTC (rev 5004)
@@ -47,6 +47,11 @@
        | Yes 
    end
 
+structure Show =
+   struct
+      datatype t = Anns | PathMap
+   end
+
 val gcc: string ref = ref "<unset>"
 val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
 val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
@@ -65,7 +70,7 @@
 val profileSet: bool ref = ref false
 val profileTimeSet: bool ref = ref false
 val runtimeArgs: string list ref = ref ["@MLton"]
-val showAnns: bool ref = ref false
+val show: Show.t option ref = ref NONE
 val stop = ref Place.OUT
 
 val targetMap: unit -> {arch: MLton.Platform.Arch.t,
@@ -451,8 +456,20 @@
         boolRef profileStack),
        (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
         SpaceString (fn s => List.push (runtimeArgs, s))),
-       (Expert, "show-anns", " {false|true}", "show annotations",
-        boolRef showAnns),
+       (Expert, "show", " {anns|path-map}", "print specified data and stop",
+        SpaceString
+        (fn s =>
+         show := SOME (case s of
+                          "anns" => Show.Anns
+                        | "path-map" => Show.PathMap
+                        | _ => usage (concat ["invalid -show arg: ", s])))),
+       (Expert, "show-anns", " {false|true}", "deprecated (use -show anns)",
+        Bool
+        (fn b =>
+         (if b then show := SOME Show.Anns else ()
+          ; Out.output
+            (Out.error,
+             "Warning: deprecated option: -show-anns.  Use -show anns.\n")))),
        (Normal, "show-basis", " <file>", "write out the final basis environment",
         SpaceString (fn s => showBasis := SOME s)),
        (Normal, "show-def-use", " <file>", "write def-use information",
@@ -583,11 +600,24 @@
                       | SOME c => c)
       val () = MLton.Rusage.measureGC (!verbosity <> Silent)
       val () =
-         if !showAnns then
-            (Layout.outputl (Control.Elaborate.document {expert = !expert}, 
-                             Out.standard)
+         case !show of
+            NONE => ()
+          | SOME info =>
+            (case info of
+                Show.Anns =>
+                Layout.outputl (Control.Elaborate.document {expert = !expert},
+                                Out.standard)
+              | Show.PathMap =>
+                let
+                   open Layout
+                in
+                   outputl (align
+                            (List.map (Control.mlbPathMap (),
+                                       fn {var, path, ...} =>
+                                       str (concat [var, " ", path]))),
+                            Out.standard)
+                end
              ; let open OS.Process in exit success end)
-         else ()
       val () = if !profileTimeSet
                   then (case !codegen of
                            Native => profile := ProfileTimeLabel

[MLton-commit] r5003

[Stephen W. <sw...@ml...>]

Added internal control keepDefUse, which the elaborator uses to avoid
recording def-use information if it won't be used.  This saves some
memory during elaboration.


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

U   mlton/trunk/mlton/control/control-flags.sig
U   mlton/trunk/mlton/control/control-flags.sml
U   mlton/trunk/mlton/elaborate/elaborate-env.fun
U   mlton/trunk/mlton/main/main.fun

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

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2006-12-28 20:29:24 UTC (rev 5002)
+++ mlton/trunk/mlton/control/control-flags.sig	2006-12-28 22:26:34 UTC (rev 5003)
@@ -152,9 +152,12 @@
 
       val inlineIntoMain: bool ref
 
-      (* The input file on the command line, minus path and extension *)
+      (* The input file on the command line, minus path and extension. *)
       val inputFile: File.t ref
 
+      (* Whether or not the elaborator keeps def-use information. *)
+      val keepDefUse: bool ref
+         
       (* Keep dot files for whatever SSA files are produced. *)
       val keepDot: bool ref
 

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2006-12-28 20:29:24 UTC (rev 5002)
+++ mlton/trunk/mlton/control/control-flags.sml	2006-12-28 22:26:34 UTC (rev 5003)
@@ -706,6 +706,10 @@
                         default = false,
                         toString = Bool.toString}
 
+val keepDefUse = control {name = "keep def use",
+                          default = true,
+                          toString = Bool.toString}
+
 val keepDot = control {name = "keep dot",
                        default = false,
                        toString = Bool.toString}

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2006-12-28 20:29:24 UTC (rev 5002)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2006-12-28 22:26:34 UTC (rev 5003)
@@ -1154,9 +1154,13 @@
       fun newUses (T {defUses, ...}, class, def) =
          let
             val u = Uses.new ()
-            val _ = List.push (defUses, {class = class,
-                                         def = def,
-                                         uses = u})
+            val _ =
+               if !Control.keepDefUse then
+                  List.push (defUses, {class = class,
+                                       def = def,
+                                       uses = u})
+               else
+                  ()
          in
             u
          end

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2006-12-28 20:29:24 UTC (rev 5002)
+++ mlton/trunk/mlton/main/main.fun	2006-12-28 22:26:34 UTC (rev 5003)
@@ -675,10 +675,11 @@
          if !keepDot andalso List.isEmpty (!keepPasses)
             then keepSSA := true
          else ()
-      val keepDefUse = 
-         isSome (!showDefUse)
-         orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused)
-         orelse (Control.Elaborate.default Control.Elaborate.warnUnused)
+      val () =
+         keepDefUse
+         := (isSome (!showDefUse)
+             orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused)
+             orelse (Control.Elaborate.default Control.Elaborate.warnUnused))
       val warnMatch =
           (Control.Elaborate.enabled Control.Elaborate.nonexhaustiveMatch)
           orelse (Control.Elaborate.enabled Control.Elaborate.redundantMatch)
@@ -688,7 +689,7 @@
                   Control.Elaborate.DiagEIW.Ignore)
       val _ = elaborateOnly := (stop = Place.TypeCheck
                                 andalso not (warnMatch)
-                                andalso not (keepDefUse))
+                                andalso not (!keepDefUse))
       val _ =
          if !codegen = Bytecode andalso !profile <> ProfileNone
             then usage (concat ["bytecode doesn't support profiling\n"])

[MLton-commit] r5002

[Stephen W. <sw...@ml...>]

Added MLton.Word8{Array,Vector} and MLTON_MONO_{ARRAY,VECTOR}.

These include conversions between a polymorphic container
(e.g. Word8.word vector) and its mononorphic counterpart
(e.g. Word8Vector.vector).


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

U   mlton/trunk/basis-library/build/sources.mlb
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
U   mlton/trunk/basis-library/mlton/mlton.sig
U   mlton/trunk/basis-library/mlton/mlton.sml
A   mlton/trunk/basis-library/mlton/mono-array.sig
A   mlton/trunk/basis-library/mlton/mono-vector.sig
U   mlton/trunk/basis-library/mlton.mlb

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

Modified: mlton/trunk/basis-library/build/sources.mlb
===================================================================
--- mlton/trunk/basis-library/build/sources.mlb	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/build/sources.mlb	2006-12-28 20:29:24 UTC (rev 5002)
@@ -354,6 +354,8 @@
    ../mlton/word.sig
    ../mlton/world.sig
    ../mlton/world.sml
+   ../mlton/mono-array.sig
+   ../mlton/mono-vector.sig
    ../mlton/mlton.sig
    ../mlton/mlton.sml
 

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis-sigs.sml	2006-12-28 20:29:24 UTC (rev 5002)
@@ -92,6 +92,8 @@
 signature MLTON_INT_INF = MLTON_INT_INF
 signature MLTON_IO = MLTON_IO
 signature MLTON_ITIMER = MLTON_ITIMER
+signature MLTON_MONO_ARRAY = MLTON_MONO_ARRAY
+signature MLTON_MONO_VECTOR = MLTON_MONO_VECTOR
 signature MLTON_PLATFORM = MLTON_PLATFORM
 signature MLTON_POINTER = MLTON_POINTER
 signature MLTON_PROC_ENV = MLTON_PROC_ENV

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2006-12-28 20:29:24 UTC (rev 5002)
@@ -622,6 +622,8 @@
       sharing type MLton.BinIO.outstream = BinIO.outstream
       sharing type MLton.TextIO.instream = TextIO.instream
       sharing type MLton.TextIO.outstream = TextIO.outstream
+      sharing type MLton.Word8Array.t = Word8Array.array
+      sharing type MLton.Word8Vector.t = Word8Vector.vector
    end
    (* bool is already defined as bool and so cannot be shared.
     * So, we where these to get the needed sharing.

Modified: mlton/trunk/basis-library/mlton/mlton.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sig	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/mlton/mlton.sig	2006-12-28 20:29:24 UTC (rev 5002)
@@ -50,5 +50,7 @@
       structure Weak: MLTON_WEAK
       structure Word: MLTON_WORD
       structure Word8: MLTON_WORD
+      structure Word8Array: MLTON_MONO_ARRAY
+      structure Word8Vector: MLTON_MONO_VECTOR
       structure World: MLTON_WORLD
    end

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2006-12-28 20:29:24 UTC (rev 5002)
@@ -81,6 +81,16 @@
       type t = word
    end
 
+structure Word8Array = struct
+   open Word8Array
+   type t = array
+end
+
+structure Word8Vector = struct
+   open Word8Vector
+   type t = vector
+end
+
 val _ = 
    (Primitive.TopLevel.setHandler MLtonExn.topLevelHandler
     ; Primitive.TopLevel.setSuffix 

Added: mlton/trunk/basis-library/mlton/mono-array.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mono-array.sig	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/mlton/mono-array.sig	2006-12-28 20:29:24 UTC (rev 5002)
@@ -0,0 +1,6 @@
+signature MLTON_MONO_ARRAY = sig
+   type t
+   type elem
+   val fromPoly: elem array -> t
+   val toPoly: t -> elem array
+end

Added: mlton/trunk/basis-library/mlton/mono-vector.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mono-vector.sig	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/mlton/mono-vector.sig	2006-12-28 20:29:24 UTC (rev 5002)
@@ -0,0 +1,6 @@
+signature MLTON_MONO_VECTOR = sig
+   type t
+   type elem
+   val fromPoly: elem vector -> t
+   val toPoly: t -> elem vector
+end

Modified: mlton/trunk/basis-library/mlton.mlb
===================================================================
--- mlton/trunk/basis-library/mlton.mlb	2006-12-28 20:27:17 UTC (rev 5001)
+++ mlton/trunk/basis-library/mlton.mlb	2006-12-28 20:29:24 UTC (rev 5002)
@@ -24,6 +24,8 @@
       signature MLTON_INT_INF
       signature MLTON_IO
       signature MLTON_ITIMER
+      signature MLTON_MONO_ARRAY
+      signature MLTON_MONO_VECTOR
       signature MLTON_PLATFORM
       signature MLTON_POINTER
       signature MLTON_PROC_ENV

[MLton-commit] r5001

[Stephen W. <sw...@ml...>]

Better error message when fread_safe fails.

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

U   mlton/trunk/runtime/util/safe.h

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

Modified: mlton/trunk/runtime/util/safe.h
===================================================================
--- mlton/trunk/runtime/util/safe.h	2006-12-28 18:36:31 UTC (rev 5000)
+++ mlton/trunk/runtime/util/safe.h	2006-12-28 20:27:17 UTC (rev 5001)
@@ -47,9 +47,14 @@
   size_t res;
 
   res = fread (buf, size, count, f);
-  if (res != count)
-    diee ("fread (_, %zu, %zu, _) failed (only read %zu).\n",
-          size, count, res);
+  if (res != count) {
+    if (feof (f))
+       fprintf (stderr, "eof\n");
+    else
+       fprintf (stderr, "errno = %d\n", ferror (f));  
+    diee ("fread ("FMTPTR", %zu, %zu, _) failed (only read %zu).\n",
+          (uintptr_t)buf, size, count, res);
+  }
 }
 
 static inline void fwrite_safe (const void *buf, size_t size, size_t count, FILE *f) {

[MLton-commit] r5000

[Vesa K. <ve...@ml...>]

Initial commit of libc mlnlffi interface.  There is still much to do
(perhaps even including extensions to mlnlffigen).

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

A   mltonlib/trunk/org/mlton/vesak/
A   mltonlib/trunk/org/mlton/vesak/libc/
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/LICENSE
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/README
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/stdio.c
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/util.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h
A   mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h

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


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable
___________________________________________________________________
Name: svn:ignore
   + *.a
.*
generated


Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/LICENSE
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/LICENSE	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/LICENSE	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,20 @@
+COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.
+
+Copyright (C) 2006 Vesa Karvonen
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both the copyright notice and this permission notice and warranty
+disclaimer appear in supporting documentation, and that the name of
+the above copyright holders, or their entities, not be used in
+advertising or publicity pertaining to distribution of the software
+without specific, written prior permission.
+
+The above copyright holders disclaim all warranties with regard to
+this software, including all implied warranties of merchantability and
+fitness. In no event shall the above copyright holders be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether in an
+action of contract, negligence or other tortious action, arising out
+of or in connection with the use or performance of this software.

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,56 @@
+# Copyright (C) 2006 Vesa Karvonen
+#
+# This code is released under the MLton license, a BSD-style license.
+# See the LICENSE file or http://mlton.org/License for details.
+
+target_arch := $(shell mlton -show-path-map true | \
+                       awk '/^TARGET_ARCH/ {print $$2}')
+target_os   := $(shell mlton -show-path-map true | \
+                       awk '/^TARGET_OS/ {print $$2}')
+target_id   := $(target_arch)-$(target_os)
+
+lib_file    := libc-nlffi-$(target_id).a
+mlb_file    := libc.mlb
+
+config_h    := public/config-$(target_id).h
+cc_opts     := -Wall -std=c99
+
+bin_dir     := .bin/$(target_id)
+gen_dir     := generated/$(target_id)
+
+c_dir       := detail/c
+c_files     := $(wildcard $(c_dir)/*.c)
+o_files     := $(patsubst $(c_dir)/%.c,$(bin_dir)/%.o,$(c_files))
+
+.PHONY : all clean help
+
+help :
+	@echo "Targets:"
+	@echo "    all      Builds the library ($(lib_file)) and NLFFI files"
+	@echo "    clean    Removes generated files"
+	@echo "    help     Prints this message"
+
+all : $(gen_dir)/$(mlb_file) $(lib_file)
+
+clean :
+	rm -rf $(gen_dir) $(bin_dir) $(config_h) $(lib_file)
+
+$(config_h) : detail/config-gen.c
+	mkdir -p $(bin_dir)
+	gcc $(cc_opts) -o $(bin_dir)/config-gen $<
+	$(bin_dir)/config-gen > $@
+
+$(gen_dir)/$(mlb_file) : $(config_h) $(wildcard public/*.h)
+	mkdir -p $(gen_dir)
+	mlnlffigen -dir $(gen_dir)                                         \
+	           -mlbfile $(mlb_file)                                    \
+	           -cppopt '-U$(target_arch) -DTARGET_ARCH=$(target_arch)' \
+	           -cppopt '-U$(target_os) -DTARGET_OS=$(target_os)'       \
+	           -linkage static $^
+
+$(lib_file) : $(o_files)
+	ar cr $@ $^
+
+$(bin_dir)/%.o : $(c_dir)/%.c
+	mkdir -p $(bin_dir)
+	gcc $(cc_opts) -c -o $@ $<


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/Makefile
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/README
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/README	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/README	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,61 @@
+LibC MLNLFFI Interface
+----------------------
+
+   This library provides a MLNLFFI interface to (some portions of) the C
+   standard library (libc).
+
+
+Info
+----
+
+   License:         MLton license (a BSD-style license)
+   Portability:     portable
+   Stability:       experimental
+   Maintainer:      Vesa Karvonen <ves...@cs...>
+
+
+About Library Organization
+--------------------------
+
+   Makefile
+
+      This is a GNU makefile for building the library.  It is designed to
+      allow a single source tree to be built on multiple platforms.  Run
+      the command
+
+         make
+
+      to see a list of supported targets.
+
+   libc-nlffi-$(TARGET_ARCH)-$(TARGET_OS).a
+
+      This library contains the C compiled part of the libc interface.
+      You need to link your program against this library.  The variables
+      TARGET_ARCH and TARGET_OS refer to the corresponding variables as
+      defined by the compiler.  For example, with the mlton compiler
+      running the command
+
+         mlton -show-path-map true | grep TARGET
+
+      shows the variables.
+
+   public/
+
+      This directory contains the public header files used as source files
+      to mlnlffigen.
+
+   libc.mlb
+
+      This the MLB-file for the SML part of the libc interface.
+
+   detail/
+
+      This directory contains the implementation details of the library.
+
+
+About Motivation and Scope
+--------------------------
+
+   The main motivation of this library is to make it easier to implement
+   bindings to C libraries.  This library should eventually include all
+   parts of libc that make sense from that perspective.

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/stdio.c
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/stdio.c	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/stdio.c	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,25 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#include <stdio.h>
+#include "util.h"
+
+CONSTANT(int, EOF)
+CONSTANT(int, FILENAME_MAX)
+CONSTANT(int, FOPEN_MAX)
+CONSTANT(int, L_tmpnam)
+CONSTANT(int, SEEK_CUR)
+CONSTANT(int, SEEK_END)
+CONSTANT(int, SEEK_SET)
+CONSTANT(int, TMP_MAX)
+CONSTANT(int, _IOFBF)
+CONSTANT(int, _IOLBF)
+CONSTANT(int, _IONBF)
+CONSTANT(size_t, BUFSIZ)
+
+CONST_FN(FILE *, stderr)
+CONST_FN(FILE *, stdin)
+CONST_FN(FILE *, stdout)


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/stdio.c
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/util.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/util.h	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/util.h	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,8 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#define CONSTANT(type, name) const type name##_ = name;
+#define CONST_FN(type, name) type name##_(void) {return name;}


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/c/util.h
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,161 @@
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+/* This simple C program is used to generate a configuration header that
+ * defines typedefs for standard types and typedefs.  For each type[def],
+ * this program simply chooses a type that has the correct size and kind
+ * (signed or unsigned integer).  The reason for doing this is that system
+ * and/or compiler headers may (and often do) contain non-standard C and
+ * choke mlnlffigen.  Also, mlnlffigen can't export macros, so we need to
+ * do something about them.  So, instead of #including system headers, we
+ * make our own headers.
+ */
+
+#include <stdarg.h>
+#include <stdbool.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+/************************************************************************/
+
+static void
+fail(const char *format, ...) {
+  va_list args;
+  va_start(args, format);
+  fprintf(stderr, "Error: ");
+  vfprintf(stderr, format, args);
+  fprintf(stderr, "\n");
+  va_end(args);
+  exit(EXIT_FAILURE);
+}
+
+#define fail(...) do fail(__VA_ARGS__); while (true)
+
+/************************************************************************/
+
+typedef enum integer_kind {
+  signed_integer,
+  unsigned_integer
+} integer_kind;
+
+static const char *
+choose_integer_type(const size_t size, const integer_kind kind) {
+  switch (kind) {
+  case signed_integer:
+    if (sizeof(signed char) == size) return "signed char";
+    if (sizeof(short) == size) return "short";
+    if (sizeof(int) == size) return "int";
+    if (sizeof(long) == size) return "long";
+    if (sizeof(long long) == size) return "long long";
+    break;
+  case unsigned_integer:
+    if (sizeof(unsigned char) == size) return "unsigned char";
+    if (sizeof(unsigned short) == size) return "unsigned short";
+    if (sizeof(unsigned int) == size) return "unsigned int";
+    if (sizeof(unsigned long) == size) return "unsigned long";
+    if (sizeof(unsigned long long) == size) return "unsigned long long";
+    break;
+  }
+  fail("Couldn't find a %s type of %zd bytes.",
+       signed_integer == kind ? "signed" : "unsigned",
+       size);
+}
+
+/************************************************************************/
+
+static void
+print_header(void) {
+  printf("#ifndef CONFIG_H\n"
+         "#define CONFIG_H\n"
+         "\n"
+         "/* THIS FILE IS GENERATED.  DO NOT EDIT! */\n");
+}
+
+static void
+print_separator(const char *text) {
+  printf("\n/** <%s> *", text);
+  for (size_t width = strlen(text) + strlen("/** <> *"); width < 72; ++width)
+    printf("*");
+  printf("*/\n\n");
+}
+
+static void
+print_integer_type(const size_t size,
+                   const integer_kind kind,
+                   const char *name) {
+  printf("typedef %s %s;\n", choose_integer_type(size, kind), name);
+}
+
+static void
+print_footer(void) {
+  printf("\n"
+         "#endif\n");
+}
+
+/************************************************************************/
+
+#define INTEGER_TYPE(type)                      \
+print_integer_type(sizeof(type),                \
+                   (type)-1 < (type)0           \
+                   ? signed_integer             \
+                   : unsigned_integer,          \
+                   #type)
+
+int
+main(int argc, char *argv[]) {
+  print_header();
+
+  print_separator("stdbool.h");
+
+  INTEGER_TYPE(bool);
+
+  print_separator("stddef.h");
+
+  INTEGER_TYPE(size_t);
+  INTEGER_TYPE(ptrdiff_t);
+
+  print_separator("stdint.h");
+
+  INTEGER_TYPE(int8_t);
+  INTEGER_TYPE(int16_t);
+  INTEGER_TYPE(int32_t);
+  INTEGER_TYPE(int64_t);
+  INTEGER_TYPE(uint8_t);
+  INTEGER_TYPE(uint16_t);
+  INTEGER_TYPE(uint32_t);
+  INTEGER_TYPE(uint64_t);
+  INTEGER_TYPE(int_least8_t);
+  INTEGER_TYPE(int_least16_t);
+  INTEGER_TYPE(int_least32_t);
+  INTEGER_TYPE(int_least64_t);
+  INTEGER_TYPE(uint_least8_t);
+  INTEGER_TYPE(uint_least16_t);
+  INTEGER_TYPE(uint_least32_t);
+  INTEGER_TYPE(uint_least64_t);
+  INTEGER_TYPE(int_fast8_t);
+  INTEGER_TYPE(int_fast16_t);
+  INTEGER_TYPE(int_fast32_t);
+  INTEGER_TYPE(int_fast64_t);
+  INTEGER_TYPE(uint_fast8_t);
+  INTEGER_TYPE(uint_fast16_t);
+  INTEGER_TYPE(uint_fast32_t);
+  INTEGER_TYPE(uint_fast64_t);
+  INTEGER_TYPE(intptr_t);
+  INTEGER_TYPE(uintptr_t);
+  INTEGER_TYPE(intmax_t);
+  INTEGER_TYPE(uintmax_t);
+
+  print_separator("wchar.h");
+
+  INTEGER_TYPE(wchar_t);
+
+  print_footer();
+
+  return EXIT_SUCCESS;
+}


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/detail/config-gen.c
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+generated/$(TARGET_ARCH)-$(TARGET_OS)/libc.mlb


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/libc.mlb
___________________________________________________________________
Name: svn:eol-style
   + native


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public
___________________________________________________________________
Name: svn:ignore
   + config-*-*.h


Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,21 @@
+#ifndef COMMON_H
+#define COMMON_H
+
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#if !defined(TARGET_ARCH) || !defined(TARGET_OS)
+#error TARGET_ARCH and TARGET_OS must be defined
+#endif
+
+#define STRINGIFY(x) STRINGIFY_DELAY(x)
+#define STRINGIFY_DELAY(x) #x
+
+#include STRINGIFY(config-TARGET_ARCH-TARGET_OS.h)
+
+#define restrict /* mlnlffigen can't parse restrict ATM */
+
+#endif


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/common.h
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h
===================================================================
--- mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h	2006-12-28 14:26:15 UTC (rev 4999)
+++ mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h	2006-12-28 18:36:31 UTC (rev 5000)
@@ -0,0 +1,80 @@
+#ifndef STDIO_H
+#define STDIO_H
+
+/* Copyright (C) 2006 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+#include "common.h"
+
+typedef struct FILE FILE;
+typedef struct fpos_t fpos_t;
+
+extern const int EOF_;
+extern const int FILENAME_MAX_;
+extern const int FOPEN_MAX_;
+extern const int L_tmpnam_;
+extern const int SEEK_CUR_;
+extern const int SEEK_END_;
+extern const int SEEK_SET_;
+extern const int TMP_MAX_;
+extern const int _IOFBF_;
+extern const int _IOLBF_;
+extern const int _IONBF_;
+extern const size_t BUFSIZ_;
+
+FILE *stderr_(void);
+FILE *stdin_(void);
+FILE *stdout_(void);
+
+int remove(const char *filename);
+int rename(const char *old, const char *new);
+FILE *tmpfile(void);
+char *tmpnam(char *s);
+int fclose(FILE *stream);
+int fflush(FILE *stream);
+FILE *fopen(const char * restrict filename, const char * restrict mode);
+FILE *freopen(const char * restrict filename, const char * restrict mode,
+FILE * restrict stream);
+void setbuf(FILE * restrict stream, char * restrict buf);
+int setvbuf(FILE * restrict stream, char * restrict buf, int mode, size_t size);
+/* int fprintf(FILE * restrict stream, const char * restrict format, ...); */
+/* int fscanf(FILE * restrict stream, const char * restrict format, ...); */
+/* int printf(const char * restrict format, ...); */
+/* int scanf(const char * restrict format, ...); */
+/* int snprintf(char * restrict s, size_t n, const char * restrict format, ...); */
+/* int sprintf(char * restrict s, const char * restrict format, ...); */
+/* int sscanf(const char * restrict s, const char * restrict format, ...); */
+/* int vfprintf(FILE * restrict stream, const char * restrict format, va_list arg); */
+/* int vfscanf(FILE * restrict stream, const char * restrict format, va_list arg); */
+/* int vprintf(const char * restrict format, va_list arg); */
+/* int vscanf(const char * restrict format, va_list arg); */
+/* int vsnprintf(char * restrict s, size_t n, const char * restrict format, va_list arg); */
+/* int vsprintf(char * restrict s, const char * restrict format, va_list arg); */
+/* int vsscanf(const char * restrict s, const char * restrict format, va_list arg); */
+int fgetc(FILE *stream);
+char *fgets(char * restrict s, int n, FILE * restrict stream);
+int fputc(int c, FILE *stream);
+int fputs(const char * restrict s, FILE * restrict stream);
+int getc(FILE *stream);
+int getchar(void);
+char *gets(char *s);
+int putc(int c, FILE *stream);
+int putchar(int c);
+int puts(const char *s);
+int ungetc(int c, FILE *stream);
+size_t fread(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream);
+size_t fwrite(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream);
+int fgetpos(FILE * restrict stream, fpos_t * restrict pos);
+int fseek(FILE *stream, long int offset, int whence);
+int fsetpos(FILE *stream, const fpos_t *pos);
+long int ftell(FILE *stream);
+void rewind(FILE *stream);
+void clearerr(FILE *stream);
+int feof(FILE *stream);
+int ferror(FILE *stream);
+void perror(const char *s);
+
+#endif


Property changes on: mltonlib/trunk/org/mlton/vesak/libc/unstable/public/stdio.h
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r4999

[Vesa K. <ve...@ml...>]

Added org/mlton -hierarchy.
----------------------------------------------------------------------

A   mltonlib/trunk/org/
A   mltonlib/trunk/org/mlton/

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

[MLton-commit] r4998

[Vesa K. <ve...@ml...>]

Using type abbreviation.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig	2006-12-27 14:19:26 UTC (rev 4997)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig	2006-12-27 14:22:07 UTC (rev 4998)
@@ -11,7 +11,7 @@
    type 'a t = 'a array
    (** Convenience alias. *)
 
-   val duplicate : 'a t -> 'a t
+   val duplicate : 'a t UnOp.t
    (**
     * Makes a fresh duplicate of the given array.  {duplicate a} is
     * equivalent to {tabulate (length a, fn i => sub (a, i))}.

[MLton-commit] r4997

[Vesa K. <ve...@ml...>]

Added ShiftOp : SHIFT_OP.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
A   mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/shift-op.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2006-12-27 14:19:26 UTC (rev 4997)
@@ -52,3 +52,4 @@
 structure Emb = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a Option.t) end
 structure Iso = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a) end
 structure With = struct type ('a, 'b) t = ('a -> 'b) -> 'b end
+structure ShiftOp = struct type 'a t = 'a * Word.t -> 'a end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm	2006-12-27 14:19:26 UTC (rev 4997)
@@ -25,6 +25,7 @@
    ../../public/fn/cmp.sig
    ../../public/fn/effect.sig
    ../../public/fn/fn.sig
+   ../../public/fn/shift-op.sig
    ../../public/fn/thunk.sig
    ../../public/fn/un-op.sig
    ../../public/fn/un-pr.sig

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-27 14:19:26 UTC (rev 4997)
@@ -201,6 +201,7 @@
          in
             bas public/lazy/promise.sig detail/promise.sml end
          end
+         basis ShiftOp = bas public/fn/shift-op.sig end
 
          open BinOp BinPr Bool Buffer
          open Cmp
@@ -212,7 +213,7 @@
          open Option Order
          open Products Promise
          open Reader Ref
-         open Scalars Seqs Sq Sum
+         open Scalars Seqs ShiftOp Sq Sum
          open Thunk Tie
          open Unit Univ UnOp UnPr
          open With Writer

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2006-12-27 14:19:26 UTC (rev 4997)
@@ -88,6 +88,7 @@
         "detail/"^compiler^"/mono-array-slices.sml",
         "detail/"^compiler^"/texts.sml",
         "public/lazy/promise.sig", "detail/promise.sml",
+        "public/fn/shift-op.sig",
         "detail/"^compiler^"/forget.use",
         "public/export/"^compiler^".sml",
         "public/export/common.sml",

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml	2006-12-27 14:19:26 UTC (rev 4997)
@@ -38,6 +38,7 @@
 signature READER = READER
 signature REAL = REAL
 signature REF = REF
+signature SHIFT_OP = SHIFT_OP
 signature SQ = SQ
 signature STRING = STRING
 signature SUBSTRING = SUBSTRING
@@ -55,10 +56,14 @@
 signature WORD = WORD
 signature WRITER = WRITER
 
+structure Sq : SQ = Sq
+structure Sum : SUM = Sum
+structure Thunk : THUNK = Thunk
+structure UnPr : UN_PR = UnPr
 structure Univ : UNIV = Univ
 structure Vector : VECTOR = Vector
+structure With : WITH = With
 structure Writer : WRITER = Writer
-structure With : WITH = With
 
 structure Array : ARRAY = Array
 structure ArraySlice : ARRAY_SLICE = ArraySlice
@@ -94,15 +99,12 @@
 structure Reader : READER = Reader
 structure Real : REAL = Real
 structure Ref : REF where type 'a t = 'a ref = Ref
-structure Sq : SQ = Sq
+structure ShiftOp : SHIFT_OP = ShiftOp
 structure String : STRING = String
 structure Substring : SUBSTRING = Substring
-structure Sum : SUM = Sum
 structure Text : TEXT = Text
-structure Thunk : THUNK = Thunk
 structure Tie : TIE = Tie
 structure UnOp : UN_OP = UnOp
-structure UnPr : UN_PR = UnPr
 structure Unit : UNIT = Unit
 structure VectorSlice : VECTOR_SLICE = VectorSlice
 structure Word : WORD = Word

Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/shift-op.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/shift-op.sig	2006-12-25 05:00:18 UTC (rev 4996)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/shift-op.sig	2006-12-27 14:19:26 UTC (rev 4997)
@@ -0,0 +1,11 @@
+(* Copyright (C) 2006 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(** Utilities for dealing with bit-wise shift operators. *)
+signature SHIFT_OP = sig
+   type 'a t = 'a * Word.t -> 'a
+   (** Type of bit-wise shift operators {<<, >>, ~>>}. *)
+end


Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/shift-op.sig
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r4996

[Vesa K. <ve...@ml...>]

Fixed comment.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/buffer.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/buffer.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/buffer.sig	2006-12-23 21:24:49 UTC (rev 4995)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/buffer.sig	2006-12-25 05:00:18 UTC (rev 4996)
@@ -81,8 +81,8 @@
 
    val pushBuffer : ('a t * 'a t) Effect.t
    (**
-    * Adds the elements of the buffer to the buffer.  {pushVectorSlice (b,
-    * b')} is equivalent to {pushList (b, toList b')}.
+    * Adds the elements of the buffer to the buffer.  {pushBuffer (b, b')}
+    * is equivalent to {pushList (b, toList b')}.
     *)
 
    val pushList : ('a t * 'a List.t) Effect.t

[MLton-commit] r4995

[Vesa K. <ve...@ml...>]

Renamed readme.txt -> README to make it stand out.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/extended-basis/unstable/README
D   mltonlib/trunk/com/ssh/extended-basis/unstable/readme.txt

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

Copied: mltonlib/trunk/com/ssh/extended-basis/unstable/README (from rev 4994, mltonlib/trunk/com/ssh/extended-basis/unstable/readme.txt)

Deleted: mltonlib/trunk/com/ssh/extended-basis/unstable/readme.txt
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/readme.txt	2006-12-21 21:21:56 UTC (rev 4994)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/readme.txt	2006-12-23 21:24:49 UTC (rev 4995)
@@ -1,130 +0,0 @@
-Extended Basis Library
-----------------------
-
-   This library implements a number of extensions to the signatures and
-   structures of the Standard ML Basis Library [1] as well as several
-   additional modules.  The extensions are done in a non-intrusive manner
-   by simply rebinding the signatures and structures of the basis library.
-   The reason for extending the basis library in this way is that the
-   extensions are naturally associated with specific basis library
-   modules.  Extensions include things like isomorphisms and embeddings
-   (pairs of the form (toX, fromX)), bounds (pairs of the form (minX,
-   maxX)), and simple utility functions such as isZero, isEven and isOdd.
-
-
-Info
-----
-
-   License:         MLton license (a BSD-style license)
-   Portability:     portable
-   Stability:       experimental
-   Maintainer:      Vesa Karvonen <ves...@cs...>
-
-
-About Library Organization
---------------------------
-
-   public/
-
-      This directory contains the documented signature definitions (*.sig)
-      and listings of all top-level bindings exported by this library
-      (export*.sml).  The contents of this directory should be sufficient
-      to understand the extensions provided by this library.
-
-   basis.{cm,mlb,use}
-
-      These build files define the extended basis library including all of
-      the original basis library.  The idea is that users refer to one of
-      these, depending on the compiler, instead of the original basis
-      library.  See the build files for further instructions.
-
-   extensions.{cm,mlb,use}
-
-      These build files define only the extensions provided by this
-      library.  Users may refer to these files, but they are probably more
-      interesting to maintainers.  See the build files for further
-      instructions.
-
-   detail/
-
-      This directory contains the implementation details of the library.
-
-   detail/$(SML_COMPILER)/
-
-      These directories (e.g. detail/mlton/) contain compiler specific
-      implementation details.  Different compilers implement different
-      subsets of the original basis library.
-
-   detail/$(SML_COMPILER)/workarounds/
-
-      These directories (e.g. detail/smlnj/workarounds/) contain compiler
-      specific workarounds.  The idea is that workarounds are separated
-      from other code so that once a compiler becomes more conforming to
-      the language definition and basis library specification, the
-      workarounds can be easily removed.
-
-
-About Motivation and Scope
---------------------------
-
-   The basis library, while certainly not perfect, is a valuable library
-   and it doesn't make sense to throw it away.  There is a book describing
-   the basis library and people just learning SML are likely to spend time
-   learning the basis library.  It makes sense to build on that knowledge.
-
-   However, maintaining 100% basis library compatibility is unlikely to
-   lead to an "optimal" design.  In particular, here is what the basis
-   library book [1] says (page 11, start of section 2, emphasis added):
-
-      "We view the signature and structure names used below as being
-      *reserved*.  For an implementation to be conforming, any module it
-      provides that is named in the SML Basis Library must *exactly* match
-      the description specified in the Library."
-
-   So, the design of the basis library is supposed to be more or less cast
-   in stone - at least if you want to claim that you've implemented the
-   SML Basis Library.  However, one can argue that the basis library
-   contains an organizational framework that goes beyond the exact
-   signatures and structures specified.  For many simple extensions there
-   is a place in that organizational framework, and while it isn't
-   technically necessary to extended the basis library, it makes sense to
-   do so because it can reduce the learning curve and make the entirety
-   easier to use.
-
-   On the other hand, it probably doesn't make sense to put everything
-   into this library.  As a rule of thumb, things that naturally belong to
-   specific basis library modules and what those things depend on should
-   go into this library.  On the other hand, when there are several ways
-   to implement something with significantly different trade-offs, it
-   should most likely go into another library.
-
-
-Contributions
--------------
-
-   The signatures and structures defined by this library are not meant to
-   be cast in stone!  We welcome contributions including new extensions,
-   bugfixes, and ports to new compilers.  The recommended submit method
-   for small contributions to this library is to send a message with a
-   brief description of the proposed contribution as well as a patch
-   containing full code and documentation (signature comments) to either
-   the MLton-user list
-
-      mlt...@ml...
-
-   or the MLton list
-
-      ml...@ml... .
-
-   For larger extensions or changes we recommend that you first contact
-   the active maintainer(s) of this library.  The preferred contact method
-   is through the above mailing lists.
-
-
-References
-----------
-
-  [1] The Standard ML Basis Library.
-      Emden R. Gansner and John H. Reppy.
-      Cambridge University Press, 2004.
-      ISBN 0521794781.

[MLton-commit] r4994

[Vesa K. <ve...@ml...>]

Added map to UnPr and BinPr.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bin-pr.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/un-pr.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/bin-pr.sig
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/un-pr.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bin-pr.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bin-pr.sml	2006-12-20 21:05:44 UTC (rev 4993)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bin-pr.sml	2006-12-21 21:21:56 UTC (rev 4994)
@@ -6,4 +6,5 @@
 
 structure BinPr :> BIN_PR = struct
    open BinPr
+   fun map f = UnPr.map (Sq.map f)
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/un-pr.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/un-pr.sml	2006-12-20 21:05:44 UTC (rev 4993)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/un-pr.sml	2006-12-21 21:21:56 UTC (rev 4994)
@@ -6,6 +6,7 @@
 
 structure UnPr :> UN_PR = struct
    open UnPr
+   fun map f p = p o f
    fun op andAlso (p, q) ? = p ? andalso q ?
    fun op orElse (p, q) ? = p ? orelse q ?
    fun negate p = not o p

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-20 21:05:44 UTC (rev 4993)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-21 21:21:56 UTC (rev 4994)
@@ -68,7 +68,11 @@
          basis Fix = bas public/generic/fix.sig detail/fix.sml end
          basis UnPr = bas public/fn/un-pr.sig detail/un-pr.sml end
          basis Order = bas public/data/order.sig detail/order.sml end
-         basis BinPr = bas public/fn/bin-pr.sig detail/bin-pr.sml end
+         basis BinPr = let
+            open Sq UnPr
+         in
+            bas public/fn/bin-pr.sig detail/bin-pr.sml end
+         end
          basis Cmp = let
             open Fn Order Sq
          in

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/bin-pr.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/bin-pr.sig	2006-12-20 21:05:44 UTC (rev 4993)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/bin-pr.sig	2006-12-21 21:21:56 UTC (rev 4994)
@@ -8,4 +8,7 @@
 signature BIN_PR = sig
    type 'a t = 'a Sq.t UnPr.t
    (** Type of binary predicates or relations (e.g. {<, <=, >=, >, ...}). *)
+
+   val map : ('a -> 'b) -> 'b t -> 'a t
+   (** Change the domain of a binary predicate. *)
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/un-pr.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/un-pr.sig	2006-12-20 21:05:44 UTC (rev 4993)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/un-pr.sig	2006-12-21 21:21:56 UTC (rev 4994)
@@ -6,9 +6,12 @@
 
 (** Utilities for dealing with (unary) predicates. *)
 signature UN_PR = sig
-   type 'a t = 'a -> bool
+   type 'a t = 'a -> Bool.t
    (** Type of (unary) predicates (e.g. {null, isSome, ...}). *)
 
+   val map : ('a -> 'b) -> 'b t -> 'a t
+   (** Change the domain of a predicate. *)
+
    val andAlso : 'a t BinOp.t
    (** Conjunction of predicates ({(p andAlso q) x = p x andalso q y}). *)
 

[MLton-commit] r4993

[Vesa K. <ve...@ml...>]

Added map to array modules.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/array.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-mono-array-ext.fun
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/mono-array.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/array.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/array.sml	2006-12-20 07:52:43 UTC (rev 4992)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/array.sml	2006-12-20 21:05:44 UTC (rev 4993)
@@ -14,4 +14,5 @@
    val toVector = vector
    fun fromVector v = tabulate (Vector.length v, fn i => Vector.sub (v, i))
    val isoVector = (toVector, fromVector)
+   fun map f a = tabulate (length a, fn i => f (sub (a, i)))
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-mono-array-ext.fun
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-mono-array-ext.fun	2006-12-20 07:52:43 UTC (rev 4992)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-mono-array-ext.fun	2006-12-20 21:05:44 UTC (rev 4993)
@@ -28,4 +28,5 @@
    val toVector = vector
    val isoVector = (toVector, fromVector)
    val isoPoly = (toPoly, fromPoly)
+   fun map f a = tabulate (length a, fn i => f (sub (a, i)))
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig	2006-12-20 07:52:43 UTC (rev 4992)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/array.sig	2006-12-20 21:05:44 UTC (rev 4993)
@@ -24,6 +24,9 @@
     * bi+1) = f (i, bi)}.
     *)
 
+   val map : ('a -> 'b) -> 'a t -> 'b t
+   (** {map f} is equivalent to {fromVector o Vector.map f o toVector}. *)
+
    (** == Conversions == *)
 
    val fromVector : 'a Vector.t -> 'a t

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/mono-array.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/mono-array.sig	2006-12-20 07:52:43 UTC (rev 4992)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/sequence/mono-array.sig	2006-12-20 21:05:44 UTC (rev 4993)
@@ -24,6 +24,9 @@
     * bi+1) = f (i, bi)}.
     *)
 
+   val map : elem UnOp.t -> t UnOp.t
+   (** {map f} is equivalent to {fromVector o MonoVector.map f o toVector}. *)
+
    (** == Conversions == *)
 
    val fromPoly : elem Array.t -> t

[MLton-commit] r4992

[Vesa K. <ve...@ml...>]

Changed '-stop f' output to include mlb-files.  The motivation for this is
that '-stop f' is often used for generating dependencies in Makefiles and
the mlb-files should be included.

It is easy to recover the old output (without the mlb-files).  For
example, if one previously used the command

  mlton -stop f some.mlb

then the old output can be recovered using the command

  mlton -stop f some.mlb | grep -v '\.mlb$'

where the grep removes the mlb-files from the output.

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

U   mlton/trunk/mlton/ast/ast-mlbs.fun

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

Modified: mlton/trunk/mlton/ast/ast-mlbs.fun
===================================================================
--- mlton/trunk/mlton/ast/ast-mlbs.fun	2006-12-19 20:09:46 UTC (rev 4991)
+++ mlton/trunk/mlton/ast/ast-mlbs.fun	2006-12-20 07:52:43 UTC (rev 4992)
@@ -128,7 +128,8 @@
                      else let
                              val () = b := true
                           in
-                             sourceFilesBasdec (Promise.force dec)
+                             Buffer.add (sourceFiles, fileAbs)
+                             ; sourceFilesBasdec (Promise.force dec)
                           end
                end
           | Open _ => ()

[MLton-commit] r4991

[Matthew F. <fl...@ml...>]

Merge trunk revisions 4907:4990 into x86_64 branch
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml
U   mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
U   mlton/branches/on-20050822-x86_64-branch/bin/mlton-script
U   mlton/branches/on-20050822-x86_64-branch/doc/changelog
U   mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el
U   mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el
U   mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
U   mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
U   mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
U   mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c

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

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml	2006-12-19 20:09:46 UTC (rev 4991)
@@ -334,6 +334,7 @@
 structure IntInf =
    struct
       structure Prim = Primitive.IntInf
+      structure MLton = Primitive.MLton
 
       structure A = Primitive.Array
       structure V = Primitive.Vector
@@ -876,8 +877,11 @@
             Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex num),
             Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex extra),
             Sz.+ (bytesPerMPLimb, (* isneg Field *)
-                  bytesPerArrayHeader (* Array Header *)
-            )))
+            Sz.+ (bytesPerArrayHeader, (* Array Header *)
+                  case MLton.Align.align of (* alignment *)
+                     MLton.Align.Align4 => 0w3
+                   | MLton.Align.Align8 => 0w7
+            ))))
       end
 
       (* badObjptr{Int,Word}{,Tagged} is the fixnum IntInf.int whose 
@@ -1202,13 +1206,16 @@
                        Int32.+ (Int32.quot (bpl, bpd),
                                 if Int32.mod (bpl, bpd) = 0
                                    then 0 else 1)
+                    val bytes =
+                       Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
+                             Sz.+ (0w1 (* sign *),
+                                   case MLton.Align.align of (* alignment *)
+                                      MLton.Align.Align4 => 0w3
+                                    | MLton.Align.Align8 => 0w7)),
+                             Sz.* (Sz.zextdFromInt32 dpl, 
+                                   Sz.zextdFromSeqIndex (numLimbs arg)))
                  in
-                    Prim.toString
-                    (arg, base, 
-                     Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
-                                 0w1 (* sign *)),
-                           Sz.* (Sz.zextdFromInt32 dpl, 
-                                 Sz.zextdFromSeqIndex (numLimbs arg))))
+                    Prim.toString (arg, base, bytes)
                  end
 
       fun mkBigLog2 {fromSmall: {smallLog2: Primitive.Int32.int} -> 'a,

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml	2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,6 +32,17 @@
       val gcState = #1 _symbol "gcStateAddress": t GetSet.t; ()
    end
 
+structure Align =
+   struct
+      datatype t = Align4 | Align8
+
+      val align =
+         case _build_const "MLton_Align_align": Int32.int; of
+            4 => Align4
+          | 8 => Align8
+          | _ => raise Primitive.Exn.Fail8 "MLton_Align_align"
+   end
+
 structure CallStack =
    struct
       (* The most recent caller is at index 0 in the array. *)

Modified: mlton/branches/on-20050822-x86_64-branch/bin/mlton-script
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/bin/mlton-script	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/bin/mlton-script	2006-12-19 20:09:46 UTC (rev 4991)
@@ -70,46 +70,45 @@
 # The darwin linker complains (loudly) about non-existent library
 # search paths.
 darwinLinkOpts=''
-if [ -d '/opt/local/lib' ]; then
-        darwinLinkOpts="$darwinLinkOpts -L/opt/local/lib"
-fi
 if [ -d '/sw/lib' ]; then
         darwinLinkOpts="$darwinLinkOpts -L/sw/lib"
 fi
+if [ -d '/opt/local/lib' ]; then
+        darwinLinkOpts="$darwinLinkOpts -L/opt/local/lib"
+fi
 
 doit "$lib" \
         -cc "$gcc"                                               \
-        -cc-opt "-I$lib/include"                                 \
+        -cc-opt-quote "-I$lib/include"                           \
         -cc-opt '-O1'                                            \
-        -cc-opts '-fno-strict-aliasing -fomit-frame-pointer -w'  \
+        -cc-opt '-fno-strict-aliasing -fomit-frame-pointer -w'   \
         -mlb-path-map "$lib/mlb-path-map"                        \
-        -target-as-opts amd64 '-m32 -mtune=opteron'              \
-        -target-cc-opts amd64 '-m32 -mtune=opteron'              \
-        -target-cc-opts darwin                                   \
+        -target-as-opt amd64 '-m32 -mtune=opteron'               \
+        -target-cc-opt amd64 '-m32 -mtune=opteron'               \
+        -target-cc-opt darwin                                    \
                 '-I/opt/local/include -I/sw/include'             \
-        -target-cc-opts freebsd '-I/usr/local/include'           \
-        -target-cc-opts netbsd '-I/usr/pkg/include'              \
-        -target-cc-opts openbsd '-I/usr/local/include'           \
-        -target-cc-opts solaris                                  \
-                '-Wa,-xarch=v8plusa
-                -mcpu=ultrasparc'                                \
-        -target-cc-opts sparc '-mcpu=v8 -m32'                    \
-        -target-cc-opts x86                                      \
+        -target-cc-opt freebsd '-I/usr/local/include'            \
+        -target-cc-opt netbsd '-I/usr/pkg/include'               \
+        -target-cc-opt openbsd '-I/usr/local/include'            \
+        -target-cc-opt solaris                                   \
+                '-Wa,-xarch=v8plusa -mcpu=ultrasparc'            \
+        -target-cc-opt sparc '-mcpu=v8 -m32'                     \
+        -target-cc-opt x86                                       \
                 '-fno-strength-reduce
                 -fschedule-insns
                 -fschedule-insns2
                 -malign-functions=5
                 -malign-jumps=2
                 -malign-loops=2'                                 \
-        -target-link-opts amd64 '-m32'                           \
-        -target-link-opts darwin "$darwinLinkOpts"               \
-        -target-link-opts freebsd '-L/usr/local/lib/'            \
-        -target-link-opts mingw                                  \
+        -target-link-opt amd64 '-m32'                            \
+        -target-link-opt darwin "$darwinLinkOpts"                \
+        -target-link-opt freebsd '-L/usr/local/lib/'             \
+        -target-link-opt mingw                                   \
                 '-lws2_32 -lkernel32 -lpsapi -lnetapi32'         \
-        -target-link-opts netbsd                                 \
+        -target-link-opt netbsd                                  \
                 '-Wl,-R/usr/pkg/lib -L/usr/pkg/lib/'             \
-        -target-link-opts openbsd '-L/usr/local/lib/'            \
-        -target-link-opts solaris '-lnsl -lsocket -lrt'          \
-        -link-opts '-lgdtoa -lm -lgmp'                           \
+        -target-link-opt openbsd '-L/usr/local/lib/'             \
+        -target-link-opt solaris '-lnsl -lsocket -lrt'           \
+        -link-opt '-lgdtoa -lm -lgmp'                            \
         -profile-exclude '<basis>'                               \
         "$@"

Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog	2006-12-19 20:09:46 UTC (rev 4991)
@@ -1,5 +1,12 @@
 Here are the changes since version 20051202.
 
+* 2006-12-8
+   - Added command line switches -{,target}-{as,cc,link}-opt-quote, which
+     pass their argument as a single argument to gcc (i.e., without
+     tokenization at spaces).  These options support using headers and
+     libraries (including the MLton runtime headers and libraries) from a
+     path with spaces.  
+
 * 2006-12-02
    - Extensive reorganization of garbage collector, runtime system, and
      Basis Library implementation. (This is in preparation for future

Modified: mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-mlb-mode.el	2006-12-19 20:09:46 UTC (rev 4991)
@@ -242,21 +242,23 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Syntax and highlighting
 
-(defconst esml-mlb-string-continue-regexp "\\(\\\\[ \t\n]+\\\\\\)")
+(defconst esml-mlb-string-continue-regexp "\\(?:\\\\[ \t\n]+\\\\\\)")
 (defconst esml-mlb-string-char-regexp
-  (concat "\\(" esml-mlb-string-continue-regexp
-          "*\\([^\n\"\\]\\|\\\\[^ \t\n]\\)\\)"))
+  (concat "\\(?:" esml-mlb-string-continue-regexp
+          "*\\(?:[^\n\"\\]\\|\\\\[^ \t\n]\\)\\)"))
 (defconst esml-mlb-inside-string-regexp
   (concat "\"" esml-mlb-string-char-regexp "*"
           esml-mlb-string-continue-regexp "*"))
 (defconst esml-mlb-string-regexp (concat esml-mlb-inside-string-regexp "\""))
-(defconst esml-mlb-inside-comment-regexp "(\\*\\([^*]\\|\\*[^)]\\)*")
+(defconst esml-mlb-inside-comment-regexp "(\\*\\(?:[^*]\\|\\*[^)]\\)*")
 (defconst esml-mlb-comment-regexp
   (concat esml-mlb-inside-comment-regexp "\\*)"))
 (defconst esml-mlb-path-var-chars "A-Za-z0-9_")
 (defconst esml-mlb-unquoted-path-chars "-A-Za-z0-9_/.")
 (defconst esml-mlb-unquoted-path-or-ref-chars
   (concat esml-mlb-unquoted-path-chars "()$"))
+(defconst esml-mlb-compiler-ann-prefix
+  (concat "\\(?:" esml-mlb-string-char-regexp "*:[ \t]*\\)"))
 
 (defun esml-mlb-<token>-to-regexp (<token>)
   (let* ((<token>-to-regexp
@@ -309,7 +311,7 @@
           ;; annotations
           (,(apply
              'concat
-             "\"[ \t]*\\("
+             "\"[ \t]*" esml-mlb-compiler-ann-prefix "?\\("
              (reduce
               (function
                (lambda (regexps name-values)
@@ -484,7 +486,7 @@
 
    ;; annotation values
    ((esml-point-preceded-by
-     (concat "\"[ \t\n]*\\("
+     (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\("
              (regexp-opt (mapcar 'car esml-mlb-annotations))
              "\\)[ \t\n]+\\(" esml-mlb-string-char-regexp "*\\)"))
     (let* ((annot (assoc (match-string 1) esml-mlb-annotations))
@@ -511,7 +513,8 @@
           (concat "\\<ann[ \t\n]+\\([ \t\n]+\\|" esml-mlb-string-regexp
                   "\\|" esml-mlb-comment-regexp "\\)*\"[^\"]*"))
          (esml-point-preceded-by
-          (concat "\"[ \t\n]*\\(" esml-mlb-string-char-regexp "*\\)")))
+          (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\("
+                  esml-mlb-string-char-regexp "*\\)")))
     (let* ((name-prefix (match-string 1))
            (name-completion (try-completion name-prefix esml-mlb-annotations))
            (name (if (eq t name-completion) name-prefix name-completion)))

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	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/ide/emacs/esml-util.el	2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,11 +32,8 @@
       (forward-char (length str))
     (insert str)))
 
-;; workaround for incompatibility between GNU Emacs and XEmacs
 (defun esml-split-string (string separator)
-  (if (string-match "XEmacs" emacs-version)
-      (split-string string separator t)
-    (remove* "" (split-string string separator))))
+  (remove* "" (split-string string separator) :test 'equal))
 
 ;; workaround for incompatibility between GNU Emacs and XEmacs
 (defun esml-replace-regexp-in-string (str regexp rep)

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun	2006-12-19 20:09:46 UTC (rev 4991)
@@ -429,9 +429,7 @@
                 end
              fun bigAllocation (bytesNeeded: Operand.t): unit =
                 let
-                   val extraBytes =
-                      Bytes.+ (Runtime.arrayHeaderSize,
-                               blockCheckAmount {blockIndex = i})
+                   val extraBytes = blockCheckAmount {blockIndex = i}
                 in
                    case bytesNeeded of
                       Operand.Const c =>

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun	2006-12-19 20:09:46 UTC (rev 4991)
@@ -24,7 +24,10 @@
       val int = Int.toString
       open Control
    in
-      [("MLton_Codegen_codegen", fn () => int (case !codegen of
+      [("MLton_Align_align", fn () => int (case !align of
+                                              Align4 => 4
+                                            | Align8 => 8)),
+       ("MLton_Codegen_codegen", fn () => int (case !codegen of
                                                   Bytecode => 0
                                                 | CCodegen => 1
                                                 | Native => 2)),

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun	2006-12-19 20:09:46 UTC (rev 4991)
@@ -47,19 +47,20 @@
        | Yes 
    end
 
+val gcc: string ref = ref "<unset>"
 val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val buildConstants: bool ref = ref false
 val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
+val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
+
+val buildConstants: bool ref = ref false
 val coalesce: int option ref = ref NONE
 val debugRuntime: bool ref = ref false
 val expert: bool ref = ref false
 val explicitAlign: Control.align option ref = ref NONE
 val explicitCodegen: Control.codegen option ref = ref NONE
-val gcc: string ref = ref "<unset>"
 val keepGenerated = ref false
 val keepO = ref false
 val keepSML = ref false
-val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
 val output: string option ref = ref NONE
 val profileSet: bool ref = ref false
 val profileTimeSet: bool ref = ref false
@@ -140,11 +141,12 @@
                usage (concat ["invalid -", flag, " flag: ", s])
       open Control Popt
       datatype z = datatype MLton.Platform.Arch.t
-      fun splitString f opts =
-        List.foreach (String.tokens (opts, Char.isSpace), f)
-      fun splitString2 f (target, opts) =
-        List.foreach (String.tokens (opts, Char.isSpace), 
-                      fn opt => f (target, opt))
+      fun tokenizeOpt f opts =
+         List.foreach (String.tokens (opts, Char.isSpace), 
+                       fn opt => f opt)
+      fun tokenizeTargetOpt f (target, opts) =
+         List.foreach (String.tokens (opts, Char.isSpace), 
+                       fn opt => f (target, opt))
    in
       List.map
       (
@@ -159,24 +161,22 @@
                                 | _ => usage (concat ["invalid -align flag: ",
                                                       s]))))),
        (Normal, "as-opt", " <opt>", "pass option to assembler",
-        SpaceString (fn s =>
-                     List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
-       (Expert, "as-opts", " <opts>", "pass options to assembler",
+        (SpaceString o tokenizeOpt)
+        (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
+       (Expert, "as-opt-quote", " <opt>", "pass (quoted) option to assembler",
         SpaceString 
-         (splitString (fn s =>
-                       List.push (asOpts, {opt = s, pred = OptPred.Yes})))),
+        (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
        (Expert, "build-constants", " {false|true}",
         "output C file that prints basis constants",
         boolRef buildConstants),
        (Expert, "cc", " <gcc>", "path to gcc executable",
         SpaceString (fn s => gcc := s)),
        (Normal, "cc-opt", " <opt>", "pass option to C compiler",
-        SpaceString (fn s =>
-                     List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
-       (Expert, "cc-opts", " <opts>", "pass options to C compiler",
+        (SpaceString o tokenizeOpt)
+        (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
+       (Expert, "cc-opt-quote", " <opt>", "pass (quoted) option to C compiler",
         SpaceString 
-         (splitString (fn s =>
-                       List.push (ccOpts, {opt = s, pred = OptPred.Yes})))),
+        (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
        (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
         Int (fn n => coalesce := SOME n)),
        (Normal, "codegen",
@@ -306,12 +306,11 @@
                                     end
                    | NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
        (Normal, "link-opt", " <opt>", "pass option to linker",
-        SpaceString (fn s =>
-                     List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
-       (Expert, "link-opts", " <opts>", "pass options to linker",
+        (SpaceString o tokenizeOpt)
+        (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
+       (Expert, "link-opt-quote", " <opt>", "pass (quoted) option to linker",
         SpaceString 
-         (splitString (fn s =>
-                       List.push (linkOpts, {opt = s, pred = OptPred.Yes})))),
+        (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
        (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
         Int 
         (fn i => 
@@ -501,32 +500,29 @@
          (target := (if t = "self" then Self else Cross t);
           setTargetType (t, usage)))),
        (Normal, "target-as-opt", " <target> <opt>", "target-dependent assembler option",
+        (SpaceString2 o tokenizeTargetOpt)
+        (fn (target, opt) =>
+         List.push (asOpts, {opt = opt, pred = OptPred.Target target}))),
+       (Expert, "target-as-opt-quote", " <target> <opt>", "target-dependent assembler option (quoted)",
         (SpaceString2
          (fn (target, opt) =>
           List.push (asOpts, {opt = opt, pred = OptPred.Target target})))),
-       (Expert, "target-as-opts", " <target> <opts>", "target-dependent assembler options",
-        (SpaceString2
-         (splitString2 
-          (fn (target, opt) =>
-           List.push (asOpts, {opt = opt, pred = OptPred.Target target}))))),
        (Normal, "target-cc-opt", " <target> <opt>", "target-dependent C compiler option",
+        (SpaceString2 o tokenizeTargetOpt)
+        (fn (target, opt) =>
+         List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))),
+       (Expert, "target-cc-opt-quote", " <target> <opt>", "target-dependent C compiler option (quoted)",
         (SpaceString2
          (fn (target, opt) =>
           List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
-       (Expert, "target-cc-opts", " <target> <opts>", "target-dependent C compiler options",
-        (SpaceString2
-         (splitString2
-          (fn (target, opt) =>
-           List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))))),
        (Normal, "target-link-opt", " <target> <opt>", "target-dependent linker option",
+        (SpaceString2 o tokenizeTargetOpt)
+        (fn (target, opt) =>
+         List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))),
+       (Expert, "target-link-opt-quote", " <target> <opt>", "target-dependent linker option (quoted)",
         (SpaceString2
          (fn (target, opt) =>
           List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
-       (Expert, "target-link-opts", " <target> <opts>", "target-dependent linker options",
-        (SpaceString2
-         (splitString2
-          (fn (target, opt) =>
-           List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))))),
        (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
        (Expert, "type-check", " {false|true}", "type check ILs",
         boolRef typeCheck),

Modified: mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/package/mingw/mlton.bat	2006-12-19 20:09:46 UTC (rev 4991)
@@ -32,7 +32,7 @@
 set linkopts=-lgdtoa -lm
 set linkopts=%linkopts% -lgmp -lws2_32 -lkernel32 -lpsapi -lnetapi32
 
-%mlton% @MLton load-world %world% ram-slop 0.5 -- %lib% -cc %cc% -cc-opt "-I%lib%\include" -cc-opts "%ccopts%" -mlb-path-map "%lib%\mlb-path-map" -link-opts "%linkopts%" %*
+%mlton% @MLton load-world %world% ram-slop 0.5 -- %lib% -cc %cc% -cc-opt-quote "-I%lib%\include" -cc-opt "%ccopts%" -mlb-path-map "%lib%\mlb-path-map" -link-opt "%linkopts%" %*
 goto :eof
 
 :setdir

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/array-allocate.c	2006-12-19 20:09:46 UTC (rev 4991)
@@ -10,66 +10,74 @@
                           size_t ensureBytesFree, 
                           GC_arrayLength numElements, 
                           GC_header header) {
-  uintmax_t arraySizeMax;
-  size_t arraySize;
+  uintmax_t arraySizeMax, arraySizeAlignedMax;
+  size_t arraySize, arraySizeAligned;
   size_t bytesPerElement;
   uint16_t bytesNonObjptrs;
   uint16_t numObjptrs;
   pointer frontier;
   pointer last;
-  pointer res;
+  pointer result;
 
   splitHeader(s, header, NULL, NULL, &bytesNonObjptrs, &numObjptrs);
   if (DEBUG)
     fprintf (stderr, "GC_arrayAllocate (%zu, "FMTARRLEN", "FMTHDR")\n",
              ensureBytesFree, numElements, header);
   bytesPerElement = bytesNonObjptrs + (numObjptrs * OBJPTR_SIZE);
-  arraySizeMax = 
-    alignMax ((uintmax_t)bytesPerElement * (uintmax_t)numElements + GC_ARRAY_HEADER_SIZE,
-              s->alignment);
-  if (arraySizeMax >= (uintmax_t)SIZE_MAX)
+  arraySizeMax =
+    (uintmax_t)bytesPerElement * (uintmax_t)numElements + GC_ARRAY_HEADER_SIZE;
+  arraySizeAlignedMax = alignMax (arraySizeMax, s->alignment);
+  if (arraySizeAlignedMax >= (uintmax_t)SIZE_MAX)
     die ("Out of memory: cannot allocate array with %s bytes.",
-         uintmaxToCommaString(arraySizeMax));
+         uintmaxToCommaString(arraySizeAlignedMax));
   arraySize = (size_t)arraySizeMax;
-  if (arraySize < GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE)
+  arraySizeAligned = (size_t)arraySizeAlignedMax;
+  if (arraySizeAligned < GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE) {
     /* Create space for forwarding pointer. */
-    arraySize = GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE;
+    arraySize = GC_ARRAY_HEADER_SIZE;
+    arraySizeAligned = align(GC_ARRAY_HEADER_SIZE + OBJPTR_SIZE, s->alignment);
+  }
   if (DEBUG_ARRAY)
-    fprintf (stderr, "array with "FMTARRLEN" elts of size %zu and total size %s.  Ensure %s bytes free.\n",
+    fprintf (stderr, 
+             "Array with "FMTARRLEN" elts of size %zu and size %s and aligned size %s.  "
+             "Ensure %s bytes free.\n",
              numElements, bytesPerElement, 
              uintmaxToCommaString(arraySize),
+             uintmaxToCommaString(arraySizeAligned),
              uintmaxToCommaString(ensureBytesFree));
-  if (arraySize >= s->controls.oldGenArraySize) {
-    if (not hasHeapBytesFree (s, arraySize, ensureBytesFree)) {
+  if (arraySizeAligned >= s->controls.oldGenArraySize) {
+    if (not hasHeapBytesFree (s, arraySizeAligned, ensureBytesFree)) {
       enter (s);
-      performGC (s, arraySize, ensureBytesFree, FALSE, TRUE);
+      performGC (s, arraySizeAligned, ensureBytesFree, FALSE, TRUE);
       leave (s);
     }
     frontier = s->heap.start + s->heap.oldGenSize;
-    last = frontier + arraySize;
-    s->heap.oldGenSize += arraySize;
-    s->cumulativeStatistics.bytesAllocated += arraySize;
+    s->heap.oldGenSize += arraySizeAligned;
+    s->cumulativeStatistics.bytesAllocated += arraySizeAligned;
   } else {
     size_t bytesRequested;
+    pointer newFrontier;
 
-    bytesRequested = arraySize + ensureBytesFree;
+    bytesRequested = arraySizeAligned + ensureBytesFree;
     if (not hasHeapBytesFree (s, 0, bytesRequested)) {
       enter (s);
       performGC (s, 0, bytesRequested, FALSE, TRUE);
       leave (s);
     }
     frontier = s->frontier;
-    last = frontier + arraySize;
-    assert (isFrontierAligned (s, last));
-    s->frontier = last;
+    newFrontier = frontier + arraySizeAligned;
+    assert (isFrontierAligned (s, newFrontier));
+    s->frontier = newFrontier;
   }
+  last = frontier + arraySize;
   *((GC_arrayCounter*)(frontier)) = 0;
   frontier = frontier + GC_ARRAY_COUNTER_SIZE;
   *((GC_arrayLength*)(frontier)) = numElements;
   frontier = frontier + GC_ARRAY_LENGTH_SIZE;
   *((GC_header*)(frontier)) = header;
   frontier = frontier + GC_HEADER_SIZE;
-  res = frontier;
+  result = frontier;
+  assert (isAligned ((size_t)result, s->alignment));
   /* Initialize all pointers with BOGUS_OBJPTR. */
   if (1 <= numObjptrs and 0 < numElements) {
     pointer p;
@@ -94,10 +102,10 @@
       }
     }
   }
-  GC_profileAllocInc (s, arraySize);
+  GC_profileAllocInc (s, arraySizeAligned);
   if (DEBUG_ARRAY) {
-    fprintf (stderr, "GC_arrayAllocate done.  res = "FMTPTR"  frontier = "FMTPTR"\n",
-             (uintptr_t)res, (uintptr_t)s->frontier);
+    fprintf (stderr, "GC_arrayAllocate done.  result = "FMTPTR"  frontier = "FMTPTR"\n",
+             (uintptr_t)result, (uintptr_t)s->frontier);
     displayGCState (s, stderr);
   }
   assert (ensureBytesFree <= (size_t)(s->limitPlusSlop - s->frontier));
@@ -105,5 +113,5 @@
    * unless we did the GC, we never set s->currentThread->stack->used
    * to reflect what the mutator did with stackTop.
    */
-  return res;
+  return result;
 }       

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/new-object.c	2006-12-19 20:09:46 UTC (rev 4991)
@@ -37,6 +37,7 @@
   GC_profileAllocInc (s, bytesRequested);
   *((GC_header*)frontier) = header;
   result = frontier + GC_NORMAL_HEADER_SIZE;
+  assert (isAligned ((size_t)result, s->alignment));
   if (DEBUG)
     fprintf (stderr, FMTPTR " = newObject ("FMTHDR", %zu, %s)\n",
              (uintptr_t)result,

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c	2006-12-19 18:17:31 UTC (rev 4990)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.c	2006-12-19 20:09:46 UTC (rev 4991)
@@ -50,17 +50,29 @@
 
 /* Pointer to the topmost word in use on the stack. */
 pointer getStackTop (GC_state s, GC_stack stack) {
-  return getStackBottom (s, stack) + stack->used;
+  pointer res;
+
+  res = getStackBottom (s, stack) + stack->used;
+  assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }
 
 /* Pointer to the end of stack. */
 pointer getStackLimitPlusSlop (GC_state s, GC_stack stack) {
-  return getStackBottom (s, stack) + stack->reserved;
+  pointer res;
+
+  res = getStackBottom (s, stack) + stack->reserved;
+  // assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }
 
 /* The maximum value which is valid for stackTop. */
 pointer getStackLimit (GC_state s, GC_stack stack) {
-  return getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+  pointer res;
+
+  res  = getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+  // assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }
 
 

[MLton-commit] r4990

[Matthew F. <fl...@ml...>]

Fixed an assertion failure with IntInf operations and alignment.

fenrir:~/devel/mlton/mlton.svn.trunk/regression fluet$ ./conv2
gc/new-object.c:90: assert((size_t)(p - s->frontier) <= bytes) failed.
Abort trap

The cause and solution are discussed at:
http://mlton.org/pipermail/mlton/2006-December/029452.html

Essentially:

1) Require any primitive or C call with bytesNeeded to include
sufficient bytes for any necessary headers and alignment restrictions.
[The only primitives or C calls with bytesNeeded are the IntInf
operations, which already satisfy the former, but not the later.]

2) Remove the extraneous arrayHeaderSize from bigAllocation (in
mlton/backend/limit-check.fun).

3) Include a _build_const: "MLton_Align_align", with the obvious
meaning.

4) Modify the IntInf implementation to include sufficient bytes for
the necessary alignment.


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

U   mlton/trunk/basis-library/integer/int-inf0.sml
U   mlton/trunk/basis-library/primitive/prim-mlton.sml
U   mlton/trunk/mlton/backend/limit-check.fun
U   mlton/trunk/mlton/main/lookup-constant.fun

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

Modified: mlton/trunk/basis-library/integer/int-inf0.sml
===================================================================
--- mlton/trunk/basis-library/integer/int-inf0.sml	2006-12-19 18:09:25 UTC (rev 4989)
+++ mlton/trunk/basis-library/integer/int-inf0.sml	2006-12-19 18:17:31 UTC (rev 4990)
@@ -334,6 +334,7 @@
 structure IntInf =
    struct
       structure Prim = Primitive.IntInf
+      structure MLton = Primitive.MLton
 
       structure A = Primitive.Array
       structure V = Primitive.Vector
@@ -876,8 +877,11 @@
             Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex num),
             Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex extra),
             Sz.+ (bytesPerMPLimb, (* isneg Field *)
-                  bytesPerArrayHeader (* Array Header *)
-            )))
+            Sz.+ (bytesPerArrayHeader, (* Array Header *)
+                  case MLton.Align.align of (* alignment *)
+                     MLton.Align.Align4 => 0w3
+                   | MLton.Align.Align8 => 0w7
+            ))))
       end
 
       (* badObjptr{Int,Word}{,Tagged} is the fixnum IntInf.int whose 
@@ -1202,13 +1206,16 @@
                        Int32.+ (Int32.quot (bpl, bpd),
                                 if Int32.mod (bpl, bpd) = 0
                                    then 0 else 1)
+                    val bytes =
+                       Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
+                             Sz.+ (0w1 (* sign *),
+                                   case MLton.Align.align of (* alignment *)
+                                      MLton.Align.Align4 => 0w3
+                                    | MLton.Align.Align8 => 0w7)),
+                             Sz.* (Sz.zextdFromInt32 dpl, 
+                                   Sz.zextdFromSeqIndex (numLimbs arg)))
                  in
-                    Prim.toString
-                    (arg, base, 
-                     Sz.+ (Sz.+ (bytesPerArrayHeader (* Array Header *),
-                                 0w1 (* sign *)),
-                           Sz.* (Sz.zextdFromInt32 dpl, 
-                                 Sz.zextdFromSeqIndex (numLimbs arg))))
+                    Prim.toString (arg, base, bytes)
                  end
 
       fun mkBigLog2 {fromSmall: {smallLog2: Primitive.Int32.int} -> 'a,

Modified: mlton/trunk/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-mlton.sml	2006-12-19 18:09:25 UTC (rev 4989)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml	2006-12-19 18:17:31 UTC (rev 4990)
@@ -32,6 +32,17 @@
       val gcState = #1 _symbol "gcStateAddress": t GetSet.t; ()
    end
 
+structure Align =
+   struct
+      datatype t = Align4 | Align8
+
+      val align =
+         case _build_const "MLton_Align_align": Int32.int; of
+            4 => Align4
+          | 8 => Align8
+          | _ => raise Primitive.Exn.Fail8 "MLton_Align_align"
+   end
+
 structure CallStack =
    struct
       (* The most recent caller is at index 0 in the array. *)

Modified: mlton/trunk/mlton/backend/limit-check.fun
===================================================================
--- mlton/trunk/mlton/backend/limit-check.fun	2006-12-19 18:09:25 UTC (rev 4989)
+++ mlton/trunk/mlton/backend/limit-check.fun	2006-12-19 18:17:31 UTC (rev 4990)
@@ -429,9 +429,7 @@
                 end
              fun bigAllocation (bytesNeeded: Operand.t): unit =
                 let
-                   val extraBytes =
-                      Bytes.+ (Runtime.arrayHeaderSize,
-                               blockCheckAmount {blockIndex = i})
+                   val extraBytes = blockCheckAmount {blockIndex = i}
                 in
                    case bytesNeeded of
                       Operand.Const c =>

Modified: mlton/trunk/mlton/main/lookup-constant.fun
===================================================================
--- mlton/trunk/mlton/main/lookup-constant.fun	2006-12-19 18:09:25 UTC (rev 4989)
+++ mlton/trunk/mlton/main/lookup-constant.fun	2006-12-19 18:17:31 UTC (rev 4990)
@@ -24,7 +24,10 @@
       val int = Int.toString
       open Control
    in
-      [("MLton_Codegen_codegen", fn () => int (case !codegen of
+      [("MLton_Align_align", fn () => int (case !align of
+                                              Align4 => 4
+                                            | Align8 => 8)),
+       ("MLton_Codegen_codegen", fn () => int (case !codegen of
                                                   Bytecode => 0
                                                 | CCodegen => 1
                                                 | Native => 2)),

[MLton-commit] r4989

[Matthew F. <fl...@ml...>]

Added assertion that new objects are properly aligned
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/new-object.c
U   mlton/trunk/runtime/gc/stack.c

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

Modified: mlton/trunk/runtime/gc/new-object.c
===================================================================
--- mlton/trunk/runtime/gc/new-object.c	2006-12-19 18:08:40 UTC (rev 4988)
+++ mlton/trunk/runtime/gc/new-object.c	2006-12-19 18:09:25 UTC (rev 4989)
@@ -37,6 +37,7 @@
   GC_profileAllocInc (s, bytesRequested);
   *((GC_header*)frontier) = header;
   result = frontier + GC_NORMAL_HEADER_SIZE;
+  assert (isAligned ((size_t)result, s->alignment));
   if (DEBUG)
     fprintf (stderr, FMTPTR " = newObject ("FMTHDR", %zu, %s)\n",
              (uintptr_t)result,

Modified: mlton/trunk/runtime/gc/stack.c
===================================================================
--- mlton/trunk/runtime/gc/stack.c	2006-12-19 18:08:40 UTC (rev 4988)
+++ mlton/trunk/runtime/gc/stack.c	2006-12-19 18:09:25 UTC (rev 4989)
@@ -50,17 +50,29 @@
 
 /* Pointer to the topmost word in use on the stack. */
 pointer getStackTop (GC_state s, GC_stack stack) {
-  return getStackBottom (s, stack) + stack->used;
+  pointer res;
+
+  res = getStackBottom (s, stack) + stack->used;
+  assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }
 
 /* Pointer to the end of stack. */
 pointer getStackLimitPlusSlop (GC_state s, GC_stack stack) {
-  return getStackBottom (s, stack) + stack->reserved;
+  pointer res;
+
+  res = getStackBottom (s, stack) + stack->reserved;
+  // assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }
 
 /* The maximum value which is valid for stackTop. */
 pointer getStackLimit (GC_state s, GC_stack stack) {
-  return getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+  pointer res;
+
+  res  = getStackLimitPlusSlop (s, stack) - sizeofStackSlop (s);
+  // assert (isAligned ((size_t)res, s->alignment));
+  return res;
 }