diff options
| author |  Benjamin Barenblat <bbaren@mit.edu> | 2016-02-13 10:41:17 -0500 |
|---|---|---|
| committer | Benjamin Barenblat <bbaren@mit.edu> | 2016-02-13 10:41:17 -0500 |
| commit | 5ca6148aaf7b930a8868d0543f1a307d40532243 (patch) | |
| tree | 55ec538c5bdef601b0ac8ebca71ad495f644326d | |
| parent | 3d3886672433f0775f772d8d2ee47c5f5e0bc745 (diff) | |
| parent | 3044fbedd58961f8c1168eb3bc2eeeb8a2b0b60e (diff) | |
Merge branch 'upstream' into dfsg_clean20160213+dfsg
54 files changed, 390 insertions, 298 deletions
@@ -1,5 +1,3 @@ -syntax: glob - *~ .cm src/.cm @@ -72,9 +70,9 @@ tests/*.db syntax: regexp -^Makefile$ -^src/c/Makefile$ -^libtool$ -^include/urweb/config.h$ -^include/urweb/config.h.in$ -^include/urweb/stamp-h1$ +Makefile +src/c/Makefile +libtool +include/urweb/config.h +include/urweb/config.h.in +include/urweb/stamp-h1 diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..0b2b8b90 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,27 @@ +language: c + +os: + - linux + - osx + +compiler: + - clang + - gcc + +# when https://github.com/travis-ci/apt-package-whitelist/issues/792 is closed, use the container-based infrastructure +#sudo: false +#addons: +# apt: +# packages: +# - mlton + +before_install: + - export CONFIGURE_ARGS="" + - if command -v apt-get &>/dev/null; then sudo apt-get update -qq; fi + - if command -v apt-get &>/dev/null; then sudo apt-get install -y mlton; fi + - if command -v brew &>/dev/null; then brew update; fi + - if command -v brew &>/dev/null; then brew tap MLton/mlton; fi + - if command -v brew &>/dev/null; then brew install openssl mlton; fi + - if command -v brew &>/dev/null; then export CONFIGURE_ARGS="--with-openssl=/usr/local/opt/openssl"; fi + +script: ./autogen.sh && ./configure $CONFIGURE_ARGS && make && make test @@ -1,4 +1,13 @@ ======== +20160213 +======== + +- .urp 'library' directive: only process a given library the first time it is referenced +- For maintenance of Ur/Web project source code, switched from Mercurial to Git +- Added Travis integration +- Bug fixes and improvements to type inference and compatibility + +======== 20151220 ======== diff --git a/Makefile.am b/Makefile.am index ab11999e..9ab31acd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -105,12 +105,6 @@ uninstall-local-main: uninstall-local: uninstall-local-main uninstall-emacs -package: - hg archive -t tgz -X tests "/tmp/urweb-$(VERSION).tgz" - -reauto: - ./autogen.sh - EXTRA_DIST = demo doc lib/js lib/ur xml \ src/coq src/*.sig src/*.sml src/*.mlb src/config.sml.in src/elisp src/*.cm src/sources src/*.grm src/*.lex \ CHANGELOG LICENSE urweb.ebuild include/urweb/*.h bin diff --git a/README.md b/README.md new file mode 100644 index 00000000..3bfd94a1 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +[](https://travis-ci.org/urweb/urweb) + +# The Ur/Web Programming Language + +Implementation of a domain-specific functional programming language for web applications. Please see [the Ur/Web project web site](http://www.impredicative.com/ur/) for much more information! Here's a summary: + +Ur is a programming language in the tradition of ML and Haskell, but featuring a significantly richer type system. Ur is functional, pure, statically typed, and strict. Ur supports a powerful kind of metaprogramming based on row types. + +Ur/Web is Ur plus a special standard library and associated rules for parsing and optimization. Ur/Web supports construction of dynamic web applications backed by SQL databases. The signature of the standard library is such that well-typed Ur/Web programs "don't go wrong" in a very broad sense. Not only do they not crash during particular page generations, but they also may not: + +* Suffer from any kinds of code-injection attacks +* Return invalid HTML +* Contain dead intra-application links +* Have mismatches between HTML forms and the fields expected by their handlers +* Include client-side code that makes incorrect assumptions about the "AJAX"-style services that the remote web server provides +* Attempt invalid SQL queries +* Use improper marshaling or unmarshaling in communication with SQL databases or between browsers and web servers + +This type safety is just the foundation of the Ur/Web methodology. It is also possible to use metaprogramming to build significant application pieces by analysis of type structure. For instance, the demo includes an ML-style functor for building an admin interface for an arbitrary SQL table. The type system guarantees that the admin interface sub-application that comes out will always be free of the above-listed bugs, no matter which well-typed table description is given as input. + +The Ur/Web compiler also produces very efficient object code that does not use garbage collection. These compiled programs will often be even more efficient than what most programmers would bother to write in C. For example, the standalone web server generated for the demo uses less RAM than the bash shell. The compiler also generates JavaScript versions of client-side code, with no need to write those parts of applications in a different language. diff --git a/configure.ac b/configure.ac index a8060104..351d1129 100644 --- a/configure.ac +++ b/configure.ac @@ -1,14 +1,14 @@ -AC_INIT([urweb], [20151220]) +AC_INIT([urweb], [20160213]) WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it m4_ifdef([AM_PROG_AR], [AM_PROG_AR]) +AC_CONFIG_MACRO_DIR([m4]) AM_INIT_AUTOMAKE([-Wall -Werror foreign no-define]) AC_PROG_CC() AC_PROG_LIBTOOL() -AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_HEADERS([include/urweb/config.h]) AX_PTHREAD([echo >/dev/null], [echo "Your C compiler does not support POSIX threads."; exit 1]) @@ -91,25 +91,7 @@ if test [-z $SQHEADER]; then fi if test [$WORKING_VERSION = "1"]; then - VERSION="$VERSION + `hg identify || (cat .hg_archival.txt | grep 'node\:') || echo ?`" -fi - -# Clang does not like being passed -pthread, since it's implicit on OS X. -# So let's get rid of that! Here's to hoping it doesn't break Clang -# on other platforms. -AC_MSG_CHECKING([if compiling with clang]) -AC_COMPILE_IFELSE( -[AC_LANG_PROGRAM([], [[ -#ifndef __clang__ - not clang -#endif -]])], -[CLANG=yes], [CLANG=no]) -AC_MSG_RESULT([$CLANG]) - -if test [$CLANG = "yes"]; then - PTHREAD_CFLAGS="" - PTHREAD_LIBS="" + VERSION="$VERSION + `git log -1 --format="%H" || echo ?`" fi # Check if pthread_t is a scalar or pointer type so we can use the correct @@ -160,7 +142,7 @@ Ur/Web configuration: include directory: INCLUDE $INCLUDE site-lisp directory: SITELISP $SITELISP C compiler: CC $CC - Extra CC args: CCARGS $CCARGS + Extra CC args: CCARGS $CCARGS Extra MLTON args: MLTONARGS $MLTONARGS Postgres C header: PGHEADER $PGHEADER MySQL C header: MSHEADER $MSHEADER diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index ce0f2825..77e4c611 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -130,7 +130,12 @@ typedef struct uw_Sqlcache_Value { unsigned long timeValid; } uw_Sqlcache_Value; -typedef struct uw_Sqlcache_Entry uw_Sqlcache_Entry; +typedef struct uw_Sqlcache_Entry { + char *key; + uw_Sqlcache_Value *value; + unsigned long timeInvalid; + UT_hash_handle hh; +} uw_Sqlcache_Entry; typedef struct uw_Sqlcache_Cache { pthread_rwlock_t lockOut; diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 14ec4612..410a0e23 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1823,8 +1823,6 @@ function lookup(env, n) { function execP(env, p, v) { switch (p.c) { - case "w": - return env; case "v": return cons(v, env); case "c": @@ -1850,7 +1848,7 @@ function execP(env, p, v) { } return env; default: - whine("Unknown Ur pattern kind" + p.c); + whine("Unknown Ur pattern kind " + p.c); } } diff --git a/m4/m4_ax_pthread.m4 b/m4/m4_ax_pthread.m4 index a6bf596c..0b2718f3 100644 --- a/m4/m4_ax_pthread.m4 +++ b/m4/m4_ax_pthread.m4 @@ -82,7 +82,7 @@ # modified version of the Autoconf Macro, you may extend this special # exception to the GPL to apply to your modified version as well. -#serial 16 +#serial 21 AU_ALIAS([ACX_PTHREAD], [AX_PTHREAD]) AC_DEFUN([AX_PTHREAD], [ @@ -103,8 +103,8 @@ if test x"$PTHREAD_LIBS$PTHREAD_CFLAGS" != x; then save_LIBS="$LIBS" LIBS="$PTHREAD_LIBS $LIBS" AC_MSG_CHECKING([for pthread_join in LIBS=$PTHREAD_LIBS with CFLAGS=$PTHREAD_CFLAGS]) - AC_TRY_LINK_FUNC(pthread_join, ax_pthread_ok=yes) - AC_MSG_RESULT($ax_pthread_ok) + AC_TRY_LINK_FUNC([pthread_join], [ax_pthread_ok=yes]) + AC_MSG_RESULT([$ax_pthread_ok]) if test x"$ax_pthread_ok" = xno; then PTHREAD_LIBS="" PTHREAD_CFLAGS="" @@ -145,8 +145,8 @@ ax_pthread_flags="pthreads none -Kthread -kthread lthread -pthread -pthreads -mt # --thread-safe: KAI C++ # pthread-config: use pthread-config program (for GNU Pth library) -case "${host_cpu}-${host_os}" in - *solaris*) +case ${host_os} in + solaris*) # On Solaris (at least, for some versions), libc contains stubbed # (non-functional) versions of the pthreads routines, so link-based @@ -158,12 +158,22 @@ case "${host_cpu}-${host_os}" in ax_pthread_flags="-pthreads pthread -mt -pthread $ax_pthread_flags" ;; - - *-darwin*) - ax_pthread_flags="-pthread $ax_pthread_flags" - ;; esac +# Clang doesn't consider unrecognized options an error unless we specify +# -Werror. We throw in some extra Clang-specific options to ensure that +# this doesn't happen for GCC, which also accepts -Werror. + +AC_MSG_CHECKING([if compiler needs -Werror to reject unknown flags]) +save_CFLAGS="$CFLAGS" +ax_pthread_extra_flags="-Werror" +CFLAGS="$CFLAGS $ax_pthread_extra_flags -Wunknown-warning-option -Wsizeof-array-argument" +AC_COMPILE_IFELSE([AC_LANG_PROGRAM([int foo(void);],[foo()])], + [AC_MSG_RESULT([yes])], + [ax_pthread_extra_flags= + AC_MSG_RESULT([no])]) +CFLAGS="$save_CFLAGS" + if test x"$ax_pthread_ok" = xno; then for flag in $ax_pthread_flags; do @@ -178,7 +188,7 @@ for flag in $ax_pthread_flags; do ;; pthread-config) - AC_CHECK_PROG(ax_pthread_config, pthread-config, yes, no) + AC_CHECK_PROG([ax_pthread_config], [pthread-config], [yes], [no]) if test x"$ax_pthread_config" = xno; then continue; fi PTHREAD_CFLAGS="`pthread-config --cflags`" PTHREAD_LIBS="`pthread-config --ldflags` `pthread-config --libs`" @@ -193,7 +203,7 @@ for flag in $ax_pthread_flags; do save_LIBS="$LIBS" save_CFLAGS="$CFLAGS" LIBS="$PTHREAD_LIBS $LIBS" - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" + CFLAGS="$CFLAGS $PTHREAD_CFLAGS $ax_pthread_extra_flags" # Check for various functions. We must include pthread.h, # since some functions may be macros. (On the Sequent, we @@ -219,7 +229,7 @@ for flag in $ax_pthread_flags; do LIBS="$save_LIBS" CFLAGS="$save_CFLAGS" - AC_MSG_RESULT($ax_pthread_ok) + AC_MSG_RESULT([$ax_pthread_ok]) if test "x$ax_pthread_ok" = xyes; then break; fi @@ -245,54 +255,70 @@ if test "x$ax_pthread_ok" = xyes; then [attr_name=$attr; break], []) done - AC_MSG_RESULT($attr_name) + AC_MSG_RESULT([$attr_name]) if test "$attr_name" != PTHREAD_CREATE_JOINABLE; then - AC_DEFINE_UNQUOTED(PTHREAD_CREATE_JOINABLE, $attr_name, + AC_DEFINE_UNQUOTED([PTHREAD_CREATE_JOINABLE], [$attr_name], [Define to necessary symbol if this constant uses a non-standard name on your system.]) fi AC_MSG_CHECKING([if more special flags are required for pthreads]) flag=no - case "${host_cpu}-${host_os}" in - *-aix* | *-freebsd* | *-darwin*) flag="-D_THREAD_SAFE";; - *solaris* | *-osf* | *-hpux*) flag="-D_REENTRANT";; + case ${host_os} in + aix* | freebsd* | darwin*) flag="-D_THREAD_SAFE";; + osf* | hpux*) flag="-D_REENTRANT";; + solaris*) + if test "$GCC" = "yes"; then + flag="-D_REENTRANT" + else + # TODO: What about Clang on Solaris? + flag="-mt -D_REENTRANT" + fi + ;; esac - AC_MSG_RESULT(${flag}) + AC_MSG_RESULT([$flag]) if test "x$flag" != xno; then PTHREAD_CFLAGS="$flag $PTHREAD_CFLAGS" fi AC_CACHE_CHECK([for PTHREAD_PRIO_INHERIT], - ax_cv_PTHREAD_PRIO_INHERIT, [ - AC_LINK_IFELSE([ - AC_LANG_PROGRAM([[#include <pthread.h>]], [[int i = PTHREAD_PRIO_INHERIT;]])], + [ax_cv_PTHREAD_PRIO_INHERIT], [ + AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <pthread.h>]], + [[int i = PTHREAD_PRIO_INHERIT;]])], [ax_cv_PTHREAD_PRIO_INHERIT=yes], [ax_cv_PTHREAD_PRIO_INHERIT=no]) ]) AS_IF([test "x$ax_cv_PTHREAD_PRIO_INHERIT" = "xyes"], - AC_DEFINE([HAVE_PTHREAD_PRIO_INHERIT], 1, [Have PTHREAD_PRIO_INHERIT.])) + [AC_DEFINE([HAVE_PTHREAD_PRIO_INHERIT], [1], [Have PTHREAD_PRIO_INHERIT.])]) LIBS="$save_LIBS" CFLAGS="$save_CFLAGS" - # More AIX lossage: must compile with xlc_r or cc_r - if test x"$GCC" != xyes; then - AC_CHECK_PROGS(PTHREAD_CC, xlc_r cc_r, ${CC}) - else - PTHREAD_CC=$CC + # More AIX lossage: compile with *_r variant + if test "x$GCC" != xyes; then + case $host_os in + aix*) + AS_CASE(["x/$CC"], + [x*/c89|x*/c89_128|x*/c99|x*/c99_128|x*/cc|x*/cc128|x*/xlc|x*/xlc_v6|x*/xlc128|x*/xlc128_v6], + [#handle absolute path differently from PATH based program lookup + AS_CASE(["x$CC"], + [x/*], + [AS_IF([AS_EXECUTABLE_P([${CC}_r])],[PTHREAD_CC="${CC}_r"])], + [AC_CHECK_PROGS([PTHREAD_CC],[${CC}_r],[$CC])])]) + ;; + esac fi -else - PTHREAD_CC="$CC" fi -AC_SUBST(PTHREAD_LIBS) -AC_SUBST(PTHREAD_CFLAGS) -AC_SUBST(PTHREAD_CC) +test -n "$PTHREAD_CC" || PTHREAD_CC="$CC" + +AC_SUBST([PTHREAD_LIBS]) +AC_SUBST([PTHREAD_CFLAGS]) +AC_SUBST([PTHREAD_CC]) # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x"$ax_pthread_ok" = xyes; then - ifelse([$1],,AC_DEFINE(HAVE_PTHREAD,1,[Define if you have POSIX threads libraries and header files.]),[$1]) + ifelse([$1],,[AC_DEFINE([HAVE_PTHREAD],[1],[Define if you have POSIX threads libraries and header files.])],[$1]) : else ax_pthread_ok=no diff --git a/src/c/openssl.c b/src/c/openssl.c index 981d48da..15c4de5e 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -35,14 +35,15 @@ static void random_password() { // OpenSSL callbacks #ifdef PTHREAD_T_IS_POINTER -# define CRYPTO_THREADID_SET CRYPTO_THREADID_set_pointer +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_pointer(result, pthread_self()); +} #else -# define CRYPTO_THREADID_SET CRYPTO_THREADID_set_numeric -#endif static void thread_id(CRYPTO_THREADID *const result) { - CRYPTO_THREADID_SET(result, pthread_self()); + CRYPTO_THREADID_set_numeric(result, (unsigned long)pthread_self()); } -#undef CRYPTO_THREADID_SET +#endif + static void lock_or_unlock(const int mode, const int type, const char *file, const int line) { pthread_mutex_t *const lock = &openssl_locks[type]; diff --git a/src/c/urweb.c b/src/c/urweb.c index 50aac5e8..c057688c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4562,13 +4562,6 @@ void uw_set_remoteSock(uw_context ctx, int sock) { // Sqlcache -typedef struct uw_Sqlcache_Entry { - char *key; - uw_Sqlcache_Value *value; - unsigned long timeInvalid; - UT_hash_handle hh; -} uw_Sqlcache_Entry; - static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) { if (value) { free(value->result); diff --git a/src/cjr.sml b/src/cjr.sml index 3742a06f..e582e6ae 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -46,8 +46,7 @@ datatype patCon = | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = - PWild - | PVar of string * typ + PVar of string * typ | PPrim of Prim.t | PCon of datatype_kind * patCon * pat option | PRecord of (string * pat * typ) list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2c2133d6..2471ce59 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -163,9 +163,7 @@ fun p_con_named env n = fun p_pat_preamble env (p, _) = case p of - PWild => (box [], - env) - | PVar (x, t) => (box [p_typ env t, + PVar (x, t) => (box [p_typ env t, space, string "__uwr_", p_ident x, @@ -194,8 +192,7 @@ fun p_patCon env pc = fun p_patMatch (env, disc) (p, loc) = case p of - PWild => string "1" - | PVar _ => string "1" + PVar _ => string "1" | PPrim (Prim.Int n) => box [string ("(" ^ disc), space, string "==", @@ -318,9 +315,7 @@ fun p_patMatch (env, disc) (p, loc) = fun p_patBind (env, disc) (p, loc) = case p of - PWild => - (box [], env) - | PVar (x, t) => + PVar (x, t) => (box [p_typ env t, space, string "__uwr_", @@ -2356,7 +2351,7 @@ fun p_fun isRec env (fx, n, args, ran, e) = val global_initializers : Print.PD.pp_desc list ref = ref [] -fun p_decl env (dAll as (d, _) : decl) = +fun p_decl env (dAll as (d, loc) : decl) = case d of DStruct (n, xts) => let @@ -2378,9 +2373,6 @@ fun p_decl env (dAll as (d, _) : decl) = end | DDatatype dts => let - val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) => - dk1 = Enum andalso dk2 <> Enum) dts - fun p_one (Enum, x, n, xncs) = box [string "enum", space, @@ -2605,6 +2597,23 @@ fun p_file env (ds, ps) = self := NONE; global_initializers := []) + (* First, pull out all of the enumerated types, to be declared first. *) + val (ds, enums) = ListUtil.foldlMapPartial (fn (d, enums) => + case #1 d of + DDatatype dts => + let + val (enum, other) = List.partition (fn (Enum, _, _, _) => true + | _ => false) dts + in + (SOME (DDatatype other, #2 d), + List.revAppend (enum, enums)) + end + | DDatatypeForward (Enum, _, _) => (NONE, enums) + | _ => (SOME d, enums)) + [] ds + + val ds = (DDatatype enums, ErrorMsg.dummySpan) :: ds + val (pds, env) = ListUtil.foldlMap (fn (d, env) => let val d' = p_decl env d diff --git a/src/cjrize.sml b/src/cjrize.sml index 5f6ae4d8..fbc7eba1 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -191,8 +191,7 @@ fun cifyPatCon (pc, sm) = fun cifyPat ((p, loc), sm) = case p of - L.PWild => ((L'.PWild, loc), sm) - | L.PVar (x, t) => + L.PVar (x, t) => let val (t, sm) = cifyTyp (t, sm) in diff --git a/src/compiler.sml b/src/compiler.sml index bf7491e5..7580c5e4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, 2014, Adam Chlipala +(* Copyright (c) 2008-2012, 2014, 2016, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -412,6 +412,14 @@ fun inputCommentableLine inf = val lastUrp = ref "" +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) + fun parseUrp' accLibs fname = (lastUrp := fname; if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) @@ -459,6 +467,7 @@ fun parseUrp' accLibs fname = let val pathmap = ref (!pathmap) val bigLibs = ref [] + val libSet = ref SS.empty fun pu filename = let @@ -822,10 +831,19 @@ fun parseUrp' accLibs fname = fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind end | _ => ErrorMsg.error "Bad 'deny' syntax") - | "library" => if accLibs then - libs := pu (libify (relify arg)) :: !libs - else - bigLibs := libify' arg :: !bigLibs + | "library" => + if accLibs then + let + val arg = libify (relify arg) + in + if SS.member (!libSet, arg) then + () + else + (libs := pu arg :: !libs; + libSet := SS.add (!libSet, arg)) + end + else + bigLibs := libify' arg :: !bigLibs | "path" => (case String.fields (fn ch => ch = #"=") arg of [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir})) @@ -878,7 +896,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; Settings.addJsFile arg) - + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -936,14 +954,6 @@ fun addModuleRoot (k, v) = moduleRoots := relativeTo = OS.FileSys.getDir ()}, v) :: !moduleRoots -structure SK = struct -type ord_key = string -val compare = String.compare -end - -structure SS = BinarySetFn(SK) -structure SM = BinaryMapFn(SK) - exception MissingFile of string val parse = { @@ -1503,7 +1513,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = let val proto = Settings.currentProtocol () - val lib = if Settings.getStaticLinking () then + val lib = if Settings.getBootLinking () then + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + else if Settings.getStaticLinking () then " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" @@ -1518,7 +1530,16 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = ^ " " ^ #compile proto ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname - val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs) + fun concatArgs (a1, a2) = + if CharVector.all Char.isSpace a1 then + a2 + else + a1 ^ " " ^ a2 + + val args = concatArgs (Config.ccArgs, Config.pthreadCflags) + val args = concatArgs (args, Config.pthreadLibs) + + val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ args) val ssl = if Settings.getStaticLinking () then Config.openssl ^ " -ldl -lz" diff --git a/src/core.sml b/src/core.sml index 193825bf..8f57c31f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -78,8 +78,7 @@ datatype patCon = con : string, arg : con option, kind : datatype_kind} datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/core_env.sml b/src/core_env.sml index 9a4f9ec7..7d78bdee 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -354,8 +354,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -363,8 +362,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p @@ -372,8 +370,7 @@ fun patBindsN (p, loc) = fun patBindsL (p, loc) = case p of - PWild => [] - | PVar (x, t) => [(x, t)] + PVar (x, t) => [(x, t)] | PPrim _ => [] | PCon (_, _, _, NONE) => [] | PCon (_, _, _, SOME p) => patBindsL p diff --git a/src/core_print.sml b/src/core_print.sml index f360f346..5c71e978 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -224,8 +224,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, _, NONE) => p_patCon env n | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/core_util.sml b/src/core_util.sml index 9ca85c37..57ef16f7 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -416,11 +416,7 @@ fun pcCompare (pc1, pc2) = fun pCompare ((p1, _), (p2, _)) = case (p1, p2) of - (PWild, PWild) => EQUAL - | (PWild, _) => LESS - | (_, PWild) => GREATER - - | (PVar _, PVar _) => EQUAL + (PVar _, PVar _) => EQUAL | (PVar _, _) => LESS | (_, PVar _) => GREATER @@ -712,8 +708,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -771,8 +766,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/corify.sml b/src/corify.sml index 5d58efcc..19cd3ec8 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -529,8 +529,7 @@ fun corifyPatCon st pc = fun corifyPat st (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) + L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, ts, po) => (L'.PCon (dk, corifyPatCon st pc, map (corifyCon st) ts, Option.map (corifyPat st) po), loc) diff --git a/src/elab.sml b/src/elab.sml index 209d3307..90c14e4b 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -97,8 +97,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/elab_env.sml b/src/elab_env.sml index 3523b576..cb08f348 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1563,8 +1563,7 @@ fun projectConstraints env {sgn, str} = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -1572,8 +1571,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p diff --git a/src/elab_print.sml b/src/elab_print.sml index 5a41883f..06ea097f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -289,8 +289,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc, diff --git a/src/elab_util.sml b/src/elab_util.sml index ed2e82a0..0cdb9cc1 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -346,8 +346,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fun doVars ((p, _), ctx) = case p of - PWild => ctx - | PVar xt => bind (ctx, RelE xt) + PVar xt => bind (ctx, RelE xt) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => doVars (p, ctx) @@ -452,8 +451,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -517,8 +515,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/elaborate.sml b/src/elaborate.sml index 25cce6bd..6965adfd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -163,22 +163,25 @@ r := L'.KKnown k1All) handle Subscript => err KIncompatible) | (L'.KTupleUnif (loc, nks1, r1 as ref (L'.KUnknown f1)), L'.KTupleUnif (_, nks2, r2 as ref (L'.KUnknown f2))) => - let - val nks = foldl (fn (p as (n, k1), nks) => - case ListUtil.search (fn (n', k2) => - if n' = n then - SOME k2 - else - NONE) nks2 of - NONE => p :: nks - | SOME k2 => (unifyKinds' env k1 k2; - nks)) nks2 nks1 + if r1 = r2 then + () + else + let + val nks = foldl (fn (p as (n, k1), nks) => + case ListUtil.search (fn (n', k2) => + if n' = n then + SOME k2 + else + NONE) nks2 of + NONE => p :: nks + | SOME k2 => (unifyKinds' env k1 k2; + nks)) nks2 nks1 - val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) - in - r1 := L'.KKnown k; - r2 := L'.KKnown k - end + val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) + in + r1 := L'.KKnown k; + r2 := L'.KKnown k + end | _ => err KIncompatible end @@ -282,6 +285,7 @@ fun hnormKind (kAll as (k, _)) = case k of L'.KUnif (_, _, ref (L'.KKnown k)) => hnormKind k + | L'.KTupleUnif (_, _, ref (L'.KKnown k)) => hnormKind k | _ => kAll open ElabOps @@ -641,10 +645,10 @@ | (L'.KUnif (_, _, r), _) => let val ku = kunif env loc - val k = (L'.KTupleUnif (loc, [(n, ku)], r), loc) + val k = (L'.KTupleUnif (loc, [(n, ku)], ref (L'.KUnknown (fn _ => true))), loc) in r := L'.KKnown k; - k + ku end | (L'.KTupleUnif (_, nks, r), _) => (case ListUtil.search (fn (n', k) => if n' = n then SOME k else NONE) nks of @@ -652,10 +656,10 @@ | NONE => let val ku = kunif env loc - val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), r), loc) + val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), ref (L'.KUnknown (fn _ => true))), loc) in r := L'.KKnown k; - k + ku end) | k => raise CUnify' (env, CKindof (k, c, "tuple"))) @@ -1341,6 +1345,31 @@ | (L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, fn () => err CIncompatible) | (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, fn () => err CIncompatible) + | (L'.CTuple cs, L'.CRel x) => + (case hnormKind (kindof env c2All) of + (L'.KTuple ks, _) => + if length cs <> length ks then + err CIncompatible + else + let + fun rightProjs (cs, n) = + case cs of + c :: cs' => + (case hnormCon env c of + (L'.CProj ((L'.CRel x', _), n'), _) => + x' = x andalso n' = n andalso rightProjs (cs', n+1) + | _ => false) + | [] => true + in + if rightProjs (cs, 1) then + () + else + err CIncompatible + end + | _ => err CIncompatible) + | (L'.CRel x, L'.CTuple cs) => + unifyCons'' env loc c2All c1All + | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => (unifyKinds env dom1 dom2; unifyKinds env ran1 ran2) @@ -1497,8 +1526,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = let - val perror = (L'.PWild, loc) val terror = (L'.CError, loc) + val perror = (L'.PVar ("_", terror), loc) val pterror = (perror, terror) val rerror = (pterror, (env, bound)) @@ -1534,11 +1563,9 @@ fun elabPat (pAll as (p, loc), (env, bound)) = end in case p of - L.PWild => (((L'.PWild, loc), cunif env (loc, (L'.KType, loc))), - (env, bound)) - | L.PVar x => + L.PVar x => let - val t = if SS.member (bound, x) then + val t = if x <> "_" andalso SS.member (bound, x) then (expError env (DuplicatePatternVariable (loc, x)); terror) else @@ -1613,6 +1640,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = (* This exhaustiveness checking follows Luc Maranget's paper "Warnings for pattern matching." *) fun exhaustive (env, t, ps, loc) = let + val pwild = L'.PVar ("_", t) + fun fail n = raise Fail ("Elaborate.exhaustive: Impossible " ^ Int.toString n) fun patConNum pc = @@ -1654,7 +1683,7 @@ fun exhaustive (env, t, ps, loc) = val loc = #2 p1 fun wild () = - SOME (map (fn _ => (L'.PWild, loc)) args @ ps) + SOME (map (fn _ => (pwild, loc)) args @ ps) in case #1 p1 of L'.PPrim _ => NONE @@ -1675,9 +1704,8 @@ fun exhaustive (env, t, ps, loc) = SOME p else NONE) xpts of - NONE => (L'.PWild, loc) + NONE => (pwild, loc) | SOME p => p) args @ ps) - | L'.PWild => wild () | L'.PVar _ => wild () end) P @@ -1687,8 +1715,7 @@ fun exhaustive (env, t, ps, loc) = (fn [] => fail 2 | (p1, _) :: ps => case p1 of - L'.PWild => SOME ps - | L'.PVar _ => SOME ps + L'.PVar _ => SOME ps | L'.PPrim _ => NONE | L'.PCon _ => NONE | L'.PRecord _ => NONE) @@ -1818,8 +1845,8 @@ fun exhaustive (env, t, ps, loc) = | SOME ps => let val p = case cons of - [] => L'.PWild - | (0, _) :: _ => L'.PWild + [] => pwild + | (0, _) :: _ => pwild | _ => case IS.find (fn _ => true) unused of NONE => fail 6 @@ -1832,7 +1859,7 @@ fun exhaustive (env, t, ps, loc) = SOME (n, []) => L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], NONE) | SOME (n, [_]) => - L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (L'.PWild, loc)) + L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (pwild, loc)) | _ => fail 7 in SOME ((p, loc) :: ps) diff --git a/src/expl.sml b/src/expl.sml index 3d784e3f..994c05cf 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -77,8 +77,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/expl_env.sml b/src/expl_env.sml index 5712a72d..f7f51be5 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -404,8 +404,7 @@ fun sgiBinds env (sgi, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p diff --git a/src/expl_print.sml b/src/expl_print.sml index 22d246e2..10ea6056 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -215,8 +215,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, cs, SOME p) => diff --git a/src/expl_rename.sml b/src/expl_rename.sml index bb763a60..bdcf1aa4 100644 --- a/src/expl_rename.sml +++ b/src/expl_rename.sml @@ -99,8 +99,7 @@ fun renamePatCon st pc = fun renamePat st (all as (p, loc)) = case p of - PWild => all - | PVar (x, c) => (PVar (x, renameCon st c), loc) + PVar (x, c) => (PVar (x, renameCon st c), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, renamePatCon st pc, map (renameCon st) cs, diff --git a/src/explify.sml b/src/explify.sml index f38151d2..e2a317a2 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -90,8 +90,7 @@ fun explifyPatCon pc = fun explifyPat (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) + L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, cs, po) => (L'.PCon (dk, explifyPatCon pc, map explifyCon cs, Option.map explifyPat po), loc) | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, explifyPat p, explifyCon t)) xps), loc) diff --git a/src/iflow.sml b/src/iflow.sml index 8bde7ea3..5e8d697e 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1405,8 +1405,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun evalPat env e (pt, _) = case pt of - PWild => env - | PVar _ => e :: env + PVar _ => e :: env | PPrim _ => env | PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env) | PCon (_, pc, SOME pt) => @@ -2045,8 +2044,7 @@ fun check (file : file) = let fun doPat (p, env) = case #1 p of - PWild => env - | PVar _ => v :: env + PVar _ => v :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => doPat (p, env) diff --git a/src/jscomp.sml b/src/jscomp.sml index e5a0cb27..65a0fa3a 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -458,8 +458,7 @@ fun process (file : file) = fun jsPat (p, _) = case p of - PWild => str "{c:\"w\"}" - | PVar _ => str "{c:\"v\"}" + PVar _ => str "{/*hoho*/c:\"v\"}" | PPrim p => strcat [str "{c:\"c\",v:", jsPrim p, str "}"] @@ -1009,8 +1008,7 @@ fun process (file : file) = fun patBinds ((p, _), env) = case p of - PWild => env - | PVar (_, t) => t :: env + PVar (_, t) => t :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds (p, env) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 67732b58..f595134f 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -64,7 +64,7 @@ fun oneRun args = fun doArgs args = case args of [] => () - | "-version" :: rest => + | "-version" :: rest => printVersion () | "-numeric-version" :: rest => printNumericVersion () @@ -151,7 +151,7 @@ fun oneRun args = doArgs rest) | "-boot" :: rest => (Compiler.enableBoot (); - Settings.setStaticLinking true; + Settings.setBootLinking true; doArgs rest) | "-sigfile" :: name :: rest => (Settings.setSigFile (SOME name); @@ -318,7 +318,7 @@ val () = case CommandLine.arguments () of (* Redirect the daemon's output to the socket. *) redirect Posix.FileSys.stdout; redirect Posix.FileSys.stderr; - + loop' ("", []); Socket.close sock; diff --git a/src/mono.sml b/src/mono.sml index b05c3dcc..cdadded5 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -48,8 +48,7 @@ datatype patCon = | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = - PWild - | PVar of string * typ + PVar of string * typ | PPrim of Prim.t | PCon of datatype_kind * patCon * pat option | PRecord of (string * pat * typ) list diff --git a/src/mono_env.sml b/src/mono_env.sml index 52e07893..0dd668ea 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -148,8 +148,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t NONE + PVar (x, t) => pushERel env x t NONE | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds env p @@ -159,8 +158,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBindsN p diff --git a/src/mono_print.sml b/src/mono_print.sml index 3e498d2c..a3b55ec0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -105,8 +105,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, NONE) => p_patCon env n | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 61866af7..540d396b 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -191,8 +191,7 @@ datatype result = Yes of (string * typ * exp) list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes ((x, t, e) :: env) + (PVar (x, t), _) => Yes ((x, t, e) :: env) | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => if String.isPrefix s' s then @@ -300,8 +299,7 @@ val p_events = Print.p_list p_event fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBinds p diff --git a/src/mono_util.sml b/src/mono_util.sml index 5d7eb164..fc1a2bcb 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -235,8 +235,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, NONE) => ctx | PCon (_, _, SOME p) => pb (p, ctx) diff --git a/src/monoize.sml b/src/monoize.sml index 75851a48..6715290f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -440,8 +440,7 @@ fun monoPat env (all as (p, loc)) = dummyPat) in case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) + L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) => @@ -1430,16 +1429,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = string), ("2", str (Settings.mangleSql (lowercaseFirst nm2)), string)], loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), (L'.ERecord [("1", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm1) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "1"), loc)), + (L'.EField ((L'.ERel 1, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm2) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "2"), loc)), + (L'.EField ((L'.ERel 1, loc), "2"), loc)), loc), string)], loc))], {disc = string, @@ -1484,9 +1483,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), strcat [str (" ON " ^ kw ^ " "), - (L'.EField ((L'.ERel 0, loc), fd), loc)])], + (L'.EField ((L'.ERel 1, loc), fd), loc)])], {disc = string, result = string}), loc) in @@ -2013,6 +2012,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), (L'.EAbs ("tab2", s, s, @@ -2022,17 +2022,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 0, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PWild, loc), - strcat [(L'.ERel 1, loc), + ((L'.PVar ("_", disc), loc), + strcat [(L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + (L'.ERel 1, loc)])], + {disc = disc, result = s}), loc)), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), @@ -2043,23 +2044,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc), fm) end @@ -2067,6 +2068,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec right, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2081,23 +2083,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " LEFT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2105,6 +2107,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec left, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2119,23 +2122,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " RIGHT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2143,6 +2146,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec (left @ right), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2157,23 +2161,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " FULL JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2202,11 +2206,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), - ((L'.PWild, loc), - strcat [(L'.ERel 2, loc), - (L'.ERel 1, loc), + ((L'.PVar ("_", s), loc), + strcat [(L'.ERel 3, loc), + (L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2312,13 +2316,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val s = (L'.TFfi ("Basis", "string"), loc) - val default = strcat [str "(", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ")"] + fun default n = strcat [str "(", + (L'.ERel (n + 1), loc), + str " ", + (L'.ERel (n + 2), loc), + str " ", + (L'.ERel n, loc), + str ")"] val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => @@ -2335,11 +2339,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = str ") IS NULL AND (", (L'.ERel 0, loc), str ") IS NULL))"]), - ((L'.PWild, loc), - default)], + ((L'.PVar ("_", s), loc), + default 1)], {disc = s, result = s}), loc) - | _ => default + | _ => default 0 in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), @@ -2393,6 +2397,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TFfi ("Basis", "bool"), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2409,9 +2414,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " (", (L'.ERel 0, loc), @@ -2430,9 +2435,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), @@ -2773,9 +2778,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.ERel 0, loc), [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", s), loc), strcat [str " ORDER BY ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc), str ")"] diff --git a/src/reduce.sml b/src/reduce.sml index 0762a4a1..04cec168 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -148,8 +148,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -425,8 +424,7 @@ fun kindConAndExp (namedC, namedE) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -757,14 +755,12 @@ fun kindConAndExp (namedC, namedE) = end | ECase (_, [((PRecord [], _), e)], _) => exp env e - | ECase (_, [((PWild, _), e)], _) => exp env e | ECase (e, pes, {disc, result}) => let fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 6fbc6a96..06f49fef 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -62,8 +62,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -313,8 +312,7 @@ fun exp env (all as (e, loc)) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -322,8 +320,7 @@ fun exp env (all as (e, loc)) = fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/settings.sig b/src/settings.sig index 732a31fa..c75f12a3 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -238,6 +238,9 @@ signature SETTINGS = sig val setStaticLinking : bool -> unit val getStaticLinking : unit -> bool + val setBootLinking : bool -> unit + val getBootLinking : unit -> bool + val setDeadlines : bool -> unit val getDeadlines : unit -> bool diff --git a/src/settings.sml b/src/settings.sml index 94692a2e..38ea30fc 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -686,6 +686,10 @@ val staticLinking = ref false fun setStaticLinking b = staticLinking := b fun getStaticLinking () = !staticLinking +val bootLinking = ref false +fun setBootLinking b = bootLinking := b +fun getBootLinking () = !bootLinking + val deadlines = ref false fun setDeadlines b = deadlines := b fun getDeadlines () = !deadlines diff --git a/src/source.sml b/src/source.sml index 2a741dd9..9971ca93 100644 --- a/src/source.sml +++ b/src/source.sml @@ -104,8 +104,7 @@ and sgn' = | SgnProj of string * string list * string and pat' = - PWild - | PVar of string + PVar of string | PPrim of Prim.t | PCon of string list * string * pat option | PRecord of (string * pat) list * bool diff --git a/src/source_print.sml b/src/source_print.sml index db56a0db..7b657422 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -187,8 +187,7 @@ and p_name (all as (c, _)) = fun p_pat' par (p, _) = case p of - PWild => string "_" - | PVar s => string s + PVar s => string s | PPrim p => Prim.p_t p | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x]) | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]), diff --git a/src/specialize.sml b/src/specialize.sml index 5d8cef09..33545250 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -162,8 +162,7 @@ and specCon st = U.Con.foldMap {kind = kind, con = con} st fun pat (p, st) = case #1 p of - PWild => (p, st) - | PVar _ => (p, st) + PVar _ => (p, st) | PPrim _ => (p, st) | PCon (dk, PConVar pn, args as (_ :: _), po) => let diff --git a/src/termination.sml b/src/termination.sml index f0b21d99..f0ec46d8 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -107,8 +107,7 @@ fun declOk' env (d, loc) = | _ => foldl (fn ((_, pt', _), penv) => pat penv (Rabble, pt')) penv xps in case (p, pt) of - (_, PWild) => penv - | (_, PVar _) => p :: penv + (_, PVar _) => p :: penv | (_, PPrim _) => penv | (_, PCon (_, _, _, NONE)) => penv | (Arg (i, j, _), PCon (_, pc, _, SOME pt')) => con (i, j, pc, pt') diff --git a/src/unnest.sml b/src/unnest.sml index 3034eb6e..7469ffd4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -256,8 +256,7 @@ fun exp ((ns, ks, ts), e as old, st : state) = fun doVars ((p, _), ts) = case p of - PWild => ts - | PVar xt => xt :: ts + PVar xt => xt :: ts | PPrim _ => ts | PCon (_, _, _, NONE) => ts | PCon (_, _, _, SOME p) => doVars (p, ts) diff --git a/src/urweb.grm b/src/urweb.grm index 50dacf21..0f499e20 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -335,7 +335,7 @@ fun applyWindow loc e window = fun patternOut (e : exp) = case #1 e of - EWild => (PWild, #2 e) + EWild => (PVar "_", #2 e) | EVar ([], x, Infer) => if Char.isUpper (String.sub (x, 0)) then (PCon ([], x, NONE), #2 e) @@ -346,7 +346,7 @@ fun patternOut (e : exp) = (PCon (xs, x, NONE), #2 e) else (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern"; - (PWild, #2 e)) + (PVar "_", #2 e)) | EPrim p => (PPrim p, #2 e) | EApp ((EVar (xs, x, Infer), _), e') => (PCon (xs, x, SOME (patternOut e')), #2 e) @@ -364,7 +364,7 @@ fun patternOut (e : exp) = | EAnnot (e', t) => (PAnnot (patternOut e', t), #2 e) | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern."; - (PWild, #2 e)) + (PVar "_", #2 e)) %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -1543,7 +1543,7 @@ pat : patS (patS) pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) - | UNDER (PWild, s (UNDERleft, UNDERright)) + | UNDER (PVar "_", s (UNDERleft, UNDERright)) | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) diff --git a/tests/library.urp b/tests/library.urp new file mode 100644 index 00000000..1c4d6fb2 --- /dev/null +++ b/tests/library.urp @@ -0,0 +1 @@ +script /bogus.js diff --git a/tests/library2.urp b/tests/library2.urp new file mode 100644 index 00000000..17b1ad55 --- /dev/null +++ b/tests/library2.urp @@ -0,0 +1 @@ +library library diff --git a/tests/localInstance.ur b/tests/localInstance.ur new file mode 100644 index 00000000..81a65ddb --- /dev/null +++ b/tests/localInstance.ur @@ -0,0 +1,8 @@ +datatype foo = Bar + +val x = + let + val _ = mkShow (fn Bar => "Bar") + in + show Bar + end diff --git a/tests/multilib.ur b/tests/multilib.ur new file mode 100644 index 00000000..52c8cb30 --- /dev/null +++ b/tests/multilib.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return <xml><body> + <button onclick={fn _ => alert "AHA!"}>CLICK ME</button> +</body></xml> diff --git a/tests/multilib.urp b/tests/multilib.urp new file mode 100644 index 00000000..b33d66e4 --- /dev/null +++ b/tests/multilib.urp @@ -0,0 +1,5 @@ +library library +library library2 +rewrite all Multilib/* + +multilib |