diff --git a/.indent.pro b/.indent.pro new file mode 100644 index 0000000..36aab03 --- /dev/null +++ b/.indent.pro @@ -0,0 +1,22 @@ +--blank-lines-after-procedures +--braces-on-func-def-line +--braces-on-if-line +--braces-on-struct-decl-line +--case-brace-indentation4 +--case-indentation4 +--cuddle-do-while +--cuddle-else +--dont-break-function-decl-args +--dont-break-procedure-type +--ignore-newlines +--indent-level4 +--no-space-after-function-call-names +--no-tabs +--pointer-align-right +--preprocessor-indentation2 +--space-after-for +--space-after-if +--space-after-while +--spaces-around-initializers +--struct-brace-indentation1 +--swallow-optional-blank-lines diff --git a/Makefile b/Makefile index fe4acc7..564b17b 100644 --- a/Makefile +++ b/Makefile @@ -5,19 +5,18 @@ TARGET=cekf # in Ubuntu 22.10 # `ulimit -c unlimited` to turn on core dumps # written to /var/lib/apport/coredump/ -PROFILING=-pg -OPTIMIZING=-O2 -DEBUGGING=-g +MODE_P=-pg +MODE_O=-O2 +MODE_D=-g -# CCMODE = $(PROFILING) -# CCMODE = $(OPTIMIZING) -CCMODE = $(DEBUGGING) +CCMODE = $(MODE_D) CC=cc -Wall -Wextra -Werror $(CCMODE) LAXCC=cc -Werror $(CCMODE) PYTHON=python3 +MAKEAST=$(PYTHON) ./tools/makeAST.py -EXTRA_YAML=$(wildcard src/*.yaml) +EXTRA_YAML=$(filter-out src/primitives.yaml, $(wildcard src/*.yaml)) EXTRA_C_TARGETS=$(patsubst src/%.yaml,generated/%.c,$(EXTRA_YAML)) EXTRA_H_TARGETS=$(patsubst src/%.yaml,generated/%.h,$(EXTRA_YAML)) EXTRA_OBJTYPES_H_TARGETS=$(patsubst src/%.yaml,generated/%_objtypes.h,$(EXTRA_YAML)) @@ -55,7 +54,7 @@ EXTRA_DEP=$(patsubst obj/%,dep/%,$(patsubst %.o,%.d,$(EXTRA_OBJ))) PARSER_DEP=$(patsubst obj/%,dep/%,$(patsubst %.o,%.d,$(PARSER_OBJ))) ALL_OBJ=$(OBJ) $(EXTRA_OBJ) $(PARSER_OBJ) -ALL_DEP=$(DEP) $(EXTRA_DEP) $(TEST_DEP) $(PARSER_DEP) +ALL_DEP=$(DEP) $(EXTRA_DEP) $(TEST_DEP) $(PARSER_DEP) $(MAIN_DEP) TMP_H=generated/parser.h generated/lexer.h TMP_C=generated/parser.c generated/lexer.c @@ -67,20 +66,20 @@ $(TARGET): $(MAIN_OBJ) $(ALL_OBJ) include $(ALL_DEP) -$(EXTRA_C_TARGETS): generated/%.c: src/%.yaml tools/makeAST.py | generated - $(PYTHON) tools/makeAST.py $< c > $@ || (rm -f $@ ; exit 1) +$(EXTRA_C_TARGETS): generated/%.c: src/%.yaml tools/makeAST.py src/primitives.yaml | generated + $(MAKEAST) $< c > $@ || (rm -f $@ ; exit 1) $(EXTRA_H_TARGETS): generated/%.h: src/%.yaml tools/makeAST.py | generated - $(PYTHON) tools/makeAST.py $< h > $@ || (rm -f $@ ; exit 1) + $(MAKEAST) $< h > $@ || (rm -f $@ ; exit 1) -$(EXTRA_OBJTYPES_H_TARGETS): generated/%_objtypes.h: src/%.yaml tools/makeAST.py | generated - $(PYTHON) tools/makeAST.py $< objtypes_h > $@ || (rm -f $@ ; exit 1) +$(EXTRA_OBJTYPES_H_TARGETS): generated/%_objtypes.h: src/%.yaml tools/makeAST.py src/primitives.yaml | generated + $(MAKEAST) $< objtypes_h > $@ || (rm -f $@ ; exit 1) -$(EXTRA_DEBUG_H_TARGETS): generated/%_debug.h: src/%.yaml tools/makeAST.py | generated - $(PYTHON) tools/makeAST.py $< debug_h > $@ || (rm -f $@ ; exit 1) +$(EXTRA_DEBUG_H_TARGETS): generated/%_debug.h: src/%.yaml tools/makeAST.py src/primitives.yaml | generated + $(MAKEAST) $< debug_h > $@ || (rm -f $@ ; exit 1) -$(EXTRA_DEBUG_C_TARGETS): generated/%_debug.c: src/%.yaml tools/makeAST.py | generated - $(PYTHON) tools/makeAST.py $< debug_c > $@ || (rm -f $@ ; exit 1) +$(EXTRA_DEBUG_C_TARGETS): generated/%_debug.c: src/%.yaml tools/makeAST.py src/primitives.yaml | generated + $(MAKEAST) $< debug_c > $@ || (rm -f $@ ; exit 1) .generated: $(EXTRA_TARGETS) $(TMP_H) touch $@ @@ -137,8 +136,9 @@ profile: all rm -f callgrind.out.* valgrind --tool=callgrind ./$(TARGET) -indent: .typedefs - (cd src; indent `cat ../.typedefs | sort -u | xargs` -T bigint_word -T BigInt -T IntegerBinOp -T Control -T Stack -T Env -T Snapshot -T Kont -T ValueList -T Clo -T Fail -T Vec -T ProtectionStack -T HashSymbol -T hash_t -T Header -T PmModule -T HashTable -T byte -T word -T ByteCodes -T ByteCodeArray -T Value *.[ch]) +indent: .typedefs .indent.pro + indent `cat .typedefs | sort -u | xargs` -T bigint_word -T BigInt -T IntegerBinOp -T Control -T Stack -T Env -T Snapshot -T Kont -T ValueList -T Clo -T Fail -T Vec -T ProtectionStack -T HashSymbol -T hash_t -T Header -T PmModule -T HashTable -T byte -T word -T ByteCodes -T ByteCodeArray -T Value -T FILE src/*.[ch] generated/*.[ch] + rm -f src/*~ generated/*~ .typedefs: .generated diff --git a/README.md b/README.md index faddb8a..5bf36de 100644 --- a/README.md +++ b/README.md @@ -67,16 +67,25 @@ the $step$ function: one to deal with `amb` and one to deal with `back`. ```mermaid flowchart TD - -source --> -AST[Parser] --abstract syntax--> -lambda[Lambda Conversion] --lambda calculus--> -check[Type Checking] --typed lambda calculus--> -anf[A-Normal Form Conversion] --ANF--> -desugaring2[Desugaring] --ANF--> -static[Static Analysis] --annotated ANF--> -Bytecode[Bytecode Generation] --bytecode--> -VM +classDef process fill:#aef; +source(Source) --> +parser([Parser]):::process --> +ast(AST) --> +lc([Lambda Conversion]):::process <--> tpmc([Tpmc]):::process +lc <--> pg([Print Function Generator]):::process +lc <--> ci([Constructor Inlining]):::process +tpmc <--> vs([Variable Substitution]):::process +lc ----> lambda1(Plain Lambda Form) +lambda1 --> tc([Type Checking]):::process +tc <--> pc([Print Compiler]):::process +tc ---> lambda2(Plain Lambda Form) +lambda2 --> anfc([A-Normal Form Conversion]):::process +anfc --> anf(ANF) +anf --> desug([Desugaring]):::process +desug --> danf(Desugared ANF) +danf --> bcc([Bytecode Compiler]):::process +bcc --> bc(Byte Code) +bc --> cekf([CEKF Runtime VM]):::process ``` All stages basically complete, but it needs a lot of testing now. diff --git a/docs/ENV.md b/docs/ENV.md new file mode 100644 index 0000000..f128836 --- /dev/null +++ b/docs/ENV.md @@ -0,0 +1,524 @@ +# Environments + +Various approaches to having namespaced environments. + +## Environments as Namespaces + +By elevating environments to first-class data types we can re-use existing +code to achieve encapsulation and namespaces. + +However this proves very difficult to reconcile with fast lexical +adressing, two environments with the same apparent prototype can still +differ in the order of their bindings and hence the lexical addresses of +their components, a variable access could not then be correctly annotated +for multiple use-cases. + + +## Namespaces Only + +As an alternative to fully first-class environments we could look at +`env` declarations purely as namespaces, that is the names of envs are +not variables but constant names to be used literally. This is certainly +simpler, but the semantics are a bit wooly, so how would it work? + +The `.` operator would evaluate its rhs in the context of the namespace +on the lhs, like `myns.doSomething(arg)`. The dot operator would have to +have higher precedence than even function calls, so that would parse as +`(myns.doSomething)(arg)`. Bytecode might then be something like + +``` +| ..arg.. | SAVENV | myns | SETENV | VAR[n][n] | SWAP | RESTORENV | APPLY | +``` + +I'm not sure I like the save and restore because we don't currently have +an environment stack, and we'd need Forth-level stack twiddling to use +the existing stack (i.e. the `VAR` lookup would leave its result top of +stack hence the need for a SWAP bytecode or similar). + +> Future self: using the existing stack turns out to be fine. + +The new `getenv` internal construct pushes the current environment on +the top of the stack, where it can be bound to a variable `myns` in the +normal way. `myns` in the bytecode above just becomes a var lookup. + +What about type checking? Again if `myns` is bound to a `TcEnv` during +type checking, that env can be used to validate the rhs of the dot +operator. + +Any other holes in this idea? ANF conversion is purely local transforms +that shouldn't be affected, desugaring likewise. + +### Printing Again + +The `print` construct fails in this scenario though. If an env declares a +`typedef` and return data of that type, then for example + +``` +print(a.returnThing()) +``` + +will compole to + +```scheme +(print$Thing (dot a (returnThing))) +``` + +and `print$thing` is not in scope. Error. What we want print to compile +to instead is + +```scheme +((dot a print$Thing) (dot a (returnThing))) +``` + +This can be made to work if types are annotated with their scopes. which +leads to... + +### Scoped Types + +Scoped types are necessary in any case, otherwise two environments could +both declare the same type name for different types and those types +would unify incorrectly. So we'll need types to unify on their scopes +too. For that reason scopes need to be canonical. + +It works to treat canonical scopes equivalently to a file system with +a root `/`, the difference being that we don't allow relative paths, +only absolute ones. + +It will also pay to keep the syntax distinct in discussions, using +`/a/b/c` to mean a canonical scope and restrict `a.b.c` to mean lookup in +the surface language, which has very different semantics. To illustrate, +after: + +``` +env a { + env b { + } +} +env c { + d +} +``` + +...the expression `a.b.c.d` is valid at the top level: `a` is found +at top, `b` is found in `a`, but when `c` is not found in `b` search +proceeds back to `a` then to the root where `c` is located, thence `d`, +so in this example `a.b.c.d` resolves to `/c/d`. + +Before proceeding, there's a problem here: + +``` +env a { + env b { + env c { + } + } +} +env c { + d +} +``` + +in this case `a.b.c.d` would not resolve because `c` is found in `b` +and will not be searched for a second time. + +we could solve this with backtracking (compile time so probably ok) +but the semantics are still not great, maybe better to leave as is and +fail to resolve, after all given the above `a.b.c.d` is a pretty silly +thing to do. + +Anyway assuming we can always resolve valid type scopes to a canonical +form, the print compiler will need the type, as before, plus the current +canonical scope. For example + +``` +env a { + env b { + typedef T1 ... + fn getT1() {...} + } + ... + print(b.getT1()) +} +``` + +The print compiler will get a type `/a/b/T1` and a current scope `/a` +so will resolve to: + +```scheme +((dot b print$T1) (dot b (getT1))) +``` + +by removing the common prefix. + +This should work fine with `extends` whaen that's implemented: + +``` +env complex extends math { ... } +``` + +provides an initial `/math` scope for processing `complex`. + +Another problem with this though, typedefs from within function bodies +won't be resolvable in this way, or even at all since the `print$thing` +functions won't even exist after the function exits. Maybe we only allow +typedefs and envs within other envs or at the top level? + +Since that seems overly restrictive, let's try another approach. + +### Named vs. Anonymous Scopes + +Suppose we make a distinction between `env`s being "named scopes" and +other types of anonymous nests (function bodies etc.) as being "anonymous +scopes", then we can simply impose the restiction that user-defined types +cannot escape anonymous scopes. That way we can continue to use typedefs +within function bodies, but functions defining such types can only use +them internally and not return values of those types. types defined within +envs are accessible outside of those envs if they are qualified by the +path to that env (which cannot cross the boundary of an anonymous scope). + +All types can remain fully qualified by a scope, but canonical scopes +can make use of some internally constructed pseudo-root to indicate +they are not top-level. A possible nomenclature might be `$/a/b/c` meaning +`a` is an env whose parent is the closest enclosing anonymous scope. + +Trial: + +``` +env a { + typedef T1 ... // /a/T1 + env b { + typedef T2 ... // /a/b/T2 + } + fn f1 () { // begin anonymous scope + typedef T3 ... // $/T3 + T3 // ok $/T3 + b.T2 // ok /a/b/T2 + T1 // ok /a/T1 + } + T1 // ok /a/T1 + b.T2 // ok /a/b/T2 + T3 // not ok +} +``` + +This looks like it could be made to work, but will need some formalizing. +In particular the error case, if `T3` is allowed to leak out of +`f1` then its scope cannot just be re-interpreted as a new nearest +enclosing anonymous scope, so maybe each anonymous scope needs a unique +identifier? or we trap the leak and raise an error. Trapping the leak +is too restrictive: if we declare a type inside a function and then +map over a list of that type within the function that should be fine, +but the type must be leaked to `map` it's just that map doesn't care as +long as the types of its arguments match `(a -> b) -> list(a) -> list(b)`. + +Since the type checker we've already decided will be passing around a +current canonical scope, we might just use the machine address of the +nest as the current scope, or generate a symbol on the fly with a qualifying +`$` to say it's anonymous. Then it's unifiable within the current scope +but not outside of it. + +so assume each anonymous nest generates a new id, and then all canonical +paths are root based. We've identified two "leaking" scenarios so far: + +1. Returning a value from a function of a type defined in that function. +2. Passing a value from a function, of a type defined in that function, + to another polymorphic function. + +The first should cause an error if that type is used in a non-polymorphic +way, the second should be ok. + +``` +env a { + fn b() { + let + typedef T1 ... // /a/$nnn/T1 + fn c (t1) { ... } // /a/$nnn/T1 -> int + in + map(c [t1, t1, t1]) // returns list of int + } +} +``` + +`map` should get `(/a/$nnn/T1 -> int) -> /list(/a/$nnn/T1) -> /list(int)` +which will unify fine even outside of the body of `fn b`. + +Because the type checker is passing around the current scope, `print` can +compare that with the scope of a type `T1` to determine if the `print$T1` +function is in scope or not. If the type is in scope it will use the +generated printer, otherwise fallback to a generic default `putv`.` + +`print` needs the scope in any case to "trim" the canonical scope to an +env path, and if there are no anonymous ids left in this trimmed path then +`print` knows the `print$T1` function is accessible. + +So to nail the semantics, scopes are linked lists, the root of the +scope is the tail of the list, so in `env a { env b { env c { x } } }` +the scope of `x` is `c=>b=>a=>/`. Having got that out of the way lets +tabulate some examples using the following structure: + +``` +T1 +env a { + T2 + fn f1 { + T3 + } + env b { + T4 + fn f2 { + T5 + } + env c { + T6 + fn f3 { + T7 + } + } + } +} +env d { + T8 + fn f4 { + T9 + } +} + +``` + +| current scope | type scope | relative scope | accessible | notes | +| ------------- | ------------------- | -------------- | ---------- | ----- | +| `/` | `T1 /` | `T1` | Y | both global | +| `/` | `T2 a=>/` | `a.T2` | Y | | +| `/` | `T3 f1=>a=>/` | `a.f1.T3` | N | relative contains anonymous scope | +| `/` | `T4 b=>a=>/` | `a.b.T4` | Y | | +| `/` | `T5 f2=>b=>a=>/` | `a.b.f2.T5` | N | | +| `/` | `T6 c=>b=>a=>/` | `a.b.c.T6` | Y | | +| `/` | `T7 f3=>c=>b=>a=>/` | `a.b.c.f3.T7` | N | | +| `/` | `T8 d=>/` | `d.T8` | Y | same as T2 | +| `/` | `T9 f4=>d=>/` | `d.f4.T9` | N | same as T3 | +| `a=>/` | `T1 /` | `T1` | Y | parent scope | +| `a=>/` | `T2 a=>/` | `T2` | Y | same scope | +| `a=>/` | `T3 f1=>a=>/` | `f1.T3` | N | relative contains anonymous scope | +| `a=>/` | `T4 b=>a=>/` | `b.T4` | Y | | +| `a=>/` | `T5 f2=>b=>a=>/` | `b.f2.T5` | N | | +| `a=>/` | `T6 c=>b=>a=>/` | `b.c.T6` | Y | | +| `a=>/` | `T7 f3=>c=>b=>a=>/` | `b.c.f3.T7` | N | | +| `a=>/` | `T8 d=>/` | `d.T8` | Y | parent scope | +| `a=>/` | `T9 f4=>d=>/` | `d.f4.T9` | N | parent scope | +| `f1=>a=>/` | `T1 /` | `T1` | Y | parent scope | +| `f1=>a=>/` | `T2 a=>/` | `T2` | Y | same scope | +| `f1=>a=>/` | `T3 f1=>a=>/` | `T3` | Y | anonymous scope pruned | +| `f1=>a=>/` | `T4 b=>a=>/` | `b.T4` | Y | | +| `f1=>a=>/` | `T5 f2=>b=>a=>/` | `b.f2.T5` | N | different functions | +| `f1=>a=>/` | `T6 c=>b=>a=>/` | `b.c.T6` | Y | | +| `f1=>a=>/` | `T7 f3=>c=>b=>a=>/` | `b.c.f3.T7` | N | | +| `f1=>a=>/` | `T8 d=>/` | `d.T8` | Y | parent scope | +| `f1=>a=>/` | `T9 f4=>d=>/` | `d.f4.T9` | N | parent scope | +| `b=>a=>/` | `T1 /` | `T1` | Y | parent scope | +| `b=>a=>/` | `T2 a=>/` | `T2` | Y | same scope | +| `b=>a=>/` | `T3 f1=>a=>/` | `f2.T3` | N | anonymous scope pruned | +| `b=>a=>/` | `T4 b=>a=>/` | `T4` | Y | | + +etc. + +Obviously the relative scope is generated by comparing the current +scope with the type scope and removing any common roots. Then if the +result contains any anonymous components the type is not accessible +from the current scope, as far as printing is concerned (the generated +`print$type` functions are not accessible to the print compiler). If the +types and therefore their generated print functions are acccessible, the +print compiler need only prefix the print function with the calculated +relative scope. Otherwise it uses the generic `print$` function. + +### Algorithm to Calculate Relative Scope + +Easiest is just to reverse the scopes then walk them from tail to head. +We'll have tuples at some point so let's just use them here, a scope +element is a tuple of a string and a bool (anonymous flag). A scope is +a list of elements. + +``` +fn relativeScope { + ([], []) { [] } + (#(v, _) @ sc, #(v, _) @ st) { relativeScope(sc, st) } + (_, st) { st } +} +``` + +Try it on a few examples + +| sc | st | result | +| --- | --- | -------| +| / | / | / | +| / | a | a | +| / | a.b | a.b | +| / | b | b | +| a | / | / | +| a | a | / | +| a | a.b | b | +| a | b | b | +| a.b | / | / | +| a.b | a | / | +| a.b | a.b | / | + +## More Problems + +Consider + +``` +env a { + env b { + T1 + } +} +env b { + T1 +} +``` + +`a.b.T1` resolves to `b.T1` in `a`, but so does `b.T1`, so the whole +relative paths idea may be dead in the water. But only `print` uses +these relative paths, can it use absolute ones? or, for efficiency, +have a global root env that is hidden (illegal var name) but can be +pruned to a relative path as with any other? None of the above changes, +except that the root is an explicit component rather than just nil. + +We might even support it in the language, use a leading '`.`' to signify +an absolute path, that way in the above, code inside `.a` could explicitly +refer to code in `.b`, distinct from `.a.b` which it could continue to +refer to as just `b`. + +If we use `$` to signify the root then `$.b` in context `$.a.b` would +still get pruned to `b` so that doesn't work either. + +Of course we don't have to prune, `print` would still work if all +of its paths were absolute, but we'd loose the ability to check for +inaccessible scopes, and actually `print` relies on relative paths +to avoid impossible lookups on those anonymous scopes so it wouldn't +work. + +Another option, this might just work, rename environments to all have +unique names, or otherwise tag them with some unique id. Some sort +of scoping rules would be needed to rewrite explicit environment +references, but the print compiler would just directly use the unique +names. In fact the unique names could just be their absolute paths +or some concatenation of them. That then removes the need for a global +env to qualify them, top-level `.b` is just `b`, but `.a.b` becomes +something like `.a.a/b` and within `.a`, `b` is relatively `a/b`. + +### TODO, then + +1. rename environments to reflect their scope and make them globally + unique. +2. rewrite explicit environment lookups to use these qualified names. +3. type-checker maintains current environment context and passes it to + the print compiler, as well as using it to qualify the context of + each type (constructor). + +## Environments as Dispatch Functions + +Another possibility is to translate an environment into a dispatch +function returning the components of the environment. + +This promises less effort because the generated lambda calculus will not +need to be extended to support environments explicitly, and therefore +nothing downstream of it will need those extensions either. There is +the adiitional overhead of a lookup and return to access an environment +component, but that might be worth the decrease in complexity. + +The problem is that such a dispatch function, which must return arbitrary +types, can not be naively type-checked. We have to either type-check it +specially, or propagate the environment concept into the lambda form, +rewriting it to a dispatch after type checking. This might still be +worthwhile. + +Anyway the transformations are quite straightforward, for example + +``` +let + env a { + typedef color { red | green | blue } + fn add1(x) { 1 + x } + } +in + a.add1(2) +``` + +might generate something like: + +```scheme +(letrec ((a + (letrec ((print$color ...) + (add1 (lambda (x) (+ 1 x)))) + (lambda (selector) ;; returned dispatch function 'a' + (match selector + ((0) print$color) + ((1) add1)))))) + ((a 1) 2)) +``` + +Note that any generated `print$` functions are also exported, and we +make use of the existing `match` construct for fast O(1) lookup, safe +because we know the number of elements in the environment. + +Chained lookup also works, so `a.b.c(x)` becomes something like `(((a 0) +1) x)` + +It would be preferable to typecheck the dispatcher specially but that +might be just as difficult or more so than typechecking the environment +then transforming it. It would be less likely to be wrong though. + +Also it's not yet clear how this might work if we plan to implement the +`extends` attribute of environments, which is likely a requirement for +any really useful language. + +Anyway, food for thought, and maybe there's a hybrid approach. + +Returning to this, actually there is a way to get a dispatch function +past the type-checker, if we declare a type that contains all possible +arguments and another type that contains all popssible result types, +for example: + +``` +let + env a { + fn map { + (_, []) { [] } + (f, h @ t) { f(h) @ map(f, t) } + } + fn fact { + (0) { 1 } + (n) { n * fact(n - 1) } + } + } +in + a.factorial(5) +``` +becomes something like +``` +let + typedef a$args(#f, #u) { a$map$args(#f, list(#t)) | a$fact$args(int) } + typedef a$results(#u) { a$map$result(list(#u)) | a$fact$result(int) } + fn a$dispatch(args) { + let + fn map { + (_, []) { [] } + (f, h @ t) { f(h) @ map(f, t) } + } + fn fact { + (0) { 1 } + (n) { n * fact(n - 1) } + } + in + switch(args) { + (a_map_args(f, u)) { a_map_result(map(f, u)) } + (a_fact_args(n) { a_fact_result(fact(n)) } + } + } +in + switch (a$dispatch(a$fact$args(5))) { + (a$fact$result(n)) { n } + } +``` +That might just work but I'm not sure I like it. + diff --git a/docs/Overview.drawio b/docs/Overview.drawio new file mode 100644 index 0000000..9f05d05 --- /dev/null +++ b/docs/Overview.drawio @@ -0,0 +1,121 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/TODO.md b/docs/TODO.md index dae770d..9f66385 100644 --- a/docs/TODO.md +++ b/docs/TODO.md @@ -1,26 +1,30 @@ # TODO -* over-application i.e. `fn (a) { fn (b) { a + b } }(2, 3)` -* allow user overrides of print functions +* over-application i.e. `fn (a) { fn (b) { a + b } }(2, 3)`. +* allow user overrides of print functions. * tuples - can use vec type to implement. - * BUT - fn args are not tuples, that might interfere with currying. + * BUT - the collection of args to a function is not itself a tuple, that might interfere with currying. * tc has support for pairs and we might leverage those as a start, but flat vecs will be more efficient. -* unpacking function return values (tuples only) + * specific syntax: `#(2, "hi")` might be better than just round braces. +* unpacking function return values (tuples only). * `now()` expression returns current time in milliseconds. * macro support (see [MACROS](./MACROS.md) for initial thoughts). * more numbers: - * rationals: 1/3 - * irrationals: sqrt(2) - * complex numbers -* UTF8 and `wchar_t` -* first class environments -* libraries - * probably use file system layout - * env var to specify the root location(s) - * better preable/postamble handling + * rationals: 1/3. + * irrationals: sqrt(2). + * complex numbers. +* UTF8 and `wchar_t`. +* first class environments. +* libraries. + * probably use file system layout. + * env var to specify the root location(s). + * better preable/postamble handling. * propagate file and line numbers into all error reporting. * much better error reporting. * error recovery. * command-line arguments for libraries etc. * fail on non-exhaustive pattern match (optional). -* error function +* error function. +* user definable infix operators. + * with precedence and associativity. +* curried binary operators `(2+)` etc. diff --git a/docs/TPMC.drawio b/docs/TPMC.drawio new file mode 100644 index 0000000..ed9f370 --- /dev/null +++ b/docs/TPMC.drawio @@ -0,0 +1,936 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/V2.md b/docs/V2.md index 1cb6f47..9788fbc 100644 --- a/docs/V2.md +++ b/docs/V2.md @@ -138,7 +138,14 @@ I should probably explain that. Consider a primitive sequence like `2 + 3 * 4`. That will parse to `2 + (3 * 4)` and the AST will look like: -![AST](parse-tree.png) +```mermaid +flowchart TD +plus(+) +plus ---- two(2) +plus --- times(×) +times --- three(3) +times --- four(4) +``` There are various ways to print out that tree, for example for each (non-terminal) node, printing the left hand branch, then printing the @@ -584,8 +591,8 @@ In all other cases the called function can re-use the calling function's stack f ### Changes to V2 -Firstly we're going to need a new register to keep track of the stack, all the good letters are gone so I'm just going to call it `S`. -Our CEKF machine is now a CEKFS machine. +Firstly we're going to need a new register to keep track of the stack, all the good letters are gone so I'm just going to call it `(s)`. +Our `CEKF` machine is now a `CEKF(s)` machine. #### Variables diff --git a/docs/lambda-conversion.md b/docs/lambda-conversion.md index 7b65587..1b348f2 100644 --- a/docs/lambda-conversion.md +++ b/docs/lambda-conversion.md @@ -459,6 +459,104 @@ has a complete algorithm described and working that does exactly what I want! Plan now is to get that working as a Python prototype, then translate into C. +## Description of the TPMC Algorithm + +Explaining it to myself. + +### Step 1. Renaming + +All patterns in the arguments to a composite function are collected into a matrix +of patterns, and the components are renamed and labelled in a consistent way, +such thar the same variable position has the same name, for example in + +``` +fn map { + (_, nil) { nil } + (f, pair(h, t)) { pair(f(h), map(f, t)) } +} +``` + +The matrix is + +``` +(_, nil) +(f, pair(h, t)) +``` + +and after renaming and labelling that becomes + +``` +(p$0=_, p$1=nil) +(p$0=_, p$1=pair(p$1$0=_, p$1$1=_)) +``` + +An array of final states (the bodies of the individual functions) is also constructed + +``` +{ nil } +{ pair(p$0(p$1$0), map(p$0, p$1$1)) } +``` + +### Step 2. Generating the DFA + +The input to the `match` algorithm is that matrix of patterns M and the array of final states S. +The output of the `match` algorithm is the DFA for the matrix. + +`match` inspects the first (top) row of M. If all of the patterns in the row are +variables then it cannot fail to match any arguments. This invokes the "Variable Rule". +Otherwise at least one pattern in the top row is a constructor or constant. This situation +invokes the "Mixture Rule". + +#### The Variable Rule + +If there are no constructors or constants in the top row then the result is the first state in the array of final states. + +#### The Mixture Rule + +* select any column C whose first pattern is not a wildcard. +* construct an array N containing the patterns from any column whose first pattern is not a wildcard. +* construct a new matrix MN consisting of all the columns from M except that column. +* construct a new test state T. +* for each constructor K in N: + * let AK be the arity of K. + * let {i1 .. ii} be the indices of the patterns in N (both wildcards and equal constructors) that match that constructor. + * let {p1 .. pi} be the patterns at those indices. + * let L be the size of {p1 .. pi} + * construct a matrix MNC from MN by selecting rows {i1 .. ii} + * construct a matrix NC with AK columns and L rows + * for each pattern pj in {p1 .. pi} + * if pj is a constructor place a row of the constructor's AK arguments in row j of NC + * otherwise place a row of AK wildcards with appropriate names (p$1$1 etc.( in row j of NC + * construct a new matrix MNCNC by appending MN to MNC + * let SN be an array of S's states {i1 .. ii} + * call `match` on MNCNC and SN to get state F + * create an arc from T to F, labelling it with the constructor K +* if the list of constructors in N is exhaustive + * return T +* else if there are wildcards in N: + * let {w1 .. wi} be the indices of the wildcards in N + * construct a matrix MNF by selecting rows {w1 .. wn} + * construct a state array SF from S by selecting states {w1 .. wi} + * call match on MNF and SF resulting in a DFA F + * add an arc from T to F labelled with a wildcard + * return T +* else: + * add an arc from T to the error state E + * return T + +### Step 3. Optimize the DFA + +This just involves reference counting states and removing duplicates. +States with a reference count greater than one will become local functions. + +### Step 4. Generate Intermediate Code + +Again this is fairly straightforward, local procedures are created for those +states with multiple entry points, so track must be kept of free variables etc. +Otherwise a test state becomes a switch statement (in our case either a `MATCH` +for constructors or a `COND` for constants), an arc becomes a case in that statement, +and a final state is either the body of the state or a call to the local procedure. + And it's working! At least the python prototype [TPMC2.py](../prototyping/TPMC2.py). For sample inputs here's the output: ```scheme @@ -544,3 +642,170 @@ And it's working! At least the python prototype [TPMC2.py](../prototyping/TPMC2. (let (p1$2 (vec 2 p1)) E3))))))))) ``` + +### Extending TPMC to Support Comparison + +The language requires an addition, if possible to the kinds of pattern matching available. +Specific example is `member` + +``` +let + fn member { + (_, []) { false } + (x, x @ _) { true } + (x, _ @ t) { member(x, t) } + } +in + member('c', "abc") +``` + +Where the second match succeeds if the first argument equals the head of the second argument. + +While I thought I had this working, simply treating comparison as a new kind of "constructor", +in fact in my tests it was only working accidentally. +In general there is no guarantee that the variable representing the thing being compared is +in scope when the comparison happens. In the above example x in the second match is only in scope +because it is bound at the top level. + +In the original algorithm variables are brought in to scope by the conversion of the arc pattern. +But the non-locality of the variable being compared causes problems. + +``` +let + typedef baz { foo(int) | bar(baz) } + fn fail { + (x, x) { 1 } + (bar(x), x) { 2 } + } +in + print(fail(foo(1), foo(1))) +### +undefined variable p$15$0 in analyzeVar +``` + +The DFA constructed is + +```mermaid +flowchart TD +T39("p$16\n[]") +F36("(begin 1)\n[p$16]") +T39 --"p$16:p$15:_==p$16:_\n[p$15]"--> F36 +T40("p$15\n[p$16 p$15]") +F37("(begin 2)\n[p$16]") +T40 --"p$15:bar(p$15$0:_)\n[p$16]"--> F37 +ERROR +T40 --"p$15:_\n[]"--> ERROR +T39 --"p$16:p$15$0:_==p$16:_\n[p$15$0 p$15]"--> T40 +ERROR +T39 --"p$16:_\n[]"--> ERROR +``` + +(`cekf --tpmc-mermaid` will generate the above diagram) + +And the intermediate code generated is + +```scheme +(lambda (p$15 p$16) + (letrec (($tpmc38 (lambda () (error)))) + (if (eq p$15 p$16) + (begin 1) + (if (eq p$15$0 p$16) + (match (tag p$15) + ((1:bar) (begin 2)) + ((0:foo) ($tpmc38))) + ($tpmc38))))) +``` + +So walking through, the matrix M and final states S will be + +| M1 | M2 | S | +| ------------------- | --------------- | ----------- | +| `p$15` | `p$16==p$15` | `(begin 1)` | +| `p$15=bar(p$15$0)` | `p$16==p$15$0` | `(begin 2)` | + + + +The mixture rule applies on row 1 column 2 because it is a comparison +not just a var. + +So The algorithm finds two constructors in column 2, both are distict +comparisons so don't match one another. + +Construction of the first arc for Row 1 compiles fine, match recurses +on `p$15` where the variable rule applies and the final state `1` is +returned, then an arc from the start state to the first final state is +constructed, labelled by the comparison: + +```mermaid +flowchart LR +T39("p$16\n[]") +F36("(begin 1)\n[p$16]") +T39 --"p$16:p$15:_==p$16:_\n[p$15]"--> F36 +``` + +The reason this compiles ok is that `p$15` (the first `x` in of the +source function) is bound by the top-level function before the comparison +is done. + +The free variable `[p$15]` on the arc is because of an earlier attempt +to fix the issue, it wouldn't be there in the vanilla implementation. + +Anyway the problem occurs when compiling the second row of the matrix. +Match recurses on `p$15=bar(p$15$0)` where the mixture rule applies, +eventually resulting in an intermediate test state and arc to the final +state labelled with the constructor: + +```mermaid +flowchart LR +T41("p$15\n[p$16 p$15]") +F37("(begin 2)\n[p$16]") +T41 --"p$15:bar(p$15$0:_)\n[p$16]"--> F37 +``` + +and `mixture` then prepends this with an arc from the start state, +labelled with the comparison: + +```mermaid +flowchart LR +T40("p$16\n[]") +T41("p$15\n[p$16 p$15]") +F37("(begin 2)\n[p$16]") +T41 --"p$15:bar(p$15$0:_)\n[p$16]"--> F37 +T40 --"p$16:p$15$0:_==p$16:_\n[p$15$0 p$15]"--> T41 +``` + +The problem is that when the intermediate code is generated, `p$15$0` +is free (not yet bound by the second match) at the time the comparison +code is emitted. + +To summarise, the algorithm given the initial matrix skips past the +plain var `x` in row 1 to find column 2, which in turn results in row +2 column 2 being processed before row 2 column 1. + +### Possible Solutions + +One possibility, extend the algorithm so that after identifying column +2 in the above, it finally decides to process column 1 instead, because +it sees the depenancy of row 2 column 2 on row 2 column 1. In fact could +it just say "because there is a pattern in the first row, process the +first column"? I suspect not, there are potentially no constructors +in column 1, but would that be a problem? Very easy to try out and it +seems to work! The generated DFA for `fail` has one extra state, so maybe +it's less optimised, but all tests still pass and fail now works! + +```mermaid +flowchart TD +T40("p$15\n[]") +T41("p$16\n[p$16 p$15$0 p$15]") +F36("(begin 1)\n[p$16]") +T41 --"p$16:p$15:_==p$16:_\n[p$15]"--> F36 +F37("(begin 2)\n[p$16]") +T41 --"p$16:p$15$0:_==p$16:_\n[p$15$0]"--> F37 +F38("(begin 3)\n[]") +T41 --"p$16:_\n[]"--> F38 +T40 --"p$15:bar(p$15$0:_)\n[p$16]"--> T41 +T42("p$16\n[p$16 p$15]") +T42 --"p$16:p$15:_==p$16:_\n[p$15]"--> F36 +T42 --"p$16:_\n[]"--> F38 +T40 --"p$15:_\n[p$16]"--> T42 +``` diff --git a/fn/barrels.fn b/fn/barrels.fn index a6f3e2f..5425413 100644 --- a/fn/barrels.fn +++ b/fn/barrels.fn @@ -63,5 +63,4 @@ let beer } in - print(barrels_of_fun()); - puts("\n") + print(barrels_of_fun()) diff --git a/fn/bugs.fn b/fn/bugs.fn new file mode 100644 index 0000000..c17cd9e --- /dev/null +++ b/fn/bugs.fn @@ -0,0 +1,9 @@ +let + + fn last { + ([a]) { a } + (_ @ t) { last(t) } + } + +in + print(last(["well", " ", "hi", " ", "there"])) diff --git a/fn/derivative.fn b/fn/derivative.fn new file mode 100644 index 0000000..713d9f5 --- /dev/null +++ b/fn/derivative.fn @@ -0,0 +1,61 @@ +let + typedef term { num(int) | + var(char) | + add(term, term) | + sub(term, term) | + mul(term, term) | + div(term, term) | + pow(term, term) } + + fn deriv { + (x, x) { num(1) } + (num(_), _) { num(0) } + (pow(x, num(n)), x) { mul(num(n), pow(x, num(n - 1))) } + (pow(y, n), x) { + let t = simplify(y); + in + if (t == y) { + pow(t, n) + } else { + deriv(pow(t, n), x) + } + } + (add(f, g), x) { add(deriv(f, x), deriv(g, x)) } + (sub(f, g), x) { sub(deriv(f, x), deriv(g, x)) } + (mul(f, g), x) { add(mul(g, deriv(f, x)), mul(f, deriv(g, x))) } + (div(num(1), f), x) { div(sub(num(0), deriv(f, x)), mul(f, f)) } + (div(f, g), x) { div(sub(mul(g, deriv(f, x)), mul(f, deriv(g, x))), mul(g, g)) } + } + + fn simplify { + (x=num(_)) { x } + (x=var(_)) { x } + (add(a, num(0))) | + (add(num(0), a)) { simplify(a) } + (add(num(a), num(b))) { num(a + b) } + (add(num(a), add(num(b), x))) | + (add(num(a), add(x, num(b)))) | + (add(add(x, num(b)), num(a))) | + (add(add(num(b), x), num(a))) { simplify(add(num(a + b), x)) } + (add(a, num(n))) | + (add(a, b)) { add(simplify(a), simplify(b)) } + (sub(a, num(0))) { simplify(a) } + (sub(a, b)) { sub(simplify(a), simplify(b)) } + (mul(num(0), _)) | + (mul(_, num(0))) { num(0) } + (mul(num(1), a)) | + (mul(a, num(1))) { simplify(a) } + (mul(num(a), num(b))) { num(a * b) } + (mul(a, b)) { mul(simplify(a), simplify(b)) } + (div(a, num(1))) { simplify(a) } + (div(num(0), a)) { num(0) } + (div(a, b)) { div(simplify(a), simplify(b)) } + (pow(a, num(1))) { simplify(a) } + (pow(a, num(0))) { num(1) } + (pow(num(a), num(b))) { num(a**b) } + // (a + b)**2 == a**2 + 2ab + b**2 + (pow(add(a, b), num(2))) { simplify(add(pow(a, num(2)), add(mul(num(2), mul(a, b)), pow(b, num(2))))) } + (pow(a, b)) { pow(simplify(a), simplify(b)) } + } +in + print(simplify(deriv(add(add(pow(add(var('x'), num(1)), num(2)), var('x')), num(1)), var('x')))) diff --git a/fn/derivative2.fn b/fn/derivative2.fn new file mode 100644 index 0000000..fcc866e --- /dev/null +++ b/fn/derivative2.fn @@ -0,0 +1,73 @@ +let + typedef term { num(int) | + var(char) | + add(term, term) | + sub(term, term) | + mul(term, term) | + div(term, term) | + pow(term, term) } + + fn deriv(t, x) { + if (t == x) { + num(1) + } else { + switch(t) { + (num(_)) { num(0) } + (pow(y, num(n))) { + if (y == x) { + mul(num(n), pow(y, num(n - 1))) + } else { + let t = simplify(y); + in + if (t == y) { + pow(t, num(n)) + } else { + deriv(pow(t, num(n)), x) + } + } + } + (add(f, g)) { add(deriv(f, x), deriv(g, x)) } + (sub(f, g)) { sub(deriv(f, x), deriv(g, x)) } + (mul(f, g)) { add(mul(g, deriv(f, x)), mul(f, deriv(g, x))) } + (div(num(1), f)) { div(sub(num(0), deriv(f, x)), mul(f, f)) } + (div(f, g)) { div(sub(mul(g, deriv(f, x)), mul(f, deriv(g, x))), mul(g, g)) } + } + } + } + + fn simplify { + (x=num(_)) { x } + (x=var(_)) { x } + (add(a, num(0))) | + (add(num(0), a)) { simplify(a) } + (add(num(a), num(b))) { num(a + b) } + (add(num(a), add(num(b), x))) | + (add(num(a), add(x, num(b)))) | + (add(add(x, num(b)), num(a))) | + (add(add(num(b), x), num(a))) { simplify(add(num(a + b), x)) } + (add(a, num(n))) | + (add(num(n), a)) { add(num(n), simplify(a)) } + (add(a, b)) { add(simplify(a), simplify(b)) } + (sub(a, num(0))) { simplify(a) } + (sub(a, num(n))) { sub(simplify(a), num(n)) } + (sub(a, b)) { sub(simplify(a), simplify(b)) } + (mul(num(0), _)) | + (mul(_, num(0))) { num(0) } + (mul(num(1), a)) | + (mul(a, num(1))) { simplify(a) } + (mul(num(a), num(b))) { num(a * b) } + (mul(a, num(n))) | + (mul(num(n), a)) { mul(num(n), simplify(a)) } + (mul(a, b)) { mul(simplify(a), simplify(b)) } + (div(a, num(1))) { simplify(a) } + (div(num(0), a)) { num(0) } + (div(a, b)) { div(simplify(a), simplify(b)) } + (pow(a, num(1))) { simplify(a) } + (pow(a, num(0))) { num(1) } + (pow(num(a), num(b))) { num(a**b) } + // (a + b)**2 == a**2 + 2ab + b**2 + (pow(add(a, b), num(2))) { simplify(add(pow(a, num(2)), add(mul(num(2), mul(a, b)), pow(b, num(2))))) } + (pow(a, b)) { pow(simplify(a), simplify(b)) } + } +in + print(simplify(simplify(deriv(add(add(pow(add(var('x'), num(1)), num(2)), var('x')), num(1)), var('x'))))) diff --git a/fn/derivative3.fn b/fn/derivative3.fn new file mode 100644 index 0000000..d67e084 --- /dev/null +++ b/fn/derivative3.fn @@ -0,0 +1,9 @@ +let + typedef baz { foo(int) | bar(baz) } + fn fail { + (x, x) { 1 } + (bar(x), x) { 2 } + (_, _) { 3 } + } +in + print(fail(foo(1), foo(1))) diff --git a/fn/dictionary.fn b/fn/dictionary.fn index 191ef61..79d125f 100644 --- a/fn/dictionary.fn +++ b/fn/dictionary.fn @@ -9,7 +9,6 @@ let (B, D(R, a, x, D(R, b, y, c)), z, d) | (B, a, x, D(R, D(R, b, y, c), z, d)) | (B, a, x, D(R, b, y, D(R, c, z, d))) { D(R, D(B, a, x, b), y, D(B, c, z, d)) } - (BB, D(R, a, x, D(R, b, y, c)), z, d) | (BB, D(R, a, x, D(R, b, y, c)), z, d) { D(B, D(B, a, x, b), y, D(B, c, z, d)) } (color, a, b, c) { D(color, a, b, c) } @@ -125,4 +124,4 @@ let } in - lookup('f', delete('f', makeDict("kgimtseettepmupybbbmplgntqzutrfxqarki"))) + print(lookup('f', delete('k', makeDict("kgimtseettepmupybbbmplgntqzutrfxqarki")))) diff --git a/fn/fact.fn b/fn/fact.fn index a925b02..f1c88a4 100644 --- a/fn/fact.fn +++ b/fn/fact.fn @@ -4,5 +4,4 @@ let (n) { n * fact(n - 1) } } in - print(fact(1000)); - puts("\n") + print(fact(1000)) diff --git a/fn/interpreter.fn b/fn/interpreter.fn index 79472ff..9483d69 100644 --- a/fn/interpreter.fn +++ b/fn/interpreter.fn @@ -71,5 +71,4 @@ in symbol("a") ), frame("a", number(3), root) - )); - puts("\n") + )) diff --git a/fn/liars.fn b/fn/liars.fn index d76e37d..a5b47d5 100644 --- a/fn/liars.fn +++ b/fn/liars.fn @@ -44,5 +44,4 @@ let [betty, ethel, joan, kitty, mary] } in - print(liars()); - puts("\n") + print(liars()) diff --git a/fn/listutils.fn b/fn/listutils.fn index 2698da3..df59056 100644 --- a/fn/listutils.fn +++ b/fn/listutils.fn @@ -1,100 +1,185 @@ -fn member { - (_, []) { false } - (x, x @ _) { true } - (x, _ @ t) { member(x, t) } -} - -fn map { - (_, []) { [] } - (func, h @ t) { func(h) @ map(func, t)) } -} - -fn length { - ([]) { 0 } - (_ @ t) { 1 + length(t) } -} - -fn foldl { - (_, [], acc) { acc } - (func, h @ t, acc) { foldl(func, t, func(h, acc)) } -} - -fn foldr(func, lst, acc) { - foldl(func, reverse(lst), acc) -} - -fn reverse (lst) { - foldl(fn (elem, acc) { elem @ acc }, lst, []) -} - -fn filter { - (_, []) { [] } - (func, h @ t) { - if (func(h)) { - h @ filter(func, t) - } else { - filter(func, t) +let + fn member { + (_, []) { false } + (x, x @ _) { true } + (x, _ @ t) { member(x, t) } + } + + fn map { + (_, []) { [] } + (func, h @ t) { func(h) @ map(func, t) } + } + + fn length { + ([]) { 0 } + (_ @ t) { 1 + length(t) } + } + + fn foldl { + (_, acc, []) { acc } + (func, acc, h @ t) { foldl(func, func(h, acc), t) } + } + + fn foldr(func, acc, lst) { + foldl(func, acc, reverse(lst)) + } + + fn foldl1(func, h @ t) { + foldl(func, h, t) + } + + fn foldr1(func, lst) { + foldl1(func, reverse(lst)) + } + + // reverse = foldl((@), []) + fn reverse (lst) { + foldl(fn (elem, acc) { elem @ acc }, [], lst) + } + + fn scanl (func, acc, lst) { + let fn scan { + (acc, []) { acc } + (acc = acc_h @ _, lst_h @ lst_t) { scan(func(lst_h, acc_h) @ acc, lst_t) } } + in scan([acc], lst) } -} - -fn fill { - (0, _) { [] } - (n, v) { v @ fill(n - 1, v) } -} - -fn nth { - (0, h @ _) { h } - (n, _ @ t) { nth(n - 1, t) } -} - -fn sum(lst) { - foldl(fn (elm, acc) { elm + acc }, lst, 0) -} - -fn range(low, high) { - if (low >= high) { [] } - else { low @ range(low + 1, high) } -} - -fn dedup { - ([]) { [] } - (h @ t) { - h @ dedup(filter(t, fn(i) { h != i })) - } -} - -fn sort(lst) { - let - fn full_sort { - ([]) { [] } - (first @ rest) { - partition(first, rest, fn (lesser, greater) { - partial_sort(lesser, first @ full_sort(greater)) - }) + + fn filter { + (_, []) { [] } + (func, h @ t) { + if (func(h)) { + h @ filter(func, t) + } else { + filter(func, t) } } - fn partial_sort { - (first @ rest, already_sorted) { - partition(first, rest, fn (lesser, greater) { - partial_sort(lesser, first @ partial_sort(greater, already_sorted)) - }) - } - ([], sorted) { sorted } + } + + fn concat(lst) { + foldr(fn (elem, acc) { elem @@ acc }, [], lst) + } + + fn any { + (_, []) { false } + (f, h @ t) { f(h) or any(f, t) } + } + + fn none(f, l) { + not any(f, l) + } + + fn all { + (_, []) { true } + (f, h @ t) { f(h) and all(f, t) } + } + + fn repeat { + (0, _) { [] } + (n, v) { v @ repeat(n - 1, v) } + } + + fn nth { + (0, h @ _) { h } + (n, _ @ t) { nth(n - 1, t) } + } + + // sum = foldl((+), 0) + fn sum(lst) { + foldl(fn (elm, acc) { elm + acc }, 0, lst) + } + + // product = foldl((*), 1) + fn product(lst) { + foldl(fn (elm, acc) { elm * acc }, 1, lst) + } + + fn zip { + (h1 @ t1, h2 @ t2) { [h1, h2] @ zip(t1, t2) } + (_, _) { [] } + } + + fn zipWith { + (f, h1 @ t1, h2 @ t2) { f(h1, h2) @ zipWith(f, t1, t2) } + (_, _, _) { [] } + } + + fn last { + ([a]) { a } + (_ @ t) { last(t) } + } + + fn empty { + ([]) { true } + (_) { false } + } + + fn take { + (0, _) { [] } + (n, []) { [] } + (n, h @ t) { h @ take(n - 1, t) } + } + + fn drop { + (0, l) { l } + (n, []) { [] } + (n, _ @ t) { drop(n - 1, t) } + } + + fn minimum(lst) { + foldl1(fn (elem, acc) { if (elem < acc) { elem } else { acc } }, lst) + } + + fn maximum(lst) { + foldl1(fn (elem, acc) { if (elem > acc) { elem } else { acc } }, lst) + } + + fn range(low, high) { + if (low > high) { [] } + else { low @ range(low + 1, high) } + } + + fn dedup { + ([]) { [] } + (h @ t) { + h @ dedup(filter(fn(i) { h != i }, t)) } - fn partition(key, lst, kont) { - let fn helper { - ([], lesser, greater) { kont(lesser, greater) } - (first @ rest, lesser, greater) { - if (key < first) { - helper(rest, lesser, first @ greater) - } else { - helper(rest, first @ lesser, greater) + } + + fn sort(lst) { + let + fn full_sort { + ([]) { [] } + (first @ rest) { + partition(first, rest, fn (lesser, greater) { + partial_sort(lesser, first @ full_sort(greater)) + }) + } + } + fn partial_sort { + (first @ rest, already_sorted) { + partition(first, rest, fn (lesser, greater) { + partial_sort(lesser, first @ partial_sort(greater, already_sorted)) + }) + } + ([], sorted) { sorted } + } + fn partition(key, lst, kont) { + let fn helper { + ([], lesser, greater) { kont(lesser, greater) } + (first @ rest, lesser, greater) { + if (key < first) { + helper(rest, lesser, first @ greater) + } else { + helper(rest, first @ lesser, greater) + } } } + in helper(lst, [], []) } - in helper(lst, [], []) - } - in - full_sort(lst) -} + in + full_sort(lst) + } + +in + print(concat(take(3, ["well", " ", "hi", " ", "there"]))) diff --git a/fn/member2.fn b/fn/member2.fn new file mode 100644 index 0000000..8dfe470 --- /dev/null +++ b/fn/member2.fn @@ -0,0 +1,8 @@ +let + fn member2 { + ([], _) { false } + (item @ t, item) { true } + (_ @ tail, item) { member2(tail, item) } + } +in + member2("abc", 'c') diff --git a/fn/oddEven.fn b/fn/oddEven.fn new file mode 100644 index 0000000..09f9586 --- /dev/null +++ b/fn/oddEven.fn @@ -0,0 +1,11 @@ +let + fn odd { + (0) { false } + (n) { even(n - 1) } + } + fn even { + (0) { true } + (n) { odd(n - 1) } + } +in + print(odd(3)) diff --git a/fn/pythagoreanTriples.fn b/fn/pythagoreanTriples.fn index 62b83b2..e89d86a 100644 --- a/fn/pythagoreanTriples.fn +++ b/fn/pythagoreanTriples.fn @@ -3,8 +3,6 @@ let condition or back } - fn square(x) { x * x } - fn integers_from(n) { n then integers_from(n + 1) } @@ -20,13 +18,12 @@ let x = integers_between(1, z); y = integers_between(x, z); in - require(square(x) + square(y) == square(z)); + require(x**2 + y**2 == z**2); [x, y, z] } in { let triple = pythagorean_triples(); in print(triple); - puts("\n"); require( 20) // until } diff --git a/fn/qsort.fn b/fn/qsort.fn index b877f95..d6680c2 100644 --- a/fn/qsort.fn +++ b/fn/qsort.fn @@ -1,29 +1,110 @@ -// naive un-optimised quicksort implementation to -// demonstrate the principle, see qqsort.fn for -// an optimised version. +// qsort is a naive un-optimised quicksort implementation to +// demonstrate the principle, qqsort is an optimised version. let - unsorted = "rhrtgefewhgjtyjyuosfsfswfgikpzxxvcbfvwfh"; + unsorted = "kgimtseettepmupybbbmplgntqzutrfxqarkivirlbjqjigntslfewhnjouuyiepnswymkfpyovclntwb" + "mhngufnoeidjfmhxxaqmqiaoodslwlwwnzxtdxawnfxbiesjtdwmrzkbdozzyppmdyzhvyhfadldkflw" + "iwvmfutfeckzsqulxlenvpwpbqdjwxpphhtyeuojmvmhgwcisxevzlvbtnobaaokqbutzqumbzlgqwqs" + "ludnrygnynsqcvjekjouyyplgyzlhlsbakaknjauctsspolsvifpwrklfxjfbxrnkecgmypfkbxonkus" + "uzigleakcrnqhktvjonlfiuoeoupuwdtzyytsmggyspdoswafjvceqyzgtksocdhszgybbrrivirlcgo" + "zvxgtvtxgyuukntggimfsoprufwmdngqkabxolitehdjbiqhdjexiaojatkhdjdcpckbxdxwfocqjchi" + "jeylcyhoxnywikniqzpqeeqtucengrvgbbntwmvyeoddjxlgqablttpyrmxlckrvstwmvmfcvmbskciv" + "vsjlchmoczdnbczvznnkiaabonyiqvjmbiyeddetcczprvjfmhmshxmknhonxyxgbgpawkahqbknbqpa" + "rgbnnunwgxphhlvedlyazkfzavezdtlfefpvjiooocpwspyalpahadximvaauocirfgpijbhqskcuuyn" + "vcvtndifklhczerlvjpfpjhnkxxprrsktdfnrrmoypigecxbkzxflgtmdxxzfvdvesewzqotfdlqfibz" + "kchndafnmxirrruoluwghokrgadfanokngfgrwnuxboualnlhxmighxpwfhcvsdgyiryiehzsaqpelnh" + "mzbejngybaqnnwthmxohakvwulpyzsdltquyyxfjtmfrkajmroebudshflggonmhmqahdvdmytvalcdi" + "gjqzsiefihwiihqwuvptripgpzwwbjkqrqwmacsjoqbphilfrkuaqbcqvedwkpmbmxdclajloiimciya" + "trpuhddbpknmkydzxpxqbmiyugulmxxaffpqlurwechzjgsgzrivnzsdbihytchqxvderrjxsoilgyzi" + "zpumoaexhovuadssebduwakznwigstaxgcjixnwfplffmdmpnkgtnrcbkeefpgbdxpjxlrxoiabhhzfn" + "lnshiwszijzfnstudgnqnvvqyshcnekqokcftgiqirhfgxvttijoohfaaapgdrxjiqwmbhwcvudlcexq" + "ybceknreincfokgvoznyfymbjfihngowqecfrwyiwcoawpxnwmxjqdjfsswewbparjwvgmqoqkqsltop" + "vdbvfdwuzgyymdfwxbwccsyzqrvgwgwbmjxqwdcpszcvgghjmwbdsiyrruoparniylkdwxyfsosxzfwz" + "nazzvorretnjpvfndbepurvghnzzzsmoffqoqqcibiblqwsjbjakclgwuuirisihetsykmzhtvrkrqcn" + "paupfvwtyvdbvdoketzlpdhkirmttkgvmqwjfqcqikbnyzvlsuxpnvptcbkjoggygghbvkmbaebikvly" + "lavudzccjyunjnqazihlpeecbxeiimimmjjewztrmggfrhsbvxnvqhjbyhtgfftkyyhiajqtkjmlurbl" + "aiuxppzfzumynhridmymfeaonqyrnrqdachqhsixnnfhsfmfkosolwoarhkmhbmxrfwicojiqrvzllbo" + "vlkdlsurbczlcvfddcnxiccstfqyudnfjwhdpdvwpguowkjvpwbecsjtuxdbtevwpkbdoutwatjoblgs" + "csfapnxdxaxyanuwvuddoqgilxdcznpmdykiskewnbqdsvrnmpbngzvrhkgglfyhqtypoejtqiqcuwjq" + "kbiuwxnjtwvegqhoneeewxdbwqqdipyzvfqmslutyuqfebtwdfoboobxruzspspguysayinklowkfggl" + "yosgqorbuuozjfkqzehptptdbfknkfdmaphktpuzwgjcluxiigpytlejqajvosrpfqvokpaurhzqxydb" + "aphihujakxkgpkktvsywqbeqqnvqfpkokpduowffpqeddgaeesuvrehtttezbrmqmsheeduzztooeleu" + "tvbazyjscveflomwwwkfcxzbzuuxxymgtnczxqhmfmvpactzcovibwizgjpzkxbghbyvraqjjozcwufu" + "bvzcsewyschjxucgkcftobwyrkkervodvvpeabzxbkfyobqmhrycezkrtyqbyddfazuezibxsajclayh" + "yoatnljujvftuedcygqzyfchbenwoffrfkhdhnchecuwkljmuwmjqfxmskimzhrztpagllrosusaofjm" + "kvqzljjlminstxbxydteofdhsjrvpxmjrfpwtevvcxiuabkthrqltmgvpmomklfpknorfxmcvmmmvumo" + "duwboexdejvlwjtpslwnhobenhyzlvyvkclmbqpdgjvflqfzdyshwhtqlsojdlgnazymlutdlzgxdomo" + "bqmcqcvojgmqlyiokaxrorxcswvngwmhsruhshzqlaybhjbctzizftuzbaljjxsjyxmzstvmyinbszsq" + "fylacpgmclczrxlgenrxatrkdgcnytjtxgrtqopssjjzrcsafpacrvtvscthxrpmsdrmenvaaetklhez" + "oqbfhweopoxvadkxqvbhiipegtasxonteityfibkpnuigancwisyowxeihfjuadsfjoxlewpnifjjceg" + "zitjxqpxcousmucwisdmvtinsuuwpzwuuawpcxzscpnqafftsadxcwtrragewwjlnavplniaeathgovt" + "usbgytesbncqtdazvhhjyvdbobuaqdeukualscrywgcqnsrwxupqymypjtgkxlezymjerjjwkrgrnmmy" + "lsxlwsdglcouajefvwfhjylykjgeojbnuirxdgtjsissxhdedndtfuruyxalrricqnkqpupskajjyltj" + "ezgzpdtlktykbvrierzvvzskehmvzgzieizwxhggddfanpnxbyjrekojhdorkzwkplgyumlqmyveesor" + "othsffgsuxdsealasqkycajhgdwgvjqyqlxfsghaaarruxplabewjpxkqwmckbaipcxhebrukmgpeaug" + "uuxicchlzzhhcrctuulypiwtcpsmmhhrllbrcuztikkewrumznhujmgibzzpnxiycmedaawqomhrsika" + "wqzyvdtqcjrzuhapyruccjotrkrlvyrgkrjglomqzxxjmev"; - fn qsort { - ([]) { [] } - (pivot @ rest) { - let - lesser = filter(fn (a, b) { a >= b }(pivot), rest); - greater = filter(fn (a, b) { a < b }(pivot), rest); - in - qsort(lesser) @@ [pivot] @@ qsort(greater) - } + // ~3.6 times faster than simple qsort + fn qqsort(lst) { + let + fn full_sort { + ([]) { [] } + (first @ rest) { + partition(first, rest, fn (lesser, greater) { + partial_sort(lesser, first @ full_sort(greater)) + }) + } + } + fn partial_sort { + (first @ rest, already_sorted) { + partition(first, rest, fn (lesser, greater) { + partial_sort(lesser, first @ partial_sort(greater, already_sorted)) + }) + } + ([], already_sorted) { already_sorted } + } + fn partition(key, lst, kont) { + let fn helper { + ([], lesser, greater) { kont(lesser, greater) } + (first @ rest, lesser, greater) { + if (key < first) { + helper(rest, lesser, first @ greater) + } else { + helper(rest, first @ lesser, greater) + } + } + } + in helper(lst, [], []) + } + in + full_sort(lst) } - fn filter { - (f, []) { [] } - (f, h @ t) { - if (f(h)) { - h @ filter(f, t) - } else { - filter(f, t) + fn qsort(lst) { + let + fn sort { + ([]) { [] } + (pivot @ rest) { + let + lesser = filter(fn (a, b) { a >= b }(pivot), rest); + greater = filter(fn (a, b) { a < b }(pivot), rest); + in + sort(lesser) @@ [pivot] @@ sort(greater) + } + } + + fn filter { + (f, []) { [] } + (f, h @ t) { + if (f(h)) { + h @ filter(f, t) + } else { + filter(f, t) + } + } } - } + in + sort(lst) } in - qsort(unsorted) + qqsort(unsorted) diff --git a/fn/redBlack.fn b/fn/redBlack.fn index 602d5a7..dd5184f 100644 --- a/fn/redBlack.fn +++ b/fn/redBlack.fn @@ -21,7 +21,9 @@ let (red(red(a, x, b), y, c), z, d) | (red(a, x, red(b, y, c)), z, d) | (a, x, red(red(b, y, c), z, d)) | - (a, x, red(b, y, red(c, z, d))) { red(black(a, x, b), y, black(c, z, d)) } + (a, x, red(b, y, red(c, z, d))) { + red(black(a, x, b), y, black(c, z, d)) + } (a, x, b) { black(a, x, b) } } @@ -63,7 +65,8 @@ let fn part_flatten { (red(left, t, right), already_flat) | (black(left, t, right), already_flat) { - part_flatten(left, t @ part_flatten(right, already_flat)) + part_flatten(left, + t @ part_flatten(right, already_flat)) } (leaf, already_flat) { already_flat } } @@ -74,15 +77,18 @@ in makeList( print( makeSet( - "kgimtseettepmupybbbmplgntqzutrfxqarkivirlbjqjigntslfewhnjouuyiepnswymk" - "fpyovclntwbmhngufnoeidjfmhxxaqmqiaoodslwlwwnzxtdxawnfxbiesjtdwmrzkbdoz" - "zyppmdyzhvyhfadldkflwiwvmfutfeckzsqulxlenvpwpbqdjwxpphhtyeuojmvmhgwcis" - "xevzlvbtnobaaokqbutzqumbzlgqwqsludnrygnynsqcvjekjouyyplgyzlhlsbakaknja" - "uctsspolsvifpwrklfxjfbxrnkecgmypfkbxonkusuzigleakcrnqhktvjonlfiuoeoupu" - "wdtzyytsmggyspdoswafjvceqyzgtksocdhszgybbrrivirlcgozvxgtvtxgyuukntggim" - "fsoprufwmdngqkabxolitehdjbiqhdjexiaojatkhdjdcpckbxdxwfocqjchijeylcyhox" - "nywikniqzpqeeqtucengrvgbbntwmvyeoddjxlgqablttpyrmxlckrvstwmvmfcvmbskci" - "vvsjlchmoczdnbczvznnkiaabonyiqvjmbiyeddetcczprvjfmhmshxmknhonxyxgbgpaw" - "kahqbknbqpargbnnunwgxphhlvedlyazkfzavezdtlfefpvjiooocpwspyalpahadximva" - "auocirfgpijbhqskcuuynvcvtndifklhczerlvjpfpjhnkxxprrsktdfnrrmoypigecxbk" - "zxflgtmdxxzfvdvesewzqotfdlqfibzkchndafnmxirrruol"))) + "kgimtseettepmupybbbmplgntqzutrfxqarkivirlbjqjigntslfewhn" + "jouuyiepnswymkfpyovclntwbmhngufnoeidjfmhxxaqmqiaoodslwlw" + "wnzxtdxawnfxbiesjtdwmrzkbdozzyppmdyzhvyhfadldkflwiwvmfut" + "feckzsqulxlenvpwpbqdjwxpphhtyeuojmvmhgwcisxevzlvbtnobaao" + "kqbutzqumbzlgqwqsludnrygnynsqcvjekjouyyplgyzlhlsbakaknja" + "uctsspolsvifpwrklfxjfbxrnkecgmypfkbxonkusuzigleakcrnqhkt" + "vjonlfiuoeoupuwdtzyytsmggyspdoswafjvceqyzgtksocdhszgybbr" + "rivirlcgozvxgtvtxgyuukntggimfsoprufwmdngqkabxolitehdjbiq" + "hdjexiaojatkhdjdcpckbxdxwfocqjchijeylcyhoxnywikniqzpqeeq" + "tucengrvgbbntwmvyeoddjxlgqablttpyrmxlckrvstwmvmfcvmbskci" + "vvsjlchmoczdnbczvznnkiaabonyiqvjmbiyeddetcczprvjfmhmshxm" + "knhonxyxgbgpawkahqbknbqpargbnnunwgxphhlvedlyazkfzavezdtl" + "fefpvjiooocpwspyalpahadximvaauocirfgpijbhqskcuuynvcvtndi" + "fklhczerlvjpfpjhnkxxprrsktdfnrrmoypigecxbkzxflgtmdxxzfvd" + "vesewzqotfdlqfibzkchndafnmxirrruol"))) diff --git a/src/anf.yaml b/src/anf.yaml index e389694..27f8954 100644 --- a/src/anf.yaml +++ b/src/anf.yaml @@ -205,32 +205,9 @@ hashes: CTIntTable: entries: int -primitives: - HashSymbol: - cname: "HashSymbol *" - printFn: "printAstSymbol" - valued: true - bool: - cname: "bool" - printf: "%d" - valued: true - char: - cname: "char" - printf: "%c" - valued: true - int: - cname: "int" - printf: "%d" - valued: true - void_ptr: - cname: "void *" - printf: "%p" - valued: false - BigInt: - cname: "BigInt *" - printFn: "printBigInt" - markFn: "markBigInt" - valued: true +primitives: !include primitives.yaml + +external: TcType: cname: "struct TcType *" printFn: printTcType diff --git a/src/anf_helper.h b/src/anf_helper.h index ee3cf71..15073f8 100644 --- a/src/anf_helper.h +++ b/src/anf_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_anf_helper_h -# define cekf_anf_helper_h +# define cekf_anf_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -22,6 +22,6 @@ * Generated from src/anf.yaml by tools/makeAST.py */ -# include "anf.h" +# include "anf.h" #endif diff --git a/src/anf_normalize.c b/src/anf_normalize.c index 80b7dea..19abd60 100644 --- a/src/anf_normalize.c +++ b/src/anf_normalize.c @@ -25,13 +25,13 @@ #include "bigint.h" #ifdef DEBUG_ANF -# include -# include -# include "debug.h" -# include "lambda_pp.h" -# include "debugging_on.h" +# include +# include +# include "debug.h" +# include "lambda_pp.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static Exp *normalize(LamExp *lamExp, Exp *tail); @@ -94,35 +94,6 @@ Exp *anfNormalize(LamExp *lamExp) { return normalize(lamExp, NULL); } -static int countAexpVarList(AexpVarList *list) { - int count = 0; - while (list != NULL) { - count++; - list = list->next; - } - return count; -} - -static int countAexpList(AexpList *list) { - int count = 0; - while (list != NULL) { - count++; - list = list->next; - } - return count; -} - -/* -static int countLetRecBindings(LetRecBindings *list) { - int count = 0; - while (list != NULL) { - count++; - list = list->next; - } - return count; -} -*/ - static Exp *normalize(LamExp *lamExp, Exp *tail) { ENTER(normalize); IFDEBUG(ppLamExp(lamExp)); diff --git a/src/anf_normalize.h b/src/anf_normalize.h index cc47b8e..8fa2f63 100644 --- a/src/anf_normalize.h +++ b/src/anf_normalize.h @@ -1,5 +1,5 @@ #ifndef cekf_anf_normalize_h -# define cekf_anf_normalize_h +# define cekf_anf_normalize_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "lambda.h" -# include "anf.h" +# include "lambda.h" +# include "anf.h" Exp *anfNormalize(LamExp *exp); diff --git a/src/anf_pp.c b/src/anf_pp.c index 75642ae..17b7b28 100644 --- a/src/anf_pp.c +++ b/src/anf_pp.c @@ -215,7 +215,7 @@ void ppCexpCond(CexpCond *x) { void ppCexpIntCondCases(CexpIntCondCases *x) { while (x != NULL) { eprintf("("); - fprintBigInt(stderr, x->option); + fprintBigInt(errout, x->option); eprintf(" "); ppExp(x->body); eprintf(")"); @@ -351,7 +351,7 @@ void ppAexp(Aexp *x) { eprintf("nil"); break; case AEXP_TYPE_BIGINTEGER: - fprintBigInt(stderr, x->val.biginteger); + fprintBigInt(errout, x->val.biginteger); break; case AEXP_TYPE_LITTLEINTEGER: eprintf("%d", x->val.littleinteger); diff --git a/src/anf_pp.h b/src/anf_pp.h index fd372f0..bb7296a 100644 --- a/src/anf_pp.h +++ b/src/anf_pp.h @@ -1,5 +1,5 @@ #ifndef cekf_anf_pp_h -# define cekf_anf_pp_h +# define cekf_anf_pp_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -20,11 +20,11 @@ // Bespoke pretty-printer for anf -# include -# include +# include +# include -# include "common.h" -# include "anf.h" +# include "common.h" +# include "anf.h" void ppAexpLam(AexpLam *x); void ppAexpVarList(AexpVarList *x); diff --git a/src/annotate.c b/src/annotate.c index cb03c32..70d3dfe 100644 --- a/src/annotate.c +++ b/src/annotate.c @@ -27,7 +27,7 @@ #include "anf.h" #ifdef DEBUG_ANNOTATE -# include "debug.h" +# include "debug.h" #endif static bool locate(HashSymbol *var, CTEnv *env, int *frame, int *offset); diff --git a/src/annotate.h b/src/annotate.h index 51b69e9..78482b7 100644 --- a/src/annotate.h +++ b/src/annotate.h @@ -1,5 +1,5 @@ #ifndef cekf_annotate_h -# define cekf_annotate_h +# define cekf_annotate_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,12 +18,12 @@ * along with this program. If not, see . */ -# include +# include -# include "common.h" -# include "anf.h" -# include "hash.h" -# include "memory.h" +# include "common.h" +# include "anf.h" +# include "hash.h" +# include "memory.h" void annotateExp(Exp *x, CTEnv *env); diff --git a/src/ast.yaml b/src/ast.yaml index c121030..bd24338 100644 --- a/src/ast.yaml +++ b/src/ast.yaml @@ -36,27 +36,15 @@ structs: symbol: HashSymbol expression: AstExpression - AstPrototype: - symbol: HashSymbol - body: AstPrototypeBody - - AstPrototypeBody: - single: AstSinglePrototype - next: AstPrototypeBody - - AstPrototypeSymbolType: - symbol: HashSymbol - type: AstType - AstLoad: package: AstPackage symbol: HashSymbol AstTypeDef: - flatType: AstFlatType + userType: AstUserType typeBody: AstTypeBody - AstFlatType: + AstUserType: symbol: HashSymbol typeSymbols: AstTypeSymbols @@ -143,14 +131,9 @@ structs: unions: AstDefinition: define: AstDefine - prototype: AstPrototype load: AstLoad typeDef: AstTypeDef - AstSinglePrototype: - symbolType: AstPrototypeSymbolType - prototype: AstPrototype - AstTypeClause: integer: void_ptr character: void_ptr @@ -183,23 +166,4 @@ arrays: dimension: 1 entries: char -enums: {} - -primitives: - HashSymbol: - cname: "HashSymbol *" - printFn: printAstSymbol - valued: true - char: - cname: char - printf: "%c" - valued: true - void_ptr: - cname: "void *" - printf: "%p" - valued: false - BigInt: - cname: "BigInt *" - printFn: printBigInt - markFn: markBigInt - valued: true +primitives: !include primitives.yaml diff --git a/src/ast_helper.h b/src/ast_helper.h index 9b201eb..2267f90 100644 --- a/src/ast_helper.h +++ b/src/ast_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_ast_helper_h -# define cekf_ast_helper_h +# define cekf_ast_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "hash.h" -# include "memory.h" +# include "ast.h" +# include "hash.h" +# include "memory.h" void markAstSymbolTable(void); diff --git a/src/bigint.c b/src/bigint.c index a80672a..1b64c59 100644 --- a/src/bigint.c +++ b/src/bigint.c @@ -7,9 +7,9 @@ #include #include #ifdef DEBUG_BIGINT -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif #define BIGINT_ASSERT(a, op, b) assert((a) op (b)); @@ -1301,10 +1301,10 @@ void freeBigInt(BigInt *x) { void printBigInt(BigInt *x, int depth) { eprintf("%*s", depth * PAD_WIDTH, ""); - fprintBigInt(stderr, x); + fprintBigInt(errout, x); } -void bigint_fprint(FILE * f, bigint * bi) { +void bigint_fprint(FILE *f, bigint * bi) { int size = bigint_write_size(bi, 10); if (size < 256) { static char buffer[256]; @@ -1318,7 +1318,7 @@ void bigint_fprint(FILE * f, bigint * bi) { } } -void fprintBigInt(FILE * f, BigInt *x) { +void fprintBigInt(FILE *f, BigInt *x) { if (x == NULL) { fprintf(f, ""); return; @@ -1394,7 +1394,7 @@ BigInt *powBigInt(BigInt *a, BigInt *b) { return res; } -void dumpBigInt(FILE * fp, BigInt *big) { +void dumpBigInt(FILE *fp, BigInt *big) { fprintf(fp, "BigInt %p", big); if (big != NULL) { fprintf(fp, " size:%d, capacity:%d, neg:%d, words:[", big->bi.size, diff --git a/src/bigint.h b/src/bigint.h index 998204d..e36483a 100644 --- a/src/bigint.h +++ b/src/bigint.h @@ -1,35 +1,35 @@ #ifndef BIGINT_H_INCLUDED -# define BIGINT_H_INCLUDED +# define BIGINT_H_INCLUDED -# ifdef __cplusplus +# ifdef __cplusplus extern "C" { -# endif +# endif -# include -# include -# include -# include -# include "memory.h" +# include +# include +# include +# include +# include "memory.h" /* any unsigned integer type */ typedef uint32_t bigint_word; -# define BIGINT_KARATSUBA_WORD_THRESHOLD 20 +# define BIGINT_KARATSUBA_WORD_THRESHOLD 20 -# define BIGINT_WORD_BITS ((sizeof(bigint_word) * CHAR_BIT)) -# define BIGINT_WORD_MAX ((bigint_word)-1) -# define BIGINT_HALF_WORD_MAX (BIGINT_WORD_MAX >> BIGINT_WORD_BITS / 2) +# define BIGINT_WORD_BITS ((sizeof(bigint_word) * CHAR_BIT)) +# define BIGINT_WORD_MAX ((bigint_word)-1) +# define BIGINT_HALF_WORD_MAX (BIGINT_WORD_MAX >> BIGINT_WORD_BITS / 2) -# define BIGINT_WORD_LO(a) ((a) & BIGINT_HALF_WORD_MAX) -# define BIGINT_WORD_HI(a) ((a) >> sizeof(a) * CHAR_BIT / 2) +# define BIGINT_WORD_LO(a) ((a) & BIGINT_HALF_WORD_MAX) +# define BIGINT_WORD_HI(a) ((a) >> sizeof(a) * CHAR_BIT / 2) -# define BIGINT_MIN(a, b) ((a) < (b) ? (a) : (b)) -# define BIGINT_MAX(a, b) ((a) > (b) ? (a) : (b)) -# define BIGINT_INT_ABS(a) ((a) < 0 ? -(unsigned int)(a) : (unsigned int)(a)) +# define BIGINT_MIN(a, b) ((a) < (b) ? (a) : (b)) +# define BIGINT_MAX(a, b) ((a) > (b) ? (a) : (b)) +# define BIGINT_INT_ABS(a) ((a) < 0 ? -(unsigned int)(a) : (unsigned int)(a)) -# define BIGINT_SWAP(type, a, b) do { type _tmp = a; a = b; b = _tmp; } while (0) +# define BIGINT_SWAP(type, a, b) do { type _tmp = a; a = b; b = _tmp; } while (0) -# define BIGINT_REVERSE(type, data, n) do {\ +# define BIGINT_REVERSE(type, data, n) do {\ int _i;\ for (_i = 0; _i < (n)/2; _i++) BIGINT_SWAP(type, data[_i], data[n - 1 - _i]);\ } while (0) @@ -53,10 +53,10 @@ extern "C" { void markBigInt(BigInt *bi); void freeBigInt(BigInt *bi); void printBigInt(BigInt *bi, int depth); - void fprintBigInt(FILE * f, BigInt *x); + void fprintBigInt(FILE *f, BigInt *x); void sprintBigInt(char *s, BigInt *x); int cmpBigInt(BigInt *a, BigInt *b); - void dumpBigInt(FILE * fp, BigInt *big); + void dumpBigInt(FILE *fp, BigInt *big); typedef bigint *(*bigint_binop)(bigint * dst, const bigint * a, const bigint * b); BigInt *addBigInt(BigInt *a, BigInt *b); @@ -65,7 +65,7 @@ extern "C" { BigInt *divBigInt(BigInt *a, BigInt *b); BigInt *modBigInt(BigInt *a, BigInt *b); BigInt *powBigInt(BigInt *a, BigInt *b); - void bigint_fprint(FILE * f, bigint * bi); + void bigint_fprint(FILE *f, bigint * bi); // END CEKF additions @@ -178,7 +178,7 @@ extern "C" { double bigint_double(const bigint * src); -# ifdef __cplusplus +# ifdef __cplusplus } -# endif +# endif #endif diff --git a/src/bytecode.c b/src/bytecode.c index 8b2217b..f50aacd 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -28,9 +28,9 @@ #include "common.h" #ifdef DEBUG_BYTECODE -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif void initByteCodeArray(ByteCodeArray *b) { @@ -287,24 +287,6 @@ void writeCexpIf(CexpIf *x, ByteCodeArray *b) { LEAVE(writeCexpIf); } -static int countCexpCharCondCases(CexpCharCondCases *x) { - int val = 0; - while (x != NULL) { - val++; - x = x->next; - } - return val; -} - -static int countCexpIntCondCases(CexpIntCondCases *x) { - int val = 0; - while (x != NULL) { - val++; - x = x->next; - } - return val; -} - void writeCexpCharCondCases(int depth, int *values, int *addresses, int *jumps, CexpCharCondCases *x, ByteCodeArray *b) { diff --git a/src/bytecode.h b/src/bytecode.h index fed7519..8cf42c9 100644 --- a/src/bytecode.h +++ b/src/bytecode.h @@ -1,5 +1,5 @@ #ifndef cekf_bytecode_h -# define cekf_bytecode_h +# define cekf_bytecode_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "anf.h" -# include "memory.h" +# include "anf.h" +# include "memory.h" typedef uint8_t byte; typedef uint16_t word; diff --git a/src/cekf.h b/src/cekf.h index e67b1c4..eaa242f 100644 --- a/src/cekf.h +++ b/src/cekf.h @@ -1,5 +1,5 @@ #ifndef cekf_cekf_h -# define cekf_cekf_h +# define cekf_cekf_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -22,14 +22,14 @@ * The structures of the CEKF machine. */ -# include -# include +# include +# include -# include "bytecode.h" -# include "common.h" -# include "anf.h" -# include "memory.h" -# include "value.h" +# include "bytecode.h" +# include "common.h" +# include "anf.h" +# include "memory.h" +# include "value.h" typedef size_t Control; diff --git a/src/common.h b/src/common.h index 281706a..8af2700 100644 --- a/src/common.h +++ b/src/common.h @@ -1,5 +1,5 @@ #ifndef cekf_common_h -# define cekf_common_h +# define cekf_common_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,11 +18,13 @@ * along with this program. If not, see . */ -# include -# include +# include +# include +# include -typedef uint32_t hash_t; +# define DEBUG_ANY +# ifdef DEBUG_ANY // #define DEBUG_STACK // #define DEBUG_STEP // if DEBUG_STEP is defined, this sleeps for 1 second between each machine step @@ -31,10 +33,10 @@ typedef uint32_t hash_t; # define DEBUG_STRESS_GC // #define DEBUG_LOG_GC // #define DEBUG_GC -// #define DEBUG_TPMC_MATCH -// #define DEBUG_TPMC_TRANSLATE -// #define DEBUG_TPMC_LOGIC -// #define DEBUG_ANALIZE +// # define DEBUG_TPMC_MATCH +// # define DEBUG_TPMC_TRANSLATE +// # define DEBUG_TPMC_LOGIC +// #define DEBUG_ANNOTATE // #define DEBUG_DESUGARING // #define DEBUG_HASHTABLE // #define DEBUG_TIN_SUBSTITUTION @@ -43,8 +45,8 @@ typedef uint32_t hash_t; // #define DEBUG_BYTECODE // define this to make fatal errors dump core (if ulimit allows) # define DEBUG_DUMP_CORE -// #define DEBUG_TC -// #define DEBUG_LAMBDA_CONVERT +// # define DEBUG_TC +// # define DEBUG_LAMBDA_CONVERT // #define DEBUG_LAMBDA_SUBSTITUTE // #define DEBUG_LEAK // #define DEBUG_ANF @@ -53,17 +55,21 @@ typedef uint32_t hash_t; // #define DEBUG_PRINT_COMPILER // define this to turn on additional safety checks for things that shouldn't but just possibly might happen # define SAFETY_CHECKS +# endif -# ifndef __GNUC__ -# define __attribute__(x) -# endif -void cant_happen(const char *message, ...) - __attribute__((noreturn, format(printf, 1, 2))); +# ifndef __GNUC__ +# define __attribute__(x) +# endif +# define errout stdout +void _cant_happen(char *file, int line, const char *message, ...) + __attribute__((noreturn, format(printf, 3, 4))); void can_happen(const char *message, ...) __attribute__((format(printf, 1, 2))); void eprintf(const char *message, ...) __attribute__((format(printf, 1, 2))); bool hadErrors(void); -# define PAD_WIDTH 2 +#define cant_happen(...) _cant_happen(__FILE__, __LINE__, __VA_ARGS__) + +# define PAD_WIDTH 2 #endif diff --git a/src/debug.c b/src/debug.c index fafad57..93fc128 100644 --- a/src/debug.c +++ b/src/debug.c @@ -49,7 +49,7 @@ void printContainedValue(Value x, int depth) { break; case VALUE_TYPE_BIGINT: printPad(depth); - fprintBigInt(stderr, x.val.b); + fprintBigInt(errout, x.val.b); break; case VALUE_TYPE_CHARACTER: printPad(depth); @@ -464,7 +464,7 @@ void dumpByteCode(ByteCodeArray *b) { if (bigint_flag) { bigint bi = readBigint(b, &i); eprintf(" "); - bigint_fprint(stderr, &bi); + bigint_fprint(errout, &bi); bigint_free(&bi); } else { int li = readInt(b, &i); @@ -546,7 +546,7 @@ void dumpByteCode(ByteCodeArray *b) { case BYTECODE_BIGINT:{ eprintf("BIGINT ["); bigint bi = readBigint(b, &i); - bigint_fprint(stderr, &bi); + bigint_fprint(errout, &bi); eprintf("]\n"); bigint_free(&bi); } diff --git a/src/debug.h b/src/debug.h index 6974b63..c632cef 100644 --- a/src/debug.h +++ b/src/debug.h @@ -1,5 +1,5 @@ #ifndef cekf_debug_h -# define cekf_debug_h +# define cekf_debug_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,10 +18,10 @@ * along with this program. If not, see . */ -# include "cekf.h" -# include "anf.h" -# include "annotate.h" -# include "bytecode.h" +# include "cekf.h" +# include "anf.h" +# include "annotate.h" +# include "bytecode.h" void printCEKF(CEKF * x); diff --git a/src/debugging_off.h b/src/debugging_off.h index 2827144..f94bc08 100644 --- a/src/debugging_off.h +++ b/src/debugging_off.h @@ -1,5 +1,5 @@ #ifndef cekf_debugging -# define cekf_debugging +# define cekf_debugging /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -20,14 +20,14 @@ * Term Pattern Matching Compiler stage 4. code generation */ -# define ENTER(n) -# define LEAVE(n) -# define DEBUG(...) -# define DEBUGN(...) -# define IFDEBUG(x) -# define IFDEBUGN(x) -# define NEWLINE() -# define DEBUGGING_ON() -# define DEBUGGING_OFF() +# define ENTER(n) +# define LEAVE(n) +# define DEBUG(...) +# define DEBUGN(...) +# define IFDEBUG(x) +# define IFDEBUGN(x) +# define NEWLINE() +# define DEBUGGING_ON() +# define DEBUGGING_OFF() #endif diff --git a/src/debugging_on.h b/src/debugging_on.h index d4abe09..e37bf40 100644 --- a/src/debugging_on.h +++ b/src/debugging_on.h @@ -1,5 +1,5 @@ #ifndef cekf_debugging -# define cekf_debugging +# define cekf_debugging /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -22,9 +22,9 @@ static int _debugInvocationId __attribute__((unused)) = 0; static bool _debuggingOn __attribute__((unused)) = true; static int _debuggingDepth __attribute__((unused)) = 0; -# define __DEBUGPAD__() do { for (int pads = _debuggingDepth / 4; pads > 0; pads--) { eprintf(" |"); } eprintf("%*s", _debuggingDepth % 4, ""); } while (false) +# define __DEBUGPAD__() do { for (int pads = _debuggingDepth / 4; pads > 0; pads--) { eprintf(" |"); } eprintf("%*s", _debuggingDepth % 4, ""); } while (false) -# define DEBUG(...) do { \ +# define DEBUG(...) do { \ if (_debuggingOn) { \ eprintf("%s:%-5d", __FILE__, __LINE__); \ __DEBUGPAD__(); \ @@ -33,7 +33,7 @@ static int _debuggingDepth __attribute__((unused)) = 0; } \ } while(0) -# define DEBUGN(...) do { \ +# define DEBUGN(...) do { \ if (_debuggingOn) { \ eprintf("%s:%-5d", __FILE__, __LINE__); \ __DEBUGPAD__(); \ @@ -41,18 +41,18 @@ static int _debuggingDepth __attribute__((unused)) = 0; } \ } while(0) -# define ENTER(name) int _debugMyId = _debugInvocationId++; DEBUG("ENTER " #name " #%d", _debugMyId); _debuggingDepth++ +# define ENTER(name) int _debugMyId = _debugInvocationId++; DEBUG("ENTER " #name " #%d", _debugMyId); _debuggingDepth++ -# define LEAVE(name) _debuggingDepth--; DEBUG("LEAVE " #name " #%d", _debugMyId) +# define LEAVE(name) _debuggingDepth--; DEBUG("LEAVE " #name " #%d", _debugMyId) -# define NEWLINE() do { if (_debuggingOn) eprintf("\n"); } while(0) +# define NEWLINE() do { if (_debuggingOn) eprintf("\n"); } while(0) -# define IFDEBUG(x) do { if (_debuggingOn) { eprintf("%s:%-5d", __FILE__, __LINE__); __DEBUGPAD__(); x; NEWLINE(); } } while(0) +# define IFDEBUG(x) do { if (_debuggingOn) { eprintf("%s:%-5d", __FILE__, __LINE__); __DEBUGPAD__(); x; NEWLINE(); } } while(0) -# define IFDEBUGN(x) do { if (_debuggingOn) { x; NEWLINE(); } } while(0) +# define IFDEBUGN(x) do { if (_debuggingOn) { x; NEWLINE(); } } while(0) -# define DEBUGGING_ON() do { _debuggingOn = true; } while (0) +# define DEBUGGING_ON() do { _debuggingOn = true; } while (0) -# define DEBUGGING_OFF() do { _debuggingOn = false; } while (0) +# define DEBUGGING_OFF() do { _debuggingOn = false; } while (0) #endif diff --git a/src/desugaring.c b/src/desugaring.c index e0a8b12..2a310e8 100644 --- a/src/desugaring.c +++ b/src/desugaring.c @@ -26,7 +26,7 @@ #include "symbol.h" #ifdef DEBUG_DESUGARING -# include "debug.h" +# include "debug.h" #endif static AexpLam *desugarAexpLam(AexpLam *x); @@ -45,9 +45,9 @@ static Aexp *desugarAexp(Aexp *x); static Cexp *desugarCexp(Cexp *x); #ifdef DEBUG_DESUGARING -# define DEBUG_DESUGAR(type, val) do { printf("desugar" #type ": "); print ## type (val); printf("\n"); } while(0) +# define DEBUG_DESUGAR(type, val) do { printf("desugar" #type ": "); print ## type (val); printf("\n"); } while(0) #else -# define DEBUG_DESUGAR(type, val) do {} while(0) +# define DEBUG_DESUGAR(type, val) do {} while(0) #endif static AexpLam *desugarAexpLam(AexpLam *x) { diff --git a/src/desugaring.h b/src/desugaring.h index 99ad368..afaf6c7 100644 --- a/src/desugaring.h +++ b/src/desugaring.h @@ -1,5 +1,5 @@ #ifndef cekf_desugaring_h -# define cekf_desugaring_h +# define cekf_desugaring_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,7 +18,7 @@ * along with this program. If not, see . */ -# include "anf.h" +# include "anf.h" Exp *desugarExp(Exp *expr); diff --git a/src/errors.c b/src/errors.c index cd12c7a..9828098 100644 --- a/src/errors.c +++ b/src/errors.c @@ -28,14 +28,12 @@ static bool errors = false; -#define __OUT__ stderr - -void cant_happen(const char *message, ...) { +void _cant_happen(char *file, int line, const char *message, ...) { va_list args; va_start(args, message); - vfprintf(__OUT__, message, args); + vfprintf(errout, message, args); va_end(args); - eprintf("\n"); + eprintf(" at %s line %d\n", file, line); #ifdef DEBUG_DUMP_CORE abort(); #else @@ -46,7 +44,7 @@ void cant_happen(const char *message, ...) { void can_happen(const char *message, ...) { va_list args; va_start(args, message); - vfprintf(__OUT__, message, args); + vfprintf(errout, message, args); va_end(args); eprintf("\n"); errors = true; @@ -55,7 +53,7 @@ void can_happen(const char *message, ...) { void eprintf(const char *message, ...) { va_list args; va_start(args, message); - vfprintf(__OUT__, message, args); + vfprintf(errout, message, args); va_end(args); } diff --git a/src/hash.c b/src/hash.c index d078024..6aea652 100644 --- a/src/hash.c +++ b/src/hash.c @@ -27,9 +27,9 @@ #include "hash.h" #include "memory.h" #ifdef DEBUG_HASHTABLE -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif bool quietPrintHashTable = false; @@ -166,10 +166,10 @@ void hashSet(HashTable *table, HashSymbol *var, void *src) { void *target = valuePtr(table, index); #if defined(DEBUG_HASHTABLE) || defined(DEBUG_LEAK) eprintf("memcpy(%p, %p, %ld);\n", target, src, table->valuesize); -# ifdef DEBUG_LEAK +# ifdef DEBUG_LEAK eprintf("// *%p == %p, table->values == %p\n", src, *((void **) src), table->values); -# endif +# endif #endif memcpy(target, src, table->valuesize); } diff --git a/src/hash.h b/src/hash.h index 29f8472..3c5623f 100644 --- a/src/hash.h +++ b/src/hash.h @@ -1,5 +1,5 @@ #ifndef cekf_hash_h -# define cekf_hash_h +# define cekf_hash_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,13 +18,15 @@ * along with this program. If not, see . */ -# include +# include -# include "common.h" -# include "memory.h" -# include "value.h" +# include "common.h" +# include "memory.h" +# include "value.h" -# define HASH_MAX_LOAD 0.75 +# define HASH_MAX_LOAD 0.75 + +typedef uint32_t hash_t; typedef struct HashSymbol { struct Header header; diff --git a/src/lambda.yaml b/src/lambda.yaml index e5def85..c2f8ac6 100644 --- a/src/lambda.yaml +++ b/src/lambda.yaml @@ -90,7 +90,7 @@ structs: next: LamIntCondCases LamCharCondCases: - constant: character + constant: char body: LamExp next: LamCharCondCases @@ -186,7 +186,7 @@ structs: LamTypeConstructorInfo: type: LamTypeConstructor - vec: bool # does this need to be a vector? + needsVec: bool # does this need to be a vector? arity: int # number of arguments to this constructor size: int # number of alternatives index: int # index into list of alternatives @@ -242,7 +242,7 @@ unions: or: LamOr amb: LamAmb print: LamPrint - character: character + character: char back: void_ptr error: void_ptr cond_default: void_ptr @@ -264,35 +264,11 @@ hashes: LamExpTable: entries: LamExp -primitives: - HashSymbol: - cname: "HashSymbol *" - printFn: "printLambdaSymbol" - markFn: "markHashSymbol" - valued: true - BigInt: - cname: "BigInt *" - printFn: "printBigInt" - markFn: "markBigInt" - valued: true +primitives: !include primitives.yaml + +external: TcType: cname: "struct TcType *" printFn: printTcType markFn: markTcType valued: true - void_ptr: - cname: "void *" - printf: "%p" - valued: false - int: - cname: "int" - printf: "%d" - valued: true - bool: - cname: "bool" - printf: "%d" - valued: true - character: - cname: "char" - printf: "%c" - valued: true diff --git a/src/lambda_conversion.c b/src/lambda_conversion.c index aa55ac3..374cc2e 100644 --- a/src/lambda_conversion.c +++ b/src/lambda_conversion.c @@ -28,6 +28,7 @@ #include "lambda_helper.h" #include "symbols.h" #include "tpmc_logic.h" +#include "tpmc_mermaid.h" #include "ast_debug.h" #include "print_generator.h" @@ -49,39 +50,24 @@ static LamTypeDefList *collectTypeDefs(AstDefinitions *definitions, static LamTypeConstructor *collectTypeConstructor(AstTypeConstructor *typeConstructor, LamType *type, int size, - int index, bool hasFields, + int index, bool needsVec, LamContext *env); static void collectTypeInfo(HashSymbol *symbol, LamTypeConstructor *type, - bool someoneHasFields, int enumCount, int index, + bool needsVec, int enumCount, int index, int arity, LamContext *env); static LamTypeConstructorArgs *convertAstTypeList(AstTypeList *typeList); static HashSymbol *dollarSubstitute(HashSymbol *original); #ifdef DEBUG_LAMBDA_CONVERT -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif -#define MAKE_COUNT_LIST(type) \ -static int count ## type (type *list) { \ - ENTER(count ## type); \ - int count = 0; \ - while (list != NULL) { \ - count++; \ - list = list->next; \ - } \ - LEAVE(count ## type); \ - return count; \ -} - -MAKE_COUNT_LIST(LamLetRecBindings) MAKE_COUNT_LIST(AstTypeList) -MAKE_COUNT_LIST(AstExpressions) MAKE_COUNT_LIST(AstArgList) -MAKE_COUNT_LIST(AstCompositeFunction) - static bool inPreamble = true; // preamble is treated specially - static bool preambleLocked = false; - - LamExp *lamConvertNest(AstNest *nest, LamContext *env) { +static bool inPreamble = true; // preamble is treated specially +static bool preambleLocked = false; + +LamExp *lamConvertNest(AstNest *nest, LamContext *env) { ENTER(lamConvertNest); bool hasLock = inPreamble && !preambleLocked; if (hasLock) @@ -120,10 +106,12 @@ MAKE_COUNT_LIST(AstCompositeFunction) result = newLamExp(LAMEXP_TYPE_TYPEDEFS, LAMEXP_VAL_TYPEDEFS(typeDefs)); } + if (hasLock) + preambleLocked = false; UNPROTECT(save); LEAVE(lamConvertNest); return result; - } +} static LamExp *lamConvertIff(AstIff *iff, LamContext *context) { ENTER(lamConvertIff); @@ -168,15 +156,6 @@ static LamLetRecBindings *convertFuncDefs(AstDefinitions *definitions, return this; } -static int countTypeBodies(AstTypeBody *typeBody) { - int count = 0; - while (typeBody != NULL) { - count++; - typeBody = typeBody->next; - } - return count; -} - static LamTypeArgs *convertTypeSymbols(AstTypeSymbols *symbols) { if (symbols == NULL) return NULL; @@ -187,10 +166,10 @@ static LamTypeArgs *convertTypeSymbols(AstTypeSymbols *symbols) { return this; } -static LamType *convertTypeDefType(AstFlatType *flat) { - LamTypeArgs *args = convertTypeSymbols(flat->typeSymbols); +static LamType *convertUserType(AstUserType *userType) { + LamTypeArgs *args = convertTypeSymbols(userType->typeSymbols); int save = PROTECT(args); - LamType *res = newLamType(flat->symbol, args); + LamType *res = newLamType(userType->symbol, args); UNPROTECT(save); return res; } @@ -291,11 +270,11 @@ static LamTypeConstructorArgs *convertAstTypeList(AstTypeList *typeList) { } static void collectTypeInfo(HashSymbol *symbol, LamTypeConstructor *type, - bool someoneHasFields, int enumCount, int index, + bool needsVec, int enumCount, int index, int arity, LamContext *env) { ENTER(collectTypeInfo); LamTypeConstructorInfo *info = - newLamTypeConstructorInfo(type, someoneHasFields, arity, enumCount, + newLamTypeConstructorInfo(type, needsVec, arity, enumCount, index); int save = PROTECT(info); addToLamContext(env, symbol, info); @@ -307,7 +286,7 @@ static LamTypeConstructor *collectTypeConstructor(AstTypeConstructor *typeConstructor, LamType *type, int enumCount, int index, - bool someoneHasFields, + bool needsVec, LamContext *env) { int nargs = countAstTypeList(typeConstructor->typeList); LamTypeConstructorArgs *args = @@ -316,18 +295,18 @@ static LamTypeConstructor *collectTypeConstructor(AstTypeConstructor LamTypeConstructor *lamTypeConstructor = newLamTypeConstructor(typeConstructor->symbol, type, args); PROTECT(lamTypeConstructor); - collectTypeInfo(typeConstructor->symbol, lamTypeConstructor, - someoneHasFields, enumCount, index, nargs, env); + collectTypeInfo(typeConstructor->symbol, lamTypeConstructor, needsVec, + enumCount, index, nargs, env); UNPROTECT(save); return lamTypeConstructor; } static LamTypeDef *collectTypeDef(AstTypeDef *typeDef, LamContext *env) { - LamType *type = convertTypeDefType(typeDef->flatType); + LamType *type = convertUserType(typeDef->userType); int save = PROTECT(type); AstTypeBody *typeBody = typeDef->typeBody; - bool hasFields = typeHasFields(typeBody); - int enumCount = countTypeBodies(typeBody); + bool needsVec = typeHasFields(typeBody); + int enumCount = countAstTypeBody(typeBody); int index = 0; LamTypeConstructorList *lamTypeConstructorList = NULL; int save2 = PROTECT(type); @@ -337,7 +316,7 @@ static LamTypeDef *collectTypeDef(AstTypeDef *typeDef, LamContext *env) { type, enumCount, index, - hasFields, + needsVec, env); int save3 = PROTECT(lamTypeConstructor); lamTypeConstructorList = @@ -422,10 +401,17 @@ static LamExp *makeConstant(HashSymbol *name, int tag) { return res; } -static LamLetRecBindings *prependDefine(AstDefine *define, LamContext *env, - LamLetRecBindings *next) { +static LamLetRecBindings *prependDefine(AstDefine * define, LamContext * env, + LamLetRecBindings * next) { ENTER(prependDefine); + bool doMermaid = (tpmc_mermaid_function != NULL + && strcmp(tpmc_mermaid_function, + define->symbol->name) == 0); + if (doMermaid) + tpmc_mermaid_flag = 1; LamExp *exp = convertExpression(define->expression, env); + if (doMermaid) + tpmc_mermaid_flag = 0; int save = PROTECT(exp); LamLetRecBindings *this = newLamLetRecBindings(dollarSubstitute(define->symbol), exp, next); @@ -461,24 +447,15 @@ static HashSymbol *dollarSubstitute(HashSymbol *symbol) { } #define CHECK_ONE_ARG(name, args) do { \ - if ((args) == NULL) { \ - cant_happen("expected 1 arg in " #name ", got 0"); \ - } \ - if ((args)->next != NULL) { \ - cant_happen("expected 1 arg in " #name ", got > 1"); \ - } \ + int count = countLamList(args); \ + if (count != 1) \ + cant_happen("expected 1 arg in " #name ", got %d", count); \ } while(0) #define CHECK_TWO_ARGS(name, args) do { \ - if ((args) == NULL) { \ - cant_happen("expected 2 args in " #name ", got 0"); \ - } \ - if ((args)->next == NULL) { \ - cant_happen("expected 2 args in " #name ", got 1"); \ - } \ - if ((args)->next->next != NULL) { \ - cant_happen("expected 2 args in " #name ", got > 2"); \ - } \ + int count = countLamList(args); \ + if (count != 2) \ + cant_happen("expected 2 args in " #name ", got %d", count); \ } while(0) static LamExp *makeUnaryOp(LamUnaryOp opCode, LamList *args) { @@ -581,48 +558,65 @@ static LamExp *makePrimApp(HashSymbol *symbol, LamList *args) { return NULL; } -static LamExp *convertFunCall(AstFunCall *funCall, LamContext *env) { - AstExpression *function = funCall->function; - LamList *args = convertExpressions(funCall->arguments, env); - int actualNargs = countAstExpressions(funCall->arguments); - int save = PROTECT(args); - // see if it's a type constructor we can inline FIXME - or a primitive - if (function->type == AST_EXPRESSION_TYPE_SYMBOL) { - HashSymbol *symbol = function->val.symbol; - LamExp *primApp = makePrimApp(symbol, args); - if (primApp != NULL) { - return primApp; +static LamExp *inlineConstructor(HashSymbol *symbol, LamList *args, + LamContext *env) { + LamTypeConstructorInfo *info = lookupInLamContext(env, symbol); + if (info != NULL) { + int actualNargs = countLamList(args); + if (info->needsVec) { + if (actualNargs == info->arity) { + return makeConstruct(symbol, info->index, args); + } else { + cant_happen("wrong number of arguments to constructor %s", + symbol->name); + } } else { - LamTypeConstructorInfo *info = lookupInLamContext(env, symbol); - if (info != NULL) { - if (info->vec) { - if (actualNargs == info->arity) { - LamExp *inLine = - makeConstruct(symbol, info->index, args); - UNPROTECT(save); - return inLine; - } else { - cant_happen - ("wrong number of arguments to constructor %s", - symbol->name); - } - } else { - cant_happen("arguments to empty constructor %s", - symbol->name); - } + if (actualNargs > 0) { + cant_happen("arguments to constant constructor %s", + symbol->name); } + return makeConstant(symbol, info->index); } } - // otherwise we convert as normal - LamExp *fun = convertExpression(function, env); - (void) PROTECT(fun); + return NULL; +} + +static LamExp *convertApplication(AstFunCall *funCall, LamList *args, + LamContext *env) { + int actualNargs = countAstExpressions(funCall->arguments); + LamExp *fun = convertExpression(funCall->function, env); + int save = PROTECT(fun); LamApply *apply = newLamApply(fun, actualNargs, args); - (void) PROTECT(apply); + PROTECT(apply); LamExp *result = newLamExp(LAMEXP_TYPE_APPLY, LAMEXP_VAL_APPLY(apply)); UNPROTECT(save); return result; } +static LamExp *convertFunCall(AstFunCall *funCall, LamContext *env) { + LamList *args = convertExpressions(funCall->arguments, env); + int save = PROTECT(args); + LamExp *result = NULL; + if (funCall->function->type == AST_EXPRESSION_TYPE_SYMBOL) { + HashSymbol *symbol = funCall->function->val.symbol; + result = makePrimApp(symbol, args); + if (result != NULL) { + UNPROTECT(save); + return result; + } + // see if it's a type constructor we can inline + result = inlineConstructor(symbol, args, env); + if (result != NULL) { + UNPROTECT(save); + return result; + } + } + // otherwise we convert as normal + result = convertApplication(funCall, args, env); + UNPROTECT(save); + return result; +} + static LamLam *convertCompositeBodies(int nargs, AstCompositeFunction *fun, LamContext *env) { ENTER(convertCompositeBodies); @@ -666,22 +660,12 @@ static LamExp *convertCompositeFun(AstCompositeFunction *fun, LamContext *env) { } static LamExp *convertSymbol(HashSymbol *symbol, LamContext *env) { - LamTypeConstructorInfo *info = lookupInLamContext(env, symbol); - if (info == NULL) { - DEBUG("convertSymbol %s is not a constructor", symbol->name); + LamExp *result = inlineConstructor(symbol, NULL, env); + if (result == NULL) { symbol = dollarSubstitute(symbol); - LamExp *res = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(symbol)); - return res; - } - DEBUG("convertSymbol %s is a constructor", symbol->name); - if (info->vec) { - if (info->arity > 0) { - cant_happen("too few arguments to constructor %s", symbol->name); - } - return makeConstruct(symbol, info->index, NULL); - } else { - return makeConstant(symbol, info->index); + result = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(symbol)); } + return result; } static LamExp *convertExpression(AstExpression *expression, LamContext *env) { diff --git a/src/lambda_conversion.h b/src/lambda_conversion.h index 5805ac7..2eb2a29 100644 --- a/src/lambda_conversion.h +++ b/src/lambda_conversion.h @@ -1,5 +1,5 @@ #ifndef cekf_lambda_conversion_h -# define cekf_lambda_conversion_h +# define cekf_lambda_conversion_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "lambda.h" +# include "ast.h" +# include "lambda.h" LamExp *lamConvertNest(AstNest *nest, LamContext *env); #endif diff --git a/src/lambda_helper.h b/src/lambda_helper.h index 701913e..b973134 100644 --- a/src/lambda_helper.h +++ b/src/lambda_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_lambda_helper_h -# define cekf_lambda_helper_h +# define cekf_lambda_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,10 +18,10 @@ * along with this program. If not, see . */ -# include "lambda.h" -# include "lambda_debug.h" -# include "hash.h" -# include "memory.h" +# include "lambda.h" +# include "lambda_debug.h" +# include "hash.h" +# include "memory.h" void printLambdaSymbol(HashSymbol *x, int depth); LamContext *extendLamContext(LamContext *parent); diff --git a/src/lambda_pp.c b/src/lambda_pp.c index ee641e2..44ae11f 100644 --- a/src/lambda_pp.c +++ b/src/lambda_pp.c @@ -22,6 +22,7 @@ #include #include #include "lambda_pp.h" +void ppLamTag(LamExp *tag); void ppLamExpD(LamExp *exp, int depth) { while (depth > 0) { @@ -109,7 +110,7 @@ void ppLamExp(LamExp *exp) { ppHashSymbol(exp->val.var); break; case LAMEXP_TYPE_BIGINTEGER: - fprintBigInt(stderr, exp->val.biginteger); + fprintBigInt(errout, exp->val.biginteger); break; case LAMEXP_TYPE_STDINT: eprintf("%d", exp->val.stdint); @@ -132,6 +133,9 @@ void ppLamExp(LamExp *exp) { case LAMEXP_TYPE_CONSTRUCT: ppLamConstruct(exp->val.construct); break; + case LAMEXP_TYPE_TAG: + ppLamTag(exp->val.tag); + break; case LAMEXP_TYPE_CONSTANT: ppLamConstant(exp->val.constant); break; @@ -351,7 +355,7 @@ void ppLamIff(LamIff *iff) { static void _ppLamIntCondCases(LamIntCondCases *cases) { eprintf("("); - fprintBigInt(stderr, cases->constant); + fprintBigInt(errout, cases->constant); eprintf(" "); ppLamExp(cases->body); eprintf(")"); @@ -632,11 +636,17 @@ void ppLamIntList(LamIntList *list) { void ppLamConstruct(LamConstruct *construct) { eprintf("(construct "); ppHashSymbol(construct->name); - eprintf(" %d", construct->tag); + eprintf(" [%d]", construct->tag); _ppLamList(construct->args); eprintf(")"); } +void ppLamTag(LamExp *tag) { + eprintf("(tag "); + ppLamExp(tag); + eprintf(")"); +} + void ppLamConstant(LamConstant *constant) { eprintf("(constant "); ppHashSymbol(constant->name); @@ -646,7 +656,7 @@ void ppLamConstant(LamConstant *constant) { void ppLamDeconstruct(LamDeconstruct *deconstruct) { eprintf("(deconstruct "); ppHashSymbol(deconstruct->name); - eprintf(" %d ", deconstruct->vec); + eprintf("[%d] ", deconstruct->vec); ppLamExp(deconstruct->exp); eprintf(")"); } diff --git a/src/lambda_pp.h b/src/lambda_pp.h index 6964008..cfb9b72 100644 --- a/src/lambda_pp.h +++ b/src/lambda_pp.h @@ -1,5 +1,5 @@ #ifndef cekf_lambda_pp_h -# define cekf_lambda_pp_h +# define cekf_lambda_pp_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -21,7 +21,7 @@ * */ -# include "lambda.h" +# include "lambda.h" void ppLamExpD(LamExp *exp, int depth); void ppLamLam(LamLam *lam); diff --git a/src/lambda_substitution.c b/src/lambda_substitution.c index 29429b8..798adfb 100644 --- a/src/lambda_substitution.c +++ b/src/lambda_substitution.c @@ -16,10 +16,7 @@ * along with this program. If not, see . */ -// conversion of the AST generated by the parser -// to an intermediate "plain" lambda calculus which -// will then be fed into the type checker and the -// A-Normal Form converter. +// Substitution of variables in the bodies of functions, called by the TPMC. #include #include @@ -32,9 +29,9 @@ #include "print_generator.h" #ifdef DEBUG_LAMBDA_SUBSTITUTE -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static HashSymbol *performVarSubstitutions(HashSymbol *var, TpmcSubstitutionTable diff --git a/src/lambda_substitution.h b/src/lambda_substitution.h index b54ae79..5e65ede 100644 --- a/src/lambda_substitution.h +++ b/src/lambda_substitution.h @@ -1,5 +1,5 @@ #ifndef cekf_lambda_substitution_h -# define cekf_lambda_substitution_h +# define cekf_lambda_substitution_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "tpmc.h" -# include "lambda.h" +# include "ast.h" +# include "tpmc.h" +# include "lambda.h" LamExp *lamPerformSubstitutions(LamExp *exp, TpmcSubstitutionTable *substitutions); diff --git a/src/main.c b/src/main.c index c1ab8af..c211119 100644 --- a/src/main.c +++ b/src/main.c @@ -42,19 +42,20 @@ #include "bigint.h" #include "tc_analyze.h" #include "tc_debug.h" +#include "tpmc_mermaid.h" int report_flag = 0; static int help_flag = 0; -int main(int argc, char *argv[]) { +static void processArgs(int argc, char *argv[]) { int c; - clock_t begin = clock(); while (1) { static struct option long_options[] = { { "bigint", no_argument, &bigint_flag, 1 }, { "report", no_argument, &report_flag, 1 }, { "help", no_argument, &help_flag, 1 }, + { "tpmc-mermaid", required_argument, 0, 'm' }, { 0, 0, 0, 0 } }; int option_index = 0; @@ -63,73 +64,89 @@ int main(int argc, char *argv[]) { if (c == -1) break; + + if (c == 'm') { + tpmc_mermaid_function = optarg; + } } if (help_flag) { printf("%s", - "--bigint use arbitrary precision integers\n" - "--report report statistics\n" - "--help this help\n"); + "--bigint use arbitrary precision integers\n" + "--report report statistics\n" + "--tpmc-mermaid=function produce a mermaid graph of the\n" + " function's TPMC state table\n" + "--help this help\n"); exit(0); } - ByteCodeArray byteCodes; - initProtection(); - disableGC(); - /* - printf("char: %ld\n", sizeof(char)); - printf("word: %ld\n", sizeof(word)); - printf("int: %ld\n", sizeof(int)); - printf("bigint_word: %ld\n", sizeof(bigint_word)); - printf("void *: %ld\n", sizeof(void *)); - */ - if (optind >= argc) { eprintf("need filename\n"); exit(1); } - // parse => AST - PmModule *mod = newPmToplevelFromFile(argv[optind]); - PROTECT(mod); +} + +static AstNest *parseFile(char *file) { + disableGC(); + PmModule *mod = newPmToplevelFromFile(file); + int save = PROTECT(mod); pmParseModule(mod); enableGC(); - // lambda conversion: AST => LamExp - LamExp *exp = lamConvertNest(mod->nest, NULL); + UNPROTECT(save); + return mod->nest; +} + +static LamExp *convertNest(AstNest *nest) { + LamExp *exp = lamConvertNest(nest, NULL); int save = PROTECT(exp); #ifdef DEBUG_LAMBDA_CONVERT ppLamExp(exp); eprintf("\n"); #endif - // type checking + UNPROTECT(save); + return exp; +} + +static void typeCheck(LamExp *exp) { TcEnv *env = tc_init(); - PROTECT(env); - TcType *res = tc_analyze(exp, env); + int save = PROTECT(env); + TcType *res __attribute__((unused)) = tc_analyze(exp, env); if (hadErrors()) { - return 1; + exit(1); } - PROTECT(res); - // normalization: LamExp => ANF - Exp *anfExp = anfNormalize(exp); - PROTECT(anfExp); +#ifdef DEBUG_TC + ppTcType(res); + eprintf("\n"); +#endif + UNPROTECT(save); +} + +static Exp *desugar(Exp *anfExp) { disableGC(); - // desugaring anfExp = desugarExp(anfExp); - PROTECT(anfExp); + int save = PROTECT(anfExp); enableGC(); - // static analysis: ANF => annotated ANF (de bruijn) + UNPROTECT(save); + return anfExp; +} + +static void annotate(Exp *anfExp) { annotateExp(anfExp, NULL); #ifdef DEBUG_ANF ppExp(anfExp); eprintf("\n"); #endif - // byte code generation +} + +static ByteCodeArray generateByteCodes(Exp *anfExp) { + ByteCodeArray byteCodes; initByteCodeArray(&byteCodes); writeExp(anfExp, &byteCodes); writeEnd(&byteCodes); - UNPROTECT(save); - // execution - run(byteCodes); - // report stats etc. + return byteCodes; +} + +static void report(clock_t begin) { if (report_flag) { clock_t end = clock(); double time_spent = (double) (end - begin) / CLOCKS_PER_SEC; @@ -138,3 +155,35 @@ int main(int argc, char *argv[]) { reportSteps(); } } + +int main(int argc, char *argv[]) { + clock_t begin = clock(); + processArgs(argc, argv); + initProtection(); + + AstNest *nest = parseFile(argv[optind]); + int save = PROTECT(nest); + + LamExp *exp = convertNest(nest); + REPLACE_PROTECT(save, exp); + + typeCheck(exp); + + Exp *anfExp = anfNormalize(exp); + REPLACE_PROTECT(save, anfExp); + + anfExp = desugar(anfExp); + REPLACE_PROTECT(save, anfExp); + + annotate(anfExp); + + ByteCodeArray byteCodes = generateByteCodes(anfExp); + + UNPROTECT(save); + + run(byteCodes); + + report(begin); + + exit(0); +} diff --git a/src/memory.c b/src/memory.c index 2f08d04..af4292d 100644 --- a/src/memory.c +++ b/src/memory.c @@ -144,7 +144,7 @@ void replaceProtect(int i, Header *obj) { int protect(Header *obj) { #ifdef DEBUG_LOG_GC - fprintf(stderr, "PROTECT(%p:%s) -> %d (%d)\n", obj, + fprintf(errout, "PROTECT(%p:%s) -> %d (%d)\n", obj, (obj == NULL ? "NULL" : typeName(obj->type, obj)), protected->sp, protected->capacity); #endif diff --git a/src/memory.h b/src/memory.h index c444092..ebc5996 100644 --- a/src/memory.h +++ b/src/memory.h @@ -1,5 +1,5 @@ #ifndef cekf_memory_h -# define cekf_memory_h +# define cekf_memory_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,16 +18,16 @@ * along with this program. If not, see . */ -# include -# include +# include +# include struct Header; -# include "ast_objtypes.h" -# include "anf_objtypes.h" -# include "lambda_objtypes.h" -# include "tpmc_objtypes.h" -# include "tc_objtypes.h" +# include "ast_objtypes.h" +# include "anf_objtypes.h" +# include "lambda_objtypes.h" +# include "tpmc_objtypes.h" +# include "tc_objtypes.h" typedef enum { @@ -85,29 +85,29 @@ void validateLastAlloc(void); void reportMemory(void); -# define EXIT_OOM 2 +# define EXIT_OOM 2 -# define NEW_VEC(size) ((Vec *)allocate(sizeof(Vec) + size * sizeof(Value), OBJTYPE_VEC)) -# define FREE_VEC(vec) ((void)reallocate(vec, sizeof(vec) + vec->size * sizeof(Value), 0)) +# define NEW_VEC(size) ((Vec *)allocate(sizeof(Vec) + size * sizeof(Value), OBJTYPE_VEC)) +# define FREE_VEC(vec) ((void)reallocate(vec, sizeof(vec) + vec->size * sizeof(Value), 0)) // Allocation for directly managed objects -# define NEW(thing, type) ((thing *)allocate(sizeof(thing), type)) -# define FREE(thing, type) ((void)reallocate(thing, sizeof(type), 0)) +# define NEW(thing, type) ((thing *)allocate(sizeof(thing), type)) +# define FREE(thing, type) ((void)reallocate(thing, sizeof(type), 0)) // Allocation for indirectly managed objects -# define ALLOCATE(type) ((type *)reallocate(NULL, 0, sizeof(type))) +# define ALLOCATE(type) ((type *)reallocate(NULL, 0, sizeof(type))) -# define NEW_ARRAY(type, count) ((type *)reallocate(NULL, 0, sizeof(type) * (count))) -# define FREE_ARRAY(type, array, count) ((void)reallocate(array, sizeof(type) * (count), 0)) -# define GROW_ARRAY(type, array, oldcount, newcount) ((type *)reallocate(array, sizeof(type) * (oldcount), sizeof(type) * (newcount))) -# define MOVE_ARRAY(type, dest, src, amount) (memmove((dest), (src), sizeof(type) * (amount))) -# define COPY_ARRAY(type, dest, src, amount) (memcpy((dest), (src), sizeof(type) * (amount))) +# define NEW_ARRAY(type, count) ((type *)reallocate(NULL, 0, sizeof(type) * (count))) +# define FREE_ARRAY(type, array, count) ((void)reallocate(array, sizeof(type) * (count), 0)) +# define GROW_ARRAY(type, array, oldcount, newcount) ((type *)reallocate(array, sizeof(type) * (oldcount), sizeof(type) * (newcount))) +# define MOVE_ARRAY(type, dest, src, amount) (memmove((dest), (src), sizeof(type) * (amount))) +# define COPY_ARRAY(type, dest, src, amount) (memcpy((dest), (src), sizeof(type) * (amount))) -# define STARTPROTECT() protect(NULL); -# define PROTECT(x) protect((Header *)(x)) -# define UNPROTECT(i) unProtect(i) -# define REPLACE_PROTECT(i, x) replaceProtect(i, (Header *)(x)) +# define STARTPROTECT() protect(NULL); +# define PROTECT(x) protect((Header *)(x)) +# define UNPROTECT(i) unProtect(i) +# define REPLACE_PROTECT(i, x) replaceProtect(i, (Header *)(x)) -# define MARK(obj) (((Header *)(obj))->keep = true) -# define MARKED(obj) (((Header *)(obj))->keep == true) +# define MARK(obj) (((Header *)(obj))->keep = true) +# define MARKED(obj) (((Header *)(obj))->keep == true) #endif diff --git a/src/module.c b/src/module.c index cc5915e..7bbf79d 100644 --- a/src/module.c +++ b/src/module.c @@ -55,7 +55,7 @@ static FILE *safeFOpen(const char *filename) { return f; } -PmModule *newPmModuleFromFileHandle(FILE * f, const char *origin) { +PmModule *newPmModuleFromFileHandle(FILE *f, const char *origin) { PmModule *mod = newPmModule(); int save = PROTECT(mod); YY_BUFFER_STATE bs = yy_create_buffer(f, YY_BUF_SIZE, mod->scanner); @@ -90,7 +90,7 @@ static void pushPmToplevelFromBufState(PmModule *mod, YY_BUFFER_STATE bs, UNPROTECT(save); } -PmModule *newPmToplevelFromFileHandle(FILE * f, const char *origin) { +PmModule *newPmToplevelFromFileHandle(FILE *f, const char *origin) { PmModule *mod = newPmModule(); pushPmToplevelFromBufState(mod, yy_create_buffer(f, YY_BUF_SIZE, mod->scanner), @@ -171,7 +171,7 @@ void incLineNo(PmModule *mod) { mod->bufStack->lineno++; } -void showModuleState(FILE * fp, PmModule *mod) { +void showModuleState(FILE *fp, PmModule *mod) { if (mod == NULL) { fprintf(fp, "module is null\n"); return; diff --git a/src/module.h b/src/module.h index ac6b50f..10b6d6d 100644 --- a/src/module.h +++ b/src/module.h @@ -1,9 +1,9 @@ #ifndef cekf_module_h -# define cekf_module_h +# define cekf_module_h -# include -# include "ast.h" -# include "memory.h" +# include +# include "ast.h" +# include "memory.h" typedef struct PmModule { Header header; @@ -12,12 +12,12 @@ typedef struct PmModule { AstNest *nest; } PmModule; -PmModule *newPmModuleFromFileHandle(FILE * f, const char *origin); +PmModule *newPmModuleFromFileHandle(FILE *f, const char *origin); PmModule *newPmModuleFromStdin(void); PmModule *newPmModuleFromFile(const char *filename); PmModule *newPmModuleFromString(char *src, char *id); -PmModule *newPmToplevelFromFileHandle(FILE * f, const char *origin); +PmModule *newPmToplevelFromFileHandle(FILE *f, const char *origin); PmModule *newPmToplevelFromStdin(void); PmModule *newPmToplevelFromFile(const char *filename); PmModule *newPmToplevelFromString(char *src, char *id); @@ -27,6 +27,6 @@ void freePmModule(Header *h); int pmParseModule(PmModule *mod); void incLineNo(PmModule *mod); int popPmFile(PmModule *mod); -void showModuleState(FILE * fp, PmModule *mod); +void showModuleState(FILE *fp, PmModule *mod); #endif diff --git a/src/parser.y b/src/parser.y index 8d840c3..f6fac13 100644 --- a/src/parser.y +++ b/src/parser.y @@ -62,6 +62,10 @@ static AstFunCall *newStringList(AstCharArray *str) { return res; } +static AstArg *newAstNilArg() { + return newAstArg(AST_ARG_TYPE_SYMBOL, AST_ARG_VAL_SYMBOL(nilSymbol())); +} + static AstUnpack *newStringUnpack(AstCharArray *str) { AstUnpack *res = newAstUnpack(nilSymbol(), NULL); for (int size = str->size; size > 0; size--) { @@ -130,17 +134,13 @@ static AstCompositeFunction *makeAstCompositeFunction(AstAltFunction *functions, AstEnvType *envType; AstExpression *expression; AstExpressions *expressions; - AstFlatType *flatType; + AstUserType *userType; AstFunCall *funCall; AstLoad *load; AstNamedArg *namedArg; AstNest *nest; AstPackage *package; AstPrint *print; - AstPrototypeBody *prototypeBody; - AstPrototype *prototype; - AstPrototypeSymbolType *prototypeSymbolType; - AstSinglePrototype *singlePrototype; HashSymbol *symbol; AstTypeBody *typeBody; AstTypeClause *typeClause; @@ -169,17 +169,13 @@ static AstCompositeFunction *makeAstCompositeFunction(AstAltFunction *functions, %type env_type %type expression %type expressions expression_statements -%type flat_type +%type user_type %type fun_call binop conslist unop switch string %type load %type named_farg %type top nest nest_body iff_nest %type package extends %type print -%type prototype_body -%type prototype_symbol_type -%type prototype -%type single_prototype %type symbol type_symbol as %type type_body %type type_clause @@ -260,43 +256,15 @@ definitions : %empty { $$ = NULL; } ; definition : symbol '=' expression ';' { $$ = newAstDefinition( AST_DEFINITION_TYPE_DEFINE, AST_DEFINITION_VAL_DEFINE(newAstDefine($1, $3))); } - | prototype { $$ = newAstDefinition( AST_DEFINITION_TYPE_PROTOTYPE, AST_DEFINITION_VAL_PROTOTYPE($1)); } | load { $$ = newAstDefinition( AST_DEFINITION_TYPE_LOAD, AST_DEFINITION_VAL_LOAD($1)); } | typedef { $$ = newAstDefinition( AST_DEFINITION_TYPE_TYPEDEF, AST_DEFINITION_VAL_TYPEDEF($1)); } | defun { $$ = newAstDefinition( AST_DEFINITION_TYPE_DEFINE, AST_DEFINITION_VAL_DEFINE($1)); } | denv { $$ = newAstDefinition( AST_DEFINITION_TYPE_DEFINE, AST_DEFINITION_VAL_DEFINE($1)); } ; -prototype : PROTOTYPE symbol '{' prototype_body '}' { $$ = newAstPrototype($2, $4); } - ; - defun : FN symbol fun { $$ = newAstDefine($2, newAstExpression(AST_EXPRESSION_TYPE_FUN, AST_EXPRESSION_VAL_FUN($3))); } ; -prototype_body : %empty { $$ = NULL; } - | single_prototype prototype_body { - if ($2 == NULL) $$ = newAstPrototypeBody($1, NULL); - else $$ = newAstPrototypeBody($1, $2); - } - ; - -single_prototype : prototype_symbol_type ';' { - $$ = newAstSinglePrototype( - AST_SINGLEPROTOTYPE_TYPE_SYMBOLTYPE, - AST_SINGLEPROTOTYPE_VAL_SYMBOLTYPE($1) - ); - } - | prototype { - $$ = newAstSinglePrototype( - AST_SINGLEPROTOTYPE_TYPE_PROTOTYPE, - AST_SINGLEPROTOTYPE_VAL_PROTOTYPE($1) - ); - } - ; - -prototype_symbol_type : symbol ':' type { $$ = newAstPrototypeSymbolType($1, $3); } - ; - denv : ENV symbol env_expr { $$ = newAstDefine($2, newAstExpression(AST_EXPRESSION_TYPE_ENV, AST_EXPRESSION_VAL_ENV($3))); } ; @@ -309,11 +277,11 @@ as : %empty { $$ = NULL; } /******************************** types */ -typedef : TYPEDEF flat_type '{' type_body '}' { $$ = newAstTypeDef($2, $4); } +typedef : TYPEDEF user_type '{' type_body '}' { $$ = newAstTypeDef($2, $4); } ; -flat_type : symbol { $$ = newAstFlatType($1, NULL); } - | symbol '(' type_symbols ')' { $$ = newAstFlatType($1, $3); } +user_type : symbol { $$ = newAstUserType($1, NULL); } + | symbol '(' type_symbols ')' { $$ = newAstUserType($1, $3); } ; type_symbols : type_symbol { $$ = newAstTypeSymbols($1, NULL); } @@ -388,7 +356,7 @@ fargs : %empty { $$ = NULL; } | farg ',' fargs { $$ = newAstArgList($1, $3); } ; -consfargs : farg { $$ = newAstUnpack(consSymbol(), newAstArgList($1, NULL)); } +consfargs : farg { $$ = newAstUnpack(consSymbol(), newAstArgList($1, newAstArgList(newAstNilArg(), NULL))); } | farg ',' consfargs { $$ = newAstUnpack(consSymbol(), newAstArgList($1, newAstArgList(newAstArg(AST_ARG_TYPE_UNPACK, AST_ARG_VAL_UNPACK($3)), NULL))); } ; @@ -398,7 +366,7 @@ farg : symbol { $$ = newAstArg(AST_ARG_TYPE_SYMBOL, AST_ARG_VAL_SYM | unpack { $$ = newAstArg(AST_ARG_TYPE_UNPACK, AST_ARG_VAL_UNPACK($1)); } | cons { $$ = newAstArg(AST_ARG_TYPE_UNPACK, AST_ARG_VAL_UNPACK($1)); } | named_farg { $$ = newAstArg(AST_ARG_TYPE_NAMED, AST_ARG_VAL_NAMED($1)); } - | '[' ']' { $$ = newAstArg(AST_ARG_TYPE_SYMBOL, AST_ARG_VAL_SYMBOL(nilSymbol())); } + | '[' ']' { $$ = newAstNilArg(); } | '[' consfargs ']' { $$ = newAstArg(AST_ARG_TYPE_UNPACK, AST_ARG_VAL_UNPACK($2)); } | env_type { $$ = newAstArg(AST_ARG_TYPE_ENV, AST_ARG_VAL_ENV($1)); } | number { $$ = newAstArg(AST_ARG_TYPE_NUMBER, AST_ARG_VAL_NUMBER($1)); } @@ -407,6 +375,9 @@ farg : symbol { $$ = newAstArg(AST_ARG_TYPE_SYMBOL, AST_ARG_VAL_SYM | WILDCARD { $$ = newAstArg(AST_ARG_TYPE_WILDCARD, AST_ARG_VAL_WILDCARD()); } ; +cons : farg CONS farg { $$ = newAstUnpack(consSymbol(), newAstArgList($1, newAstArgList($3, NULL))); } + ; + unpack : symbol '(' fargs ')' { $$ = newAstUnpack($1, $3); } ; @@ -420,9 +391,6 @@ str : STRING { $$ = newCharArray($1); } | str STRING { $$ = appendCharArray($1, $2); } ; -cons : farg CONS farg { $$ = newAstUnpack(consSymbol(), newAstArgList($1, newAstArgList($3, NULL))); } - ; - env_type : symbol ':' symbol { $$ = newAstEnvType($1, $3); } ; @@ -517,9 +485,9 @@ print : PRINT '(' expression ')' { $$ = newAstPrint($3); } %% void yyerror (yyscan_t *locp, PmModule *mod, char const *msg) { - fprintf(stderr, "%s\n", msg); + fprintf(errout, "%s\n", msg); if (mod && mod->bufStack) { - showModuleState(stderr, mod); + showModuleState(errout, mod); } abort(); } diff --git a/src/primitives.yaml b/src/primitives.yaml new file mode 100644 index 0000000..3151127 --- /dev/null +++ b/src/primitives.yaml @@ -0,0 +1,57 @@ +# +# CEKF - VM supporting amb +# Copyright (C) 2022-2023 Bill Hails +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# + +# common primitive types not defined by the schemas + +HashSymbol: + cname: "HashSymbol *" + printFn: printAstSymbol + valued: true + +int: + cname: int + printf: "%d" + valued: true + +void_ptr: + cname: "void *" + printf: "%p" + valued: false + +bool: + cname: "bool" + printf: "%d" + valued: true + +char: + cname: "char" + printf: "%c" + valued: true + +BigInt: + cname: "BigInt *" + printFn: "printBigInt" + markFn: "markBigInt" + compareFn: "cmpBigInt" + valued: true + +string: + cname: "char *" + printf: "%s" + valued: true + diff --git a/src/print_compiler.c b/src/print_compiler.c index 70403f6..8320e29 100644 --- a/src/print_compiler.c +++ b/src/print_compiler.c @@ -31,9 +31,9 @@ #include "symbols.h" #ifdef DEBUG_PRINT_COMPILER -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static LamExp *compilePrinterForFunction(TcFunction *function); @@ -41,9 +41,54 @@ static LamExp *compilePrinterForPair(TcPair *pair); static LamExp *compilePrinterForVar(TcVar *var, TcEnv *env); static LamExp *compilePrinterForInt(); static LamExp *compilePrinterForChar(); -static LamExp *compilePrinterForTypeDef(TcTypeDef *typeDef, TcEnv *env); +static LamExp *compilePrinterForUserType(TcUserType *userType, TcEnv *env); +static LamExp *compilePrinter(TcType *type, TcEnv *env); LamExp *compilePrinterForType(TcType *type, TcEnv *env) { + // (lambda (x) (begin (printer x) (putc '\n') x) + LamExp *printer = compilePrinter(type, env); + int save = PROTECT(printer); + // x) + HashSymbol *name = genSym("x$"); + LamExp *var = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(name)); + PROTECT(var); + LamSequence *seq = newLamSequence(var, NULL); + PROTECT(seq); + + // (putc '\n') x) + LamExp *newline = newLamExp(LAMEXP_TYPE_CHARACTER, LAMEXP_VAL_CHARACTER('\n')); + PROTECT(newline); + LamUnaryApp *app = newLamUnaryApp(LAMUNARYOP_TYPE_PUTC, newline); + PROTECT(app); + LamExp *exp = newLamExp(LAMEXP_TYPE_UNARY, LAMEXP_VAL_UNARY(app)); + PROTECT(exp); + seq = newLamSequence(exp, seq); + PROTECT(seq); + + // (printer x) (putc '\n') x) + LamList *args = newLamList(var, NULL); + PROTECT(args); + LamApply *apply = newLamApply(printer, 1, args); + PROTECT(apply); + LamExp *applyExp = newLamExp(LAMEXP_TYPE_APPLY, LAMEXP_VAL_APPLY(apply)); + PROTECT(applyExp); + seq = newLamSequence(applyExp, seq); + PROTECT(seq); + + // (lambda (x) (begin (printer x) (putc '\n') x) + LamVarList *fargs = newLamVarList(name, NULL); + PROTECT(fargs); + LamExp *body = newLamExp(LAMEXP_TYPE_LIST, LAMEXP_VAL_LIST(seq)); + PROTECT(body); + LamLam *lambda = newLamLam(1, fargs, body); + PROTECT(lambda); + LamExp *res = newLamExp(LAMEXP_TYPE_LAM, LAMEXP_VAL_LAM(lambda)); + UNPROTECT(save); + return res; +} + +static LamExp *compilePrinter(TcType *type, TcEnv *env) { + ENTER(compilePrinter); LamExp *res = NULL; switch (type->type) { case TCTYPE_TYPE_FUNCTION: @@ -62,13 +107,14 @@ LamExp *compilePrinterForType(TcType *type, TcEnv *env) { case TCTYPE_TYPE_CHARACTER: res = compilePrinterForChar(); break; - case TCTYPE_TYPE_TYPEDEF: - res = compilePrinterForTypeDef(type->val.typeDef, env); + case TCTYPE_TYPE_USERTYPE: + res = compilePrinterForUserType(type->val.userType, env); break; default: - cant_happen("unrecognised TcType %d in compilePrinterForType", + cant_happen("unrecognised TcType %d in compilePrinter", type->type); } + LEAVE(compilePrinter); return res; } @@ -85,7 +131,7 @@ static LamExp *compilePrinterForVar(TcVar *var, TcEnv *env) { if (var->instance == NULL) { return makeSymbolExpr("print$"); } - return compilePrinterForType(var->instance, env); + return compilePrinter(var->instance, env); } static LamExp *compilePrinterForInt() { @@ -96,15 +142,20 @@ static LamExp *compilePrinterForChar() { return makePrintChar(); } -static LamList *compilePrinterForTypeDefArgs(TcTypeDefArgs *args, TcEnv *env) { - if (args == NULL) +static LamList *compilePrinterForUserTypeArgs(TcUserTypeArgs *args, + TcEnv *env) { + ENTER(compilePrinterForUserTypeArgs); + if (args == NULL) { + LEAVE(compilePrinterForUserTypeArgs); return NULL; - LamList *next = compilePrinterForTypeDefArgs(args->next, env); + } + LamList *next = compilePrinterForUserTypeArgs(args->next, env); int save = PROTECT(next); - LamExp *this = compilePrinterForType(args->type, env); + LamExp *this = compilePrinter(args->type, env); PROTECT(this); LamList *res = newLamList(this, next); UNPROTECT(save); + LEAVE(compilePrinterForUserTypeArgs); return res; } @@ -113,20 +164,21 @@ static LamExp *compilePrinterForString() { return newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(name)); } -static LamExp *compilePrinterForTypeDef(TcTypeDef *typeDef, TcEnv *env) { - if (typeDef->name == listSymbol()) { - if (typeDef->args - && typeDef->args->type->type == TCTYPE_TYPE_CHARACTER) { +static LamExp *compilePrinterForUserType(TcUserType *userType, TcEnv *env) { + IFDEBUG(printTcUserType(userType, 0)); + if (userType->name == listSymbol()) { + if (userType->args + && userType->args->type->type == TCTYPE_TYPE_CHARACTER) { return compilePrinterForString(); } } - HashSymbol *name = makePrintName("print$", typeDef->name->name); + HashSymbol *name = makePrintName("print$", userType->name->name); if (!getFromTcEnv(env, name, NULL)) { return makeSymbolExpr("print$"); } LamExp *exp = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(name)); int save = PROTECT(exp); - LamList *args = compilePrinterForTypeDefArgs(typeDef->args, env); + LamList *args = compilePrinterForUserTypeArgs(userType->args, env); PROTECT(args); int nargs = countLamList(args); if (nargs == 0) { diff --git a/src/print_compiler.h b/src/print_compiler.h index 1472bdd..b952829 100644 --- a/src/print_compiler.h +++ b/src/print_compiler.h @@ -1,5 +1,5 @@ #ifndef cekf_print_compiler_h -# define cekf_print_compiler_h +# define cekf_print_compiler_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "lambda.h" -# include "value.h" -# include "tc.h" +# include "lambda.h" +# include "value.h" +# include "tc.h" LamExp *compilePrinterForType(TcType *type, TcEnv *env); diff --git a/src/print_generator.c b/src/print_generator.c index aa97e11..0b6f725 100644 --- a/src/print_generator.c +++ b/src/print_generator.c @@ -32,9 +32,9 @@ #include "symbols.h" #ifdef DEBUG_PRINT_GENERATOR -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static LamLetRecBindings *makePrintFunction(LamTypeDef *typeDef, @@ -79,24 +79,6 @@ HashSymbol *makePrintName(char *prefix, char *name) { return res; } -static int countLamVarList(LamVarList *list) { - int res = 0; - while (list != NULL) { - list = list->next; - res++; - } - return res; -} - -int countLamList(LamList *list) { - int res = 0; - while (list != NULL) { - list = list->next; - res++; - } - return res; -} - static HashSymbol *printArgSymbol(void) { static HashSymbol *res = NULL; if (res == NULL) @@ -422,7 +404,7 @@ static LamExp *makeFunctionBody(LamTypeConstructorList *constructors, constructors->constructor->name->name); } LamMatch *match = NULL; - if (info->vec) { + if (info->needsVec) { match = makeTagMatch(constructors, env); } else { match = makePlainMatch(constructors, env); @@ -464,6 +446,7 @@ static LamLetRecBindings *makePrintFunction(LamTypeDef *typeDef, LamContext *env, bool inPreamble) { if (inPreamble && isListType(typeDef->type)) { + // print$list is hand-coded in the preamble return next; } else { return makePrintTypeFunction(typeDef, env, next); diff --git a/src/print_generator.h b/src/print_generator.h index 1b2109e..47f5bf4 100644 --- a/src/print_generator.h +++ b/src/print_generator.h @@ -1,5 +1,5 @@ #ifndef cekf_print_generator_h -# define cekf_print_generator_h +# define cekf_print_generator_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "lambda.h" -# include "value.h" -# include "tc.h" +# include "lambda.h" +# include "value.h" +# include "tc.h" LamLetRecBindings *makePrintFunctions(LamTypeDefList *typeDefs, LamLetRecBindings *rest, @@ -29,6 +29,5 @@ LamExp *makeSymbolExpr(char *name); LamExp *makePrintInt(); LamExp *makePrintChar(); HashSymbol *makePrintName(char *prefix, char *name); -int countLamList(LamList *list); #endif diff --git a/src/stack.c b/src/stack.c index 6e4ea01..60a42f1 100644 --- a/src/stack.c +++ b/src/stack.c @@ -27,10 +27,10 @@ #include #include #ifdef DEBUG_STACK -# include "debug.h" -# include "debugging_on.h" +# include "debug.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif Snapshot noSnapshot = { diff --git a/src/step.c b/src/step.c index f4b7ef9..e1637fe 100644 --- a/src/step.c +++ b/src/step.c @@ -32,9 +32,9 @@ #include "hash.h" #ifdef DEBUG_STEP -# define DEBUGPRINTF(...) printf(__VA_ARGS__) +# define DEBUGPRINTF(...) printf(__VA_ARGS__) #else -# define DEBUGPRINTF(...) +# define DEBUGPRINTF(...) #endif /** @@ -785,7 +785,7 @@ static void step() { break; case BYTECODE_MATCH:{ // pop the dispach code, verify it's an integer and in range, and dispatch - int size = readCurrentByte(); + int size __attribute__((unused)) = readCurrentByte(); #ifdef DEBUG_STEP printf("MATCH [%d]", size); int save = state.C; @@ -1047,9 +1047,9 @@ static void step() { cant_happen("unrecognised bytecode %d in step()", bytecode); } #ifdef DEBUG_STEP -# ifdef DEBUG_SLOW_STEP +# ifdef DEBUG_SLOW_STEP sleep(1); -# endif +# endif #endif } } diff --git a/src/step.h b/src/step.h index 6a01fba..4859063 100644 --- a/src/step.h +++ b/src/step.h @@ -1,5 +1,5 @@ #ifndef cekf_step_h -# define cekf_step_h +# define cekf_step_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "bytecode.h" -# include "value.h" +# include "bytecode.h" +# include "value.h" Value run(ByteCodeArray B); diff --git a/src/symbol.c b/src/symbol.c index 758163b..aa48804 100644 --- a/src/symbol.c +++ b/src/symbol.c @@ -19,31 +19,75 @@ #include #include "symbol.h" +typedef enum GenSymFmt { + DECIMAL, + ALPHABETIC +} GenSymFmt; + // application-wide global symbol store static HashTable *symbolTable = NULL; +static HashTable *genSymTable = NULL; void markVarTable() { markHashTableObj((Header *) symbolTable); + markHashTableObj((Header *) genSymTable); } -HashSymbol *newSymbol(char *name) { +static void initSymbolTable() { if (symbolTable == NULL) { symbolTable = newHashTable(0, NULL, NULL); } +} + +static void initGenSymTable() { + if (genSymTable == NULL) { + genSymTable = newHashTable(sizeof(int), NULL, NULL); + } +} + +HashSymbol *newSymbol(char *name) { + initSymbolTable(); HashSymbol *res = uniqueHashSymbol(symbolTable, name, NULL); validateLastAlloc(); return res; } -HashSymbol *genSym(char *prefix) { - static int symbolCounter = 0; - char buffer[128]; - if (symbolTable == NULL) { - symbolTable = newHashTable(0, NULL, NULL); +HashSymbol *newSymbolCounter(char *baseName) { + initGenSymTable(); + HashSymbol *base = newSymbol(baseName); + if (!hashGet(genSymTable, base, NULL)) { + int i = 0; + hashSet(genSymTable, base, &i); } + return base; +} + +HashSymbol *_genSym(char *prefix, GenSymFmt fmt) { + int symbolCounter = 0; + char buffer[128]; + initSymbolTable(); + HashSymbol *base = newSymbolCounter(prefix); + hashGet(genSymTable, base, &symbolCounter); for (;;) { - sprintf(buffer, "%s%d", prefix, symbolCounter++); + switch (fmt) { + case DECIMAL: + sprintf(buffer, "%s%d", prefix, symbolCounter++); + break; + case ALPHABETIC:{ + char *alphabet = "abcdefghijklmnopqrstuvwxyz"; + char suffix[128]; + int index = 0; + int value = symbolCounter++; + while (value > 0) { + suffix[index++] = alphabet[value % 26]; + suffix[index] = '\0'; + value = value / 26; + } + sprintf(buffer, "%s%s", prefix, suffix); + } + break; + } if (hashGetVar(symbolTable, buffer) == NULL) { HashSymbol *x = NEW(HashSymbol, OBJTYPE_HASHSYMBOL); int save = PROTECT(x); @@ -51,8 +95,16 @@ HashSymbol *genSym(char *prefix) { x->hash = hashString(buffer); hashSet(symbolTable, x, NULL); UNPROTECT(save); - validateLastAlloc(); + hashSet(genSymTable, base, &symbolCounter); return x; } } } + +HashSymbol *genSym(char *prefix) { + return _genSym(prefix, DECIMAL); +} + +HashSymbol *genAlphaSym(char *prefix) { + return _genSym(prefix, ALPHABETIC); +} diff --git a/src/symbol.h b/src/symbol.h index d5e626e..ea93c63 100644 --- a/src/symbol.h +++ b/src/symbol.h @@ -1,5 +1,5 @@ #ifndef cekf_symbol_h -# define cekf_symbol_h +# define cekf_symbol_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,10 @@ * along with this program. If not, see . */ -# include "hash.h" +# include "hash.h" HashSymbol *genSym(char *prefix); +HashSymbol *genAlphaSym(char *prefix); HashSymbol *newSymbol(char *name); diff --git a/src/symbols.c b/src/symbols.c index 5ff192b..6e1a58a 100644 --- a/src/symbols.c +++ b/src/symbols.c @@ -181,7 +181,7 @@ HashSymbol *cmpSymbol() { return res; } -HashSymbol *starshipSymbol() { +HashSymbol *spaceshipSymbol() { static HashSymbol *res = NULL; if (res == NULL) { res = newSymbol("cmp"); diff --git a/src/symbols.h b/src/symbols.h index fff1489..c438f0f 100644 --- a/src/symbols.h +++ b/src/symbols.h @@ -1,5 +1,5 @@ #ifndef cekf_symbols_h -# define cekf_symbols_h +# define cekf_symbols_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,7 +18,7 @@ * along with this program. If not, see . */ -# include "symbol.h" +# include "symbol.h" HashSymbol *addSymbol(void); HashSymbol *andSymbol(void); @@ -45,7 +45,7 @@ HashSymbol *leSymbol(void); HashSymbol *listSymbol(void); HashSymbol *ltSymbol(void); HashSymbol *cmpSymbol(void); -HashSymbol *starshipSymbol(void); +HashSymbol *spaceshipSymbol(void); HashSymbol *modSymbol(void); HashSymbol *mulSymbol(void); HashSymbol *negSymbol(void); diff --git a/src/tc.yaml b/src/tc.yaml index ffad8d1..2836ab6 100644 --- a/src/tc.yaml +++ b/src/tc.yaml @@ -44,13 +44,13 @@ structs: first: TcType second: TcType - TcTypeDef: + TcUserType: name: HashSymbol - args: TcTypeDefArgs + args: TcUserTypeArgs - TcTypeDefArgs: + TcUserTypeArgs: type: TcType - next: TcTypeDefArgs + next: TcUserTypeArgs TcVar: name: HashSymbol @@ -69,18 +69,7 @@ unions: smallinteger: void_ptr biginteger: void_ptr character: void_ptr - typeDef: TcTypeDef + unknown: HashSymbol + userType: TcUserType -primitives: - HashSymbol: - cname: "HashSymbol *" - printFn: printAstSymbol - valued: true - int: - cname: int - printf: "%d" - valued: true - void_ptr: - cname: "void *" - printf: "%p" - valued: false +primitives: !include primitives.yaml diff --git a/src/tc_analyze.c b/src/tc_analyze.c index c13ed7f..e62cc7e 100644 --- a/src/tc_analyze.c +++ b/src/tc_analyze.c @@ -29,24 +29,25 @@ #include "lambda_pp.h" #ifdef DEBUG_TC -# include "debugging_on.h" -# include "lambda_pp.h" +# include "debugging_on.h" +# include "lambda_pp.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static TcEnv *extendEnv(TcEnv *parent); static TcNg *extendNg(TcNg *parent); static void addToEnv(TcEnv *env, HashSymbol *key, TcType *type); -static void addToNg(TcNg *env, HashSymbol *symbol, TcType *type); +static void addToNg(TcNg *env, TcType *type); static void addFreshVarToEnv(TcEnv *env, HashSymbol *key); static void addCmpToEnv(TcEnv *env, HashSymbol *key); static TcType *makeBoolean(void); -static TcType *makeStarship(void); +static TcType *makeSpaceship(void); static TcType *makeSmallInteger(void); static TcType *makeBigInteger(void); static TcType *makeCharacter(void); -static TcType *makeFreshVar(char *); +static TcType *makeUnknown(HashSymbol *var); +static TcType *makeFreshVar(char *name __attribute__((unused))); static TcType *makeVar(HashSymbol *t); static TcType *makeFn(TcType *arg, TcType *result); static void addBoolBinOpToEnv(TcEnv *env, HashSymbol *symbol); @@ -86,7 +87,7 @@ static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng); static TcType *analyzeCharacter(); static TcType *analyzeBack(); static TcType *analyzeError(); -static bool unify(TcType *a, TcType *b); +static bool unify(TcType *a, TcType *b, char *trace __attribute__((unused))); static TcType *prune(TcType *t); static bool occursInType(TcType *a, TcType *b); static bool occursIn(TcType *a, TcType *b); @@ -98,7 +99,7 @@ static TcType *analyzeBooleanExp(LamExp *exp, TcEnv *env, TcNg *ng); static TcType *analyzeCharacterExp(LamExp *exp, TcEnv *env, TcNg *ng); static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map); static TcType *lookup(TcEnv *env, HashSymbol *symbol, TcNg *ng); -static TcType *makeTypeDef(HashSymbol *name, TcTypeDefArgs *args); +static TcType *makeUserType(HashSymbol *name, TcUserTypeArgs *args); static int id_counter = 0; @@ -134,8 +135,7 @@ TcEnv *tc_init(void) { TcType *tc_analyze(LamExp *exp, TcEnv *env) { TcNg *ng = extendNg(NULL); int save = PROTECT(ng); - IFDEBUG(ppLamExp(exp)); - TcType *res = prune(analyzeExp(exp, env, ng)); + TcType *res = analyzeExp(exp, env, ng); UNPROTECT(save); return res; } @@ -145,59 +145,59 @@ static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng) { return NULL; switch (exp->type) { case LAMEXP_TYPE_LAM: - return analyzeLam(exp->val.lam, env, ng); + return prune(analyzeLam(exp->val.lam, env, ng)); case LAMEXP_TYPE_VAR: - return analyzeVar(exp->val.var, env, ng); + return prune(analyzeVar(exp->val.var, env, ng)); case LAMEXP_TYPE_STDINT: - return analyzeSmallInteger(); + return prune(analyzeSmallInteger()); case LAMEXP_TYPE_BIGINTEGER: - return analyzeBigInteger(); + return prune(analyzeBigInteger()); case LAMEXP_TYPE_PRIM: - return analyzePrim(exp->val.prim, env, ng); + return prune(analyzePrim(exp->val.prim, env, ng)); case LAMEXP_TYPE_UNARY: - return analyzeUnary(exp->val.unary, env, ng); + return prune(analyzeUnary(exp->val.unary, env, ng)); case LAMEXP_TYPE_LIST: - return analyzeSequence(exp->val.list, env, ng); + return prune(analyzeSequence(exp->val.list, env, ng)); case LAMEXP_TYPE_MAKEVEC: cant_happen("encountered make-vec in analyzeExp"); case LAMEXP_TYPE_CONSTRUCT: - return analyzeConstruct(exp->val.construct, env, ng); + return prune(analyzeConstruct(exp->val.construct, env, ng)); case LAMEXP_TYPE_DECONSTRUCT: - return analyzeDeconstruct(exp->val.deconstruct, env, ng); + return prune(analyzeDeconstruct(exp->val.deconstruct, env, ng)); case LAMEXP_TYPE_TAG: - return analyzeTag(exp->val.tag, env, ng); + return prune(analyzeTag(exp->val.tag, env, ng)); case LAMEXP_TYPE_CONSTANT: - return analyzeConstant(exp->val.constant, env, ng); + return prune(analyzeConstant(exp->val.constant, env, ng)); case LAMEXP_TYPE_APPLY: - return analyzeApply(exp->val.apply, env, ng); + return prune(analyzeApply(exp->val.apply, env, ng)); case LAMEXP_TYPE_IFF: - return analyzeIff(exp->val.iff, env, ng); + return prune(analyzeIff(exp->val.iff, env, ng)); case LAMEXP_TYPE_CALLCC: - return analyzeCallCC(exp->val.callcc, env, ng); + return prune(analyzeCallCC(exp->val.callcc, env, ng)); case LAMEXP_TYPE_PRINT: - return analyzePrint(exp->val.print, env, ng); + return prune(analyzePrint(exp->val.print, env, ng)); case LAMEXP_TYPE_LETREC: - return analyzeLetRec(exp->val.letrec, env, ng); + return prune(analyzeLetRec(exp->val.letrec, env, ng)); case LAMEXP_TYPE_TYPEDEFS: - return analyzeTypeDefs(exp->val.typedefs, env, ng); + return prune(analyzeTypeDefs(exp->val.typedefs, env, ng)); case LAMEXP_TYPE_LET: - return analyzeLet(exp->val.let, env, ng); + return prune(analyzeLet(exp->val.let, env, ng)); case LAMEXP_TYPE_MATCH: - return analyzeMatch(exp->val.match, env, ng); + return prune(analyzeMatch(exp->val.match, env, ng)); case LAMEXP_TYPE_COND: - return analyzeCond(exp->val.cond, env, ng); + return prune(analyzeCond(exp->val.cond, env, ng)); case LAMEXP_TYPE_AND: - return analyzeAnd(exp->val.and, env, ng); + return prune(analyzeAnd(exp->val.and, env, ng)); case LAMEXP_TYPE_OR: - return analyzeOr(exp->val.or, env, ng); + return prune(analyzeOr(exp->val.or, env, ng)); case LAMEXP_TYPE_AMB: - return analyzeAmb(exp->val.amb, env, ng); + return prune(analyzeAmb(exp->val.amb, env, ng)); case LAMEXP_TYPE_CHARACTER: - return analyzeCharacter(); + return prune(analyzeCharacter()); case LAMEXP_TYPE_BACK: - return analyzeBack(); + return prune(analyzeBack()); case LAMEXP_TYPE_ERROR: - return analyzeError(); + return prune(analyzeError()); case LAMEXP_TYPE_COND_DEFAULT: cant_happen("encountered cond default in analyzeExp"); default: @@ -207,9 +207,9 @@ static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng) { static TcType *makeFunctionType(LamVarList *args, TcEnv *env, TcType *returnType) { - ENTER(makeFunctionType); + // ENTER(makeFunctionType); if (args == NULL) { - LEAVE(makeFunctionType); + // LEAVE(makeFunctionType); return returnType; } TcType *next = makeFunctionType(args->next, env, returnType); @@ -220,43 +220,39 @@ static TcType *makeFunctionType(LamVarList *args, TcEnv *env, } TcType *ret = makeFn(this, next); UNPROTECT(save); - LEAVE(makeFunctionType); + // LEAVE(makeFunctionType); return ret; } static TcType *analyzeLam(LamLam *lam, TcEnv *env, TcNg *ng) { - ENTER(analyzeLam); - IFDEBUG(ppLamLam(lam)); + // ENTER(analyzeLam); env = extendEnv(env); int save = PROTECT(env); ng = extendNg(ng); PROTECT(ng); for (LamVarList *args = lam->args; args != NULL; args = args->next) { - TcType *freshVar = makeFreshVar(args->var->name); - int save2 = PROTECT(freshVar); - addToEnv(env, args->var, freshVar); - addToNg(ng, freshVar->val.var->name, freshVar); + TcType *freshType = makeFreshVar(args->var->name); + int save2 = PROTECT(freshType); + addToEnv(env, args->var, freshType); + addToNg(ng, freshType); UNPROTECT(save2); } TcType *returnType = analyzeExp(lam->exp, env, ng); PROTECT(returnType); TcType *functionType = makeFunctionType(lam->args, env, returnType); UNPROTECT(save); - LEAVE(analyzeLam); - IFDEBUG(ppTcType(functionType)); + // LEAVE(analyzeLam); return functionType; } static TcType *analyzeVar(HashSymbol *var, TcEnv *env, TcNg *ng) { - ENTER(analyzeVar); - DEBUG("var: %s", var->name); + // ENTER(analyzeVar); TcType *res = lookup(env, var, ng); if (res == NULL) { can_happen("undefined variable %s in analyzeVar", var->name); + return makeUnknown(var); } - LEAVE(analyzeVar); - DEBUG("var: %s", var->name); - IFDEBUG(ppTcType(res)); + // LEAVE(analyzeVar); return res; } @@ -265,36 +261,36 @@ static TcType *analyzeSmallInteger() { } static TcType *analyzeBigInteger() { - ENTER(analyzeBigInteger); + // ENTER(analyzeBigInteger); TcType *res = makeBigInteger(); - LEAVE(analyzeBigInteger); + // LEAVE(analyzeBigInteger); return res; } static TcType *analyzeBinaryArith(LamExp *exp1, LamExp *exp2, TcEnv *env, TcNg *ng) { - ENTER(analyzeBinaryArith); + // ENTER(analyzeBinaryArith); (void) analyzeBigIntegerExp(exp1, env, ng); TcType *res = analyzeBigIntegerExp(exp2, env, ng); - LEAVE(analyzeBinaryArith); + // LEAVE(analyzeBinaryArith); return res; } static TcType *analyzeUnaryArith(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeBinaryArith); + // ENTER(analyzeBinaryArith); TcType *res = analyzeBigIntegerExp(exp, env, ng); - LEAVE(analyzeBinaryArith); + // LEAVE(analyzeBinaryArith); return res; } static TcType *analyzeComparison(LamExp *exp1, LamExp *exp2, TcEnv *env, TcNg *ng) { - ENTER(analyzeComparison); + // ENTER(analyzeComparison); TcType *type1 = analyzeExp(exp1, env, ng); int save = PROTECT(type1); TcType *type2 = analyzeExp(exp2, env, ng); PROTECT(type2); - if (!unify(type1, type2)) { + if (!unify(type1, type2, "comparison")) { eprintf("while unifying comparison:\n"); ppLamExp(exp1); eprintf("\nwith\n"); @@ -303,18 +299,18 @@ static TcType *analyzeComparison(LamExp *exp1, LamExp *exp2, TcEnv *env, } UNPROTECT(save); TcType *res = makeBoolean(); - LEAVE(analyzeComparison); + // LEAVE(analyzeComparison); return res; } -static TcType *analyzeStarship(LamExp *exp1, LamExp *exp2, TcEnv *env, +static TcType *analyzeSpaceship(LamExp *exp1, LamExp *exp2, TcEnv *env, TcNg *ng) { - ENTER(analyzeComparison); + // ENTER(analyzeComparison); TcType *type1 = analyzeExp(exp1, env, ng); int save = PROTECT(type1); TcType *type2 = analyzeExp(exp2, env, ng); PROTECT(type2); - if (!unify(type1, type2)) { + if (!unify(type1, type2, "<=>")) { eprintf("while unifying <=>:\n"); ppLamExp(exp1); eprintf("\nwith\n"); @@ -322,36 +318,36 @@ static TcType *analyzeStarship(LamExp *exp1, LamExp *exp2, TcEnv *env, eprintf("\n"); } UNPROTECT(save); - TcType *res = makeStarship(); - LEAVE(analyzeComparison); + TcType *res = makeSpaceship(); + // LEAVE(analyzeComparison); return res; } static TcType *analyzeBinaryBool(LamExp *exp1, LamExp *exp2, TcEnv *env, TcNg *ng) { - ENTER(analyzeBinaryBool); + // ENTER(analyzeBinaryBool); (void) analyzeBooleanExp(exp1, env, ng); TcType *res = analyzeBooleanExp(exp2, env, ng); - LEAVE(analyzeBinaryBool); + // LEAVE(analyzeBinaryBool); return res; } static TcType *analyzeUnaryBool(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeUnaryBool); + // ENTER(analyzeUnaryBool); TcType *res = analyzeBooleanExp(exp, env, ng); - LEAVE(analyzeUnaryBool); + // LEAVE(analyzeUnaryBool); return res; } static TcType *analyzeUnaryChar(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeUnaryChar); + // ENTER(analyzeUnaryChar); TcType *res = analyzeCharacterExp(exp, env, ng); - LEAVE(analyzeUnaryChar); + // LEAVE(analyzeUnaryChar); return res; } static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { - ENTER(analyzePrim); + // ENTER(analyzePrim); TcType *res = NULL; switch (app->type) { case LAMPRIMOP_TYPE_ADD: @@ -371,7 +367,7 @@ static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { res = analyzeComparison(app->exp1, app->exp2, env, ng); break; case LAMPRIMOP_TYPE_CMP: - res = analyzeStarship(app->exp1, app->exp2, env, ng); + res = analyzeSpaceship(app->exp1, app->exp2, env, ng); break; case LAMPRIMOP_TYPE_VEC: cant_happen("encountered VEC in analyzePrim"); @@ -382,12 +378,12 @@ static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { default: cant_happen("unrecognised type %d in analyzePrim", app->type); } - LEAVE(analyzePrim); + // LEAVE(analyzePrim); return res; } static TcType *analyzeUnary(LamUnaryApp *app, TcEnv *env, TcNg *ng) { - ENTER(analyzeUnary); + // ENTER(analyzeUnary); TcType *res = NULL; switch (app->type) { case LAMUNARYOP_TYPE_NEG: @@ -406,54 +402,44 @@ static TcType *analyzeUnary(LamUnaryApp *app, TcEnv *env, TcNg *ng) { default: cant_happen("unrecognized type %d in analyzeUnary", app->type); } - LEAVE(analyzeUnary); + // LEAVE(analyzeUnary); return res; } static TcType *analyzeSequence(LamSequence *sequence, TcEnv *env, TcNg *ng) { - ENTER(analyzeSequence); - IFDEBUG(ppLamSequence(sequence)); + // ENTER(analyzeSequence); if (sequence == NULL) { cant_happen("NULL sequence in analyzeSequence"); } TcType *type = analyzeExp(sequence->exp, env, ng); if (sequence->next != NULL) { TcType *res = analyzeSequence(sequence->next, env, ng); - LEAVE(analyzeSequence); + // LEAVE(analyzeSequence); return res; } - LEAVE(analyzeSequence); + // LEAVE(analyzeSequence); return type; } -static int countLamList(LamList *list) { - int i = 0; - while (list != NULL) { - i++; - list = list->next; - } - return i; -} - static LamApply *constructToApply(LamConstruct *construct) { - ENTER(constructToApply); + // ENTER(constructToApply); LamExp *constructor = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(construct->name)); int save = PROTECT(constructor); LamApply *apply = newLamApply(constructor, countLamList(construct->args), construct->args); UNPROTECT(save); - LEAVE(constructToApply); + // LEAVE(constructToApply); return apply; } static TcType *analyzeConstruct(LamConstruct *construct, TcEnv *env, TcNg *ng) { - ENTER(analyzeConstruct); + // ENTER(analyzeConstruct); LamApply *apply = constructToApply(construct); int save = PROTECT(apply); TcType *res = analyzeApply(apply, env, ng); UNPROTECT(save); - LEAVE(analyzeConstruct); + // LEAVE(analyzeConstruct); return res; } @@ -484,30 +470,27 @@ static TcType *findResultType(TcType *fn) { static TcType *analyzeDeconstruct(LamDeconstruct *deconstruct, TcEnv *env, TcNg *ng) { - ENTER(analyzeDeconstruct); - IFDEBUG(ppLamDeconstruct(deconstruct)); + // ENTER(analyzeDeconstruct); TcType *constructor = lookup(env, deconstruct->name, ng); int save = PROTECT(constructor); if (constructor == NULL) { can_happen("undefined type deconstructor %s", deconstruct->name->name); TcType *res = makeFreshVar(deconstruct->name->name); - LEAVE(analyzeDeconstruct); + // LEAVE(analyzeDeconstruct); return res; } TcType *fieldType = findNthArg(deconstruct->vec - 1, constructor); TcType *resultType = findResultType(constructor); TcType *expType = analyzeExp(deconstruct->exp, env, ng); PROTECT(expType); - if (!unify(expType, resultType)) { + if (!unify(expType, resultType, "deconstruct")) { eprintf("while unifying deconstruct:\n"); ppLamDeconstruct(deconstruct); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeDeconstruct); - IFDEBUG(ppTcType(fieldType)); - IFDEBUG(ppTcType(resultType)); + // LEAVE(analyzeDeconstruct); return fieldType; } @@ -516,15 +499,15 @@ static TcType *analyzeTag(LamExp *tagged, TcEnv *env, TcNg *ng) { } static TcType *analyzeConstant(LamConstant *constant, TcEnv *env, TcNg *ng) { - ENTER(analyzeConstant); + // ENTER(analyzeConstant); TcType *constType = lookup(env, constant->name, ng); if (constType == NULL) { can_happen("undefined constant %s", constant->name->name); TcType *res = makeFreshVar("err"); - LEAVE(analyzeConstant); + // LEAVE(analyzeConstant); return res; } - LEAVE(analyzeConstant); + // LEAVE(analyzeConstant); return constType; } @@ -553,30 +536,28 @@ static LamApply *curryLamApply(LamApply *apply) { } static TcType *analyzeApply(LamApply *apply, TcEnv *env, TcNg *ng) { - ENTER(analyzeApply); - IFDEBUG(ppLamApply(apply)); + // ENTER(analyzeApply); switch (apply->nargs) { case 0:{ - DEBUG("analyzeApply, nargs: 0"); TcType *res = analyzeExp(apply->function, env, ng); - LEAVE(analyzeApply); - IFDEBUG(ppLamApply(apply)); - IFDEBUG(ppTcType(res)); + // LEAVE(analyzeApply); return res; } case 1:{ - DEBUG("analyzeApply, nargs: 1"); + // fn :: #a -> #b TcType *fn = analyzeExp(apply->function, env, ng); int save = PROTECT(fn); - DEBUG("analyzeApply function is"); - IFDEBUG(ppTcType(fn)); + // arg :: #c TcType *arg = analyzeExp(apply->args->exp, env, ng); PROTECT(arg); + // res :: #d TcType *res = makeFreshVar("apply"); PROTECT(res); + // functionType :: #c -> #d TcType *functionType = makeFn(arg, res); PROTECT(functionType); - if (!unify(fn, functionType)) { + // unify(#a -> #b, #c -> #d) + if (!unify(fn, functionType, "apply")) { eprintf("while analyzing apply "); ppLamExp(apply->function); eprintf(" to "); @@ -584,33 +565,30 @@ static TcType *analyzeApply(LamApply *apply, TcEnv *env, TcNg *ng) { eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeApply); - IFDEBUG(ppLamApply(apply)); - IFDEBUG(ppTcType(res)); + // LEAVE(analyzeApply); + res = prune(res); + // #d/#b return res; } default:{ - DEBUG("analyzeApply, nargs: %d", apply->nargs); LamApply *curried = curryLamApply(apply); int save = PROTECT(curried); TcType *res = analyzeApply(curried, env, ng); UNPROTECT(save); - IFDEBUG(ppLamApply(apply)); - LEAVE(analyzeApply); - IFDEBUG(ppTcType(res)); + // LEAVE(analyzeApply); return res; } } } static TcType *analyzeIff(LamIff *iff, TcEnv *env, TcNg *ng) { - ENTER(analyzeIff); + // ENTER(analyzeIff); (void) analyzeBooleanExp(iff->condition, env, ng); TcType *consequent = analyzeExp(iff->consequent, env, ng); int save = PROTECT(consequent); TcType *alternative = analyzeExp(iff->alternative, env, ng); PROTECT(alternative); - if (!unify(consequent, alternative)) { + if (!unify(consequent, alternative, "iff")) { eprintf("while unifying consequent:\n"); ppLamExp(iff->consequent); eprintf("\nwith alternative:\n"); @@ -618,7 +596,7 @@ static TcType *analyzeIff(LamIff *iff, TcEnv *env, TcNg *ng) { eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeIff); + // LEAVE(analyzeIff); return consequent; } @@ -634,7 +612,7 @@ static TcType *analyzeCallCC(LamExp *called, TcEnv *env, TcNg *ng) { PROTECT(aba); TcType *calledType = analyzeExp(called, env, ng); PROTECT(calledType); - if (!unify(calledType, aba)) { + if (!unify(calledType, aba, "call/cc")) { eprintf("while unifying call/cc:\n"); ppLamExp(called); eprintf("\n"); @@ -645,10 +623,13 @@ static TcType *analyzeCallCC(LamExp *called, TcEnv *env, TcNg *ng) { static TcType *analyzePrint(LamPrint *print, TcEnv *env, TcNg *ng) { // a -> a, but installs a printer for type a + // ENTER(analyzePrint); TcType *type = analyzeExp(print->exp, env, ng); int save = PROTECT(type); print->printer = compilePrinterForType(type, env); UNPROTECT(save); + // LEAVE(analyzePrint); + IFDEBUG(ppTcType(type)); return type; } @@ -656,8 +637,34 @@ static bool isLambdaBinding(LamLetRecBindings *bindings) { return bindings->val->type == LAMEXP_TYPE_LAM; } +static void prepareLetRecEnv(LamLetRecBindings *bindings, TcEnv *env) { + TcType *freshType = makeFreshVar(bindings->var->name); + int save = PROTECT(freshType); + addToEnv(env, bindings->var, freshType); + UNPROTECT(save); +} + +static void processLetRecBinding(LamLetRecBindings *bindings, TcEnv *env, + TcNg *ng) { + TcType *existingType = NULL; + if (!getFromTcEnv(env, bindings->var, &existingType)) { + cant_happen("failed to retrieve fresh var from env in analyzeLetRec"); + } + int save = PROTECT(existingType); + // Recursive functions need to be statically typed inside their own context: + TcNg *ng2 = extendNg(ng); + PROTECT(ng2); + addToNg(ng2, existingType); + TcType *type = analyzeExp(bindings->val, env, ng2); + PROTECT(type); + unify(existingType, type, "letrec"); + DEBUGN("analyzeLetRec %s :: ", bindings->var->name); + IFDEBUGN(ppTcType(existingType)); + UNPROTECT(save); +} + static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) { - ENTER(analyzeLetRec); + // ENTER(analyzeLetRec); env = extendEnv(env); int save = PROTECT(env); ng = extendNg(ng); @@ -666,50 +673,37 @@ static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) { for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL; bindings = bindings->next) { if (isLambdaBinding(bindings)) { - TcType *freshVar = makeFreshVar(bindings->var->name); - int save2 = PROTECT(freshVar); - addToEnv(env, bindings->var, freshVar); - UNPROTECT(save2); + prepareLetRecEnv(bindings, env); } } for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL; bindings = bindings->next) { + DEBUGN("analyzeLetRec %s => ", bindings->var->name); + IFDEBUGN(ppLamExp(bindings->val)); if (!isLambdaBinding(bindings)) { - TcType *freshVar = makeFreshVar(bindings->var->name); - int save2 = PROTECT(freshVar); - addToEnv(env, bindings->var, freshVar); - UNPROTECT(save2); + prepareLetRecEnv(bindings, env); } - DEBUG("analyzeLetRec considering %s", bindings->var->name); - TcType *freshVar = NULL; - if (!getFromTcEnv(env, bindings->var, &freshVar)) { - cant_happen - ("failed to retrieve fresh var from env in analyzeLetRec"); + processLetRecBinding(bindings, env, ng); + } + // HACK! second pass through fixes up forward references + for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL; + bindings = bindings->next) { + if (isLambdaBinding(bindings)) { + processLetRecBinding(bindings, env, ng); } - int save2 = PROTECT(freshVar); - // Recursive functions need to be statically typed inside their own context: - TcNg *ng2 = extendNg(ng); - PROTECT(ng2); - addToNg(ng2, freshVar->val.var->name, freshVar); - TcType *type = analyzeExp(bindings->val, env, ng2); - PROTECT(type); - unify(freshVar, type); - DEBUG("analyzeLetRec binding %s, result:", bindings->var->name); - IFDEBUG(ppTcType(freshVar)); - UNPROTECT(save2); } TcType *res = analyzeExp(letRec->body, env, ng); UNPROTECT(save); - LEAVE(analyzeLetRec); + // LEAVE(analyzeLetRec); return res; } -static TcTypeDefArgs *makeTcTypeDefArgs(LamTypeArgs *lamTypeArgs, - TcTypeTable *map) { +static TcUserTypeArgs *makeTcUserTypeArgs(LamTypeArgs *lamTypeArgs, + TcTypeTable *map) { if (lamTypeArgs == NULL) { return NULL; } - TcTypeDefArgs *next = makeTcTypeDefArgs(lamTypeArgs->next, map); + TcUserTypeArgs *next = makeTcUserTypeArgs(lamTypeArgs->next, map); int save = PROTECT(next); TcType *name = NULL; if (!getTcTypeTable(map, lamTypeArgs->name, &name)) { @@ -718,26 +712,24 @@ static TcTypeDefArgs *makeTcTypeDefArgs(LamTypeArgs *lamTypeArgs, setTcTypeTable(map, lamTypeArgs->name, name); UNPROTECT(save2); } - TcTypeDefArgs *this = newTcTypeDefArgs(name, next); + TcUserTypeArgs *this = newTcUserTypeArgs(name, next); UNPROTECT(save); return this; } -static TcType *makeTypeDef(HashSymbol *name, TcTypeDefArgs *args) { - TcTypeDef *tcTypeDef = newTcTypeDef(name, args); - int save = PROTECT(tcTypeDef); +static TcType *makeUserType(HashSymbol *name, TcUserTypeArgs *args) { + TcUserType *tcUserType = newTcUserType(name, args); + int save = PROTECT(tcUserType); TcType *res = - newTcType(TCTYPE_TYPE_TYPEDEF, TCTYPE_VAL_TYPEDEF(tcTypeDef)); + newTcType(TCTYPE_TYPE_USERTYPE, TCTYPE_VAL_USERTYPE(tcUserType)); UNPROTECT(save); - DEBUG("makeTypeDef: %s %p", name->name, res); - IFDEBUG(ppTcTypeDef(tcTypeDef)); return res; } -static TcType *makeTcTypeDefType(LamType *lamType, TcTypeTable *map) { - TcTypeDefArgs *args = makeTcTypeDefArgs(lamType->args, map); +static TcType *makeTcUserType(LamType *lamType, TcTypeTable *map) { + TcUserTypeArgs *args = makeTcUserTypeArgs(lamType->args, map); int save = PROTECT(args); - TcType *res = makeTypeDef(lamType->name, args); + TcType *res = makeUserType(lamType->name, args); UNPROTECT(save); return res; } @@ -745,16 +737,16 @@ static TcType *makeTcTypeDefType(LamType *lamType, TcTypeTable *map) { static TcType *makeTypeConstructorArg(LamTypeConstructorType *arg, TcTypeTable *map); -static TcTypeDefArgs *makeTypeDefArgs(LamTypeConstructorArgs *args, - TcTypeTable *map) { +static TcUserTypeArgs *makeUserTypeArgs(LamTypeConstructorArgs *args, + TcTypeTable *map) { if (args == NULL) { return NULL; } - TcTypeDefArgs *next = makeTypeDefArgs(args->next, map); + TcUserTypeArgs *next = makeUserTypeArgs(args->next, map); int save = PROTECT(next); TcType *arg = makeTypeConstructorArg(args->arg, map); PROTECT(arg); - TcTypeDefArgs *this = newTcTypeDefArgs(arg, next); + TcUserTypeArgs *this = newTcUserTypeArgs(arg, next); UNPROTECT(save); return this; } @@ -763,9 +755,9 @@ static TcType *makeTypeConstructorApplication(LamTypeFunction *func, TcTypeTable *map) { // this code is building the inner application of a type, i.e. // list(t) in the context of t -> list(t) -> list(t) - TcTypeDefArgs *args = makeTypeDefArgs(func->args, map); + TcUserTypeArgs *args = makeUserTypeArgs(func->args, map); int save = PROTECT(args); - TcType *res = makeTypeDef(func->name, args); + TcType *res = makeUserType(func->name, args); UNPROTECT(save); return res; } @@ -828,7 +820,7 @@ static void collectTypeDef(LamTypeDef *lamTypeDef, TcEnv *env) { TcTypeTable *map = newTcTypeTable(); int save = PROTECT(map); LamType *lamType = lamTypeDef->type; - TcType *tcType = makeTcTypeDefType(lamType, map); + TcType *tcType = makeTcUserType(lamType, map); PROTECT(tcType); for (LamTypeConstructorList *list = lamTypeDef->constructors; list != NULL; list = list->next) { @@ -838,23 +830,21 @@ static void collectTypeDef(LamTypeDef *lamTypeDef, TcEnv *env) { } static TcType *analyzeTypeDefs(LamTypeDefs *typeDefs, TcEnv *env, TcNg *ng) { - DEBUG("***************************************"); - ENTER(analyzeTypeDefs); + // ENTER(analyzeTypeDefs); env = extendEnv(env); int save = PROTECT(env); - DEBUG("after extendEnv:"); for (LamTypeDefList *list = typeDefs->typeDefs; list != NULL; list = list->next) { collectTypeDef(list->typeDef, env); } TcType *res = analyzeExp(typeDefs->body, env, ng); UNPROTECT(save); - LEAVE(analyzeTypeDefs); + // LEAVE(analyzeTypeDefs); return res; } static TcType *analyzeLet(LamLet *let, TcEnv *env, TcNg *ng) { - ENTER(analyzeLet); + // ENTER(analyzeLet); // let expression is evaluated in the current environment TcType *valType = analyzeExp(let->value, env, ng); int save = PROTECT(valType); @@ -863,197 +853,197 @@ static TcType *analyzeLet(LamLet *let, TcEnv *env, TcNg *ng) { addToEnv(env, let->var, valType); TcType *res = analyzeExp(let->body, env, ng); UNPROTECT(save); - LEAVE(analyzeLet); + // LEAVE(analyzeLet); return res; } static TcType *analyzeMatchCases(LamMatchList *cases, TcEnv *env, TcNg *ng) { - ENTER(analyzeMatchCases); + // ENTER(analyzeMatchCases); if (cases == NULL) { TcType *res = makeFreshVar("matchCases"); - LEAVE(analyzeMatchCases); + // LEAVE(analyzeMatchCases); return res; } TcType *rest = analyzeMatchCases(cases->next, env, ng); int save = PROTECT(rest); TcType *this = analyzeExp(cases->body, env, ng); PROTECT(this); - if (!unify(this, rest)) { + if (!unify(this, rest, "match cases")) { eprintf("while unifying match cases:\n"); ppLamExp(cases->body); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeMatchCases); + // LEAVE(analyzeMatchCases); return this; } static TcType *analyzeBigIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeBigIntegerExp); + // ENTER(analyzeBigIntegerExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *integer = makeBigInteger(); PROTECT(integer); - if (!unify(type, integer)) { + if (!unify(type, integer, "big integer exp")) { eprintf("while analyzing bigint expr:\n"); ppLamExp(exp); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeBigIntegerExp); + // LEAVE(analyzeBigIntegerExp); return integer; } static TcType *analyzeSmallIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeSmallIntegerExp); + // ENTER(analyzeSmallIntegerExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *integer = makeSmallInteger(); PROTECT(integer); - if (!unify(type, integer)) { + if (!unify(type, integer, "small integer exp")) { eprintf("while analyzing smallint expr:\n"); ppLamExp(exp); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeSmallIntegerExp); + // LEAVE(analyzeSmallIntegerExp); return integer; } static TcType *analyzeBooleanExp(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeBooleanExp); + // ENTER(analyzeBooleanExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *boolean = makeBoolean(); PROTECT(boolean); - if (!unify(type, boolean)) { + if (!unify(type, boolean, "boolean exp")) { eprintf("while analyzing boolean expr:\n"); ppLamExp(exp); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeBooleanExp); + // LEAVE(analyzeBooleanExp); return boolean; } static TcType *analyzeCharacterExp(LamExp *exp, TcEnv *env, TcNg *ng) { - ENTER(analyzeCharacterExp); + // ENTER(analyzeCharacterExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *character = makeCharacter(); PROTECT(character); - if (!unify(type, character)) { + if (!unify(type, character, "character exp")) { eprintf("while analyzing character expr:\n"); ppLamExp(exp); eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeCharacterExp); + // LEAVE(analyzeCharacterExp); return character; } static TcType *lookupConstructorType(HashSymbol *name, TcEnv *env, TcNg *ng) { - ENTER(lookupConstructorType); + // ENTER(lookupConstructorType); TcType *res = lookup(env, name, ng); if (res == NULL) { cant_happen("lookupConstructorType %s failed", name->name); } res = findResultType(res); - LEAVE(lookupConstructorType); + // LEAVE(lookupConstructorType); return res; } static TcType *analyzeIntList(LamIntList *intList, TcEnv *env, TcNg *ng) { - ENTER(analyzeIntList); + // ENTER(analyzeIntList); if (intList == NULL) { - LEAVE(analyzeIntList); + // LEAVE(analyzeIntList); return makeFreshVar("intList"); } TcType *next = analyzeIntList(intList->next, env, ng); int save = PROTECT(next); TcType *this = lookupConstructorType(intList->name, env, ng); PROTECT(this); - if (!unify(next, this)) { + if (!unify(next, this, "int list")) { eprintf("while analyzing intList case %s\n", intList->name->name); } - LEAVE(analyzeIntList); + // LEAVE(analyzeIntList); UNPROTECT(save); return this; } static TcType *findCaseType(LamMatchList *matchList, TcEnv *env, TcNg *ng) { - ENTER(findCaseType); + // ENTER(findCaseType); if (matchList == NULL) { - LEAVE(findCaseType); + // LEAVE(findCaseType); return makeFreshVar("caseType"); } TcType *next = findCaseType(matchList->next, env, ng); int save = PROTECT(next); TcType *this = analyzeIntList(matchList->matches, env, ng); PROTECT(this); - if (!unify(this, next)) { + if (!unify(this, next, "find case type")) { eprintf("while finding case type\n"); } UNPROTECT(save); - LEAVE(findCaseType); + // LEAVE(findCaseType); return this; } static TcType *analyzeMatch(LamMatch *match, TcEnv *env, TcNg *ng) { - ENTER(analyzeMatch); + // ENTER(analyzeMatch); TcType *caseType = findCaseType(match->cases, env, ng); int save = PROTECT(caseType); TcType *indexType = analyzeExp(match->index, env, ng); PROTECT(indexType); - if (!unify(caseType, indexType)) { + if (!unify(caseType, indexType, "match")) { eprintf("while analyzing match\n"); } TcType *res = analyzeMatchCases(match->cases, env, ng); - LEAVE(analyzeMatch); + // LEAVE(analyzeMatch); UNPROTECT(save); return res; } static TcType *analyzeIntCondCases(LamIntCondCases *cases, TcEnv *env, TcNg *ng) { - ENTER(analyzeIntCondCases); + // ENTER(analyzeIntCondCases); if (cases == NULL) { - LEAVE(analyzeIntCondCases); + // LEAVE(analyzeIntCondCases); return makeFreshVar("intCondCases"); } TcType *rest = analyzeIntCondCases(cases->next, env, ng); int save = PROTECT(rest); TcType *this = analyzeExp(cases->body, env, ng); PROTECT(this); - if (!unify(this, rest)) { + if (!unify(this, rest, "cond cases")) { eprintf("while analyzing int cond cases\n"); } UNPROTECT(save); - LEAVE(analyzeIntCondCases); + // LEAVE(analyzeIntCondCases); return this; } static TcType *analyzeCharCondCases(LamCharCondCases *cases, TcEnv *env, TcNg *ng) { - ENTER(analyzeCharCondCases); + // ENTER(analyzeCharCondCases); if (cases == NULL) { - LEAVE(analyzeCharCondCases); + // LEAVE(analyzeCharCondCases); return makeFreshVar("charCondCases"); } TcType *rest = analyzeCharCondCases(cases->next, env, ng); int save = PROTECT(rest); TcType *this = analyzeExp(cases->body, env, ng); PROTECT(this); - if (!unify(this, rest)) { + if (!unify(this, rest, "char cond cases")) { eprintf("while analyzing char cond cases\n"); } UNPROTECT(save); - LEAVE(analyzeCharCondCases); + // LEAVE(analyzeCharCondCases); return this; } static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng) { - ENTER(analyzeCond); + // ENTER(analyzeCond); TcType *result = NULL; int save = PROTECT(result); TcType *value = analyzeExp(cond->value, env, ng); @@ -1062,7 +1052,7 @@ static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng) { case LAMCONDCASES_TYPE_INTEGERS:{ TcType *integer = makeBigInteger(); PROTECT(integer); - if (!unify(value, integer)) { + if (!unify(value, integer, "cond[1]")) { eprintf("while analyzing integer cond:\n"); ppLamExp(cond->value); eprintf("\n"); @@ -1074,7 +1064,7 @@ static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng) { case LAMCONDCASES_TYPE_CHARACTERS:{ TcType *character = makeCharacter(); PROTECT(character); - if (!unify(value, character)) { + if (!unify(value, character, "cond[2]")) { eprintf("while analyzing character cond:\n"); ppLamExp(cond->value); eprintf("\n"); @@ -1089,31 +1079,31 @@ static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng) { cond->cases->type); } UNPROTECT(save); - LEAVE(analyzeCond); + // LEAVE(analyzeCond); return result; } static TcType *analyzeAnd(LamAnd *and, TcEnv *env, TcNg *ng) { - ENTER(analyzeAnd); + // ENTER(analyzeAnd); TcType *res = analyzeBinaryBool(and->left, and->right, env, ng); - LEAVE(analyzeAnd); + // LEAVE(analyzeAnd); return res; } static TcType *analyzeOr(LamOr *or, TcEnv *env, TcNg *ng) { - ENTER(analyzeOr); + // ENTER(analyzeOr); TcType *res = analyzeBinaryBool(or->left, or->right, env, ng); - LEAVE(analyzeOr); + // LEAVE(analyzeOr); return res; } static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng) { - ENTER(analyzeAmb); + // ENTER(analyzeAmb); TcType *left = analyzeExp(amb->left, env, ng); int save = PROTECT(left); TcType *right = analyzeExp(amb->right, env, ng); PROTECT(right); - if (!unify(left, right)) { + if (!unify(left, right, "amb")) { eprintf("while unifying amb:\n"); ppLamExp(amb->left); eprintf("\nwith:\n"); @@ -1121,34 +1111,32 @@ static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng) { eprintf("\n"); } UNPROTECT(save); - LEAVE(analyzeAmb); + // LEAVE(analyzeAmb); return left; } static TcType *analyzeCharacter() { - ENTER(analyzeCharacter); + // ENTER(analyzeCharacter); TcType *res = makeCharacter(); - LEAVE(analyzeCharacter); + // LEAVE(analyzeCharacter); return res; } static TcType *analyzeBack() { - ENTER(analyzeBack); + // ENTER(analyzeBack); TcType *res = makeFreshVar("back"); - LEAVE(analyzeBack); + // LEAVE(analyzeBack); return res; } static TcType *analyzeError() { - ENTER(analyzeError); + // ENTER(analyzeError); TcType *res = makeFreshVar("error"); - LEAVE(analyzeError); + // LEAVE(analyzeError); return res; } static void addToEnv(TcEnv *env, HashSymbol *symbol, TcType *type) { - DEBUG("addToEnv %s =>", symbol->name); - IFDEBUG(ppTcType(type)); setTcTypeTable(env->table, symbol, type); } @@ -1177,7 +1165,6 @@ static TcType *makePair(TcType *first, TcType *second) { int save = PROTECT(resPair); TcType *res = newTcType(TCTYPE_TYPE_PAIR, TCTYPE_VAL_PAIR(resPair)); UNPROTECT(save); - DEBUG("makePair: %p", res); return res; } @@ -1191,50 +1178,39 @@ static TcType *freshPair(TcPair *pair, TcNg *ng, TcTypeTable *map) { return res; } -static TcTypeDefArgs *freshTypeDefArgs(TcTypeDefArgs *args, TcNg *ng, - TcTypeTable *map) { +static TcUserTypeArgs *freshUserTypeArgs(TcUserTypeArgs *args, TcNg *ng, + TcTypeTable *map) { if (args == NULL) return NULL; - TcTypeDefArgs *next = freshTypeDefArgs(args->next, ng, map); + TcUserTypeArgs *next = freshUserTypeArgs(args->next, ng, map); int save = PROTECT(next); TcType *type = freshRec(args->type, ng, map); PROTECT(type); - TcTypeDefArgs *this = newTcTypeDefArgs(type, next); + TcUserTypeArgs *this = newTcUserTypeArgs(type, next); UNPROTECT(save); return this; } -static TcType *freshTypeDef(TcTypeDef *typeDef, TcNg *ng, TcTypeTable *map) { - ENTER(freshTypeDef); - TcTypeDefArgs *args = freshTypeDefArgs(typeDef->args, ng, map); +static TcType *freshUserType(TcUserType *userType, TcNg *ng, TcTypeTable *map) { + TcUserTypeArgs *args = freshUserTypeArgs(userType->args, ng, map); int save = PROTECT(args); - TcType *res = makeTypeDef(typeDef->name, args); + TcType *res = makeUserType(userType->name, args); UNPROTECT(save); - LEAVE(freshTypeDef); - IFDEBUG(ppTcTypeDef(typeDef)); - IFDEBUG(ppTcType(res)); return res; } static bool isGeneric(TcType *typeVar, TcNg *ng) { - ENTER(isGeneric); - IFDEBUG(ppTcType(typeVar)); - IFDEBUG(printTcNg(ng, 0)); while (ng != NULL) { int i = 0; TcType *entry = NULL; HashSymbol *s = NULL; while ((s = iterateTcTypeTable(ng->table, &i, &entry)) != NULL) { if (occursInType(typeVar, entry)) { - LEAVE(isGeneric); - DEBUG("false"); return false; } } ng = ng->next; } - LEAVE(isGeneric); - DEBUG("true"); return true; } @@ -1261,9 +1237,9 @@ static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map) { } case TCTYPE_TYPE_VAR: if (isGeneric(type, ng)) { - TcType *freshVar = makeFreshVar(type->val.var->name->name); - int save = PROTECT(freshVar); - TcType *res = typeGetOrPut(map, type, freshVar); + TcType *freshType = makeFreshVar(type->val.var->name->name); + int save = PROTECT(freshType); + TcType *res = typeGetOrPut(map, type, freshType); UNPROTECT(save); return res; } @@ -1271,9 +1247,10 @@ static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map) { case TCTYPE_TYPE_SMALLINTEGER: case TCTYPE_TYPE_BIGINTEGER: case TCTYPE_TYPE_CHARACTER: + case TCTYPE_TYPE_UNKNOWN: return type; - case TCTYPE_TYPE_TYPEDEF:{ - TcType *res = freshTypeDef(type->val.typeDef, ng, map); + case TCTYPE_TYPE_USERTYPE:{ + TcType *res = freshUserType(type->val.userType, ng, map); return res; } default: @@ -1282,55 +1259,57 @@ static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map) { } static TcType *fresh(TcType *type, TcNg *ng) { - ENTER(fresh); - IFDEBUG(ppTcType(type)); + // ENTER(fresh); TcTypeTable *map = newTcTypeTable(); int save = PROTECT(map); TcType *res = freshRec(type, ng, map); UNPROTECT(save); - LEAVE(fresh); - IFDEBUG(ppTcType(res)); + // LEAVE(fresh); return res; } static TcType *lookup(TcEnv *env, HashSymbol *symbol, TcNg *ng) { - ENTER(lookup); - DEBUG("lookup: %s", symbol->name); + // ENTER(lookup); TcType *type = NULL; if (getFromTcEnv(env, symbol, &type)) { TcType *res = fresh(type, ng); - LEAVE(lookup); - IFDEBUG(ppTcType(res)); + // LEAVE(lookup); + DEBUGN("lookup %s => ", symbol->name); + IFDEBUGN(ppTcType(res)); return res; } - LEAVE(lookup); - DEBUG("NULL"); + // LEAVE(lookup); + DEBUG("lookup %s => NULL", symbol->name); return NULL; } -static void addToNg(TcNg *ng, HashSymbol *symbol, TcType *type) { - DEBUG("addToNg %s =>", symbol->name); - IFDEBUG(ppTcType(type)); - setTcTypeTable(ng->table, symbol, type); +static void addToNg(TcNg *ng, TcType *type) { +#ifdef SAFETY_CHECKS + if (type->type != TCTYPE_TYPE_VAR) { + cant_happen("non-var type passed to addToNg"); + } +#endif + setTcTypeTable(ng->table, type->val.var->name, type); } static TcType *makeBoolean() { - TcType *res = makeTypeDef(boolSymbol(), NULL); + TcType *res = makeUserType(boolSymbol(), NULL); return res; } -static TcType *makeStarship() { - TcType *res = makeTypeDef(starshipSymbol(), NULL); +static TcType *makeSpaceship() { + TcType *res = makeUserType(spaceshipSymbol(), NULL); return res; } static TcType *makeFn(TcType *arg, TcType *result) { + arg = prune(arg); + result = prune(result); TcFunction *fn = newTcFunction(arg, result); int save = PROTECT(fn); assert(fn != NULL); TcType *type = newTcType(TCTYPE_TYPE_FUNCTION, TCTYPE_VAL_FUNCTION(fn)); UNPROTECT(save); - DEBUG("makeFunction: %p", type); return type; } @@ -1349,32 +1328,31 @@ static TcType *makeVar(HashSymbol *t) { int save = PROTECT(var); TcType *res = newTcType(TCTYPE_TYPE_VAR, TCTYPE_VAL_VAR(var)); UNPROTECT(save); - DEBUG("makeVar %s %p", t->name, res); return res; } -static TcType *makeFreshVar(char *name) { - static char buff[256]; - snprintf(buff, 256, "%s/", name); - return makeVar(genSym(buff)); +static TcType *makeFreshVar(char *name __attribute__((unused))) { + return makeVar(genAlphaSym("#")); } static TcType *makeSmallInteger() { TcType *res = newTcType(TCTYPE_TYPE_SMALLINTEGER, TCTYPE_VAL_SMALLINTEGER()); - DEBUG("makeSmallInteger %p", res); return res; } static TcType *makeBigInteger() { TcType *res = newTcType(TCTYPE_TYPE_BIGINTEGER, TCTYPE_VAL_BIGINTEGER()); - DEBUG("makeBigInteger %p", res); + return res; +} + +static TcType *makeUnknown(HashSymbol *var) { + TcType *res = newTcType(TCTYPE_TYPE_UNKNOWN, TCTYPE_VAL_UNKNOWN(var)); return res; } static TcType *makeCharacter() { TcType *res = newTcType(TCTYPE_TYPE_CHARACTER, TCTYPE_VAL_CHARACTER()); - DEBUG("makeCharacter %p", res); return res; } @@ -1440,13 +1418,13 @@ static void addHereToEnv(TcEnv *env) { static void addCmpToEnv(TcEnv *env, HashSymbol *symbol) { // all binary comparisons are a -> a -> bool - TcType *freshVar = makeFreshVar(symbol->name); - int save = PROTECT(freshVar); + TcType *freshType = makeFreshVar(symbol->name); + int save = PROTECT(freshType); TcType *boolean = makeBoolean(); (void) PROTECT(boolean); - TcType *unOp = makeFn(freshVar, boolean); + TcType *unOp = makeFn(freshType, boolean); (void) PROTECT(unOp); - TcType *binOp = makeFn(freshVar, unOp); + TcType *binOp = makeFn(freshType, unOp); (void) PROTECT(binOp); addToEnv(env, symbol, binOp); UNPROTECT(save); @@ -1454,9 +1432,9 @@ static void addCmpToEnv(TcEnv *env, HashSymbol *symbol) { static void addFreshVarToEnv(TcEnv *env, HashSymbol *symbol) { // 'error' and 'back' both have unconstrained types - TcType *freshVar = makeFreshVar(symbol->name); - int save = PROTECT(freshVar); - addToEnv(env, symbol, freshVar); + TcType *freshType = makeFreshVar(symbol->name); + int save = PROTECT(freshType); + addToEnv(env, symbol, freshType); UNPROTECT(save); } @@ -1488,35 +1466,37 @@ static void addBoolBinOpToEnv(TcEnv *env, HashSymbol *symbol) { static void addThenToEnv(TcEnv *env) { // a -> a -> a - TcType *freshVar = makeFreshVar("then"); - int save = PROTECT(freshVar); - addBinOpToEnv(env, thenSymbol(), freshVar); + TcType *freshType = makeFreshVar("then"); + int save = PROTECT(freshType); + addBinOpToEnv(env, thenSymbol(), freshType); UNPROTECT(save); } static bool unifyFunctions(TcFunction *a, TcFunction *b) { - bool res = unify(a->arg, b->arg) && unify(a->result, b->result); + bool res = unify(a->arg, b->arg, "functions[arg]") + && unify(a->result, b->result, "functions[result]"); return res; } static bool unifyPairs(TcPair *a, TcPair *b) { - bool res = unify(a->first, b->first) && unify(a->second, b->second); + bool res = unify(a->first, b->first, "pairs[first]") + && unify(a->second, b->second, "pairs[second]"); return res; } -static bool unifyTypeDefs(TcTypeDef *a, TcTypeDef *b) { +static bool unifyUserTypes(TcUserType *a, TcUserType *b) { if (a->name != b->name) { can_happen("unification failed[1]"); - ppTcTypeDef(a); + ppTcUserType(a); eprintf(" vs "); - ppTcTypeDef(b); + ppTcUserType(b); eprintf("\n"); return false; } - TcTypeDefArgs *aArgs = a->args; - TcTypeDefArgs *bArgs = b->args; + TcUserTypeArgs *aArgs = a->args; + TcUserTypeArgs *bArgs = b->args; while (aArgs != NULL && bArgs != NULL) { - if (!unify(aArgs->type, bArgs->type)) { + if (!unify(aArgs->type, bArgs->type, "user types")) { return false; } aArgs = aArgs->next; @@ -1524,43 +1504,38 @@ static bool unifyTypeDefs(TcTypeDef *a, TcTypeDef *b) { } if (aArgs != NULL || bArgs != NULL) { can_happen("unification failed[2]"); - ppTcTypeDef(a); + ppTcUserType(a); eprintf(" vs "); - ppTcTypeDef(b); + ppTcUserType(b); eprintf("\n"); return false; } return true; } -static bool unify(TcType *a, TcType *b) { +static bool _unify(TcType *a, TcType *b) { a = prune(a); b = prune(b); - DEBUG("UNIFY"); - IFDEBUG(ppTcType(a); - eprintf(" WITH "); - ppTcType(b)); - if (a == b) + if (a == b) { + if (a->type == TCTYPE_TYPE_UNKNOWN) + return false; return true; + } if (a->type == TCTYPE_TYPE_VAR) { if (b->type != TCTYPE_TYPE_VAR) { if (occursInType(a, b)) { can_happen("occurs-in check failed"); return false; } - DEBUG("unify combining"); a->val.var->instance = b; - IFDEBUG(ppTcType(a)); return true; } if (a->val.var->name != b->val.var->name) { - DEBUG("unify combining"); a->val.var->instance = b; - IFDEBUG(ppTcType(a)); } return true; } else if (b->type == TCTYPE_TYPE_VAR) { - return unify(b, a); + return unify(b, a, "unify"); } else { if (a->type != b->type) { can_happen("unification failed[3]"); @@ -1581,8 +1556,10 @@ static bool unify(TcType *a, TcType *b) { case TCTYPE_TYPE_BIGINTEGER: case TCTYPE_TYPE_CHARACTER: return true; - case TCTYPE_TYPE_TYPEDEF: - return unifyTypeDefs(a->val.typeDef, b->val.typeDef); + case TCTYPE_TYPE_UNKNOWN: + return false; + case TCTYPE_TYPE_USERTYPE: + return unifyUserTypes(a->val.userType, b->val.userType); default: cant_happen("unrecognised type %d in unify", a->type); } @@ -1590,7 +1567,18 @@ static bool unify(TcType *a, TcType *b) { cant_happen("reached end of unify"); } -static void pruneTypeDefArgs(TcTypeDefArgs *args) { +static bool unify(TcType *a, TcType *b, char *trace __attribute__((unused))) { + // *INDENT-OFF* + DEBUGN("unify(%s) :> ", trace); + IFDEBUGN(ppTcType(a); eprintf(" =?= "); ppTcType(b)); + bool res = _unify(a, b); + DEBUGN("unify(%s) <: ", trace); + IFDEBUGN(ppTcType(a); eprintf(" === "); ppTcType(b)); + return res; + // *INDENT-ON* +} + +static void pruneUserTypeArgs(TcUserTypeArgs *args) { while (args != NULL) { args->type = prune(args->type); args = args->next; @@ -1605,8 +1593,8 @@ static TcType *prune(TcType *t) { t->val.var->instance = prune(t->val.var->instance); return t->val.var->instance; } - } else if (t->type == TCTYPE_TYPE_TYPEDEF) { - pruneTypeDefArgs(t->val.typeDef->args); + } else if (t->type == TCTYPE_TYPE_USERTYPE) { + pruneUserTypeArgs(t->val.userType->args); } else if (t->type == TCTYPE_TYPE_FUNCTION) { t->val.function->arg = prune(t->val.function->arg); t->val.function->result = prune(t->val.function->result); @@ -1622,12 +1610,12 @@ static bool samePairType(TcPair *a, TcPair *b) { return sameType(a->first, b->first) && sameType(a->second, b->second); } -static bool sameTypeDefType(TcTypeDef *a, TcTypeDef *b) { +static bool sameUserType(TcUserType *a, TcUserType *b) { if (a->name != b->name) { return false; } - TcTypeDefArgs *aArgs = a->args; - TcTypeDefArgs *bArgs = b->args; + TcUserTypeArgs *aArgs = a->args; + TcUserTypeArgs *bArgs = b->args; while (aArgs != NULL && bArgs != NULL) { if (!sameType(aArgs->type, bArgs->type)) return false; @@ -1660,8 +1648,10 @@ static bool sameType(TcType *a, TcType *b) { case TCTYPE_TYPE_SMALLINTEGER: case TCTYPE_TYPE_CHARACTER: return true; - case TCTYPE_TYPE_TYPEDEF: - return sameTypeDefType(a->val.typeDef, b->val.typeDef); + case TCTYPE_TYPE_UNKNOWN: + return false; + case TCTYPE_TYPE_USERTYPE: + return sameUserType(a->val.userType, b->val.userType); default: cant_happen("unrecognised type %d in sameType", a->type); } @@ -1685,8 +1675,9 @@ static bool occursInPair(TcType *var, TcPair *pair) { return occursInType(var, pair->first) || occursInType(var, pair->second); } -static bool occursInTypeDef(TcType *var, TcTypeDef *typeDef) { - for (TcTypeDefArgs *args = typeDef->args; args != NULL; args = args->next) { +static bool occursInUserType(TcType *var, TcUserType *userType) { + for (TcUserTypeArgs *args = userType->args; args != NULL; + args = args->next) { if (occursInType(var, args->type)) return true; } @@ -1704,9 +1695,10 @@ static bool occursIn(TcType *a, TcType *b) { case TCTYPE_TYPE_SMALLINTEGER: case TCTYPE_TYPE_BIGINTEGER: case TCTYPE_TYPE_CHARACTER: + case TCTYPE_TYPE_UNKNOWN: return false; - case TCTYPE_TYPE_TYPEDEF: - return occursInTypeDef(a, b->val.typeDef); + case TCTYPE_TYPE_USERTYPE: + return occursInUserType(a, b->val.userType); default: cant_happen("unrecognised type %d in occursIn", b->type); } diff --git a/src/tc_analyze.h b/src/tc_analyze.h index fd6c0c4..c96270f 100644 --- a/src/tc_analyze.h +++ b/src/tc_analyze.h @@ -1,5 +1,5 @@ #ifndef cekf_tc_analyze_h -# define cekf_tc_analyze_h +# define cekf_tc_analyze_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "tc.h" -# include "lambda.h" +# include "tc.h" +# include "lambda.h" TcEnv *tc_init(void); TcType *tc_analyze(LamExp *exp, TcEnv *env); diff --git a/src/tc_helper.c b/src/tc_helper.c index 1e296a4..4c5c2ba 100644 --- a/src/tc_helper.c +++ b/src/tc_helper.c @@ -43,11 +43,14 @@ void ppTcType(TcType *type) { case TCTYPE_TYPE_CHARACTER: eprintf("char"); break; - case TCTYPE_TYPE_TYPEDEF: - ppTcTypeDef(type->val.typeDef); + case TCTYPE_TYPE_UNKNOWN: + eprintf("unknown:%s", type->val.unknown->name); + break; + case TCTYPE_TYPE_USERTYPE: + ppTcUserType(type->val.userType); break; default: - cant_happen("unrecognized type %d in ppTcType", type->type); + eprintf("unrecognized type %d", type->type); } } @@ -67,7 +70,7 @@ void ppTcPair(TcPair *pair) { } void ppTcVar(TcVar *var) { - eprintf("<%s>%d", var->name->name, var->id); + eprintf("%s", var->name->name); if (var->instance != NULL) { eprintf(" ["); ppTcType(var->instance); @@ -75,7 +78,7 @@ void ppTcVar(TcVar *var) { } } -static void ppTypeDefArgs(TcTypeDefArgs *args) { +static void ppUserTypeArgs(TcUserTypeArgs *args) { while (args != NULL) { ppTcType(args->type); if (args->next) @@ -84,9 +87,9 @@ static void ppTypeDefArgs(TcTypeDefArgs *args) { } } -void ppTcTypeDef(TcTypeDef *typeDef) { - eprintf("%s(", typeDef->name->name); - ppTypeDefArgs(typeDef->args); +void ppTcUserType(TcUserType *userType) { + eprintf("%s(", userType->name->name); + ppUserTypeArgs(userType->args); eprintf(")"); } diff --git a/src/tc_helper.h b/src/tc_helper.h index ad5b990..586288c 100644 --- a/src/tc_helper.h +++ b/src/tc_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_tc_helper_h -# define cekf_tc_helper_h +# define cekf_tc_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,14 +18,14 @@ * along with this program. If not, see . */ -# include "ast_helper.h" -# include "tc.h" +# include "ast_helper.h" +# include "tc.h" void ppTcType(TcType *type); void ppTcFunction(TcFunction *function); void ppTcPair(TcPair *pair); void ppTcVar(TcVar *var); -void ppTcTypeDef(TcTypeDef *typeDef); +void ppTcUserType(TcUserType *userType); bool getFromTcEnv(TcEnv *env, HashSymbol *symbol, TcType **type); #endif diff --git a/src/tpmc.yaml b/src/tpmc.yaml index 5117e41..107dde7 100644 --- a/src/tpmc.yaml +++ b/src/tpmc.yaml @@ -135,21 +135,9 @@ arrays: dimension: 2 entries: TpmcPattern -enums: {} - -primitives: - HashTable: - cname: "HashTable *" - printFn: "printHashTable" - markFn: "markHashTable" - valued: true - - HashSymbol: - cname: "HashSymbol *" - printFn: "printAstSymbol" - markFn: "markHashSymbol" - valued: true +primitives: !include primitives.yaml +external: LamExp: cname: "LamExp *" printFn: ppLamExpD @@ -157,12 +145,6 @@ primitives: copyFn: copyLamExp valued: true - BigInt: - cname: "BigInt *" - printFn: "printBigInt" - markFn: "markBigInt" - valued: true - LamTypeConstructorInfo: cname: "LamTypeConstructorInfo *" printFn: printLamTypeConstructorInfo @@ -170,27 +152,3 @@ primitives: copyFn: copyLamTypeConstructorInfo valued: true - int: - cname: "int" - printf: "%d" - valued: true - - bool: - cname: bool - printf: "%d" - valued: true - - string: - cname: "char *" - printf: "%s" - valued: true - - char: - cname: "char" - printf: "'%c'" - valued: true - - void_ptr: - cname: "void *" - printf: "%p" - valued: false diff --git a/src/tpmc_compare.c b/src/tpmc_compare.c index 1d78f26..03558ee 100644 --- a/src/tpmc_compare.c +++ b/src/tpmc_compare.c @@ -18,6 +18,8 @@ * Term Pattern Matching Compiler logic */ +// TODO should be able to get rid of this now we auto-generate comparison functions + #include "tpmc_compare.h" #define PREAMBLE() do {\ diff --git a/src/tpmc_compare.h b/src/tpmc_compare.h index 3f4b0b1..ab24f23 100644 --- a/src/tpmc_compare.h +++ b/src/tpmc_compare.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_compare_h -# define cekf_tpmc_compare_h +# define cekf_tpmc_compare_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -20,8 +20,8 @@ * Term Pattern Matching Compiler logic */ -# include -# include "tpmc.h" +# include +# include "tpmc.h" bool tpmcStateEq(TpmcState *a, TpmcState *b); bool tpmcStateValueEq(TpmcStateValue *a, TpmcStateValue *b); diff --git a/src/tpmc_helper.h b/src/tpmc_helper.h index bc7231f..579efbb 100644 --- a/src/tpmc_helper.h +++ b/src/tpmc_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_helper_h -# define cekf_tpmc_helper_h +# define cekf_tpmc_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "ast_helper.h" -# include "tpmc.h" -# include "hash.h" -# include "memory.h" +# include "ast_helper.h" +# include "tpmc.h" +# include "hash.h" +# include "memory.h" #endif diff --git a/src/tpmc_logic.c b/src/tpmc_logic.c index 9c0b819..cf87575 100644 --- a/src/tpmc_logic.c +++ b/src/tpmc_logic.c @@ -19,6 +19,7 @@ */ #include +#include #include "common.h" #include "tpmc_logic.h" #include "tpmc_translate.h" @@ -30,22 +31,27 @@ #include "memory.h" #include "lambda_substitution.h" #include "lambda_pp.h" +#include "tpmc_mermaid.h" +#include "tpmc_pp.h" #ifdef DEBUG_TPMC_LOGIC -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static TpmcPattern *convertPattern(AstArg *arg, LamContext *env); static TpmcVariableArray *createRootVariables(int nargs) { + ENTER(createRootVariables); TpmcVariableArray *rootVariables = newTpmcVariableArray(); int p = PROTECT(rootVariables); for (int i = 0; i < nargs; i++) { HashSymbol *s = genSym("p$"); + IFDEBUG(eprintf("%s", s->name)); pushTpmcVariableArray(rootVariables, s); } UNPROTECT(p); + LEAVE(createRootVariables); return rootVariables; } @@ -241,6 +247,7 @@ static void renameConstructorPattern(TpmcConstructorPattern *pattern, if (snprintf(buf, 512, "%s$%d", path->name, i) >= 511) { can_happen("maximum path depth exceeded"); } + DEBUG("renameConstructorPattern: %s", buf); HashSymbol *newPath = newSymbol(buf); renamePattern(components->entries[i], newPath); } @@ -362,7 +369,7 @@ static TpmcPattern *replaceComparisonPattern(TpmcPattern *pattern, return replaceConstructorPattern(pattern, seen); case TPMCPATTERNVALUE_TYPE_COMPARISON: cant_happen - ("encounterted comparison pattern during replaceComparisonPattern"); + ("encounterted nested comparison pattern during replaceComparisonPattern"); default: cant_happen("unrecognised pattern type in renamePattern"); } @@ -405,8 +412,8 @@ static TpmcPattern *collectAssignmentSubstitutions(TpmcPattern *pattern, TpmcSub pattern->pattern->val.assignment->name, pattern->path); // we no longer need to remember this is an assignment now we have the substitution - return collectPatternSubstitutions(pattern->pattern->val.assignment-> - value, substitutions); + TpmcPattern *value = pattern->pattern->val.assignment->value; + return collectPatternSubstitutions(value, substitutions); } static TpmcPattern *collectConstructorSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable @@ -423,9 +430,9 @@ static TpmcPattern *collectConstructorSubstitutions(TpmcPattern *pattern, TpmcSu static TpmcPattern *collectComparisonSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable *substitutions) { + TpmcPattern *previous = pattern->pattern->val.comparison->previous; pattern->pattern->val.comparison->previous = - collectPatternSubstitutions(pattern->pattern->val.comparison-> - previous, substitutions); + collectPatternSubstitutions(previous, substitutions); pattern->pattern->val.comparison->current = collectPatternSubstitutions(pattern->pattern->val.comparison->current, substitutions); @@ -557,12 +564,12 @@ LamLam *tpmcConvert(int nargs, int nbodies, AstArgList **argLists, replaceComparisonRules(input); renameRules(input); performRulesSubstitutions(input); - DEBUG("*** RULES ***"); - IFDEBUG(printTpmcMatchRules(input, 0)); + // DEBUG("*** RULES ***"); + // IFDEBUG(printTpmcMatchRules(input, 0)); TpmcMatrix *matrix = convertToMatrix(input); PROTECT(matrix); DEBUG("*** MATRIX ***"); - IFDEBUG(printTpmcMatrix(matrix, 0)); + IFDEBUG(ppTpmcMatrix(matrix)); TpmcStateArray *finalStates = extractFinalStates(input); PROTECT(finalStates); TpmcStateArray *knownStates = newTpmcStateArray("tpmcConvert"); @@ -574,11 +581,12 @@ LamLam *tpmcConvert(int nargs, int nbodies, AstArgList **argLists, PROTECT(errorState); TpmcState *dfa = tpmcMatch(matrix, finalStates, errorState, knownStates); PROTECT(dfa); - DEBUG("*** DFA ***"); - IFDEBUG(printTpmcState(dfa, 0)); + // DEBUG("*** DFA ***"); + // IFDEBUG(printTpmcState(dfa, 0)); + tpmcMermaid(dfa); LamExp *body = tpmcTranslate(dfa); PROTECT(body); - DEBUG("tpmcTranslate returned %p", body); + // DEBUG("tpmcTranslate returned %p", body); LamVarList *args = arrayToVarList(rootVariables); PROTECT(args); LamLam *res = newLamLam(rootVariables->size, args, body); diff --git a/src/tpmc_logic.h b/src/tpmc_logic.h index 11caec5..e47f535 100644 --- a/src/tpmc_logic.h +++ b/src/tpmc_logic.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_logic_h -# define cekf_tpmc_logic_h +# define cekf_tpmc_logic_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "lambda.h" +# include "ast.h" +# include "lambda.h" LamLam *tpmcConvert(int nargs, int nbodies, AstArgList **argList, LamExp **actions, LamContext *env); diff --git a/src/tpmc_match.c b/src/tpmc_match.c index c636404..e27f7a9 100644 --- a/src/tpmc_match.c +++ b/src/tpmc_match.c @@ -20,45 +20,45 @@ #include #include +#include #include "common.h" #include "tpmc_match.h" #include "tpmc_compare.h" #include "tpmc_debug.h" +#include "tpmc_pp.h" #include "lambda_debug.h" #include "lambda_helper.h" #include "symbol.h" #ifdef DEBUG_TPMC_MATCH -# include "debugging_on.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif +static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates); + +TpmcState *tpmcMatch(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates) { +#ifdef DEBUG_TPMC_MATCH + system("clear"); +#endif + return match(matrix, finalStates, errorState, knownStates); +} + TpmcState *tpmcMakeState(TpmcStateValue *val) { static int counter = 0; return newTpmcState(counter++, val); } -// this is definately a wildcard -// TPMCPATTERNVALUE_TYPE_WILDCARD -// -// TPMCPATTERNVALUE_TYPE_COMPARISON -// -// these are all constructors: -// TPMCPATTERNVALUE_TYPE_CHARACTER -// TPMCPATTERNVALUE_TYPE_INTEGER -// TPMCPATTERNVALUE_TYPE_CONSTRUCTOR - -static bool patternIsWildcard(TpmcMatrix *m, int x, int y) { - TpmcPatternValueType type = getTpmcMatrixIndex(m, x, y)->pattern->type; - DEBUG("patternIsWildcard x = %d, y = %d, type = %d", x, y, type); - return type == TPMCPATTERNVALUE_TYPE_WILDCARD; +static bool patternIsWildcard(TpmcPattern *pattern) { + return pattern->pattern->type == TPMCPATTERNVALUE_TYPE_WILDCARD; } -static bool noRemainingTests(TpmcMatrix *matrix) { - DEBUG("noRemainingTests %d", matrix->width); +static bool topRowOnlyVariables(TpmcMatrix *matrix) { for (int x = 0; x < matrix->width; x++) { - if (!patternIsWildcard(matrix, x, 0)) { + if (!patternIsWildcard(getTpmcMatrixIndex(matrix, x, 0))) { return false; } } @@ -67,7 +67,8 @@ static bool noRemainingTests(TpmcMatrix *matrix) { static int findFirstConstructorColumn(TpmcMatrix *matrix) { for (int x = 0; x < matrix->width; x++) { - if (!patternIsWildcard(matrix, x, 0)) { + if (!patternIsWildcard(getTpmcMatrixIndex(matrix, x, 0))) { + DEBUG("findFirstConstructorColumn(%d x %d) => %d", matrix->width, matrix->height, x); return x; } } @@ -75,7 +76,6 @@ static int findFirstConstructorColumn(TpmcMatrix *matrix) { } static TpmcState *makeEmptyTestState(HashSymbol *path) { - ENTER(makeEmptyTestState); TpmcArcArray *arcs = newTpmcArcArray(); int save = PROTECT(arcs); TpmcTestState *test = newTpmcTestState(path, arcs); @@ -83,38 +83,22 @@ static TpmcState *makeEmptyTestState(HashSymbol *path) { TpmcStateValue *val = newTpmcStateValue(TPMCSTATEVALUE_TYPE_TEST, TPMCSTATEVALUE_VAL_TEST(test)); PROTECT(val); - TpmcState *state = tpmcMakeState(val); -#ifdef DEBUG_TPMC_MATCH2 - eprintf("makeEmptyTestState returning: "); - printTpmcState(state, 0); - eprintf("\n"); -#endif + TpmcState *testState = tpmcMakeState(val); UNPROTECT(save); - LEAVE(makeEmptyTestState); - return state; + return testState; } static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { - ENTER(patternMatches); -#ifdef DEBUG_TPMC_MATCH2 - eprintf("patternMatches constructor: "); - printTpmcPattern(constructor, 0); - eprintf("\npatternMatches pattern: "); - printTpmcPattern(pattern, 0); - eprintf("\n"); -#endif bool isComparison = (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON); switch (pattern->pattern->type) { case TPMCPATTERNVALUE_TYPE_VAR: - cant_happen("patternMatches ennncountered var"); + cant_happen("patternMatches encountered var"); case TPMCPATTERNVALUE_TYPE_COMPARISON: - LEAVE(patternMatches); - return true; + return eqTpmcPattern(constructor, pattern); case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: cant_happen("patternMatches encountered assignment"); case TPMCPATTERNVALUE_TYPE_WILDCARD: - LEAVE(patternMatches); return true; case TPMCPATTERNVALUE_TYPE_CHARACTER:{ bool res = isComparison @@ -122,7 +106,6 @@ static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { TPMCPATTERNVALUE_TYPE_CHARACTER && constructor->pattern->val.character == pattern->pattern->val.character); - LEAVE(patternMatches); return res; } case TPMCPATTERNVALUE_TYPE_BIGINTEGER:{ @@ -131,7 +114,6 @@ static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { TPMCPATTERNVALUE_TYPE_BIGINTEGER && cmpBigInt(constructor->pattern->val.biginteger, pattern->pattern->val.biginteger) == 0); - LEAVE(patternMatches); return res; } case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ @@ -142,75 +124,115 @@ static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { // pointer equivalence works for hash symbols constructor->pattern->val.constructor->tag == pattern->pattern->val.constructor->tag) || isComparison; - LEAVE(patternMatches); return res; } default: - cant_happen("unrecognized pattern type %d in patternMatches", - pattern->pattern->type); + cant_happen("unrecognized pattern type %s in patternMatches", + tpmcPatternValueTypeName(pattern->pattern->type)); } } -static bool patternIndexMatches(TpmcMatrix *matrix, int x, int y, int yy) { - if (y == yy) { -#ifdef DEBUG_TPMC_MATCH2 - eprintf("patternIndexMatches is true trivially\n"); -#endif - return true; +TpmcIntArray *findPatternsMatching(TpmcPattern *c, TpmcPatternArray *N) { + TpmcIntArray *res = newTpmcIntArray(); + int save = PROTECT(res); + int i = 0; + TpmcPattern *candidate; + while (iterateTpmcPatternArray(N, &i, &candidate, NULL)) { + if (patternMatches(c, candidate)) { + pushTpmcIntArray(res, i - 1); + } } - TpmcPattern *constructor = getTpmcMatrixIndex(matrix, x, y); - TpmcPattern *pattern = getTpmcMatrixIndex(matrix, x, yy); - return patternMatches(constructor, pattern); + UNPROTECT(save); + return res; } -TpmcIntArray *findPatternsMatching(TpmcMatrix *matrix, int x, int y) { - ENTER(findPatternsMatching); - TpmcIntArray *res = newTpmcIntArray(); +static TpmcPatternArray *extractColumnSubset(TpmcIntArray *ys, + TpmcPatternArray *N) { + TpmcPatternArray *res = newTpmcPatternArray("extractColumnSubset"); int save = PROTECT(res); - for (int yy = 0; yy < matrix->height; yy++) { - if (patternIndexMatches(matrix, x, y, yy)) { - pushTpmcIntArray(res, yy); - } + int i = 0; + int y; + while (iterateTpmcIntArray(ys, &i, &y, NULL)) { + pushTpmcPatternArray(res, N->entries[y]); } -#ifdef DEBUG_TPMC_MATCH2 - eprintf("findPatternsMatching %d %d returning: ", x, y); - printTpmcIntArray(res, 0); - eprintf("\n"); -#endif UNPROTECT(save); - LEAVE(findPatternsMatching); return res; } -static TpmcPatternArray *extractMatrixColumnSubset(TpmcMatrix *matrix, int x, - TpmcIntArray *ys) { - ENTER(extractMatrixColumnSubset); - TpmcPatternArray *res = newTpmcPatternArray("extractMatrixColumnSubset"); +static TpmcPatternArray *extractMatrixColumn(int x, TpmcMatrix *matrix) { + TpmcPatternArray *res = newTpmcPatternArray("extractMatrixColumn"); int save = PROTECT(res); - for (int i = 0; i < ys->size; ++i) { - int y = ys->entries[i]; + for (int y = 0; y < matrix->height; y++) { pushTpmcPatternArray(res, getTpmcMatrixIndex(matrix, x, y)); } -#ifdef DEBUG_TPMC_MATCH2 - eprintf("extractMatrixColumnSubset returning: "); - printTpmcPatternArray(res, 0); - eprintf("\n"); -#endif UNPROTECT(save); - LEAVE(extractMatrixColumnSubset); return res; } -static TpmcStateArray *extractStateArraySubset(TpmcStateArray *all, - TpmcIntArray *indices) { - ENTER(extractStateArraySubset); -#ifdef DEBUG_TPMC_MATCH2 - eprintf("extractStateArraySubset all: "); - printTpmcStateArray(all, 0); - eprintf("\nextractStateArraySubset indices: "); - printTpmcIntArray(indices, 0); - eprintf("\n"); -#endif +static TpmcMatrix *discardMatrixColumn(int column, TpmcMatrix *matrix) { + TpmcMatrix *res = newTpmcMatrix(matrix->width - 1, matrix->height); + int save = PROTECT(res); + for (int x = 0; x < matrix->width; x++) { + for (int y = 0; y < matrix->height; y++) { + if (x < column) { + setTpmcMatrixIndex(res, x, y, + getTpmcMatrixIndex(matrix, x, y)); + } else if (x > column) { + setTpmcMatrixIndex(res, x - 1, y, + getTpmcMatrixIndex(matrix, x, y)); + } else { + // no-op + } + } + } + UNPROTECT(save); + return res; +} + +static TpmcMatrix *extractMatrixRows(TpmcIntArray *indices, + TpmcMatrix *matrix) { + TpmcMatrix *res = newTpmcMatrix(matrix->width, indices->size); + int save = PROTECT(res); + int resy = 0; + int iy = 0; + int i = 0; + while (iterateTpmcIntArray(indices, &i, &iy, NULL)) { + for (int x = 0; x < res->width; ++x) { + setTpmcMatrixIndex(res, x, resy, + getTpmcMatrixIndex(matrix, x, iy)); + } + resy++; + } + UNPROTECT(save); + return res; +} + +static TpmcMatrix *appendMatrices(TpmcMatrix *prefix, TpmcMatrix *suffix) { + if (prefix->height != suffix->height) { + cant_happen + ("appendMatrices given matrices with different heights, %d vs %d", + prefix->height, suffix->height); + } + TpmcMatrix *res = + newTpmcMatrix(prefix->width + suffix->width, prefix->height); + int save = PROTECT(res); + for (int x = 0; x < res->width; ++x) { + for (int y = 0; y < res->height; ++y) { + if (x >= prefix->width) { + setTpmcMatrixIndex(res, x, y, + getTpmcMatrixIndex(suffix, + x - prefix->width, y)); + } else { + setTpmcMatrixIndex(res, x, y, + getTpmcMatrixIndex(prefix, x, y)); + } + } + } + UNPROTECT(save); + return res; +} + +static TpmcStateArray *extractStateArraySubset(TpmcIntArray *indices, TpmcStateArray *all) { TpmcStateArray *res = newTpmcStateArray("extractStateArraySubset"); int save = PROTECT(res); for (int i = 0; i < indices->size; ++i) { @@ -218,16 +240,13 @@ static TpmcStateArray *extractStateArraySubset(TpmcStateArray *all, pushTpmcStateArray(res, all->entries[j]); } UNPROTECT(save); - LEAVE(extractStateArraySubset); return res; } -static int determineArity(TpmcPattern *pattern) { +static int arityOf(TpmcPattern *pattern) { if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { LamTypeConstructorInfo *info = pattern->pattern->val.constructor->info; - DEBUG("'%s' has arity %d", - pattern->pattern->val.constructor->tag->name, info->arity); return info->arity; } else { return 0; @@ -237,7 +256,6 @@ static int determineArity(TpmcPattern *pattern) { static void populateSubPatternMatrixRowWithWildcards(TpmcMatrix *matrix, int y, int arity, TpmcPattern *pattern) { - ENTER(populateSubPatternMatrixRowWithWildcards); // FIXME safeMalloc this from strlen + some n char buf[512]; for (int i = 0; i < arity; i++) { @@ -254,39 +272,36 @@ static void populateSubPatternMatrixRowWithWildcards(TpmcMatrix *matrix, getTpmcMatrixIndex(matrix, i, y)->path = path; UNPROTECT(save); } - LEAVE(populateSubPatternMatrixRowWithWildcards); } static void populateSubPatternMatrixRowWithComponents(TpmcMatrix *matrix, int y, int arity, TpmcPattern *pattern) { - ENTER(populateSubPatternMatrixRowWithComponents); if (arity != pattern->pattern->val.constructor->components->size) { + ppTpmcPattern(pattern); cant_happen ("arity %d does not match constructor arity %d in populateSubPatternMatrixRowWithComponents", arity, pattern->pattern->val.constructor->components->size); } for (int i = 0; i < arity; i++) { - setTpmcMatrixIndex(matrix, i, y, - pattern->pattern->val.constructor->components-> - entries[i]); + TpmcPattern *entry = + pattern->pattern->val.constructor->components->entries[i]; + setTpmcMatrixIndex(matrix, i, y, entry); } - LEAVE(populateSubPatternMatrixRowWithComponents); } -static void populateSubPatternMatrix(TpmcMatrix *matrix, - TpmcPatternArray *patterns, int arity) { - ENTER(populateSubPatternMatrix); +static TpmcMatrix *makeSubPatternMatrix(TpmcPatternArray *patterns, int arity) { + TpmcMatrix *matrix = newTpmcMatrix(arity, patterns->size); if (arity == 0) { - LEAVE(populateSubPatternMatrix); - return; + return matrix; } + int save = PROTECT(matrix); for (int i = 0; i < patterns->size; ++i) { TpmcPattern *pattern = patterns->entries[i]; switch (pattern->pattern->type) { case TPMCPATTERNVALUE_TYPE_VAR: cant_happen - ("encountered pattern type var during populateSubPatternMatrix"); + ("encountered pattern type var during makeSubPatternMatrix"); case TPMCPATTERNVALUE_TYPE_COMPARISON: case TPMCPATTERNVALUE_TYPE_WILDCARD: populateSubPatternMatrixRowWithWildcards(matrix, i, arity, @@ -298,64 +313,24 @@ static void populateSubPatternMatrix(TpmcMatrix *matrix, break; case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: cant_happen - ("encountered pattern type assignment during populateSubPatternMatrix"); + ("encountered pattern type assignment during makeSubPatternMatrix"); case TPMCPATTERNVALUE_TYPE_CHARACTER: cant_happen - ("encountered pattern type char during populateSubPatternMatrix"); + ("encountered pattern type char during makeSubPatternMatrix"); case TPMCPATTERNVALUE_TYPE_BIGINTEGER: cant_happen - ("encountered pattern type int during populateSubPatternMatrix"); + ("encountered pattern type int during makeSubPatternMatrix"); default: cant_happen - ("unrecognised pattern type %d during populateSubPatternMatrix", - pattern->pattern->type); - } - } - LEAVE(populateSubPatternMatrix); -} - -static void copyMatrixExceptColAndOnlyRows(int col, TpmcIntArray *ys, - TpmcMatrix *from, TpmcMatrix *to) { - ENTER(copyMatrixExceptColAndOnlyRows); - DEBUG("copyMatrixExceptColAndOnlyRows col : %d", col); -#ifdef DEBUG_TPMC_MATCH2 - eprintf("copyMatrixExceptColAndOnlyRows rows: "); - printTpmcIntArray(ys, 0); - eprintf("\n"); - DEBUG("copyMatrixExceptColAndOnlyRows from: %d * %d to: %d * %d", - from->width, from->height, to->width, to->height); -#endif - int tx = 0; - for (int x = 0; x < from->width; x++) { - if (x != col) { - for (int iy = 0; iy < ys->size; ++iy) { - int y = ys->entries[iy]; - DEBUG("copyMatrixExceptCol(%d), to[%d][%d] <= from[%d][%d]", - col, tx, iy, x, y); - setTpmcMatrixIndex(to, tx, iy, - getTpmcMatrixIndex(from, x, y)); - } - tx++; - } - } - LEAVE(copyMatrixExceptColAndOnlyRows); -} - -static void copyMatrixWithOffset(int offset, TpmcMatrix *from, TpmcMatrix *to) { - ENTER(copyMatrixWithOffset); - for (int x = 0; x < from->width; x++) { - for (int y = 0; y < from->height; ++y) { - DEBUG("copyMatrixWithOffset(%d), to[%d][%d] <= from[%d][%d]", - offset, x + offset, y, x, y); - setTpmcMatrixIndex(to, x + offset, y, - getTpmcMatrixIndex(from, x, y)); + ("unrecognised pattern type %s during makeSubPatternMatrix", + tpmcPatternValueTypeName(pattern->pattern->type)); } } - LEAVE(copyMatrixWithOffset); + UNPROTECT(save); + return matrix; } static TpmcPattern *replaceComponentsWithWildcards(TpmcPattern *pattern) { - ENTER(replaceComponentsWithWildcards); if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { TpmcConstructorPattern *constructor = pattern->pattern->val.constructor; @@ -386,23 +361,19 @@ static TpmcPattern *replaceComponentsWithWildcards(TpmcPattern *pattern) { TpmcPattern *replacement = newTpmcPattern(patternValue); replacement->path = pattern->path; UNPROTECT(save); - LEAVE(replaceComponentsWithWildcards); return replacement; } } - LEAVE(replaceComponentsWithWildcards); return pattern; } static TpmcIntArray *makeTpmcIntArray(int size, int initialValue) { - ENTER(makeTpmcIntArray); TpmcIntArray *res = newTpmcIntArray(); int save = PROTECT(res); for (int i = 0; i < size; ++i) { pushTpmcIntArray(res, initialValue); } UNPROTECT(save); - LEAVE(makeTpmcIntArray); return res; } @@ -438,8 +409,7 @@ static bool arcsAreExhaustive(int size, TpmcArcArray *arcs) { static bool constructorsAreExhaustive(TpmcState *state) { TpmcTestState *testState = state->state->val.test; if (testState->arcs->size == 0) { - cant_happen - ("constructorsAreExhaustive() passed a test state with zero arcs"); + return false; } TpmcPattern *pattern = testState->arcs->entries[0]->test; if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_WILDCARD) { @@ -454,7 +424,6 @@ static bool constructorsAreExhaustive(TpmcState *state) { } static TpmcPattern *makeNamedWildcardPattern(HashSymbol *path) { - ENTER(makeNamedWildcardPattern); TpmcPatternValue *wc = newTpmcPatternValue(TPMCPATTERNVALUE_TYPE_WILDCARD, TPMCPATTERNVALUE_VAL_WILDCARD ()); @@ -462,7 +431,6 @@ static TpmcPattern *makeNamedWildcardPattern(HashSymbol *path) { TpmcPattern *pattern = newTpmcPattern(wc); pattern->path = path; UNPROTECT(save); - LEAVE(makeNamedWildcardPattern); return pattern; } @@ -470,31 +438,25 @@ static TpmcState *deduplicateState(TpmcState *state, TpmcStateArray *knownStates) { for (int i = 0; i < knownStates->size; i++) { if (tpmcStateEq(state, knownStates->entries[i])) { - DEBUG("deduplicateState found dup"); validateLastAlloc(); return knownStates->entries[i]; } } - DEBUG("deduplicateState adding new"); pushTpmcStateArray(knownStates, state); - DEBUG("deduplicateState added new"); return state; } static void collectPathsBoundByConstructor(TpmcPatternArray *components, TpmcVariableTable *boundVariables) { - ENTER(collectPathsBoundByConstructor); for (int i = 0; i < components->size; ++i) { TpmcPattern *pattern = components->entries[i]; setTpmcVariableTable(boundVariables, pattern->path); } - LEAVE(collectPathsBoundByConstructor); } static void collectPathsBoundByPattern(TpmcPattern *pattern, TpmcVariableTable *boundVariables) { - ENTER(collecPathsBoundByPattern); // FIXME is this correct? setTpmcVariableTable(boundVariables, pattern->path); switch (pattern->pattern->type) { @@ -505,35 +467,32 @@ static void collectPathsBoundByPattern(TpmcPattern *pattern, case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: cant_happen("collectPathsBoundByPattern encountered ASSIGNMENT"); case TPMCPATTERNVALUE_TYPE_WILDCARD: - break; case TPMCPATTERNVALUE_TYPE_CHARACTER: - break; case TPMCPATTERNVALUE_TYPE_BIGINTEGER: break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - collectPathsBoundByConstructor(pattern->pattern->val.constructor-> - components, boundVariables); + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ + TpmcPatternArray *components = + pattern->pattern->val.constructor->components; + collectPathsBoundByConstructor(components, boundVariables); + } break; default: - cant_happen("unrecognised type %d in collectPathsBoundByPattern", - pattern->pattern->type); + cant_happen("unrecognised type %s in collectPathsBoundByPattern", + tpmcPatternValueTypeName(pattern->pattern->type)); } - LEAVE("collecPathsBoundByPattern"); } static TpmcVariableTable *variablesBoundByPattern(TpmcPattern *pattern) { - ENTER(variablesBoundByPattern); TpmcVariableTable *boundVariables = newTpmcVariableTable(); int save = PROTECT(boundVariables); collectPathsBoundByPattern(pattern, boundVariables); UNPROTECT(save); - LEAVE(variablesBoundByPattern); return boundVariables; } static TpmcVariableTable *getTestStatesFreeVariables(TpmcTestState *testState) { - // The free variables of a test state is the union of the free variables of the outgoing arcs, plus the test variable. - ENTER(getTestStatesFreeVariables); + // The free variables of a test state is the union of the free variables + // of the outgoing arcs, plus the test variable. TpmcVariableTable *freeVariables = newTpmcVariableTable(); int save = PROTECT(freeVariables); setTpmcVariableTable(freeVariables, testState->path); @@ -551,12 +510,10 @@ static TpmcVariableTable *getTestStatesFreeVariables(TpmcTestState *testState) { } } UNPROTECT(save); - LEAVE(getTestStatesFreeVariables); return freeVariables; } static TpmcVariableTable *getStatesFreeVariables(TpmcState *state) { - ENTER(getStatesFreeVariables); if (state->freeVariables == NULL) { switch (state->state->type) { case TPMCSTATEVALUE_TYPE_TEST: @@ -571,16 +528,22 @@ static TpmcVariableTable *getStatesFreeVariables(TpmcState *state) { ("getStatesFreeVariables encountered error state with null free variables"); default: cant_happen - ("unrecognised state type %d in getStateFreeVariables", - state->state->type); + ("unrecognised state type %s in getStateFreeVariables", + tpmcStateValueTypeName(state->state->type)); } } - LEAVE(getStatesFreeVariables); return state->freeVariables; } -static TpmcArc *makeTpmcArc(TpmcState *state, TpmcPattern *pattern) { - ENTER(makeTpmcArc); +static void addFreeVariablesRequiredByPattern(TpmcPattern *pattern, TpmcVariableTable *freeVariables) { + if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { + TpmcPattern *previous = pattern->pattern->val.comparison->previous; + HashSymbol *name = previous->path; + setTpmcVariableTable(freeVariables, name); + } +} + +static TpmcArc *makeTpmcArc(TpmcPattern *pattern, TpmcState *state) { TpmcArc *arc = newTpmcArc(state, pattern); int save = PROTECT(arc); // the free variables of an arc are the free variables of its state minus the variables bound in the pattern @@ -592,216 +555,140 @@ static TpmcArc *makeTpmcArc(TpmcState *state, TpmcPattern *pattern) { HashSymbol *key; while ((key = iterateTpmcVariableTable(statesFreeVariables, &i)) != NULL) { if (!getTpmcVariableTable(boundVariables, key)) { - DEBUG("makeTpmcArc adding free variable %s", key->name); setTpmcVariableTable(arc->freeVariables, key); } } + addFreeVariablesRequiredByPattern(pattern, arc->freeVariables); state->refcount++; - DEBUG("makeTpmcArc creating arc to state with refcount %d", - state->refcount); - IFDEBUG(printTpmcState(state, 0)); UNPROTECT(save); - LEAVE(makeTpmcArc); return arc; } -#ifdef DEBUG_TPMC_MATCH -void ppPattern(TpmcPattern *pattern) { - eprintf("%s == ", pattern->path->name); - switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_COMPARISON:{ - TpmcComparisonPattern *c = pattern->pattern->val.comparison; - eprintf("(%s == %s)", c->previous->path->name, - c->current->path->name); - break; - } - case TPMCPATTERNVALUE_TYPE_WILDCARD: - eprintf("_"); - break; - case TPMCPATTERNVALUE_TYPE_CHARACTER: - eprintf("'%c'", pattern->pattern->val.character); - break; - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - fprintBigInt(stderr, pattern->pattern->val.biginteger); - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - TpmcConstructorPattern *c = pattern->pattern->val.constructor; - eprintf("%s(", c->tag->name); - for (int i = 0; i < c->components->size; ++i) { - ppPattern(c->components->entries[i]); - if (i + 1 < c->components->size) { - eprintf(", "); - } - } - eprintf(")"); - break; - } - default: - cant_happen("ppPattern encountered unexpected type"); +static TpmcIntArray *findWcIndices(TpmcPatternArray *N) { + TpmcIntArray *wcIndices = newTpmcIntArray(); + int save = PROTECT(wcIndices); + int row = 0; + TpmcPattern *candidate; + while (iterateTpmcPatternArray(N, &row, &candidate, NULL)) { + if (patternIsWildcard(candidate)) { + pushTpmcIntArray(wcIndices, row - 1); + } } + UNPROTECT(save); + return wcIndices; } -# define PPPATTERN(p) ppPattern(p); eprintf("\n") -#else -# define PPPATTERN(p) -#endif - -static TpmcState *mixture(TpmcMatrix *matrix, TpmcStateArray *finalStates, +static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, TpmcState *errorState, TpmcStateArray *knownStates) { ENTER(mixture); - // there is some column whose topmost pattern is a constructor - int x = findFirstConstructorColumn(matrix); - // The goal is to build a test state with the variable v and some outgoing arcs (one for each constructor and possibly a default arc). - TpmcState *state = - makeEmptyTestState(getTpmcMatrixIndex(matrix, x, 0)->path); - int save = PROTECT(state); - // For each constructor c in the selected column, its arc is defined as follows: - for (int y = 0; y < matrix->height; y++) { - DEBUG("mixture examining[%d][%d]", x, y); - PPPATTERN(getTpmcMatrixIndex(matrix, x, y)); - if (!patternIsWildcard(matrix, x, y)) { - DEBUG("mixture pattern is not wildcard"); - TpmcPattern *c = getTpmcMatrixIndex(matrix, x, y); - // Let {i1 , ... , ij} be the row-indices of the patterns in the column that match c. - TpmcIntArray *matchingIndices = - findPatternsMatching(matrix, x, y); - validateLastAlloc(); + // there is some column N whose topmost pattern is a constructor + int firstConstructorColumn = findFirstConstructorColumn(M); + firstConstructorColumn = 0; + TpmcPatternArray *N = extractMatrixColumn(firstConstructorColumn, M); + int save = PROTECT(N); + // let M-N be all the columns in M except N + TpmcMatrix *MN = discardMatrixColumn(firstConstructorColumn, M); + PROTECT(MN); + // The goal is to build a test state with the variable v and some outgoing arcs + // (one for each constructor and possibly a default arc). + TpmcState *testState = makeEmptyTestState(N->entries[0]->path); + PROTECT(testState); + for (int row = 0; row < N->size; row++) { + TpmcPattern *c = N->entries[row]; + // For each constructor c in the selected column, its arc is defined as follows: + if (!patternIsWildcard(c)) { + // Let {i1 , ... , ij} be the row-indices of the patterns in N that match c. + TpmcIntArray *matchingIndices = findPatternsMatching(c, N); int save2 = PROTECT(matchingIndices); // Let {pat1 , ... , patj} be the patterns in the column corresponding to the indices computed above, - TpmcPatternArray *matchingPatterns = - extractMatrixColumnSubset(matrix, x, matchingIndices); + TpmcPatternArray *matchingPatterns = extractColumnSubset(matchingIndices, N); PROTECT(matchingPatterns); // let n be the arity of the constructor c - int arity = determineArity(c); - // ... a pattern matrix with n columns and j rows (create ahead of time) - DEBUG("mixture - creating sub-pattern matrix %d * %d", arity, - matchingPatterns->size); - TpmcMatrix *subPatternMatrix = newTpmcMatrix(arity, matchingPatterns->size); // could be zero-width - PROTECT(subPatternMatrix); + int n = arityOf(c); // For each pati, its n sub-patterns are extracted; // if pati is a wildcard, n wildcards are produced instead, each tagged with the right path variable. - populateSubPatternMatrix(subPatternMatrix, matchingPatterns, - arity); - // This matrix is then appended to the result of selecting, from each column in the rest of the - // original matrix, those rows whose indices are in {i1 , ... , ij}. - TpmcMatrix *newMatrix = newTpmcMatrix(matrix->width + arity - 1, - matchingPatterns->size); - DEBUG("mixture - created newMatrix %d * %d", newMatrix->width, - newMatrix->height); + TpmcMatrix *subPatternMatrix = makeSubPatternMatrix(matchingPatterns, n); + PROTECT(subPatternMatrix); + // This matrix is then appended to the result of selecting, from each column in MN, + // those rows whose indices are in {i1 , ... , ij}. + TpmcMatrix *prefixMatrix = extractMatrixRows(matchingIndices, MN); + PROTECT(prefixMatrix); + TpmcMatrix *newMatrix = appendMatrices(prefixMatrix, subPatternMatrix); PROTECT(newMatrix); - copyMatrixExceptColAndOnlyRows(x, matchingIndices, matrix, - newMatrix); - copyMatrixWithOffset(matrix->width - 1, subPatternMatrix, - newMatrix); // Finally the indices are used to select the corresponding final states that go with these rows. - TpmcStateArray *newFinalStates = - extractStateArraySubset(finalStates, matchingIndices); + TpmcStateArray *newFinalStates = extractStateArraySubset(matchingIndices, finalStates); PROTECT(newFinalStates); // The arc for the constructor c is now defined as (c’,state), where c’ is c with any immediate // sub-patterns replaced by their path variables (thus c’ is a simple pattern) TpmcPattern *cPrime = replaceComponentsWithWildcards(c); PROTECT(cPrime); // and state is the result of recursively applying match to the new matrix and the new sequence of final states - TpmcState *newState = - tpmcMatch(newMatrix, newFinalStates, errorState, knownStates); + TpmcState *newState = match(newMatrix, newFinalStates, errorState, knownStates); PROTECT(newState); - TpmcArc *arc = makeTpmcArc(newState, cPrime); + TpmcArc *arc = makeTpmcArc(cPrime, newState); PROTECT(arc); - if (tpmcArcInArray(arc, state->state->val.test->arcs)) { + if (tpmcArcInArray(arc, testState->state->val.test->arcs)) { arc->state->refcount--; validateLastAlloc(); } else { - pushTpmcArcArray(state->state->val.test->arcs, arc); + pushTpmcArcArray(testState->state->val.test->arcs, arc); } UNPROTECT(save2); } } // Finally, the possibility for matching failure is considered. // If the set of constructors is exhaustive, then no more arcs are computed - if (constructorsAreExhaustive(state)) { - TpmcState *res = deduplicateState(state, knownStates); - UNPROTECT(save); - DEBUG("mixture - constructors are exhaustive"); - LEAVE(mixture); - return res; - } - // Otherwise, a default arc (_,state) is the last arc. - // If there are any wildcard patterns in the selected column - TpmcIntArray *wcIndices = newTpmcIntArray(); - PROTECT(wcIndices); - for (int y = 0; y < matrix->height; y++) { - if (patternIsWildcard(matrix, x, y)) { - pushTpmcIntArray(wcIndices, y); + if (!constructorsAreExhaustive(testState)) { + // Otherwise, a default arc (_,state) is the last arc. + // If there are any wildcard patterns in the selected column + TpmcIntArray *wcIndices = findWcIndices(N); + PROTECT(wcIndices); + if (countTpmcIntArray(wcIndices) > 0) { + // then their rows are selected from the rest of the matrix and the final states + TpmcMatrix *wcMatrix = extractMatrixRows(wcIndices, MN); + PROTECT(wcMatrix); + TpmcStateArray *wcFinalStates = extractStateArraySubset(wcIndices, finalStates); + PROTECT(wcFinalStates); + // and the state is the result of applying match to the new matrix and states + TpmcState *wcState = match(wcMatrix, wcFinalStates, errorState, knownStates); + PROTECT(wcState); + TpmcPattern *wcPattern = makeNamedWildcardPattern(N->entries[0]->path); + PROTECT(wcPattern); + TpmcArc *wcArc = makeTpmcArc(wcPattern, wcState); + PROTECT(wcArc); + pushTpmcArcArray(testState->state->val.test->arcs, wcArc); + } else { + validateLastAlloc(); + // Otherwise, the error state is used after its reference count has been incremented + TpmcPattern *errorPattern = makeNamedWildcardPattern(N->entries[0]->path); + PROTECT(errorPattern); + TpmcArc *errorArc = makeTpmcArc(errorPattern, errorState); + PROTECT(errorArc); + pushTpmcArcArray(testState->state->val.test->arcs, errorArc); } } - if (wcIndices->size > 0) { - // then their rows are selected from the rest of the matrix and the final states - TpmcMatrix *wcMatrix = - newTpmcMatrix(matrix->width - 1, wcIndices->size); - PROTECT(wcMatrix); - copyMatrixExceptColAndOnlyRows(x, wcIndices, matrix, wcMatrix); - TpmcStateArray *wcFinalStates = - extractStateArraySubset(finalStates, wcIndices); - PROTECT(wcFinalStates); - // and the state is the result of applying match to the new matrix and states - TpmcState *wcState = - tpmcMatch(wcMatrix, wcFinalStates, errorState, knownStates); - PROTECT(wcState); - TpmcPattern *wcPattern = - makeNamedWildcardPattern(getTpmcMatrixIndex(matrix, x, 0)->path); - PROTECT(wcPattern); - TpmcArc *wcArc = makeTpmcArc(wcState, wcPattern); - PROTECT(wcArc); - pushTpmcArcArray(state->state->val.test->arcs, wcArc); - TpmcState *res = deduplicateState(state, knownStates); - UNPROTECT(save); - DEBUG("mixture - wildcards supply default"); - LEAVE(mixture); - return res; - } else { - validateLastAlloc(); - // Otherwise, the error state is used after its reference count has been incremented - TpmcPattern *errorPattern = - makeNamedWildcardPattern(getTpmcMatrixIndex(matrix, x, 0)->path); - PROTECT(errorPattern); - TpmcArc *errorArc = makeTpmcArc(errorState, errorPattern); - PROTECT(errorArc); - pushTpmcArcArray(state->state->val.test->arcs, errorArc); - TpmcState *res = deduplicateState(state, knownStates); - UNPROTECT(save); - DEBUG("mixture - error state supplies default"); - LEAVE(mixture); - return res; - } + TpmcState *res = deduplicateState(testState, knownStates); + UNPROTECT(save); + LEAVE(mixture); + return res; } -TpmcState *tpmcMatch(TpmcMatrix *matrix, TpmcStateArray *finalStates, - TpmcState *errorState, TpmcStateArray *knownStates) { - ENTER(tpmcMatch); +static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates) { + ENTER(match); + IFDEBUG(ppTpmcMatrix(matrix)); + IFDEBUG(ppTpmcStateArray(finalStates)); if (matrix->height == 0) { cant_happen("zero-height matrix passed to match"); } TpmcState *res = NULL; -#ifdef DEBUG_TPMC_MATCH2 - eprintf("tpmcMatch: matrix: "); - printTpmcMatrix(matrix, 0); - eprintf("\ntpmcMatch: finalStates: "); - printTpmcStateArray(finalStates, 0); - eprintf("\n"); -#endif - if (noRemainingTests(matrix)) { - DEBUG("variable rule applies"); + if (topRowOnlyVariables(matrix)) { res = finalStates->entries[0]; } else { - DEBUG("mixture rule applies"); res = mixture(matrix, finalStates, errorState, knownStates); } - LEAVE(tpmcMatch); -#ifdef DEBUG_TPMC_MATCH2 - eprintf("tpmcMatch returning: "); - printTpmcState(res, 0); - eprintf("\n"); -#endif + IFDEBUG(ppTpmcState(res)); + LEAVE(match); return res; } diff --git a/src/tpmc_match.h b/src/tpmc_match.h index a0cb54b..1bc9fe5 100644 --- a/src/tpmc_match.h +++ b/src/tpmc_match.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_match_h -# define cekf_tpmc_match_h +# define cekf_tpmc_match_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -20,7 +20,7 @@ * Term Pattern Matching Compiler match algorithm */ -# include "tpmc.h" +# include "tpmc.h" TpmcState *tpmcMakeState(TpmcStateValue *val); TpmcState *tpmcMatch(TpmcMatrix *matrix, TpmcStateArray *states, diff --git a/src/tpmc_mermaid.c b/src/tpmc_mermaid.c new file mode 100644 index 0000000..a0a3337 --- /dev/null +++ b/src/tpmc_mermaid.c @@ -0,0 +1,203 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ +#include +#include +#include "common.h" +#include "symbol.h" +#include "tpmc_mermaid.h" + +int tpmc_mermaid_flag = 0; +char *tpmc_mermaid_function = NULL; + +static char *mermaidState(TpmcState *state); +static void mermaidPattern(TpmcPattern *pattern); + +static TpmcVariableTable *seen = NULL; + +static int initSeenTable() { + seen = newTpmcVariableTable(); + return PROTECT(seen); +} + +static void terminateSeenTable(int save) { + UNPROTECT(save); + seen = NULL; +} + +static bool seenName(char *name) { + HashSymbol *symbol = newSymbol(name); + if (getTpmcVariableTable(seen, symbol)) + return true; + setTpmcVariableTable(seen, symbol); + return false; +} + +static void mermaidFreeVariables(TpmcVariableTable *freeVariables) { + printf("["); + if (freeVariables != NULL) { + int i = 0; + int count = 0; + HashSymbol *key; + while ((key = iterateTpmcVariableTable(freeVariables, &i)) != NULL) { + printf("%s", key->name); + count++; + if (count < countTpmcVariableTable(freeVariables)) { + printf(" "); + } + } + } + printf("]"); +} + +static char *mermaidStateName(TpmcState *state) { + static char buf[512]; + switch (state->state->type) { + case TPMCSTATEVALUE_TYPE_TEST: + sprintf(buf, "T%d", state->stamp); + if (!seenName(buf)) { + printf("%s(\"%s\\n", buf, + state->state->val.test->path->name); + mermaidFreeVariables(state->freeVariables); + printf("\")\n"); + } + break; + case TPMCSTATEVALUE_TYPE_FINAL: + sprintf(buf, "F%d", state->stamp); + if (!seenName(buf)) { + printf("%s(\"", buf); + ppLamExp(state->state->val.final->action); + printf("\\n"); + mermaidFreeVariables(state->freeVariables); + printf("\")\n"); + } + break; + case TPMCSTATEVALUE_TYPE_ERROR: + sprintf(buf, "ERROR"); + printf("%s\n", buf); + break; + default: + cant_happen("unrecognised statevalue type %d in mermaidStateName", + state->state->type); + } + return strdup(buf); +} + +static void mermaidConstructorComponents(TpmcPatternArray *patterns) { + for (int i = 0; i < countTpmcPatternArray(patterns); ++i) { + mermaidPattern(patterns->entries[i]); + if (i < (countTpmcPatternArray(patterns) - 1)) { + printf(", "); + } + } +} + +static void mermaidPattern(TpmcPattern *pattern) { + printf("%s:", pattern->path->name); + TpmcPatternValue *value = pattern->pattern; + switch (value->type) { + case TPMCPATTERNVALUE_TYPE_VAR: + printf("var %s", value->val.var->name); + break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + mermaidPattern(value->val.comparison->previous); + printf("=="); + mermaidPattern(value->val.comparison->current); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + printf("assignment"); + break; + case TPMCPATTERNVALUE_TYPE_WILDCARD: + printf("_"); + break; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + printf("'%c'", value->val.character); + break; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + fprintBigInt(stdout, value->val.biginteger); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + printf("%s(", value->val.constructor->tag->name); + mermaidConstructorComponents(value->val.constructor->components); + printf(")"); + break; + default: + cant_happen("unrecognised type %d in mermaidArcLabel", + value->type); + } +} + +static void mermaidArcLabel(TpmcArc *arc) { + printf("\""); + mermaidPattern(arc->test); + printf("\\n"); + mermaidFreeVariables(arc->freeVariables); + printf("\""); +} + +static void mermaidArc(char *stateName, TpmcArc *arc) { + char *targetState = mermaidState(arc->state); + printf("%s --", stateName); + mermaidArcLabel(arc); + printf("--> %s\n", targetState); + free(targetState); +} + +static void mermaidTestState(char *name, TpmcTestState *testState) { + for (int i = 0; i < countTpmcArcArray(testState->arcs); i++) { + mermaidArc(name, testState->arcs->entries[i]); + } +} + +static void mermaidStateValue(char *name, TpmcStateValue *value) { + if (value == NULL) { + return; + } + switch (value->type) { + case TPMCSTATEVALUE_TYPE_TEST: + mermaidTestState(name, value->val.test); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + case TPMCSTATEVALUE_TYPE_ERROR: + break; + default: + cant_happen + ("unrecognised statevalue type %d in mermaidStateValue", + value->type); + } +} + +static char *mermaidState(TpmcState *state) { + if (state == NULL) { + return ""; + } + char *name = mermaidStateName(state); + mermaidStateValue(name, state->state); + return name; +} + +void tpmcMermaid(TpmcState *state) { + if (tpmc_mermaid_flag) { + int save = initSeenTable(); + printf("## %s\n", tpmc_mermaid_function); + printf("```mermaid\n"); + printf("flowchart TD\n"); + free(mermaidState(state)); + printf("```\n"); + terminateSeenTable(save); + } +} diff --git a/src/tpmc_mermaid.h b/src/tpmc_mermaid.h new file mode 100644 index 0000000..22511f8 --- /dev/null +++ b/src/tpmc_mermaid.h @@ -0,0 +1,29 @@ +#ifndef cekf_tpmc_mermaid_h +# define cekf_tpmc_mermaid_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +# include "tpmc.h" + +void tpmcMermaid(TpmcState *state); + +extern int tpmc_mermaid_flag; + +extern char *tpmc_mermaid_function; + +#endif diff --git a/src/tpmc_pp.c b/src/tpmc_pp.c new file mode 100644 index 0000000..edb7fe4 --- /dev/null +++ b/src/tpmc_pp.c @@ -0,0 +1,229 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "tpmc_pp.h" +#include "common.h" + +void ppTpmcComparisonPattern(TpmcComparisonPattern *comparisonPattern) { + ppTpmcPattern(comparisonPattern->previous); + eprintf("=="); + ppTpmcPattern(comparisonPattern->current); +} + +void ppTpmcAssignmentPattern(TpmcAssignmentPattern *assignmentPattern) { + eprintf("%s<-", assignmentPattern->name->name); + ppTpmcPattern(assignmentPattern->value); +} + +void ppTpmcConstructorPattern(TpmcConstructorPattern *constructorPattern) { + ppTpmcSymbol(constructorPattern->tag); + ppTpmcPatternArray(constructorPattern->components); +} + +void ppTpmcPatternArray(TpmcPatternArray *patternArray) { + eprintf("("); + int i = 0; + TpmcPattern *pattern = NULL; + bool more = false; + while (iterateTpmcPatternArray(patternArray, &i, &pattern, &more)) { + ppTpmcPattern(pattern); + if (more) { + eprintf(", "); + } + } + eprintf(")"); +} + +void ppTpmcPatternValue(TpmcPatternValue *patternValue) { + if (patternValue == NULL) { + eprintf(""); + return; + } + switch (patternValue->type) { + case TPMCPATTERNVALUE_TYPE_VAR: + ppTpmcSymbol(patternValue->val.var); + break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + ppTpmcComparisonPattern(patternValue->val.comparison); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + ppTpmcAssignmentPattern(patternValue->val.assignment); + break; + case TPMCPATTERNVALUE_TYPE_WILDCARD: + eprintf("_"); + break; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + eprintf("'%c'", patternValue->val.character); + break; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + fprintBigInt(errout, patternValue->val.biginteger); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + ppTpmcConstructorPattern(patternValue->val.constructor); + break; + } +} + +void ppTpmcPattern(TpmcPattern *pattern) { + if (pattern == NULL) { + eprintf(""); + return; + } + if (pattern->path == NULL) { + eprintf(""); + } else { + eprintf("%s", pattern->path->name); + } + if (pattern->pattern->type != TPMCPATTERNVALUE_TYPE_WILDCARD) { + eprintf("=("); + ppTpmcPatternValue(pattern->pattern); + eprintf(")"); + } +} + +void ppTpmcMatrix(TpmcMatrix *matrix) { + if (matrix == NULL) { + eprintf("\n"); + return; + } + eprintf("TpmcMatrix[\n"); + for (int height = 0; height < matrix->height; height++) { + eprintf(" ("); + for (int width = 0; width < matrix->width; width++) { + ppTpmcPattern(getTpmcMatrixIndex(matrix, width, height)); + if (width + 1 < matrix->width) + eprintf(", "); + } + eprintf(")\n"); + } + eprintf("]\n"); +} + +static char getTpmcStateType(TpmcState *state) { + switch (state->state->type) { + case TPMCSTATEVALUE_TYPE_TEST: + return 'T'; + case TPMCSTATEVALUE_TYPE_FINAL: + return 'F'; + case TPMCSTATEVALUE_TYPE_ERROR: + return 'E'; + default: + return '?'; + } +} + +void ppTpmcState(TpmcState *state) { + eprintf("%c%d(%d) ", getTpmcStateType(state), state->stamp, + state->refcount); + ppTpmcVariableTable(state->freeVariables); + eprintf(" "); + ppTpmcStateValue(state->state); +} + +void ppTpmcVariableTable(TpmcVariableTable *table) { + eprintf("["); + if (table != NULL) { + int i = 0; + int count = 0; + HashSymbol *symbol; + while ((symbol = iterateTpmcVariableTable(table, &i)) != NULL) { + ppTpmcSymbol(symbol); + count++; + if (count < countTpmcVariableTable(table)) { + eprintf(", "); + } + } + } + eprintf("]"); +} + +void ppTpmcSymbol(HashSymbol *symbol) { + eprintf("%s", symbol->name); +} + +void ppTpmcStateValue(TpmcStateValue *value) { + switch (value->type) { + case TPMCSTATEVALUE_TYPE_TEST: + ppTpmcTestState(value->val.test); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + ppTpmcFinalState(value->val.final); + break; + case TPMCSTATEVALUE_TYPE_ERROR: + eprintf("ERROR"); + break; + } +} + +void ppTpmcTestState(TpmcTestState *test) { + ppTpmcSymbol(test->path); + eprintf(":"); + ppTpmcArcArray(test->arcs); +} + +void ppTpmcArcArray(TpmcArcArray *arcs) { + eprintf("{"); + int i = 0; + TpmcArc *arc; + bool more; + while (iterateTpmcArcArray(arcs, &i, &arc, &more)) { + ppTpmcArc(arc); + if (more) + eprintf(", "); + } + eprintf("}"); +} + +void ppTpmcArc(TpmcArc *arc) { + eprintf("ARC("); + ppTpmcVariableTable(arc->freeVariables); + eprintf("::"); + ppTpmcPattern(arc->test); + eprintf("=>"); + ppTpmcState(arc->state); + eprintf(")"); +} + +void ppTpmcFinalState(TpmcFinalState *final) { + ppLamExp(final->action); +} + +void ppTpmcIntArray(TpmcIntArray *array) { + eprintf("["); + int i = 0; + int entry; + bool more; + while (iterateTpmcIntArray(array, &i, &entry, &more)) { + eprintf("%d%s", entry, more ? ", " : ""); + } + eprintf("]"); +} + +void ppTpmcStateArray(TpmcStateArray *array) { + eprintf("[\n"); + int i = 0; + TpmcState *state; + bool more; + while (iterateTpmcStateArray(array, &i, &state, &more)) { + eprintf(" "); + ppTpmcState(state); + if (more) + eprintf(",\n"); + } + eprintf("\n]"); +} diff --git a/src/tpmc_pp.h b/src/tpmc_pp.h new file mode 100644 index 0000000..90cc536 --- /dev/null +++ b/src/tpmc_pp.h @@ -0,0 +1,41 @@ +#ifndef cekf_tpmc_pp_h +# define cekf_tpmc_pp_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +# include "tpmc.h" + +void ppTpmcMatrix(TpmcMatrix *matrix); +void ppTpmcPattern(TpmcPattern *pattern); +void ppTpmcPatternValue(TpmcPatternValue *patternValue); +void ppTpmcComparisonPattern(TpmcComparisonPattern *comparisonPattern); +void ppTpmcAssignmentPattern(TpmcAssignmentPattern *assignmentPattern); +void ppTpmcConstructorPattern(TpmcConstructorPattern *constructorPattern); +void ppTpmcPatternArray(TpmcPatternArray *patternArray); +void ppTpmcState(TpmcState *state); +void ppTpmcVariableTable(TpmcVariableTable *table); +void ppTpmcSymbol(HashSymbol *symbol); +void ppTpmcStateValue(TpmcStateValue *value); +void ppTpmcTestState(TpmcTestState *test); +void ppTpmcArcArray(TpmcArcArray *arcs); +void ppTpmcArc(TpmcArc *arc); +void ppTpmcFinalState(TpmcFinalState *final); +void ppTpmcIntArray(TpmcIntArray *array); +void ppTpmcStateArray(TpmcStateArray *array); + +#endif diff --git a/src/tpmc_translate.c b/src/tpmc_translate.c index 3655b9a..ea87c4b 100644 --- a/src/tpmc_translate.c +++ b/src/tpmc_translate.c @@ -27,10 +27,10 @@ #include "common.h" #ifdef DEBUG_TPMC_TRANSLATE -# include "debug_tpmc.h" -# include "debugging_on.h" +# include "tpmc_debug.h" +# include "debugging_on.h" #else -# include "debugging_off.h" +# include "debugging_off.h" #endif static LamExp *translateStateToInlineCode(TpmcState *dfa, @@ -152,11 +152,13 @@ static LamExp *storeLambdaAndTranslateToApply(TpmcState *dfa, static LamExp *translateComparisonArcToTest(TpmcArc *arc) { ENTER(translateComparisonArcToTest); +#ifdef SAFETY_CHECKS if (arc->test->pattern->type != TPMCPATTERNVALUE_TYPE_COMPARISON) { cant_happen - ("translateComparisonArcToTest ecncountered non-comparison type %d", + ("translateComparisonArcToTest encountered non-comparison type %d", arc->test->pattern->type); } +#endif TpmcComparisonPattern *pattern = arc->test->pattern->val.comparison; LamExp *a = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(pattern->previous->path)); @@ -179,19 +181,25 @@ static LamExp *prependLetBindings(TpmcPattern *test, TpmcVariableTable *freeVariables, LamExp *body) { ENTER(prependLetBindings); +#ifdef SAFETY_CHECKS if (test->pattern->type != TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { cant_happen("prependLetBindings passed non-constructor %d", test->pattern->type); } +#endif TpmcConstructorPattern *constructor = test->pattern->val.constructor; if (constructor->components->size == 0) { + LEAVE(prependLetBindings); return body; } HashSymbol *name = constructor->info->type->name; int save = PROTECT(body); + DEBUG("constructor %s has size %d", name->name, constructor->components->size); for (int i = 0; i < constructor->components->size; i++) { HashSymbol *path = constructor->components->entries[i]->path; + DEBUG("considering variable %s", path->name); if (getTpmcVariableTable(freeVariables, path)) { + DEBUG("%s is free", path->name); LamExp *base = newLamExp(LAMEXP_TYPE_VAR, LAMEXP_VAL_VAR(test->path)); int save2 = PROTECT(base); @@ -208,6 +216,8 @@ static LamExp *prependLetBindings(TpmcPattern *test, body = newLamExp(LAMEXP_TYPE_LET, LAMEXP_VAL_LET(let)); REPLACE_PROTECT(save, body); UNPROTECT(save2); + } else { + DEBUG("%s is not free", path->name); } } LEAVE(prependLetBindings); @@ -367,9 +377,11 @@ static LamExp *translateComparisonArcListToIf(TpmcArcList *arcList, static LamExp *translateArcList(TpmcArcList *arcList, LamExp *testVar, LamExpTable *lambdaCache) { ENTER(translateArcList); +#ifdef SAFETY_CHECKS if (arcList == NULL) { cant_happen("ran out of arcs in translateArcList"); } +#endif LamExp *res = NULL; switch (arcList->arc->test->pattern->type) { case TPMCPATTERNVALUE_TYPE_COMPARISON:{ @@ -424,7 +436,7 @@ static LamExp *translateArcList(TpmcArcList *arcList, LamExp *testVar, lambdaCache); PROTECT(matches); LamExp *testExp = NULL; - if (info->vec) { + if (info->needsVec) { testExp = newLamExp(LAMEXP_TYPE_TAG, LAMEXP_VAL_TAG(testVar)); PROTECT(testExp); @@ -487,9 +499,11 @@ static LamIntCondCases *translateConstantIntArcList(TpmcArcList *arcList, LamExp *testVar, LamExpTable *lambdaCache) { +#ifdef SAFETY_CHECKS if (arcList == NULL) { cant_happen("ran out of arcs in translateConstantIntArcList"); } +#endif ENTER(translateConstantIntArcList); LamIntCondCases *res = NULL; switch (arcList->arc->test->pattern->type) { @@ -534,9 +548,11 @@ static LamCharCondCases *translateConstantCharArcList(TpmcArcList *arcList, LamExp *testVar, LamExpTable *lambdaCache) { +#ifdef SAFETY_CHECKS if (arcList == NULL) { cant_happen("ran out of arcs in translateConstantCharArcList"); } +#endif ENTER(translateConstantCharArcList); LamCharCondCases *res = NULL; switch (arcList->arc->test->pattern->type) { @@ -577,26 +593,6 @@ static LamCharCondCases *translateConstantCharArcList(TpmcArcList *arcList, return res; } -#ifdef DEBUG_TPMC_TRANSLATE -static int arcListLength(TpmcArcList *list) { - int i = 0; - while (list != NULL) { - list = list->next; - i++; - } - return i; -} - -static int intListLength(LamIntList *list) { - int i = 0; - while (list != NULL) { - list = list->next; - i++; - } - return i; -} -#endif - static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, LamExp *testVar, LamIntList *unexhaustedIndices, @@ -604,15 +600,18 @@ static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, ENTER(translateConstructorArcList); if (arcList == NULL) { if (unexhaustedIndices == NULL) { + LEAVE(translateConstructorArcList); return NULL; } else { cant_happen ("ran out of arcs with unexhausted indices in translateConstructorArcList"); } } +#ifdef SAFETY_CHECKS if (unexhaustedIndices == NULL) { cant_happen("all indices exhausted with arcs remaining"); } +#endif LamMatchList *res = NULL; switch (arcList->arc->test->pattern->type) { case TPMCPATTERNVALUE_TYPE_COMPARISON:{ diff --git a/src/tpmc_translate.h b/src/tpmc_translate.h index d9b9d09..8100b78 100644 --- a/src/tpmc_translate.h +++ b/src/tpmc_translate.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_translate_h -# define cekf_tpmc_translate_h +# define cekf_tpmc_translate_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,8 @@ * along with this program. If not, see . */ -# include "tpmc.h" -# include "lambda.h" +# include "tpmc.h" +# include "lambda.h" LamExp *tpmcTranslate(TpmcState *dfa); #endif diff --git a/src/value.h b/src/value.h index fa927da..2802fe3 100644 --- a/src/value.h +++ b/src/value.h @@ -1,5 +1,5 @@ #ifndef cekf_value_h -# define cekf_value_h +# define cekf_value_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,7 +18,7 @@ * along with this program. If not, see . */ -# include "bigint.h" +# include "bigint.h" typedef enum { VALUE_TYPE_VOID, @@ -46,15 +46,15 @@ typedef struct Value { ValueVal val; } Value; -# define VALUE_VAL_STDINT(x) ((ValueVal){.z = (x)}) -# define VALUE_VAL_BIGINT(x) ((ValueVal){.b = (x)}) -# define VALUE_VAL_CHARACTER(x) ((ValueVal){.c = (x)}) +# define VALUE_VAL_STDINT(x) ((ValueVal){.z = (x)}) +# define VALUE_VAL_BIGINT(x) ((ValueVal){.b = (x)}) +# define VALUE_VAL_CHARACTER(x) ((ValueVal){.c = (x)}) // CLO and PCLO share the same Clo struct -# define VALUE_VAL_CLO(x) ((ValueVal){.clo = (x)}) -# define VALUE_VAL_PCLO(x) ((ValueVal){.clo = (x)}) -# define VALUE_VAL_CONT(x) ((ValueVal){.k = (x)}) -# define VALUE_VAL_VEC(x) ((ValueVal){.vec = (x)}) -# define VALUE_VAL_NONE() ((ValueVal){.none = NULL}) +# define VALUE_VAL_CLO(x) ((ValueVal){.clo = (x)}) +# define VALUE_VAL_PCLO(x) ((ValueVal){.clo = (x)}) +# define VALUE_VAL_CONT(x) ((ValueVal){.k = (x)}) +# define VALUE_VAL_VEC(x) ((ValueVal){.vec = (x)}) +# define VALUE_VAL_NONE() ((ValueVal){.none = NULL}) // constants extern Value vTrue; diff --git a/tests/src/test_typechecker.c b/tests/src/test_typechecker.c index 0cf19bc..d38d52f 100644 --- a/tests/src/test_typechecker.c +++ b/tests/src/test_typechecker.c @@ -60,19 +60,19 @@ static TcType *makeVar(char *name) { return var; } -static TcType *makeTypeDef(char *name, TcTypeDefArgs *args) { +static TcType *makeUserType(char *name, TcUserTypeArgs *args) { HashSymbol *sym = newSymbol(name); - TcTypeDef *typeDef = newTcTypeDef(sym, args); + TcUserType *typeDef = newTcUserType(sym, args); int save = PROTECT(typeDef); - TcType *td = newTcType(TCTYPE_TYPE_TYPEDEF, TCTYPE_VAL_TYPEDEF(typeDef)); + TcType *td = newTcType(TCTYPE_TYPE_USERTYPE, TCTYPE_VAL_USERTYPE(typeDef)); UNPROTECT(save); return td; } static TcType *listOf(TcType *type) { - TcTypeDefArgs *args = newTcTypeDefArgs(type, NULL); + TcUserTypeArgs *args = newTcUserTypeArgs(type, NULL); int save = PROTECT(args); - TcType *td = makeTypeDef("list", args); + TcType *td = makeUserType("list", args); UNPROTECT(save); return td; } @@ -281,7 +281,7 @@ static void test_id() { int save = PROTECT(result); TcType *res = analyze(result); PROTECT(res); - TcType *expected = makeTypeDef("bool", NULL); + TcType *expected = makeUserType("bool", NULL); PROTECT(expected); assert(compareTcTypes(res, expected)); UNPROTECT(save); @@ -297,11 +297,11 @@ static void test_either_1() { PROTECT(big); TcType *var = makeVar("#t"); PROTECT(var); - TcTypeDefArgs *args = newTcTypeDefArgs(var, NULL); + TcUserTypeArgs *args = newTcUserTypeArgs(var, NULL); PROTECT(args); - args = newTcTypeDefArgs(big, args); + args = newTcUserTypeArgs(big, args); PROTECT(args); - TcType *expected = makeTypeDef("either", args); + TcType *expected = makeUserType("either", args); PROTECT(expected); assert(compareTcTypes(res, expected)); UNPROTECT(save); diff --git a/tools/makeAST.py b/tools/makeAST.py index 252d4a4..2996ca0 100644 --- a/tools/makeAST.py +++ b/tools/makeAST.py @@ -22,6 +22,7 @@ import sys import argparse import re +import os class Catalog: def __init__(self, typeName): @@ -84,6 +85,14 @@ def printMarkDeclarations(self): for entity in self.contents.values(): entity.printMarkDeclaration(self) + def printCountDeclarations(self): + for entity in self.contents.values(): + entity.printCountDeclaration(self) + + def printCountFunctions(self): + for entity in self.contents.values(): + entity.printCountFunction(self) + def printAccessDeclarations(self): for entity in self.contents.values(): entity.printAccessDeclarations(self) @@ -116,10 +125,6 @@ def printIteratorDeclarations(self): for entity in self.contents.values(): entity.printIteratorDeclaration(self) - def printCountDeclarations(self): - for entity in self.contents.values(): - entity.printCountDeclaration(self) - def printIteratorFunctions(self): for entity in self.contents.values(): entity.printIteratorFunction(self) @@ -136,6 +141,14 @@ def printCopyDeclarations(self): for entity in self.contents.values(): entity.printCopyDeclaration(self) + def printNameFunctionDeclarations(self): + for entity in self.contents.values(): + entity.printNameFunctionDeclaration() + + def printNameFunctionBodies(self): + for entity in self.contents.values(): + entity.printNameFunctionBody() + def printPrintFunctions(self): for entity in self.contents.values(): entity.printPrintFunction(self) @@ -257,6 +270,12 @@ def build(self, catalog): def printTypedef(self, catalog): pass + def printNameFunctionDeclaration(self): + pass + + def printNameFunctionBody(self): + pass + def printFreeDeclaration(self, catalog): pass @@ -311,7 +330,10 @@ def printAccessDeclarations(self, catalog): def printPushDeclaration(self, catalog): pass - def printPushFunction(selfself, catalog): + def printPushFunction(self, catalog): + pass + + def printCountFunction(self, catalog): pass def isEnum(self): @@ -374,6 +396,9 @@ def __init__(self, owner, name): self.owner = owner self.name = name + def isSimpleField(self): + return False; + def isSelfInitializing(self, catalog): return False @@ -381,6 +406,10 @@ def printEnumTypedefLine(self, count): field = self.makeTypeName() print(f" {field}, // {count}"); + def printNameFunctionLine(self): + field = self.makeTypeName() + print(f' case {field}: return "{field}";') + def makeTypeName(self): v = self.owner + '_type_' + self.name v = v.upper().replace('AST', 'AST_') @@ -423,6 +452,18 @@ def __init__(self, owner, name, typeName): self.typeName = typeName self.default = None + def isSimpleField(self): + return True + + def getName(self): + return self.name + + def getObj(self, catalog): + return catalog.get(self.typeName) + + def getObjName(self, catalog): + return self.getObj(catalog).getName() + def isSelfInitializing(self, catalog): obj = catalog.get(self.typeName) return obj.isSelfInitializing() @@ -574,11 +615,11 @@ def getIteratorDeclaration(self, catalog): def printIteratorDeclaration(self, catalog): decl = self.getIteratorDeclaration(catalog) - print(f'{decl}; // SimpleHask.printIteratorDeclaration') + print(f'{decl}; // SimpleHash.printIteratorDeclaration') def printIteratorFunction(self, catalog): decl = self.getIteratorDeclaration(catalog) - print(f'{decl} {{ // SimpleHask.printIteratorFunction') + print(f'{decl} {{ // SimpleHash.printIteratorFunction') if self.entries is None: print(' return iterateHashTable((HashTable *)table, i, NULL);') else: @@ -609,9 +650,10 @@ def printGetFunction(self, catalog): def printCountDeclaration(self, catalog): myName = self.getName() myType = self.getTypeDeclaration() - print(f'static inline int count{myName}({myType} table) {{') - print(' return ((HashTable *)table)->count;') - print('}') + print(f'static inline int count{myName}({myType} table) {{ // SimpleHash.printCountDeclaration') + print(' return ((HashTable *)table)->count; // SimpleHash.printCountDeclaration') + print('} // SimpleHash.printCountDeclaration') + print('') def printTypedef(self, catalog): self.noteTypedef() @@ -619,6 +661,7 @@ def printTypedef(self, catalog): print(f'typedef struct {myName} {{ // SimpleHash.printTypedef') print(' struct HashTable wrapped; // SimpleHash.printTypedef') print(f'}} {myName}; // SimpleHash.printTypedef') + print('') def printCopyField(self, field, depth, prefix=''): myConstructor = self.getConstructorName() @@ -662,11 +705,7 @@ def printNewFunction(self, catalog): print('}') print('') print(f'{decl} {{ // SimpleHash.printNewFunction') - print(f' return ({myName} *)newHashTable( // SimpleHash.printNewFunction') - print(f' {size}, // SimpleHash.printNewFunction') - print(f' {markFn}, // SimpleHash.printNewFunction') - print(f' {printFn} // SimpleHash.printNewFunction') - print(' ); // SimpleHash.printNewFunction') + print(f' return ({myName} *)newHashTable({size}, {markFn}, {printFn});// SimpleHash.printNewFunction') print('}') print('') @@ -718,16 +757,20 @@ def printPrintField(self, field, depth, prefix=''): def printAccessDeclarations(self, catalog): if self.dimension == 2: print(f"static inline {self.entries.getTypeDeclaration(catalog)} get{self.getName()}Index({self.getTypeDeclaration()} obj, int x, int y) {{ // SimpleArray.printAccessDeclarations") + print("#ifdef SAFETY_CHECKS // SimpleArray.printAccessDeclarations"); print(" if (x >= obj->width || y >= obj->height || x < 0 || y < 0) { // SimpleArray.printAccessDeclarations"); print(' cant_happen("2d matrix bounds exceeded"); // SimpleArray.printAccessDeclarations') print(" }") + print("#endif // SimpleArray.printAccessDeclarations"); print(" return obj->entries[x + y * obj->width]; // SimpleArray.printAccessDeclarations") print("} // SimpleArray.printAccessDeclarations") print("") print(f"static inline void set{self.getName()}Index({self.getTypeDeclaration()} obj, int x, int y, {self.entries.getTypeDeclaration(catalog)} val) {{ // SimpleArray.printAccessDeclarations") + print("#ifdef SAFETY_CHECKS // SimpleArray.printAccessDeclarations"); print(" if (x >= obj->width || y >= obj->height || x < 0 || y < 0) { // SimpleArray.printAccessDeclarations"); print(' cant_happen("2d matrix bounds exceeded"); // SimpleArray.printAccessDeclarations') print(" } // SimpleArray.printAccessDeclarations") + print("#endif // SimpleArray.printAccessDeclarations"); print(" obj->entries[x + y * obj->width] = val; // SimpleArray.printAccessDeclarations") print("} // SimpleArray.printAccessDeclarations") @@ -889,6 +932,17 @@ def getPrintSignature(self, catalog): def getCtype(self, astType, catalog): return f"{astType} *" + def printCountDeclaration(self, catalog): + myName = self.getName() + myType = self.getTypeDeclaration() + print(f'static inline int count{myName}({myType} x) {{ // SimpleArray.printCountDeclaration') + if self.dimension == 1: + print(' return x->size; // SimpleArray.printCountDeclaration') + else: + print(' return x->width * x->height; // SimpleArray.printCountDeclaration') + print('} // SimpleArray.printCountDeclaration') + print('') + def getExtraCmpFargs(self, catalog): extra = [] for name in self.extraCmpArgs: @@ -1044,6 +1098,93 @@ def printMarkField(self, field, depth, prefix=''): pad(depth) print("mark{myName}(x->{prefix}{field}); // SimpleArray..printMarkField".format(field=field, myName=self.getName(), prefix=prefix)) + def getIterator1DDeclaration(self, catalog): + myName = self.getName() + myType = self.getTypeDeclaration() + myContainedType = self.entries.getTypeDeclaration(catalog) + return f'bool iterate{myName}({myType} table, int *i, {myContainedType} *res, bool *more)' + + def getIterator2DDeclaration(self, catalog): + myName = self.getName() + myType = self.getTypeDeclaration() + myContainedType = self.entries.getTypeDeclaration(catalog) + return f'bool iterate{myName}({myType} table, int *x, int *y, {myContainedType} *res, bool *more_x, bool *more_y)' + + def printIteratorDeclaration(self, catalog): + if self.dimension == 2: + self.printIterator2DDeclaration(catalog); + else: + self.printIterator1DDeclaration(catalog) + + def printIterator1DDeclaration(self, catalog): + decl = self.getIterator1DDeclaration(catalog) + print(f'{decl}; // SimpleArray.printIterator1DDeclaration') + + def printIterator2DDeclaration(self, catalog): + decl = self.getIterator2DDeclaration(catalog) + print(f'{decl}; // SimpleArray.printIterator2DDeclaration') + + def printIteratorFunction(self, catalog): + if self.dimension == 2: + self.printIterator2DFunction(catalog) + else: + self.printIterator1DFunction(catalog) + + def printIterator1DFunction(self, catalog): + decl = self.getIterator1DDeclaration(catalog) + print(f'{decl} {{ // SimpleArray.printIterator1DFunction') + print(' if (*i < 0 || *i >= table->size) {') + print(' if (more != NULL) {') + print(' *more = false;') + print(' }') + print(' return false;') + print(' } else {') + print(' if (more != NULL) {') + print(' *more = (*i + 1 < table->size);') + print(' }') + print(' if (res != NULL) {') + print(' *res = table->entries[*i];') + print(' }') + print(' *i = *i + 1;') + print(' return true;') + print(' }') + print('} // SimpleArray.printIteratorFunction') + print('') + + def printIterator2DFunction(self, catalog): + decl = self.getIterator2DDeclaration(catalog) + print(f'{decl} {{ // SimpleArray.printIterator2DFunction') + print(' if (*x < 0 || *x >= table->width) {') + print(' if (more_x != NULL) {') + print(' *more_x = false;') + print(' }') + print(' return false;') + print(' } else if (*y < 0 || *y >= table->height) {') + print(' if (more_y != NULL) {') + print(' *more_y = false;') + print(' }') + print(' return false;') + print(' } else {') + print(' if (more_x != NULL) {') + print(' *more_x = (*x + 1 < table->width);') + print(' }') + print(' if (more_y != NULL) {') + print(' *more_y = (*y + 1 < table->height);') + print(' }') + print(' if (res != NULL) {') + print(' *res = table->entries[*x * table->width + *y];') + print(' }') + print(' if (*x + 1 == table->width) {') + print(' *x = 0;') + print(' *y = *y + 1;') + print(' } else {') + print(' *x = *x + 1;') + print(' }') + print(' return true;') + print(' }') + print('} // SimpleArray.printIteratorFunction') + print('') + def isArray(self): return True @@ -1076,9 +1217,44 @@ def getTypeDeclaration(self): def getObjType(self): return ('objtype_' + self.getName()).upper() + def isSinglySelfReferential(self, catalog): + count = 0 + for field in self.fields: + if field.isSimpleField() and field.getObjName(catalog) == self.getName(): + count += 1 + return count == 1 + + def getSelfReferentialField(self, catalog): + for field in self.fields: + if field.isSimpleField() and field.getObjName(catalog) == self.getName(): + return field.getName() + raise Exception(f'cannot find self-referential field name for {self.getName()}') + def objTypeArray(self): return [ self.getObjType() ] + def getCountSignature(self): + myType = self.getTypeDeclaration() + myName = self.getName() + return f'int count{myName}({myType} x)' + + def printCountDeclaration(self, catalog): + if self.isSinglySelfReferential(catalog): + print(f'{self.getCountSignature()}; // SimpleStruct.printCountDeclaration') + + def printCountFunction(self, catalog): + if self.isSinglySelfReferential(catalog): + print(f'{self.getCountSignature()} {{ // SimpleStruct.printCountFunction') + selfRefField = self.getSelfReferentialField(catalog) + print(' int count = 0; // SimpleStruct.printCountFunction') + print(' while (x != NULL) { // SimpleStruct.printCountFunction') + print(f' x = x->{selfRefField}; // SimpleStruct.printCountFunction') + print(' count++;; // SimpleStruct.printCountFunction') + print(' } // SimpleStruct.printCountFunction') + print(' return count; // SimpleStruct.printCountFunction') + print('} // SimpleStruct.printCountFunction') + print('') + def getMarkSignature(self, catalog): myType = self.getTypeDeclaration() return "void mark{myName}({myType} x)".format(myName=self.getName(), myType=myType) @@ -1578,6 +1754,30 @@ def getName(self): def getFieldName(self): return 'type' + def getNameFunctionDeclaration(self): + name = self.getName(); + camel = name[0].lower() + name[1:] + return f"char * {camel}Name(enum {name} type)" + + def printNameFunctionDeclaration(self): + decl = self.getNameFunctionDeclaration() + print(f"{decl}; // DiscriminatedUnionEnum.printNameFunctionDeclaration") + + def printNameFunctionBody(self): + decl = self.getNameFunctionDeclaration() + print(f"{decl} {{ // DiscriminatedUnionEnum.printNameFunctionDeclaration") + print(" switch(type) {") + for field in self.fields: + field.printNameFunctionLine() + print(" default: {") + print(" static char buf[64];") + print(' sprintf(buf, "%d", type);') + print(" return buf;"); + print(" }") + print(" }") + print("}") + print("") + def getTypeDeclaration(self): return "enum {name} ".format(name=self.getName()) @@ -1651,7 +1851,7 @@ def printCompareField(self, field, depth, prefix=''): if self.compareFn is None: print(f"if (a->{prefix}{field} != b->{prefix}{field}) return false; // Primitive.printCompareField") else: - print(f"if (!{self.compareFn}(a->{prefix}{field}, b->{prefix}{field})) return false; // Primitive.printCompareField") + print(f"if ({self.compareFn}(a->{prefix}{field}, b->{prefix}{field})) return false; // Primitive.printCompareField") def printPrintHashField(self, depth): pad(depth) @@ -1719,6 +1919,23 @@ def printGpl(file, document): print(f" * Generated from {file} by tools/makeAST.py") print(" */") +class Loader(yaml.SafeLoader): + + def __init__(self, stream): + + self._root = os.path.split(stream.name)[0] + + super(Loader, self).__init__(stream) + + def include(self, node): + + filename = os.path.join(self._root, self.construct_scalar(node)) + + with open(filename, 'r') as f: + return yaml.load(f, Loader) + +Loader.add_constructor('!include', Loader.include) + ################################################################## parser = argparse.ArgumentParser() @@ -1731,7 +1948,7 @@ def printGpl(file, document): stream = open(args.yaml, 'r') -document = yaml.load(stream, Loader=yaml.Loader) +document = yaml.load(stream, Loader) typeName = document['config']['name'] if 'includes' in document['config']: @@ -1765,6 +1982,10 @@ def printGpl(file, document): for name in document["primitives"]: catalog.add(Primitive(name, document["primitives"][name])) +if "external" in document: + for name in document["external"]: + catalog.add(Primitive(name, document["external"][name])) + if "arrays" in document: for name in document["arrays"]: catalog.add(SimpleArray(name, document["arrays"][name])) @@ -1818,11 +2039,14 @@ def printSection(name): catalog.printGetDeclarations() catalog.printSetDeclarations() catalog.printIteratorDeclarations() - catalog.printCountDeclarations() printSection("defines") catalog.printDefines() printSection("access declarations") catalog.printAccessDeclarations() + printSection("count declarations") + catalog.printCountDeclarations() + printSection("name declarations") + catalog.printNameFunctionDeclarations() print("") print("#endif") @@ -1865,6 +2089,8 @@ def printSection(name): catalog.printGetFunctions() catalog.printSetFunctions() catalog.printIteratorFunctions() + printSection("count functions") + catalog.printCountFunctions() printSection("mark functions") catalog.printMarkFunctions() printSection("generic mark function") @@ -1875,6 +2101,8 @@ def printSection(name): catalog.printFreeObjFunction() printSection("type identifier function") catalog.printTypeObjFunction() + printSection("type name function") + catalog.printNameFunctionBodies() elif args.type == 'debug_h': diff --git a/utils.sh b/utils.sh new file mode 100644 index 0000000..bbad0c5 --- /dev/null +++ b/utils.sh @@ -0,0 +1,3 @@ +fnd () { + grep -rwn $1 src +}