Set LD_LIBRARY_PATH globally in all workflow jobs/steps

This should also fix installation problem of node-gyp in CI

.github/workflows/build-majestic.yml

@@ -0,0 +1,162 @@
+name: Build majestic runtime
+
+on: push
+
+env:
+  LD_LIBRARY_PATH: /usr/local/lib
+
+jobs:
+
+  ubuntu-runtime:
+    name: Runtime (Ubuntu)
+    runs-on: ubuntu-20.04
+
+    steps:
+    - uses: actions/checkout@v2
+
+    - name: Build runtime
+      working-directory: ./src/runtime/c
+      run: |
+        autoreconf -i
+        ./configure
+        make
+        sudo make install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@master
+      with:
+        name: libpgf-ubuntu
+        path: |
+          /usr/local/lib/libpgf*
+          /usr/local/include/pgf
+
+  ubuntu-haskell:
+    name: Haskell (Ubuntu)
+    runs-on: ubuntu-20.04
+    needs: ubuntu-runtime
+
+    steps:
+    - uses: actions/checkout@v2
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-ubuntu
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Setup Haskell
+      uses: haskell/actions/setup@v1
+
+    - name: Build & run testsuite
+      working-directory: ./src/runtime/haskell
+      run: |
+        cabal test --extra-lib-dirs=/usr/local/lib
+
+  ubuntu-python:
+    name: Python (Ubuntu)
+    runs-on: ubuntu-20.04
+    needs: ubuntu-runtime
+
+    steps:
+    - uses: actions/checkout@v2
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-ubuntu
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Install bindings
+      working-directory: ./src/runtime/python
+      run: |
+        python setup.py build
+        sudo python setup.py install
+
+    - name: Run testsuite
+      working-directory: ./src/runtime/python
+      run: |
+        pip install pytest
+        pytest
+
+  ubuntu-javascript:
+    name: JavaScript (Ubuntu)
+    runs-on: ubuntu-20.04
+    needs: ubuntu-runtime
+
+    steps:
+    - uses: actions/checkout@v2
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-ubuntu
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Install dependencies
+      working-directory: ./src/runtime/javascript
+      run: |
+        npm ci
+
+    - name: Run testsuite
+      working-directory: ./src/runtime/javascript
+      run: |
+        npm run test
+
+# ----------------------------------------------------------------------------
+
+  macos-runtime:
+    name: Runtime (macOS)
+    runs-on: macOS-11
+
+    steps:
+    - uses: actions/checkout@v2
+
+    - name: Install build tools
+      run: |
+        brew install \
+          autoconf \
+          automake \
+          libtool \
+
+    - name: Build runtime
+      working-directory: ./src/runtime/c
+      run: |
+        glibtoolize
+        autoreconf -i
+        ./configure
+        make
+        sudo make install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@master
+      with:
+        name: libpgf-macos
+        path: |
+          /usr/local/lib/libpgf*
+          /usr/local/include/pgf
+
+  macos-haskell:
+    name: Haskell (macOS)
+    runs-on: macOS-11
+    needs: macos-runtime
+
+    steps:
+    - uses: actions/checkout@v2
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-macos
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Setup Haskell
+      uses: haskell/actions/setup@v1
+
+    - name: Build & run testsuite
+      working-directory: ./src/runtime/haskell
+      run: |
+        cabal test --extra-lib-dirs=/usr/local/lib

.gitignore

@@ -5,6 +5,7 @@
 *.jar
 *.gfo
 *.pgf
+*.ngf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -46,6 +47,8 @@ src/runtime/c/sg/.dirstamp
 src/runtime/c/stamp-h1
 src/runtime/java/.libs/
 src/runtime/python/build/
+src/runtime/python/**/__pycache__/
+src/runtime/python/**/.pytest_cache/
 .cabal-sandbox
 cabal.sandbox.config
 .stack-work

.travis.yml

@@ -1,14 +0,0 @@
-sudo: required
-
-language: c
-
-services:
-  - docker
-
-before_install:
-  - docker pull odanoburu/gf-src:3.9
-
-script:
-  - |
-    docker run --mount src="$(pwd)",target=/home/gfer,type=bind odanoburu/gf-src:3.9 /bin/bash -c "cd /home/gfer/src/runtime/c &&
-    autoreconf -i && ./configure && make && make install ; cd /home/gfer ; cabal install -fserver -fc-runtime --extra-lib-dirs='/usr/local/lib'"

CHANGELOG.md

@@ -0,0 +1,11 @@
+### New since 3.11 (WIP)
+
+- Added a changelog!
+
+### 3.11
+
+See <https://www.grammaticalframework.org/download/release-3.11.html>
+
+### 3.10
+
+See <https://www.grammaticalframework.org/download/release-3.10.html>

Makefile

@@ -65,6 +65,6 @@ bintar:
 
 # Make a source tar.gz distribution using git to make sure that everything is included.
 # We put the distribution in dist/ so it is removed on `make clean`
-sdist:
-	test -d dist || mkdir dist
-	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD
+# sdist:
+# 	test -d dist || mkdir dist
+# 	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD

README.md

@@ -1,4 +1,4 @@
-![GF Logo](doc/Logos/gf1.svg)
+![GF Logo](https://www.grammaticalframework.org/doc/Logos/gf1.svg)
 
 # Grammatical Framework (GF)
 
@@ -39,7 +39,7 @@ or:
 stack install
 ```
 
-For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html).
+For more information, including links to precompiled binaries, see the [download page](https://www.grammaticalframework.org/download/index.html).
 
 ## About this repository
 

RELEASE.md

@@ -47,11 +47,14 @@ but the generated _artifacts_ must be manually attached to the release as _asset
 
 In order to do this you will need to be added the [GF maintainers](https://hackage.haskell.org/package/gf/maintainers/) on Hackage.
 
-1. Run `make sdist`
+1. Run `stack sdist --test-tarball` and address any issues.
 2. Upload the package, either:
-    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`
-    2. **via Cabal (≥2.4)**: `cabal upload dist/gf-X.Y.tar.gz`
-3. If the documentation-building fails on the Hackage server, do:
+    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file generated by the previous command.
+    2. **via Stack**: `stack upload . --candidate`
+3. After testing the candidate, publish it:
+    1. **Manually**: visit <https://hackage.haskell.org/package/gf-X.Y.Z/candidate/publish>
+    1. **via Stack**: `stack upload .`
+4. If the documentation-building fails on the Hackage server, do:
 ```
 cabal v2-haddock --builddir=dist/docs --haddock-for-hackage --enable-doc
 cabal upload --documentation dist/docs/*-docs.tar.gz

doc/gf-people.md

@@ -7,7 +7,6 @@ title: "Grammatical Framework: Authors and Acknowledgements"
 The current maintainers of GF are
 
 [Krasimir Angelov](http://www.chalmers.se/cse/EN/organization/divisions/computing-science/people/angelov-krasimir),
-[Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/),
 [Aarne Ranta](http://www.cse.chalmers.se/~aarne/),
 [John J. Camilleri](http://johnjcamilleri.com), and
 [Inari Listenmaa](https://inariksit.github.io/).
@@ -22,6 +21,7 @@ and
 
 The following people have contributed code to some of the versions:
 
+- [Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/) (University of Gothenburg)
 - Grégoire Détrez (University of Gothenburg)
 - Ramona Enache (University of Gothenburg)
 - [Björn Bringert](http://www.cse.chalmers.se/alumni/bringert) (University of Gothenburg)

doc/hackers-guide/CompilationOverview.md

@@ -0,0 +1,11 @@
+# Compilation
+
+The GF language is designed to be easy for the programmers to use but be able to run it efficiently we need to reduce it to a more low-level language. The goal of this chapter is to give an overview of the different steps in the compilation. The program transformation goes throught the following phases:
+
+- renaming - here all identifiers in the grammar are made explicitly qualified. For example, if you had used the identifier PredVP somewhere, the compiler will search for a definition of that identifier in either the current module or in any of the modules imported from the current one. If a definition is found in, say in a module called Sentence, then the unqualified name PredVP will be replaced with the explicit qualification Sentence.PredVP. On the other hand, if the source program is already using an explicit qualification like Sentence.PredVP, then the compiler will check whether PredVP is indeed defined in the module Sentence. 
+
+- type checking - here the compiler will check whether all functions and variables are used correctly with respect to their types. For each term that the compiler checks it will also generate a new version of the term after the type checking. The input and output terms may not need to be the same. For example, the compiler may insert explicit type information. It might fill-in implicit arguments, or it may instantiate meta variables.
+
+- partial evaluation - here is where the real compilation starts. The compiler will fully evaluate the term for each linearization to a normal. In the process, all uses of operations will be inlined. This is part of reducing the GF language to a simpler language which does not support operations.
+
+- PMCFG generation - the language that the GF runtime understands is an extension of the PMCFG formalism. Not all features permitted in the GF language are allowed on that level. Most of the uses for that extra features have been eliminated via partial evaluation. If there are any left, then the compilation will abort. The main purpose of the PMCFG generation is to get rid of most of the parameter types in the source grammar. That is possible by generating several specialized linearization rules from a single linearization rule in the source.

doc/hackers-guide/DESIDERATA.md

@@ -0,0 +1,51 @@
+This is an experiment to develop **a majestic new GF runtime**.
+
+The reason is that there are several features that we want to have and they all require a major rewrite of the existing C runtime.
+Instead of beating the old code until it starts doing what we want, it is time to start from scratch.
+
+# New Features
+
+The features that we want are:
+
+- We want to support **even bigger grammars that don't fit in the main memory** anymore. Instead, they should reside on the disc and parts will be loaded on demand.
+The current design is that all memory allocated for the grammars should be from memory-mapped files. In this way the only limit for the grammar size will
+be the size of the virtual memory, i.e. 2^64 bytes. The swap file is completely circumvented, while all of the available RAM can be used as a cache for loading parts
+of the grammar.
+
+- We want to be able to **update grammars dynamically**. This is a highly desired feature since recompiling large grammars takes hours.
+Instead, dynamic updates should happen instantly.
+
+- We want to be able to **store additional information in the PGF**. For example that could be application specific semantic data.
+Another example is to store the source code of the different grammar rules, to allow the compiler to recompile individual rules.
+
+- We want to **allow a single file to contain slightly different versions of the grammar**. This will be a kind of a version control system,
+which will allow different users to store their own grammar extensions while still using the same core content.
+
+- We want to **avoid the exponential explosion in the size of PMCFG** for some grammars. This happens because PMCFG as a formalism is too low-level.
+By enriching it with light-weight variables, we can make it more powerful and hopefully avoid the exponential explosion.
+
+- We want to finally **ditch the old Haskell runtime** which has long outlived its time.
+
+There are also two bugs in the old C runtime whose fixes will require a lot of changes, so instead of fixing the old runtime we do it here:
+
+- **Integer literals in the C runtime** are implemented as 32-bit integers, while the Haskell runtime used unlimited integers.
+Python supports unlimited integers too, so it would be nice to support them in the new runtime as well.
+
+- The old C runtime assumed that **String literals are terminated with the NULL character**. None of the modern languages (Haskell, Python, Java, etc) make
+that assumption, so we should drop it too.
+
+# Consequences
+
+The desired features will have the following implementation cosequences.
+
+- The switch from memory-based to disc-based runtime requires one big change. Before it was easy to just keep a pointer from one object to another.
+Unfortunately this doesn't work with memory-mapped files, since every time when you map a file into memory it may end up at a different virtual address.
+Instead we must use file offsets. In order to make programming simpler, the new runtime will be **implemented in C++ instead of C**. This allows us to overload
+the arrow operator (`->`) which will dynamically convert file offsets to in-memory pointers.
+
+- The choice of C++ also allows us to ditch the old `libgu` library and **use STL** instead.
+
+- The content of the memory mapped files is platform-specific. For that reason there will be two grammar representations:
+     - **Native Grammar Format** (`.ngf`) - which will be instantly loadable by just mapping it to memory, but will be platform-dependent.
+     - **Portable Grammar Format** (`.pgf`) - which will take longer to load but will be more compact and platform independent.
+  The runtime will be able to load `.pgf` files and convert them to `.ngf`. Conversely `.pgf` can be exported from the current `.ngf`.

doc/hackers-guide/README.md

@@ -0,0 +1,20 @@
+# The Hacker's Guide to GF
+
+This is the hacker's guide to GF, for the guide to the galaxy, see the full edition [here](https://en.wikipedia.org/wiki/The_Hitchhiker%27s_Guide_to_the_Galaxy).
+Here we will limit outselves to the vastly narrower domain of the [GF](https://www.grammaticalframework.org) runtime. This means that we will not meet
+any [Vogons](https://en.wikipedia.org/wiki/Vogon), but we will touch upon topics like memory management, databases, transactions, compilers,
+functional programming, theorem proving and sometimes even languages. Subjects that no doubt would interest any curious hacker.
+
+So, **Don't Panic!** and keep reading. This is a live document and will develop together with the runtime itself.
+
+**TABLE OF CONTENTS**
+
+1. Compilation
+   1. [Overview](CompilationOverview.md)
+   1. [Lambda Calculus](LambdaCalculus.md)
+   2. [Parallel Multiple Context-Free Grammars](PMCFG.md)
+2. Runtime
+   1. [Desiderata](DESIDERATA.md)
+   2. [Memory Model](memory_model.md)
+   3. [Abstract Expressions](abstract_expressions.md)
+   4. [Transactions](transactions.md)

doc/hackers-guide/abstract_expressions.md

@@ -0,0 +1,192 @@
+# Data Marshalling Strategies
+
+The runtime is designed to be used from a high-level programming language, which means that there are frequent foreign calls between the host language and C. This also implies that all the data must be frequently marshalled between the binary representations of the two languages. This is usually trivial and well supported for primitive types like numbers and strings but for complex data structures we need to design our own strategy.
+
+The most central data structure in GF is of course the abstract syntax expression. The other two secondary but closely related structures are types and literals. These are complex structures and no high-level programming language will let us to manipulate them directly unless if they are in the format that the runtime of the language understands. There are three main strategies to deal with complex data accross a language boundry:
+
+1. Keep the data in the C world and provide only an opaque handle to the host language. This means that all operations over the data must be done in C via foreign calls.
+2. Design a native host-language representation. For each foreign call the data is copied from the host language to the C representation and vice versa. Copying is obviously bad, but not too bad if the data is small. The added benefit is that now both languages have first-class access to the data. As a bonus, the garbage collector of the host language now understands the data and can immediately release it if part of it becomes unreachable.
+3. Keep the data in the host language. The C code has only an indirect access via opaque handles and calls back to the host language. The program in the host language has first-class access and the garbage collector can work with the data. No copying is needed.
+
+The old C runtime used option 1. Obviously, this means that abstract expressions cannot be manipulated directly, but this is not the only problem. When the application constructs abstract expressions from different pieces, a whole a lot of overhead is added. First, the design was such that data in C must always be allocated from a memory pool. This means that even if we want to make a simple function application, we first must allocate a pool which adds memory overhead. In addition, the host language must allocate an object which wraps arround the C structure. The net effect is that while the plain abstract function application requires the allocation of only two pointers, the actually allocated data may be several times bigger if the application builds the expression piece by piece. The situation is better if the expression is entirely created from the runtime and the application just needs to keep a reference to it.
+
+Another problem is that when the runtime has to create a whole bunch of expressions, for instance as a result from parsing or random and exhaustive generation, then all the expressions are allocated in the same memory pool. The application gets separate handles to each of the produced expressions, but the memory pool is released only after all of the handles become unreachable. Obviously the problem here is that different expressions share the same pool. Unfortunately this is hard to avoid since although the expressions are different, they usually share common subexpression. Identifying the shared parts would be expensive and at the end it might mean that each expression node must be allocated in its own pool.
+
+The path taken in the new runtime is a combination of strategies 2 and 3. The abstract expressions are stored in the heap of the host language and use a native for that language representation.
+
+# Abstract Expressions in Different Languages
+
+In Haskell, abstract expressions are represented with an algebraic data type:
+```Haskell
+data Expr =
+   EAbs BindType Var Expr
+ | EApp Expr Expr
+ | ELit Literal
+ | EMeta  MetaId
+ | EFun   Fun
+ | EVar   Int
+ | ETyped Expr Type
+ | EImplArg Expr
+```
+while in Python and all other object-oriented languages an expression is represented with objects of different classes:
+```Python
+class Expr: pass
+class ExprAbs(Expr): pass
+class ExprApp(Expr): pass
+class ExprLit(Expr): pass
+class ExprMeta(Expr): pass
+class ExprFun(Expr): pass
+class ExprVar(Expr): pass
+class ExprTyped(Expr): pass
+class ExprImplArg(Expr): pass
+```
+
+The runtime needs its own representation as well but only when an expression is stored in a .ngf file. This happens for instance with all types in the abstract syntax of the grammar. Since the type system allows dependent types, some type signature might contain expressions too. Another appearance for abstract expressions is in function definitions, i.e. in the def rules.
+
+Expressions in the runtime are represented with C structures which on the other hand may contain tagged references to other structures. The lowest four bits of each reference encode the type of structure that it points to, while the rest contain the file offsets in the memory mapped file. For example, function application is represented as:
+```C++
+struct PgfExprApp {
+  static const uint8_t tag = 1;
+
+  PgfExpr fun;
+  PgfExpr arg;
+};
+```
+Here the constant `tag` says that any reference to a PgfExprApp structure must contain the value 1 in its lowest four bits. The fields `fun` and `arg` refer to the function and the argument for that application. The type PgfExpr is defined as:
+```C++
+typedef uintptr_t object;
+typedef object PgfExpr;
+```
+In order to dereference an expression, we first neeed to pattern match and then obtain a `ref<>` object:
+```C++
+switch (ref<PgfExpr>::get_tag(e)) {
+...
+case PgfExprApp::tag: {
+    auto eapp = ref<PgfExprApp>::untagged(e);
+    // do something with eapp->fun and eapp->arg
+    ...
+    break;
+}
+...
+}
+```
+
+The representation in the runtime is internal and should never be exposed to the host language. Moreover, these structures live in the memory mapped file and as we discussed in Section "[Memory Model](memory_model.md)" accessing them requires special care. This also means that occasionally the runtime must make a copy from the native representation to the host representation and vice versa. For example, function:
+```Haskell
+functionType :: PGF -> Fun -> Maybe Type
+```
+must look up the type of an abstract syntax function in the .ngf file and return its type. The type, however, is in the native representation and it must first be copied in the host representation. The converse also happens. When the compiler wants to add a new abstract function to the grammar, it creates its type in the Haskell heap, which the runtime later copies to the native representation in the .ngf file. This is not much different from any other database. The database file usually uses a different data representation than what the host language has.
+
+In most other runtime operations, copying is not necessary. The only thing that the runtime needs to know is how to create new expressions in the heap of the host and how to pattern match on them. For that it calls back to code implemented differently for each host language. For example in:
+```Haskell
+readExpr :: String -> Maybe Expr
+```
+the runtime knows how to read an abstract syntax expression, while for the construction of the actual value it calls back to Haskell. Similarly:
+```Haskell
+showExpr :: [Var] -> Expr -> String
+```
+uses code implemented in Haskell to pattern match on the different algebraic constructors, while the text generation itself happens inside the runtime.
+
+# Marshaller and Unmarshaller
+
+The marshaller and the unmarshaller are the two key data structures which bridge together the different representation realms for abstract expressions and types. The structures have two equivalent definitions, one in C++:
+```C++
+struct PgfMarshaller {
+    virtual object match_lit(PgfUnmarshaller *u, PgfLiteral lit)=0;
+    virtual object match_expr(PgfUnmarshaller *u, PgfExpr expr)=0;
+    virtual object match_type(PgfUnmarshaller *u, PgfType ty)=0;
+};
+
+struct PgfUnmarshaller {
+    virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body)=0;
+    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg)=0;
+    virtual PgfExpr elit(PgfLiteral lit)=0;
+    virtual PgfExpr emeta(PgfMetaId meta)=0;
+    virtual PgfExpr efun(PgfText *name)=0;
+    virtual PgfExpr evar(int index)=0;
+    virtual PgfExpr etyped(PgfExpr expr, PgfType typ)=0;
+    virtual PgfExpr eimplarg(PgfExpr expr)=0;
+    virtual PgfLiteral lint(size_t size, uintmax_t *v)=0;
+    virtual PgfLiteral lflt(double v)=0;
+    virtual PgfLiteral lstr(PgfText *v)=0;
+    virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
+                         PgfText *cat,
+                         int n_exprs, PgfExpr *exprs)=0;
+    virtual void free_ref(object x)=0;
+};
+```
+and one in C:
+```C
+typedef struct PgfMarshaller PgfMarshaller;
+typedef struct PgfMarshallerVtbl PgfMarshallerVtbl;
+struct PgfMarshallerVtbl {
+    object (*match_lit)(PgfUnmarshaller *u, PgfLiteral lit);
+    object (*match_expr)(PgfUnmarshaller *u, PgfExpr expr);
+    object (*match_type)(PgfUnmarshaller *u, PgfType ty);
+};
+struct PgfMarshaller {
+    PgfMarshallerVtbl *vtbl;
+};
+
+typedef struct PgfUnmarshaller PgfUnmarshaller;
+typedef struct PgfUnmarshallerVtbl PgfUnmarshallerVtbl;
+struct PgfUnmarshallerVtbl {
+    PgfExpr (*eabs)(PgfUnmarshaller *this, PgfBindType btype, PgfText *name, PgfExpr body);
+    PgfExpr (*eapp)(PgfUnmarshaller *this, PgfExpr fun, PgfExpr arg);
+    PgfExpr (*elit)(PgfUnmarshaller *this, PgfLiteral lit);
+    PgfExpr (*emeta)(PgfUnmarshaller *this, PgfMetaId meta);
+    PgfExpr (*efun)(PgfUnmarshaller *this, PgfText *name);
+    PgfExpr (*evar)(PgfUnmarshaller *this, int index);
+    PgfExpr (*etyped)(PgfUnmarshaller *this, PgfExpr expr, PgfType typ);
+    PgfExpr (*eimplarg)(PgfUnmarshaller *this, PgfExpr expr);
+    PgfLiteral (*lint)(PgfUnmarshaller *this, size_t size, uintmax_t *v);
+    PgfLiteral (*lflt)(PgfUnmarshaller *this, double v);
+    PgfLiteral (*lstr)(PgfUnmarshaller *this, PgfText *v);
+    PgfType (*dtyp)(PgfUnmarshaller *this,
+                    int n_hypos, PgfTypeHypo *hypos,
+                    PgfText *cat,
+                    int n_exprs, PgfExpr *exprs);
+    void (*free_ref)(PgfUnmarshaller *this, object x);
+};
+struct PgfUnmarshaller {
+    PgfUnmarshallerVtbl *vtbl;
+};
+```
+Which one you will get, depends on whether you import `pgf/pgf.h` from C or C++.
+
+As we can see, most of the arguments for the different methods are of type `PgfExpr`, `PgfType` or `PgfLiteral`. These are all just type synonyms for the type `object`, which on the other hand is nothing else but a number with enough bits to hold an address if necessary. The interpretation of the number depends on the realm in which the object lives. The following table shows the interpretations for four languages as well as the one used internally in the .ngf files:
+|          | PgfExpr        | PgfLiteral        | PgfType        |
+|----------|----------------|-------------------|----------------|
+| Haskell  | StablePtr Expr | StablePtr Literal | StablePtr Type |
+| Python   | ExprObject *   | PyObject *        | TypeObject *   |
+| Java     | jobject        | jobject           | jobject        |
+| .NET     | GCHandle       | GCHandle          | GCHandle       |
+| internal | file offset    | file offset       | file offset    |
+
+The marshaller is the structure that lets the runtime to pattern match on an expression. When one of the match methods is executed, it checks the kind of expr, literal or type and calls the corresponding method from the unmarshaller which it gets as an argument. The method on the other hand gets as arguments the corresponding sub-expressions and attributes.
+
+Generally the role of an unmarshaller is to construct things. For example, the variable `unmarshaller` in `PGF2.FFI` is an object which can construct new expressions in the Haskell heap from the already created children. Function `readExpr`, for instance, passes that one to the runtime to instruct it that the result must be in the Haskell realm.
+
+Constructing objects is not the only use of an unmarshaller. The implementation of `showExpr` passes to `pgf_print_expr` an abstract expression in Haskell and the `marshaller` defined in PGF2.FFI. That marshaller knows how to pattern match on Haskell expressions and calls the right methods from whatever unmarhaller is given to it. What it will get in that particular case is a special unmarshaller which does not produce new representations of abstract expressions, but generates a string.
+
+
+# Literals
+
+Finally, we should have a few remarks about how values of the literal types `String`, `Int` and `Float` are represented in the runtime.
+
+`String` is represented as the structure:
+```C
+typedef struct {
+    size_t size;
+    char text[];
+} PgfText;
+```
+Here the first field is the size of the string in number of bytes. The second field is the string itself, encoded in UTF-8. Just like in most modern languages, the string may contain the zero character and that is not an indication for end of string. This means that functions like `strlen` and `strcat` should never be used when working with PgfText. Despite that the text is not zero terminated, the runtime always allocates one more last byte for the text content and sets it to zero. That last byte is not included when calculating the field `size`. The purpose is that with that last zero byte the GDB debugger knows how to show the string properly. Most of the time, this doesn't incur any memory overhead either since `malloc` always allocates memory in size divisible by the size of two machine words. The consequence is that usually there are some byte left unused at the end of every string anyway.
+
+`Int` is like the integers in Haskell and Python and can have arbitrarily many digits. In the runtime, the value is represented as an array of `uintmax_t` values. Each of these values contains as many decimal digits as it is possible to fit in `uintmax_t`. For example on a 64-bit machine, 
+the maximal value that fits is 18446744073709551616. However, the left-most digit here is at most 1, this means that if we want to represend an arbitrary sequence of digits, the maximal length of the sequence must be at most 19. Similarly on a 32-bit machine each value in the array will store 9 decimal digits. Finally the sign of the number is stored as the sign of the first number in the array which is always threated as `intmax_t`.
+
+Just to have an example, the number `-774763251095801167872` is represented as the array `{-77, 4763251095801167872}`. Note that this representation is not at all suitable for implementing arithmetics with integers, but is very simple to use for us since the runtime only needs to to parse and linearize numbers.
+
+`Float` is trivial and is just represented as the type `double` in C/C++. This can also be seen in the type of the method `lflt` in the unmarshaller.
+

doc/hackers-guide/memory_model.md

@@ -0,0 +1,136 @@
+# The different storage files
+
+The purpose of the `.ngf` files is to be used as on-disk databases that store grammars. Their format is platform-dependent and they should not be copied from
+one platform to another. In contrast the `.pgf` files are platform-independent and can be moved around. The runtime can import a `.pgf` file and create an `.ngf` file.
+Conversely a `.pgf` file can be exported from an already existing `.ngf` file.
+
+The internal relation between the two files is more interesting. The runtime uses its own memory allocator which always allocates memory from a memory mapped file.
+The file may be explicit or an anonymous one. The `.ngf` is simply a memory image saved in a file. This means that loading the file is always immediate.
+You just create a new mapping and the kernel will load memory pages on demand.
+
+On the other hand a `.pgf` file is a version of the grammar serialized in a platform-independent format. This means that loading this type of file is always slower.
+Fortunately, you can always create an `.ngf` file from it to speed up later reloads.
+
+The runtime has three ways to load a grammar:
+
+#### 1. Loading a `.pgf`
+```Haskell
+readPGF :: FilePath -> IO PGF
+```
+This loads the `.pgf` into an anonymous memory-mapped file. In practice, this means that instead of allocating memory from an explicit file, the runtime will still
+use the normal swap file.
+
+#### 2. Loading a `.pgf` and booting a new `.ngf`
+```Haskell
+bootPGF :: FilePath -> FilePath -> IO PGF
+```
+The grammar is loaded from a `.pgf` (the first argument) and the memory is mapped to an explicit `.ngf` (second argument). The `.ngf` file is created by the function
+and a file with the same name should not exist before the call.
+
+#### 3. Loading an existing memory image
+```Haskell
+readNGF :: FilePath -> IO PGF
+```
+Once an `.ngf` file exists, it can be mapped back to memory by using this function. This call is always guaranteed to be fast. The same function can also
+create new empty `.ngf` files. If the file does not exist, then a new one will be created which contains an empty grammar. The grammar could then be extended
+by dynamically adding functions and categories.
+
+# The content of an `.ngf` file
+
+The `.ngf` file is a memory image but this is not the end of the story. The problem is that there is no way to control at which address the memory image would be
+mapped. On Posix systems, `mmap` takes as hint the mapping address but the kernel may choose to ignore it. There is also the flag `MAP_FIXED`, which makes the hint
+into a constraint, but then the kernel may fail to satisfy the constraint. For example that address may already be used for something else. Furthermore, if the
+same file is mapped from several processes (if they all load the same grammar), it would be difficult to find an address which is free in all of them.
+Last but not least using `MAP_FIXED` is considered a security risk.
+
+Since the start address of the mapping can change, using traditional memory pointers withing the mapped area is not possible. The only option is to use offsets
+relative to the beginning of the area. In other words, if normally we would have written `p->x`, now we have the offset `o` which we must use like this:
+```C++
+((A*) (current_base+o))->x
+```
+
+Writing the explicit pointer arithmetics and typecasts, each time when we dereference a pointer, is not better than Vogon poetry and it
+becomes worse when using a chain of arrow operators. The solution is to use the operator overloading in C++.
+There is the type `ref<A>` which wraps around a file offset to a data item of type `A`. The operators `->` and `*`
+are overloaded for the type and they do the necessary pointer arithmetics and type casts.
+
+This solves the problem with code readability but creates another problem. How do `->` and `*` know the address of the memory mapped area? Obviously,
+`current_base` must be a global variable and there must be a way to initialize it. More specifically it must be thread-local to allow different threads to
+work without collisions.
+
+A database (a memory-mapped file) in the runtime is represented by the type `DB`. Before any of the data in the database is accessed, the database must
+be brought into scope. Bringing into scope means that `current_base` is initialized to point to the mapping area for that database. After that any dereferencing
+of a reference will be done relative to the corresponding database. This is how scopes are defined:
+```C++
+{
+    DB_scope scope(db, READER_SCOPE);
+    ...
+}
+```
+Here `DB_scope` is a helper type and `db` is a pointer to the database that you want to bring into scope. The constructor for `DB_scope` saves the old value
+for `current_base` and then sets it to point to the area of the given database. Conversely, the destructor restores the previous value.
+
+The use of `DB_scope` is reentrant, i.e. you can do this:
+```C++
+{
+    DB_scope scope(db1, READER_SCOPE);
+    ...
+    {
+        DB_scope scope(db2, READER_SCOPE);
+        ...
+    }
+    ...
+}
+```
+What you can't do is to have more than one database in scope simultaneously. Fortunately, that is not needed. All API functions start a scope
+and the internals of the runtime always work with the current database in scope.
+
+Note the flag `READER_SCOPE`. You can use either `READER_SCOPE` or `WRITER_SCOPE`. In addition to selecting the database, the `DB_scope` also enforces
+the single writer/multiple readers policy. The main problem is that a writer may have to enlarge the current file, which consequently may mean
+that the kernel should relocate the mapping area to a new address. If there are readers at the same time, they may break since they expect that the mapped
+area is at a particular location.
+
+# Developing writers
+
+There is one important complication when developing procedures modifying the database. Every call to `DB::malloc` may potentially have to enlarge the mapped area
+which sometimes leads to changing `current_base`. That would not have been a problem if GCC was not sometimes caching variables in registers. Look at the following code:
+```C++
+p->r = foo();
+```
+Here `p` is a reference which is used to access another reference `r`. On the other hand, `foo()` is a procedure which directly or indirectly calls `DB::malloc`.
+GCC compiles assignments by first computing the address to modify, and then it evaluates the right hand side. This means that while `foo()` is being evaluated the address computed on the left-hand side is saved in a register or somewhere in the stack. But now, if it happens that the allocation in `foo()` has changed
+`current_base`, then the saved address is no longer valid.
+
+That first problem is solved by overloading the assignment operator for `ref<A>`:
+```C++
+ref<A>& operator= (const ref<A>& r) {
+    offset = r.offset;
+    return *this;
+}
+```
+On first sight, nothing special happens here and it looks like the overloading is redundant. However, now the assignments are compiled in a very different way.
+The overloaded operator is inlined, so there is no real method call and we don't get any overhead. The real difference is that now, whatever is on the left-hand side of the assignment becomes the value of the `this` pointer, and `this` is always the last thing to be evaluated in a method call. This solves the problem.
+`foo()` is evaluated first and if it changes `current_base`, the change will be taken into account when computing the left-hand side of the assignment.
+
+Unfortunately, this is not the only problem. A similar thing happens when the arguments of a function are calls to other functions. See this:
+```C++
+foo(p->r,bar(),q->r)
+```
+Where now `bar()` is the function that performs allocation. The compiler is free to keep in a register the value of `current_base` that it needs for the evaluation of
+`p->r`, while it evaluates `bar()`. But if `current_base` has changed, then the saved value would be invalid while computing `q->r`. There doesn't seem to be
+a work around for this. The only solution is to:
+
+**Never call a function that allocates as an argument to another function**
+
+Instead we call allocating functions on a separate line and we save the result in a temporary variable.
+
+
+# Thread-local variables
+
+A final remark is the compilation of thread-local variables. When a thread-local variable is compiled in a position-dependent code, i.e. in executables, it is
+compiled efficiently by using the `fs` register which points to the thread-local segment. Unfortunately, that is not the case by default for shared
+libraries like our runtime. In that case, GCC applies the global-dynamic model which means that access to a thread local variable is internally implemented
+with a call to the function `__tls_get_addr`. Since `current_base` is used all the time, this adds overhead.
+
+The solution is to define the variable with the attribute `__attribute__((tls_model("initial-exec")))` which says that it should be treated as if it is defined
+in an executable. This removes the overhead, but adds the limitation that the runtime should not be loaded with `dlopen`.

doc/hackers-guide/transactions.md

@@ -0,0 +1,131 @@
+# Transactions
+
+The `.ngf` files that the runtime creates are actual databases which are used to get quick access to the grammars. Like in any database, we also make it possible to dynamically change the data. In our case this means that we can add and remove functions and categories at any time. Moreover, any changes happen in transactions which ensure that changes are not visible until the transaction is commited. The rest of the document describes how the transactions are implemented.
+
+# Databases and Functional Languages
+
+The database model of the runtime is specifically designed to be friendly towards pure functional languages like Haskell. In a usual database, updates happen constantly and therefore executing one and the same query at different times would yield different results. In our grammar databases, queries correspond to operations like parsing, linearization and generation. This means that if we had used the usual database model, all these operations would have to be bound to the IO monad. Consider this example:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  functionType gr "f" >>= print
+  -- modify the grammar gr
+  functionType gr "f" >>= print
+```
+Here we ask for the type of a function before and after an arbitrary update in the grammar `gr`. Obviously if we allow that then `functionType` would have to be in the IO monad, e.g.:
+
+```Haskell
+functionType :: PGF -> Fun -> IO Type
+```
+
+Although this is a possible way to go, it would mean that the programmer would have to do all grammar related work in the IO. This is not nice and against the spirit of functional programming. Moreover, all previous implementations of the runtime have assumed that most operations are pure. If we go along that path then this will cause a major breaking change.
+
+Fortunately there is an alternative. Read-only operations remain pure functions, but any update should create a new revision of the database rather than modifying the existing one. Compare this example with the previous:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  print (functionType gr "f")
+  gr2 <- modifyPGF gr $ do
+           -- do all updates here
+  print (functionType gr2 "f")
+```
+Here `modifyPGF` allows us to do updates but the updates are performed on a freshly created clone of the grammar `gr`. The original grammar is never ever modified. After the changes the variable `gr2` is a reference to the new revision. While the transaction is in progress we cannot see the currently changing revision, and therefore all read-only operations can remain pure. Only after the transaction is complete do we get to use `gr2`, which will not change anymore.
+
+Note also that above `functionType` is used with its usual pure type:
+```Haskell
+functionType :: PGF -> Fun -> Type
+```
+This is safe since the API never exposes database revisions which are not complete. Furthermore, the programmer is free to keep several revisions of the same database simultaneously. In this example:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  gr2 <- modifyPGF gr $ do
+           -- do all updates here
+  print (functionType gr "f", functionType gr2 "f")
+```
+The last line prints the type of function `"f"` in both the old and the new revision. Both are still available.
+
+The API as described so far would have been complete if all updates were happening in a single thread. In reality we can expect that there might be several threads or processes modifying the database. The database ensures a multiple readers/single writer exclusion but this doesn't mean that another process/thread cannot modify the database while the current one is reading an old revision. In a parallel setting, `modifyPGF` first merges the revision which the process is using with the latest revision in the database. On top of that the specified updates are performed. The final revision after the updates is returned as a result.
+
+**TODO: Interprocess synhronization is still not implemented**
+
+**TODO: Merges are still not implemented.**
+
+The process can also ask for the latest revision by calling `checkoutPGF`, see bellow.
+
+# Databases and Imperative Languages
+
+In imperative languages, the state of the program constantly changes and the considerations in the last section do not apply. All read-only operations always work with the latest revision. Bellow is the previous example translated to Python:
+```Python
+gr = readNGF("Example.ngf")
+print(functionType(gr,"f"))
+with gr.transaction() as t:
+  # do all updates here by using t
+print(functionType(gr,"f"))
+```
+Here the first call to `functionType` returns the old type of "f", while the second call retrives the type after the updates. The transaction itself is initiated by the `with` statement. Inside the with statement `gr` will still refer to the old revision since the new one is not complete yet. If the `with` statement is finished without exceptions then `gr` is updated to point to the new one. If an exception occurs then the new revision is discarded, which corresponds to a transaction rollback. Inside the `with` block, the object `t` of type `Transaction` provides methods for modifying the data.
+
+# Branches
+
+Since the database already supports revisions, it is a simple step to support branches as well. A branch is just a revision with a name. When you open a database with `readNGF`, the runtime looks up and returns the revision (branch) with name `master`. There might be other branches as well. You can retrieve a specific branch by calling:
+```Haskell
+checkoutPGF :: PGF -> String -> IO (Maybe PGF)
+```
+Here the string is the branch name. New branches can be created by using:
+```Haskell
+branchPGF :: PGF -> String -> Transaction a -> IO PGF
+```
+Here we start with an existing revision, apply a transaction and store the result in a new branch with the given name.
+
+# Implementation
+
+The low-level API for transactions consists of only four functions:
+```C
+PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
+                               PgfText *name,
+                               PgfExn *err);
+
+void pgf_free_revision(PgfDB *pgf, PgfRevision revision);
+
+void pgf_commit_revision(PgfDB *db, PgfRevision revision,
+                         PgfExn *err);
+
+PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
+                                  PgfExn *err);
+```
+Here `pgf_clone_revision` makes a copy of an existing revision and — if `name` is not `NULL` — changes its name. The new revision is transient and exists only until it is released with `pgf_free_revision`. Transient revisions can be updated with the API for adding functions and categories. To make a revision persistent, call `pgf_commit_revision`. After the revision is made persistent it will stay in the database even after you call `pgf_free_revision`. Moreover, it will replace the last persistent revision with the same name. The old revision will then become transient and will exist only until all clients call `pgf_free_revision` for it.
+
+Persistent revisions can never be updated. Instead you clone it to create a new transient revision. That one is updated and finally it replaces the existing persistent revision.
+
+This design for transactions may sound unusual but it is just another way to present the copy-on-write strategy. There instead of transaction logs, each change to the data is written in a new place and the result is made available only after all changes are in place. This is for instance what the [LMDB](http://www.lmdb.tech/doc/) (Lightning Memory-Mapped Database) does and it has also served as an inspiration for us.
+
+## Functional Data Structures
+
+From an imperative point of view, it may sound wasteful that a new copy of the grammar is created for each transaction. Functional programmers on the other hand know that with a functional data structure, you can make a copy which shares as much of the data with the original as possible. Each new version copies only those bits that are different from the old one. For example the main data structure that we use to represent the abstract syntax of a grammar is a size-balanced binary tree as described by:
+
+- Stephen Adams, "Efficient sets: a balancing act", Journal of Functional Programming 3(4):553-562, October 1993, http://www.swiss.ai.mit.edu/~adams/BB/.
+
+- J. Nievergelt and E.M. Reingold, "Binary search trees of bounded balance", SIAM journal of computing 2(1), March 1973.
+
+
+## Garbage Collection
+
+We use reference counting to keep track of which objects should be kept alive. For instance, `pgf_free_revision` knows that a transient revision should be removed only when its reference count reaches zero. This means that there is no process or thread using it. The function also checks whether the revision is persistent. Persistent revisions are never removed since they can always be retrieved with `checkoutPGF`.
+
+Clients are supposed to correctly use `pgf_free_revision` to indicate that they don't need a revision any more. Unfortunately, this is not always possible to guarantee. For example many languages with garbage collection will call `pgf_free_revision` from a finalizer method. In some languages, however, the finalizer is not guaranteed to be executed if the process terminates before the garbage collection is done. Haskell is one of those languages. Even in languages with reference counting like Python, the process may get killed by the operating system and then the finalizer may still not be executed.
+
+The solution is that we count on the database clients to correctly report when a revision is not needed. However, on a fresh database restart we explictly clean all left over transient revisions. This means that even if a client is killed or if it does not correctly release its revisions, the worst that can happen is a memory leak until the next restart.
+
+
+## Atomicity
+
+The transactions serve two goals. First they make it possible to isolate readers from seeing unfinished changes from writers. Second, they ensure atomicity. A database change should be either completely done or not done at all. The use of transient revisions ensures the isolation but the atomicity is only partly taken care of.
+
+Think about what happens when a writer starts updating a transient revision. All the data is allocated in a memory mapped file. From the point of view of the runtime, all changes happen in memory. When all is done, the runtime calls `msync` which tells the kernel to flush all dirty pages to disk. The problem is that the kernel is also free to flush pages at any time. For instance, if there is not enough memory, it may decide to swap out pages earlier and reuse the released physical space to swap in other virtual pages. This would be fine if the transaction eventually succeeds. However, if this doesn't happen then the image in the file is already changed.
+
+We can avoid the situation by calling [mlock](https://man7.org/linux/man-pages/man2/mlock.2.html) and telling the kernel that certain pages should not be swapped out. The question is which pages to lock. We can lock them all, but this is too much. That would mean that as soon as a page is touched it will never leave the physical memory. Instead, it would have been nice to tell the kernel -- feel free to swap out clean pages but, as soon as they get dirty, keep them in memory until further notice. Unfortunately there is no way to do that directly.
+
+The work around is to first use [mprotect](https://man7.org/linux/man-pages/man2/mprotect.2.html) and keep all pages as read-only. Any attempt to change a page will cause segmentation fault which we can capture. If the change happens during a transaction then we can immediate lock the page and add it to the list of modified pages. When a transaction is successful we sync all modified pages. If an attempt to change a page happens outside of a transaction, then this is either a bug in the runtime or the client is trying to change an address which it should not change. In any case this prevents unintended changes in the data.
+
+
+**TODO: atomicity is not implemented yet**

download/index-3.11.md

@@ -53,26 +53,39 @@ You will probably need to update the `PATH` environment variable to include your
 
 For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
 
-<!--## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
+## Installing from Hackage
+
+_Instructions applicable for macOS, Linux, and WSL2 on Windows._
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
 
-1.  Install ghcup https://www.haskell.org/ghcup/
-2.  `ghcup install ghc 8.10.4`
-3.  `ghcup set ghc 8.10.4`
-4.  `cabal update`
-5.  On Linux: install some C libraries from your Linux distribution (see note below)
-6.  `cabal install gf-3.11`
-
-You can also download the source code release from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases),
-and follow the instructions below under **Installing from the latest developer source code**.
+```
+cabal update
+cabal install gf-3.11
+```
 
 ### Notes
 
+**GHC version**
+
+The GF source code is known to be compilable with GHC versions 7.10 through to 8.10.
+
+**Obtaining Haskell**
+
+There are various ways of obtaining Haskell, including:
+
+- ghcup
+    1.  Install from https://www.haskell.org/ghcup/
+    2.  `ghcup install ghc 8.10.4`
+    3.  `ghcup set ghc 8.10.4`
+- Haskell Platform https://www.haskell.org/platform/
+- Stack https://haskellstack.org/
+
+
 **Installation location**
 
-The above steps installs GF for a single user.
+The above steps install GF for a single user.
 The executables are put in `$HOME/.cabal/bin` (or on macOS in `$HOME/Library/Haskell/bin`),
 so you might want to add this directory to your path (in `.bash_profile` or similar):
 
@@ -84,32 +97,34 @@ PATH=$HOME/.cabal/bin:$PATH
 
 GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
 on Linux depends on some non-Haskell libraries that won't be installed
-automatically by cabal, and therefore need to be installed manually.
+automatically by Cabal, and therefore need to be installed manually.
 Here is one way to do this:
 
 - On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
 - On Fedora: `sudo dnf install ghc-haskeline-devel`
 
-**GHC version**
+## Installing from source code
 
-The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
--->
-## Installing from the latest developer source code
+**Obtaining**
 
-If you haven't already, clone the repository with:
+To obtain the source code for the **release**,
+download it from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases).
 
+Alternatively, to obtain the **latest version** of the source code:
+
+1. If you haven't already, clone the repository with:
 ```
 git clone https://github.com/GrammaticalFramework/gf-core.git
 ```
-
-If you've already cloned the repository previously, update with:
-
+2. If you've already cloned the repository previously, update with:
 ```
 git pull
 ```
 
-Then install with:
 
+**Installing**
+
+You can then install with:
 ```
 cabal install
 ```

gf.cabal

@@ -109,8 +109,6 @@ executable gf
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Predef
-    GF.Compile.Compute.Value
     GF.Compile.Compute.Concrete
     GF.Compile.ExampleBased
     GF.Compile.Export
@@ -118,7 +116,6 @@ executable gf
     GF.Compile.GeneratePMCFG
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
-    GF.Compile.Optimize
     GF.Compile.OptimizePGF
     GF.Compile.PGFtoHaskell
     GF.Compile.PGFtoJava

index.html

@@ -8,7 +8,7 @@
 
   <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
   <link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css" integrity="sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO" crossorigin="anonymous">
-  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.4.2/css/all.css" integrity="sha384-/rXc/GQVaYpyDdyxK+ecHPVYJSN9bmVFBvjA/9eOB+pb3F2w2N6fc5qB9Ew5yIns" crossorigin="anonymous">
+  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.15.4/css/all.css" crossorigin="anonymous">
 
   <link rel="alternate" href="https://github.com/GrammaticalFramework/gf-core/" title="GF GitHub repository">
 </head>
@@ -85,10 +85,27 @@
   <div class="col-sm-6 col-md-3 mb-4">
     <h3>Contribute</h3>
     <ul class="mb-2">
-      <li><a href="http://groups.google.com/group/gf-dev">Mailing List</a></li>
+      <li>
+        <a href="https://web.libera.chat/?channels=#gf">
+          <i class="fas fa-hashtag"></i>
+          IRC
+        </a>
+        /
+        <a href="https://discord.gg/EvfUsjzmaz">
+          <i class="fab fa-discord"></i>
+          Discord
+        </a>
+      </li>
+      <li>
+        <a href="https://stackoverflow.com/questions/tagged/gf">
+          <i class="fab fa-stack-overflow"></i>
+          Stack Overflow
+        </a>
+      </li>
+      <li><a href="https://groups.google.com/group/gf-dev">Mailing List</a></li>
       <li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
-      <li><a href="doc/gf-people.html">Authors</a></li>
       <li><a href="//school.grammaticalframework.org/2020/">Summer School</a></li>
+      <li><a href="doc/gf-people.html">Authors</a></li>
     </ul>
     <a href="https://github.com/GrammaticalFramework/" class="btn btn-primary ml-3">
       <i class="fab fa-github mr-1"></i>
@@ -154,7 +171,7 @@ least one, it may help you to get a first idea of what GF is.
 <div class="row">
 
   <div class="col-md-6">
-    <h2>Applications & Availability</h2>
+    <h2>Applications & availability</h2>
     <p>
     GF can be used for building
     <a href="//cloud.grammaticalframework.org/translator/">translation systems</a>,
@@ -219,19 +236,28 @@ least one, it may help you to get a first idea of what GF is.
     or <a href="https://www.grammaticalframework.org/irc/?C=M;O=D">browse the channel logs</a>.
     </p>
     <p>
-    If you have a larger question which the community may benefit from, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
+    There is also a <a href="https://discord.gg/EvfUsjzmaz">GF server on Discord</a>.
+    </p>
+
+    <p>
+    For bug reports and feature requests, please create an issue in the
+    <a href="https://github.com/GrammaticalFramework/gf-core/issues">GF Core</a> or
+    <a href="https://github.com/GrammaticalFramework/gf-rgl/issues">RGL</a> repository.
+
+    For programming questions, consider asking them on <a href="https://stackoverflow.com/questions/tagged/gf">Stack Overflow with the <code>gf</code> tag</a>.
+    If you have a more general question to the community, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
     </p>
 
   </div>
 
   <div class="col-md-6">
     <h2>News</h2>
-    <dt class="col-sm-3 text-center text-nowrap">2021-07-25</dt>
-    <dd class="col-sm-9">
-      <strong>GF 3.11 released.</strong>
-      <a href="download/release-3.11.html">Release notes</a>
-    </dd>
     <dl class="row">
+      <dt class="col-sm-3 text-center text-nowrap">2021-07-25</dt>
+      <dd class="col-sm-9">
+        <strong>GF 3.11 released.</strong>
+        <a href="download/release-3.11.html">Release notes</a>
+      </dd>
       <dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
       <dd class="col-sm-9">
         <a href="https://cloud.grammaticalframework.org/wordnet/">GF WordNet</a> now supports languages for which there are no other WordNets. New additions: Afrikaans, German, Korean, Maltese, Polish, Somali, Swahili.
@@ -244,34 +270,6 @@ least one, it may help you to get a first idea of what GF is.
       <dd class="col-sm-9">
         <a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Abstract Syntax as Interlingua</a>: Scaling Up the Grammatical Framework from Controlled Languages to Robust Pipelines. A paper in Computational Linguistics (2020) summarizing much of the development in GF in the past ten years.
       </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-03</dt>
-      <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-02</dt>
-      <dd class="col-sm-9">
-        <strong>GF 3.10 released.</strong>
-        <a href="download/release-3.10.html">Release notes</a>
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-07-25</dt>
-      <dd class="col-sm-9">
-        The GF repository has been split in two:
-        <a href="https://github.com/GrammaticalFramework/gf-core">gf-core</a> and
-        <a href="https://github.com/GrammaticalFramework/gf-rgl">gf-rgl</a>.
-        The original <a href="https://github.com/GrammaticalFramework/GF">GF</a> repository is now archived.
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-08-11</dt>
-      <dd class="col-sm-9">
-        <strong>GF 3.9 released.</strong>
-        <a href="download/release-3.9.html">Release notes</a>
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-06-29</dt>
-      <dd class="col-sm-9">
-        GF is moving to <a href="https://github.com/GrammaticalFramework/GF/">GitHub</a>.</dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-03-13</dt>
-      <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2017/">GF Summer School</a> in Riga (Latvia), 14-25 August 2017
-      </dd>
     </dl>
 
     <h2>Projects</h2>
@@ -341,7 +339,7 @@ least one, it may help you to get a first idea of what GF is.
     Libraries are at the heart of modern software engineering. In natural language
     applications, libraries are a way to cope with thousands of details involved in
     syntax, lexicon, and inflection. The
-    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> has
+    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> (RGL) has
     support for an increasing number of languages, currently including
     Afrikaans,
     Amharic (partial),

src/compiler/GF/Command/Commands.hs

@@ -6,7 +6,6 @@ module GF.Command.Commands (
 import Prelude hiding (putStrLn,(<>))
 
 import PGF2
-import PGF2.Internal(writePGF)
 
 import GF.Compile.Export
 import GF.Compile.ToAPI
@@ -666,7 +665,7 @@ pgfCommands = Map.fromList [
          [e] -> case unApp e of
                   Just (id, []) -> case functionType pgf id of
                                      Just ty -> do putStrLn (showFun pgf id ty)
-                                                   putStrLn ("Probability: "++show (treeProbability pgf e))
+                                                   putStrLn ("Probability: "++show (exprProbability pgf e))
                                                    return void
                                      Nothing -> case categoryContext pgf id of
                                                   Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
@@ -682,7 +681,7 @@ pgfCommands = Map.fromList [
                                      Left err     -> error err
                                      Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                                         putStrLn ("Type:        "++showType [] ty)
-                                                        putStrLn ("Probability: "++show (treeProbability pgf e))
+                                                        putStrLn ("Probability: "++show (exprProbability pgf e))
                                                         return void
          _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void,
@@ -800,8 +799,8 @@ pgfCommands = Map.fromList [
 
    showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
                        where
-                         kwd | functionIsDataCon pgf id = "data"
-                             | otherwise                = "fun"
+                         kwd | functionIsConstructor pgf id = "data"
+                             | otherwise                    = "fun"
 
    morphos pgf opts s =
      [(s,lookupMorpho concr s) | concr <- optLangs pgf opts]

src/compiler/GF/Command/Importing.hs

@@ -39,6 +39,8 @@ importGrammar pgf0 opts files =
                       return pgf0
     ".pgf" -> do
       mapM readPGF files >>= foldM ioUnionPGF pgf0
+    ".ngf" -> do
+      mapM readNGF files >>= foldM ioUnionPGF pgf0
     ext -> die $ "Unknown filename extension: " ++ show ext
 
 ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,6 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF2(pExpr,pIdent)
+import PGF(pExpr,pIdent)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -22,7 +22,7 @@ pCommandLine =
 pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
 
 pCommand = (do
-  cmd  <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
   skipSpaces
   opts <- sepBy pOption skipSpaces
   arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
 
 pOption = do
   char '-'
-  flg <- readS_to_P pIdent
+  flg <- pIdent
   option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
 
 pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
 
 pArgument =
   option ANoArg
-    (fmap AExpr (readS_to_P pExpr)
+    (fmap AExpr pExpr
               <++
-    (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
 
 pArgTerm = ATerm `fmap` readS_to_P sTerm
   where

src/compiler/GF/Command/SourceCommands.hs

@@ -8,9 +8,11 @@ import qualified Data.Map as Map
 
 import GF.Infra.SIO(MonadSIO(..),restricted)
 import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
-import GF.Data.Operations (chunks,err,raise)
-import GF.Text.Pretty(render)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM
+import GF.Text.Pretty(render,pp)
 import GF.Data.Str(sstr)
+import GF.Data.Operations (chunks,err,raise)
 
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Grammar.Analyse
@@ -18,10 +20,8 @@ import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(normalForm)
 import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
-import GF.Infra.Dependencies(depGraph)
-import GF.Infra.CheckM(runCheck)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -162,12 +162,11 @@ sourceCommands = Map.fromList [
       do sgr <- getGrammar
          liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete opts ws sgr =
+    compute_concrete opts ws sgr = fmap fst $ runCheck $
       case runP pExp (UTF8.fromString s) of
         Left (_,msg) -> return $ pipeMessage msg
-        Right t      -> return $ err pipeMessage
-                                     (fromString . showTerm sgr style q)
-                                 $ checkComputeTerm opts sgr t
+        Right t      -> do t <- checkComputeTerm opts sgr t
+                           return (fromString (showTerm sgr style q t))
       where
         (style,q) = pOpts TermPrintDefault Qualified opts
         s = unwords ws
@@ -200,16 +199,16 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations os ts sgr =
+    show_operations os ts sgr = fmap fst $ runCheck $
       case greatestResource sgr of
-        Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
+        Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?")
         Just mo -> do
           let greps = map valueString (listFlags "grep" os)
           let isRaw = isOpt "raw" os
           ops <- case ts of
              _:_ -> do
                let Right t = runP pExp (UTF8.fromString (unwords ts))
-               ty <- err error return $ checkComputeTerm os sgr t
+               ty <- checkComputeTerm os sgr t
                return $ allOpersTo sgr ty
              _   -> return $ allOpers sgr
           let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
@@ -254,14 +253,12 @@ sourceCommands = Map.fromList [
          return void
 
 checkComputeTerm os sgr t =
-  do mo <- maybe (raise "no source grammar in scope") return $
+  do mo <- maybe (checkError (pp "no source grammar in scope")) return $
            greatestResource sgr
-     ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
-                                inferLType sgr [] t
+     t <- renameSourceTerm sgr mo t
+     (t,_) <- inferLType sgr [] t                                
      let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
-         t2 = evalStr t1
-     checkPredefError t2
+     fmap evalStr (normalForm sgr t)
   where
     -- ** Try to compute pre{...} tokens in token sequences
     evalStr t =

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -21,7 +21,7 @@ import Data.Maybe(fromMaybe)
 --------------------------
 
 cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
-cf2pgf opts fpath cf probs = 
+cf2pgf opts fpath cf probs = error "TODO: cf2pgf" {-
  build (let abstr = cf2abstr cf probs
         in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
  where
@@ -134,3 +134,4 @@ mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n
 	_         -> "_"
+-}

src/compiler/GF/Compile/CheckGrammar.hs

@@ -27,9 +27,9 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
 import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(normalForm)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -54,11 +54,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
   infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
-  foldM updateCheckInfos mo infoss
-  where
-    updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
-      where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
-    update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})
+  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -120,8 +116,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                     return js
                    _ -> do
                      case mb_def of
-                       Ok def -> do (cont,val) <- linTypeOfType gr cm ty
-                                    let linty = (snd (valCat ty),cont,val)
+                       Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
                                     return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                        Bad _  -> do noLinOf c
                                     return js
@@ -140,9 +135,8 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
-                                        do (cont,val) <- linTypeOfType gr cm ty
-                                           let linty = (snd (valCat ty),cont,val)
+                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
+                                        do linty <- linTypeOfType gr cm (L loc ty)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
                                            return js
@@ -158,37 +152,30 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
 
        _ -> return $ Map.insert c info js
 
-
--- | General Principle: only Just-values are checked.
--- A May-value has always been checked in its origin module.
-checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
-checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
+checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
   checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) ->
       mkCheck loc "the category" $
         checkContext gr cont
 
-    AbsFun (Just (L loc typ0)) ma md moper -> do
-      typ <- compAbsTyp [] typ0   -- to calculate let definitions
+    AbsFun (Just (L loc typ)) ma md moper -> do
       mkCheck loc "the type of function" $
         checkTyp gr typ
+      typ <- compAbsTyp [] typ   -- to calculate let definitions
       case md of
         Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-                                          checkDef gr (m,c) typ eq) eqs
+                                          checkDef gr (fst sm,c) typ eq) eqs
         Nothing  -> return ()
-      return (AbsFun (Just (L loc typ)) ma md moper)
+      update sm c (AbsFun (Just (L loc typ)) ma md moper)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $
-                                     (if False --flag optNewComp opts
-                                        then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
-                                                typ  <- computeLType gr [] typ
-                                                return (Just (L loc typ))
-                                        else do (typ,_) <- checkLType gr [] typ typeType
-                                                typ  <- computeLType gr [] typ
-                                                return (Just (L loc typ)))
+                Just (L loc typ) -> chIn loc "linearization type of" $ do
+                                      (typ,_) <- checkLType gr [] typ typeType
+                                      typ  <- normalForm gr typ
+                                      return (Just (L loc typ))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
                 (Just (L _ typ),Just (L loc def)) ->
@@ -208,11 +195,11 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      return (CncCat mty mdef mref mpr mpmcfg)
+      update sm c (CncCat mty mdef mref mpr mpmcfg)
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (cat,cont,val),Just (L loc trm)) ->
+              (Just (_,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
                      (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
                      return (Just (L loc trm))
@@ -223,55 +210,55 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      return (CncFun mty mt mpr mpmcfg)
+      update sm c (CncFun mty mt mpr mpmcfg)
 
     ResOper pty pde -> do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
-           ty'     <- chIn loct "operation" $
-                         (if False --flag optNewComp opts
-                            then CN.checkLType (CN.resourceValues opts gr) ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !!
-                            else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
+           ty'     <- chIn loct "operation" $ do
+                         (ty,_) <- checkLType gr [] ty typeType
+                         normalForm gr ty
            (de',_) <- chIn locd "operation" $
-                         (if False -- flag optNewComp opts
-                            then CN.checkLType (CN.resourceValues opts gr) de ty'
-                            else checkLType gr [] de ty')
+                         checkLType gr [] de ty'
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          (if False -- flag optNewComp opts
-                            then CN.inferLType (CN.resourceValues opts gr) de
-                            else inferLType gr [] de)
+                          inferLType gr [] de
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
              checkError (pp "No definition given to the operation")
-      return (ResOper pty' pde')
+      update sm c (ResOper pty' pde')
 
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
-      tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
+      tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
       tysts1 <- mapM (uncurry $ flip (checkLType gr []))
                   [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
       checkUniq $
         sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
-      return (ResOverload os [(y,x) | (x,y) <- tysts'])
+      update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $
-              liftM concat $ mapM mkPar pcs
-      return (ResParam (Just (L loc pcs)) (Just ts))
+      (sm,cnt,ts) <- chIn loc "parameter type" $
+                        mkParamValues sm 0 [] pcs
+      update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
 
-    _ ->  return info
+    _ ->  return sm
  where
-   gr = prependModule sgr (m,mo)
-   chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
+   gr = prependModule sgr sm
+   chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
 
-   mkPar (f,co) = do
-       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
-       return $ map (mkApp (QC (m,f))) vs
+   mkParamValues sm         cnt ts []          = return (sm,cnt,[])
+   mkParamValues sm@(mn,mi) cnt ts ((f,co):fs) = do
+     sm <- case lookupIdent f (jments mi) of
+             Ok (ResValue ty _) -> update sm f (ResValue ty cnt)
+             Bad msg            -> checkError (pp msg)
+     vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+     (sm,cnt,ts) <- mkParamValues sm (cnt+length vs) ts fs
+     return (sm,cnt,map (mkApp (QC (mn,f))) vs ++ ts)
 
    checkUniq xss = case xss of
      x:y:xs
@@ -281,7 +268,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
      _ -> return ()
 
    mkCheck loc cat ss = case ss of
-     [] -> return info
+     [] -> return sm
      _ -> chIn loc cat $ checkError (vcat ss)
 
    compAbsTyp g t = case t of
@@ -294,7 +281,9 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        t' <- compAbsTyp ((x,Vr x):g) t
        return $ Prod b x a' t'
      Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t
+     _ -> composOp (compAbsTyp g) t  
+
+   update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
 
 
 -- | for grammars obtained otherwise than by parsing ---- update!!
@@ -306,12 +295,13 @@ checkReservedId x =
 -- auxiliaries
 
 -- | linearization types and defaults
-linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
-linTypeOfType cnc m typ = do
-  let (cont,cat) = typeSkeleton typ
-  val  <- lookLin cat
-  args <- mapM mkLinArg (zip [0..] cont)
-  return (args, val)
+linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
+linTypeOfType cnc m (L loc typ) = do
+  let (ctxt,res_cat) = typeSkeleton typ
+  val <- lookLin res_cat
+  lin_args <- mapM mkLinArg (zip [0..] ctxt)
+  let (args,arg_cats) = unzip lin_args
+  return (arg_cats, snd res_cat, args, val)
  where
    mkLinArg (i,(n,mc@(m,cat))) = do
      val  <- lookLin mc
@@ -323,8 +313,8 @@ linTypeOfType cnc m typ = do
                                       "with" $$
                                       nest 2 val)) $
                              plusRecType vars val
-     return (Explicit,symb,rec)
+     return ((Explicit,symb,rec),cat)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= computeLType cnc []
+      lookupLincat cnc m c >>= normalForm cnc
      ,return defLinType
      ]

src/compiler/GF/Compile/Compute/Predef.hs

@@ -1,172 +0,0 @@
--- | Implementations of predefined functions
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-module GF.Compile.Compute.Predef(predef,predefName,delta) where
-
-import qualified Data.Map as Map
-import Data.Array(array,(!))
-import Data.List (isInfixOf)
-import Data.Char (isUpper,toLower,toUpper)
-import Control.Monad(ap)
-
-import GF.Data.Utilities (apBoth) --mapSnd
-
-import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident,showIdent) --,varX
-import GF.Data.Operations(Err) -- ,err
-import GF.Grammar.Predef
-
---------------------------------------------------------------------------------
-class Predef a where
-  toValue :: a -> Value
-  fromValue :: Value -> Err a
-
-instance Predef Int where
-  toValue = VInt
-  fromValue (VInt i) = return i
-  fromValue v = verror "Int" v
-
-instance Predef Bool where
-  toValue = boolV
-  fromValue v = case v of
-    VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
-    VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
-    _ -> verror "Bool" v
-
-instance Predef String where
-  toValue = string
-  fromValue v = case norm v of
-                  VString s -> return s
-                  _ -> verror "String" v
-
-instance Predef Value where
-  toValue = id
-  fromValue = return
-
-instance Predef Predefined where
-  toValue p = VApp p []
-  fromValue v = case v of
-                  VApp p _ -> return p
-                  _        -> fail $ "Expected a predefined constant, got something else"
-
-{-
-instance (Predef a,Predef b) => Predef (a->b) where
-  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
--}
-verror t v =
-  case v of
-    VError e -> fail e
-    VGen {}  -> fail $ "Expected a static value of type "++t
-                       ++", got a dynamic value"
-    _ -> fail $ "Expected a value of type "++t++", got "++show v
-
---------------------------------------------------------------------------------
-
-predef f = maybe undef return (Map.lookup f predefs)
-  where
-    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
-
-predefs :: Map.Map Ident Predefined
-predefs = Map.fromList predefList
-
-predefName pre = predefNames ! pre
-predefNames = array (minBound,maxBound) (map swap predefList)
-
-predefList =
-    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
-     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
-     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
-     (cLessInt,LessInt),
-     -- cShow, cRead, cMapStr, cEqVal
-     (cError,Error),(cTrace,Trace),
-     -- Canonical values:
-     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),(cFloat,Float),
-     (cInts,Ints),(cNonExist,NonExist)
-     ,(cBIND,BIND),(cSOFT_BIND,SOFT_BIND),(cSOFT_SPACE,SOFT_SPACE)
-     ,(cCAPIT,CAPIT),(cALL_CAPIT,ALL_CAPIT)]
-    --- add more functions!!!
-
-delta f vs =
-    case f of
-      Drop    -> fromNonExist vs NonExist (ap2 (drop::Int->String->String))
-      Take    -> fromNonExist vs NonExist (ap2 (take::Int->String->String))
-      Tk      -> fromNonExist vs NonExist (ap2 tk)
-      Dp      -> fromNonExist vs NonExist (ap2 dp)
-      EqStr   -> fromNonExist vs PFalse   (ap2 ((==)::String->String->Bool))
-      Occur   -> fromNonExist vs PFalse   (ap2 occur)
-      Occurs  -> fromNonExist vs PFalse   (ap2 occurs)
-      ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper))
-      ToLower -> fromNonExist vs NonExist (ap1 (map toLower))
-      IsUpper -> fromNonExist vs PFalse   (ap1 (all' isUpper))
-      Length  -> fromNonExist vs (0::Int) (ap1 (length::String->Int))
-      Plus    -> ap2 ((+)::Int->Int->Int)
-      EqInt   -> ap2 ((==)::Int->Int->Bool)
-      LessInt -> ap2 ((<)::Int->Int->Bool)
-    {- -- | Show | Read | ToStr | MapStr | EqVal -}
-      Error   -> ap1 VError
-      Trace   -> ap2 vtrace
-      -- Canonical values:
-      PBool   -> canonical
-      Int     -> canonical
-      Float   -> canonical
-      Ints    -> canonical
-      PFalse  -> canonical
-      PTrue   -> canonical
-      NonExist-> canonical
-      BIND    -> canonical
-      SOFT_BIND->canonical
-      SOFT_SPACE->canonical
-      CAPIT   -> canonical
-      ALL_CAPIT->canonical
-  where
-    canonical = delay
-    delay = return (VApp f vs) -- wrong number of arguments
-
-    ap1 f = case vs of
-              [v1] -> (toValue . f) `fmap` fromValue v1
-              _ -> delay
-
-    ap2 f = case vs of
-             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
-             _ -> delay
-
-    fromNonExist vs a b
-      | null [v | v@(VApp NonExist _) <- vs] = b
-      | otherwise                            = return (toValue a)
-
-    vtrace :: Value -> Value -> Value
-    vtrace x y = y -- tracing is implemented elsewhere
-
---  unimpl id = bug $ "unimplemented predefined function: "++showIdent id
---  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
-
-    tk i s = take (max 0 (length s - i)) s :: String
-    dp i s = drop (max 0 (length s - i)) s :: String
-    occur s t = isInfixOf (s::String) (t::String)
-    occurs s t = any (`elem` (t::String)) (s::String)
-    all' = all :: (a->Bool) -> [a] -> Bool
-
-boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
-
-norm v =
-  case v of
-    VC v1 v2 -> case apBoth norm (v1,v2) of
-                  (VString s1,VString s2) -> VString (s1++" "++s2)
-                  (v1,v2) -> VC v1 v2
-    _ -> v
-{-
-strict v = case v of
-             VError err -> Left err
-             _ -> Right v
--}
-string s = case words s of
-             [] -> VString ""
-             ss -> foldr1 VC (map VString ss)
-
----
-
-swap (x,y) = (y,x)
-{-
-bug msg = ppbug msg
-ppbug doc = error $ render $
-                    hang "Internal error in Compute.Predef:" 4 doc
--}

src/compiler/GF/Compile/Compute/Value.hs

@@ -1,56 +0,0 @@
-module GF.Compile.Compute.Value where
-import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
-import PGF2(BindType)
-import GF.Infra.Ident(Ident)
-import Text.Show.Functions()
-import Data.Ix(Ix)
-
--- | Self-contained (not quite) representation of values
-data Value
-  = VApp Predefined [Value] -- from Q, always Predef.x, has a built-in value
-  | VCApp QIdent [Value] -- from QC, constructors
-  | VGen Int [Value] -- for lambda bound variables, possibly applied
-  | VMeta MetaId Env [Value]
--- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
-  | VAbs BindType Ident Binding -- used in Compute.Concrete
-  | VProd BindType Value Ident Binding -- used in Compute.Concrete
-  | VInt Int
-  | VFloat Double
-  | VString String
-  | VSort Ident
-  | VImplArg Value
-  | VTblType Value Value
-  | VRecType [(Label,Value)]
-  | VRec [(Label,Value)]
-  | VV Type [Value] [Value] -- preserve type for conversion back to Term
-  | VT Wild Value [(Patt,Bind Env)]
-  | VC Value Value
-  | VS Value Value
-  | VP Value Label
-  | VPatt Patt
-  | VPattType Value
-  | VFV [Value]
-  | VAlts Value [(Value, Value)]
-  | VStrs [Value]
--- -- | VGlue Value Value -- hmm
--- --  | VExtR Value Value -- hmm
-  | VError String
-  deriving (Eq,Show)
-
-type Wild = Bool
-type Binding = Bind Value
-data Bind a = Bind (a->Value) deriving Show
-
-instance Eq (Bind a) where x==y = False
-
-type Env = [(Ident,Value)]
-
--- | Predefined functions
-data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
-                | ToLower | IsUpper | Length | Plus | EqInt | LessInt
-             {- | Show | Read | ToStr | MapStr | EqVal -}
-                | Error | Trace
-                -- Canonical values below:
-                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist
-                | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
-                deriving (Show,Eq,Ord,Ix,Bounded,Enum)

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,5 +1,7 @@
 -- | Translate concrete syntax to Haskell
 module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
+
+import PGF2(Literal(..))
 import Data.List(isPrefixOf,sort,sortOn)
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -16,13 +18,13 @@ import Debug.Trace(trace)
 
 -- | Generate Haskell code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
-concretes2haskell opts absname gr =
-  [(filename,render80 $ concrete2haskell opts abstr cncmod)
-     | let Grammar abstr cncs = grammar2canonical opts absname gr,
-       cncmod<-cncs,
-       let ModId name = concName cncmod
-           filename = showRawIdent name ++ ".hs" :: FilePath
-  ]
+concretes2haskell opts absname gr = do
+  Grammar abstr cncs <- grammar2canonical opts absname gr
+  return [(filename,render80 $ concrete2haskell opts abstr cncmod)
+             | cncmod<-cncs,
+               let ModId name = concName cncmod
+                   filename = showRawIdent name ++ ".hs" :: FilePath
+         ]
 
 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are
@@ -181,9 +183,9 @@ concrete2haskell opts
 
         ppL l =
           case l of
-            FloatConstant x -> pure (lit x)
-            IntConstant n -> pure (lit n)
-            StrConstant s -> pure (token s)
+            LFlt x -> pure (lit x)
+            LInt n -> pure (lit n)
+            LStr s -> pure (token s)
 
         pId p@(ParamId s) =
           if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack

src/compiler/GF/Compile/GenerateBC.hs

@@ -4,7 +4,8 @@ module GF.Compile.GenerateBC(generateByteCode) where
 import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
-import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
+import PGF2(Literal(..))
+import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
 import qualified Data.Map as Map
 import Data.List(nub,mapAccumL)
 import Data.Maybe(fromMaybe)

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -10,633 +10,173 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.GeneratePMCFG
-    (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+    (generatePMCFG, pgfCncCat, addPMCFG
     ) where
 
-import qualified PGF2 as PGF2
-import qualified PGF2.Internal as PGF2
-import PGF2.Internal(Symbol(..),fidVar)
-
-import GF.Infra.Option
-import GF.Grammar hiding (Env, mkRecord, mkTable)
-import GF.Grammar.Lookup
+import GF.Grammar hiding (VApp)
 import GF.Grammar.Predef
-import GF.Grammar.Lockfield (isLockLabel)
-import GF.Data.BacktrackM
-import GF.Data.Operations
-import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
-import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
---import qualified Data.IntMap as IntMap
-import qualified Data.IntSet as IntSet
+import GF.Grammar.Lookup
+import GF.Infra.CheckM
+import GF.Infra.Option
 import GF.Text.Pretty
-import Data.Array.IArray
-import Data.Array.Unboxed
---import Data.Maybe
---import Data.Char (isDigit)
-import Control.Applicative(Applicative(..))
+import GF.Compile.Compute.Concrete
+import GF.Data.Operations(Err(..))
+import PGF2.Transactions
+import qualified Data.Map.Strict as Map
 import Control.Monad
-import Control.Monad.Identity
---import Control.Exception
---import Debug.Trace(trace)
-import qualified Control.Monad.Fail as Fail
+import Data.List(mapAccumL)
 
-----------------------------------------------------------------------
--- main conversion function
+generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+generatePMCFG opts cwd gr cmo@(cm,cmi) = do
+  let gr' = prependModule gr cmo
+  js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi))
+  return (cm,cmi{jments = (Map.fromAscList js)})
 
---generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
-generatePMCFG opts sgr opath cmo@(cm,cmi) = do
-  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
-  when (verbAtLeast opts Verbose) $ ePutStrLn ""
-  return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
+addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
+  checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do
+    rules <- pmcfgForm gr term ctxt val
+    return (id,CncFun mty mlin mprn (Just rules))
+addPMCFG opts cwd gr cmi id_info = return id_info
+
+pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [PMCFGRule]
+pmcfgForm gr t ctxt ty =
+  runEvalM gr $ do
+    ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
+                                   let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
+                                   tnk <- newThunk [] t
+                                   return ((d+1,ms'),tnk))
+                               (0,Map.empty) ctxt
+    sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
+    v <- eval [] t args
+    (lins,params) <- flatten v ty ([],[])
+    lins <- mapM str2lin lins
+    (r,rs,_) <- compute params
+    args <- zipWithM tnk2pmcfgcat args ctxt
+    return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
+    where
+      tnk2pmcfgcat tnk (_,_,ty) = do
+        v <- force tnk []
+        (_,params) <- flatten v ty ([],[])
+        (r,rs,_) <- compute params
+        return (PMCFGCat r rs)
+
+      compute []     = return (0,[],1)
+      compute (v:vs) = do
+        (r, rs ,cnt ) <- param2int v
+        (r',rs',cnt') <- compute vs
+        return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+
+type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
+type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+  (ms,r+1,TSymCat d r rs)
+type2metaTerm gr d ms r rs (RecType lbls) =
+  let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
+                                                      in ((ms',r'),(lbl,(Just ty,t))))
+                                 (ms,r) lbls
+  in (ms',r',R ass)  
+type2metaTerm gr d ms r rs (Table p q) =
+  let pv = identS ('p':show (length rs))
+      (ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q
+      count = case allParamValues gr p of
+                Ok ts   -> length ts
+                Bad msg -> error msg
+  in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)])
+type2metaTerm gr d ms r rs ty@(QC q) =
+  let i = Map.size ms + 1
+  in (Map.insert i ty ms,r,Meta i)
+
+
+flatten (VSusp tnk env vs k) ty st = do
+  tnk_st <- getMeta tnk
+  case tnk_st of
+    Evaluated v             -> do v <- apply v vs
+                                  flatten v ty st
+    Unbound (Just (QC q)) _ -> do (m,ResParam (Just (L _ ps)) _) <- getInfo q
+                                  msum [bind tnk m p | p <- ps]
+                                  v <- k tnk
+                                  flatten v ty st
   where
-    cenv = resourceValues opts gr
-    gr = prependModule sgr cmo
-    MTConcrete am = mtype cmi
-
-mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
-                                     -> Map.Map k b -> m (a,Map.Map k c)
-mapAccumWithKeyM f a m = do let xs = Map.toAscList m
-                            (a,ys) <- mapAccumM f a xs
-                            return (a,Map.fromAscList ys)
+    bind tnk m (p, ctxt) = do
+      tnks <- mapM (\(_,_,ty) -> newMeta (Just ty) 0) ctxt
+      setMeta tnk (Evaluated (VApp (m,p) tnks))
+flatten (VR as) (RecType lbls) st = do
+  foldM collect st lbls
   where
-    mapAccumM f a []          = return (a,[])
-    mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
-                                   (a,kys) <- mapAccumM f a kxs
-                                   return (a,(k,y):kys)
-
-
---addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
---when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
-  let pres  = protoFCat gr res val
-      pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
-
-      pmcfgEnv0   = emptyPMCFGEnv
-  b             <- convert opts gr cenv (floc opath loc id) term (cont,val) pargs
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addRule
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pres,pargs)
-      pmcfg      = getPMCFG pmcfgEnv1
-
-      stats      = let PMCFG prods funs = pmcfg
-                       (s,e)            = bounds funs
-                       !prods_cnt       = length prods
-                       !funs_cnt        = e-s+1
-                   in (prods_cnt,funs_cnt)
-
-  when (verbAtLeast opts Verbose) $
-    ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
-  seqs1 `seq` stats `seq` return ()
-  when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,CncFun mty mlin mprn (Just pmcfg))
+    collect st (lbl,ty) =
+      case lookup lbl as of
+        Just tnk -> do v <- force tnk []
+                       flatten v ty st
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+flatten v@(VT _ env cs) (Table p q) st = do
+  ts <- getAllParamValues p
+  foldM collect st ts
   where
-    (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
-
-    addRule lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-          newArgs  = map getFIds newArgs'
-      in addFunction env0 newCat fun newArgs
-
-addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) 
-                                                  mdef@(Just (L loc1 def))
-                                                  mref@(Just (L loc2 ref))
-                                                  mprn
-                                                  Nothing) = do
-  let pcat = protoFCat gr (am,id) lincat
-      pvar = protoFCat gr (MN identW,cVar) typeStr
-
-      pmcfgEnv0  = emptyPMCFGEnv
-
-  let lincont    = [(Explicit, varStr, typeStr)]
-  b             <- convert opts gr cenv (floc opath loc1 id) def (lincont,lincat) [pvar]
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addLindef
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pcat,[pvar])
-
-  let lincont    = [(Explicit, varStr, lincat)]
-  b             <- convert opts gr cenv (floc opath loc2 id) ref (lincont,typeStr) [pcat]
-  let (seqs2,b2) = addSequencesB seqs1 b
-      pmcfgEnv2  = foldBM addLinref
-                          pmcfgEnv1
-                          (goB b2 CNil [])
-                          (pvar,[pcat])
-
-  let pmcfg     = getPMCFG pmcfgEnv2
-
-  when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
+    collect st t = do
+      tnk <- newThunk [] t
+      let v0 = VS v tnk []
+      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
+      flatten v q st
+flatten (VV _ tnks) (Table _ q) st = do
+  foldM collect st tnks
   where
-    addLindef lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-      in addFunction env0 newCat fun [[fidVar]]
+    collect st tnk = do
+      v <- force tnk []
+      flatten v q st
+flatten v (Sort s) (lins,params) | s == cStr = do
+  return (v:lins,params)
+flatten v (QC q) (lins,params) = do
+  return (lins,v:params)
 
-    addLinref lins (newCat', [newArg']) env0 =
-      let newArg   = getFIds newArg'
-          !fun     = mkArray lins
-      in addFunction env0 fidVar fun [newArg]
-
-addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
-
-floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
-
-convert opts gr cenv loc term ty@(_,val) pargs =
-  case normalForm cenv loc (etaExpand ty term) of
-    Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
-    term    -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])
+str2lin (VStr s)         = return [SymKS s]
+str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
+                              return [SymCat d r rs]
   where
-    etaExpand (context,val) = mkAbs pars . flip mkApp args
-      where pars = [(Explicit,v) | v <- vars]
-            args = map Vr vars
-            vars = map (\(bt,x,t) -> x) context
+    compute r' []                = return (r',[])
+    compute r' ((cnt',tnk):tnks) = do
+      (r, rs,_) <- force tnk [] >>= param2int
+      (r',rs' ) <- compute r' tnks
+      return (r*cnt'+r',combine cnt' rs rs')
+str2lin (VC vs)          = fmap concat (mapM str2lin vs)
+str2lin v                = do t <- value2term 0 v
+                              evalError ("the term" <+> ppTerm Unqualified 0 t $$
+                                         "cannot be evaluated at compile time.")
 
-pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
-pgfCncCat gr id lincat index =
-  let ((_,size),schema) = computeCatRange gr lincat
-  in ( id
-     , index
-     , index+size-1
-     , map (renderStyle style{mode=OneLineMode} . ppPath)
-           (getStrPaths schema)
-     )
+param2int (VApp q tnks) = do
+  (r ,    cnt ) <- getIdxCnt q
+  (r',rs',cnt') <- compute tnks
+  return (r*cnt' + r',rs',cnt*cnt')
   where
-    getStrPaths :: Schema Identity s c -> [Path]
-    getStrPaths = collect CNil []
-      where
-        collect path paths (CRec rs)   = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
-        collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel  trm path) paths t) paths cs
-        collect path paths (CStr _)    = reversePath path : paths
-        collect path paths (CPar _)    = paths
+    getIdxCnt q = do
+      (_,ResValue (L _ ty) idx) <- getInfo q
+      let QC p = valTypeCnc ty
+      (_,ResParam _ (Just (_,cnt))) <- getInfo p
+      return (idx,cnt)
 
-----------------------------------------------------------------------
--- CnvMonad monad
---
--- The branching monad provides backtracking together with
--- recording of the choices made. We have two cases
--- when we have alternative choices:
---
---      * when we have parameter type, then
---        we have to try all possible values
---      * when we have variants we have to try all alternatives
---
--- The conversion monad keeps track of the choices and they are
--- returned as 'Branch' data type.
+    compute []         = return (0,[],1)
+    compute (tnk:tnks) = do
+      (r, rs ,cnt ) <- force tnk [] >>= param2int
+      (r',rs',cnt') <- compute tnks
+      return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+param2int (VMeta tnk _ _) = do
+  tnk_st <- getMeta tnk
+  case tnk_st of
+    Evaluated v         -> param2int v
+    Unbound (Just ty) j -> do let QC q = valTypeCnc ty
+                              (_,ResParam _ (Just (_,cnt))) <- getInfo q
+                              return (0,[(1,j)],cnt)
 
-data Branch a
-  = Case Int Path [(Term,Branch a)]
-  | Variant [Branch a]
-  | Return  a
+combine cnt'          []            rs' = rs'
+combine cnt'         rs              [] = [(r*cnt',pv) | (r,pv) <- rs]
+combine cnt' ((r,pv):rs) ((r',pv'):rs') =
+  case compare pv pv' of
+    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
+    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
+    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
 
-newtype CnvMonad a = CM {unCM :: SourceGrammar
-                              -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
-                              -> ([ProtoFCat],[Symbol])
-                              -> Branch b}
+mapAccumM f a []     = return (a,[])
+mapAccumM f a (x:xs) = do (a, y) <- f a x
+                          (a,ys) <- mapAccumM f a xs
+                          return (a,y:ys)
 
-instance Fail.MonadFail CnvMonad where
-  fail = bug
-
-instance Applicative CnvMonad where
-  pure = return
-  (<*>) = ap
-
-instance Monad CnvMonad where
-    return a   = CM (\gr c s -> c a s)
-    CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s)
-
-instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
-    get = CM (\gr c s -> c s s)
-    put s = CM (\gr c _ -> c () s)
-
-instance Functor CnvMonad where
-    fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
-
-runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
-runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
-
--- | backtracking for all variants
-variants :: [a] -> CnvMonad a
-variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
-
--- | backtracking for all parameter values that a variable could take
-choices :: Int -> Path -> CnvMonad Term
-choices nr path = do (args,_) <- get
-                     let PFCat _ _ schema = args !! nr
-                     descend schema path CNil
-  where
-    descend (CRec rs)     (CProj lbl path) rpath = case lookup lbl rs of
-                                                     Just (Identity t) -> descend t path (CProj lbl rpath)
-    descend (CRec rs)     CNil             rpath = do rs <- mapM (\(lbl,Identity t) -> fmap (assign lbl) (descend t CNil (CProj lbl rpath))) rs
-                                                      return (R rs)
-    descend (CTbl pt cs)  (CSel  trm path) rpath = case lookup trm cs of
-                                                     Just (Identity t) -> descend t path (CSel trm rpath)
-    descend (CTbl pt cs)  CNil             rpath = do cs <- mapM (\(trm,Identity t) -> descend t CNil (CSel trm rpath)) cs
-                                                      return (V pt cs)
-    descend (CPar (m,vs)) CNil             rpath = case vs of
-                                                     [(value,index)] -> return value
-                                                     values          -> let path = reversePath rpath
-                                                                        in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
-                                                                                                                    | (value,index) <- values])
-    descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
-
-    updateEnv path value gr c (args,seq) =
-      case updateNthM (restrictProtoFCat path value) nr args of
-        Just args -> c value (args,seq)
-        Nothing   -> bug "conflict in updateEnv"
-
--- | the argument should be a parameter type and then
--- the function returns all possible values.
-getAllParamValues :: Type -> CnvMonad [Term]
-getAllParamValues ty = CM (\gr c -> c (err bug id (allParamValues gr ty)))
-
-mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs [])
-
-mkTable  :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkTable pt xs = CM (\gr c -> foldl (\c (trm,CM m) bs s -> c ((trm,m gr (\v s -> Return v) s) : bs) s) (c . CTbl pt) xs [])
-
-----------------------------------------------------------------------
--- Term Schema
---
--- The term schema is a term-like structure, with records, tables,
--- strings and parameters values, but in addition we could add
--- annotations of arbitrary types
-
--- | Term schema
-data Schema b s c
-  = CRec      [(Label,b (Schema b s c))]
-  | CTbl Type [(Term, b (Schema b s c))]
-  | CStr s
-  | CPar c
---deriving Show -- doesn't work
-
-instance Show s => Show (Schema b s c) where
-  showsPrec _ sch =
-      case sch of
-        CRec r   -> showString "CRec " . shows (map fst r)
-        CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _"
-        CStr s   -> showString "CStr " . showsPrec 10 s
-        CPar c   -> showString "CPar{}"
-
--- | Path into a term or term schema
-data Path
-  = CProj Label Path
-  | CSel  Term  Path
-  | CNil
-  deriving (Eq,Show)
-
--- | The ProtoFCat represents a linearization type as term schema.
--- The annotations are as follows: the strings are annotated with
--- their index in the PMCFG tuple, the parameters are annotated
--- with their value both as term and as index.
-data ProtoFCat  = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
-type Env        = (ProtoFCat, [ProtoFCat])
-
-protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
-protoFCat gr cat lincat =
-  case computeCatRange gr lincat of
-    ((_,f),schema) -> PFCat (snd cat) f schema
-
-getFIds :: ProtoFCat -> [FId]
-getFIds (PFCat _ _ schema) =
-  reverse (solutions (variants schema) ())
-  where
-    variants (CRec rs)         = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
-    variants (CTbl _ cs)       = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
-    variants (CStr _)          = return 0
-    variants (CPar (m,values)) = do (value,index) <- member values
-                                    return (m*index)
-
-catFactor :: ProtoFCat -> Int
-catFactor (PFCat _ f _) = f
-
-computeCatRange gr lincat = compute (0,1) lincat
-  where
-    compute st (RecType  rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> case lbl of
-                                                                                LVar _ -> let (st',t') = compute st t
-                                                                                          in (st ,(lbl,Identity t'))
-                                                                                _      -> let (st',t') = compute st t
-                                                                                          in (st',(lbl,Identity t'))) st rs
-                               in (st',CRec rs')
-    compute st (Table pt vt) = let vs        = err bug id (allParamValues gr pt)
-                                   (st',cs') = List.mapAccumL (\st v       -> let (st',vt') = compute st vt
-                                                                              in (st',(v,Identity vt'))) st vs
-                               in (st',CTbl pt cs')
-    compute st (Sort s)
-                   | s == cStr = let (index,m) = st
-                                 in ((index+1,m),CStr index)
-    compute st t               = let vs = err bug id (allParamValues gr t)
-                                     (index,m) = st
-                                 in ((index,m*length vs),CPar (m,zip vs [0..]))
-
-ppPath (CProj lbl path) = lbl <+> ppPath path
-ppPath (CSel  trm path) = ppU 5 trm   <+> ppPath path
-ppPath CNil             = empty
-
-reversePath path = rev CNil path
-  where
-    rev path0 CNil             = path0
-    rev path0 (CProj lbl path) = rev (CProj lbl path0) path
-    rev path0 (CSel  trm path) = rev (CSel  trm path0) path
-
-
-----------------------------------------------------------------------
--- term conversion
-
-type Value a = Schema Branch a Term
-
-convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
-convertTerm opts sel ctype (Vr x)       = convertArg opts ctype (getVarIndex x) (reversePath sel)
-convertTerm opts sel ctype (Abs _ _ t)  = convertTerm opts sel ctype t                -- there are only top-level abstractions and we ignore them !!!
-convertTerm opts sel ctype (R record)   = convertRec opts sel ctype record
-convertTerm opts sel ctype (P term l)   = convertTerm opts (CProj l sel) ctype term
-convertTerm opts sel ctype (V pt ts)    = convertTbl opts sel ctype pt ts
-convertTerm opts sel ctype (S term p)   = do v <- evalTerm CNil p
-                                             convertTerm opts (CSel v sel) ctype term
-convertTerm opts sel ctype (FV vars)    = do term <- variants vars
-                                             convertTerm opts sel ctype term
-convertTerm opts sel ctype (C t1 t2)    = do v1 <- convertTerm opts sel ctype t1
-                                             v2 <- convertTerm opts sel ctype t2
-                                             return (CStr (concat [s | CStr s <- [v1,v2]]))
-convertTerm opts sel ctype (K t)        = return (CStr [SymKS t])
-convertTerm opts sel ctype Empty        = return (CStr [])
-convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil ctype s
-                                             alts <- forM alts $ \(u,alt) -> do
-                                                            CStr u <- convertTerm opts CNil ctype u
-                                                            Strs ps <- unPatt alt
-                                                            ps     <- mapM (convertTerm opts CNil ctype) ps
-                                                            return (u,map unSym ps)
-                                             return (CStr [SymKP s alts])
-  where
-    unSym (CStr [])        = ""
-    unSym (CStr [SymKS t]) = t
-    unSym _                = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts)
-
-    unPatt (EPatt p) = fmap Strs (getPatts p)
-    unPatt u         = return u
-
-    getPatts p = case p of
-      PAlt a b  -> liftM2 (++) (getPatts a) (getPatts b)
-      PString s -> return [K s]
-      PSeq a b  -> do
-        as <- getPatts a
-        bs <- getPatts b
-        return [K (s ++ t) | K s <- as, K t <- bs]
-      _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
-
-convertTerm opts sel ctype (Q (m,f))
-  | m == cPredef &&
-    f == cBIND                          = return (CStr [SymBIND])
-  | m == cPredef &&
-    f == cSOFT_BIND                     = return (CStr [SymSOFT_BIND])
-  | m == cPredef &&
-    f == cSOFT_SPACE                    = return (CStr [SymSOFT_SPACE])
-  | m == cPredef &&
-    f == cCAPIT                         = return (CStr [SymCAPIT])
-  | m == cPredef &&
-    f == cALL_CAPIT                     = return (CStr [SymALL_CAPIT])
-  | m == cPredef &&
-    f == cNonExist                      = return (CStr [SymNE])
-{-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2))
-                    | l `elem` map fst rs2 = convertTerm opts sel ctype t2
-                    | otherwise            = convertTerm opts sel ctype t1
-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
-                    | l `elem` map fst rs1 = convertTerm opts sel ctype t1
-                    | otherwise            = convertTerm opts sel ctype t2
--}
-convertTerm opts CNil ctype t           = do v <- evalTerm CNil t
-                                             return (CPar v)
-convertTerm _    sel  _     t           = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t])
-
-convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
-convertArg opts (RecType rs)  nr path =
-  mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs)
-convertArg opts (Table pt vt) nr path = do
-  vs <- getAllParamValues pt
-  mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
-convertArg opts (Sort _)      nr path = do
-  (args,_) <- get
-  let PFCat cat _ schema = args !! nr
-      l = index (reversePath path) schema
-      sym | CProj (LVar i) CNil <- path = SymVar nr i
-          | isLiteralCat opts cat       = SymLit nr l
-          | otherwise                   = SymCat nr l
-  return (CStr [sym])
-  where
-    index (CProj lbl path) (CRec   rs) = case lookup lbl rs of
-                                           Just (Identity t) -> index path t
-    index (CSel  trm path) (CTbl _ rs) = case lookup trm rs of
-                                           Just (Identity t) -> index path t
-    index CNil             (CStr idx)  = idx
-convertArg opts ty nr path              = do
-  value <- choices nr (reversePath path)
-  return (CPar value)
-
-convertRec opts CNil (RecType rs) record =
-    mkRecord [(lbl,convertTerm opts CNil ctype (proj lbl))|(lbl,ctype)<-rs]
-  where proj lbl = if isLockLabel lbl then R [] else projectRec lbl record
-convertRec opts (CProj lbl path) ctype record =
-  convertTerm opts path ctype (projectRec lbl record)
-convertRec opts _ ctype _ = bug ("convertRec: "++show ctype)
-
-convertTbl opts CNil (Table _ vt) pt ts = do
-  vs <- getAllParamValues pt
-  mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts)
-convertTbl opts (CSel v sub_sel) ctype pt ts = do
-  vs <- getAllParamValues pt
-  case lookup v (zip vs ts) of
-    Just t  -> convertTerm opts sub_sel ctype t
-    Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$
-                                          "among" <+> vcat vs))
-convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
-
-
-goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goB (Case nr path bs) rpath ss = do (value,b) <- member bs
-                                    restrictArg nr path value
-                                    goB b rpath ss
-goB (Variant bs)      rpath ss = do b <- member bs
-                                    goB b rpath ss
-goB (Return  v)       rpath ss = goV v rpath ss
-
-goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goV (CRec xs)    rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs)
-goV (CTbl _ xs)  rpath ss = foldM (\ss (trm,b) -> goB b (CSel  trm rpath) ss) ss (reverse xs)
-goV (CStr seqid) rpath ss = return (seqid : ss)
-goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
-
-
-----------------------------------------------------------------------
--- SeqSet
-
-type SeqSet   = Map.Map [Symbol] SeqId
-
-addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
-addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                       in (seqs',(trm,b'))) seqs bs
-                                       in (seqs1,Case nr path bs1)
-addSequencesB seqs (Variant bs)      = let !(seqs1,bs1) = mapAccumL' addSequencesB seqs bs
-                                       in (seqs1,Variant bs1)
-addSequencesB seqs (Return  v)       = let !(seqs1,v1) = addSequencesV seqs v
-                                       in (seqs1,Return v1)
-
-addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
-addSequencesV seqs (CRec vs)  = let !(seqs1,vs1) = mapAccumL' (\seqs (lbl,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(lbl,b'))) seqs vs
-                                in (seqs1,CRec vs1)
-addSequencesV seqs (CTbl pt vs)=let !(seqs1,vs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(trm,b'))) seqs vs
-                                in (seqs1,CTbl pt vs1)
-addSequencesV seqs (CStr lin) = let !(seqs1,seqid) = addSequence seqs lin
-                                in (seqs1,CStr seqid)
-addSequencesV seqs (CPar i)   = (seqs,CPar i)
-
--- a strict version of Data.List.mapAccumL
-mapAccumL' f s []     = (s,[])
-mapAccumL' f s (x:xs) = (s'',y:ys)
-                        where !(s', y ) = f s x
-                              !(s'',ys) = mapAccumL' f s' xs
-
-addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs seq =
-  case Map.lookup seq seqs of
-    Just id -> (seqs,id)
-    Nothing -> let !last_seq = Map.size seqs
-               in (Map.insert seq last_seq seqs, last_seq)
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: Path -> Term -> CnvMonad Term
-evalTerm CNil (QC f)       = return (QC f)
-evalTerm CNil (App x y)    = do x <- evalTerm CNil x
-                                y <- evalTerm CNil y
-                                return (App x y)
-evalTerm path (Vr x)       = choices (getVarIndex x) path
-evalTerm path (R rs)       =
-    case path of
-      CProj lbl path -> evalTerm path (projectRec lbl rs)
-      CNil           -> R `fmap` mapM (\(lbl,(_,t)) -> assign lbl `fmap` evalTerm path t) rs
-evalTerm path (P term lbl) = evalTerm (CProj lbl path) term
-evalTerm path (V pt ts)    =
-   case path of
-     CNil          -> V pt `fmap` mapM (evalTerm path) ts
-     CSel trm path ->
-         do vs <- getAllParamValues pt
-            case lookup trm (zip vs ts) of
-              Just t  -> evalTerm path t
-              Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
-                                 $$ "among:" <+>fsep (map (ppU 10) vs)
-evalTerm path (S term sel) = do v <- evalTerm CNil sel
-                                evalTerm (CSel v path) term
-evalTerm path (FV terms)   = variants terms >>= evalTerm path
-evalTerm path (EInt n)     = return (EInt n)
-evalTerm path t            = ppbug ("evalTerm" <+> parens t)
---evalTerm path t            = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
-
-getVarIndex x = maybe err id $ getArgIndex x
-  where err = bug ("getVarIndex "++show x)
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
-type ProdSet  = Set.Set Production
-type FunSet   = Map.Map (UArray LIndex SeqId) FunId
-
-emptyPMCFGEnv =
-  PMCFGEnv Set.empty Map.empty
-
-addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
-addFunction (PMCFGEnv prodSet funSet) !fid fun args =
-  case Map.lookup fun funSet of
-    Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                            funSet
-    Nothing     -> let !funid = Map.size funSet
-                   in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                               (Map.insert fun funid funSet)
-
-getPMCFG :: PMCFGEnv -> PMCFG
-getPMCFG (PMCFGEnv prodSet funSet) =
-  PMCFG (optimize prodSet) (mkSetArray funSet)
-  where
-    optimize ps = Map.foldrWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
-      where
-        ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
-        ff (fid,funid) xs prods
-          | product (map IntSet.size ys) == count
-                      = (Production fid funid (map IntSet.toList ys)) : prods
-          | otherwise = map (Production fid funid) xs ++ prods
-          where
-            count = sum (map (product . map length) xs)
-            ys    = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
-
-------------------------------------------------------------
--- updating the MCF rule
-
-restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
-restrictArg nr path index = do
-  (head, args) <- get
-  args <- updateNthM (restrictProtoFCat path index) nr args
-  put (head, args)
-
-restrictHead :: Path -> Term -> BacktrackM Env ()
-restrictHead path term = do
-  (head, args) <- get
-  head <- restrictProtoFCat path term head
-  put (head, args)
-
-restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
-restrictProtoFCat path v (PFCat cat f schema) = do
-  schema <- addConstraint path v schema
-  return (PFCat cat f schema)
-  where
-    addConstraint (CProj lbl path) v (CRec rs)     = fmap CRec      $ update lbl (addConstraint path v) rs
-    addConstraint (CSel  trm path) v (CTbl pt cs)  = fmap (CTbl pt) $ update trm (addConstraint path v) cs
-    addConstraint CNil             v (CPar (m,vs)) = case lookup v vs of
-                                                       Just index -> return (CPar (m,[(v,index)]))
-                                                       Nothing    -> mzero
-    addConstraint CNil             v (CStr _)      = bug "restrictProtoFCat: string path"
-
-    update k0 f [] = return []
-    update k0 f (x@(k,Identity v):xs)
-      | k0 == k    = do v <- f v
-                        return ((k,Identity v):xs)
-      | otherwise  = do xs <- update k0 f xs
-                        return (x:xs)
-
-mkArray    lst = listArray (0,length lst-1) lst
-mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
-bug msg = ppbug msg
-ppbug msg = error completeMsg
- where
-  originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
-  completeMsg =
-    case render msg of -- the error message for pattern matching a runtime string
-      "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
-        -> unlines [originalMsg -- add more helpful output
-            ,""
-            ,"1) Check that you are not trying to pattern match a /runtime string/."
-            ,"   These are illegal:"
-            ,"     lin Test foo = case foo.s of {"
-            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
-            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
-            ,""
-            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
-            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
-            ]
-      _ -> originalMsg -- any other message: just print it as is
-
-ppU = ppTerm Unqualified
+pgfCncCat = error "TODO: pgfCncCat"

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -15,12 +15,12 @@ import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
 import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
-import GF.Compile.Compute.Predef(predef)
-import GF.Compile.Compute.Value(Predefined(..))
+-- import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
-import PGF2.Internal(Literal(..))
-import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
+import GF.Infra.CheckM
+import PGF2(Literal(..))
+import GF.Compile.Compute.Concrete(normalForm)
 import GF.Grammar.Canonical as C
 import System.FilePath ((</>), (<.>))
 import qualified Debug.Trace as T
@@ -28,15 +28,16 @@ import qualified Debug.Trace as T
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
-grammar2canonical opts absname gr =
-   Grammar (abstract2canonical absname gr)
-           (map snd (concretes2canonical opts absname gr))
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
+grammar2canonical opts absname gr = do
+  abs <- abstract2canonical absname gr
+  cncs <- concretes2canonical opts absname gr
+  return (Grammar abs (map snd cncs))
 
 -- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Abstract
+abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
 abstract2canonical absname gr =
-    Abstract (modId absname) (convFlags gr absname) cats funs
+  return (Abstract (modId absname) (convFlags gr absname) cats funs)
   where
     cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
 
@@ -49,7 +50,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
-        tf -> error $ "abstract2canonical convHypo: " ++ show tf
+        tf -> error ("abstract2canonical convHypo: " ++ show tf)
 
     convType t =
       case typeForm t of
@@ -62,27 +63,24 @@ abstract2canonical absname gr =
 
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
-concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
-  [(cncname,concrete2canonical gr cenv absname cnc cncmod)
-     | let cenv = resourceValues opts gr,
-       cnc<-allConcretes gr absname,
-       let cncname = "canonical" </> render cnc <.> "gf"
-           Ok cncmod = lookupModule gr cnc
-  ]
+  sequence
+    [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
+        | cnc<-allConcretes gr absname,
+          let cncname = "canonical" </> render cnc <.> "gf"
+              Ok cncmod = lookupModule gr cnc
+        ]
 
 -- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
-concrete2canonical gr cenv absname cnc modinfo =
-  Concrete (modId cnc) (modId absname) (convFlags gr cnc)
-      (neededParamTypes S.empty (params defs))
-      [lincat | (_,Left lincat) <- defs]
-      [lin | (_,Right lin) <- defs]
+concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
+concrete2canonical gr absname cnc modinfo = do
+  defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
+  return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+                   (neededParamTypes S.empty (params defs))
+                   [lincat | (_,Left lincat) <- defs]
+                   [lin | (_,Right lin) <- defs])
   where
-    defs = concatMap (toCanonical gr absname cenv) .
-           M.toList $
-           jments modinfo
-
     params = S.toList . S.unions . map fst
 
     neededParamTypes have [] = []
@@ -92,32 +90,25 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
--- toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
-toCanonical gr absname cenv (name,jment) =
+-- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
+toCanonical gr absname (name,jment) =
   case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ ->
-        [(pts,Left (LincatDef (gId name) (convType ntyp)))]
-      where
-        pts = paramTypes gr ntyp
-        ntyp = nf loc typ
-    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
-        [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
-      where
-        tts = tableTypes gr [e']
-
-        e' = cleanupRecordFields lincat $
-             unAbs (length params) $
-             nf loc (mkAbs params (mkApp def (map Vr args)))
-        params = [(b,x)|(b,x,_)<-ctx]
-        args = map snd params
-
+    CncCat (Just (L loc typ)) _ _ pprn _ -> do
+      ntyp <- normalForm gr typ
+      let pts = paramTypes gr ntyp
+      return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+    CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
+      let params = [(b,x)|(b,x,_)<-ctx]
+          args   = map snd params
+      e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args)))
+      let e   = cleanupRecordFields lincat (unAbs (length params) e0)
+          tts = tableTypes gr [e]
+      return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
     AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
-                     _ -> []
-    _ -> []
+                     Ok (m,jment) -> toCanonical gr absname (name,jment)
+                     _ -> return []
+    _ -> return []
   where
-    nf loc = normalForm cenv (L loc name)
-
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
@@ -193,18 +184,18 @@ convert' gr vs = ppT
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
-        EInt n -> LiteralValue (IntConstant n)
+        EInt n -> LiteralValue (LInt n)
         Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
         QC (m,n) -> ParamConstant (Param (gQId m n) [])
-        K s -> LiteralValue (StrConstant s)
-        Empty -> LiteralValue (StrConstant "")
+        K s -> LiteralValue (LStr s)
+        Empty -> LiteralValue (LStr "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
         _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
-    ppPredef n =
+    ppPredef n = error "TODO: ppPredef" {-
       case predef n of
         Ok BIND       -> p "BIND"
         Ok SOFT_BIND  -> p "SOFT_BIND"
@@ -214,7 +205,7 @@ convert' gr vs = ppT
         _ -> VarValue (gQId cPredef n) -- hmm
       where
        p = PredefValue . PredefId . rawIdentS
-
+-}
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
@@ -243,12 +234,12 @@ convert' gr vs = ppT
         pre (K s) = [s]
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
-        pre (EPatt p) = pat p
+        pre (EPatt _ _ p) = pat p
         pre t = error $ "convert' alts pre: " ++ show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
-        pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
+        pat (PSeq _ _ p1 _ _ p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
         pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
@@ -265,8 +256,8 @@ convert' gr vs = ppT
 concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
-    (LiteralValue (StrConstant ""),_) -> v2
-    (_,LiteralValue (StrConstant "")) -> v1
+    (LiteralValue (LStr ""),_) -> v2
+    (_,LiteralValue (LStr "")) -> v1
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
@@ -429,11 +420,5 @@ unqual n = Unqual (ident2raw n)
 
 convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
-  Flags [(rawIdentS n,convLit v) |
+  Flags [(rawIdentS n,v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
-  where
-    convLit l =
-      case l of
-        LStr s -> Str s
-        LInt i -> C.Int i
-        LFlt d -> Flt d

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, MagicHash #-}
 module GF.Compile.GrammarToPGF (grammar2PGF) where
 
 import GF.Compile.GeneratePMCFG
@@ -6,7 +6,7 @@ import GF.Compile.GenerateBC
 import GF.Compile.OptimizePGF
 
 import PGF2 hiding (mkType)
-import PGF2.Internal
+import PGF2.Transactions
 import GF.Grammar.Predef
 import GF.Grammar.Grammar hiding (Production)
 import qualified GF.Grammar.Lookup as Look
@@ -25,12 +25,16 @@ import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
 import Data.Maybe(fromMaybe)
+import System.FilePath
+import System.Directory
 
 import GHC.Prim
 import GHC.Base(getTag)
 
 grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
 grammar2PGF opts gr am probs = do
+  gr <- mkAbstr am probs
+  return gr {-do
   cnc_infos <- getConcreteInfos gr am
   return $
     build (let gflags   = if flag optSplitPGF opts 
@@ -38,13 +42,30 @@ grammar2PGF opts gr am probs = do
                             else []
                (an,abs) = mkAbstr am probs
                cncs     = map (mkConcr opts abs) cnc_infos
-           in newPGF gflags an abs cncs)
+           in newPGF gflags an abs cncs)-}
   where
-    cenv = resourceValues opts gr
     aflags = err (const noOptions) mflags (lookupModule gr am)
 
-    mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
-    mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
+    mkAbstr :: ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
+    mkAbstr am probs = do
+      let abs_name = mi2i am
+      mb_ngf_path <-
+         if snd (flag optLinkTargets opts)
+           then do let fname = maybe id (</>)
+                                     (flag optOutputDir opts)
+                                     (fromMaybe abs_name (flag optName opts)<.>"ngf")
+                   exists <- doesFileExist fname
+                   if exists
+                     then removeFile fname
+                     else return ()
+                   putStr ("(Boot image "++fname++") ")
+                   return (Just fname)
+           else do return Nothing
+      gr <- newNGF abs_name mb_ngf_path
+      modifyPGF gr $ do
+        sequence_ [setAbstractFlag name value | (name,value) <- flags]
+        sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
+        sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
       where
         adefs =
             [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
@@ -74,7 +95,7 @@ grammar2PGF opts gr am probs = do
                 deflt = case length [f | (f,Nothing) <- pfs] of
                           0 -> 0
                           n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
-
+{-
     mkConcr opts abs (cm,ex_seqs,cdefs) =
       let cflags = err (const noOptions) mflags (lookupModule gr cm)
           ciCmp | flag optCaseSensitive cflags = compare
@@ -125,34 +146,34 @@ grammar2PGF opts gr am probs = do
           (seqs,info)  <- addPMCFG opts gr cenv Nothing am cm seqs id info
           (seqs,infos) <- addMissingPMCFGs cm seqs is
           return (seqs, ((m,id), info) : infos)
-
+-}
 i2i :: Ident -> String
 i2i = showIdent
 
 mi2i :: ModuleName -> String
 mi2i (MN i) = i2i i
 
-mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
+mkType :: [Ident] -> A.Type -> PGF2.Type
 mkType scope t =
   case GM.typeForm t of
     (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                           in dTyp hyps' (i2i cat) (map (mkExp scope') args)
+                           in DTyp hyps' (i2i cat) (map (mkExp scope') args)
 
-mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
+mkExp :: [Ident] -> A.Term -> Expr
 mkExp scope t =
   case t of
-    Q (_,c)  -> eFun (i2i c)
-    QC (_,c) -> eFun (i2i c)
+    Q (_,c)  -> EFun (i2i c)
+    QC (_,c) -> EFun (i2i c)
     Vr x     -> case lookup x (zip scope [0..]) of
-                  Just i  -> eVar  i
-                  Nothing -> eMeta 0
-    Abs b x t-> eAbs b (i2i x) (mkExp (x:scope) t)
-    App t1 t2-> eApp (mkExp scope t1) (mkExp scope t2)
-    EInt i   -> eLit (LInt (fromIntegral i))
-    EFloat f -> eLit (LFlt f)
-    K s      -> eLit (LStr s)
-    Meta i   -> eMeta i
-    _        -> eMeta 0
+                  Just i  -> EVar  i
+                  Nothing -> EMeta 0
+    Abs b x t-> EAbs b (i2i x) (mkExp (x:scope) t)
+    App t1 t2-> EApp (mkExp scope t1) (mkExp scope t2)
+    EInt i   -> ELit (LInt (fromIntegral i))
+    EFloat f -> ELit (LFlt f)
+    K s      -> ELit (LStr s)
+    Meta i   -> EMeta i
+    _        -> EMeta 0
 {-
 mkPatt scope p = 
   case p of
@@ -169,11 +190,12 @@ mkPatt scope p =
                    in (scope',C.PImplArg p')
     A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
 -}
-mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
+
+mkContext :: [Ident] -> A.Context -> ([Ident],[PGF2.Hypo])
 mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                       in if x == identW
-                                                           then (  scope,hypo bt (i2i x) ty')
-                                                           else (x:scope,hypo bt (i2i x) ty')) scope hyps 
+                                                           then (  scope,(bt,i2i x,ty'))
+                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
 mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
 mkDef gr arity Nothing    = []
@@ -182,7 +204,7 @@ mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
 mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
 mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
                                in length ctxt
-
+{-
 genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where
     mkCncCats index []                                                = (index,[])
@@ -445,3 +467,4 @@ compareCaseInsensitive (x:xs) (y:ys) =
                               EQ -> compare x y
                               x  -> x
                       x  -> x
+-}

src/compiler/GF/Compile/Optimize.hs

@@ -1,232 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Module      : Optimize
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/16 13:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
---
--- Top-level partial evaluation for GF source modules.
------------------------------------------------------------------------------
-
-module GF.Compile.Optimize (optimizeModule) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Printer
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
-import GF.Data.Operations
-import GF.Infra.Option
-
-import Control.Monad
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Debug.Trace
-
--- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-
-optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
-optimizeModule opts sgr m@(name,mi)
-  | mstatus mi == MSComplete = do
-      ids <- topoSortJments m
-      mi <- foldM updateEvalInfo mi ids
-      return (name,mi)
-  | otherwise = return m
- where
-   oopts = opts `addOptions` mflags mi
-
-   resenv = resourceValues oopts sgr
-
-   updateEvalInfo mi (i,info) = do
-     info <- evalInfo oopts resenv sgr (name,mi) i info
-     return (mi{jments=Map.insert i info (jments mi)})
-
-evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
-evalInfo opts resenv sgr m c info = do
-
- (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
-
- errIn ("optimizing " ++ showIdent c) $ case info of
-
-  CncCat ptyp pde pre ppr mpmcfg -> do
-    pde' <- case (ptyp,pde) of
-      (Just (L _ typ), Just (L loc de)) -> do
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      (Just (L loc typ), Nothing) -> do
-        de <- mkLinDefault gr typ
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      _ -> return pde   -- indirection
-
-    pre' <- case (ptyp,pre) of
-      (Just (L _ typ), Just (L loc re)) -> do
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      (Just (L loc typ), Nothing) -> do
-        re <- mkLinReference gr typ
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      _ -> return pre   -- indirection
-
-    let ppr' = fmap (evalPrintname resenv c) ppr
-
-    return (CncCat ptyp pde' pre' ppr' mpmcfg)
-
-  CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
-       eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
-    pde' <- case pde of
-      Just (L loc de) -> do de <- partEval opts gr (cont,val) de
-                            return (Just (L loc (factor param c 0 de)))
-      Nothing -> return pde
-    let ppr' = fmap (evalPrintname resenv c) ppr
-    return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
-{-
-  ResOper pty pde
-    | not new && OptExpand `Set.member` optim -> do
-         pde' <- case pde of
-                   Just (L loc de) -> do de <- computeConcrete gr de
-                                         return (Just (L loc (factor param c 0 de)))
-                   Nothing -> return Nothing
-         return $ ResOper pty pde'
--}
-  _ ->  return info
- where
--- new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
-
-   gr = prependModule sgr m
-   optim = flag optOptimizations opts
-   param = OptParametrize `Set.member` optim
-   eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
-
--- | the main function for compiling linearizations
-partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
-partEval opts = {-if flag optNewComp opts
-                then-} partEvalNew opts
-                {-else partEvalOld opts-}
-
-partEvalNew opts gr (context, val) trm =
-    errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
-    checkPredefError trm
-{-
-partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
-  let vars  = map (\(bt,x,t) -> x) context
-      args  = map Vr vars
-      subst = [(v, Vr v) | v <- vars]
-      trm1 = mkApp trm args
-  trm2 <- computeTerm gr subst trm1
-  trm3 <- if rightType trm2
-          then computeTerm gr subst trm2 -- compute twice??
-          else recordExpand val trm2 >>= computeTerm gr subst
-  trm4 <- checkPredefError trm3
-  return $ mkAbs [(Explicit,v) | v <- vars] trm4
-  where
-    -- don't eta expand records of right length (correct by type checking)
-    rightType (R rs) = case val of
-                         RecType ts -> length rs == length ts
-                         _          -> False
-    rightType _      = False
-
-
--- here we must be careful not to reduce
---   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
---   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
-
-recordExpand :: Type -> Term -> Err Term
-recordExpand typ trm = case typ of
-  RecType tys -> case trm of
-    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
-    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
-  _ -> return trm
-
--}
--- | auxiliaries for compiling the resource
-
-mkLinDefault :: SourceGrammar -> Type -> Err Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
-   mkDefField typ = case typ of
-     Table p t  -> do
-       t' <- mkDefField t
-       let T _ cs = mkWildCases t'
-       return $ T (TWild p) cs
-     Sort s | s == cStr -> return $ Vr varStr
-     QC p           -> do vs <- lookupParamValues gr p
-                          case vs of
-                            v:_ -> return v
-                            _   -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
-     RecType r  -> do
-       let (ls,ts) = unzip r
-       ts <- mapM mkDefField ts
-       return $ R (zipWith assign ls ts)
-     _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> Bad (render ("linearization type field cannot be" <+> typ))
-
-mkLinReference :: SourceGrammar -> Type -> Err Term
-mkLinReference gr typ =
- liftM (Abs Explicit varStr) $
-   case mkDefField typ (Vr varStr) of
-     Bad "no string" -> return Empty
-     x               -> x
- where
-   mkDefField ty trm =
-     case ty of
-       Table pty ty -> do ps <- allParamValues gr pty
-                          case ps of
-                            []     -> Bad "no string"
-                            (p:ps) -> mkDefField ty (S trm p)
-       Sort s | s == cStr -> return trm
-       QC p       -> Bad "no string"
-       RecType [] -> Bad "no string"
-       RecType rs -> do
-         msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
-           `mplus` Bad "no string"
-       _ | Just _ <- isTypeInts typ -> Bad "no string"
-       _ -> Bad (render ("linearization type field cannot be" <+> typ))
-
-evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
-evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)
-
--- do even more: factor parametric branches
-
-factor :: Bool -> Ident -> Int -> Term -> Term
-factor param c i t =
-  case t of
-    T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
-    _               -> composSafeOp (factor param c i) t
-  where
-    factors ty pvs0
-                 | not param = V ty (map snd pvs0)
-    factors ty []            = V ty []
-    factors ty pvs0@[(p,v)]  = V ty [v]
-    factors ty pvs0@(pv:pvs) =
-      let t  = mkFun pv
-          ts = map mkFun pvs
-      in if all (==t) ts
-           then T (TTyped ty) (mkCases t)
-           else V ty (map snd pvs0)
-
-    --- we hope this will be fresh and don't check... in GFC would be safe
-    qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i)
-
-    mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
-    mkCases t = [(PV qvar, t)]
-
---  we need to replace subterms
-replace :: Term -> Term -> Term -> Term
-replace old new trm =
-  case trm of
-    -- these are the important cases, since they can correspond to patterns
-    QC _     | trm == old -> new
-    App _ _  | trm == old -> new
-    R _      | trm == old -> new
-    App x y               -> App (replace old new x) (replace old new y)
-    _                     -> composSafeOp (replace old new) trm

src/compiler/GF/Compile/OptimizePGF.hs

@@ -2,7 +2,7 @@
 module GF.Compile.OptimizePGF(optimizePGF) where
 
 import PGF2(Cat,Fun)
-import PGF2.Internal
+import PGF2.Transactions
 import Data.Array.ST
 import Data.Array.Unboxed
 import qualified Data.Map as Map
@@ -12,15 +12,16 @@ import qualified Data.IntMap as IntMap
 import qualified Data.List as List
 import Control.Monad.ST
 
-type ConcrData = ([(FId,[FunId])],          -- ^ Lindefs
+type ConcrData = ()
+{-([(FId,[FunId])],          -- ^ Lindefs
                   [(FId,[FunId])],          -- ^ Linrefs
                   [(FId,[Production])],     -- ^ Productions
                   [(Fun,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
                   [[Symbol]],               -- ^ Sequences            (must be sorted)
                   [(Cat,FId,FId,[String])]) -- ^ Concrete categories
-
+-}
 optimizePGF :: Cat -> ConcrData -> ConcrData
-optimizePGF startCat = topDownFilter startCat . bottomUpFilter
+optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
 
 catString = "String"
 catInt    = "Int"
@@ -187,3 +188,4 @@ filterProductions prods0 hoc0 prods
 
     accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
     accumHOC hoc _                   = hoc
+-}

src/compiler/GF/Compile/PGFtoJSON.hs

@@ -6,8 +6,8 @@ import Text.JSON
 import qualified Data.Map as Map
 
 pgf2json :: PGF -> String
-pgf2json pgf =
-  encode $ makeObj
+pgf2json pgf = error "TODO: pgf2json"
+{-  encode $ makeObj
     [ ("abstract", abstract2json pgf)
     , ("concretes", makeObj $ map concrete2json
                                 (Map.toList (languages pgf)))
@@ -108,3 +108,4 @@ new f xs =
     [ ("type", showJSON f)
     , ("args", showJSON xs)
     ]
+-}

src/compiler/GF/Compile/Rename.hs

@@ -130,8 +130,8 @@ renameIdentTerm' env@(act,imps) t0 =
 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
 info2status mq c i = case i of
   AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
-  ResValue _  -> maybe Con (curry QC) mq
-  ResParam _ _  -> maybe Con (curry QC) mq
+  ResValue _ _ -> maybe Con (curry QC) mq
+  ResParam _ _ -> maybe Con (curry QC) mq
   AnyInd True m -> maybe Con (const (curry QC m)) mq
   AnyInd False m -> maybe Cn (const (curry Q m)) mq
   _           -> maybe Cn (curry Q) mq
@@ -168,9 +168,9 @@ renameInfo cwd status (m,mi) i info =
     ResParam (Just pp) m -> do
       pp' <- renLoc (mapM (renParam status)) pp
       return (ResParam (Just pp') m)
-    ResValue t -> do
+    ResValue t i -> do
       t <- renLoc (renameTerm status []) t
-      return (ResValue t)
+      return (ResValue t i)
     CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
     CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
@@ -237,9 +237,9 @@ renameTerm env vars = ren vars where
                             , checkError ("unknown qualified constant" <+> trm)
                             ]
 
-    EPatt p -> do
+    EPatt minp maxp p -> do
       (p',_) <- renpatt p
-      return $ EPatt p'
+      return $ EPatt minp maxp p'
 
     _ -> composOp (ren vs) trm
 
@@ -306,14 +306,14 @@ renamePattern env patt =
         (q',ws) <- renp q
         return (PAlt p' q', vs ++ ws)
 
-      PSeq p q -> do
+      PSeq minp maxp p minq maxq q -> do
         (p',vs) <- renp p
         (q',ws) <- renp q
-        return (PSeq p' q', vs ++ ws)
+        return (PSeq minp maxp p' minq maxq q', vs ++ ws)
 
-      PRep p -> do
+      PRep minp maxp p -> do
         (p',vs) <- renp p
-        return (PRep p', vs)
+        return (PRep minp maxp p', vs)
 
       PNeg p -> do
         (p',vs) <- renp p

src/compiler/GF/Compile/Tags.hs

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
     getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
                                                   maybe (list (loc "def"))   mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
-    getLocations (ResValue mb_type)             = ltype "param-value"          mb_type
+    getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 

src/compiler/GF/Compile/TypeCheck/Concrete.hs

@@ -13,6 +13,7 @@ import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
 import GF.Compile.TypeCheck.Primitives
 
 import Data.List
+import Data.Maybe(fromMaybe)
 import Control.Monad
 import GF.Text.Pretty
 
@@ -264,9 +265,10 @@ inferLType gr g trm = case trm of
    EPattType ty -> do
      ty' <- justCheck g ty typeType
      return (EPattType ty',typeType)
-   EPatt p -> do
+   EPatt _ _ p -> do
      ty <- inferPatt p
-     return (trm, EPattType ty)
+     let (minp,maxp,p') = measurePatt gr p
+     return (EPatt minp maxp p', EPattType ty)
 
    ELin c trm -> do
      (trm',ty) <- inferLType gr g trm
@@ -290,7 +292,7 @@ inferLType gr g trm = case trm of
    inferCase mty (patt,term) = do
      arg  <- maybe (inferPatt patt) return mty
      cont <- pattContext gr g arg patt
-     (_,val) <- inferLType gr (reverse cont ++ g) term
+     (term',val) <- inferLType gr (reverse cont ++ g) term
      return (arg,val)
    isConstPatt p = case p of
      PC _ ps -> True --- all isConstPatt ps
@@ -302,9 +304,9 @@ inferLType gr g trm = case trm of
      PFloat _ -> True
      PChar -> True
      PChars _ -> True
-     PSeq p q -> isConstPatt p && isConstPatt q
+     PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
      PAlt p q -> isConstPatt p && isConstPatt q
-     PRep p -> isConstPatt p
+     PRep _ _ p -> isConstPatt p
      PNeg p -> isConstPatt p
      PAs _ p -> isConstPatt p
      _ -> False
@@ -314,12 +316,44 @@ inferLType gr g trm = case trm of
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ -> return $ typeStr
-     PRep _   -> return $ typeStr
+     PSeq _ _ _ _ _ _ -> return $ typeStr
+     PRep _ _ _ -> return $ typeStr
      PChar    -> return $ typeStr
      PChars _ -> return $ typeStr
      _ -> inferLType gr g (patt2term p) >>= return . snd
 
+measurePatt gr p =
+  case p of
+    PM q       -> case lookupResDef gr q of
+                    Ok t    -> case t of
+                                 EPatt minp maxp _ -> (minp,maxp,p)
+                                 _ -> error "Expected pattern macro"
+                    Bad msg -> error msg
+    PR ass     -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt gr p in (lbl,p')) ass)
+                  in (0,Nothing,p')
+    PString s  -> let len=length s
+                  in (len,Just len,p)
+    PT t p     -> let (min,max,p') = measurePatt gr p
+                  in (min,max,PT t p')
+    PAs x p    -> let (min,max,p') = measurePatt gr p
+                  in (min,max,PAs x p')
+    PImplArg p -> let (min,max,p') = measurePatt gr p
+                  in (min,max,PImplArg p')
+    PNeg p     -> let (_,_,p') = measurePatt gr p
+                  in (0,Nothing,PNeg p')
+    PAlt p1 p2 -> let (min1,max1,p1') = measurePatt gr p1
+                      (min2,max2,p2') = measurePatt gr p2
+                  in (min min1 min2,liftM2 max max1 max2,PAlt p1' p2')
+    PSeq _ _ p1 _ _ p2
+               -> let (min1,max1,p1') = measurePatt gr p1
+                      (min2,max2,p2') = measurePatt gr p2
+                  in (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1' min2 max2 p2')
+    PRep _ _ p -> let (minp,maxp,p') = measurePatt gr p
+                  in (0,Nothing,PRep minp maxp p')
+    PChar      -> (1,Just 1,p)
+    PChars _   -> (1,Just 1,p)
+    _          -> (0,Nothing,p)
+
 -- type inference: Nothing, type checking: Just t
 -- the latter permits matching with value type
 getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
@@ -596,7 +630,8 @@ checkLType gr g trm typ0 = do
    checkCase arg val (p,t) = do
      cont <- pattContext gr g arg p
      t' <- justCheck (reverse cont ++ g) t val
-     return (p,t')
+     let (_,_,p') = measurePatt gr p
+     return (p',t')
 
 pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
 pattContext env g typ p = case p of
@@ -633,11 +668,11 @@ pattContext env g typ p = case p of
        fsep pts <+>
        "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
     return g1 -- must be g1 == g2
-  PSeq p q -> do
+  PSeq _ _ p _ _ q -> do
     g1 <- pattContext env g typ p
     g2 <- pattContext env g typ q
     return $ g1 ++ g2
-  PRep p' -> noBind typeStr p'
+  PRep _ _ p' -> noBind typeStr p'
   PNeg p' -> noBind typ p'
 
   _ -> return [] ---- check types!

src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs

@@ -11,7 +11,6 @@ import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
 import GF.Compile.Compute.Concrete
-import GF.Compile.Compute.Predef(predef,predefName)
 import GF.Infra.CheckM
 import GF.Data.Operations
 import Control.Applicative(Applicative(..))
@@ -22,20 +21,20 @@ import qualified Data.IntMap as IntMap
 import Data.Maybe(fromMaybe,isNothing)
 import qualified Control.Monad.Fail as Fail
 
-checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
-checkLType ge t ty = runTcM $ do
+checkLType :: Grammar -> Term -> Type -> Check (Term, Type)
+checkLType ge t ty = error "TODO: checkLType" {- runTcM $ do
   vty <- liftErr (eval ge [] ty)
   (t,_) <- tcRho ge [] t (Just vty)
   t <- zonkTerm t
-  return (t,ty)
+  return (t,ty) -}
 
-inferLType :: GlobalEnv -> Term -> Check (Term, Type)
-inferLType ge t = runTcM $ do
+inferLType :: Grammar -> Term -> Check (Term, Type)
+inferLType ge t = error "TODO: inferLType" {- runTcM $ do
   (t,ty) <- inferSigma ge [] t
   t  <- zonkTerm t
   ty <- zonkTerm =<< tc_value2term (geLoc ge) [] ty
-  return (t,ty)
-
+  return (t,ty) -}
+{-
 inferSigma :: GlobalEnv -> Scope -> Term -> TcM (Term,Sigma)
 inferSigma ge scope t = do                                      -- GEN1
   (t,ty) <- tcRho ge scope t Nothing
@@ -318,7 +317,7 @@ tcPatt ge scope (PString s) ty0 = do
 tcPatt ge scope PChar ty0 = do
   unify ge scope ty0 vtypeStr
   return scope
-tcPatt ge scope (PSeq p1 p2) ty0 = do
+tcPatt ge scope (PSeq _ _ p1 _ _ p2) ty0 = do
   unify ge scope ty0 vtypeStr
   scope <- tcPatt ge scope p1 vtypeStr
   scope <- tcPatt ge scope p2 vtypeStr
@@ -800,3 +799,4 @@ runTcA g f = TcM (\ms msgs -> case f of
                                                  [(x,ms,msgs)] -> TcOk x ms msgs
                                                  rs            -> unTcM (g xs) ms msgs
                                 TcSingle f                     -> f ms msgs)
+-}

src/compiler/GF/Compile/TypeCheck/Primitives.hs

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
 typPredefined f = case Map.lookup f primitives of
                     Just (ResOper (Just (L _ ty)) _) -> Just ty
                     Just (ResParam _ _)              -> Just typePType
-                    Just (ResValue (L _ ty))         -> Just ty
+                    Just (ResValue (L _ ty) _)       -> Just ty
                     _                                -> Nothing
 
 primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
   , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
   , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
   , (cInts     , fun [typeInt] typePType)
-  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
-  , (cPTrue    , ResValue (noLoc typePBool))
-  , (cPFalse   , ResValue (noLoc typePBool))
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just ([QC (cPredef,cPTrue), QC (cPredef,cPFalse)],2)))
+  , (cPTrue    , ResValue (noLoc typePBool) 0)
+  , (cPFalse   , ResValue (noLoc typePBool) 1)
   , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
   , (cLength   , fun [typeTok] typeInt)
   , (cDrop     , fun [typeInt,typeTok] typeTok)

src/compiler/GF/Compile/TypeCheck/TC.hs

@@ -35,7 +35,7 @@ data AExp =
      AVr   Ident Val
    | ACn   QIdent Val
    | AType
-   | AInt  Int
+   | AInt  Integer
    | AFloat Double
    | AStr  String
    | AMeta MetaId Val

src/compiler/GF/Compile/Update.hs

@@ -78,7 +78,7 @@ extendModule cwd gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -115,7 +115,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
                     else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
-      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -131,7 +131,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
 
   return (i,mi')
 
@@ -168,7 +168,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
     indirInfo :: ModuleName -> Info -> Info
     indirInfo n info = AnyInd b n' where
       (b,n') = case info of
-        ResValue _ -> (True,n)
+        ResValue _ _ -> (True,n)
         ResParam _ _ -> (True,n)
         AbsFun _ _ Nothing _ -> (True,n)
         AnyInd b k -> (b,k)
@@ -179,7 +179,7 @@ globalizeLoc fpath i =
     AbsCat mc             -> AbsCat (fmap gl mc)
     AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
     ResParam mt mv        -> ResParam (fmap gl mt) mv
-    ResValue t            -> ResValue (gl t)
+    ResValue t i          -> ResValue (gl t) i
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
     CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -201,9 +201,9 @@ unifyAnyInfo m i j = case (i,j) of
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1), ResValue (L l2 t2))
-      | t1==t2    -> return (ResValue (L l1 t1))
-      | otherwise -> fail ""
+  (ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
+      | t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
+      | otherwise          -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
   (ResOper mt1 m1, ResOper mt2 m2) ->

src/compiler/GF/CompileOne.hs

@@ -8,7 +8,6 @@ module GF.CompileOne(-- ** Compiling a single module
 import GF.Compile.GetGrammar(getSourceModule)
 import GF.Compile.Rename(renameModule)
 import GF.Compile.CheckGrammar(checkModule)
-import GF.Compile.Optimize(optimizeModule)
 import GF.Compile.SubExOpt(subexpModule,unsubexpModule)
 import GF.Compile.GeneratePMCFG(generatePMCFG)
 import GF.Compile.Update(extendModule,rebuildModule)
@@ -107,10 +106,9 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- Apply to complete modules when not generating tags
     backend mo3 =
-      do mo4 <- runPassE Optimize "optimizing" $ optimizeModule opts gr mo3
-         if isModCnc (snd mo4) && flag optPMCFG opts
-          then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
-          else runPassI "" $ return mo4
+      do if isModCnc (snd mo3) && flag optPMCFG opts
+          then runPassI "generating PMCFG" $ fmap fst $ runCheck' opts (generatePMCFG opts cwd gr mo3)
+          else runPassI "" $ return mo3
 
     ifComplete yes mo@(_,mi) =
       if isCompleteModule mi then yes mo else return mo
@@ -128,7 +126,6 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- * Running a compiler pass, with impedance matching
     runPass = runPass' fst fst snd (liftErr . runCheck' opts)
-    runPassE = runPass2e liftErr id
     runPassI = runPass2e id id Canon
     runPass2e lift dump = runPass' id dump (const "") lift
 

src/compiler/GF/Compiler.hs

@@ -1,7 +1,7 @@
 module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Internal(unionPGF,writePGF,writeConcr)
+import PGF2.Internal(unionPGF,writeConcr)
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -15,6 +15,7 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
+import GF.Infra.CheckM
 import GF.Data.ErrM
 import GF.System.Directory
 import GF.Text.Pretty(render,render80)
@@ -67,22 +68,25 @@ compileSourceFiles opts fs =
       where
         ofmts = flag optOutputFormats opts
 
-    cnc2haskell (cnc,gr) =
-      do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
+    cnc2haskell (cnc,gr) = do
+      (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
+      mapM_ writeExport res
 
-    abs2canonical (cnc,gr) =
-        writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+    abs2canonical (cnc,gr) = do
+      (canAbs,_) <- runCheck (abstract2canonical absname gr)
+      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
       where
         absname = srcAbsName gr cnc
-        canAbs = abstract2canonical absname gr
 
-    cnc2canonical (cnc,gr) =
-      mapM_ (writeExport.fmap render80) $
-            concretes2canonical opts (srcAbsName gr cnc) gr
+    cnc2canonical (cnc,gr) = do
+      (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
+      mapM_ (writeExport.fmap render80) res
 
-    grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
-      where absname = srcAbsName gr cnc
-            gr_canon = grammar2canonical opts absname gr
+    grammar2json (cnc,gr) = do
+      (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
+      return (encodeJSON (render absname ++ ".json") gr_canon)
+      where
+        absname = srcAbsName gr cnc
 
     writeExport (path,s) = writing opts path $ writeUTF8File path s
 
@@ -157,7 +161,11 @@ writeOutputs opts pgf = do
 -- A split PGF file is output if the @-split-pgf@ option is used.
 writeGrammar :: Options -> PGF -> IOE ()
 writeGrammar opts pgf =
-  if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+  if fst (flag optLinkTargets opts)
+    then if flag optSplitPGF opts
+           then writeSplitPGF
+           else writeNormalPGF
+    else return ()
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")

src/compiler/GF/Grammar/Analyse.hs

@@ -29,7 +29,7 @@ stripInfo i = case i of
   AbsCat _ -> i
   AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
   ResParam mp mt -> ResParam mp Nothing
-  ResValue lt -> i ----
+  ResValue lt _ -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
   CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
@@ -108,7 +108,7 @@ sizeInfo i = case i of
     sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
     1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
-  ResValue lt -> 0
+  ResValue _ _ -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
   CncCat mty _ _ _ _ -> 1 + msize mty   -- ignoring lindef, linref and printname

src/compiler/GF/Grammar/BNFC.hs

@@ -25,7 +25,7 @@ data BNFCRule = BNFCRule {
                  ruleName :: CFTerm }
               | BNFCCoercions {
                  coerCat :: Cat,
-                 coerNum :: Int }
+                 coerNum :: Integer }
               | BNFCTerminator {
                  termNonEmpty :: Bool,
                  termCat :: Cat,

src/compiler/GF/Grammar/Binary.hs

@@ -22,10 +22,11 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF2.Internal(Literal(..),Symbol(..))
+import PGF2(Literal(..))
+import PGF2.Transactions(Symbol(..))
 
 -- Please change this every time when the GFO format is changed
-gfoVersion = "GF04"
+gfoVersion = "GF05"
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -43,9 +44,9 @@ instance Binary Grammar where
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -102,24 +103,19 @@ instance Binary Options where
              toString (LInt n) = show n
              toString (LFlt d) = show d
 
-instance Binary Production where
-  put (Production res funid args) = put (res,funid,args)
-  get = do res   <- get
-           funid <- get
-           args  <- get
-           return (Production res funid args)
+instance Binary PMCFGCat where
+  put (PMCFGCat r rs) = put (r,rs)
+  get = get >>= \(r,rs) -> return (PMCFGCat r rs)
 
-instance Binary PMCFG where
-  put (PMCFG prods funs) = put (prods,funs)
-  get = do prods <- get
-           funs  <- get
-           return (PMCFG prods funs)
+instance Binary PMCFGRule where
+  put (PMCFGRule res args rules) = put (res,args,rules)
+  get = get >>= \(res,args,rules) -> return (PMCFGRule res args rules)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
   put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
   put (ResParam x y)   = putWord8 2 >> put (x,y)
-  put (ResValue x)     = putWord8 3 >> put x
+  put (ResValue x y)   = putWord8 3 >> put (x,y)
   put (ResOper x y)    = putWord8 4 >> put (x,y)
   put (ResOverload x y)= putWord8 5 >> put (x,y)
   put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
@@ -130,7 +126,7 @@ instance Binary Info where
              0 -> get >>= \x         -> return (AbsCat x)
              1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
              2 -> get >>= \(x,y)     -> return (ResParam x y)
-             3 -> get >>= \x         -> return (ResValue x)
+             3 -> get >>= \(x,y)     -> return (ResValue x y)
              4 -> get >>= \(x,y)     -> return (ResOper x y)
              5 -> get >>= \(x,y)     -> return (ResOverload x y)
              6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
@@ -181,14 +177,13 @@ instance Binary Term where
   put (QC x)        = putWord8 25 >> put x
   put (C x y)       = putWord8 26 >> put (x,y)
   put (Glue x y)    = putWord8 27 >> put (x,y)
-  put (EPatt x)     = putWord8 28 >> put x
+  put (EPatt x y z) = putWord8 28 >> put (x,y,z)
   put (EPattType x) = putWord8 29 >> put x
   put (ELincat x y) = putWord8 30 >> put (x,y)
   put (ELin x y)    = putWord8 31 >> put (x,y)
   put (FV x)        = putWord8 32 >> put x
   put (Alts x y)    = putWord8 33 >> put (x,y)
   put (Strs x)      = putWord8 34 >> put x
-  put (Error x)     = putWord8 35 >> put x
 
   get = do tag <- getWord8
            case tag of
@@ -220,14 +215,13 @@ instance Binary Term where
              25 -> get >>= \x       -> return (QC x)
              26 -> get >>= \(x,y)   -> return (C x y)
              27 -> get >>= \(x,y)   -> return (Glue x y)
-             28 -> get >>= \x       -> return (EPatt x)
+             28 -> get >>= \(x,y,z) -> return (EPatt x y z)
              29 -> get >>= \x       -> return (EPattType x)
              30 -> get >>= \(x,y)   -> return (ELincat x y)
              31 -> get >>= \(x,y)   -> return (ELin x y)
              32 -> get >>= \x       -> return (FV x)
              33 -> get >>= \(x,y)   -> return (Alts x y)
              34 -> get >>= \x       -> return (Strs x)
-             35 -> get >>= \x       -> return (Error x)
              _  -> decodingError
 
 instance Binary Patt where
@@ -243,8 +237,8 @@ instance Binary Patt where
   put (PAs  x y)   = putWord8 10 >> put (x,y)
   put (PNeg x)     = putWord8 11 >> put x
   put (PAlt x y)   = putWord8 12 >> put (x,y)
-  put (PSeq x y)   = putWord8 13 >> put (x,y)
-  put (PRep x)     = putWord8 14 >> put x
+  put (PSeq minx maxx x miny maxy y)   = putWord8 13 >> put (minx,maxx,x,miny,maxy,y)
+  put (PRep minx maxx x)= putWord8 14 >> put (minx,maxx,x)
   put (PChar)      = putWord8 15
   put (PChars x)   = putWord8 16 >> put x
   put (PMacro x)   = putWord8 17 >> put x
@@ -265,8 +259,8 @@ instance Binary Patt where
              10 -> get >>= \(x,y)   -> return (PAs  x y)
              11 -> get >>= \x       -> return (PNeg x)
              12 -> get >>= \(x,y)   -> return (PAlt x y)
-             13 -> get >>= \(x,y)   -> return (PSeq x y)
-             14 -> get >>= \x       -> return (PRep x)
+             13 -> get >>= \(minx,maxx,x,miny,maxy,y) -> return (PSeq minx maxx x miny maxy y)
+             14 -> get >>= \(minx,maxx,x)-> return (PRep minx maxx x)
              15 ->                     return (PChar)
              16 -> get >>= \x       -> return (PChars x)
              17 -> get >>= \x       -> return (PMacro x)
@@ -318,7 +312,7 @@ instance Binary Literal where
              _ -> decodingError
 
 instance Binary Symbol where
-  put (SymCat n l)       = putWord8 0 >> put (n,l)
+  put (SymCat d r rs)    = putWord8 0 >> put (d,r,rs)
   put (SymLit n l)       = putWord8 1 >> put (n,l)
   put (SymVar n l)       = putWord8 2 >> put (n,l)
   put (SymKS ts)         = putWord8 3 >> put ts
@@ -331,7 +325,7 @@ instance Binary Symbol where
   put SymALL_CAPIT       = putWord8 10
   get = do tag <- getWord8
            case tag of
-             0 -> liftM2 SymCat get get
+             0 -> liftM3 SymCat get get get
              1 -> liftM2 SymLit get get
              2 -> liftM2 SymVar get get
              3 -> liftM  SymKS  get
@@ -378,7 +372,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
 decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
   where
     conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
-        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
 
 encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
 encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

src/compiler/GF/Grammar/CFG.hs

@@ -8,7 +8,7 @@ module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
 
 import GF.Data.Utilities
 import PGF2(Fun,Cat)
-import PGF2.Internal(Token)
+import PGF2.Transactions(Token)
 import GF.Data.Relation
 
 import Data.Map (Map)

src/compiler/GF/Grammar/Canonical.hs

@@ -9,9 +9,11 @@
 
 {-# LANGUAGE DeriveTraversable #-}
 module GF.Grammar.Canonical where
+
 import Prelude hiding ((<>))
 import GF.Text.Pretty
 import GF.Infra.Ident (RawIdent)
+import PGF(Literal(..))
 
 -- | A Complete grammar
 data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -58,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 
 -- | Linearization value, RHS of @lin@
 data LinValue = ConcatValue LinValue LinValue
-              | LiteralValue LinLiteral
+              | LiteralValue Literal
               | ErrorValue String
               | ParamConstant ParamValue
               | PredefValue PredefId
@@ -74,11 +76,6 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
-data LinLiteral = FloatConstant Float
-                | IntConstant Int
-                | StrConstant String
-                deriving (Eq,Ord,Show)
-
 data LinPattern = ParamPattern ParamPattern
                 | RecordPattern [RecordRow LinPattern]
                 | TuplePattern [LinPattern]
@@ -120,9 +117,8 @@ newtype FunId = FunId Id  deriving (Eq,Show)
 
 data VarId = Anonymous | VarId Id  deriving Show
 
-newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
+newtype Flags = Flags [(FlagName,Literal)] deriving Show
 type FlagName = Id
-data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 
 -- *** Identifiers
@@ -243,13 +239,13 @@ instance PPA LinValue where
              VarValue v -> pp v
              _ -> parens lv
 
-instance Pretty LinLiteral where pp = ppA
+instance Pretty Literal where pp = ppA
 
-instance PPA LinLiteral where
+instance PPA Literal where
   ppA l = case l of
-            FloatConstant f -> pp f
-            IntConstant n -> pp n
-            StrConstant s -> doubleQuotes s -- hmm
+            LFlt f -> pp f
+            LInt n -> pp n
+            LStr s -> doubleQuotes s -- hmm
 
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
@@ -298,11 +294,6 @@ instance Pretty Flags where
     where
       ppFlag (name,value) = name <+> "=" <+> value <>";"
 
-instance Pretty FlagValue where
-  pp (Str s) = pp s
-  pp (Int i) = pp i
-  pp (Flt d) = pp d
-
 --------------------------------------------------------------------------------
 -- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
 class Pretty a => PPA a where ppA :: a -> Doc

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -8,7 +8,7 @@ import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 import Control.Monad (guard)
 import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
-
+import PGF(Literal(..))
 
 encodeJSON :: FilePath -> Grammar -> IO ()
 encodeJSON fpath g = writeFile fpath (encode g)
@@ -171,13 +171,13 @@ instance JSON LinValue where
     <|>        do vs <- readJSON o :: Result [LinValue]
                   return (foldr1 ConcatValue vs)
 
-instance JSON LinLiteral where
+instance JSON Literal where
   -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
-  showJSON (StrConstant   s) = showJSON s
-  showJSON (FloatConstant f) = showJSON f
-  showJSON (IntConstant   n) = showJSON n
+  showJSON (LStr s) = showJSON s
+  showJSON (LFlt f) = showJSON f
+  showJSON (LInt n) = showJSON n
 
-  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
+  readJSON = readBasicJSON LStr LInt LFlt
 
 instance JSON LinPattern where
   -- wildcards and patterns without arguments are encoded as strings:
@@ -262,15 +262,6 @@ instance JSON Flags where
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
                                       return (rawIdentS lbl, value)
 
-instance JSON FlagValue where
-  -- flag values are encoded as basic JSON types:
-  showJSON (Str s) = showJSON s
-  showJSON (Int i) = showJSON i
-  showJSON (Flt f) = showJSON f
-
-  readJSON = readBasicJSON Str Int Flt
-
-
 --------------------------------------------------------------------------------
 -- ** Convenience functions
 

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
+        PMCFGCat(..), PMCFGRule(..)
         ) where
 
 import GF.Infra.Ident
@@ -74,7 +74,7 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..))
-import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
+import PGF2.Transactions(Symbol,LIndex,LParam)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -100,7 +100,6 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId [Symbol]),
     jments  :: Map.Map Ident Info
   }
 
@@ -305,14 +304,11 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
-data Production = Production {-# UNPACK #-} !FId
-                             {-# UNPACK #-} !FunId
-                             [[FId]]
-                  deriving (Eq,Ord,Show)
+data PMCFGCat  = PMCFGCat LIndex [(LIndex,LParam)]
+                 deriving (Eq,Show)
 
-data PMCFG = PMCFG [Production]
-                   (Array FunId (UArray LIndex SeqId)) 
-             deriving (Eq,Show)
+data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
+                 deriving (Eq,Show)
 
 -- | the constructors are judgements in 
 --
@@ -329,15 +325,18 @@ data Info =
  | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
- | ResParam (Maybe (L [Param])) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue (L Type)                             -- ^ (/RES/) to mark parameter constructors for lookup
- | ResOper  (Maybe (L Type)) (Maybe (L Term))    -- ^ (/RES/)
+ | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
+                                                     -- and its precomputed length.
+ | ResValue (L Type) Int                             -- ^ (/RES/) to mark parameter constructors for lookup.
+                                                     -- The second argument is the offset into the list of all values
+                                                     -- where that constructor appears first.
+ | ResOper  (Maybe (L Type)) (Maybe (L Term))        -- ^ (/RES/)
 
- | ResOverload [ModuleName] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
+ | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -354,7 +353,7 @@ data Term =
  | Cn Ident                      -- ^ constant
  | Con Ident                     -- ^ constructor
  | Sort Ident                    -- ^ basic type
- | EInt Int                      -- ^ integer literal
+ | EInt Integer                  -- ^ integer literal
  | EFloat Double                 -- ^ floating point literal
  | K String                      -- ^ string literal or token: @\"foo\"@
  | Empty                         -- ^ the empty string @[]@
@@ -386,7 +385,7 @@ data Term =
  | C Term Term                   -- ^ concatenation: @s ++ t@
  | Glue Term Term                -- ^ agglutination: @s + t@
 
- | EPatt Patt                    -- ^ pattern (in macro definition): # p
+ | EPatt Int (Maybe Int) Patt    -- ^ pattern (in macro definition): # p
  | EPattType Term                -- ^ pattern type: pattern T
 
  | ELincat Ident Term            -- ^ boxed linearization type of Ident
@@ -398,7 +397,7 @@ data Term =
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
- | Error String                  -- ^ error values returned by Predef.error
+ | TSymCat Int LIndex [(LIndex,Ident)]
   deriving (Show, Eq, Ord)
 
 -- | Patterns
@@ -409,7 +408,7 @@ data Patt =
  | PW                     -- ^ wild card pattern: @_@
  | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
  | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
- | PInt    Int            -- ^ integer literal pattern: @12@    -- only abstract
+ | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
  | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
  | PT Type Patt           -- ^ type-annotated pattern
 
@@ -421,18 +420,23 @@ data Patt =
  -- regular expression patterns
  | PNeg Patt              -- ^ negated pattern: -p
  | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
- | PSeq Patt Patt         -- ^ sequence of token parts: p + q
- | PMSeq MPatt MPatt      -- ^ sequence of token parts: p + q
- | PRep Patt              -- ^ repetition of token part: p*
+ | PSeq Int (Maybe Int) Patt Int (Maybe Int) Patt
+                          -- ^ sequence of token parts: p + q
+                          -- In the constructor PSeq minp maxp p minq maxq q,
+                          -- minp/maxp and minq/maxq are the minimal/maximal
+                          -- length of a matching string for p/q.
+ | PRep Int (Maybe Int) Patt
+                          -- ^ repetition of token part: p*
+                          -- In the constructor PRep minp maxp p,
+                          -- minp/maxp is the minimal/maximal length of
+                          -- a matching string for p.
+ 
  | PChar                  -- ^ string of length one: ?
  | PChars [Char]          -- ^ character list: ["aeiou"]
  | PMacro Ident           -- #p
  | PM QIdent              -- #m.p
   deriving (Show, Eq, Ord)
 
--- | Measured pattern (paired with the min & max matching length)
-type MPatt = ((Int,Int),Patt)
-
 -- | to guide computation and type checking of tables
 data TInfo = 
    TRaw         -- ^ received from parser; can be anything
@@ -449,7 +453,7 @@ data Label =
 
 type MetaId = Int
 
-type Hypo     = (BindType,Ident,Term)   -- (x:A)  (_:A)  A  ({x}:A)
+type Hypo     = (BindType,Ident,Type)   -- (x:A)  (_:A)  A  ({x}:A)
 type Context  = [Hypo]                  -- (x:A)(y:B)   (x,y:A)   (_,_:A)
 type Equation = ([Patt],Term) 
 

src/compiler/GF/Grammar/Lexer.x

@@ -130,7 +130,7 @@ data Token
  | T_separator
  | T_nonempty
  | T_String  String          -- string literals
- | T_Integer Int             -- integer literals
+ | T_Integer Integer         -- integer literals
  | T_Double  Double          -- double precision float literals
  | T_Ident   Ident
  | T_EOF

src/compiler/GF/Grammar/Lookup.hs

@@ -78,12 +78,12 @@ lookupResDefLoc gr (m,c)
         CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
         CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
 
-        CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
-        CncFun _                (Just ltr) _ _ -> return ltr
+        CncFun (Just (_,cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
+        CncFun _                  (Just ltr) _ _ -> return ltr
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (noLoc (QC (m,c)))
-        ResValue _        -> return (noLoc (QC (m,c)))
+        ResValue _ _      -> return (noLoc (QC (m,c)))
         _   -> raise $ render (c <+> "is not defined in resource" <+> m)
 
 lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
@@ -94,12 +94,12 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (cat,cont,val)) _ _ _ -> do
+    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
           val' <- lock cat val
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
-    ResParam _ _      -> return typePType
-    ResValue (L _ t)  -> return t
+    ResParam _ _    -> return typePType
+    ResValue (L _ t) _ -> return t
     _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
 
 lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -110,11 +110,11 @@ lookupOverloadTypes gr id@(m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
-    CncFun (Just (cat,cont,val)) _ _ _ -> do
+    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
           val' <- lock cat val
           ret $ mkProd cont val' []
-    ResParam _ _      -> ret typePType
-    ResValue (L _ t)  -> ret t
+    ResParam _ _    -> ret typePType
+    ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
             return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -154,8 +154,8 @@ lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
 lookupParamValues gr c = do
   (_,info) <- lookupOrigInfo gr c
   case info of
-    ResParam _ (Just pvs) -> return pvs
-    _                     -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    ResParam _ (Just (pvs,_)) -> return pvs
+    _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
 
 allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
 allParamValues cnc ptyp =
@@ -226,9 +226,9 @@ allOpers gr =
     typesIn info = case info of
       AbsFun  (Just ltyp) _ _ _ -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
-      ResValue ltyp             -> [ltyp]
+      ResValue ltyp _           -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
-      CncFun  (Just (i,ctx,typ)) _ _ _ ->
+      CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
                                    [L NoLoc (mkProdSimple ctx (lock' i typ))]
       _                         -> []
 

src/compiler/GF/Grammar/Macros.hs

@@ -216,7 +216,7 @@ typeTok   = Sort cTok
 typeStrs  = Sort cStrs
 
 typeString, typeFloat, typeInt :: Type
-typeInts :: Int -> Type
+typeInts :: Integer -> Type
 typePBool :: Type
 typeError :: Type
 
@@ -227,7 +227,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
 typePBool = cnPredef cPBool
 typeError = cnPredef cErrorType
 
-isTypeInts :: Type -> Maybe Int
+isTypeInts :: Type -> Maybe Integer
 isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
 isTypeInts _                                      = Nothing
 
@@ -238,12 +238,6 @@ isPredefConstant t = case t of
   Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
   _                                               -> False
 
-checkPredefError :: Fail.MonadFail m => Term -> m Term
-checkPredefError t =
-    case t of
-      Error s -> fail ("Error: "++s)
-      _ -> return t
-
 cnPredef :: Ident -> Term
 cnPredef f = Q (cPredef,f)
 
@@ -324,7 +318,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
 string2term :: String -> Term
 string2term = K
 
-int2term :: Int -> Term
+int2term :: Integer -> Term
 int2term = EInt
 
 float2term :: Double -> Term
@@ -384,7 +378,7 @@ term2patt trm = case termForm trm of
     return (PNeg a')
   Ok ([], Cn id, [a]) | id == cRep -> do
     a' <- term2patt a
-    return (PRep a')
+    return (PRep 0 Nothing a')
   Ok ([], Cn id, []) | id == cRep -> do
     return PChar
   Ok ([], Cn id,[K s]) | id == cChars  -> do
@@ -392,7 +386,7 @@ term2patt trm = case termForm trm of
   Ok ([], Cn id, [a,b]) | id == cSeq -> do
     a' <- term2patt a
     b' <- term2patt b
-    return (PSeq a' b')
+    return (PSeq 0 Nothing a' 0 Nothing b')
   Ok ([], Cn id, [a,b]) | id == cAlt -> do
     a' <- term2patt a
     b' <- term2patt b
@@ -422,9 +416,9 @@ patt2term pt = case pt of
   PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
   PChar     -> appCons cChar  []                             --- an encoding
   PChars s  -> appCons cChars [K s]                          --- an encoding
-  PSeq a b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
+  PSeq _ _ a _ _ b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
   PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
-  PRep a    -> appCons cRep   [(patt2term a)]                --- an encoding
+  PRep _ _ a-> appCons cRep   [(patt2term a)]                --- an encoding
   PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
 
 
@@ -475,9 +469,8 @@ composPattOp op patt =
     PImplArg p      -> liftM  PImplArg (op p)
     PNeg p          -> liftM  PNeg (op p)
     PAlt p1 p2      -> liftM2 PAlt (op p1) (op p2)
-    PSeq p1 p2      -> liftM2 PSeq (op p1) (op p2)
-    PMSeq (_,p1) (_,p2) -> liftM2 PSeq (op p1) (op p2) -- information loss
-    PRep p          -> liftM  PRep (op p)
+    PSeq _ _ p1 _ _ p2  -> liftM2 (\p1 p2 -> PSeq 0 Nothing p1 0 Nothing p2) (op p1) (op p2)
+    PRep _ _ p      -> liftM  (PRep 0 Nothing) (op p)
     _               -> return patt -- covers cases without subpatterns
 
 collectOp :: Monoid m => (Term -> m) -> Term -> m
@@ -514,9 +507,8 @@ collectPattOp op patt =
     PImplArg p      -> op p
     PNeg p          -> op p
     PAlt p1 p2      -> op p1++op p2
-    PSeq p1 p2      -> op p1++op p2
-    PMSeq (_,p1) (_,p2) -> op p1++op p2
-    PRep p          -> op p
+    PSeq _ _ p1 _ _ p2 -> op p1++op p2
+    PRep _ _ p      -> op p
     _               -> []     -- covers cases without subpatterns
 
 

src/compiler/GF/Grammar/Parser.y

@@ -132,14 +132,14 @@ ModDef
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       jments <- mapM (checkInfoType mtype) jments
                                       defs <- buildAnyTree id jments
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -267,7 +267,7 @@ DataDef
 ParamDef :: { [(Ident,Info)] }
 ParamDef
   : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
-                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
+                                           [(f, ResValue (L loc (mkProdSimple co (Cn $2))) 0) | L loc (f,co) <- $4] }
   | Posn LhsIdent                   Posn { [($2, ResParam Nothing Nothing)] }
 
 OperDef :: { [(Ident,Info)] }
@@ -444,7 +444,7 @@ Exp4
   | 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 }
   | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 }
   | 'strs' '{' ListExp '}'           { Strs $3       }
-  | '#' Patt3                        { EPatt $2      }
+  | '#' Patt3                        { EPatt 0 Nothing $2 }
   | 'pattern' Exp5                   { EPattType $2  }
   | 'lincat' Ident Exp5              { ELincat $2 $3 }
   | 'lin' Ident Exp5                 { ELin $2 $3 }
@@ -485,14 +485,14 @@ Exps
 Patt :: { Patt }
 Patt
   : Patt '|' Patt1            { PAlt $1 $3 } 
-  | Patt '+' Patt1            { PSeq $1 $3 }
+  | Patt '+' Patt1            { PSeq 0 Nothing $1 0 Nothing $3 }
   | Patt1                     { $1         }
 
 Patt1 :: { Patt }
 Patt1
   : Ident ListPatt            { PC $1 $2 } 
   | ModuleName '.' Ident ListPatt  { PP ($1,$3) $4 }
-  | Patt3 '*'                 { PRep $1 }
+  | Patt3 '*'                 { PRep 0 Nothing $1 }
   | Patt2                     { $1 }
 
 Patt2 :: { Patt }
@@ -774,7 +774,7 @@ checkInfoType mt jment@(id,info) =
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
-    ResValue ty          -> ifResource mt (locL ty)
+    ResValue ty _        -> ifResource mt (locL ty)
     ResOper  pty pt      -> ifOper mt pty pt
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where

src/compiler/GF/Grammar/PatternMatch.hs

@@ -15,8 +15,7 @@
 module GF.Grammar.PatternMatch (
                                 matchPattern,
                                 testOvershadow,
-                                findMatch,
-                                measurePatt
+                                findMatch
                                ) where
 
 import GF.Data.Operations
@@ -25,7 +24,7 @@ import GF.Infra.Ident
 import GF.Grammar.Macros
 --import GF.Grammar.Printer
 
---import Data.List
+import Data.Maybe(fromMaybe)
 import Control.Monad
 import GF.Text.Pretty
 --import Debug.Trace
@@ -122,11 +121,10 @@ tryMatch (p,t) = do
         Bad _ -> return []
         _ -> raise (render ("no match with negative pattern" <+> p))
 
-      (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
-      (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
+      (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
 
-      (PRep p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq p1)) (PString "")
+      (PRep _ _ p1, ([],K s, [])) -> checks [
+         trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
            [1..n]) t' | n <- [0 .. length s]
         ] >>
         return []
@@ -140,50 +138,14 @@ tryMatch (p,t) = do
   words2term [w]    = K w
   words2term (w:ws) = C (K w) (words2term ws)
 
-
-matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
---matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
-matchPSeq p1 p2 s = matchPSeq' (lengthBounds p1) p1 (lengthBounds p2) p2 s
-
-matchPSeq' b1@(min1,max1) p1 b2@(min2,max2) p2 s =
+matchPSeq min1 max1 p1 min2 max2 p2 s =
   do let n = length s
-         lo = min1 `max` (n-max2)
-         hi = (n-min2) `min` max1
+         lo = min1 `max` (n-fromMaybe n max2)
+         hi = (n-min2) `min` (fromMaybe n max1)
          cuts = [splitAt i s | i <- [lo..hi]]
      matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
      return (concat matches)
 
--- | Estimate the minimal length of the string that a pattern will match
-minLength = matchLength 0 id (+) min -- safe underestimate
-
--- | Estimate the maximal length of the string that a pattern will match
-maxLength =
-    maybe maxBound id . matchLength Nothing Just (liftM2 (+)) (liftM2 max)
-        -- safe overestimate
-
-matchLength unknown known seq alt = len
-  where
-    len p =
-      case p of
-        PString s  -> known (length s)
-        PSeq p1 p2 -> seq (len p1) (len p2)
-        PAlt p1 p2 -> alt (len p1) (len p2)
-        PChar      -> known 1
-        PChars _   -> known 1
-        PAs x p'   -> len p'
-        PT t p'    -> len p'
-        _          -> unknown
-
-lengthBounds p = (minLength p,maxLength p)
-
-mPatt p = (lengthBounds p,measurePatt p)
-
-measurePatt p =
-  case p of
-    PSeq p1 p2 -> PMSeq (mPatt p1) (mPatt p2)
-    _ -> composSafePattOp measurePatt p
-
-
 isInConstantForm :: Term -> Bool
 isInConstantForm trm = case trm of
     Cn _     -> True

src/compiler/GF/Grammar/Predef.hs

@@ -61,7 +61,6 @@ cRead = identS "read"
 cToStr = identS "toStr"
 cMapStr = identS "mapStr"
 cError = identS "error"
-cTrace = identS "trace"
 
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!

src/compiler/GF/Grammar/Printer.hs

@@ -24,8 +24,8 @@ module GF.Grammar.Printer
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import PGF2 as PGF2
-import PGF2.Internal as PGF2
+import PGF2(Literal(..))
+import PGF2.Transactions(LIndex,LParam,Symbol(..))
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
@@ -35,9 +35,8 @@ import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
 import qualified Data.Map as Map
---import qualified Data.IntMap as IntMap
---import qualified Data.Set as Set
 import qualified Data.Array.IArray as Array
+import qualified GHC.Show
 
 data TermPrintQual
   = Terse | Unqualified | Qualified | Internal
@@ -47,11 +46,10 @@ instance Pretty Grammar where
   pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
     hdr $$
     nest 2 (ppOptions opts $$
-            vcat (map (ppJudgement q) (Map.toList jments)) $$
-            maybe empty (ppSequences q) mseqs) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -110,10 +108,10 @@ ppJudgement q (id, ResParam pparams _) =
   (case pparams of
      Just (L _ ps) -> '=' <+> ppParams q ps
      _             -> empty) <+> ';'
-ppJudgement q (id, ResValue pvalue) =
+ppJudgement q (id, ResValue pvalue idx) =
   "-- param constructor" <+> id <+> ':' <+>
   (case pvalue of
-     (L _ ty) -> ppTerm q 0 ty) <+> ';'
+     (L _ ty) -> ppTerm q 0 ty) <+> ';' <+> parens (pp "index = " <> pp idx)
 ppJudgement q (id, ResOper  ptype pexp) =
   "oper" <+> id <+>
   (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
@@ -123,8 +121,8 @@ ppJudgement q (id, ResOverload ids defs) =
   ("overload" <+> '{' $$
    nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
    '}') <+> ';'
-ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
-  (case pcat of
+ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
+  (case mtyp of
      Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pdef of
@@ -136,17 +134,13 @@ ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
-  (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
+  (case (mtyp,mpmcfg,q) of
+     (Just (L _ typ),Just rules,Internal)
+                    -> "pmcfg" <+> '{' $$
+                       nest 2 (vcat (map (ppPmcfgRule id [] id) rules)) $$
                        '}'
      _              -> empty)
-ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
+ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
   (case pdef of
      Just (L _ e) -> let (xs,e') = getAbs e
                      in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
@@ -154,14 +148,10 @@ ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
-  (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
+  (case (mtyp,mpmcfg,q) of
+     (Just (args,res,_,_),Just rules,Internal)
+                    -> "pmcfg" <+> '{' $$
+                       nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, AnyInd cann mid) =
@@ -169,6 +159,13 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
+ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) =
+  pp id <+> (':' <+> hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->" <+> ppPmcfgCat res_cat res $$
+             '=' <+> brackets (vcat (map (hsep . map ppSymbol) lins)))
+
+ppPmcfgCat :: Ident -> PMCFGCat -> Doc
+ppPmcfgCat cat (PMCFGCat r rs) = pp cat <> parens (ppLinFun ppLParam r rs)
+
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -213,7 +210,7 @@ ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (m
 ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
 ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p)
 ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
 ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
 ppTerm q d (Cn id)     = pp id
@@ -241,7 +238,7 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
 ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
+ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun pp r rs <> pp '>'
 
 ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
@@ -250,15 +247,14 @@ ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
 instance Pretty Patt where pp = ppPatt Unqualified 0
 
 ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
-ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq _ _ p1 _ _ p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
 ppPatt q d (PC f ps)    = if null ps
                             then pp f
                             else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
 ppPatt q d (PP f ps)    = if null ps
                             then ppQIdent q f
                             else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PRep _ _ p) = prec d 1 (ppPatt q 3 p <> '*')
 ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
 ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
 ppPatt q d (PChar)      = pp '?'
@@ -290,7 +286,12 @@ ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue
 ppEnv :: Env -> Doc
 ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
 
-str s = doubleQuotes s
+str s = doubleQuotes (pp (foldr showLitChar "" s))
+  where
+    showLitChar c
+      | c == '"'    = showString "\\\""
+      | c > '\DEL'  = showChar c
+      | otherwise   = GHC.Show.showLitChar c
 
 ppDecl q (_,id,typ)
   | id == identW = ppTerm q 3 typ
@@ -328,18 +329,6 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
 ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 
-ppProduction (Production fid funid args) =
-  ppFId fid <+> "->" <+> ppFunId funid <>
-  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
-
-ppSequences q seqsArr
-  | null seqs || q /= Internal = empty
-  | otherwise                  = "sequences" <+> '{' $$
-                                 nest 2 (vcat (map ppSeq seqs)) $$
-                                 '}'
-  where
-    seqs = Array.assocs seqsArr
-
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
@@ -363,39 +352,40 @@ getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
 
-ppFunId funid = pp 'F' <> pp funid
-ppSeqId seqid = pp 'S' <> pp seqid
-
-ppFId fid
-  | fid == PGF2.fidString = pp "CString"
-  | fid == PGF2.fidInt    = pp "CInt"
-  | fid == PGF2.fidFloat  = pp "CFloat"
-  | fid == PGF2.fidVar    = pp "CVar"
-  | fid == PGF2.fidStart  = pp "CStart"
-  | otherwise             = pp 'C' <> pp fid
-
 ppMeta :: Int -> Doc
 ppMeta n
   | n == 0    = pp '?'
   | otherwise = pp '?' <> pp n
 
-ppLit (PGF2.LStr s) = pp (show s)
-ppLit (PGF2.LInt n) = pp n
-ppLit (PGF2.LFlt d) = pp d
+ppLit (LStr s) = pp (show s)
+ppLit (LInt n) = pp n
+ppLit (LFlt d) = pp d
 
-ppSeq (seqid,seq) = 
-  ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
+ppSymbol (SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppLParam r rs <> pp '>'
+ppSymbol (SymLit d r)   = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
+ppSymbol (SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
+ppSymbol (SymKS t)      = doubleQuotes (pp t)
+ppSymbol SymNE          = pp "nonExist"
+ppSymbol SymBIND        = pp "BIND"
+ppSymbol SymSOFT_BIND   = pp "SOFT_BIND"
+ppSymbol SymSOFT_SPACE  = pp "SOFT_SPACE"
+ppSymbol SymCAPIT       = pp "CAPIT"
+ppSymbol SymALL_CAPIT   = pp "ALL_CAPIT"
+ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
 
-ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
-ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
-ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
-ppSymbol (PGF2.SymKS t)    = doubleQuotes (pp t)
-ppSymbol PGF2.SymNE        = pp "nonExist"
-ppSymbol PGF2.SymBIND      = pp "BIND"
-ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
-ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
-ppSymbol PGF2.SymCAPIT     = pp "CAPIT"
-ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
-ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
+ppLinFun ppParam r rs
+  | r == 0 && not (null rs) = hcat (intersperse (pp '+') (       map ppTerm rs))
+  | otherwise               = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
+  where
+    ppTerm (i,p)
+      | i == 1    = ppParam p
+      | otherwise = pp i <> pp '*' <> ppParam p
+
+ppLParam p
+  | i == 0    = pp (chars !! j)
+  | otherwise = pp (chars !! j : show i)
+  where
+    chars = "ijklmnopqr"
+    (i,j) = p `divMod` (length chars)
 
 ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/compiler/GF/Infra/CheckM.hs

@@ -13,10 +13,10 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.CheckM
-          (Check, CheckResult, Message, runCheck, runCheck',
+          (Check, CheckResult(..), Message, runCheck, runCheck',
            checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
            checkIn, checkInModule, checkMap, checkMapRecover,
-           parallelCheck, accumulateError, commitCheck,
+           accumulateError, commitCheck,
           ) where
 
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
@@ -118,39 +118,15 @@ runCheck' opts c =
     list = vcat . reverse
     wlist ws = if verbAtLeast opts Normal then list ws else empty
 
-parallelCheck :: [Check a] -> Check [a]
-parallelCheck cs =
-  Check $ \ {-ctxt-} (es0,ws0) ->
-  let os = [unCheck c {-[]-} ([],[])|c<-cs] `using` parList rseq
-      (msgs1,crs) = unzip os
-      (ess,wss) = unzip msgs1
-      rs = [r | Success r<-crs]
-      fs = [f | Fail f<-crs]
-      msgs = (concat ess++es0,concat wss++ws0)
-  in if null fs
-     then (msgs,Success rs)
-     else (msgs,Fail (vcat $ reverse fs))
-
 checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
 checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
                                              return (k,v)) (Map.toList map)
                     return (Map.fromAscList xs)
 
 checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
-checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
+checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
   where f' (k,v) = fmap ((,)k) (f k v)
 
-{-
-checkMapRecover f mp = do
-  let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
-  case [s | (_,Bad s) <- xs] of
-    ss@(_:_) -> checkError (text (unlines ss))
-    _   -> do
-      let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
-      if not (all null ss) then checkWarn (text (unlines ss)) else return ()
-      return (Map.fromAscList kx)
--}
-
 checkIn :: Doc -> Check a -> Check a
 checkIn msg c = Check $ \{-ctxt-} msgs0 ->
     case unCheck c {-ctxt-} ([],[]) of

src/compiler/GF/Infra/Option.hs

@@ -35,7 +35,7 @@ import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
 import System.FilePath
-import PGF2.Internal(Literal(..))
+import PGF2(Literal(..))
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
@@ -152,6 +152,7 @@ data Flags = Flags {
       optVerbosity       :: Verbosity,
       optShowCPUTime     :: Bool,
       optOutputFormats   :: [OutputFormat],
+      optLinkTargets     :: (Bool,Bool), -- pgf,ngf files
       optSISR            :: Maybe SISRFormat,
       optHaskellOptions  :: Set HaskellOption,
       optLexicalCats     :: Set String,
@@ -262,6 +263,7 @@ defaultFlags = Flags {
       optVerbosity       = Normal,
       optShowCPUTime     = False,
       optOutputFormats   = [],
+      optLinkTargets     = (True,False),
       optSISR            = Nothing,
       optHaskellOptions  = Set.empty,
       optLiteralCats     = Set.fromList [cString,cInt,cFloat,cVar],
@@ -320,6 +322,8 @@ optDescr =
      Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
      Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
      Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
+     Option [] ["boot"] (NoArg (set $ \o -> o {optLinkTargets = (True,True)})) "Boot an .ngf database for fast grammar reloading",
+     Option [] ["boot-only"] (NoArg (set $ \o -> o {optLinkTargets = (False,True)})) "Boot the .ngf database and don't write a .pgf file",
      Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
      Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
 --   Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",

src/compiler/GF/Infra/SIO.hs

@@ -24,12 +24,14 @@ import Control.Applicative(Applicative(..))
 import Control.Monad(liftM,ap)
 import Control.Monad.Trans(MonadTrans(..))
 import System.IO(hPutStr,hFlush,stdout)
+import System.IO.Error(isUserError,ioeGetErrorString)
 import GF.System.Catch(try)
 import System.Process(system)
 import System.Environment(getEnv)
 import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
 import GF.Infra.Concurrency(lazyIO)
 import GF.Infra.UseIO(Output(..))
+import GF.Data.Operations(ErrorMonad(..))
 import qualified System.CPUTime as IO(getCPUTime)
 import qualified System.Directory as IO(getCurrentDirectory)
 import qualified System.Random as IO(newStdGen)
@@ -37,6 +39,7 @@ import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
 import qualified Control.Monad.Fail as Fail
+import Control.Exception
 
 -- * The SIO monad
 
@@ -62,6 +65,14 @@ instance Output SIO where
   putStrLnE = putStrLnFlush
   putStrE = putStr
 
+instance ErrorMonad SIO where
+  raise = fail
+  handle m h = SIO $ \putStr ->
+                 catch (unS m putStr) $
+                    \e -> if isUserError e
+                            then unS (h (ioeGetErrorString e)) putStr
+                            else ioError e
+
 class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
 -- ^ If the Monad m superclass is included, then the generic instance
 -- for monad transformers below would require UndecidableInstances
@@ -96,7 +107,7 @@ restricted io    = SIO (const (restrictedIO io))
 restrictedSystem = restricted . system
 
 restrictedIO io =
-    either (const io) (const $ fail message) =<< try (getEnv "GF_RESTRICTED")
+    either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
   where
     message =
       "This operation is not allowed when GF is running in restricted mode."

src/compiler/GF/Speech/PGFToCFG.hs

@@ -25,7 +25,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
 type Profile = [Int]
 
 pgfToCFG :: PGF -> Concr -> CFG
-pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
+pgfToCFG pgf cnc = error "TODO: pgfToCFG" {- mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
   where
     (_,start_cat,_) = unType (startCat pgf)
 
@@ -116,3 +116,4 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
     ruleToCFRule (c,PCoerce c') =
         [Rule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0)
            | l <- [0..catLinArity c-1]]
+-}

src/programs/gf-main.hs

@@ -1,3 +1,5 @@
+module Main where
+
 import qualified GF
 
 main = GF.main

src/runtime/c/AUTHORS

@@ -1,9 +0,0 @@
-libpgf is written by:
-
-Krasimir Angelov <krasimir@chalmers.se>
-Lauri Alanko <lealanko@ling.helsinki.fi>
-
-with some contributions from:
-
-Prasanth Kolachina <prasanth.kolachina@cse.gu.se>
-Bjørnar Luteberget <luteberget@gmail.com>

src/runtime/c/CMakeLists.txt

@@ -1,91 +0,0 @@
-project(libpgf)
-cmake_minimum_required(VERSION 2.8)
-
-set(GNU_LIGHTNING_ARCH "i386" CACHE STRING "Target architecture for GNU Lightning JIT")
-#set(ADD_CFLAGS "-Wall -Wextra -Wno-missing-field-initializers -Wno-unused-parameter -Wno-unused-value" CACHE STRING "Additional C compiler options")
-#set(CMAKE_SHARED_LINKER_FLAGS "${CMAKE_SHARED_LINKER_FLAGS} -Wl,-no-undefined")
-set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -std=gnu99 ${ADD_CFLAGS}")
-
-set(GNU_LIGHTNING_ARCH_HEADERS
-  pgf/lightning/${GNU_LIGHTNING_ARCH}/asm.h
-  pgf/lightning/${GNU_LIGHTNING_ARCH}/fp.h
-  pgf/lightning/${GNU_LIGHTNING_ARCH}/core.h
-  pgf/lightning/${GNU_LIGHTNING_ARCH}/funcs.h
-)
-
-file(COPY        ${GNU_LIGHTNING_ARCH_HEADERS}
-     DESTINATION ${CMAKE_CURRENT_SOURCE_DIR}/pgf/lightning/)
-
-
-include_directories(.)
-include_directories(./pgf)
-
-
-set(libgu_la_SOURCES  
-	gu/assert.c 
-	gu/bits.c 
-	gu/choice.c 
-	gu/defs.c 
-	gu/seq.c 
-	gu/enum.c 
-	gu/exn.c 
-	gu/file.c 
-	gu/fun.c 
-	gu/hash.c 
-	gu/in.c 
-	gu/map.c 
-	gu/mem.c 
-	gu/out.c 
-	gu/prime.c 
-	gu/string.c 
-	gu/utf8.c 
-	gu/ucs.c 
-	gu/variant.c
-)
-
-set(libpgf_la_SOURCES 
-	pgf/data.c 
-	pgf/data.h 
-	pgf/expr.c 
-	pgf/expr.h 
-	pgf/parser.c 
-	pgf/lookup.c
-	pgf/jit.c 
-	pgf/parseval.c 
-	pgf/literals.c 
-	pgf/literals.h 
-	pgf/reader.h 
-	pgf/reader.c 
-	pgf/linearizer.c 
-	pgf/typechecker.c 
-	pgf/reasoner.c 
-	pgf/evaluator.c 
-	pgf/hopu.c 
-	pgf/printer.c 
-	pgf/graphviz.c 
-	pgf/aligner.c 
-	pgf/pgf.c 
-	pgf/pgf.h 
-)
-
-set(libsg_la_SOURCES 
-	sg/sqlite3Btree.c 
-	sg/sg.c
-)
-
-
-add_library(gu SHARED ${libgu_la_SOURCES})
-#set_property(TARGET gu PROPERTY C_STANDARD 99)
-#set_property(TARGET gu PROPERTY WINDOWS_EXPORT_ALL_SYMBOLS true)
-target_compile_definitions(gu PRIVATE COMPILING_GU=1)
-
-add_library(pgf SHARED ${libpgf_la_SOURCES})
-#set_property(TARGET pgf PROPERTY C_STANDARD 99)
-#set_property(TARGET pgf PROPERTY WINDOWS_EXPORT_ALL_SYMBOLS true)
-target_compile_definitions(pgf PRIVATE COMPILING_PGF=1)
-target_link_libraries(pgf gu)
-if(UNIX)
-  target_link_libraries(pgf m)
-endif(UNIX)
-
-install(TARGETS gu pgf DESTINATION lib)

src/runtime/c/COPYING.LESSER

@@ -1,165 +0,0 @@
-                   GNU LESSER GENERAL PUBLIC LICENSE
-                       Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-
-  This version of the GNU Lesser General Public License incorporates
-the terms and conditions of version 3 of the GNU General Public
-License, supplemented by the additional permissions listed below.
-
-  0. Additional Definitions.
-
-  As used herein, "this License" refers to version 3 of the GNU Lesser
-General Public License, and the "GNU GPL" refers to version 3 of the GNU
-General Public License.
-
-  "The Library" refers to a covered work governed by this License,
-other than an Application or a Combined Work as defined below.
-
-  An "Application" is any work that makes use of an interface provided
-by the Library, but which is not otherwise based on the Library.
-Defining a subclass of a class defined by the Library is deemed a mode
-of using an interface provided by the Library.
-
-  A "Combined Work" is a work produced by combining or linking an
-Application with the Library.  The particular version of the Library
-with which the Combined Work was made is also called the "Linked
-Version".
-
-  The "Minimal Corresponding Source" for a Combined Work means the
-Corresponding Source for the Combined Work, excluding any source code
-for portions of the Combined Work that, considered in isolation, are
-based on the Application, and not on the Linked Version.
-
-  The "Corresponding Application Code" for a Combined Work means the
-object code and/or source code for the Application, including any data
-and utility programs needed for reproducing the Combined Work from the
-Application, but excluding the System Libraries of the Combined Work.
-
-  1. Exception to Section 3 of the GNU GPL.
-
-  You may convey a covered work under sections 3 and 4 of this License
-without being bound by section 3 of the GNU GPL.
-
-  2. Conveying Modified Versions.
-
-  If you modify a copy of the Library, and, in your modifications, a
-facility refers to a function or data to be supplied by an Application
-that uses the facility (other than as an argument passed when the
-facility is invoked), then you may convey a copy of the modified
-version:
-
-   a) under this License, provided that you make a good faith effort to
-   ensure that, in the event an Application does not supply the
-   function or data, the facility still operates, and performs
-   whatever part of its purpose remains meaningful, or
-
-   b) under the GNU GPL, with none of the additional permissions of
-   this License applicable to that copy.
-
-  3. Object Code Incorporating Material from Library Header Files.
-
-  The object code form of an Application may incorporate material from
-a header file that is part of the Library.  You may convey such object
-code under terms of your choice, provided that, if the incorporated
-material is not limited to numerical parameters, data structure
-layouts and accessors, or small macros, inline functions and templates
-(ten or fewer lines in length), you do both of the following:
-
-   a) Give prominent notice with each copy of the object code that the
-   Library is used in it and that the Library and its use are
-   covered by this License.
-
-   b) Accompany the object code with a copy of the GNU GPL and this license
-   document.
-
-  4. Combined Works.
-
-  You may convey a Combined Work under terms of your choice that,
-taken together, effectively do not restrict modification of the
-portions of the Library contained in the Combined Work and reverse
-engineering for debugging such modifications, if you also do each of
-the following:
-
-   a) Give prominent notice with each copy of the Combined Work that
-   the Library is used in it and that the Library and its use are
-   covered by this License.
-
-   b) Accompany the Combined Work with a copy of the GNU GPL and this license
-   document.
-
-   c) For a Combined Work that displays copyright notices during
-   execution, include the copyright notice for the Library among
-   these notices, as well as a reference directing the user to the
-   copies of the GNU GPL and this license document.
-
-   d) Do one of the following:
-
-       0) Convey the Minimal Corresponding Source under the terms of this
-       License, and the Corresponding Application Code in a form
-       suitable for, and under terms that permit, the user to
-       recombine or relink the Application with a modified version of
-       the Linked Version to produce a modified Combined Work, in the
-       manner specified by section 6 of the GNU GPL for conveying
-       Corresponding Source.
-
-       1) Use a suitable shared library mechanism for linking with the
-       Library.  A suitable mechanism is one that (a) uses at run time
-       a copy of the Library already present on the user's computer
-       system, and (b) will operate properly with a modified version
-       of the Library that is interface-compatible with the Linked
-       Version.
-
-   e) Provide Installation Information, but only if you would otherwise
-   be required to provide such information under section 6 of the
-   GNU GPL, and only to the extent that such information is
-   necessary to install and execute a modified version of the
-   Combined Work produced by recombining or relinking the
-   Application with a modified version of the Linked Version. (If
-   you use option 4d0, the Installation Information must accompany
-   the Minimal Corresponding Source and Corresponding Application
-   Code. If you use option 4d1, you must provide the Installation
-   Information in the manner specified by section 6 of the GNU GPL
-   for conveying Corresponding Source.)
-
-  5. Combined Libraries.
-
-  You may place library facilities that are a work based on the
-Library side by side in a single library together with other library
-facilities that are not Applications and are not covered by this
-License, and convey such a combined library under terms of your
-choice, if you do both of the following:
-
-   a) Accompany the combined library with a copy of the same work based
-   on the Library, uncombined with any other library facilities,
-   conveyed under the terms of this License.
-
-   b) Give prominent notice with the combined library that part of it
-   is a work based on the Library, and explaining where to find the
-   accompanying uncombined form of the same work.
-
-  6. Revised Versions of the GNU Lesser General Public License.
-
-  The Free Software Foundation may publish revised and/or new versions
-of the GNU Lesser General Public License from time to time. Such new
-versions will be similar in spirit to the present version, but may
-differ in detail to address new problems or concerns.
-
-  Each version is given a distinguishing version number. If the
-Library as you received it specifies that a certain numbered version
-of the GNU Lesser General Public License "or any later version"
-applies to it, you have the option of following the terms and
-conditions either of that published version or of any later version
-published by the Free Software Foundation. If the Library as you
-received it does not specify a version number of the GNU Lesser
-General Public License, you may choose any version of the GNU Lesser
-General Public License ever published by the Free Software Foundation.
-
-  If the Library as you received it specifies that a proxy can decide
-whether future versions of the GNU Lesser General Public License shall
-apply, that proxy's public statement of acceptance of any version is
-permanent authorization for you to choose that version for the
-Library.

src/runtime/c/INSTALL

@@ -1,63 +0,0 @@
-General Note
-------------
-
-If you want to use the statistical ranking in the parser then you
-have to compile your grammar with the option '-probs=grammar.probs',
-where grammar.probs must contain a tab separated file with
-the probabilities for all functions in the abstract syntax.
-In order to enable the named entity recongizer for the ParseEngAbs
-grammar you also have to add the option '-literal=Symb' while compiling.
-
-
-For Linux users
----------------
-
-You will need the packages: autoconf, automake, libtool, make
-
-- On Ubuntu: $ apt-get install autotools-dev
-- On Fedora: $ dnf install autoconf automake libtool
-
-The compilation steps are:
-
-$ autoreconf -i
-$ ./configure
-$ make
-$ make install
-
-
-For Mac OSX users
------------------
-
-The following is what I did to make it work on MacOSX 10.8:
-
-- Install XCode and XCode command line tools
-- Install Homebrew: https://brew.sh
-
-$ brew install automake autoconf libtool
-$ glibtoolize
-$ autoreconf -i
-$ ./configure
-$ make
-$ make install
-
-
-For Windows users
------------------
-
-- Install MinGW: http://www.mingw.org/. From the installer you need
-  to select at least the following packages:
-     - Mingw-developer-toolkit
-     - Mingw-base
-     - Msys-base
-  After the installation, don't forget to fix the fstab file. See here:
-     http://www.mingw.org/wiki/Getting_Started
-
-- From the MSYS shell (c:/MinGW/msys/1.0/msys.bat) go to the directory
-  which contains the INSTALL file and do:
-
-  $ autoreconf -i
-  $ ./configure
-  $ make
-  $ make install
-
-  The compiled binaries should be now in c:/MinGW/msys/1.0/local/bin.

src/runtime/c/Makefile.am

@@ -1,92 +1,35 @@
-lib_LTLIBRARIES = libgu.la libpgf.la
+lib_LTLIBRARIES = libpgf.la
 
 pkgconfigdir = $(libdir)/pkgconfig
-pkgconfig_DATA = libgu.pc libpgf.pc
-
-configincludedir = $(libdir)/libgu/include
-
-guincludedir=$(includedir)/gu
-guinclude_HEADERS = \
-	gu/assert.h \
-	gu/bits.h \
-	gu/choice.h \
-	gu/defs.h \
-	gu/enum.h \
-	gu/exn.h \
-	gu/file.h \
-	gu/fun.h \
-	gu/hash.h \
-	gu/in.h \
-	gu/map.h \
-	gu/mem.h \
-	gu/out.h \
-	gu/prime.h \
-	gu/seq.h \
-	gu/string.h \
-	gu/sysdeps.h \
-	gu/ucs.h \
-	gu/utf8.h \
-	gu/variant.h
+pkgconfig_DATA = libpgf.pc
 
 pgfincludedir=$(includedir)/pgf
 pgfinclude_HEADERS = \
-	pgf/expr.h \
-	pgf/linearizer.h \
-	pgf/literals.h \
-	pgf/graphviz.h \
-	pgf/pgf.h \
-	pgf/data.h
-
-libgu_la_SOURCES = \
-	gu/assert.c \
-	gu/bits.c \
-	gu/choice.c \
-	gu/defs.c \
-	gu/seq.c \
-	gu/enum.c \
-	gu/exn.c \
-	gu/file.c \
-	gu/fun.c \
-	gu/hash.c \
-	gu/in.c \
-	gu/map.c \
-	gu/mem.c \
-	gu/out.c \
-	gu/prime.c \
-	gu/string.c \
-	gu/utf8.c \
-	gu/ucs.c \
-	gu/variant.c
-libgu_la_LDFLAGS = -no-undefined
+	pgf/pgf.h
 
 libpgf_la_SOURCES = \
-	pgf/data.c \
-	pgf/data.h \
-	pgf/expr.c \
-	pgf/expr.h \
-	pgf/scanner.c \
-	pgf/parser.c \
-	pgf/lookup.c \
-	pgf/jit.c \
-	pgf/parseval.c \
-	pgf/literals.c \
-	pgf/literals.h \
+	pgf/db.cxx \
+	pgf/db.h \
+	pgf/ipc.cxx \
+	pgf/ipc.h \
+	pgf/text.cxx \
+	pgf/text.h \
+	pgf/pgf.cxx \
+	pgf/reader.cxx \
 	pgf/reader.h \
-	pgf/reader.c \
+	pgf/writer.cxx \
 	pgf/writer.h \
-	pgf/writer.c \
-	pgf/linearizer.c \
-	pgf/typechecker.c \
-	pgf/reasoner.c \
-	pgf/evaluator.c \
-	pgf/hopu.c \
-	pgf/printer.c \
-	pgf/graphviz.c \
-	pgf/aligner.c \
-	pgf/pgf.c \
-	pgf/pgf.h \
-libpgf_la_LDFLAGS = "-no-undefined"
-libpgf_la_LIBADD = libgu.la
+	pgf/printer.cxx \
+	pgf/printer.h \
+	pgf/data.cxx \
+	pgf/data.h \
+	pgf/expr.cxx \
+	pgf/expr.h \
+	pgf/namespace.h
+
+libpgf_la_LDFLAGS = -no-undefined
+# libpgf_la_LIBADD = -lrt
+libpgf_la_CXXFLAGS = -fno-rtti -std=c++11
 
 bin_PROGRAMS =
 
@@ -94,5 +37,4 @@ AUTOMAKE_OPTIONS = foreign subdir-objects dist-bzip2
 ACLOCAL_AMFLAGS = -I m4
 
 EXTRA_DIST = \
-	libgu.pc.in \
 	libpgf.pc.in

src/runtime/c/README.md

@@ -0,0 +1,42 @@
+# "Majestic" C Runtime
+
+## Requirements
+
+### Debian/Ubuntu
+
+Required system packages (`apt install ...`):
+```
+autoconf
+automake
+libtool
+make
+g++
+```
+
+### macOS
+
+- Install XCode from App Store
+- Install XCode command line tools: `xcode-select --install`
+- Required system packages (`brew install ...`):
+```
+autoconf
+automake
+libtool
+```
+
+## Installation
+
+**Note for macOS**: you should first run `glibtoolize`, followed by the commands below.
+
+```
+autoreconf -i
+./configure
+make
+make install
+```
+The shared libraries are installed in `/usr/local/lib`.
+
+## Using
+
+- Compiling GF with this runtime will require flag `--extra-lib-dirs=/usr/local/lib`.
+- Running GF with this runtime will require environment variable `LD_LIBRARY_PATH=/usr/local/lib`

src/runtime/c/configure.ac

@@ -1,9 +1,8 @@
-AC_INIT(Portable Grammar Format library, 0.1-pre, 
+AC_INIT(Portable Grammar Format library, 3.0-pre,
 		 http://www.grammaticalframework.org/, 
 		 libpgf)
 AC_PREREQ(2.58)
 
-AC_CONFIG_SRCDIR([gu/mem.c])
 AC_CONFIG_AUX_DIR([scripts])
 AC_CONFIG_MACRO_DIR([m4])
 
@@ -18,12 +17,11 @@ AC_CONFIG_HEADERS([config.h])
 
 AM_MAINTAINER_MODE([enable])
 AC_CHECK_LIB(m,nan)
+AC_CHECK_LIB(rt,nan)
 AC_PROG_MAKE_SET
 AC_PROG_INSTALL
 AC_PROG_LIBTOOL
-AC_PROG_CC
-AC_PROG_CC_C99
-AM_PROG_CC_C_O
+AC_PROG_CXX
 
 [if [ "x$GCC" = "xyes" ]; then
   CFLAGS="$CFLAGS\
@@ -34,29 +32,7 @@ AM_PROG_CC_C_O
  -Wno-unused-value"
 fi]
 
-case "$target_cpu" in
-	i?86)	 cpu=i386; AC_DEFINE(LIGHTNING_I386, 1,
-		   [Define if lightning is targeting the x86 architecture]) ;;
-	x86_64)	 cpu=i386; AC_DEFINE(LIGHTNING_I386, 1,
-		   [Define if lightning is targeting the x86 architecture]) ;;
-	sparc*)	 cpu=sparc; AC_DEFINE(LIGHTNING_SPARC, 1,
-		   [Define if lightning is targeting the sparc architecture]) ;;
-	powerpc) cpu=ppc; AC_DEFINE(LIGHTNING_PPC, 1,
-		   [Define if lightning is targeting the powerpc architecture]) ;;
-    arm*)    cpu=arm; AC_DEFINE(LIGHTNING_ARM, 1,
-		   [Define if lightning is targeting the arm architecture]) ;;
-	*)	 AC_MSG_ERROR([cpu $target_cpu not supported])	;;
-esac
-
-cpu_dir=pgf/lightning/$cpu
-AC_CONFIG_LINKS(pgf/lightning/asm.h:$cpu_dir/asm.h			dnl
-                pgf/lightning/fp.h:$cpu_dir/fp.h			dnl
-                pgf/lightning/core.h:$cpu_dir/core.h		dnl
-                pgf/lightning/funcs.h:$cpu_dir/funcs.h, [],
-  [cpu_dir=$cpu_dir])
-
 AC_CONFIG_FILES([Makefile
-	         libgu.pc
 		 libpgf.pc
 		 ])
 

src/runtime/c/gu/assert.c

@@ -1,52 +0,0 @@
-#include <gu/assert.h>
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-
-static const char*
-gu_assert_mode_descs[] = {
-	[GU_ASSERT_PRECOND] = "precondition failed",
-	[GU_ASSERT_POSTCOND] = "postcondition failed",
-	[GU_ASSERT_ASSERTION] = "assertion failed",
-	[GU_ASSERT_NEVER] = "control should not reach here",
-};
-
-GU_API void
-gu_abort_v_(GuAssertMode mode,
-	    const char* file, const char* func, int line,
-	    const char* msg_fmt, va_list args)
-{
-	const char* desc = gu_assert_mode_descs[mode];
-	(void) fprintf(stderr, "%s (%s:%d): %s\n", func, file, line, desc);
-	if (msg_fmt != NULL) {
-		(void) fputc('\t', stderr);
-		(void) vfprintf(stderr, msg_fmt, args);
-		(void) fputc('\n', stderr);
-	}
-	abort();
-}
-
-GU_API void
-gu_abort_(GuAssertMode mode,
-	  const char* file, const char* func, int line,
-	  const char* msg_fmt, ...)
-{
-	va_list args;
-	va_start(args, msg_fmt);
-	gu_abort_v_(mode, file, func, line, msg_fmt, args);
-	va_end(args);
-}
-
-GU_API void 
-gu_fatal(const char* fmt, ...)
-{
-	va_list args;
-	va_start(args, fmt);
-	fputs("Fatal error", stderr);
-	if (fmt) {
-		fputs(": ", stderr);
-		(void) vfprintf(stderr, fmt, args);
-	}
-	fputc('\n', stderr);
-	abort();
-}

src/runtime/c/gu/assert.h

@@ -1,61 +0,0 @@
-#ifndef GU_ASSERT_H_
-#define GU_ASSERT_H_
-
-#include <gu/defs.h>
-
-typedef enum {
-	GU_ASSERT_PRECOND,
-	GU_ASSERT_ASSERTION,
-	GU_ASSERT_POSTCOND,
-	GU_ASSERT_NEVER
-} GuAssertMode;
-
-GU_API_DECL void
-gu_abort_v_(GuAssertMode mode, 
-	    const char* file, const char* func, int line,
-	    const char* msg_fmt, va_list args);
-
-GU_API_DECL void
-gu_abort_(GuAssertMode mode, 
-	  const char* file, const char* func, int line,
-	  const char* msg_fmt, ...);
-
-#ifndef NDEBUG
-#define gu_assertion_(mode_, expr_, ...) \
-	GU_BEGIN							\
-	if (!(expr_)) {							\
-		gu_abort_(mode_, __FILE__, __func__, __LINE__, __VA_ARGS__);	\
-	}								\
-	GU_END
-#else
-// this should prevent unused variable warnings when a variable is only used
-// in an assertion
-#define gu_assertion_(mode_, expr_, ...)	\
-	GU_BEGIN				\
-	(void) (sizeof (expr_));		\
-	GU_END
-#endif
-
-
-#define gu_require(expr)				\
-	gu_assertion_(GU_ASSERT_PRECOND, expr, "%s", #expr)
-
-#define gu_assert_msg(expr, ...)				\
-	gu_assertion_(GU_ASSERT_ASSERTION, expr, __VA_ARGS__)
-
-#define gu_assert(expr)				\
-	gu_assert_msg(expr, "%s", #expr)
-
-#define gu_ensure(expr)						\
-	gu_assertion_(GU_ASSERT_POSTCOND, expr, "%s", #expr)
-
-#define gu_impossible_msg(...)			\
-	gu_assertion_(GU_ASSERT_ASSERTION, false, __VA_ARGS__)
-
-#define gu_impossible()				\
-	gu_impossible_msg(NULL)
-
-GU_API_DECL void
-gu_fatal(const char* fmt, ...);
-
-#endif /* GU_ASSERT_H_ */

src/runtime/c/gu/bits.c

@@ -1,76 +0,0 @@
-#include <gu/bits.h>
-
-#include <limits.h>
-#include <inttypes.h>
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include <math.h>
-
-GU_INTERNAL unsigned
-gu_ceil2e(unsigned u)  
-{
-	u--;
-	u |= u >> 1;
-	u |= u >> 2;
-	u |= u >> 4;
-	u |= u >> 8;
-#if UINT_MAX > UINT16_MAX
-	u |= u >> 16;
-#endif
-#if UINT_MAX > UINT32_MAX
-	u |= u >> 32;
-#endif
-	u++;
-	return u;
-}
-
-GU_INTERNAL double
-gu_decode_double(uint64_t u)
-{
-	bool sign = u >> 63;
-	unsigned rawexp = u >> 52 & 0x7ff;
-	uint64_t mantissa = u & 0xfffffffffffff;
-	double ret;
-
-	if (rawexp == 0x7ff) {
-		ret = (mantissa == 0) ? INFINITY : NAN;
-	} else {
-		uint64_t m = rawexp ? 1ULL << 52 | mantissa : mantissa << 1;
-		ret = ldexp((double) m, rawexp - 1075);
-	}
-	return sign ? copysign(ret, -1.0) : ret;
-}
-
-GU_INTERNAL uint64_t
-gu_encode_double(double d)
-{
-	int sign = signbit(d) > 0;
-	unsigned rawexp;
-	uint64_t mantissa;
-
-	switch (fpclassify(d)) {
-	case FP_NAN:
-		rawexp   = 0x7ff;
-		mantissa = 1;
-		break;
-	case FP_INFINITE:
-		rawexp   = 0x7ff;
-		mantissa = 0;
-		break;
-	default: {
-		int exp;
-		mantissa = (uint64_t) scalbn(frexp(d, &exp), 53);
-		mantissa &= ~ (1ULL << 52);
-		exp -= 53;
-
-		rawexp = exp + 1075;
-	}
-	}
-
-    uint64_t u = (((uint64_t) sign) << 63) |
-                 (((uint64_t) rawexp & 0x7ff) << 52) |
-                 mantissa;
-
-	return u;
-}

src/runtime/c/gu/bits.h

@@ -1,150 +0,0 @@
-#ifndef GU_BITS_H_
-#define GU_BITS_H_
-
-#include <gu/defs.h>
-#include <gu/assert.h>
-
-
-#define GU_WORD_BITS (sizeof(GuWord) * CHAR_BIT)
-
-
-/*
- * Based on the Bit Twiddling Hacks collection by Sean Eron Anderson
- * <http://graphics.stanford.edu/~seander/bithacks.html>
- */
-
-GU_INTERNAL_DECL
-unsigned gu_ceil2e(unsigned i);
-
-static inline int
-gu_sign(int i) {
-	return (i > 0) - (i < 0);
-}
-
-static inline size_t
-gu_ceildiv(size_t size, size_t div)
-{
-	return (size + div - 1) / div;
-}
-
-static inline bool
-gu_aligned(uintptr_t addr, size_t alignment)
-{
-	//gu_require(alignment == gu_ceil2e(alignment));
-	return (addr & (alignment - 1)) == 0;
-}
-
-static inline uintptr_t
-gu_align_forward(uintptr_t addr, size_t alignment) {
-	//gu_require(alignment == gu_ceil2e(alignment));
-	uintptr_t mask = alignment - 1;
-	return (addr + mask) & ~mask;
-}
-
-static inline uintptr_t
-gu_align_backward(uintptr_t addr, size_t alignment) {
-	//gu_require(alignment == gu_ceil2e(alignment));
-	return addr & ~(alignment - 1);
-}
-
-static inline bool
-gu_bits_test(const GuWord* bitmap, int idx) {
-	return !!(bitmap[idx / GU_WORD_BITS] & 1 << (idx % GU_WORD_BITS));
-}
-
-static inline void
-gu_bits_set(GuWord* bitmap, int idx) {
-	bitmap[idx / GU_WORD_BITS] |= ((GuWord) 1) << (idx % GU_WORD_BITS);
-}
-
-static inline void
-gu_bits_clear(GuWord* bitmap, int idx) {
-	bitmap[idx / GU_WORD_BITS] &= ~(((GuWord) 1) << (idx % GU_WORD_BITS));
-}
-
-static inline size_t
-gu_bits_size(size_t n_bits) {
-	return gu_ceildiv(n_bits, GU_WORD_BITS) * sizeof(GuWord);
-}
-
-static inline void*
-gu_word_ptr(GuWord w)
-{
-	return (void*) w;
-}
-
-static inline GuWord
-gu_ptr_word(void* p)
-{
-	return (GuWord) p;
-}
-
-#define GuOpaque() struct { GuWord w_; }
-
-typedef GuWord GuTagged;
-
-#define GU_TAG_MAX (sizeof(GuWord) - 1)
-
-static inline size_t
-gu_tagged_tag(GuTagged t) {
-	return (int) (t & (sizeof(GuWord) - 1));
-}
-
-static inline void*
-gu_tagged_ptr(GuTagged w) {
-	return (void*) gu_align_backward(w, sizeof(GuWord));
-}
-
-static inline GuTagged
-gu_tagged(void* ptr, size_t tag) {
-	gu_require(tag < sizeof(GuWord));
-	uintptr_t u = (uintptr_t) ptr;
-	gu_require(gu_align_backward(u, sizeof(GuWord)) == u);
-	return (GuWord) { u | tag };
-}
-
-#include <gu/exn.h>
-
-#define GU_DECODE_2C_(u_, t_, umax_, posmax_, tmin_, err_)	\
-	(((u_) <= (posmax_))					\
-	 ? (t_) (u_)						\
-	 : (tmin_) + ((t_) ((umax_) - (u_))) < 0		\
-	 ? (t_) (-1 - ((t_) ((umax_) - (u_))))				\
-	 : (t_) (gu_raise(err_, GuIntDecodeExn), -1))
-
-
-static inline int8_t
-gu_decode_2c8(uint8_t u, GuExn* err)
-{
-	return GU_DECODE_2C_(u, int8_t, UINT8_C(0xff), 
-			     UINT8_C(0x7f), INT8_MIN, err);
-}
-
-static inline int16_t
-gu_decode_2c16(uint16_t u, GuExn* err)
-{
-	return GU_DECODE_2C_(u, int16_t, UINT16_C(0xffff), 
-			     UINT16_C(0x7fff), INT16_MIN, err);
-}
-
-static inline int32_t
-gu_decode_2c32(uint32_t u, GuExn* err)
-{
-	return GU_DECODE_2C_(u, int32_t, UINT32_C(0xffffffff), 
-			     UINT32_C(0x7fffffff), INT32_MIN, err);
-}
-
-static inline int64_t
-gu_decode_2c64(uint64_t u, GuExn* err)
-{
-	return GU_DECODE_2C_(u, int64_t, UINT64_C(0xffffffffffffffff), 
-			     UINT64_C(0x7fffffffffffffff), INT64_MIN, err);
-}
-
-GU_INTERNAL_DECL double
-gu_decode_double(uint64_t u);
-
-GU_INTERNAL_DECL uint64_t
-gu_encode_double(double d);
-
-#endif // GU_BITS_H_

src/runtime/c/gu/choice.c

@@ -1,68 +0,0 @@
-#include <gu/choice.h>
-#include <gu/seq.h>
-#include <gu/assert.h>
-
-struct GuChoice {
-	GuBuf* path;
-	size_t path_idx;
-};
-
-GU_API GuChoice*
-gu_new_choice(GuPool* pool)
-{
-	GuChoice* ch = gu_new(GuChoice, pool);
-	ch->path = gu_new_buf(size_t, pool);
-	ch->path_idx = 0;
-	return ch;
-}
-
-GU_API GuChoiceMark
-gu_choice_mark(GuChoice* ch)
-{
-	gu_assert(ch->path_idx <= gu_buf_length(ch->path));
-	return (GuChoiceMark){ch->path_idx};
-}
-
-GU_API void
-gu_choice_reset(GuChoice* ch, GuChoiceMark mark)
-{
-	gu_assert(ch->path_idx <= gu_buf_length(ch->path));
-	gu_require(mark.path_idx <= ch->path_idx );
-	ch->path_idx = mark.path_idx;
-}
-
-GU_API int
-gu_choice_next(GuChoice* ch, int n_choices)
-{
-	gu_assert(n_choices >= 0);
-	gu_assert(ch->path_idx <= gu_buf_length(ch->path));
-	if (n_choices == 0) {
-		return -1;
-	}
-	int i = 0;
-	if (gu_buf_length(ch->path) > ch->path_idx) {
-		i = (int) gu_buf_get(ch->path, size_t, ch->path_idx);
-		gu_assert(i <= n_choices);
-	} else {
-		gu_buf_push(ch->path, size_t, n_choices);
-		i = n_choices;
-	}
-	int ret = (i == 0) ? -1 : n_choices - i;
-	ch->path_idx++;
-	return ret;
-}
-
-GU_API bool
-gu_choice_advance(GuChoice* ch)
-{
-	gu_assert(ch->path_idx <= gu_buf_length(ch->path));
-	
-	while (gu_buf_length(ch->path) > ch->path_idx) {
-		size_t last = gu_buf_pop(ch->path, size_t);
-		if (last > 1) {
-			gu_buf_push(ch->path, size_t, last-1);
-			return true;
-		}
-	}
-	return false;
-}

src/runtime/c/gu/choice.h

@@ -1,37 +0,0 @@
-#ifndef GU_CHOICE_H_
-#define GU_CHOICE_H_
-
-#include <gu/mem.h>
-
-typedef struct GuChoice GuChoice;
-
-typedef struct GuChoiceMark GuChoiceMark;
-
-GU_API_DECL GuChoice*
-gu_new_choice(GuPool* pool);
-
-GU_API_DECL int
-gu_choice_next(GuChoice* ch, int n_choices);
-
-GU_API_DECL GuChoiceMark
-gu_choice_mark(GuChoice* ch);
-
-GU_API_DECL void
-gu_choice_reset(GuChoice* ch, GuChoiceMark mark);
-
-GU_API_DECL bool
-gu_choice_advance(GuChoice* ch);
-
-
-// private
-
-struct GuChoiceMark {
-	size_t path_idx;
-};
-
-
-
-
-
-
-#endif // GU_CHOICE_H_

src/runtime/c/gu/defs.c

@@ -1,4 +0,0 @@
-#include <gu/defs.h>
-
-void* const gu_null = NULL;
-GU_API GuStruct* const gu_null_struct = NULL;

src/runtime/c/gu/defs.h

@@ -1,227 +0,0 @@
-/** @file
- *
- * Miscellaneous macros.
- */
-
-#ifndef GU_DEFS_H_
-#define GU_DEFS_H_
-
-// MSVC requires explicit export/import of
-// symbols in DLLs. CMake takes care of this
-// for functions, but not for data/variables.
-#if defined(_MSC_VER)
-#if defined(COMPILING_GU)
-#define GU_API_DECL __declspec(dllexport)
-#define GU_API __declspec(dllexport)
-#else
-#define GU_API_DECL __declspec(dllimport)
-#define GU_API ERROR_NOT_COMPILING_LIBGU
-#endif
-
-#define GU_INTERNAL_DECL
-#define GU_INTERNAL
-
-#define restrict __restrict
-
-#else
-
-#define GU_API_DECL
-#define GU_API
-
-#define GU_INTERNAL_DECL  __attribute__ ((visibility ("hidden")))
-#define GU_INTERNAL       __attribute__ ((visibility ("hidden")))
-#endif
-// end MSVC workaround
-
-#include <stddef.h>
-#include <inttypes.h>
-#include <stdbool.h>
-#include <assert.h>
-#include <limits.h>
-#include <stdarg.h>
-#include <gu/sysdeps.h>
-
-#define gu_container(mem_p, container_type, member) \
-	((container_type*)(((uint8_t*) (mem_p)) - offsetof(container_type, member)))
-/**< Find the address of a containing structure.
- *
- * If @c s has type @c t*, where @c t is a struct or union type with a
- * member @m, then <tt>GU_CONTAINER_P(&s->m, t, m) == s</tt>.
- * 
- * @param mem_p           Pointer to the member of a structure.
- * @param container_type  The type of the containing structure.
- * @param member          The name of the member of @a container_type
- * @return  The address of the containing structure.
- *
- * @hideinitializer */
-
-
-#define gu_member_p(struct_p_, offset_)		\
-	((void*)&((uint8_t*)(struct_p_))[offset_])
-
-#define gu_member(t_, struct_p_, offset_) \
-	(*(t_*)gu_member_p(struct_p_, offset_))
-
-#ifdef GU_ALIGNOF
-# define gu_alignof GU_ALIGNOF
-#elif defined(_MSC_VER)
-# define gu_alignof __alignof
-#else
-# define gu_alignof(t_) \
-	((size_t)(offsetof(struct { char c_; t_ e_; }, e_)))
-#endif
-
-#define GU_PLIT(type, expr) \
-	((type[1]){ expr })
-
-#define GU_LVALUE(type, expr) \
-	(*((type[1]){ expr }))
-
-#define GU_COMMA ,
-
-#define GU_ARRAY_LEN(a) (sizeof(a) / sizeof(a[0]))
-
-#define GU_ID(...) __VA_ARGS__
-
-// This trick is by Laurent Deniau <laurent.deniau@cern.ch>
-#define GU_N_ARGS(...)				\
-	GU_N_ARGS_(__VA_ARGS__,						\
-		   31,30,29,28,27,26,25,24,				\
-		   23,22,21,20,19,18,17,16,				\
-		   15,14,13,12,11,10,9,8,				\
-		   7,6,5,4,3,2,1,0)					
-#define GU_N_ARGS_(...) GU_N_ARGS__(__VA_ARGS__)
-#define GU_N_ARGS__(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,			\
-		    q,r,s,t,u,v,w,x,y,z,aa,ab,ac,ad,ae,N,...)		\
-	N
-
-#define GU_ARG1(a1, ...) a1
-#define GU_ARG2(a1, a2, ...) a2
-
-#define GU_BEGIN do {
-#define GU_END } while (false)
-
-#define GU_NOP GU_BEGIN (void) 0; GU_END
-
-/**< @hideinitializer */
-
-//
-// Assert
-//
-
-#define GU_MAX(a_, b_) ((a_) > (b_) ? (a_) : (b_))
-#define GU_MIN(a_, b_) ((a_) < (b_) ? (a_) : (b_))
-
-static inline int
-gu_max(int a, int b) {
-	return GU_MAX(a, b);
-}
-
-static inline int
-gu_min(int a, int b) {
-	return GU_MIN(a, b);
-}
-
-#ifdef GU_ALIGNOF
-#define gu_flex_alignof gu_alignof
-#else
-#define gu_flex_alignof(t) 0
-#endif
-
-static inline size_t
-gu_flex_size(size_t ssize, size_t offset, int n_elems, size_t e_size)
-{
-	return GU_MAX(ssize, offset + n_elems * e_size);
-}
-
-#define GU_FLEX_SIZE(type, flex_member, n_elems)			\
-	gu_flex_size(sizeof(type), offsetof(type, flex_member),		\
-		     n_elems, sizeof(((type*)NULL)->flex_member[0]))
-
-
-// The following are directly from gmacros.h in GLib
-
-#define GU_PASTE_ARGS(id1_,id2_)	\
-	id1_ ## id2_
-
-#define GU_PASTE(id1_, id2_)			\
-	GU_PASTE_ARGS(id1_, id2_)
-
-#define GU_STATIC_ASSERT(expr_)						\
-	typedef struct {						\
-		char static_assert[(expr_) ? 1 : -1];			\
-	} GU_PASTE(GuStaticAssert_, __LINE__)
-
-
-#define GU_ENSURE_TYPE(T, EXPR)			\
-	((void)(sizeof(*(T*)NULL=(EXPR))),(EXPR))
-
-#define GU_END_DECLS \
-	extern void gu_dummy_(void)
-
-extern void* const gu_null;
-
-// Dummy struct used for generic struct pointers
-typedef struct GuStruct GuStruct;
-
-GU_API_DECL extern GuStruct* const gu_null_struct;
-
-typedef uintptr_t GuWord;
-
-#define GU_WORD_MAX UINTPTR_MAX
-
-// TODO: use max_align_t once C1X is supported
-typedef union {
-	char c;
-	short s;
-	int i;
-	long l;
-	long long ll;
-	intmax_t im;
-	float f;
-	double d;
-	long double ld;
-	void* p;
-	void (*fp)();
-} GuMaxAlign;
-
-#if defined(_MSC_VER)
-#include <malloc.h>
-#define gu_alloca(N) alloca(N)
-#else
-#define gu_alloca(N)				\
-	(((union { GuMaxAlign align_; uint8_t buf_[N]; }){{0}}).buf_)
-#endif
-
-// For Doxygen
-#define GU_PRIVATE /** @private */
-
-#ifdef GU_GNUC
-# define GU_LIKELY(EXPR) __builtin_expect(EXPR, 1)
-# define GU_UNLIKELY(EXPR) __builtin_expect(EXPR, 0)
-# define GU_IS_CONSTANT(EXPR) __builtin_constant_p(EXPR)
-#else
-# define GU_LIKELY(EXPR) (EXPR)
-# define GU_UNLIKELY(EXPR) (EXPR)
-# ifdef GU_OPTIMIZE_SIZE
-#  define GU_IS_CONSTANT(EXPR) false
-# else
-#  define GU_IS_CONSTANT(EXPR) true
-# endif
-#endif
-
-// Splint annotations
-#define GU_ONLY GU_SPLINT(only)
-#define GU_NULL GU_SPLINT(null)
-#define GU_NOTNULL GU_SPLINT(notnull) 
-#define GU_RETURNED GU_SPLINT(returned)
-#define GU_ABSTRACT GU_SPLINT(abstract)
-#define GU_IMMUTABLE GU_SPLINT(immutable)
-#define GU_NOTREACHED GU_SPLINT(notreached)
-#define GU_UNUSED GU_SPLINT(unused) GU_GNUC_ATTR(unused)
-#define GU_OUT GU_SPLINT(out)
-#define GU_IN GU_SPLINT(in)
-#define GU_NORETURN GU_SPLINT(noreturn) GU_GNUC_ATTR(noreturn)
-#define GU_MODIFIES(x) GU_SPLINT(modifies x)
-
-#endif // GU_DEFS_H_

src/runtime/c/gu/enum.c

@@ -1,7 +0,0 @@
-#include <gu/enum.h>
-
-GU_API void
-gu_enum_next(GuEnum* en, void* to, GuPool* pool)
-{
-	en->next(en, to, pool);
-}

src/runtime/c/gu/enum.h

@@ -1,35 +0,0 @@
-#ifndef GU_ENUM_H_
-#define GU_ENUM_H_
-
-#include <gu/mem.h>
-
-typedef struct GuEnum GuEnum;
-
-struct GuEnum {
-	void (*next)(GuEnum* self, void* to, GuPool* pool);
-};
-
-GU_API_DECL void
-gu_enum_next(GuEnum* en, void* to, GuPool* pool);
-
-#ifdef GU_GNUC
-
-#define gu_next(ENUM, T, POOL)						\
-	({								\
-		T gu_next_tmp_;						\
-		gu_enum_next((ENUM), &gu_next_tmp_, (POOL));		\
-		gu_next_tmp_;						\
-	})
-#else
-static inline void*
-gu_enum_next_(GuEnum* en, void* to, GuPool* pool)
-{
-	gu_enum_next(en, to, pool);
-	return to;
-}
-#define gu_next(ENUM, T, POOL)			\
-	(*(T*)gu_enum_next_((ENUM), &(T){0}, (POOL)))
-
-#endif
-
-#endif /* GU_ENUM_H_ */

src/runtime/c/gu/exn.c

@@ -1,78 +0,0 @@
-#include <gu/exn.h>
-#include <gu/assert.h>
-
-
-GU_API GuExn*
-gu_new_exn(GuPool* pool)
-{
-	GuExn* exn = gu_new(GuExn, pool);
-	exn->state = GU_EXN_OK;
-	exn->caught = NULL;
-	exn->data.pool = pool;
-	exn->data.data = NULL;
-	return exn;
-}
-
-GU_API bool
-gu_exn_is_raised(GuExn* err) {
-	return err && (err->state == GU_EXN_RAISED);
-}
-
-GU_API bool
-gu_exn_caught_(GuExn* err, const char* type)
-{
-	return (err->caught && strcmp(err->caught, type) == 0);
-}
-
-GU_API void
-gu_exn_block(GuExn* err)
-{
-	if (err && err->state == GU_EXN_RAISED) {
-		err->state = GU_EXN_BLOCKED;
-	}
-}
-
-GU_API void
-gu_exn_unblock(GuExn* err)
-{
-	if (err && err->state == GU_EXN_BLOCKED) {
-		err->state = GU_EXN_RAISED;
-	}
-}
-
-GU_API GuExnData*
-gu_exn_raise_debug_(GuExn* err, const char* type, 
-		            const char* filename, const char* func, int lineno)
-{
-	gu_require(type);
-
-	GuExnState old_state = err->state;
-	err->state = GU_EXN_RAISED;
-	if (old_state == GU_EXN_OK) {
-		err->caught = type;
-		if (err->data.pool) {
-			return &err->data;
-		}
-	}
-
-	// Exceptian had already been raised, possibly blocked, or no
-	// exception value is required.
-	return NULL;
-}
-
-GU_API GuExnData*
-gu_exn_raise_(GuExn* base, const char* type)
-{
-	return gu_exn_raise_debug_(base, type, NULL, NULL, -1);
-}
-
-GU_API void
-gu_raise_errno(GuExn* err)
-{
-	GuExnData* err_data = gu_raise(err, GuErrno);
-	if (err_data) {
-		GuErrno* gu_errno = gu_new(GuErrno, err_data->pool);
-		*gu_errno = errno;
-		err_data->data = gu_errno;
-	}
-}

src/runtime/c/gu/exn.h

@@ -1,171 +0,0 @@
-#ifndef GU_EXN_H_
-#define GU_EXN_H_
-
-#include <gu/mem.h>
-
-/** @file
- *
- * @defgroup GuExn Exceptions
- * Defined in <gu/exn.h>.
- * @{
- */
-
-/// An exception frame.
-typedef struct GuExn GuExn;
-
-/// @private
-typedef enum {
-	GU_EXN_RAISED,
-	GU_EXN_OK,
-	GU_EXN_BLOCKED
-} GuExnState;
-
-typedef struct GuExnData GuExnData;
-
-/// A structure for storing exception values.
-struct GuExnData
-/**
- * When an exception is raised, if there is an associated value, it
- * must be allocated from a pool that still exists when control
- * returns to the handler of that exception. This structure is used to
- * communicate the exception from the raiser to the handler: the
- * handler sets #pool when setting up the exception frame, and the
- * raiser uses that pool to allocate the value and stores that in
- * #data. When control returns to the handler, it reads the value from
- * there.
- */
-{
-	
-	/// The pool that the exception value should be allocated from.
-	GuPool* pool;
-
-	/// The exception value.
-	void* data;
-};
-
-struct GuExn {
-	/// @privatesection
-	GuExnState state;
-	const char* caught;
-	GuExnData data;
-};
-
-
-/// @name Creating exception frames
-//@{
-
-
-/// Allocate a new local exception frame.
-#define gu_exn(pool_) &(GuExn){	\
-	.state = GU_EXN_OK,	\
-	.caught = NULL,	\
-	.data = {.pool = pool_, .data = NULL} \
-}
-
-
-/// Allocate a new exception frame.
-GU_API_DECL GuExn*
-gu_new_exn(GuPool* pool);
-
-
-GU_API_DECL bool
-gu_exn_is_raised(GuExn* err);
-
-static inline void
-gu_exn_clear(GuExn* err) {
-	err->caught = NULL;
-	err->state = GU_EXN_OK;
-}
-
-#define gu_exn_caught(err, type) \
-	(err->caught && strcmp(err->caught, #type) == 0)
-	
-GU_API_DECL bool
-gu_exn_caught_(GuExn* err, const char* type);
-
-static inline const void*
-gu_exn_caught_data(GuExn* err)
-{
-	return err->data.data;
-}
-
-/// Temporarily block a raised exception.
-GU_API_DECL void
-gu_exn_block(GuExn* err);
-
-/// Show again a blocked exception.
-GU_API_DECL void
-gu_exn_unblock(GuExn* err);
-
-//@private
-GU_API_DECL GuExnData*
-gu_exn_raise_(GuExn* err, const char* type);
-
-//@private
-GU_API_DECL GuExnData*
-gu_exn_raise_debug_(GuExn* err, const char* type,
-		      const char* filename, const char* func, int lineno);
-
-#ifdef NDEBUG
-#define gu_exn_raise(err_, type_)	\
-	gu_exn_raise_(err_, type_)
-#else
-#define gu_exn_raise(err_, type_)	\
-	gu_exn_raise_debug_(err_, type_, \
-			      __FILE__, __func__, __LINE__)
-#endif
-
-/// Raise an exception.
-#define gu_raise(exn, T)		\
-	gu_exn_raise(exn, #T)
-/**< 
- * @param exn The current exception frame.
- *
- * @param T   The C type of the exception to raise.
- *
- * @return    A #GuExnData object that can be used to store the exception value, or
- * \c NULL if no value is required.
- * 
- * @note The associated #GuType object for type \p T must be visible.
- */
-
-#define gu_raise_new(error_, t_, pool_, expr_)				\
-	GU_BEGIN							\
-	GuExnData* gu_raise_err_ = gu_raise(error_, t_);		\
-	if (gu_raise_err_) {						\
-		GuPool* pool_ = gu_raise_err_->pool;			\
-		gu_raise_err_->data = expr_;				\
-	}								\
-	GU_END
-
-/// Check the status of the current exception frame
-static inline bool
-gu_ok(GuExn* exn) {
-	return !GU_UNLIKELY(gu_exn_is_raised(exn));
-}
-/**<
- * @return \c false if an exception has been raised in the frame \p exn
- * and it has not been blocked, \c true otherwise.
- */
-
-
-/// Return from current function if an exception has been raised.
-#define gu_return_on_exn(exn_, retval_)		\
-	GU_BEGIN					\
-	if (gu_exn_is_raised(exn_)) return retval_;	\
-	GU_END
-/**<
- * @showinitializer
- */
-
-
-#include <errno.h>
-
-typedef int GuErrno;
-
-GU_API_DECL void
-gu_raise_errno(GuExn* err);
-
-/** @} */
-
-#endif // GU_EXN_H_

src/runtime/c/gu/file.c

@@ -1,77 +0,0 @@
-#include <gu/file.h>
-
-typedef struct GuFileOutStream GuFileOutStream;
-
-struct GuFileOutStream {
-	GuOutStream stream;
-	FILE* file;
-};
-
-static size_t
-gu_file_output(GuOutStream* stream, const uint8_t* buf, size_t len, GuExn* err)
-{
-	GuFileOutStream* fos = gu_container(stream, GuFileOutStream, stream);
-	errno = 0;
-	size_t wrote = fwrite(buf, 1, len, fos->file);
-	if (wrote < len) {
-		if (ferror(fos->file)) {
-			gu_raise_errno(err);
-		}
-	}
-	return wrote;
-}
-
-static void
-gu_file_flush(GuOutStream* stream, GuExn* err)
-{
-	GuFileOutStream* fos = gu_container(stream, GuFileOutStream, stream);
-	errno = 0;
-	if (fflush(fos->file) != 0) {
-		gu_raise_errno(err);
-	}
-}
-
-GU_API GuOut*
-gu_file_out(FILE* file, GuPool* pool)
-{
-	GuFileOutStream* fos = gu_new(GuFileOutStream, pool);
-	fos->stream.begin_buf = NULL;
-	fos->stream.end_buf = NULL;
-	fos->stream.output = gu_file_output;
-	fos->stream.flush = gu_file_flush;
-	fos->file = file;
-	return gu_new_out(&fos->stream, pool);
-}
-
-
-typedef struct GuFileInStream GuFileInStream;
-
-struct GuFileInStream {
-	GuInStream stream;
-	FILE* file;
-};
-
-static size_t 
-gu_file_input(GuInStream* stream, uint8_t* buf, size_t sz, GuExn* err)
-{
-	GuFileInStream* fis = gu_container(stream, GuFileInStream, stream);
-	errno = 0;
-	size_t got = fread(buf, 1, sz, fis->file);
-	if (got == 0) {
-		if (ferror(fis->file)) {
-			gu_raise_errno(err);
-		}
-	}
-	return got;
-}
-
-GU_API GuIn*
-gu_file_in(FILE* file, GuPool* pool)
-{
-	GuFileInStream* fis = gu_new(GuFileInStream, pool);
-	fis->stream.begin_buffer = NULL;
-	fis->stream.end_buffer = NULL;
-	fis->stream.input = gu_file_input;
-	fis->file = file;
-	return gu_new_in(&fis->stream, pool);
-}

src/runtime/c/gu/file.h

@@ -1,14 +0,0 @@
-#ifndef GU_FILE_H_
-#define GU_FILE_H_
-
-#include <gu/in.h>
-#include <gu/out.h>
-#include <stdio.h>
-
-GU_API_DECL GuOut*
-gu_file_out(FILE* file, GuPool* pool);
-
-GU_API_DECL GuIn* 
-gu_file_in(FILE* file, GuPool* pool);
-
-#endif // GU_FILE_H_

src/runtime/c/gu/fun.c

@@ -1 +0,0 @@
-#include <gu/fun.h>

src/runtime/c/gu/fun.h

@@ -1,71 +0,0 @@
-#ifndef GU_FUN_H_
-#define GU_FUN_H_
-
-#include <gu/defs.h>
-
-typedef void (*GuFn)();
-typedef void (*GuFn0)(GuFn* clo);
-typedef void (*GuFn1)(GuFn* clo, void* arg1);
-typedef void (*GuFn2)(GuFn* clo, void* arg1, void* arg2);
-
-#define gu_fn(fn_) (&(GuFn){ fn_ })
-
-static inline void
-gu_apply0(GuFn* fn) {
-	(*fn)(fn);
-}
-
-static inline void
-gu_apply1(GuFn* fn, void* arg1) {
-	(*fn)(fn, arg1);
-}
-
-static inline void
-gu_apply2(GuFn* fn, void* arg1, void* arg2) {
-	(*fn)(fn, arg1, arg2);
-}
-
-#define gu_apply(fn_, ...)			\
-	((fn_)->fn((fn_), __VA_ARGS__))
-
-typedef struct GuClo0 GuClo0;
-
-struct GuClo0 {
-	GuFn fn;
-};
-
-typedef struct GuClo1 GuClo1;
-
-struct GuClo1 {
-	GuFn fn;
-	void *env1;
-};
-
-typedef struct GuClo2 GuClo2;
-struct GuClo2 {
-	GuFn fn;
-	void *env1;
-	void *env2;
-};
-
-typedef struct GuClo3 GuClo3;
-struct GuClo3 {
-	GuFn fn;
-	void *env1;
-	void *env2;
-	void *env3;
-};
-
-typedef const struct GuEquality GuEquality;
-
-struct GuEquality {
-	bool (*is_equal)(GuEquality* self, const void* a, const void* b);
-};
-
-typedef const struct GuOrder GuOrder;
-
-struct GuOrder {
-	int (*compare)(GuOrder* self, const void* a, const void* b);
-};
-
-#endif // GU_FUN_H_

src/runtime/c/gu/hash.c

@@ -1,77 +0,0 @@
-#include <gu/hash.h>
-
-GU_API GuHash
-gu_hash_bytes(GuHash h, const uint8_t* buf, size_t len)
-{
-	for (size_t n = 0; n < len; n++) {
-		h = gu_hash_byte(h, buf[n]);
-	}
-	return h;
-}
-
-static bool
-gu_int_eq_fn(GuEquality* self, const void* p1, const void* p2)
-{
-	(void) self;
-	const int* ip1 = p1;
-	const int* ip2 = p2;
-	return *ip1 == *ip2;
-}
-
-static GuHash
-gu_int_hash_fn(GuHasher* self, const void* p)
-{
-	(void) self;
-	return (GuHash) *(const int*) p;
-}
-
-GU_API GuHasher gu_int_hasher[1] = {
-	{
-		{ gu_int_eq_fn },
-		gu_int_hash_fn
-	}
-};
-
-static bool
-gu_addr_eq_fn(GuEquality* self, const void* p1, const void* p2)
-{
-	(void) self;
-	return (p1 == p2);
-}
-
-static GuHash
-gu_addr_hash_fn(GuHasher* self, const void* p)
-{
-	(void) self;
-	return (GuHash) (uintptr_t) p;
-}
-
-GU_API GuHasher gu_addr_hasher[1] = {
-	{
-		{ gu_addr_eq_fn },
-		gu_addr_hash_fn
-	}
-};
-
-static bool
-gu_word_eq_fn(GuEquality* self, const void* p1, const void* p2)
-{
-	(void) self;
-	const GuWord* wp1 = p1;
-	const GuWord* wp2 = p2;
-	return (*wp1 == *wp2);
-}
-
-static GuHash
-gu_word_hash_fn(GuHasher* self, const void* p)
-{
-	(void) self;
-	return (GuHash) (uintptr_t) p;
-}
-
-GU_API GuHasher gu_word_hasher[1] = {
-	{
-		{ gu_word_eq_fn },
-		gu_word_hash_fn
-	}
-};

src/runtime/c/gu/hash.h

@@ -1,40 +0,0 @@
-#ifndef GU_HASH_H_
-#define GU_HASH_H_
-
-#include <gu/fun.h>
-
-typedef GuWord GuHash;
-
-static inline GuHash
-gu_hash_ptr(void* ptr)
-{
-	return (GuHash) ptr;
-}
-
-
-static inline GuHash
-gu_hash_byte(GuHash h, uint8_t u)
-{
-	// Paul Larson's simple byte hash
-	return h * 101 + u;
-}
-
-
-GU_API_DECL GuHash
-gu_hash_bytes(GuHash h, const uint8_t* buf, size_t len);
-
-typedef const struct GuHasher GuHasher;
-
-struct GuHasher {
-	GuEquality eq;
-	GuHash (*hash)(GuHasher* self, const void* p);
-};
-
-
-GU_API_DECL extern GuHasher gu_int_hasher[1];
-
-GU_API_DECL extern GuHasher gu_addr_hasher[1];
-
-GU_API_DECL extern GuHasher gu_word_hasher[1];
-
-#endif // GU_HASH_H_

src/runtime/c/gu/in.c

@@ -1,378 +0,0 @@
-#include <gu/in.h>
-#include <gu/bits.h>
-#include <math.h>
-
-
-static bool
-gu_in_is_buffering(GuIn* in)
-{
-	return (in->buf_end != NULL);
-}
-
-static void
-gu_in_end_buffering(GuIn* in, GuExn* err)
-{
-	if (!gu_in_is_buffering(in)) {
-		return;
-	}
-	if (in->stream->end_buffer) {
-		size_t len = ((ptrdiff_t) in->buf_size) + in->buf_curr;
-		in->stream->end_buffer(in->stream, len, err);
-	}
-	in->buf_curr = 0;
-	in->buf_size = 0;
-	in->buf_end = NULL;
-}
-
-static bool
-gu_in_begin_buffering(GuIn* in, GuExn* err)
-{
-	if (gu_in_is_buffering(in)) {
-		if (in->buf_curr < 0) {
-			return true;
-		} else {
-			gu_in_end_buffering(in, err);
-			if (!gu_ok(err)) return false;
-		}
-	}
-	if (!in->stream->begin_buffer) {
-		return false;
-	}
-	size_t sz = 0;
-	const uint8_t* new_buf = 
-		in->stream->begin_buffer(in->stream, &sz, err);
-	if (new_buf) {
-		in->buf_end = &new_buf[sz];
-		in->buf_curr = -(ptrdiff_t) sz;
-		in->buf_size = sz;
-		return true;
-	}
-	return false;
-}
-
-static size_t
-gu_in_input(GuIn* in, uint8_t* dst, size_t sz, GuExn* err)
-{
-	if (sz == 0) {
-		return 0;
-	}
-	gu_in_end_buffering(in, err);
-	if (!gu_ok(err)) {
-		return 0;
-	}
-	GuInStream* stream = in->stream;
-	if (stream->input) {
-		return stream->input(stream, dst, sz, err);
-	}
-	gu_raise(err, GuEOF);
-	return 0;
-}
-
-GU_API size_t
-gu_in_some(GuIn* in, uint8_t* dst, size_t sz, GuExn* err)
-{
-	gu_require(sz <= PTRDIFF_MAX);
-	if (!gu_in_begin_buffering(in, err)) {
-		if (!gu_ok(err)) return 0; 
-		return gu_in_input(in, dst, sz, err);
-	}
-	size_t real_sz = GU_MIN(sz, (size_t)(-in->buf_curr));
-	memcpy(dst, &in->buf_end[in->buf_curr], real_sz);
-	in->buf_curr += real_sz;
-	return real_sz;
-}
-
-GU_API void
-gu_in_bytes_(GuIn* in, uint8_t* dst, size_t sz, GuExn* err)
-{
-	for (;;) {
-		size_t avail_sz = GU_MIN(sz, (size_t)(-in->buf_curr));
-		memcpy(dst, &in->buf_end[in->buf_curr], avail_sz);
-		in->buf_curr += avail_sz;
-		dst += avail_sz;
-		sz -= avail_sz;
-
-		if (sz == 0)
-			break;
-
-		if (!gu_in_begin_buffering(in, err)) {
-			gu_in_input(in, dst, sz, err);
-			return;
-		}
-	}
-}
-
-GU_API const uint8_t*
-gu_in_begin_span(GuIn* in, size_t *sz_out, GuExn* err)
-{
-	if (!gu_in_begin_buffering(in, err)) {
-		return NULL;
-	}
-	*sz_out = (size_t) -in->buf_curr;
-	return &in->buf_end[in->buf_curr];
-}
-
-GU_API void
-gu_in_end_span(GuIn* in, size_t consumed)
-{
-	gu_require(consumed <= (size_t) -in->buf_curr);
-	in->buf_curr += (ptrdiff_t) consumed;
-}
-
-GU_API uint8_t 
-gu_in_u8_(GuIn* in, GuExn* err)
-{
-	if (gu_in_begin_buffering(in, err) && in->buf_curr < 0) {
-		return in->buf_end[in->buf_curr++];
-	}
-	uint8_t u = 0;
-	size_t r = gu_in_input(in, &u, 1, err);
-	if (r < 1) {
-		gu_raise(err, GuEOF);
-		return 0;
-	}
-	return u;
-}
-
-static uint64_t
-gu_in_be(GuIn* in, GuExn* err, int n)
-{
-	uint8_t buf[8];
-	gu_in_bytes(in, buf, n, err);
-	uint64_t u = 0;
-	for (int i = 0; i < n; i++) {
-		u = u << 8 | buf[i];
-	}
-	return u;
-}
-
-static uint64_t
-gu_in_le(GuIn* in, GuExn* err, int n)
-{
-	uint8_t buf[8];
-	gu_in_bytes(in, buf, n, err);
-	uint64_t u = 0;
-	for (int i = n-1; i >= 0; i--) {
-		u = u << 8 | buf[i];
-	}
-	return u;
-}
-
-GU_API int8_t 
-gu_in_s8(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c8(gu_in_u8(in, err), err);
-}
-
-
-GU_API uint16_t
-gu_in_u16le(GuIn* in, GuExn* err)
-{
-	return gu_in_le(in, err, 2);
-}
-
-GU_API int16_t 
-gu_in_s16le(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c16(gu_in_u16le(in, err), err);
-}
-
-GU_API uint16_t
-gu_in_u16be(GuIn* in, GuExn* err)
-{
-	return gu_in_be(in, err, 2);
-}
-
-GU_API int16_t 
-gu_in_s16be(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c16(gu_in_u16be(in, err), err);
-}
-
-GU_API uint32_t
-gu_in_u32le(GuIn* in, GuExn* err)
-{
-	return gu_in_le(in, err, 4);
-}
-
-GU_API int32_t 
-gu_in_s32le(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c32(gu_in_u32le(in, err), err);
-}
-
-GU_API uint32_t
-gu_in_u32be(GuIn* in, GuExn* err)
-{
-	return gu_in_be(in, err, 4);
-}
-
-GU_API int32_t 
-gu_in_s32be(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c32(gu_in_u32be(in, err), err);
-}
-
-GU_API uint64_t
-gu_in_u64le(GuIn* in, GuExn* err)
-{
-	return gu_in_le(in, err, 8);
-}
-
-GU_API int64_t 
-gu_in_s64le(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c64(gu_in_u64le(in, err), err);
-}
-
-GU_API uint64_t
-gu_in_u64be(GuIn* in, GuExn* err)
-{
-	return gu_in_be(in, err, 8);
-}
-
-GU_API int64_t 
-gu_in_s64be(GuIn* in, GuExn* err)
-{
-	return gu_decode_2c64(gu_in_u64be(in, err), err);
-}
-
-GU_API double
-gu_in_f64le(GuIn* in, GuExn* err)
-{
-	return gu_decode_double(gu_in_u64le(in, err));
-}
-
-GU_API double
-gu_in_f64be(GuIn* in, GuExn* err)
-{
-	return gu_decode_double(gu_in_u64be(in, err));
-}
-
-static void
-gu_in_fini(GuFinalizer* fin)
-{
-	GuIn* in = gu_container(fin, GuIn, fini);
-	GuPool* pool = gu_local_pool();
-	GuExn* err = gu_exn(pool);
-	gu_in_end_buffering(in, err);
-	gu_pool_free(pool);
-}
-
-GU_API GuIn*
-gu_new_in(GuInStream* stream, GuPool* pool)
-{
-	gu_require(stream != NULL);
-
-	GuIn* in = gu_new(GuIn, pool);
-	in->buf_end = NULL;
-	in->buf_curr = 0;
-	in->buf_size = 0;
-	in->stream = stream;
-	in->fini.fn = gu_in_fini;
-	return in;
-}
-
-typedef struct GuBufferedInStream GuBufferedInStream;
-
-struct GuBufferedInStream {
-	GuInStream stream;
-	size_t alloc;
-	size_t have;
-	size_t curr;
-	GuIn* in;
-	uint8_t buf[];
-};
-
-static const uint8_t*
-gu_buffered_in_begin_buffer(GuInStream* self, size_t* sz_out, GuExn* err)
-{
-	GuBufferedInStream* bis = 
-		gu_container(self, GuBufferedInStream, stream);
-	if (bis->curr == bis->have) {
-		bis->curr = 0;
-		bis->have = gu_in_some(bis->in, bis->buf, bis->alloc, err);
-		if (!gu_ok(err)) return NULL;
-	}
-	*sz_out = bis->have - bis->curr;
-	return &bis->buf[bis->curr];
-}
-
-static void
-gu_buffered_in_end_buffer(GuInStream* self, size_t consumed, GuExn* err)
-{
-	GuBufferedInStream* bis = 
-		gu_container(self, GuBufferedInStream, stream);
-	gu_require(consumed < bis->have - bis->curr);
-	bis->curr += consumed;
-}
-
-static size_t
-gu_buffered_in_input(GuInStream* self, uint8_t* dst, size_t sz, GuExn* err)
-{
-	GuBufferedInStream* bis = 
-		gu_container(self, GuBufferedInStream, stream);
-	return gu_in_some(bis->in, dst, sz, err);
-}
-
-GU_API GuIn*
-gu_buffered_in(GuIn* in, size_t buf_sz, GuPool* pool)
-{
-	GuBufferedInStream* bis = gu_new_flex(pool, GuBufferedInStream,
-					      buf, buf_sz);
-	bis->stream = (GuInStream) {
-		.begin_buffer = gu_buffered_in_begin_buffer,
-		.end_buffer = gu_buffered_in_end_buffer,
-		.input = gu_buffered_in_input
-	};
-	bis->alloc = buf_sz;
-	bis->have = bis->curr = 0;
-	bis->in = in;
-	return gu_new_in(&bis->stream, pool);
-}
-
-typedef struct GuDataIn GuDataIn;
-
-struct GuDataIn {
-	GuInStream stream; 
-	const uint8_t* data;
-	size_t sz;
-};
-
-static const uint8_t*
-gu_data_in_begin_buffer(GuInStream* self, size_t* sz_out, GuExn* err)
-{
-	(void) err;
-	GuDataIn* di = gu_container(self, GuDataIn, stream);
-	const uint8_t* buf = di->data;
-	if (buf) {
-		*sz_out = di->sz;
-		di->data = NULL;
-		di->sz = 0;
-	}
-	return buf;
-}
-
-GU_API GuIn*
-gu_data_in(const uint8_t* data, size_t sz, GuPool* pool)
-{
-	GuDataIn* di = gu_new(GuDataIn, pool);
-	di->stream.begin_buffer = gu_data_in_begin_buffer;
-	di->stream.end_buffer = NULL;
-	di->stream.input = NULL;
-	di->data = data;
-	di->sz = sz;
-	return gu_new_in(&di->stream, pool);
-}
-
-extern inline uint8_t 
-gu_in_u8(GuIn* restrict in, GuExn* err);
-
-extern inline void
-gu_in_bytes(GuIn* in, uint8_t* buf, size_t sz, GuExn* err);
-
-extern inline int
-gu_in_peek_u8(GuIn* restrict in);
-
-extern inline void
-gu_in_consume(GuIn* restrict in, size_t sz);

src/runtime/c/gu/in.h

@@ -1,134 +0,0 @@
-#ifndef GU_IN_H_
-#define GU_IN_H_
-
-#include <gu/defs.h>
-#include <gu/exn.h>
-#include <gu/assert.h>
-
-typedef struct GuInStream GuInStream;
-
-struct GuInStream {
-	const uint8_t* (*begin_buffer)(GuInStream* self, size_t* sz_out, 
-				       GuExn* err);
-	void (*end_buffer)(GuInStream* self, size_t consumed, GuExn* err);
-	size_t (*input)(GuInStream* self, uint8_t* buf, size_t max_sz, 
-			GuExn* err);
-};
-
-typedef struct GuIn GuIn;
-
-struct GuIn {
-	const uint8_t* restrict buf_end;
-	ptrdiff_t buf_curr;
-	size_t buf_size;
-	GuInStream* stream;
-	GuFinalizer fini;
-};
-
-GU_API_DECL GuIn*
-gu_new_in(GuInStream* stream, GuPool* pool);
-
-GU_API_DECL const uint8_t*
-gu_in_begin_span(GuIn* in, size_t *sz_out, GuExn* err);
-
-GU_API_DECL void
-gu_in_end_span(GuIn* in, size_t consumed);
-
-GU_API_DECL size_t
-gu_in_some(GuIn* in, uint8_t* buf, size_t max_len, GuExn* err);
-
-inline void
-gu_in_bytes(GuIn* in, uint8_t* buf, size_t sz, GuExn* err)
-{
-	gu_require(sz < PTRDIFF_MAX);
-	ptrdiff_t curr = in->buf_curr;
-	ptrdiff_t new_curr = curr + (ptrdiff_t) sz;
-	if (GU_UNLIKELY(new_curr > 0)) {
-		GU_API_DECL void gu_in_bytes_(GuIn* in, uint8_t* buf, size_t sz, 
-					 GuExn* err);
-		gu_in_bytes_(in, buf, sz, err);
-		return;
-	}
-	memcpy(buf, &in->buf_end[curr], sz);
-	in->buf_curr = new_curr;
-}
-
-inline int
-gu_in_peek_u8(GuIn* restrict in)
-{
-	if (GU_UNLIKELY(in->buf_curr == 0)) {
-		return -1;
-	}
-	return in->buf_end[in->buf_curr];
-}
-
-inline void
-gu_in_consume(GuIn* restrict in, size_t sz)
-{
-	gu_require((ptrdiff_t) sz + in->buf_curr <= 0);
-	in->buf_curr += sz;
-}
-
-inline uint8_t 
-gu_in_u8(GuIn* restrict in, GuExn* err)
-{
-	if (GU_UNLIKELY(in->buf_curr == 0)) {
-		GU_API_DECL uint8_t gu_in_u8_(GuIn* restrict in, GuExn* err);
-		return gu_in_u8_(in, err);
-	}
-	return in->buf_end[in->buf_curr++];
-}
-
-GU_API_DECL int8_t 
-gu_in_s8(GuIn* in, GuExn* err);
-
-GU_API_DECL uint16_t
-gu_in_u16le(GuIn* in, GuExn* err);
-
-GU_API_DECL uint16_t
-gu_in_u16be(GuIn* in, GuExn* err);
-
-GU_API_DECL int16_t
-gu_in_s16le(GuIn* in, GuExn* err);
-
-GU_API_DECL int16_t
-gu_in_s16be(GuIn* in, GuExn* err);
-
-GU_API_DECL uint32_t
-gu_in_u32le(GuIn* in, GuExn* err);
-
-GU_API_DECL uint32_t
-gu_in_u32be(GuIn* in, GuExn* err);
-
-GU_API_DECL int32_t
-gu_in_s32le(GuIn* in, GuExn* err);
-
-GU_API_DECL int32_t
-gu_in_s32be(GuIn* in, GuExn* err);
-
-GU_API_DECL uint64_t
-gu_in_u64le(GuIn* in, GuExn* err);
-
-GU_API_DECL uint64_t
-gu_in_u64be(GuIn* in, GuExn* err);
-
-GU_API_DECL int64_t
-gu_in_s64le(GuIn* in, GuExn* err);
-
-GU_API_DECL int64_t
-gu_in_s64be(GuIn* in, GuExn* err);
-
-GU_API_DECL double
-gu_in_f64le(GuIn* in, GuExn* err);
-
-GU_API_DECL double
-gu_in_f64be(GuIn* in, GuExn* err);
-
-GU_API_DECL GuIn*
-gu_buffered_in(GuIn* in, size_t sz, GuPool* pool);
-
-GU_API_DECL GuIn*
-gu_data_in(const uint8_t* buf, size_t size, GuPool* pool);
-
-
-#endif // GU_IN_H_

src/runtime/c/gu/map.c

@@ -1,392 +0,0 @@
-#include <gu/defs.h>
-#include <gu/mem.h>
-#include <gu/map.h>
-#include <gu/assert.h>
-#include <gu/prime.h>
-#include <gu/string.h>
-
-typedef struct GuMapData GuMapData;
-
-#define SKIP_DELETED 1
-#define SKIP_NONE    2
-
-struct GuMapData {
-	uint8_t* keys;
-	uint8_t* values;
-	size_t n_occupied;
-	size_t n_entries;
-	size_t zero_idx;
-};
-
-struct GuMap {
-	GuHasher* hasher;
-	size_t key_size;
-	size_t value_size;
-	size_t cell_size;   // cell_size = GU_MAX(value_size,sizeof(uint8_t))
-	const void* default_value;
-	GuMapData data;
-	
-	GuFinalizer fin;
-};
-
-static void
-gu_map_finalize(GuFinalizer* fin)
-{
-	GuMap* map = gu_container(fin, GuMap, fin);
-	gu_mem_buf_free(map->data.keys);
-	gu_mem_buf_free(map->data.values);
-}
-
-static const GuWord gu_map_empty_key = 0;
-
-static bool
-gu_map_buf_is_zero(const uint8_t* p, size_t sz) {
-	while (sz >= sizeof(GuWord)) {
-		sz -= sizeof(GuWord);
-		if (memcmp(&p[sz], &gu_map_empty_key, sizeof(GuWord)) != 0) {
-			return false;
-		}
-	}
-	return (memcmp(p, &gu_map_empty_key, sz) == 0);
-}
-
-static bool
-gu_map_entry_is_free(GuMap* map, GuMapData* data, size_t idx)
-{
-	if (idx == data->zero_idx) {
-		return false;
-	} else if (map->hasher == gu_addr_hasher) {
-		const void* key = ((const void**)data->keys)[idx];
-		return key == NULL;
-	} else if (map->hasher == gu_word_hasher) {
-		GuWord key = ((GuWord*)data->keys)[idx];
-		return key == 0;
-	} else if (map->hasher == gu_string_hasher) {
-		GuString key = ((GuString*)data->keys)[idx];
-		return key == NULL;
-	}
-	const void* key = &data->keys[idx * map->key_size];
-	return gu_map_buf_is_zero(key, map->key_size);
-}
-
-static bool
-gu_map_lookup(GuMap* map, const void* key, uint8_t del, size_t* idx_out)
-{
-	size_t n = map->data.n_entries;
-	if (map->hasher == gu_addr_hasher) {
-		GuHash hash = (GuHash) key;
-		size_t idx = hash % n;
-		size_t offset = (hash % (n - 2)) + 1;
-		while (true) {
-			const void* entry_key =
-				((const void**)map->data.keys)[idx];
-
-			if (entry_key == NULL && map->data.zero_idx != idx) {
-				if (map->data.values[idx * map->cell_size] != del) { //skip deleted
-					*idx_out = idx;
-					return false;
-				}
-			} else if (entry_key == key) {
-				*idx_out = idx;
-				return true;
-			}
-
-			idx = (idx + offset) % n;
-		}
-	} else if (map->hasher == gu_word_hasher) {
-		GuWord w = *(const GuWord*)key;
-		GuHash hash = (GuHash) w;
-		size_t idx = hash % n;
-		size_t offset = (hash % (n - 2)) + 1;
-		while (true) {
-			GuWord entry_key = ((GuWord*)map->data.keys)[idx];
-			if (entry_key == 0 && map->data.zero_idx != idx) {
-				*idx_out = idx;
-				return false;
-			} else if (entry_key == w) {
-				*idx_out = idx;
-				return true;
-			}
-			idx = (idx + offset) % n;
-		}
-	} else if (map->hasher == gu_string_hasher) {
-		GuHasher* hasher = map->hasher;
-		GuEquality* eq = (GuEquality*) hasher;
-		GuHash hash = hasher->hash(hasher, key);
-		size_t idx = hash % n;
-		size_t offset = (hash % (n - 2)) + 1;
-		while (true) {
-			GuString entry_key =
-				((GuString*)map->data.keys)[idx];
-			if (entry_key == NULL && map->data.zero_idx != idx) {
-				*idx_out = idx;
-				return false;
-			} else if (eq->is_equal(eq, key, entry_key)) {
-				*idx_out = idx;
-				return true;
-			}
-			idx = (idx + offset) % n;
-		}
-	} else {
-		GuHasher* hasher = map->hasher;
-		GuEquality* eq = (GuEquality*) hasher;
-		GuHash hash = hasher->hash(hasher, key);
-		size_t idx = hash % n;
-		size_t offset = (hash % (n - 2)) + 1;
-		size_t key_size = map->key_size;
-		while (true) {
-			void* entry_key = &map->data.keys[idx * key_size];
-			if (gu_map_buf_is_zero(entry_key, key_size) &&
-			    map->data.zero_idx != idx) {
-				*idx_out = idx;
-				return false;
-			} else if (eq->is_equal(eq, key, entry_key)) {
-				*idx_out = idx;
-				return true;
-			}
-			idx = (idx + offset) % n;
-		}
-	}
-
-	gu_impossible();
-	return false;
-}
-	
-
-static void
-gu_map_resize(GuMap* map, size_t req_entries)
-{
-	GuMapData* data = &map->data;
-	GuMapData old_data = *data;
-
-	size_t key_size = map->key_size;
-	size_t key_alloc = 0;
-	data->keys = gu_mem_buf_alloc(req_entries * key_size, &key_alloc);
-	memset(data->keys, 0, key_alloc);
-
-	size_t value_alloc = 0;
-	size_t cell_size = map->cell_size;
-	data->values = gu_mem_buf_alloc(req_entries * cell_size, &value_alloc);
-	memset(data->values, 0, value_alloc);
-
-	data->n_entries = gu_twin_prime_inf(
-	                    GU_MIN(key_alloc / key_size,
-	                           value_alloc / cell_size));
-	gu_assert(data->n_entries > data->n_occupied);
-
-	data->n_occupied = 0;
-	data->zero_idx = SIZE_MAX;
-
-	for (size_t i = 0; i < old_data.n_entries; i++) {
-		if (gu_map_entry_is_free(map, &old_data, i)) {
-			continue;
-		}
-		void* old_key = &old_data.keys[i * key_size];
-		if (map->hasher == gu_addr_hasher) {
-			old_key = *(void**)old_key;
-		} else if (map->hasher == gu_string_hasher) {
-			old_key = (void*) *(GuString*)old_key;
-		}
-		void* old_value = &old_data.values[i * cell_size];
-
-		memcpy(gu_map_insert(map, old_key),
-		       old_value, map->value_size);
-	}
-
-	gu_mem_buf_free(old_data.keys);
-	gu_mem_buf_free(old_data.values);
-}
-
-
-static bool
-gu_map_maybe_resize(GuMap* map)
-{
-	if (map->data.n_entries <=
-	    map->data.n_occupied + (map->data.n_occupied / 4)) {
-		size_t req_entries =
-			gu_twin_prime_sup(GU_MAX(11, map->data.n_occupied * 4 / 3 + 1));
-		gu_map_resize(map, req_entries);
-		return true;
-	}
-	return false;
-}
-
-GU_API void*
-gu_map_find(GuMap* map, const void* key)
-{
-	size_t idx;
-	bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
-	if (found) {
-		return &map->data.values[idx * map->cell_size];
-	}
-	return NULL;
-}
-
-GU_API const void*
-gu_map_find_default(GuMap* map, const void* key)
-{
-	void* p = gu_map_find(map, key);
-	return p ? p : map->default_value;
-}
-
-GU_API const void*
-gu_map_find_key(GuMap* map, const void* key)
-{
-	size_t idx;
-	bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
-	if (found) {
-		return &map->data.keys[idx * map->key_size];
-	}
-	return NULL;
-}
-
-GU_API bool
-gu_map_has(GuMap* ht, const void* key)
-{
-	size_t idx;
-	return gu_map_lookup(ht, key, SKIP_DELETED, &idx);
-}
-
-GU_API void*
-gu_map_insert(GuMap* map, const void* key)
-{
-	size_t idx;
-	bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
-	if (!found) {
-		if (gu_map_maybe_resize(map)) {
-			found = gu_map_lookup(map, key, SKIP_NONE, &idx);
-			gu_assert(!found);
-		}
-		if (map->hasher == gu_addr_hasher) {
-			((const void**)map->data.keys)[idx] = key;
-		} else if (map->hasher == gu_string_hasher) {
-			((GuString*)map->data.keys)[idx] = key;
-		} else {
-			memcpy(&map->data.keys[idx * map->key_size],
-			       key, map->key_size);
-		}
-		if (map->default_value) {
-			memcpy(&map->data.values[idx * map->cell_size],
-			       map->default_value, map->value_size);
-		}
-		if (gu_map_entry_is_free(map, &map->data, idx)) {
-			gu_assert(map->data.zero_idx == SIZE_MAX);
-			map->data.zero_idx = idx;
-		}
-		map->data.n_occupied++;
-	}
-	return &map->data.values[idx * map->cell_size];
-}
-
-GU_API void
-gu_map_delete(GuMap* map, const void* key)
-{
-	size_t idx;
-	bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
-	if (found) {
-		if (map->hasher == gu_addr_hasher) {
-			((const void**)map->data.keys)[idx] = NULL;
-		} else if (map->hasher == gu_string_hasher) {
-			((GuString*)map->data.keys)[idx] = NULL;
-		} else {
-			memset(&map->data.keys[idx * map->key_size],
-			       0, map->key_size);
-		}
-		map->data.values[idx * map->cell_size] = SKIP_DELETED;
-
-		if (gu_map_buf_is_zero(&map->data.keys[idx * map->key_size],
-		                       map->key_size)) {
-			map->data.zero_idx = SIZE_MAX;
-		}
-
-		map->data.n_occupied--;
-	}
-}
-
-GU_API void
-gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
-{
-	for (size_t i = 0; i < map->data.n_entries && gu_ok(err); i++) {
-		if (gu_map_entry_is_free(map, &map->data, i)) {
-			continue;
-		}
-		const void* key = &map->data.keys[i * map->key_size];
-		void* value = &map->data.values[i * map->cell_size];
-		if (map->hasher == gu_addr_hasher) {
-			key = *(const void* const*) key;
-		} else if (map->hasher == gu_string_hasher) {
-			key = *(GuString*) key;
-		}
-		itor->fn(itor, key, value, err);
-	}
-}
-
-GU_API bool
-gu_map_next(GuMap* map, size_t* pi, void* pkey, void* pvalue)
-{
-	while (*pi < map->data.n_entries) {
-		if (gu_map_entry_is_free(map, &map->data, *pi)) {
-			(*pi)++;
-			continue;
-		}
-
-		if (map->hasher == gu_addr_hasher) {
-            *((void**) pkey) = *((void**) &map->data.keys[*pi * sizeof(void*)]);
-        } else if (map->hasher == gu_word_hasher) {
-            *((GuWord*) pkey) = *((GuWord*) &map->data.keys[*pi * sizeof(GuWord)]);
-		} else if (map->hasher == gu_string_hasher) {
-			*((GuString*) pkey) = *((GuString*) &map->data.keys[*pi * sizeof(GuString)]);
-		} else {
-            memcpy(pkey, &map->data.keys[*pi * map->key_size], map->key_size);
-        }
-
-		memcpy(pvalue, &map->data.values[*pi * map->cell_size],
-		       map->value_size);
-
-		(*pi)++;
-		return true;
-	}
-
-	return false;
-}
-
-GU_API size_t
-gu_map_count(GuMap* map)
-{
-	size_t count = 0;
-	for (size_t i = 0; i < map->data.n_entries; i++) {
-		if (gu_map_entry_is_free(map, &map->data, i)) {
-			continue;
-		}
-		count++;
-	}
-	return count;
-}
-
-GU_API GuMap*
-gu_make_map(size_t key_size, GuHasher* hasher,
-	    size_t value_size, const void* default_value,
-	    size_t init_size,
-	    GuPool* pool)
-{
-	GuMapData data = {
-		.n_occupied = 0,
-		.n_entries = 0,
-		.keys = NULL,
-		.values = NULL,
-		.zero_idx = SIZE_MAX
-	};
-	GuMap* map = gu_new(GuMap, pool);
-	map->default_value = default_value;
-	map->hasher = hasher;
-	map->data = data;
-	map->key_size = key_size;
-	map->value_size = value_size;
-	map->cell_size = GU_MAX(value_size,sizeof(uint8_t));
-	map->fin.fn = gu_map_finalize;
-	gu_pool_finally(pool, &map->fin);
-
-	init_size = gu_twin_prime_sup(init_size);
-	gu_map_resize(map, init_size);
-	return map;
-}

src/runtime/c/gu/map.h

@@ -1,85 +0,0 @@
-#ifndef GU_MAP_H_
-#define GU_MAP_H_
-
-#include <gu/hash.h>
-#include <gu/mem.h>
-#include <gu/exn.h>
-#include <gu/enum.h>
-
-typedef struct GuMapItor GuMapItor;
-
-struct GuMapItor {
-	void (*fn)(GuMapItor* self, const void* key, void* value,
-		   GuExn *err);
-};
-
-typedef struct GuMap GuMap;
-
-GU_API_DECL GuMap*
-gu_make_map(size_t key_size, GuHasher* hasher,
-	    size_t value_size, const void* default_value,
-	    size_t init_size,
-	    GuPool* pool);
-
-#define GU_MAP_DEFAULT_INIT_SIZE 11
-
-#define gu_new_map(K, HASHER, V, DV, POOL)			\
-	(gu_make_map(sizeof(K), (HASHER), sizeof(V), (DV), GU_MAP_DEFAULT_INIT_SIZE, (POOL)))
-
-#define gu_new_set(K, HASHER, POOL)			\
-	(gu_make_map(sizeof(K), (HASHER), 0, NULL, GU_MAP_DEFAULT_INIT_SIZE, (POOL)))
-
-#define gu_new_addr_map(K, V, DV, POOL)				\
-	(gu_make_map(sizeof(K), gu_addr_hasher, sizeof(V), (DV), GU_MAP_DEFAULT_INIT_SIZE, (POOL)))
-
-GU_API_DECL size_t
-gu_map_count(GuMap* map);
-
-GU_API_DECL void*
-gu_map_find_full(GuMap* ht, void* key_inout);
-
-GU_API_DECL const void*
-gu_map_find_default(GuMap* ht, const void* key);
-
-#define gu_map_get(MAP, KEYP, V)		\
-	(*(V*)gu_map_find_default((MAP), (KEYP)))
-
-GU_API_DECL void*
-gu_map_find(GuMap* ht, const void* key);
-
-#define gu_map_set(MAP, KEYP, V, VAL)				\
-	GU_BEGIN						\
-	V* gu_map_set_p_ = gu_map_find((MAP), (KEYP));		\
-	*gu_map_set_p_ = (VAL);					\
-	GU_END
-
-GU_API_DECL const void*
-gu_map_find_key(GuMap* ht, const void* key);
-
-GU_API_DECL bool
-gu_map_has(GuMap* ht, const void* key);
-
-GU_API_DECL void*
-gu_map_insert(GuMap* ht, const void* key);
-
-GU_API_DECL void
-gu_map_delete(GuMap* ht, const void* key);
-
-#define gu_map_put(MAP, KEYP, V, VAL)				\
-	GU_BEGIN						\
-	V* gu_map_put_p_ = gu_map_insert((MAP), (KEYP));	\
-	*gu_map_put_p_ = (VAL);					\
-	GU_END
-
-GU_API_DECL void
-gu_map_iter(GuMap* ht, GuMapItor* itor, GuExn* err);
-
-GU_API bool
-gu_map_next(GuMap* map, size_t* pi, void* pkey, void* pvalue);
-
-typedef GuMap GuIntMap;
-
-#define gu_new_int_map(VAL_T, DEFAULT, POOL)		\
-	gu_new_map(int, gu_int_hasher, VAL_T, DEFAULT, POOL)
-
-#endif // GU_MAP_H_

src/runtime/c/gu/mem.c

@@ -1,428 +0,0 @@
-#include <gu/mem.h>
-#include <gu/fun.h>
-#include <gu/bits.h>
-#include <gu/assert.h>
-#include <string.h>
-#include <stdlib.h>
-#if !defined(_WIN32) && !defined(_WIN64)
-#include <sys/mman.h>
-#include <sys/stat.h>
-#endif
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <malloc.h>
-#endif
-
-#if !defined(_MSC_VER)
-#include <unistd.h>
-#endif
-#include <fcntl.h>
-
-#ifdef USE_VALGRIND
-#include <valgrind/valgrind.h>
-#define VG(X) X
-#else
-#define VG(X) GU_NOP
-#endif
-
-static const size_t
-// Maximum request size for a chunk. The actual maximum chunk size
-// may be somewhat larger.
-    gu_mem_chunk_max_size = 1024 * sizeof(void*),
-
-// number of bytes to allocate in the pool when it is created
-	gu_mem_pool_initial_size = 24 * sizeof(void*),
-
-// Pool allocations larger than this will get their own chunk if
-// there's no room in the current one. Allocations smaller than this may trigger
-// the creation of a new chunk, in which case the remaining space in
-// the current chunk is left unused (internal fragmentation).
-	gu_mem_max_shared_alloc = 64 * sizeof(void*),
-	
-// Should not be smaller than the granularity for malloc
-	gu_mem_unit_size = 2 * sizeof(void*),
-
-/* Malloc tuning: the additional memory used by malloc next to the
-   allocated object */
-	gu_malloc_overhead = sizeof(size_t);
-
-static void*
-gu_mem_realloc(void* p, size_t size)
-{
-	void* buf = realloc(p, size);
-	if (size != 0 && buf == NULL) {
-		gu_fatal("Memory allocation failed");
-	}
-	return buf;
-}
-
-static void*
-gu_mem_alloc(size_t size)
-{
-	void* buf = malloc(size);
-	if (buf == NULL) {
-		gu_fatal("Memory allocation failed");
-	}
-	return buf;
-}
-
-static void
-gu_mem_free(void* p)
-{
-	free(p);
-}
-
-static size_t
-gu_mem_padovan(size_t min)
-{
-	// This could in principle be done faster with Q-matrices for
-	// Padovan numbers, but not really worth it for our commonly
-	// small numbers.
-	if (min <= 5) {
-		return min;
-	}
-	size_t a = 7, b = 9, c = 12;
-	while (min > a) {
-		if (b < a) {
-			// overflow
-			return SIZE_MAX;
-		}
-		size_t tmp = a + b;
-		a = b;
-		b = c;
-		c = tmp;
-	}
-	return a;
-}
-
-GU_API void*
-gu_mem_buf_realloc(void* old_buf, size_t min_size, size_t* real_size_out)
-{
-	size_t min_blocks = ((min_size + gu_malloc_overhead - 1) /
-			     gu_mem_unit_size) + 1;
-	size_t blocks = gu_mem_padovan(min_blocks);
-	size_t size = blocks * gu_mem_unit_size - gu_malloc_overhead;
-	void* buf = gu_mem_realloc(old_buf, size);
-	*real_size_out = buf ? size : 0;
-	return buf;
-}
-
-GU_API void*
-gu_mem_buf_alloc(size_t min_size, size_t* real_size_out)
-{
-	return gu_mem_buf_realloc(NULL, min_size, real_size_out);
-}
-
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <windows.h>
-
-static int
-getpagesize()
-{
-  SYSTEM_INFO system_info;
-  GetSystemInfo(&system_info);
-  return system_info.dwPageSize;
-}
-#endif
-
-GU_API void*
-gu_mem_page_alloc(size_t min_size, size_t* real_size_out)
-{
-	size_t page_size = getpagesize();
-	size_t size = ((min_size + page_size - 1) / page_size) * page_size;
-	void *page = NULL;
-
-#if defined(ANDROID)
-	if ((page = memalign(page_size, size)) == NULL) {	
-#elif defined(__MINGW32__) || defined(_MSC_VER)
-	if ((page = malloc(size)) == NULL) {
-#else
-	if (posix_memalign(&page, page_size, size) != 0) {
-#endif
-		gu_fatal("Memory allocation failed");
-	}
-
-	*real_size_out = size;
-	return page;
-}
-
-GU_API void
-gu_mem_buf_free(void* buf)
-{
-	gu_mem_free(buf);
-}
-
-
-typedef struct GuMemChunk GuMemChunk;
-
-struct GuMemChunk {
-	GuMemChunk* next;
-	uint8_t data[];
-};
-
-typedef struct GuFinalizerNode GuFinalizerNode;
-
-struct GuFinalizerNode {
-	GuFinalizerNode* next;
-	GuFinalizer* fin;
-};
-
-enum GuPoolType {
-	GU_POOL_HEAP,
-	GU_POOL_LOCAL,
-	GU_POOL_PAGE,
-	GU_POOL_MMAP
-};
-
-struct GuPool {
-	uint8_t* curr_buf; // actually GuMemChunk*
-	GuMemChunk* chunks;
-	GuFinalizerNode* finalizers;
-	uint16_t type;
-	size_t left_edge;
-	size_t right_edge;
-	size_t curr_size;
-	uint8_t init_buf[];
-};
-
-static GuPool*
-gu_init_pool(uint8_t* buf, size_t sz)
-{
-	gu_require(gu_aligned((uintptr_t) (void*) buf, gu_alignof(GuPool)));
-	gu_require(sz >= sizeof(GuPool));
-	GuPool* pool = (GuPool*) buf;
-	pool->type = GU_POOL_HEAP;
-	pool->curr_size = sz;
-	pool->curr_buf = (uint8_t*) pool;
-	pool->chunks = NULL;
-	pool->finalizers = NULL;
-	pool->left_edge = offsetof(GuPool, init_buf);
-	pool->right_edge = sz;
-	VG(VALGRIND_CREATE_MEMPOOL(pool, 0, false));
-	return pool;
-}
-
-GU_API GuPool*
-gu_local_pool_(uint8_t* buf, size_t sz)
-{
-	GuPool* pool = gu_init_pool(buf, sz);
-	pool->type = GU_POOL_LOCAL;
-	return pool;
-}
-
-GU_API GuPool* 
-gu_new_pool(void)
-{
-	size_t sz = GU_FLEX_SIZE(GuPool, init_buf, gu_mem_pool_initial_size);
-	uint8_t* buf = gu_mem_buf_alloc(sz, &sz);
-	GuPool* pool = gu_init_pool(buf, sz);
-	return pool;
-}
-
-GU_API GuPool*
-gu_new_page_pool(void)
-{
-	size_t sz = GU_FLEX_SIZE(GuPool, init_buf, gu_mem_pool_initial_size);
-	uint8_t* buf = gu_mem_page_alloc(sz, &sz);
-	GuPool* pool = gu_init_pool(buf, sz);
-	pool->type = GU_POOL_PAGE;
-	return pool;
-}
-
-GU_API GuPool* 
-gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr)
-{
-#if !defined(_WIN32) && !defined(_WIN64)
-	int prot = PROT_READ;
-	int fd = open(fpath, O_RDONLY);
-	if (fd < 0) {
-		if (errno == ENOENT) {
-			fd = open(fpath, O_RDWR | O_CREAT | O_TRUNC, S_IRUSR | S_IWUSR);
-			if (fd < 0)
-				return NULL;
-
-			if (ftruncate(fd, size) < 0) {
-				close(fd);
-				return NULL;
-			}
-
-			prot |= PROT_WRITE;
-		} else {
-			return NULL;
-		}
-	}
-
-	void *ptr = mmap(addr, size, prot, MAP_SHARED | MAP_FIXED, fd, 0);
-	if (ptr == MAP_FAILED) {
-		close(fd);
-		return NULL;
-	}
-
-	gu_require(ptr == addr);
-
-	*pptr = (prot & PROT_WRITE) ? NULL : ptr;
-
-	size_t sz = GU_FLEX_SIZE(GuPool, init_buf, sizeof(int));
-	uint8_t* buf = gu_mem_buf_alloc(sz, &sz);
-	GuPool* pool = gu_init_pool(buf, size);
-
-	uint8_t* pfd = pool->init_buf;
-	*((int*) pfd) = fd;
-
-	pool->type = GU_POOL_MMAP;
-	pool->curr_buf = ptr;
-	pool->left_edge = 0;
-
-	return pool;
-#else
-	return NULL;
-#endif
-}
-
-static void
-gu_pool_expand(GuPool* pool, size_t req)
-{
-	gu_require(pool->type != GU_POOL_MMAP);
-	size_t real_req = GU_MAX(req, GU_MIN(((size_t)pool->curr_size) + 1,
-					     gu_mem_chunk_max_size));
-	gu_assert(real_req >= sizeof(GuMemChunk));
-	size_t size = 0;
-	GuMemChunk* chunk = 
-		(pool->type == GU_POOL_PAGE)
-		   ? gu_mem_page_alloc(real_req,  &size)
-		   : gu_mem_buf_alloc(real_req, &size);
-	chunk->next = pool->chunks;
-	pool->chunks = chunk;
-	pool->curr_buf = (uint8_t*) chunk;
-	pool->left_edge = offsetof(GuMemChunk, data);
-	pool->right_edge = pool->curr_size = size;
-	gu_assert((size_t) pool->right_edge == size); 
-}
-
-static size_t
-gu_mem_advance(size_t old_pos, size_t pre_align, size_t pre_size,
-	       size_t align, size_t size)
-{
-	size_t p = gu_align_forward(old_pos, pre_align);
-	p += pre_size;
-	p = gu_align_forward(p, align);
-	p += size;
-	return p;
-}
-
-static void*
-gu_pool_malloc_aligned(GuPool* pool, size_t pre_align, size_t pre_size,
-		       size_t align, size_t size) 
-{
-	size_t pos = gu_mem_advance(pool->left_edge, pre_align, pre_size,
-				    align, size);
-	if (pos > (size_t) pool->right_edge) {
-		pos = gu_mem_advance(offsetof(GuMemChunk, data),
-				     pre_align, pre_size, align, size);
-		gu_pool_expand(pool, pos);
-		gu_assert(pos <= pool->right_edge);
-	}
-	pool->left_edge = pos;
-	uint8_t* addr = &pool->curr_buf[pos - size];
-	VG(VALGRIND_MEMPOOL_ALLOC(pool, addr - pre_size, size + pre_size ));
-	return addr;
-}
-
-static size_t
-gu_pool_avail(GuPool* pool)
-{
-	return (size_t) pool->right_edge - (size_t) pool->left_edge;
-}
-
-GU_API void*
-gu_pool_malloc_unaligned(GuPool* pool, size_t size)
-{
-	if (size > gu_pool_avail(pool)) {
-		gu_pool_expand(pool, offsetof(GuMemChunk, data) + size);
-		gu_assert(size <= gu_pool_avail(pool));
-	}
-	pool->right_edge -= size;
-	void* addr = &pool->curr_buf[pool->right_edge];
-	VG(VALGRIND_MEMPOOL_ALLOC(pool, addr, size));
-	return addr;
-}
-
-GU_API void*
-gu_malloc_prefixed(GuPool* pool, size_t pre_align, size_t pre_size,
-		   size_t align, size_t size)
-{
-	void* ret = NULL;
-	if (pre_align == 0) {
-		pre_align = gu_alignof(GuMaxAlign);
-	}
-	if (align == 0) {
-		align = gu_alignof(GuMaxAlign);
-	}
-	size_t full_size = gu_mem_advance(offsetof(GuMemChunk, data),
-					  pre_align, pre_size, align, size);
-	if (full_size > gu_mem_max_shared_alloc &&
-	    pool->type != GU_POOL_PAGE &&
-	    pool->type != GU_POOL_MMAP) {
-		GuMemChunk* chunk = gu_mem_alloc(full_size);
-		chunk->next = pool->chunks;
-		pool->chunks = chunk;
-		uint8_t* addr = &chunk->data[full_size - size
-					     - offsetof(GuMemChunk, data)];
-		VG(VALGRIND_MEMPOOL_ALLOC(pool, addr - pre_size,
-					  pre_size + size));
-		ret = addr;
-	} else if (pre_align == 1 && align == 1) {
-		uint8_t* buf = gu_pool_malloc_unaligned(pool, pre_size + size);
-		ret = &buf[pre_size];
-	} else {
-		ret = gu_pool_malloc_aligned(pool, pre_align, pre_size,
-					     align, size);
-	}
-	return ret;
-}
-
-GU_API void*
-gu_malloc_aligned(GuPool* pool, size_t size, size_t align)
-{
-	return gu_malloc_prefixed(pool, 1, 0, align, size);
-}
-
-GU_API void 
-gu_pool_finally(GuPool* pool, GuFinalizer* finalizer)
-{
-	gu_require(pool->type != GU_POOL_MMAP);
-	GuFinalizerNode* node = gu_new(GuFinalizerNode, pool);
-	node->next = pool->finalizers;
-	node->fin = finalizer;
-	pool->finalizers = node;
-}
-
-GU_API void
-gu_pool_free(GuPool* pool)
-{
-	GuFinalizerNode* node = pool->finalizers;
-	while (node) {
-		node->fin->fn(node->fin);
-		node = node->next;
-	}
-	GuMemChunk* chunk = pool->chunks;
-	while (chunk) {
-		GuMemChunk* next = chunk->next;
-		gu_mem_buf_free(chunk);
-		chunk = next;
-	}
-	VG(VALGRIND_DESTROY_MEMPOOL(pool));
-	if (pool->type == GU_POOL_HEAP) {
-		gu_mem_buf_free(pool);
-	} else if (pool->type == GU_POOL_MMAP) {
-#if !defined(_WIN32) && !defined(_WIN64)
-		uint8_t* pfd = pool->init_buf;
-		int fd = *(pfd);
-
-		munmap(pool->curr_buf, pool->curr_size);
-		close(fd);
-#endif
-	}
-}
-
-
-extern inline void* gu_malloc(GuPool* pool, size_t size);

src/runtime/c/gu/mem.h

@@ -1,218 +0,0 @@
-/** @file
- *
- * Memory allocation tools.
- */
-
-#ifndef GU_MEM_H_
-#define GU_MEM_H_
-
-#include <gu/defs.h>
-#include <gu/fun.h>
-
-/** @defgroup GuPool Memory pools */
-//@{ 
-
-
-/// A memory pool.
-typedef struct GuPool GuPool;
-
-/// @name Creating a pool 
-//@{
-
-
-/// Create a new memory pool.
-GU_API_DECL GuPool*
-gu_new_pool(void);
-
-/**< 
- * @return A new memory pool.
- */
-
-
-//@private
-GU_API_DECL GuPool*
-gu_local_pool_(uint8_t* init_buf, size_t sz);
-
-//@private
-#define GU_LOCAL_POOL_INIT_SIZE (16 * sizeof(GuWord))
-
-
-/// Create a stack-allocated memory pool.
-#define gu_local_pool()				\
-	gu_local_pool_(gu_alloca(GU_LOCAL_POOL_INIT_SIZE),	\
-		       GU_LOCAL_POOL_INIT_SIZE)
-/**<
- * @return A memory pool whose first chunk is allocated directly from
- * the stack. This makes its creation faster, and more suitable for
- * functions that usually allocate only a little memory from the pool
- * until it is freed.
- *
- * @note The pool created with #gu_local_pool \e must be freed with
- * #gu_pool_free before the end of the block where #gu_local_pool was
- * called.
- *
- * @note Because #gu_local_pool uses relatively much stack space, it
- * should not be used in the bodies of recursive functions.
- */
-
-/// Create a pool where each chunk is corresponds to one or
-/// more pages.
-GU_API_DECL GuPool*
-gu_new_page_pool(void);
-
-/// Create a pool stored in a memory mapped file.
-GU_API_DECL GuPool* 
-gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr);
-
-//@}
-/// @name Destroying a pool
-//@{
-
-
-/// Free a memory pool and all objects allocated from it.
-GU_API_DECL void
-gu_pool_free(GU_ONLY GuPool* pool);
-/**<
- * When the pool is freed, all finalizers registered by
- * #gu_pool_finally on \p pool are invoked in reverse order of
- * registration.
- * 
- * @note After the pool is freed, all objects allocated from it become
- * invalid and may no longer be used. */
-
-//@}
-/// @name Allocating from a pool
-//@{
- 
-
-/// Allocate memory with a specified alignment.
-GU_API_DECL void* 
-gu_malloc_aligned(GuPool* pool, size_t size, size_t alignment); 
-
-GU_API_DECL void*
-gu_malloc_prefixed(GuPool* pool, size_t pre_align, size_t pre_size,
-		   size_t align, size_t size);
-
-/// Allocate memory from a pool.
-inline void*
-gu_malloc(GuPool* pool, size_t size) {
-	return gu_malloc_aligned(pool, size, 0);
-}
-
-#include <string.h>
-
-/** Allocate memory to store an array of objects of a given type. */
-
-#define gu_new_n(type, n, pool)						\
-	((type*)gu_malloc_aligned((pool),				\
-				  sizeof(type) * (n),			\
-				  gu_alignof(type)))
-/**< 
- * @param type  The C type of the objects to allocate.
- *
- * @param n     The number of objects to allocate.
- * 
- * @param pool  The memory pool to allocate from.
- *
- * @return A pointer to a heap-allocated array of \p n uninitialized
- * objects of type \p type. 
- */ 
-
-
-/** Allocate memory to store an object of a given type. */
-
-#define gu_new(type, pool) \
-	gu_new_n(type, 1, pool)
-/**< 
- * @param type  The C type of the object to allocate.
- *
- * @param pool  The memory pool to allocate from.
- *
- * @return A pointer to a heap-allocated uninitialized object of type
- * \p type.
- */
-
-
-#define gu_new_prefixed(pre_type, type, pool)				\
-	((type*)(gu_malloc_prefixed((pool),				\
-				    gu_alignof(pre_type), sizeof(pre_type), \
-				    gu_alignof(type), sizeof(type))))
-
-// Alas, there's no portable way to get the alignment of flex structs.
-#define gu_new_flex(pool_, type_, flex_member_, n_elems_)		\
-	((type_ *)gu_malloc_aligned(					\
-		(pool_),						\
-		GU_FLEX_SIZE(type_, flex_member_, n_elems_),		\
-		gu_flex_alignof(type_)))
-
-
-//@}
-/// @name Finalizers
-//@{
-
-
-typedef struct GuFinalizer GuFinalizer;
-
-struct GuFinalizer {
-	void (*fn)(GuFinalizer* self);
-	///< @param self A pointer to this finalizer.
-};
-
-/// Register a finalizer.
-GU_API_DECL void gu_pool_finally(GuPool* pool, GuFinalizer* fini);
-
-/**< Register \p fini to be called when \p pool is destroyed. The
- * finalizers are called in reverse order of registration.
- */
-
-
-//@}
-//@}
-
-/** @defgroup GuMemBuf Memory buffers
- *
- * Resizable blocks of heap-allocated memory. These operations differ
- * from standard \c malloc, \c realloc and \c free -functions in that
- * memory buffers are not allocated by exact size. Instead, a minimum
- * size is requested, and the returned buffer may be larger. This
- * gives the memory allocator more flexibility when the client code
- * can make use of larger buffers than requested.
- * */
-
-//@{
-
-
-/// Allocate a new memory buffer.
-GU_API_DECL void*
-gu_mem_buf_alloc(size_t min_size, size_t* real_size);
-/**<
- * @param min_size The minimum acceptable size for a returned memory block.
- *
- * @param[out] real_size The actual size of the returned memory
- * block. This is never less than \p min_size.
- *
- * @return A pointer to the memory buffer.
- */
-
-
-/// Allocate a new memory buffer to replace an old one.
-GU_API_DECL void*
-gu_mem_buf_realloc(
-	GU_NULL GU_ONLY GU_RETURNED
-	void* buf,
-	size_t min_size,
-	size_t* real_size_out);
-
-/// Allocate enough memory pages to contain min_size bytes.
-GU_API_DECL void*
-gu_mem_page_alloc(size_t min_size, size_t* real_size_out);
-
-/// Free a memory buffer.
-GU_API_DECL void
-gu_mem_buf_free(GU_ONLY void* buf);
-
-
-//@}
-
-
-#endif // GU_MEM_H_

src/runtime/c/gu/out.c

@@ -1,303 +0,0 @@
-#include <gu/seq.h>
-#include <gu/out.h>
-#include <gu/utf8.h>
-#include <gu/bits.h>
-#include <stdio.h>
-
-static bool
-gu_out_is_buffering(GuOut* out)
-{
-	return !!out->buf_end;
-}
-
-
-static void
-gu_out_end_buf(GuOut* out, GuExn* err)
-{
-	if (!gu_out_is_buffering(out)) {
-		return;
-	}
-	GuOutStream* stream = out->stream;
-	size_t curr_len = ((ptrdiff_t)out->buf_size) + out->buf_curr;
-	stream->end_buf(stream, curr_len, err);
-	out->buf_end = NULL;
-	out->buf_size = out->buf_curr = 0;
-}
-
-static bool
-gu_out_begin_buf(GuOut* out, size_t req, GuExn* err)
-{
-	GuOutStream* stream = out->stream;
-	if (gu_out_is_buffering(out)) {
-		if (out->buf_curr < 0) {
-			return true;
-		} else {
-			gu_out_end_buf(out, err);
-			if (!gu_ok(err)) {
-				return false;
-			}
-		}
-	}
-	if (stream->begin_buf) {
-		size_t sz = 0;
-		uint8_t* buf = stream->begin_buf(stream, req, &sz, err);
-		gu_assert(sz <= PTRDIFF_MAX);
-		if (buf) {
-			out->buf_end = &buf[sz];
-			out->buf_curr = -(ptrdiff_t) sz;
-			out->buf_size = sz;
-			return true;
-		}
-	}
-	return false;
-}
-
-
-
-static void
-gu_out_fini(GuFinalizer* self)
-{
-	GuOut* out = gu_container(self, GuOut, fini);
-	if (gu_out_is_buffering(out)) {
-		GuPool* pool = gu_local_pool();
-		GuExn* err = gu_new_exn(pool);
-		gu_out_end_buf(out, err);
-		gu_pool_free(pool);
-	}
-}
-
-GU_API GuOut*
-gu_new_out(GuOutStream* stream, GuPool* pool)
-{
-	gu_require(stream != NULL);
-
-	GuOut* out = gu_new(GuOut, pool);
-	out->buf_end = NULL,
-	out->buf_curr = 0,
-	out->stream = stream,
-	out->fini.fn = gu_out_fini;
-	gu_pool_finally(pool, &out->fini);
-	return out;
-}
-
-extern inline bool
-gu_out_try_buf_(GuOut* out, const uint8_t* src, size_t len);
-
-extern inline size_t
-gu_out_bytes(GuOut* out, const uint8_t* buf, size_t len, GuExn* err);
-
-static size_t
-gu_out_output(GuOut* out, const uint8_t* src, size_t len, GuExn* err)
-{
-	gu_out_end_buf(out, err);
-	if (!gu_ok(err)) {
-		return 0;
-	}
-	return out->stream->output(out->stream, src, len, err);
-}
-
-GU_API void 
-gu_out_flush(GuOut* out, GuExn* err)
-{
-	GuOutStream* stream = out->stream;
-	if (out->buf_end) {
-		gu_out_end_buf(out, err);
-		if (!gu_ok(err)) {
-			return;
-		}
-	}
-	if (stream->flush) {
-		stream->flush(stream, err);
-	}
-}
-
-GU_API uint8_t*
-gu_out_begin_span(GuOut* out, size_t req, size_t* sz_out, GuExn* err)
-{
-	if (!out->buf_end && !gu_out_begin_buf(out, req, err)) {
-		return NULL;
-	}
-	*sz_out = -out->buf_curr;
-	return &out->buf_end[out->buf_curr];
-}
-
-GU_API void
-gu_out_end_span(GuOut* out, size_t sz)
-{
-	ptrdiff_t new_curr = (ptrdiff_t) sz + out->buf_curr;
-	gu_require(new_curr <= 0);
-	out->buf_curr = new_curr;
-}
-
-GU_API size_t
-gu_out_bytes_(GuOut* restrict out, const uint8_t* restrict src, size_t len, 
-	      GuExn* err)
-{
-	if (!gu_ok(err)) {
-		return 0;
-	} else if (gu_out_try_buf_(out, src, len)) {
-		return len;
-	}
-	if (gu_out_begin_buf(out, len, err)) {
-		if (gu_out_try_buf_(out, src, len)) {
-			return len;
-		}
-	}
-	return gu_out_output(out, src, len, err);
-}
-
-GU_API void
-gu_out_u8_(GuOut* restrict out, uint8_t u, GuExn* err)
-{
-	if (gu_out_begin_buf(out, 1, err)) {
-		if (gu_out_try_u8_(out, u)) {
-			return;
-		}
-	}
-	gu_out_output(out, &u, 1, err);
-}
-
-extern inline void
-gu_out_u8(GuOut* restrict out, uint8_t u, GuExn* err);
-
-extern inline void
-gu_out_s8(GuOut* restrict out, int8_t i, GuExn* err);
-
-extern inline bool
-gu_out_is_buffered(GuOut* out);
-
-extern inline bool
-gu_out_try_u8_(GuOut* restrict out, uint8_t u);
-
-GU_API void
-gu_out_u16be(GuOut* out, uint16_t u, GuExn* err)
-{
-	gu_out_u8(out, (u>>8) & 0xFF, err);
-	gu_out_u8(out, u      & 0xFF, err);
-}
-
-GU_API void
-gu_out_u64be(GuOut* out, uint64_t u, GuExn* err)
-{
-	gu_out_u8(out, (u>>56) & 0xFF, err);
-	gu_out_u8(out, (u>>48) & 0xFF, err);
-	gu_out_u8(out, (u>>40) & 0xFF, err);
-	gu_out_u8(out, (u>>32) & 0xFF, err);
-	gu_out_u8(out, (u>>24) & 0xFF, err);
-	gu_out_u8(out, (u>>16) & 0xFF, err);
-	gu_out_u8(out, (u>>8)  & 0xFF, err);
-	gu_out_u8(out, u       & 0xFF, err);
-}
-
-GU_API void
-gu_out_f64be(GuOut* out, double d, GuExn* err)
-{
-	gu_out_u64be(out, gu_encode_double(d), err);
-}
-
-typedef struct GuBufferedOutStream GuBufferedOutStream;
-
-struct GuBufferedOutStream {
-	GuOutStream stream;
-	GuOut* real_out;
-	size_t sz;
-	uint8_t buf[];
-};
-
-static uint8_t*
-gu_buffered_out_buf_begin(GuOutStream* self, size_t req, size_t* sz_out,
-			  GuExn* err)
-{
-	(void) (req && err);
-	GuBufferedOutStream* b =
-		gu_container(self, GuBufferedOutStream, stream);
-	*sz_out = b->sz;
-	return b->buf;
-}
-
-static void
-gu_buffered_out_buf_end(GuOutStream* self, size_t sz, GuExn* err)
-{
-	GuBufferedOutStream* b =
-		gu_container(self, GuBufferedOutStream, stream);
-	gu_require(sz <= b->sz);
-	gu_out_bytes(b->real_out, b->buf, sz, err);
-}
-
-static size_t
-gu_buffered_out_output(GuOutStream* self, const uint8_t* src, size_t sz,
-		    GuExn* err)
-{
-	GuBufferedOutStream* bos =
-		gu_container(self, GuBufferedOutStream, stream);
-	return gu_out_bytes(bos->real_out, src, sz, err);
-}
-
-static void
-gu_buffered_out_flush(GuOutStream* self, GuExn* err)
-{
-	GuBufferedOutStream* bos =
-		gu_container(self, GuBufferedOutStream, stream);
-	gu_out_flush(bos->real_out, err);
-}
-
-GU_API GuOut*
-gu_new_buffered_out(GuOut* out, size_t sz, GuPool* pool)
-{
-	GuBufferedOutStream* b =
-		gu_new_flex(pool, GuBufferedOutStream, buf, sz);
-	b->stream = (GuOutStream) {
-		.begin_buf = gu_buffered_out_buf_begin,
-		.end_buf = gu_buffered_out_buf_end,
-		.output = gu_buffered_out_output,
-		.flush = gu_buffered_out_flush
-	};
-	b->real_out = out;
-	b->sz = sz;
-	return gu_new_out(&b->stream, pool);
-}
-
-GU_API GuOut*
-gu_out_buffered(GuOut* out, GuPool* pool)
-{
-	if (gu_out_is_buffered(out)) {
-		return out;
-	}
-	return gu_new_buffered_out(out, 4096, pool);
-}
-
-
-extern inline void
-gu_putc(char c, GuOut* out, GuExn* err);
-
-GU_API void
-gu_puts(const char* str, GuOut* out, GuExn* err)
-{
-	gu_out_bytes(out, (const uint8_t*) str, strlen(str), err);
-}
-
-GU_API void
-gu_vprintf(const char* fmt, va_list args, GuOut* out, GuExn* err)
-{
-	GuPool* tmp_pool = gu_local_pool();
-
-	va_list args2;
-	va_copy(args2, args);
-	int len = vsnprintf(NULL, 0, fmt, args2);
-	gu_assert_msg(len >= 0, "Invalid format string: \"%s\"", fmt);
-	va_end(args2);
-	char* str = gu_new_n(char, len + 1, tmp_pool);
-	vsnprintf(str, len + 1, fmt, args);
-
-	gu_out_bytes(out, (const uint8_t*) str, strlen(str), err);
-	gu_pool_free(tmp_pool);
-}
-
-GU_API void
-gu_printf(GuOut* out, GuExn* err, const char* fmt, ...)
-{
-	va_list args;
-	va_start(args, fmt);
-	gu_vprintf(fmt, args, out, err);
-	va_end(args);
-}

src/runtime/c/gu/out.h

@@ -1,174 +0,0 @@
-#ifndef GU_OUT_H_
-#define GU_OUT_H_
-
-#include <gu/defs.h>
-#include <gu/assert.h>
-#include <gu/exn.h>
-#include <gu/ucs.h>
-
-typedef struct GuOut GuOut;
-
-typedef struct GuOutStream GuOutStream;
-
-struct GuOutStream {
-	uint8_t* (*begin_buf)(GuOutStream* self, size_t req, size_t* sz_out,
-			      GuExn* err);
-	void (*end_buf)(GuOutStream* self, size_t span, GuExn* err);
-	size_t (*output)(GuOutStream* self, const uint8_t* buf, size_t size,
-			 GuExn* err);
-	void (*flush)(GuOutStream* self, GuExn* err);
-};
-
-
-struct GuOut {
-	uint8_t* restrict buf_end;
-	ptrdiff_t buf_curr;
-	size_t buf_size;
-	GuOutStream* stream;
-	GuFinalizer fini;
-};
-
-GU_API_DECL GuOut*
-gu_new_out(GuOutStream* stream, GuPool* pool);
-
-inline bool
-gu_out_is_buffered(GuOut* out)
-{
-	return !!out->stream->begin_buf;
-}
-
-GU_API_DECL GuOut*
-gu_new_buffered_out(GuOut* out, size_t buf_sz, GuPool* pool);
-
-GU_API_DECL GuOut*
-gu_out_buffered(GuOut* out, GuPool* pool);
-
-GU_API_DECL uint8_t*
-gu_out_begin_span(GuOut* out, size_t req, size_t* sz_out, GuExn* err);
-
-GU_API_DECL uint8_t*
-gu_out_force_span(GuOut* out, size_t min, size_t max, size_t* sz_out,
-		  GuExn* err);
-
-GU_API_DECL void
-gu_out_end_span(GuOut* out, size_t sz);
-
-GU_API_DECL size_t
-gu_out_bytes_(GuOut* restrict out, const uint8_t* restrict src, 
-	      size_t len, GuExn* err);
-
-inline bool
-gu_out_try_buf_(GuOut* restrict out, const uint8_t* restrict src, size_t len)
-{
-	gu_require(len <= PTRDIFF_MAX);
-	ptrdiff_t curr = out->buf_curr;
-	ptrdiff_t new_curr = curr + (ptrdiff_t) len;
-	if (GU_UNLIKELY(new_curr > 0)) {
-		return false;
-	}
-	memcpy(&out->buf_end[curr], src, len);
-	out->buf_curr = new_curr;
-	return true;
-}
-
-inline size_t
-gu_out_bytes(GuOut* restrict out, const uint8_t* restrict src, size_t len, 
-	     GuExn* err)
-{
-	if (GU_LIKELY(gu_out_try_buf_(out, src, len))) {
-		return len;
-	}
-	return gu_out_bytes_(out, src, len, err);
-}
-
-GU_API_DECL void
-gu_out_flush(GuOut* out, GuExn* err);
-
-inline bool
-gu_out_try_u8_(GuOut* restrict out, uint8_t u)
-{
-	ptrdiff_t curr = out->buf_curr;
-	ptrdiff_t new_curr = curr + 1;
-	if (GU_UNLIKELY(new_curr > 0)) {
-		return false;
-	}
-	out->buf_end[curr] = u;
-	out->buf_curr = new_curr;
-	return true;
-}
-
-inline void
-gu_out_u8(GuOut* restrict out, uint8_t u, GuExn* err)
-{
-	if (GU_UNLIKELY(!gu_out_try_u8_(out, u))) {
-		GU_API_DECL void gu_out_u8_(GuOut* restrict out, uint8_t u, 
-				       GuExn* err);
-		gu_out_u8_(out, u, err);
-	}
-}
-
-inline void
-gu_out_s8(GuOut* restrict out, int8_t i, GuExn* err)
-{
-	gu_out_u8(out, (uint8_t) i, err);
-}
-
-GU_API_DECL void
-gu_out_u16le(GuOut* out, uint16_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_u16be(GuOut* out, uint16_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s16le(GuOut* out, int16_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s16be(GuOut* out, int16_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_u32le(GuOut* out, uint32_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_u32be(GuOut* out, uint32_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s32le(GuOut* out, int32_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s32be(GuOut* out, int32_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_u64le(GuOut* out, uint64_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_u64be(GuOut* out, uint64_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s64le(GuOut* out, int64_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_s64be(GuOut* out, int64_t u, GuExn* err);
-
-GU_API_DECL void
-gu_out_f64le(GuOut* out, double d, GuExn* err);
-
-GU_API_DECL void
-gu_out_f64be(GuOut* out, double d, GuExn* err);
-
-inline void
-gu_putc(char c, GuOut* out, GuExn* err)
-{
-	GuUCS ucs = gu_char_ucs(c);
-	gu_out_u8(out, (uint8_t) ucs, err);
-}
-
-GU_API_DECL void
-gu_puts(const char* str, GuOut* out, GuExn* err);
-
-GU_API_DECL void
-gu_vprintf(const char* fmt, va_list args, GuOut* out, GuExn* err);
-
-GU_API_DECL void
-gu_printf(GuOut* out, GuExn* err, const char* fmt, ...);
-
-#endif // GU_OUT_H_

src/runtime/c/gu/prime.c

@@ -1,154 +0,0 @@
-#include <gu/defs.h>
-#include <gu/assert.h>
-
-static const uint32_t gu_prime_wheel_mask = 0UL
-	| 1 << 1
-	| 1 << 7
-	| 1 << 11
-	| 1 << 13
-	| 1 << 17
-	| 1 << 19
-	| 1 << 23
-	| 1 << 29;
-
-static bool
-gu_prime_wheel(int i)
-{
-	gu_assert(i >= 0 && i < 30);
-	return !!(gu_prime_wheel_mask & (1 << i));
-}
-
-static const uint32_t gu_small_prime_mask = 0UL
-	| 1 << 2
-	| 1 << 3 
-	| 1 << 5
-	| 1 << 7
-	| 1 << 11
-	| 1 << 13
-	| 1 << 17
-	| 1 << 19
-	| 1 << 23
-	| 1 << 29
-	| 1U << 31;
-
-static bool
-gu_is_wheel_prime(int u)
-{
-	gu_assert(u > 30 && u % 2 != 0 && u % 3 != 0 && u % 5 != 0);
-	int d = 0;
-	int i = 7;
-	goto start;
-	while (d * d <= u) {
-		for (i = 1; i <= 29; i+=2) {
-		start:
-			if (gu_prime_wheel(i) && u % (d + i) == 0) {
-				return false;
-			}
-		}
-		d += 30;
-	}
-	return true;
-}
-
-GU_INTERNAL int
-gu_prime_inf(int i)
-{
-	if (i < 2) {
-		return 0;
-	} else if (i < 32) {
-		while (!(gu_small_prime_mask & (1 << i))) {
-			i--;
-		}
-		return i;
-	}
-
-	int d = (i - 1) | 1;
-	int r = d % 30;
-
-	while (!gu_prime_wheel(r) || !gu_is_wheel_prime(d)) {
-		d -= 2;
-		r -= 2;
-		if (r < 0) {
-			r += 30;
-		} 
-	}
-	return d;
-}
-
-GU_INTERNAL int
-gu_prime_sup(int i)
-{
-	if (i <= 2) {
-		return 2;
-	} else if (i < 32) {
-		while (!(gu_small_prime_mask & (1 << i))) {
-			i++;
-		}
-		return i;
-	}
-
-	int d = i | 1;
-	int r = d % 30;
-
-	while (!gu_prime_wheel(r) || !gu_is_wheel_prime(d)) {
-		d += 2;
-		r += 2;
-		if (r > 30) {
-			r -= 30;
-		}
-	}
-	return d;
-}
-
-GU_INTERNAL bool
-gu_is_prime(int i)
-{
-	if (i < 2) {
-		return false;
-	} else if (i < 30) {
-		return !!(gu_small_prime_mask & (1 << i));
-	} else if (!gu_prime_wheel(i % 30)) {
-		return false;
-	} else {
-		return gu_is_wheel_prime(i);
-	}
-}
-
-GU_INTERNAL bool
-gu_is_twin_prime(int i)
-{
-	return gu_is_prime(i) && gu_is_prime(i - 2);
-}
-
-GU_INTERNAL int
-gu_twin_prime_inf(int i)
-{
-	while (true) {
-		i = gu_prime_inf(i);
-		if (i == 0) {
-			return 0;
-		} else if (gu_is_prime(i - 2)) {
-			return i;
-		}
-		i = i - 4;
-	}
-	return i;
-}
-
-GU_INTERNAL int
-gu_twin_prime_sup(int i)
-{
-	if (i <= 5) {
-		return 5;
-	}
-	i = i - 2;
-	while (true) {
-		i = gu_prime_sup(i);
-		if (gu_is_prime(i + 2)) {
-			return i + 2;
-		}
-		i = i + 4;
-	}
-	return i;
-}
-

src/runtime/c/gu/prime.h

@@ -1,16 +0,0 @@
-#ifndef GU_PRIME_H_
-#define GU_PRIME_H_
-
-#include <gu/defs.h>
-
-GU_INTERNAL_DECL bool gu_is_prime(int i);
-
-GU_INTERNAL_DECL bool gu_is_twin_prime(int i);
-
-GU_INTERNAL_DECL int gu_prime_inf(int i);
-GU_INTERNAL_DECL int gu_twin_prime_inf(int i);
-
-GU_INTERNAL_DECL int gu_prime_sup(int i);
-GU_INTERNAL_DECL int gu_twin_prime_sup(int i);
-
-#endif // GU_PRIME_H_

src/runtime/c/gu/seq.c

@@ -1,386 +0,0 @@
-#include <gu/out.h>
-#include <gu/seq.h>
-#include <gu/fun.h>
-#include <gu/assert.h>
-#include <stdlib.h>
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <malloc.h>
-#endif
-
-static void
-gu_buf_fini(GuFinalizer* fin)
-{
-	GuBuf* buf = gu_container(fin, GuBuf, fin);
-	if (buf->avail_len > 0)
-		gu_mem_buf_free(buf->seq);
-}
-
-GU_API GuBuf*
-gu_make_buf(size_t elem_size, GuPool* pool)
-{
-	GuBuf* buf = gu_new(GuBuf, pool);
-	buf->seq = gu_empty_seq();
-	buf->elem_size = elem_size;
-	buf->avail_len = 0;
-	buf->fin.fn = gu_buf_fini;
-	gu_pool_finally(pool, &buf->fin);
-	return buf;
-}
-
-extern size_t
-gu_buf_length(GuBuf* buf);
-
-extern size_t
-gu_buf_avail(GuBuf* buf);
-
-extern void*
-gu_buf_data(GuBuf* buf);
-
-extern GuSeq*
-gu_buf_data_seq(GuBuf* buf);
-
-extern void*
-gu_buf_extend(GuBuf* buf);
-
-extern const void*
-gu_buf_trim(GuBuf* buf);
-
-extern void
-gu_buf_flush(GuBuf* buf);
-
-static GuSeq gu_empty_seq_ = {0};
-
-GU_API GuSeq*
-gu_empty_seq() {
-	return &gu_empty_seq_;
-}
-
-GU_API GuSeq*
-gu_make_seq(size_t elem_size, size_t length, GuPool* pool)
-{
-	GuSeq* seq = gu_malloc(pool, sizeof(GuSeq) + elem_size * length);
-	seq->len = length;
-	return seq;
-}
-
-extern size_t
-gu_seq_length(GuSeq* seq);
-
-extern void*
-gu_seq_data(GuSeq* seq);
-
-GU_API GuSeq*
-gu_alloc_seq_(size_t elem_size, size_t length)
-{
-	if (length == 0)
-		return gu_empty_seq();
-
-	size_t real_size;
-	GuSeq* seq = gu_mem_buf_alloc(sizeof(GuSeq) + elem_size * length, &real_size);
-	seq->len = (real_size - sizeof(GuSeq)) / elem_size;
-	return seq;
-}
-
-GU_API GuSeq*
-gu_realloc_seq_(GuSeq* seq, size_t elem_size, size_t length)
-{
-	size_t real_size;
-	GuSeq* new_seq = (seq == NULL || seq == gu_empty_seq()) ?
-	   gu_mem_buf_alloc(sizeof(GuSeq) + elem_size * length, &real_size) :
-	   gu_mem_buf_realloc(seq, sizeof(GuSeq) + elem_size * length, &real_size);
-	new_seq->len = (real_size - sizeof(GuSeq)) / elem_size;
-	return new_seq;
-}
-
-GU_API void
-gu_seq_free(GuSeq* seq)
-{
-	if (seq == NULL || seq == gu_empty_seq())
-		return;
-	gu_mem_buf_free(seq);
-}
-
-static void
-gu_dummy_finalizer(GuFinalizer* self)
-{
-}
-
-GU_API void
-gu_buf_require(GuBuf* buf, size_t req_len)
-{
-	if (req_len <= buf->avail_len) {
-		return;
-	}
-
-	size_t req_size = sizeof(GuSeq) + buf->elem_size * req_len;
-	size_t real_size;
-
-	gu_require(buf->fin.fn != gu_dummy_finalizer);
-
-	if (buf->seq == NULL || buf->seq == gu_empty_seq())  {
-		buf->seq = gu_mem_buf_alloc(req_size, &real_size);
-		buf->seq->len = 0;
-	} else {
-		buf->seq = gu_mem_buf_realloc(buf->seq, req_size, &real_size);
-	}
-
-	buf->avail_len = (real_size - sizeof(GuSeq)) / buf->elem_size;
-}
-
-GU_API void*
-gu_buf_extend_n(GuBuf* buf, size_t n_elems)
-{
-	size_t len = gu_buf_length(buf);
-	size_t new_len = len + n_elems;
-	gu_buf_require(buf, new_len);
-	buf->seq->len = new_len;
-	return &buf->seq->data[buf->elem_size * len];
-}
-
-GU_API void
-gu_buf_push_n(GuBuf* buf, const void* data, size_t n_elems)
-{
-	void* p = gu_buf_extend_n(buf, n_elems);
-	memcpy(p, data, buf->elem_size * n_elems);
-}
-
-GU_API const void*
-gu_buf_trim_n(GuBuf* buf, size_t n_elems)
-{
-	gu_require(n_elems <= gu_buf_length(buf));
-	size_t new_len = gu_buf_length(buf) - n_elems;
-	buf->seq->len = new_len;
-	return &buf->seq->data[buf->elem_size * new_len];
-}
-
-GU_API void
-gu_buf_pop_n(GuBuf* buf, size_t n_elems, void* data_out)
-{
-	const void* p = gu_buf_trim_n(buf, n_elems);
-	memcpy(data_out, p, buf->elem_size * n_elems);
-}
-
-GU_API GuSeq*
-gu_buf_freeze(GuBuf* buf, GuPool* pool)
-{
-	size_t len = gu_buf_length(buf);
-	GuSeq* seq = gu_make_seq(buf->elem_size, len, pool);
-	void* bufdata = gu_buf_data(buf);
-	void* seqdata = gu_seq_data(seq);
-	memcpy(seqdata, bufdata, buf->elem_size * len);
-	return seq;
-}
-
-GU_API void
-gu_buf_evacuate(GuBuf* buf, GuPool* pool)
-{
-	if (buf->seq != gu_empty_seq()) {
-		size_t len = gu_buf_length(buf);
-
-		GuSeq* seq = gu_make_seq(buf->elem_size, len, pool);
-		void* bufdata = gu_buf_data(buf);
-		void* seqdata = gu_seq_data(seq);
-		memcpy(seqdata, bufdata, buf->elem_size * len);
-		gu_mem_buf_free(buf->seq);
-
-		buf->seq       = seq;
-		buf->fin.fn    = gu_dummy_finalizer;
-		buf->avail_len = len;
-	}
-}
-
-GU_API void*
-gu_buf_insert(GuBuf* buf, size_t index)
-{
-	size_t len = buf->seq->len;
-	gu_buf_require(buf, len + 1);
-
-	uint8_t* target =
-		buf->seq->data + buf->elem_size * index;
-	memmove(target+buf->elem_size, target, (len-index)*buf->elem_size);
-
-	buf->seq->len++;
-	return target;
-}
-
-static void
-gu_quick_sort(GuBuf *buf, GuOrder *order, int left, int right)
-{
-	int l_hold = left;
-	int r_hold = right;
-
-	void* pivot = alloca(buf->elem_size);
-	memcpy(pivot,
-	       &buf->seq->data[buf->elem_size * left],
-	       buf->elem_size);
-	while (left < right) {
-
-		while ((order->compare(order, &buf->seq->data[buf->elem_size * right], pivot) >= 0) && (left < right))
-			right--;
-
-		if (left != right) {
-			memcpy(&buf->seq->data[buf->elem_size * left],
-			       &buf->seq->data[buf->elem_size * right],
-			       buf->elem_size);
-			left++;
-		}
-
-		while ((order->compare(order, &buf->seq->data[buf->elem_size * left], pivot) <= 0) && (left < right))
-			left++;
-
-		if (left != right) {
-			memcpy(&buf->seq->data[buf->elem_size * right],
-			       &buf->seq->data[buf->elem_size * left],
-			       buf->elem_size);
-			right--;
-		}
-	}
-	
-	memcpy(&buf->seq->data[buf->elem_size * left],
-	       pivot,
-           buf->elem_size);
-	int index = left;
-	left  = l_hold;
-	right = r_hold;
-
-	if (left < index)
-		gu_quick_sort(buf, order, left, index-1);
-
-	if (right > index)
-		gu_quick_sort(buf, order, index+1, right);
-}
-
-GU_API void
-gu_buf_sort(GuBuf *buf, GuOrder *order)
-{
-	gu_quick_sort(buf, order, 0, gu_buf_length(buf) - 1);
-}
-
-GU_API void*
-gu_seq_binsearch_(GuSeq *seq, GuOrder *order, size_t elem_size, const void *key)
-{
-	int i = 0;
-	int j = seq->len-1;
-	
-	while (i <= j) {
-		int k = (i+j) / 2;
-		uint8_t* elem_p = &seq->data[elem_size * k];
-		int cmp = order->compare(order, key, elem_p);
-
-		if (cmp < 0) {
-			j = k-1;
-		} else if (cmp > 0) {
-			i = k+1;
-		} else {
-			return elem_p;
-		}
-	}
-
-	return NULL;
-}
-
-GU_API bool
-gu_seq_binsearch_index_(GuSeq *seq, GuOrder *order, size_t elem_size,
-                        const void *key, size_t *pindex)
-{
-	size_t i = 0;
-	size_t j = seq->len-1;
-	
-	while (i <= j) {
-		size_t k = (i+j) / 2;
-		uint8_t* elem_p = &seq->data[elem_size * k];
-		int cmp = order->compare(order, key, elem_p);
-	
-		if (cmp < 0) {
-			j = k-1;
-		} else if (cmp > 0) {
-			i = k+1;
-		} else {
-			*pindex = k;
-			return true;
-		}
-	}
-
-	*pindex = j;
-	return false;
-}
-
-static void
-gu_heap_siftdown(GuBuf *buf, GuOrder *order, 
-                 const void *value, int startpos, int pos)
-{
-	while (pos > startpos) {
-		int parentpos = (pos - 1) >> 1;
-        void *parent = &buf->seq->data[buf->elem_size * parentpos];
-        
-		if (order->compare(order, value, parent) >= 0)
-			break;
-
-		memcpy(&buf->seq->data[buf->elem_size * pos], parent, buf->elem_size);
-		pos = parentpos;
-	}
-
-	memcpy(&buf->seq->data[buf->elem_size * pos], value, buf->elem_size);
-}
-
-static void
-gu_heap_siftup(GuBuf *buf, GuOrder *order,
-               const void *value, int pos)
-{
-	int startpos = pos;
-	int endpos = gu_buf_length(buf);
-
-	int childpos = 2*pos + 1;
-	while (childpos < endpos) {
-		int rightpos = childpos + 1;
-		if (rightpos < endpos &&
-		    order->compare(order, 
-			               &buf->seq->data[buf->elem_size * childpos],
-			               &buf->seq->data[buf->elem_size * rightpos]) >= 0) {
-			childpos = rightpos;
-		}
-
-		memcpy(&buf->seq->data[buf->elem_size * pos], 
-		       &buf->seq->data[buf->elem_size * childpos], buf->elem_size);
-		pos = childpos;
-		childpos = 2*pos + 1;
-   }
-   
-   gu_heap_siftdown(buf, order, value, startpos, pos);
-}
-
-GU_API void
-gu_buf_heap_push(GuBuf *buf, GuOrder *order, void *value)
-{
-	gu_buf_extend(buf);
-	gu_heap_siftdown(buf, order, value, 0, gu_buf_length(buf)-1);
-}
-
-GU_API void
-gu_buf_heap_pop(GuBuf *buf, GuOrder *order, void* data_out)
-{
-	const void* last = gu_buf_trim(buf); // raises an error if empty
-	memcpy(data_out, buf->seq->data, buf->elem_size);
-	gu_heap_siftup(buf, order, last, 0);
-}
-
-GU_API void
-gu_buf_heap_replace(GuBuf *buf, GuOrder *order, void *value, void *data_out)
-{
-	gu_require(gu_buf_length(buf) > 0);
-
-	memcpy(data_out, buf->seq->data, buf->elem_size);
-	gu_heap_siftup(buf, order, value, 0);
-}
-
-GU_API void
-gu_buf_heapify(GuBuf *buf, GuOrder *order)
-{
-	size_t middle = gu_buf_length(buf) / 2;
-	void *value = alloca(buf->elem_size);
-	
-	for (size_t i = 0; i < middle; i++) {
-		memcpy(value, &buf->seq->data[buf->elem_size * i], buf->elem_size);
-		gu_heap_siftup(buf, order, value, i);
-	}
-}