From b850f7d1690a3e05cd4ccb73f012500151fb924a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 20 Dec 2015 14:39:50 -0500 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index a8060104..e0249a75 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20151220]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 681382fbe032e10137d78f2308d239483c3e5731 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 20 Dec 2015 15:00:10 -0500 Subject: Imported to Git from Mercurial --- .gitignore | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .hgignore | 80 ------------------------------------------------------------ Makefile.am | 6 ----- README.md | 19 +++++++++++++++ configure.ac | 2 +- 5 files changed, 98 insertions(+), 87 deletions(-) create mode 100644 .gitignore delete mode 100644 .hgignore create mode 100644 README.md diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..b30fa842 --- /dev/null +++ b/.gitignore @@ -0,0 +1,78 @@ +*~ +.cm +src/.cm + +bin/* + +src/urweb.cm +src/urweb.mlb + +*.lex.* +*.grm.* +*.o +.deps +.libs +*.lo +*.la +*.mlton.grm +*.mlton.lex + +src/config.sml + +*.exe + +*.cache +*.log +*.status + +demo/out/*.html +demo/demo.* + +demo/more/out/*.html +demo/more/demo.* + +doc/*.html +doc/*.out + +*.sql +*mlmon.out + +*.aux +*.dvi +*.pdf +*.ps +*.toc + +.depend +Makefile.coq +*.vo +*.v.d +*.glob + +xml/parse +xml/entities.sml + +Makefile.in +src/c/Makefile.in +ar-lib +*.m4 +m4/libtool.m4 +m4/lt*.m4 +config.* +configure +depcomp +compile +install-sh +ltmain.sh +missing + +tests/*.db + +syntax: regexp + +Makefile +src/c/Makefile +libtool +include/urweb/config.h +include/urweb/config.h.in +include/urweb/stamp-h1 diff --git a/.hgignore b/.hgignore deleted file mode 100644 index 20e290b8..00000000 --- a/.hgignore +++ /dev/null @@ -1,80 +0,0 @@ -syntax: glob - -*~ -.cm -src/.cm - -bin/* - -src/urweb.cm -src/urweb.mlb - -*.lex.* -*.grm.* -*.o -.deps -.libs -*.lo -*.la -*.mlton.grm -*.mlton.lex - -src/config.sml - -*.exe - -*.cache -*.log -*.status - -demo/out/*.html -demo/demo.* - -demo/more/out/*.html -demo/more/demo.* - -doc/*.html -doc/*.out - -*.sql -*mlmon.out - -*.aux -*.dvi -*.pdf -*.ps -*.toc - -.depend -Makefile.coq -*.vo -*.v.d -*.glob - -xml/parse -xml/entities.sml - -Makefile.in -src/c/Makefile.in -ar-lib -*.m4 -m4/libtool.m4 -m4/lt*.m4 -config.* -configure -depcomp -compile -install-sh -ltmain.sh -missing - -tests/*.db - -syntax: regexp - -^Makefile$ -^src/c/Makefile$ -^libtool$ -^include/urweb/config.h$ -^include/urweb/config.h.in$ -^include/urweb/stamp-h1$ 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..af4201bc --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# 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 e0249a75..6d4b7233 100644 --- a/configure.ac +++ b/configure.ac @@ -91,7 +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 ?`" + VERSION="$VERSION + `git log -1 --format="%H" || (cat .hg_archival.txt | grep 'node\:') || echo ?`" fi # Clang does not like being passed -pthread, since it's implicit on OS X. -- cgit v1.2.3 From e7c13d8091aa060a2ed7a769d9b6885dfd6b2b6e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 20 Dec 2015 15:06:14 -0500 Subject: Remove old Mercurial reference --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 6d4b7233..1b7e8aa5 100644 --- a/configure.ac +++ b/configure.ac @@ -91,7 +91,7 @@ if test [-z $SQHEADER]; then fi if test [$WORKING_VERSION = "1"]; then - VERSION="$VERSION + `git log -1 --format="%H" || (cat .hg_archival.txt | grep 'node\:') || echo ?`" + VERSION="$VERSION + `git log -1 --format="%H" || echo ?`" fi # Clang does not like being passed -pthread, since it's implicit on OS X. -- cgit v1.2.3 From 28c2120a300f0003cbe6977047d933529f9a7f85 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 14:05:25 -0500 Subject: Add .travis.yml for automated testing --- .travis.yml | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..978e6b48 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,29 @@ +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 + +# brew install mlton doesn't seem to work (https://github.com/travis-ci/travis-ci/issues/5379) +matrix: + allow_failures: + - os: osx + +before_install: + - 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 install mlton; fi + +script: ./autogen.sh && ./configure && make && make test -- cgit v1.2.3 From 3369fd85a189d1e2e0ee4e84e659f18850b8dfaa Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 14:36:04 -0500 Subject: Add build status image to README.md --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index af4201bc..3bfd94a1 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://api.travis-ci.org/urweb/urweb.png?branch=master)](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: -- cgit v1.2.3 From 7a9fe677efb63a25763cfb7217b49b88a21b33c1 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 15:17:14 -0500 Subject: Add tap for mlton on osx --- .travis.yml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 978e6b48..5bc39034 100644 --- a/.travis.yml +++ b/.travis.yml @@ -15,15 +15,11 @@ compiler: # packages: # - mlton -# brew install mlton doesn't seem to work (https://github.com/travis-ci/travis-ci/issues/5379) -matrix: - allow_failures: - - os: osx - before_install: - 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 homebrew/boneyard; fi - if command -v brew &>/dev/null; then brew install mlton; fi script: ./autogen.sh && ./configure && make && make test -- cgit v1.2.3 From e3a98699c6736846c3365fb6a22146d3481a10d0 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 30 Dec 2015 15:55:36 -0500 Subject: Remove duplicate typedef declarations. --- include/urweb/types_cpp.h | 7 ++++++- src/c/urweb.c | 7 ------- 2 files changed, 6 insertions(+), 8 deletions(-) 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/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); -- cgit v1.2.3 From 6155dea6b97d066f148439bcc93134bc9f566a11 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 16:13:58 -0500 Subject: Move some things around in configure.ac This supresses "WARNING: `missing' script is too old or missing" --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 1b7e8aa5..9f7aebbc 100644 --- a/configure.ac +++ b/configure.ac @@ -5,10 +5,10 @@ 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]) @@ -160,7 +160,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 -- cgit v1.2.3 From ae6d0cd9afb9e530ac75915875d16875a6392a41 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 16:24:48 -0500 Subject: Also install openssl from brew on OSX in Travis [A Google search](https://github.com/devsisters/gospdyquic/issues/1#issuecomment-102892729) suggests that the problem is that Mac OSX OpenSSL headers are broken. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 5bc39034..a93f8c7a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,6 +20,6 @@ before_install: - 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 homebrew/boneyard; fi - - if command -v brew &>/dev/null; then brew install mlton; fi + - if command -v brew &>/dev/null; then brew install openssl mlton; fi script: ./autogen.sh && ./configure && make && make test -- cgit v1.2.3 From 14c6f08c58238b52253a6292d830ef78f6296ab4 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 30 Dec 2015 16:37:41 -0500 Subject: Pass --with-openssl to make use of brew's openssl on OSX --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index a93f8c7a..ead1ad85 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,10 +16,12 @@ compiler: # - 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 homebrew/boneyard; 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 && make && make test +script: ./autogen.sh && ./configure $CONFIGURE_ARGS && make && make test -- cgit v1.2.3 From 3d24185389cef552d4b442d16d0c5ed1d8ccaf87 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 31 Dec 2015 12:49:40 -0500 Subject: Some bugs related to kind-checking tuples --- src/elaborate.sml | 41 ++++++++++++++++++++++------------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 25cce6bd..3b7c48ea 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 @@ -641,10 +644,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 +655,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"))) -- cgit v1.2.3 From dd92f19fcee5c66e0f63eaf49b746604ddd57210 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 31 Dec 2015 13:02:56 -0500 Subject: A simple eta rule for constructor-level tuples --- src/elaborate.sml | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/elaborate.sml b/src/elaborate.sml index 3b7c48ea..2dfbf5b2 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -285,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 @@ -1344,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) -- cgit v1.2.3 From f5f93f6efc15ade5945e8572d889f22d198611b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 31 Dec 2015 17:54:12 -0500 Subject: Upgrade M4 macros for pthreads and remove custom workaround --- configure.ac | 18 ----------- m4/m4_ax_pthread.m4 | 90 +++++++++++++++++++++++++++++++++++------------------ 2 files changed, 60 insertions(+), 48 deletions(-) diff --git a/configure.ac b/configure.ac index 9f7aebbc..fc7ba433 100644 --- a/configure.ac +++ b/configure.ac @@ -94,24 +94,6 @@ if test [$WORKING_VERSION = "1"]; then VERSION="$VERSION + `git log -1 --format="%H" || 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="" -fi - # Check if pthread_t is a scalar or pointer type so we can use the correct # OpenSSL functions on it. AC_MSG_CHECKING([if pthread_t is a pointer type]) diff --git a/m4/m4_ax_pthread.m4 b/m4/m4_ax_pthread.m4 index a6bf596c..d383ad5c 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 @@ -159,11 +159,25 @@ case "${host_cpu}-${host_os}" in ax_pthread_flags="-pthreads pthread -mt -pthread $ax_pthread_flags" ;; - *-darwin*) + 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 +192,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 +207,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 +233,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 +259,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 ]], [[int i = PTHREAD_PRIO_INHERIT;]])], + [ax_cv_PTHREAD_PRIO_INHERIT], [ + AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], + [[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 -- cgit v1.2.3 From c748c02510ce84b457c2c7d288a67b686642bd0d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 1 Jan 2016 12:07:52 -0500 Subject: Fix issue with enumerated types and dependency order --- src/cjr_print.sml | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2c2133d6..ee7792a5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2356,7 +2356,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 +2378,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 +2602,22 @@ 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.foldlMap (fn (d, enums) => + case #1 d of + DDatatype dts => + let + val (enum, other) = List.partition (fn (Enum, _, _, _) => true + | _ => false) dts + in + ((DDatatype other, #2 d), + List.revAppend (enum, enums)) + end + | _ => (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 -- cgit v1.2.3 From 8f8bca7350c25d21e079e3513d9b8fad93c42812 Mon Sep 17 00:00:00 2001 From: Eran Meir Date: Sat, 2 Jan 2016 03:49:39 +0200 Subject: Prevent pthread cflags options from being passed to linker (in order to fix build issue on mac) --- src/compiler.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index bf7491e5..5ac024d4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -878,7 +878,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; Settings.addJsFile arg) - + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -1518,7 +1518,7 @@ 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) + val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadLibs) val ssl = if Settings.getStaticLinking () then Config.openssl ^ " -ldl -lz" -- cgit v1.2.3 From 93cb1ae6e054471a464637a89fe8def57617487b Mon Sep 17 00:00:00 2001 From: Eran Meir Date: Sat, 2 Jan 2016 04:26:23 +0200 Subject: updating mlton tap --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ead1ad85..d0870280 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,7 @@ before_install: - 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 homebrew/boneyard; fi + - if command -v brew &>/dev/null; then brew tap urweb/homebrew-ur; 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 -- cgit v1.2.3 From decad4728cde057b7ea89967afe8aa0a1a6245db Mon Sep 17 00:00:00 2001 From: Eran Meir Date: Sat, 2 Jan 2016 04:51:06 +0200 Subject: Remove static linking enforcement when passing -boot flag --- src/main.mlton.sml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 67732b58..c07af1ee 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,6 @@ fun oneRun args = doArgs rest) | "-boot" :: rest => (Compiler.enableBoot (); - Settings.setStaticLinking true; doArgs rest) | "-sigfile" :: name :: rest => (Settings.setSigFile (SOME name); @@ -318,7 +317,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; -- cgit v1.2.3 From 4985395c44b8aecfe54417a383762825292ac5d5 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 1 Jan 2016 22:04:28 -0500 Subject: Update the homebrew tap for mlton This version of the tap has mlton looking for libgmp.a in the correct directory. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ead1ad85..d0870280 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,7 @@ before_install: - 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 homebrew/boneyard; fi + - if command -v brew &>/dev/null; then brew tap urweb/homebrew-ur; 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 -- cgit v1.2.3 From 6747f5ff7d80001f112fd23af51a1275471f5bf0 Mon Sep 17 00:00:00 2001 From: Eran Meir Date: Sat, 2 Jan 2016 13:56:35 +0200 Subject: Untagle boot and static flags Boot flag should build a dynamic executable but link urweb libraries statically (from build tree). This should fix the problem of not being able to build static executables on OSX. --- src/compiler.sml | 4 +++- src/main.mlton.sml | 8 ++++---- src/settings.sig | 3 +++ src/settings.sml | 4 ++++ 4 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 5ac024d4..e2dc168e 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1503,7 +1503,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" 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/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 -- cgit v1.2.3 From aa3e615e84e3e8844fd5537ef84c38d5d18298ab Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 2 Jan 2016 10:43:51 -0500 Subject: Finishing the last change in final handling of enumerated types --- src/cjr_print.sml | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index ee7792a5..bbbe5c8b 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2603,18 +2603,19 @@ fun p_file env (ds, ps) = global_initializers := []) (* First, pull out all of the enumerated types, to be declared first. *) - val (ds, enums) = ListUtil.foldlMap (fn (d, enums) => - case #1 d of - DDatatype dts => - let - val (enum, other) = List.partition (fn (Enum, _, _, _) => true - | _ => false) dts - in - ((DDatatype other, #2 d), - List.revAppend (enum, enums)) - end - | _ => (d, enums)) - [] ds + 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 -- cgit v1.2.3 From 610dc28a6c858748c6a22ce4478eeaef66477514 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 09:33:39 -0500 Subject: Tweaking discovery of Pthreads C flags --- m4/m4_ax_pthread.m4 | 12 ++++++++++++ src/compiler.sml | 11 ++++++++++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/m4/m4_ax_pthread.m4 b/m4/m4_ax_pthread.m4 index d383ad5c..f0717ada 100644 --- a/m4/m4_ax_pthread.m4 +++ b/m4/m4_ax_pthread.m4 @@ -204,11 +204,22 @@ for flag in $ax_pthread_flags; do ;; esac + save_LDFLAGS="$LDFLAGS" save_LIBS="$LIBS" save_CFLAGS="$CFLAGS" LIBS="$PTHREAD_LIBS $LIBS" CFLAGS="$CFLAGS $PTHREAD_CFLAGS $ax_pthread_extra_flags" + # This check added by Adam Chlipala on January 16, 2016. + # The documentation at the top of this file said that PTHREAD_CFLAGS needs to + # be used at link-time, too, but this test didn't seem to do so. + # For now, I'm patching just for the common case of '-pthread'. + case $flag in + -pthread) + LDFLAGS="$LDFLAGS -pthread" + ;; + esac + # Check for various functions. We must include pthread.h, # since some functions may be macros. (On the Sequent, we # need a special flag -Kthread to make this header compile.) @@ -230,6 +241,7 @@ for flag in $ax_pthread_flags; do [ax_pthread_ok=yes], []) + LDFLAGS="$save_LDFLAGS" LIBS="$save_LIBS" CFLAGS="$save_CFLAGS" diff --git a/src/compiler.sml b/src/compiler.sml index e2dc168e..e269c8b9 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1520,7 +1520,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.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" -- cgit v1.2.3 From ec67c4241a96399847efad4c5f9ab0b20744a728 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 09:41:10 -0500 Subject: Debugging autoconf by pushing a change for Travis to look at --- m4/m4_ax_pthread.m4 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/m4/m4_ax_pthread.m4 b/m4/m4_ax_pthread.m4 index f0717ada..935634db 100644 --- a/m4/m4_ax_pthread.m4 +++ b/m4/m4_ax_pthread.m4 @@ -220,6 +220,8 @@ for flag in $ax_pthread_flags; do ;; esac + AC_MSG_NOTICE([LDFLAGS = $LDFLAGS]) + # Check for various functions. We must include pthread.h, # since some functions may be macros. (On the Sequent, we # need a special flag -Kthread to make this header compile.) -- cgit v1.2.3 From 6dac2333591c096dd77c534a2b7233b12332ea43 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 09:54:47 -0500 Subject: More debugging autoconf by pushing a change for Travis to look at: use '-debug' in 'make test' --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 9ab31acd..89f90eae 100644 --- a/Makefile.am +++ b/Makefile.am @@ -113,7 +113,7 @@ TESTDB = /tmp/urweb.db TESTPID = /tmp/urweb.pid test: - bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo + bin/urweb -debug -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql demo/demo.exe & echo $$! > $(TESTPID) -- cgit v1.2.3 From 4efe08193cd957291d106ee5578732d0c7c6085b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 10:05:12 -0500 Subject: More debugging autoconf by pushing a change for Travis to look at: try removing Darwin special case --- m4/m4_ax_pthread.m4 | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/m4/m4_ax_pthread.m4 b/m4/m4_ax_pthread.m4 index 935634db..0b2718f3 100644 --- a/m4/m4_ax_pthread.m4 +++ b/m4/m4_ax_pthread.m4 @@ -158,10 +158,6 @@ case ${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 @@ -204,24 +200,11 @@ for flag in $ax_pthread_flags; do ;; esac - save_LDFLAGS="$LDFLAGS" save_LIBS="$LIBS" save_CFLAGS="$CFLAGS" LIBS="$PTHREAD_LIBS $LIBS" CFLAGS="$CFLAGS $PTHREAD_CFLAGS $ax_pthread_extra_flags" - # This check added by Adam Chlipala on January 16, 2016. - # The documentation at the top of this file said that PTHREAD_CFLAGS needs to - # be used at link-time, too, but this test didn't seem to do so. - # For now, I'm patching just for the common case of '-pthread'. - case $flag in - -pthread) - LDFLAGS="$LDFLAGS -pthread" - ;; - esac - - AC_MSG_NOTICE([LDFLAGS = $LDFLAGS]) - # Check for various functions. We must include pthread.h, # since some functions may be macros. (On the Sequent, we # need a special flag -Kthread to make this header compile.) @@ -243,7 +226,6 @@ for flag in $ax_pthread_flags; do [ax_pthread_ok=yes], []) - LDFLAGS="$save_LDFLAGS" LIBS="$save_LIBS" CFLAGS="$save_CFLAGS" -- cgit v1.2.3 From 4193f262c76fec4df28ae6c31865ea691947d619 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 10:11:59 -0500 Subject: Remove '-debug' from 'make test' --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 89f90eae..9ab31acd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -113,7 +113,7 @@ TESTDB = /tmp/urweb.db TESTPID = /tmp/urweb.pid test: - bin/urweb -debug -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo + bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql demo/demo.exe & echo $$! > $(TESTPID) -- cgit v1.2.3 From a777dd13f4075418ec883f4eb42e5de1739d50d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jan 2016 10:21:54 -0500 Subject: Use official MLton Homebrew package --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index d0870280..0b2b8b90 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,7 @@ before_install: - 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 urweb/homebrew-ur; 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 -- cgit v1.2.3 From 5579b84a97cb942fdfd4c4898793f9de95bc03d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Feb 2016 19:59:10 -0500 Subject: Merge PVar and PWild, to get more reasonable type-class resolution --- lib/js/urweb.js | 2 - src/cjrize.sml | 3 +- src/core.sml | 3 +- src/core_env.sml | 9 ++--- src/core_print.sml | 3 +- src/core_util.sml | 12 ++---- src/corify.sml | 3 +- src/elab.sml | 3 +- src/elab_env.sml | 6 +-- src/elab_print.sml | 3 +- src/elab_util.sml | 9 ++--- src/elaborate.sml | 22 +++++----- src/expl.sml | 3 +- src/expl_env.sml | 3 +- src/expl_print.sml | 3 +- src/expl_rename.sml | 3 +- src/explify.sml | 3 +- src/iflow.sml | 6 +-- src/jscomp.sml | 6 +-- src/mono.sml | 3 +- src/mono_env.sml | 6 +-- src/mono_print.sml | 3 +- src/mono_reduce.sml | 6 +-- src/mono_util.sml | 3 +- src/monoize.sml | 107 ++++++++++++++++++++++++++----------------------- src/reduce.sml | 9 ++--- src/reduce_local.sml | 9 ++--- src/source.sml | 3 +- src/source_print.sml | 3 +- src/specialize.sml | 3 +- src/termination.sml | 3 +- src/unnest.sml | 3 +- src/urweb.grm | 8 ++-- tests/localInstance.ur | 8 ++++ 34 files changed, 122 insertions(+), 160 deletions(-) create mode 100644 tests/localInstance.ur diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 14ec4612..ac469f20 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": 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/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 2dfbf5b2..9765b090 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1526,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)) @@ -1563,9 +1563,7 @@ 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 (expError env (DuplicatePatternVariable (loc, x)); @@ -1642,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 = @@ -1683,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 @@ -1704,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 @@ -1716,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) @@ -1847,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 @@ -1861,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..d8c83b94 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 "{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/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..08040ad3 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 @@ -763,8 +761,7 @@ fun kindConAndExp (namedC, namedE) = 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/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/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 -- cgit v1.2.3 From 7b379c724999c4b415b1c3826db748450c7a6571 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Feb 2016 20:41:34 -0500 Subject: Finish removing PWild; only load a library once, even if referenced multiple times in a .urp tree --- lib/js/urweb.js | 2 +- src/cjr.sml | 3 +-- src/cjr_print.sml | 11 +++-------- src/compiler.sml | 36 +++++++++++++++++++++++------------- src/elaborate.sml | 2 +- src/jscomp.sml | 2 +- src/reduce.sml | 1 - tests/library.urp | 1 + tests/library2.urp | 1 + tests/multilib.ur | 3 +++ tests/multilib.urp | 5 +++++ 11 files changed, 40 insertions(+), 27 deletions(-) create mode 100644 tests/library.urp create mode 100644 tests/library2.urp create mode 100644 tests/multilib.ur create mode 100644 tests/multilib.urp diff --git a/lib/js/urweb.js b/lib/js/urweb.js index ac469f20..410a0e23 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1848,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/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 bbbe5c8b..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_", diff --git a/src/compiler.sml b/src/compiler.sml index e269c8b9..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})) @@ -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 = { diff --git a/src/elaborate.sml b/src/elaborate.sml index 9765b090..6965adfd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1565,7 +1565,7 @@ fun elabPat (pAll as (p, loc), (env, bound)) = case p of 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 diff --git a/src/jscomp.sml b/src/jscomp.sml index d8c83b94..65a0fa3a 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -458,7 +458,7 @@ fun process (file : file) = fun jsPat (p, _) = case p of - PVar _ => str "{c:\"v\"}" + PVar _ => str "{/*hoho*/c:\"v\"}" | PPrim p => strcat [str "{c:\"c\",v:", jsPrim p, str "}"] diff --git a/src/reduce.sml b/src/reduce.sml index 08040ad3..04cec168 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -755,7 +755,6 @@ fun kindConAndExp (namedC, namedE) = end | ECase (_, [((PRecord [], _), e)], _) => exp env e - | ECase (_, [((PWild, _), e)], _) => exp env e | ECase (e, pes, {disc, result}) => let 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/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 + + 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 -- cgit v1.2.3 From c78853f8d518233bd52a86d35465dfdd56cc69d4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 13 Feb 2016 09:32:10 -0500 Subject: Add a cast to thread_id(), to support more platforms --- src/c/openssl.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) 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]; -- cgit v1.2.3 From 3044fbedd58961f8c1168eb3bc2eeeb8a2b0b60e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 13 Feb 2016 09:51:30 -0500 Subject: New release --- CHANGELOG | 9 +++++++++ configure.ac | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 097ece99..701e9c03 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +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/configure.ac b/configure.ac index fc7ba433..351d1129 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20151220]) -WORKING_VERSION=1 +AC_INIT([urweb], [20160213]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3