From e5e0de957c0572e47a386f9e0eea0aaa08199d8d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 19 Mar 2026 13:49:56 +0000 Subject: [PATCH 01/29] Release 0.0.6! --- docs/Home.md | 2 +- src/init.c | 4 +++- src/version.h | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/docs/Home.md b/docs/Home.md index b4dfc0e..be2fad6 100644 --- a/docs/Home.md +++ b/docs/Home.md @@ -172,7 +172,7 @@ The following functions are provided as of release 0.0.6: | subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. | | throw | FUNC | `(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).| | time | FUNC | `(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch. | -| try | SPFM | `(try forms... (catch symbol forms...))`: Doesn't work yet! | +| try | SPFM | `(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these. | | type | FUNC | `(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change. | | λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ function. | diff --git a/src/init.c b/src/init.c index b0d18da..0bfec24 100644 --- a/src/init.c +++ b/src/init.c @@ -537,7 +537,9 @@ int main( int argc, char *argv[] ) { bind_special( L"set!", L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.", &lisp_set_shriek ); - bind_special( L"try", L"", &lisp_try ); + bind_special( L"try", + L"`(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these.", + &lisp_try ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); diff --git a/src/version.h b/src/version.h index 462f9be..5638bc6 100644 --- a/src/version.h +++ b/src/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.6-SNAPSHOT" +#define VERSION "0.0.6" From 99d4794f3bb3deafbb83732799dd7b9ae631feb9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 19 Mar 2026 13:59:06 +0000 Subject: [PATCH 02/29] Upversioned the C source tree to '0.0.7-SNAPSHOT', but proposing to start experimental work towards 0.1.0 in separate source trees. --- Makefile | 2 +- src/{ => c}/arith/integer.c | 0 src/{ => c}/arith/integer.h | 0 src/{ => c}/arith/peano.c | 0 src/{ => c}/arith/peano.h | 0 src/{ => c}/arith/ratio.c | 0 src/{ => c}/arith/ratio.h | 0 src/{ => c}/arith/real.c | 0 src/{ => c}/arith/real.h | 0 src/{ => c}/authorise.c | 0 src/{ => c}/authorise.h | 0 src/{ => c}/debug.c | 0 src/{ => c}/debug.h | 0 src/{ => c}/init.c | 0 src/{ => c}/io/fopen.c | 0 src/{ => c}/io/fopen.h | 0 src/{ => c}/io/history.c | 0 src/{ => c}/io/history.h | 0 src/{ => c}/io/io.c | 0 src/{ => c}/io/io.h | 0 src/{ => c}/io/print.c | 0 src/{ => c}/io/print.h | 0 src/{ => c}/io/read.c | 0 src/{ => c}/io/read.h | 0 src/{ => c}/memory/conspage.c | 0 src/{ => c}/memory/conspage.h | 0 src/{ => c}/memory/consspaceobject.c | 0 src/{ => c}/memory/consspaceobject.h | 0 src/{ => c}/memory/cursor.c | 0 src/{ => c}/memory/cursor.h | Bin src/{ => c}/memory/dump.c | 0 src/{ => c}/memory/dump.h | 0 src/{ => c}/memory/hashmap.c | 0 src/{ => c}/memory/hashmap.h | 0 src/{ => c}/memory/lookup3.c | 0 src/{ => c}/memory/lookup3.h | 0 src/{ => c}/memory/stack.c | 0 src/{ => c}/memory/stack.h | 0 src/{ => c}/memory/vectorspace.c | 0 src/{ => c}/memory/vectorspace.h | 0 src/{ => c}/ops/equal.c | 0 src/{ => c}/ops/equal.h | 0 src/{ => c}/ops/intern.c | 0 src/{ => c}/ops/intern.h | 0 src/{ => c}/ops/lispops.c | 0 src/{ => c}/ops/lispops.h | 0 src/{ => c}/ops/loop.c | 0 src/{ => c}/ops/loop.h | 0 src/{ => c}/ops/meta.c | 0 src/{ => c}/ops/meta.h | 0 src/{ => c}/repl.c | 0 src/{ => c}/repl.h | 0 src/{ => c}/time/psse_time.c | 0 src/{ => c}/time/psse_time.h | 0 src/{ => c}/utils.c | 0 src/{ => c}/utils.h | 0 src/{ => c}/version.h | 2 +- 57 files changed, 2 insertions(+), 2 deletions(-) rename src/{ => c}/arith/integer.c (100%) rename src/{ => c}/arith/integer.h (100%) rename src/{ => c}/arith/peano.c (100%) rename src/{ => c}/arith/peano.h (100%) rename src/{ => c}/arith/ratio.c (100%) rename src/{ => c}/arith/ratio.h (100%) rename src/{ => c}/arith/real.c (100%) rename src/{ => c}/arith/real.h (100%) rename src/{ => c}/authorise.c (100%) rename src/{ => c}/authorise.h (100%) rename src/{ => c}/debug.c (100%) rename src/{ => c}/debug.h (100%) rename src/{ => c}/init.c (100%) rename src/{ => c}/io/fopen.c (100%) rename src/{ => c}/io/fopen.h (100%) rename src/{ => c}/io/history.c (100%) rename src/{ => c}/io/history.h (100%) rename src/{ => c}/io/io.c (100%) rename src/{ => c}/io/io.h (100%) rename src/{ => c}/io/print.c (100%) rename src/{ => c}/io/print.h (100%) rename src/{ => c}/io/read.c (100%) rename src/{ => c}/io/read.h (100%) rename src/{ => c}/memory/conspage.c (100%) rename src/{ => c}/memory/conspage.h (100%) rename src/{ => c}/memory/consspaceobject.c (100%) rename src/{ => c}/memory/consspaceobject.h (100%) rename src/{ => c}/memory/cursor.c (100%) rename src/{ => c}/memory/cursor.h (100%) rename src/{ => c}/memory/dump.c (100%) rename src/{ => c}/memory/dump.h (100%) rename src/{ => c}/memory/hashmap.c (100%) rename src/{ => c}/memory/hashmap.h (100%) rename src/{ => c}/memory/lookup3.c (100%) rename src/{ => c}/memory/lookup3.h (100%) rename src/{ => c}/memory/stack.c (100%) rename src/{ => c}/memory/stack.h (100%) rename src/{ => c}/memory/vectorspace.c (100%) rename src/{ => c}/memory/vectorspace.h (100%) rename src/{ => c}/ops/equal.c (100%) rename src/{ => c}/ops/equal.h (100%) rename src/{ => c}/ops/intern.c (100%) rename src/{ => c}/ops/intern.h (100%) rename src/{ => c}/ops/lispops.c (100%) rename src/{ => c}/ops/lispops.h (100%) rename src/{ => c}/ops/loop.c (100%) rename src/{ => c}/ops/loop.h (100%) rename src/{ => c}/ops/meta.c (100%) rename src/{ => c}/ops/meta.h (100%) rename src/{ => c}/repl.c (100%) rename src/{ => c}/repl.h (100%) rename src/{ => c}/time/psse_time.c (100%) rename src/{ => c}/time/psse_time.h (100%) rename src/{ => c}/utils.c (100%) rename src/{ => c}/utils.h (100%) rename src/{ => c}/version.h (87%) diff --git a/Makefile b/Makefile index bc2952b..b662908 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ TARGET ?= target/psse -SRC_DIRS ?= ./src +SRC_DIRS ?= ./src/c SRCS := $(shell find $(SRC_DIRS) -name *.cpp -or -name *.c -or -name *.s) HDRS := $(shell find $(SRC_DIRS) -name *.h) diff --git a/src/arith/integer.c b/src/c/arith/integer.c similarity index 100% rename from src/arith/integer.c rename to src/c/arith/integer.c diff --git a/src/arith/integer.h b/src/c/arith/integer.h similarity index 100% rename from src/arith/integer.h rename to src/c/arith/integer.h diff --git a/src/arith/peano.c b/src/c/arith/peano.c similarity index 100% rename from src/arith/peano.c rename to src/c/arith/peano.c diff --git a/src/arith/peano.h b/src/c/arith/peano.h similarity index 100% rename from src/arith/peano.h rename to src/c/arith/peano.h diff --git a/src/arith/ratio.c b/src/c/arith/ratio.c similarity index 100% rename from src/arith/ratio.c rename to src/c/arith/ratio.c diff --git a/src/arith/ratio.h b/src/c/arith/ratio.h similarity index 100% rename from src/arith/ratio.h rename to src/c/arith/ratio.h diff --git a/src/arith/real.c b/src/c/arith/real.c similarity index 100% rename from src/arith/real.c rename to src/c/arith/real.c diff --git a/src/arith/real.h b/src/c/arith/real.h similarity index 100% rename from src/arith/real.h rename to src/c/arith/real.h diff --git a/src/authorise.c b/src/c/authorise.c similarity index 100% rename from src/authorise.c rename to src/c/authorise.c diff --git a/src/authorise.h b/src/c/authorise.h similarity index 100% rename from src/authorise.h rename to src/c/authorise.h diff --git a/src/debug.c b/src/c/debug.c similarity index 100% rename from src/debug.c rename to src/c/debug.c diff --git a/src/debug.h b/src/c/debug.h similarity index 100% rename from src/debug.h rename to src/c/debug.h diff --git a/src/init.c b/src/c/init.c similarity index 100% rename from src/init.c rename to src/c/init.c diff --git a/src/io/fopen.c b/src/c/io/fopen.c similarity index 100% rename from src/io/fopen.c rename to src/c/io/fopen.c diff --git a/src/io/fopen.h b/src/c/io/fopen.h similarity index 100% rename from src/io/fopen.h rename to src/c/io/fopen.h diff --git a/src/io/history.c b/src/c/io/history.c similarity index 100% rename from src/io/history.c rename to src/c/io/history.c diff --git a/src/io/history.h b/src/c/io/history.h similarity index 100% rename from src/io/history.h rename to src/c/io/history.h diff --git a/src/io/io.c b/src/c/io/io.c similarity index 100% rename from src/io/io.c rename to src/c/io/io.c diff --git a/src/io/io.h b/src/c/io/io.h similarity index 100% rename from src/io/io.h rename to src/c/io/io.h diff --git a/src/io/print.c b/src/c/io/print.c similarity index 100% rename from src/io/print.c rename to src/c/io/print.c diff --git a/src/io/print.h b/src/c/io/print.h similarity index 100% rename from src/io/print.h rename to src/c/io/print.h diff --git a/src/io/read.c b/src/c/io/read.c similarity index 100% rename from src/io/read.c rename to src/c/io/read.c diff --git a/src/io/read.h b/src/c/io/read.h similarity index 100% rename from src/io/read.h rename to src/c/io/read.h diff --git a/src/memory/conspage.c b/src/c/memory/conspage.c similarity index 100% rename from src/memory/conspage.c rename to src/c/memory/conspage.c diff --git a/src/memory/conspage.h b/src/c/memory/conspage.h similarity index 100% rename from src/memory/conspage.h rename to src/c/memory/conspage.h diff --git a/src/memory/consspaceobject.c b/src/c/memory/consspaceobject.c similarity index 100% rename from src/memory/consspaceobject.c rename to src/c/memory/consspaceobject.c diff --git a/src/memory/consspaceobject.h b/src/c/memory/consspaceobject.h similarity index 100% rename from src/memory/consspaceobject.h rename to src/c/memory/consspaceobject.h diff --git a/src/memory/cursor.c b/src/c/memory/cursor.c similarity index 100% rename from src/memory/cursor.c rename to src/c/memory/cursor.c diff --git a/src/memory/cursor.h b/src/c/memory/cursor.h similarity index 100% rename from src/memory/cursor.h rename to src/c/memory/cursor.h diff --git a/src/memory/dump.c b/src/c/memory/dump.c similarity index 100% rename from src/memory/dump.c rename to src/c/memory/dump.c diff --git a/src/memory/dump.h b/src/c/memory/dump.h similarity index 100% rename from src/memory/dump.h rename to src/c/memory/dump.h diff --git a/src/memory/hashmap.c b/src/c/memory/hashmap.c similarity index 100% rename from src/memory/hashmap.c rename to src/c/memory/hashmap.c diff --git a/src/memory/hashmap.h b/src/c/memory/hashmap.h similarity index 100% rename from src/memory/hashmap.h rename to src/c/memory/hashmap.h diff --git a/src/memory/lookup3.c b/src/c/memory/lookup3.c similarity index 100% rename from src/memory/lookup3.c rename to src/c/memory/lookup3.c diff --git a/src/memory/lookup3.h b/src/c/memory/lookup3.h similarity index 100% rename from src/memory/lookup3.h rename to src/c/memory/lookup3.h diff --git a/src/memory/stack.c b/src/c/memory/stack.c similarity index 100% rename from src/memory/stack.c rename to src/c/memory/stack.c diff --git a/src/memory/stack.h b/src/c/memory/stack.h similarity index 100% rename from src/memory/stack.h rename to src/c/memory/stack.h diff --git a/src/memory/vectorspace.c b/src/c/memory/vectorspace.c similarity index 100% rename from src/memory/vectorspace.c rename to src/c/memory/vectorspace.c diff --git a/src/memory/vectorspace.h b/src/c/memory/vectorspace.h similarity index 100% rename from src/memory/vectorspace.h rename to src/c/memory/vectorspace.h diff --git a/src/ops/equal.c b/src/c/ops/equal.c similarity index 100% rename from src/ops/equal.c rename to src/c/ops/equal.c diff --git a/src/ops/equal.h b/src/c/ops/equal.h similarity index 100% rename from src/ops/equal.h rename to src/c/ops/equal.h diff --git a/src/ops/intern.c b/src/c/ops/intern.c similarity index 100% rename from src/ops/intern.c rename to src/c/ops/intern.c diff --git a/src/ops/intern.h b/src/c/ops/intern.h similarity index 100% rename from src/ops/intern.h rename to src/c/ops/intern.h diff --git a/src/ops/lispops.c b/src/c/ops/lispops.c similarity index 100% rename from src/ops/lispops.c rename to src/c/ops/lispops.c diff --git a/src/ops/lispops.h b/src/c/ops/lispops.h similarity index 100% rename from src/ops/lispops.h rename to src/c/ops/lispops.h diff --git a/src/ops/loop.c b/src/c/ops/loop.c similarity index 100% rename from src/ops/loop.c rename to src/c/ops/loop.c diff --git a/src/ops/loop.h b/src/c/ops/loop.h similarity index 100% rename from src/ops/loop.h rename to src/c/ops/loop.h diff --git a/src/ops/meta.c b/src/c/ops/meta.c similarity index 100% rename from src/ops/meta.c rename to src/c/ops/meta.c diff --git a/src/ops/meta.h b/src/c/ops/meta.h similarity index 100% rename from src/ops/meta.h rename to src/c/ops/meta.h diff --git a/src/repl.c b/src/c/repl.c similarity index 100% rename from src/repl.c rename to src/c/repl.c diff --git a/src/repl.h b/src/c/repl.h similarity index 100% rename from src/repl.h rename to src/c/repl.h diff --git a/src/time/psse_time.c b/src/c/time/psse_time.c similarity index 100% rename from src/time/psse_time.c rename to src/c/time/psse_time.c diff --git a/src/time/psse_time.h b/src/c/time/psse_time.h similarity index 100% rename from src/time/psse_time.h rename to src/c/time/psse_time.h diff --git a/src/utils.c b/src/c/utils.c similarity index 100% rename from src/utils.c rename to src/c/utils.c diff --git a/src/utils.h b/src/c/utils.h similarity index 100% rename from src/utils.h rename to src/c/utils.h diff --git a/src/version.h b/src/c/version.h similarity index 87% rename from src/version.h rename to src/c/version.h index 462f9be..6548d30 100644 --- a/src/version.h +++ b/src/c/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.6-SNAPSHOT" +#define VERSION "0.0.7-SNAPSHOT" From 09051a3e631ee045936656fb1898601dd56a3f12 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Mar 2026 18:47:00 +0000 Subject: [PATCH 03/29] Added an essay on the design of paged space objects; started experimenting in Zig. --- docs/Dont-know-dont-care.md | 71 ++++++++++++++++++++++++++ docs/Paged-space-objects.md | 69 +++++++++++++++++++++++++ src/zig/memory/page.zig | 9 ++++ src/zig/memory/paged-space-objects.zig | 17 ++++++ src/zig/memory/version.zig | 1 + 5 files changed, 167 insertions(+) create mode 100644 docs/Dont-know-dont-care.md create mode 100644 docs/Paged-space-objects.md create mode 100644 src/zig/memory/page.zig create mode 100644 src/zig/memory/paged-space-objects.zig create mode 100644 src/zig/memory/version.zig diff --git a/docs/Dont-know-dont-care.md b/docs/Dont-know-dont-care.md new file mode 100644 index 0000000..8c28fae --- /dev/null +++ b/docs/Dont-know-dont-care.md @@ -0,0 +1,71 @@ +# Don't know, don't care + +![The famous XKCD cartoon showing all modern digital infrastructure depending on a single person's spare-time project](https://imgs.xkcd.com/comics/dependency.png) + +One of the key design principles of the Post Scarcity computing project since my 2006 essay, [Post Scarcity Software](Post-scarcity-software.md), has been "don't know, don't care." + +The reason for this is simple. Modern computing systems are extremely complex. It is impossible for someone to be expert on every component of the system. To produce excellent work, it is necessary to specialise, to avoid being distracted by the necessary intricacies of the things on which your work depends, or of the (not yet conceived) intricacies of the work of other people which will ultimately depend on yours. It is necessary to trust. + +Randal Munroe's graphic which I've used to illustrate this essay looks like a joke, but it isn't. + +[Daniel Stenberg](https://en.wikipedia.org/wiki/Daniel_Stenberg) lives not in Nebraska, but in Sweden. He wrote what became [libcurl](https://curl.se/) in 1996, not 2003. He is still its primary maintainer. It pretty much is true to say that all modern digital infrastructure depends on it. It is a basic component which fetches data over a broad range of internet protocols, negotiating the appropriate security. There *are* alternatives to libcurl in (some) other software environments, but it is extremely widely used. Because it deals with security, it is critical; any vulnerability in it needs to be fixed quickly, because it has very major impact. + +The current [post-scarcity software environment](https://git.journeyman.cc/simon/post-scarcity) depends on libcurl, because of course it does. You certainly use libcurl yourself, even if you don't know it. You probably used it to fetch this document, in order to read it. + +I don't need to know the intricacies of URL schemae, or of Internet protocols, or of security, to the level of detail Daniel does. I've never even reviewed his code. I trust him to know what he's doing. + +Daniel's not alone, of course. Linus Torvalds wrote Linux in a university dorm room in Finland; now it powers the vast majority of servers on the Internet, and the vast majority of mobile phones in the world, and, quite incidentally, a cheap Chinese camera drone I bought to film bike rides. Linux is now an enormous project with thousands of contributors, but Linus is still the person who holds it together. [Rasmus Lerdorf](https://en.wikipedia.org/wiki/Rasmus_Lerdorf), from Greenland, wrote PHP to run his personal home page (the clue is in the name); Mark Zuckerberg used PHP to write Facebook; Michel Valdrighi used PHP to write something called b/cafelog, which Matt Mullenweg further developed into WordPress. + +There are thousands of others, of course; and, at the layer of hardware, on which all software depends, there are thousands of others whose names I do not even know. I'm vaguely aware of the architects of the ARM chip, but I had to look them up just now because I couldn't remember their names. I know that the ARM is at least a spiritual descendant of the 6502, but I don't know who designed that or anything of their story; and the antecedents behind that I don't know at all. The people behind all the many other chips which make up a working computer? I know nothing about them. + +(In any case, if one seriously wanted to build this thing, it would be better to have custom hardware — one would probably have to have custom hardware at least for the router — and if one were to have custom hardware it would be nice if it ran something very close to Lisp right down on the silicon, as the [Symbolics Ivory](https://gwern.net/doc/cs/hardware/1987-baker.pdf) chips did; so you probably wouldn't use ARM cores at all.) + +I have met and personally spoken with most of the people behind the Internet protocol stack, but I don't need to have done so in order to use it; and, indeed, the reason that [Jon Postel](https://en.wikipedia.org/wiki/Jon_Postel) bought me a beer was so that he could sit me down and very gently explain how badly I'd misunderstood something. + +----- + +But this is the point. We don't need to know, or have known, these people to build on their work. We don't have to, and cannot in detail, fully understand their work. There is simply too much of it, its complexity would overwhelm us. + +We don't know. We don't care. And that is a protective mechanism, a mechanism which is necessary in order to allow us to focus on our own task, if we are to produce excellent work. If we are to create a meaningful contribution on which the creators of the future can build. + +----- + +But there is a paradox, here, one of many conceptual paradoxes that I have encountered working on the Post Scarcity project. + +I am essentially a philosopher, or possibly a dilettante, rather than an engineer. When [Danny Hillis](https://longnow.org/people/board/danny0/) came up with the conception of the [Connection Machine](), a machine which is consciously one of the precursors of the post-scarcity project, he sought expert collaborators — and was so successful in doing so that [he persuaded Richard Feynman to join the project](https://longnow.org/ideas/richard-feynman-and-the-connection-machine/). I haven't recruited any collaborators. I don't have the social skills. And I don't have sufficient confidence that my idea is even good in itself. + +In building the first software prototype, I realised that I don't even properly understand what it means to [intern](http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/fun_intern.html) something. I realised that I still don't understand how in many Common Lisp implementations, for any integer number `n`, `(eq n n)` can return true. I note that in practice it *does*, but I don't understand how it's done. + +In the current post scarcity prototype, it *is* true for very small values of `n`, because I cache an array of small positive integers as an optimisation hack to prevent memory churn, but that's very special case and I cannot believe that Common Lisp implementations are doing it for significantly larger numbers of integers. I note that in SBCL, two bignums of equal value are not `eq`, so presumably SBCL is doing some sort of hack similar to mine, but I do not know how it works and I *shouldn't* care. + +Platonically, two instances of the same number *should be* the same object; but we do not live in a Platonic world and I don't want to. I'm perfectly happy that `eq` (which should perhaps be renamed `identical?`) should not work for numbers. + +What the behaviour is of the functions that we use, at whatever layer in the stack we work, does matter. We do need to know that. But what happens under the surface in order to deliver that behaviour? We don't need to know. We don't need to care. And we shouldn't, because that way leads to runaway recursion: behind every component, there is another component, which makes other compromises with physical matter which make good engineering sense to the people who understand that component well enough to design and to maintain it. + +The stack is not of infinite depth, of course. At its base is silicon, and traces of metals on silicon, and the behaviour of electrons as they interact with individual atoms in those traces. That is knowable, in principle, by someone. But there are sufficiently many layers in the stack, and sufficient complexity in each layer, that to have a good, clear, understanding of every layer is beyond the mental capacity of anyone I know, and, I believe, is generally beyond the mental capacity of any single person. + +----- + +But this is the point. The point is I do need to know, and do need to care, if I am to complete this project on my own; and I don't have sufficient faith in the utility of the project (or my ability to communicate that utility) that I believe that anyone else will ever care enough to contribute to it. + +And I don't have the skills, or the energy, or, indeed, the remaining time, to build any of it excellently. If it is to be built, I need collaborators; but I don't have the social skills to attract collaborators, or probably to work with them; and, actually, if I did have expert collaborators there would probably be no place for me in the project, because I don't have excellence at anything. + +----- + +I realise that I don't even really understand what a hypercube is. I describe my architecture as a hypercube. It is a cube because it has three axes, even though each of those axes is conceptually circular. Because the axes are circular, the thing can only be approximated in three dimensional space by using links of flexible wire or glass fibres to join things which, in three dimensional topology, cannot otherwise be joined; it is therefore slightly more than three dimensional while being considerably less than four dimensional. + +I *think* this is also Hillis' understanding of a hypercube, but I could be wrong on that. + +Of course, my architecture could be generalised to have four, or five, or six, or more circular axes + +[^1]: Could it? I'm reasonably confident that it could have *six* circular axes, but I cannot picture in my head how the grid intersections of a four-and-a-bit dimensional grid would work. + +, and this would result in each node having more immediate neighbours, which would potentially speed up computation by shortening hop paths. But I cannot help feeling that with each additional axis there comes a very substantial increase in the complexity of physically routing the wires, so three-and-a-bit dimensions may be as good as you practically get. + +I don't have the mathematical skill to mentally model how a computation would scale through this structure. It's more an 'if I build it I will find out whether this is computationally efficient' than an 'I have a principled idea of why this should be computationally efficient.' Intuitively, it *should be* more efficient than a [von Neumann architecture](https://en.wikipedia.org/wiki/Von_Neumann_architecture), and it's easy to give an account of how it can address (much) more memory than obvious developments of our current architectures. But I don't have a good feel of the actual time cost of copying data hoppity-hop across the structure, or the heuristics of when it will be beneficial to shard a computation between neighbours. + +----- + +Which brings me back to why I'm doing this. I'm doing it, principally, to quiet the noises in my brain; as an exercise in preventing my propensity for psychiatric melt-down from overwhelming me. It isn't, essentially, well-directed engineering. It is, essentially, self-prescribed therapy. There is no reason why anyone else should be interested. + +Which is, actually, rather solipsistic. Not a thought I like! \ No newline at end of file diff --git a/docs/Paged-space-objects.md b/docs/Paged-space-objects.md new file mode 100644 index 0000000..6885b70 --- /dev/null +++ b/docs/Paged-space-objects.md @@ -0,0 +1,69 @@ +# Paged space objects + +*Antecedents for this essay: + +1. [Reference counting, and the garbage collection of equal sized objects](https://www.journeyman.cc/blog/posts-output/2013-08-25-reference-counting-and-the-garbage-collection-of-equal-sized-objects/); +2. [Vector space, Pages, Mark-but-don't-sweep, and the world's slowest ever rapid prototype](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/). + +The post-scarcity software environment needs to store data in objects. Much of the data will be in objects which will fit in the memory footpring ot a cons cell, but some won't, and those that won't will be in a variety of sizes. + +Conventionally, operating systems allocate memory as a heap. If you allocate objects of differing sizes from a heap, the heap becoms fragmented, like a [Sierpiński carpet] or [Cantor dust](https://en.wikipedia.org/wiki/Cantor_set#Cantor_dust) — there are lots of holes in it, but it becomes increasingly difficult to find a hole which will fit anything large. + +If we store our objects in containers of standardised sizes, then, for each of those standardised sizes, we can maintain a freelisp of currently unused containers, from which new containers can be allocated. But we still don't want those relatively small objects floating around independently in memory, because we'll still get the fragmentation problem. + +This was the initial motivation behind [cons pages](https://www.journeyman.cc/post-scarcity/html/conspage_8h.html#structcons__page). However, quite early in the development of the prototype, it became obvious that we were allocating and deallocating very many stack frames, and many hash tables, neither of which fit in the memory footprint of a cons cell; and that, going forward, it was likely that we would generate many other sorts of larger objects. + +My first thought was to generalise the cons page idea, and generate pages of equal sized objects; that is, one set of pages for objects (like cons cells) with a two word payload, one for objects with a four word payload, one for objects with an eight word payload, and so on. The key idea was that each of these pages would be of equal size, so that if, say, we needed to allocate more eight word objects and there was a page for two word objects currently empty, the memory footprint could be reassigned: the hole in the carpet would be the right size. + +If we have to allocate an object which needs a five word payload, it will have to be allocated as an eight word object in an eight word object page, which wastes some memory, for the lifetime of that object; but that memory can be efficiently recovered at the end of life, and the heap doesn't fragment. Any page will, at any time, be partly empty, which wastes more memory, but again, that memory can later be efficiently reused. + +The potential problem is that you might end up, say, with many pages for two word objects each of which were partly empty, and have nowhere to allocate new eight word objects; and if this does prove in practice to be a problem, then a mark and sweep garbage collector — something I *really* don't want — will be needed. But that is not a problem for just now. + +## Efficiently allocating pages + +I cannot see how we can efficiently manage pages without each page having some housekeeping data, as every other data object in the system must have a header for housekeeping data. It may be that I am just stuck in my thinking and that the header for pages is not needed, but I *think* it is, and I am going to proceed for now as though it were. + +The problem here is that, on an essentially binary machine, it makes sense to allocate things in powers of two; and, as that makes sense at the level of allocating objects in pages, so it makes sense at the level of the basic heap allocator. I'm proposing to allocate objects in standardised containers of these payload sizes: + +| Tag | | | Size of payload | | +| ---- | ----------- | --- | --------------- | --------------- | +| Bits | Field value | Hex | Number of words | Number of bytes | +| ---- | ----------- | --- | --------------- | --------------- | +| 0000 | 0 | 0 | 1 | 8 | +| 0001 | 1 | 1 | 2 | 16 | +| 0010 | 2 | 2 | 4 | 32 | +| 0011 | 3 | 3 | 8 | 64 | +| 0100 | 4 | 4 | 16 | 128 | +| 0101 | 5 | 5 | 32 | 256 | +| 0110 | 6 | 6 | 64 | 512 | +| 0111 | 7 | 7 | 128 | 1024 | +| 1000 | 8 | 8 | 256 | 2048 | +| 1001 | 9 | 9 | 512 | 4096 | +| 1010 | 10 | A | 1024 | 8192 | +| 1011 | 11 | B | 2048 | 16384 | +| 1100 | 12 | C | 4096 | 32768 | +| 1101 | 13 | D | 8192 | 65536 | +| 1110 | 14 | E | 16384 | 131072 | +| 1111 | 15 | F | 32768 | 262144 | + +This scheme allows me to store the allocation payload size of an object, and consequently the type of a page intended to store objects of that size, in four bits, which is pretty economic. But it's not nothing, and there's a cost to this. The irreducable minimum size of header that objects in the system need to have — in my current design — is two words. So the allocation size of an object with a payload of two words, is four words; but the allocation size of an object with a payload size of thirty two thousand, seven hundred and sixty eight words, is thirty two thousand, seven hundred and seventy words. + +Why does that matter? + +Well, suppose we allocate pages of a megabyte, and we take out of that megabyte a two word page header. Then we can fit 262,143 objects with a payload size of two into that page, and waste only two words. But we can fit only three objects of size 262,144 into such a page, and we waste 262,138 words, which feels bad. + +When I first realised this, I thought, well, the idea was nice, but it doesn't work. There are three potential solutions, each of which feel inelegant to me: + +1. We simply ignore the wasted space; +2. Given that the overwhelming majority of objects used by the system, especially of transient objects, will be of payload size two (allocation size four), we fill all 'spare' space in pages with objects of payload size two, and push them all onto the freelist of objects of payload size two; + (this feels ugly to me because it breaks the idea that all objects on a given page should be of the same size) +3. We treat the size signature of the page — that four bit value — as being related not to the payload size of the ojects to be allocated into the page, but to the allocation size; so that cons cells, with a payload size of two and thus an allocation size of four, would be allocated into pages with a size tag of 0001 and not a size tag of 0010; and we store the housekeeping data for the page itself (waves hands vaguely) somewhere else; + (this feels ugly to me because, for me, the size of an object is its payload size, and I'm deeply bothered by things foating about randomly in memory without identifying information). + +There's a wee bit of autistic insistence on order in my design choices there, that I should not get hung up on. Some objects really do need allocation sizes in memory which are powers of two, but most in fact don't. Currently, the only objects which I commonly allocate and deallocate which are not cons-space objects — not objects with a payload size of two — are stack frames (current payload size 12) and hash tables (current payload size variable, but defaults to 34). + +If we're storing the (encoded) allocation size of each object in the tag of the object — which I think that in the 0.1.0 prototype we will, and if every object on any given page is of the same size, which seems to me a good plan, then I'm not sure that we actually need to store any other housekeeping data on the page, because the header of every object is the same size, and the header of every object in the page holds the critical bit of housekeeping information about the page, so we can always get that value from the header of the first object in the page. + +If we take these two pragmatic compromises together — that the size encoded in the tag of an object is its allocation saize not its payload size, and that the allocation size in the first object on a page is the allocation size for that page — then every page can fit an exact number of objects with no space wasted. + +That's not beautiful but I think it's sensible. diff --git a/src/zig/memory/page.zig b/src/zig/memory/page.zig new file mode 100644 index 0000000..25ff3e2 --- /dev/null +++ b/src/zig/memory/page.zig @@ -0,0 +1,9 @@ +/// A Page is an area of memory in which objects are stored. Every page has +/// a header, and every page header has common structure. The objects stored +/// on any page are all PagedObjects, q.v. and, on any given page, all the +/// objects stored on that page are of the same size. +const Page = struct { + const content = union { + const bytes = [1048576]u8; + }; +}; diff --git a/src/zig/memory/paged-space-objects.zig b/src/zig/memory/paged-space-objects.zig new file mode 100644 index 0000000..8c06f5c --- /dev/null +++ b/src/zig/memory/paged-space-objects.zig @@ -0,0 +1,17 @@ +/// Header for objects which are allocated in pages. +const PagedSpaceObjectHeader = struct { + const tag = union { + const bytes = [4]u8; + const value = u32; + }; + var count = u32; + const acl = u64; // later when we have a pointer object defined this will be substituted +}; + +const PSO4: type = struct { + const PagedSpaceObjectHeader: header; + const payload = union { + var bytes: [8]u8; + var words: [2]u64; + }; +}; diff --git a/src/zig/memory/version.zig b/src/zig/memory/version.zig new file mode 100644 index 0000000..ecf82a9 --- /dev/null +++ b/src/zig/memory/version.zig @@ -0,0 +1 @@ +const version: []const u8 = "0.1.0-SNAPSHOT"; From 914c35ead0510d6ae3e32336cd94e6f890db8287 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 24 Mar 2026 16:25:09 +0000 Subject: [PATCH 04/29] Moved legacy code into archive, ready for a new rapid(?) prototype. I may regret doing this! --- {src => archive}/c/arith/integer.c | 0 {src => archive}/c/arith/integer.h | 0 {src => archive}/c/arith/peano.c | 0 {src => archive}/c/arith/peano.h | 0 {src => archive}/c/arith/ratio.c | 0 {src => archive}/c/arith/ratio.h | 0 {src => archive}/c/arith/real.c | 0 {src => archive}/c/arith/real.h | 0 {src => archive}/c/authorise.c | 0 {src => archive}/c/authorise.h | 0 {src => archive}/c/debug.c | 0 {src => archive}/c/debug.h | 0 {src => archive}/c/init.c | 0 {src => archive}/c/io/fopen.c | 0 {src => archive}/c/io/fopen.h | 0 {src => archive}/c/io/history.c | 0 {src => archive}/c/io/history.h | 0 {src => archive}/c/io/io.c | 0 {src => archive}/c/io/io.h | 0 {src => archive}/c/io/print.c | 0 {src => archive}/c/io/print.h | 0 {src => archive}/c/io/read.c | 0 {src => archive}/c/io/read.h | 0 {src => archive}/c/memory/conspage.c | 0 {src => archive}/c/memory/conspage.h | 0 {src => archive}/c/memory/consspaceobject.c | 0 {src => archive}/c/memory/consspaceobject.h | 0 {src => archive}/c/memory/cursor.c | 0 {src => archive}/c/memory/cursor.h | Bin {src => archive}/c/memory/dump.c | 0 {src => archive}/c/memory/dump.h | 0 {src => archive}/c/memory/hashmap.c | 0 {src => archive}/c/memory/hashmap.h | 0 {src => archive}/c/memory/lookup3.c | 0 {src => archive}/c/memory/lookup3.h | 0 {src => archive}/c/memory/stack.c | 0 {src => archive}/c/memory/stack.h | 0 {src => archive}/c/memory/vectorspace.c | 0 {src => archive}/c/memory/vectorspace.h | 0 {src => archive}/c/ops/equal.c | 0 {src => archive}/c/ops/equal.h | 0 {src => archive}/c/ops/intern.c | 0 {src => archive}/c/ops/intern.h | 0 {src => archive}/c/ops/lispops.c | 0 {src => archive}/c/ops/lispops.h | 0 {src => archive}/c/ops/loop.c | 0 {src => archive}/c/ops/loop.h | 0 {src => archive}/c/ops/meta.c | 0 {src => archive}/c/ops/meta.h | 0 {src => archive}/c/repl.c | 0 {src => archive}/c/repl.h | 0 {src => archive}/c/time/psse_time.c | 0 {src => archive}/c/time/psse_time.h | 0 {src => archive}/c/utils.c | 0 {src => archive}/c/utils.h | 0 {src => archive}/c/version.h | 0 {unit-tests => archive/unit-tests}/add.sh | 0 .../allocation-tests/allocation-tester.sh | 0 .../allocation-tests/allocation-tests.csv | 0 .../allocation-tests/allocation-tests.ods | Bin 0 -> 32991 bytes .../allocation-tests/feature-2.test.tmp | 30 +++++++++ archive/unit-tests/allocation-tests/grep.bb | 19 ++++++ .../unit-tests}/allocation-tests/test-forms | 0 {unit-tests => archive/unit-tests}/append.sh | 0 {unit-tests => archive/unit-tests}/apply.sh | 0 archive/unit-tests/assoc.sh | 60 ++++++++++++++++++ .../unit-tests}/bignum-add.sh | 0 .../unit-tests}/bignum-expt.sh | 0 .../unit-tests}/bignum-print.sh | 0 .../unit-tests}/bignum-subtract.sh | 0 {unit-tests => archive/unit-tests}/bignum.sh | 0 .../unit-tests}/complex-list.sh | 0 {unit-tests => archive/unit-tests}/cond.sh | 0 .../unit-tests}/empty-list.sh | 0 .../unit-tests}/empty-string.sh | 0 {unit-tests => archive/unit-tests}/equal.sh | 0 .../unit-tests}/eval-integer.sh | 0 .../unit-tests}/eval-quote-sexpr.sh | 0 .../unit-tests}/eval-quote-symbol.sh | 0 .../unit-tests}/eval-real.sh | 0 .../unit-tests}/eval-string.sh | 0 {unit-tests => archive/unit-tests}/fred.sh | 0 .../unit-tests}/integer-allocation.sh | 0 {unit-tests => archive/unit-tests}/integer.sh | 0 .../unit-tests}/interpreter.sh | 0 {unit-tests => archive/unit-tests}/lambda.sh | 0 {unit-tests => archive/unit-tests}/let.sh | 0 .../unit-tests}/list-test.sh | 0 .../unit-tests}/many-args.sh | 0 {unit-tests => archive/unit-tests}/map.sh | 0 archive/unit-tests/mapcar.sh | 31 +++++++++ {unit-tests => archive/unit-tests}/memberp.sh | 0 {unit-tests => archive/unit-tests}/memory.sh | 0 .../unit-tests}/multiply.sh | 0 {unit-tests => archive/unit-tests}/nil.sh | 0 {unit-tests => archive/unit-tests}/nlambda.sh | 0 .../unit-tests}/path-notation.sh | 0 {unit-tests => archive/unit-tests}/progn.sh | 0 {unit-tests => archive/unit-tests}/quote.sh | 0 .../unit-tests}/quoted-list.sh | 0 .../unit-tests}/ratio-addition.sh | 0 .../unit-tests}/recursion.sh | 0 {unit-tests => archive/unit-tests}/reverse.sh | 0 .../unit-tests}/simple-list.sh | 0 {unit-tests => archive/unit-tests}/slurp.sh | 0 .../unit-tests}/string-allocation.sh | 0 .../unit-tests}/string-cons.sh | 0 .../unit-tests}/string-with-spaces.sh | 0 .../unit-tests}/subtract.sh | 0 {unit-tests => archive/unit-tests}/try.sh | 0 {unit-tests => archive/unit-tests}/varargs.sh | 0 .../unit-tests}/wide-character.sh | 0 docs/Paged-space-objects.md | 2 +- docs/State-of-play.md | 24 +++++++ 114 files changed, 165 insertions(+), 1 deletion(-) rename {src => archive}/c/arith/integer.c (100%) rename {src => archive}/c/arith/integer.h (100%) rename {src => archive}/c/arith/peano.c (100%) rename {src => archive}/c/arith/peano.h (100%) rename {src => archive}/c/arith/ratio.c (100%) rename {src => archive}/c/arith/ratio.h (100%) rename {src => archive}/c/arith/real.c (100%) rename {src => archive}/c/arith/real.h (100%) rename {src => archive}/c/authorise.c (100%) rename {src => archive}/c/authorise.h (100%) rename {src => archive}/c/debug.c (100%) rename {src => archive}/c/debug.h (100%) rename {src => archive}/c/init.c (100%) rename {src => archive}/c/io/fopen.c (100%) rename {src => archive}/c/io/fopen.h (100%) rename {src => archive}/c/io/history.c (100%) rename {src => archive}/c/io/history.h (100%) rename {src => archive}/c/io/io.c (100%) rename {src => archive}/c/io/io.h (100%) rename {src => archive}/c/io/print.c (100%) rename {src => archive}/c/io/print.h (100%) rename {src => archive}/c/io/read.c (100%) rename {src => archive}/c/io/read.h (100%) rename {src => archive}/c/memory/conspage.c (100%) rename {src => archive}/c/memory/conspage.h (100%) rename {src => archive}/c/memory/consspaceobject.c (100%) rename {src => archive}/c/memory/consspaceobject.h (100%) rename {src => archive}/c/memory/cursor.c (100%) rename {src => archive}/c/memory/cursor.h (100%) rename {src => archive}/c/memory/dump.c (100%) rename {src => archive}/c/memory/dump.h (100%) rename {src => archive}/c/memory/hashmap.c (100%) rename {src => archive}/c/memory/hashmap.h (100%) rename {src => archive}/c/memory/lookup3.c (100%) rename {src => archive}/c/memory/lookup3.h (100%) rename {src => archive}/c/memory/stack.c (100%) rename {src => archive}/c/memory/stack.h (100%) rename {src => archive}/c/memory/vectorspace.c (100%) rename {src => archive}/c/memory/vectorspace.h (100%) rename {src => archive}/c/ops/equal.c (100%) rename {src => archive}/c/ops/equal.h (100%) rename {src => archive}/c/ops/intern.c (100%) rename {src => archive}/c/ops/intern.h (100%) rename {src => archive}/c/ops/lispops.c (100%) rename {src => archive}/c/ops/lispops.h (100%) rename {src => archive}/c/ops/loop.c (100%) rename {src => archive}/c/ops/loop.h (100%) rename {src => archive}/c/ops/meta.c (100%) rename {src => archive}/c/ops/meta.h (100%) rename {src => archive}/c/repl.c (100%) rename {src => archive}/c/repl.h (100%) rename {src => archive}/c/time/psse_time.c (100%) rename {src => archive}/c/time/psse_time.h (100%) rename {src => archive}/c/utils.c (100%) rename {src => archive}/c/utils.h (100%) rename {src => archive}/c/version.h (100%) rename {unit-tests => archive/unit-tests}/add.sh (100%) rename {unit-tests => archive/unit-tests}/allocation-tests/allocation-tester.sh (100%) rename {unit-tests => archive/unit-tests}/allocation-tests/allocation-tests.csv (100%) create mode 100644 archive/unit-tests/allocation-tests/allocation-tests.ods create mode 100644 archive/unit-tests/allocation-tests/feature-2.test.tmp create mode 100755 archive/unit-tests/allocation-tests/grep.bb rename {unit-tests => archive/unit-tests}/allocation-tests/test-forms (100%) rename {unit-tests => archive/unit-tests}/append.sh (100%) rename {unit-tests => archive/unit-tests}/apply.sh (100%) create mode 100644 archive/unit-tests/assoc.sh rename {unit-tests => archive/unit-tests}/bignum-add.sh (100%) rename {unit-tests => archive/unit-tests}/bignum-expt.sh (100%) rename {unit-tests => archive/unit-tests}/bignum-print.sh (100%) rename {unit-tests => archive/unit-tests}/bignum-subtract.sh (100%) rename {unit-tests => archive/unit-tests}/bignum.sh (100%) rename {unit-tests => archive/unit-tests}/complex-list.sh (100%) rename {unit-tests => archive/unit-tests}/cond.sh (100%) rename {unit-tests => archive/unit-tests}/empty-list.sh (100%) rename {unit-tests => archive/unit-tests}/empty-string.sh (100%) rename {unit-tests => archive/unit-tests}/equal.sh (100%) rename {unit-tests => archive/unit-tests}/eval-integer.sh (100%) rename {unit-tests => archive/unit-tests}/eval-quote-sexpr.sh (100%) rename {unit-tests => archive/unit-tests}/eval-quote-symbol.sh (100%) rename {unit-tests => archive/unit-tests}/eval-real.sh (100%) rename {unit-tests => archive/unit-tests}/eval-string.sh (100%) rename {unit-tests => archive/unit-tests}/fred.sh (100%) rename {unit-tests => archive/unit-tests}/integer-allocation.sh (100%) rename {unit-tests => archive/unit-tests}/integer.sh (100%) rename {unit-tests => archive/unit-tests}/interpreter.sh (100%) rename {unit-tests => archive/unit-tests}/lambda.sh (100%) rename {unit-tests => archive/unit-tests}/let.sh (100%) rename {unit-tests => archive/unit-tests}/list-test.sh (100%) rename {unit-tests => archive/unit-tests}/many-args.sh (100%) rename {unit-tests => archive/unit-tests}/map.sh (100%) create mode 100644 archive/unit-tests/mapcar.sh rename {unit-tests => archive/unit-tests}/memberp.sh (100%) rename {unit-tests => archive/unit-tests}/memory.sh (100%) rename {unit-tests => archive/unit-tests}/multiply.sh (100%) rename {unit-tests => archive/unit-tests}/nil.sh (100%) rename {unit-tests => archive/unit-tests}/nlambda.sh (100%) rename {unit-tests => archive/unit-tests}/path-notation.sh (100%) rename {unit-tests => archive/unit-tests}/progn.sh (100%) rename {unit-tests => archive/unit-tests}/quote.sh (100%) rename {unit-tests => archive/unit-tests}/quoted-list.sh (100%) rename {unit-tests => archive/unit-tests}/ratio-addition.sh (100%) rename {unit-tests => archive/unit-tests}/recursion.sh (100%) rename {unit-tests => archive/unit-tests}/reverse.sh (100%) rename {unit-tests => archive/unit-tests}/simple-list.sh (100%) rename {unit-tests => archive/unit-tests}/slurp.sh (100%) rename {unit-tests => archive/unit-tests}/string-allocation.sh (100%) rename {unit-tests => archive/unit-tests}/string-cons.sh (100%) rename {unit-tests => archive/unit-tests}/string-with-spaces.sh (100%) rename {unit-tests => archive/unit-tests}/subtract.sh (100%) rename {unit-tests => archive/unit-tests}/try.sh (100%) rename {unit-tests => archive/unit-tests}/varargs.sh (100%) rename {unit-tests => archive/unit-tests}/wide-character.sh (100%) diff --git a/src/c/arith/integer.c b/archive/c/arith/integer.c similarity index 100% rename from src/c/arith/integer.c rename to archive/c/arith/integer.c diff --git a/src/c/arith/integer.h b/archive/c/arith/integer.h similarity index 100% rename from src/c/arith/integer.h rename to archive/c/arith/integer.h diff --git a/src/c/arith/peano.c b/archive/c/arith/peano.c similarity index 100% rename from src/c/arith/peano.c rename to archive/c/arith/peano.c diff --git a/src/c/arith/peano.h b/archive/c/arith/peano.h similarity index 100% rename from src/c/arith/peano.h rename to archive/c/arith/peano.h diff --git a/src/c/arith/ratio.c b/archive/c/arith/ratio.c similarity index 100% rename from src/c/arith/ratio.c rename to archive/c/arith/ratio.c diff --git a/src/c/arith/ratio.h b/archive/c/arith/ratio.h similarity index 100% rename from src/c/arith/ratio.h rename to archive/c/arith/ratio.h diff --git a/src/c/arith/real.c b/archive/c/arith/real.c similarity index 100% rename from src/c/arith/real.c rename to archive/c/arith/real.c diff --git a/src/c/arith/real.h b/archive/c/arith/real.h similarity index 100% rename from src/c/arith/real.h rename to archive/c/arith/real.h diff --git a/src/c/authorise.c b/archive/c/authorise.c similarity index 100% rename from src/c/authorise.c rename to archive/c/authorise.c diff --git a/src/c/authorise.h b/archive/c/authorise.h similarity index 100% rename from src/c/authorise.h rename to archive/c/authorise.h diff --git a/src/c/debug.c b/archive/c/debug.c similarity index 100% rename from src/c/debug.c rename to archive/c/debug.c diff --git a/src/c/debug.h b/archive/c/debug.h similarity index 100% rename from src/c/debug.h rename to archive/c/debug.h diff --git a/src/c/init.c b/archive/c/init.c similarity index 100% rename from src/c/init.c rename to archive/c/init.c diff --git a/src/c/io/fopen.c b/archive/c/io/fopen.c similarity index 100% rename from src/c/io/fopen.c rename to archive/c/io/fopen.c diff --git a/src/c/io/fopen.h b/archive/c/io/fopen.h similarity index 100% rename from src/c/io/fopen.h rename to archive/c/io/fopen.h diff --git a/src/c/io/history.c b/archive/c/io/history.c similarity index 100% rename from src/c/io/history.c rename to archive/c/io/history.c diff --git a/src/c/io/history.h b/archive/c/io/history.h similarity index 100% rename from src/c/io/history.h rename to archive/c/io/history.h diff --git a/src/c/io/io.c b/archive/c/io/io.c similarity index 100% rename from src/c/io/io.c rename to archive/c/io/io.c diff --git a/src/c/io/io.h b/archive/c/io/io.h similarity index 100% rename from src/c/io/io.h rename to archive/c/io/io.h diff --git a/src/c/io/print.c b/archive/c/io/print.c similarity index 100% rename from src/c/io/print.c rename to archive/c/io/print.c diff --git a/src/c/io/print.h b/archive/c/io/print.h similarity index 100% rename from src/c/io/print.h rename to archive/c/io/print.h diff --git a/src/c/io/read.c b/archive/c/io/read.c similarity index 100% rename from src/c/io/read.c rename to archive/c/io/read.c diff --git a/src/c/io/read.h b/archive/c/io/read.h similarity index 100% rename from src/c/io/read.h rename to archive/c/io/read.h diff --git a/src/c/memory/conspage.c b/archive/c/memory/conspage.c similarity index 100% rename from src/c/memory/conspage.c rename to archive/c/memory/conspage.c diff --git a/src/c/memory/conspage.h b/archive/c/memory/conspage.h similarity index 100% rename from src/c/memory/conspage.h rename to archive/c/memory/conspage.h diff --git a/src/c/memory/consspaceobject.c b/archive/c/memory/consspaceobject.c similarity index 100% rename from src/c/memory/consspaceobject.c rename to archive/c/memory/consspaceobject.c diff --git a/src/c/memory/consspaceobject.h b/archive/c/memory/consspaceobject.h similarity index 100% rename from src/c/memory/consspaceobject.h rename to archive/c/memory/consspaceobject.h diff --git a/src/c/memory/cursor.c b/archive/c/memory/cursor.c similarity index 100% rename from src/c/memory/cursor.c rename to archive/c/memory/cursor.c diff --git a/src/c/memory/cursor.h b/archive/c/memory/cursor.h similarity index 100% rename from src/c/memory/cursor.h rename to archive/c/memory/cursor.h diff --git a/src/c/memory/dump.c b/archive/c/memory/dump.c similarity index 100% rename from src/c/memory/dump.c rename to archive/c/memory/dump.c diff --git a/src/c/memory/dump.h b/archive/c/memory/dump.h similarity index 100% rename from src/c/memory/dump.h rename to archive/c/memory/dump.h diff --git a/src/c/memory/hashmap.c b/archive/c/memory/hashmap.c similarity index 100% rename from src/c/memory/hashmap.c rename to archive/c/memory/hashmap.c diff --git a/src/c/memory/hashmap.h b/archive/c/memory/hashmap.h similarity index 100% rename from src/c/memory/hashmap.h rename to archive/c/memory/hashmap.h diff --git a/src/c/memory/lookup3.c b/archive/c/memory/lookup3.c similarity index 100% rename from src/c/memory/lookup3.c rename to archive/c/memory/lookup3.c diff --git a/src/c/memory/lookup3.h b/archive/c/memory/lookup3.h similarity index 100% rename from src/c/memory/lookup3.h rename to archive/c/memory/lookup3.h diff --git a/src/c/memory/stack.c b/archive/c/memory/stack.c similarity index 100% rename from src/c/memory/stack.c rename to archive/c/memory/stack.c diff --git a/src/c/memory/stack.h b/archive/c/memory/stack.h similarity index 100% rename from src/c/memory/stack.h rename to archive/c/memory/stack.h diff --git a/src/c/memory/vectorspace.c b/archive/c/memory/vectorspace.c similarity index 100% rename from src/c/memory/vectorspace.c rename to archive/c/memory/vectorspace.c diff --git a/src/c/memory/vectorspace.h b/archive/c/memory/vectorspace.h similarity index 100% rename from src/c/memory/vectorspace.h rename to archive/c/memory/vectorspace.h diff --git a/src/c/ops/equal.c b/archive/c/ops/equal.c similarity index 100% rename from src/c/ops/equal.c rename to archive/c/ops/equal.c diff --git a/src/c/ops/equal.h b/archive/c/ops/equal.h similarity index 100% rename from src/c/ops/equal.h rename to archive/c/ops/equal.h diff --git a/src/c/ops/intern.c b/archive/c/ops/intern.c similarity index 100% rename from src/c/ops/intern.c rename to archive/c/ops/intern.c diff --git a/src/c/ops/intern.h b/archive/c/ops/intern.h similarity index 100% rename from src/c/ops/intern.h rename to archive/c/ops/intern.h diff --git a/src/c/ops/lispops.c b/archive/c/ops/lispops.c similarity index 100% rename from src/c/ops/lispops.c rename to archive/c/ops/lispops.c diff --git a/src/c/ops/lispops.h b/archive/c/ops/lispops.h similarity index 100% rename from src/c/ops/lispops.h rename to archive/c/ops/lispops.h diff --git a/src/c/ops/loop.c b/archive/c/ops/loop.c similarity index 100% rename from src/c/ops/loop.c rename to archive/c/ops/loop.c diff --git a/src/c/ops/loop.h b/archive/c/ops/loop.h similarity index 100% rename from src/c/ops/loop.h rename to archive/c/ops/loop.h diff --git a/src/c/ops/meta.c b/archive/c/ops/meta.c similarity index 100% rename from src/c/ops/meta.c rename to archive/c/ops/meta.c diff --git a/src/c/ops/meta.h b/archive/c/ops/meta.h similarity index 100% rename from src/c/ops/meta.h rename to archive/c/ops/meta.h diff --git a/src/c/repl.c b/archive/c/repl.c similarity index 100% rename from src/c/repl.c rename to archive/c/repl.c diff --git a/src/c/repl.h b/archive/c/repl.h similarity index 100% rename from src/c/repl.h rename to archive/c/repl.h diff --git a/src/c/time/psse_time.c b/archive/c/time/psse_time.c similarity index 100% rename from src/c/time/psse_time.c rename to archive/c/time/psse_time.c diff --git a/src/c/time/psse_time.h b/archive/c/time/psse_time.h similarity index 100% rename from src/c/time/psse_time.h rename to archive/c/time/psse_time.h diff --git a/src/c/utils.c b/archive/c/utils.c similarity index 100% rename from src/c/utils.c rename to archive/c/utils.c diff --git a/src/c/utils.h b/archive/c/utils.h similarity index 100% rename from src/c/utils.h rename to archive/c/utils.h diff --git a/src/c/version.h b/archive/c/version.h similarity index 100% rename from src/c/version.h rename to archive/c/version.h diff --git a/unit-tests/add.sh b/archive/unit-tests/add.sh similarity index 100% rename from unit-tests/add.sh rename to archive/unit-tests/add.sh diff --git a/unit-tests/allocation-tests/allocation-tester.sh b/archive/unit-tests/allocation-tests/allocation-tester.sh similarity index 100% rename from unit-tests/allocation-tests/allocation-tester.sh rename to archive/unit-tests/allocation-tests/allocation-tester.sh diff --git a/unit-tests/allocation-tests/allocation-tests.csv b/archive/unit-tests/allocation-tests/allocation-tests.csv similarity index 100% rename from unit-tests/allocation-tests/allocation-tests.csv rename to archive/unit-tests/allocation-tests/allocation-tests.csv diff --git a/archive/unit-tests/allocation-tests/allocation-tests.ods b/archive/unit-tests/allocation-tests/allocation-tests.ods new file mode 100644 index 0000000000000000000000000000000000000000..32a99d6041b03db1cda8c56580a2b228911ee8a8 GIT binary patch literal 32991 zcmbTd1yEdF)&&X#cMb0D9^BpCElA_;PH@-Y?(Xgm!69gHcXx+JzWL{y%+$Q8dhb?s z^{qa=_FjAKb8hb=Eid&66cq>v5(wxRR75+_k|T@`2ngu+>*FIJD>EyAqnj;2-`3XB z%uwIa%*LAD+1iNCM&H5AfzHMjU~Ob$=wt=3cBFH#wFl@MIhXv@A2pCUwd~DGMaMuG!0`w$?+7P`15WP+P2m%q2 za{NgMA?J`mS$@3 zGEr~t1nb19S%I5z^W3uPb#Fi1p_Ta<=e0swcka>Van9SeK6$pbdbWS2v*^0Gphh!> z#2oN4iexB!w2r<2Rr7#MNLPxo^%5#5T5VS@AHrpNuPu3e^h9Wtknd@Qbjs?K+a#9o zfMgX}RH2Pdupl#le>WoG9jth-z#<1&E9&H>aLWcZfUw$~Q56vh9BNS!S?Q9g|3T9P z54QC)w6wjqP7qB`E8pXJwIpnl@X#Nh(-G2)V~Z{ThuLFtls^qs@QD2xNxJ!;J_o-4`PB}u%s(SB zDH{1RXl9u|?HnEc$zX+?c~tmn6^!Pek=~%Blz-eCRkdY~@qMzPy!kpP$?Qp)8%(!syXQwtU(w zOuomQm5xaqSJE}bXSHNiP3;fuaOGZn$$}T_bO9))cnXQO5w8O-%89c$-%E(I5Z3mF z$T_NPcbHwOT{(|Jh_ehiHipRIt?lx^ykLoyy6WdNmCK0(aA;Vhqe=3Yc4ml5V2YKg zo1@w7E8rg0(NeaC9*<88?2pQMkR;E;9`R^@eO}d>_g@3%F!5J%bkI(1JTMDiOt!h^{4oRZlRMw&pB#8*QU-&_Z~ zs}|uK5l>-c`132-wn5_$!k)E(nd1=I&IJx6u`wkx9fTsE_%WMQIFSRI3{(>pK zIY;+UEt&-U3&yQU)Ne{fS}s)Jqu*@e^kn)4B=RQ*BnwzmTKDsz`y+F!YS3$lq=!v! z9Vc#L@V}@KCp>^AAm2r!R?=RV%kuSzW;1d^_!e$Bqx@nJOho=%@NV8>;>3ynH;b>2 z;)Ht&CHf{xGuXT%b(~&!%N&2RKgpk#%~k9*@IGAqnK^g({TC#Q=sv*|>WVdp9u~1M zZ~}5-I(?L~t7;K?HIiw>gg`cB^D5|B9&wl4C!Q0&;(ETy4{?36PI3Nj)Mbibq3KjdJ ziY~X$_dhtO)xqWbE$;O`w4GtB?diM$p|{fMzuR+_i<~9z<`rLMP zDfFJfc$6~`)>`mAe zV_{%K&Mp;8emA<*DeiQZqPF-a5TS?ZQrO!lglUg)3dMS~DDIp+F);xa0N_l!mX4A> zqwzZHg$a~>ZF!0;t(=t&t!K^{>8+sJZgR3F@Jen6;I2Ed_Dd6YuXaz;9}YJ=^dc9yNP#D5hmJaSaH(}f(Hz-z~1EMLkHJk6$mVqD=O1SITrg$Lw4?}p) ze+xi+49HOQ0ZPo=(dngn`e@?ozeaewbvj!@w5GPs?f?RH1>L^}#cDVPPrXuPP} z4>hWav&)#>!!fA8$6ZF~+SVe|ZB((u0eoG?D!idjmFwx$-*+oj;KNRJz+q5(C6HME)c6V1D606E~p} zhDYHM@H;!Y+4ZeW)qjo$(g8mbm~prd)OtaEt3E=+zk6eGoSN>)`SA8OZyP(dPx$u( zC*U*sI2@5UOH*Hiu4nP|(U}3Z;6Fy$xlM}wT-K9dp=ZL3PHZ>_S%}z$CWa{@gI9FH z2{BX)k-Lx}U3rgzSD}Q=byD%-);1K!;RC1hl`Ph0HX~xmU8mRUz*V%C z-6(DiLVUxu{D2eADs(CE!r=SmuPL?1OrKKhzi<|G0Y)lqJR->VTLB|dolLIE-DLrh zSWgJTOF^9@1Fa*k=?C+isH`)WdG|r}gOK%I5N|ia0uIj$0Vm)-&iQ2Mb{P{w$`n)( z3i{d3C=K#vmP!pxnhw~7C`0MR^2+eJz5J(S&{&$~8ymuY3Am<~NDGJD!hyN=h-l#E zYzk8&o$)ay?k{*C_4Oggj(E9(3LGKOpBmCAObwdIcM33!NTlDz7TG1Bf}OR_&9)n;n{7^cBq3z2{tt5+3X&^Uxi?d-M3pmce;_ox zWMm-PPsC-Yw>UF`|3!I88FoIost1d-zU)6N$*Ym=1S~NXD2QkmT_d7}jR+`X6t4;k zSa7P2yCzc8QvJK3)ae>?$yRMM+5d<}d ziq=&vs)pSE0Pyakj{tsh_~(ipo;Q|B_1E6IcHb+-(&mkCNJRtPm*tp^6w5#cc%?XGM+R;XN~`Z zYz;SycGxl=eFBzrzY`~dLQXM`aG-CdMsBqOS_+cEZdhRgwJL3eUc1r2mB_7B8uyP) zn=GmCFEgm|Av*P}YqYf9XO`-X*?C#J#p>U}X)_Cz) zd3|rBFLVsyfp-7vK=rE997M%vr1St;5}WX8*gg z&(@J~%$13fgCP}tXLT6i>NkrO+Q_O3e0p>P-`2)TB&8KP z;;M?DQ0P-V(aj6U)W1&{bzm+rk11j0Gat}FeLGWEZ% z4u0oSZ474Vvk1o}wplTV)TAkVxl@L`95Z#LXc(AROg?Pv7O<9;FMAE>MdI9v@H|;u zz86{X^Y3y3ufpA;)1M_hD>$vSbA06jPhPDmC=)4rZdrQO-u`lK;8K-MeY8NiB2@5@ z+-vFg=-1l>`K%AEhWPjc+BSdzHWr{mQT7~4y6`Jf$iFTK44;9$tcHSt8V@TX2)sRc zTar_2B8y-Jt$fy+E4cL({1Vr$V%ck7{(e!t(Er528~w!Yh{kU4S1VBF6V@c3I3v4hYkC zKT8B(azFx4J0|rl%D6n7>$FHuOqQNGDQ4xlmSi?j1B;5CW>L2&HpPj~(t6fM_Bzep zSAi3;n{hYY%iZ|Qf`azkL7 znnXaTt_D)DSK}?>Ki#|pP`&C`uUmR^PdikE+-IiNO6WooSn$< zTaT|B#u7Vq_r@$~na4>))}59!qv6jj?XynDbAl4@er_83zJ6}Yq7bZXPONn5%+~dM zrZE$F5)1VA$?c~Vj1~(_x`&=#=X=~tWW68{I4ealpie+{UIpbO*7-gANITOwBOxq$ zMG+i4Na3AXV>aEd>49xF+$+bt zS)U)S{{&Xd!lag1Q=ya)`}mn@&m%@n*v7@x&%Wg1d^&O7#;|fxd|p=zg+`_|0M@y% z$%gShAWdqH?i;P2w{C*47?`V+y2zLl>=Xb#ny^Cs=(T+Ob~&onWpg8^XQ+UEEa+3z zPBHWzR>ua9FhORWCC;6KF4(@Ga#buuqpEJFKFaTw9VHy!sm8|g6HWFlC9)9oqMq6DWT#~#rGwCE}+Nt%S*`#b9IG&OT2xulN!u+ z)n>>P8ECEs_@#@St_dA`9A?;mW?fC5N+DnWoR6>CGc$oJ8Q>h&tK>=?3mg~n!*|0* z#0KY}4X;8guJIj0UJ3%Ti*Y$>4+RM5i3S+x|9!a->F?!20!I3el}LR$S1ZfNxN&QL z2E>4KFX)}UF!Z5lWSEdyA-Pz0vw}6Eg*C*cuf&FecwGa)sj3QdX=-oACMKtj9+e{- z0gVcxCM1POQ1URu33Na-8)8qagGYSF3v^HH>!-w8w#3 zEAv*)}Jif_YFntn;08nBgmqZ?NbWH^nlYZ9(cWBcM=r|QqN5o#kFp&ao>xF5QmIoMGR9m5%hzvC9ZOZ8 zd(djCD%`|2zorP+1*;}7Nh?0gF$Us$+a9y+Wc}87RS0#96c`9d3IynXX#A0c|67v% z(AdGz%@W}7TjdNDskmhV#MOONIsmOJx6U)(_Q=SU8*Oahqhz#YoyN^D5R_70ZP^y%$({k;i>H#x#G*9A9zDTT zv5c8k*D(qw_a3Oa#PI^x{f@pkMEf1#Yr;42bBxFJz5Edj>ajuCmXtw>Wy!Rcq4^gtv)@%u_1z@Hom{Wc`kHb-| z!>O;eZV>=4Me|~V>?Vs>e5N74VH84 z#-TDr*(AIo*p|F)INER_Cp<{0tKN*lrGv&r8aGkVD!42=3S@w4H{3z*A7;g9!!!9D zZOQ|;uC6Xx*1G3^Y}C*^@HFYD<~Lg0#IYLe^l1qDJIt;zu4en!^>VCIk+kw)D4t9D zO!T4yR<40I<_v5{&g>t-2RG=yJI8o^Lf^_q=NJP2U!CJ)XW(C*!_das@%KvqNAEb* zwsKf*MtWP*>-j0e)p98BnLtz0Xiax{Gee5MbS&M~OCnqY421`zF}-@z#G}bjHXpm=l4xKefBnU{v=#k?in7+J0(=7;LgHpE|e04aSpBRK45oq|;u=vgb*1 z>f1>_<$Eo_rT2%%^4}STHSx_-J6puwR$lB~x8xaPD`es+oN~Osy^QkZu};Kf>}h9n z_nwwMyp)Q%if9Z*4?W9r=)nA7;VQ)>v3!AK_%h9HUT(o{hX`R|9Z2YnuVYgSPs=2&6qvD$Z4Ar1JGb(#B?=a- z)ubBRU*0CltabpB(Qwf&GN1ss~U ztJ>GZ5lZ3N+5um1TsFEpBU?ubeXj=7dk5#51NFkPO#!Immq9X+BRR3%6$QbMTFXj8 zgQE0F)bMkEUlK%3XCm5GKQB3aAK09OFQ9EinRw*~WkD^)PggKfJE z3GN6(bCY(dYHgj;GF5XK0d~!KT%aXLXmSy(Me|RdZd%qISJ^lXBjXawE_w84#l%J` zavG^+IwaL}vfq`vbB-d@cPnP{9Ne_1yvzwSJ@U-I2G+)(?8b0I9+5%`4PZHIe``w) zMRkxeCN4I(p{5uzi%QTK@1=BjGjlkSU{ejM6rP}?kP8%4sfMe(WuQ`C`9&dTB;97u zwi{1l-CBtjs2uf~&t>k0xgCBD$OtA(fE5Ir5S8dH zIGEo%Lh?{WQk-@fmL=DfiVxg>I}@bHr55am7asd&xFAUC)B$zW@z-MT`^8VBjla;d zTO^v?zl;;thSqe*Ze#2_2SE9jYY_HggLU{8$|M{d^!e$NSf-;H=vk0p@EC9jh|u;; z8_|vcMOxMOwJTo2#*n=dsQ8zjs=e1Y^x7eJvG0Njc%)@RNW<$8u?S2hSJbf_b@x@5 zTVhbb_bEUruvTF~9ZXff0)6we8XPsJ{e{;Uj9jd08?{^(Z}(Gywv9{cTF6g^jpnF3 z(wTAra=NyIJT%H=j4c^_#$+Mn`xzXo$Mw9gQ;fg8f@P9W1_|x$<@%Qpr)!tA!7JX~ zs8@-2r@eV~G9{NQ?HkyLxWQ_!@2ws{L2bQ8Urwp3PhlO?*k!B7jg<0q!KL3`Xhl~} zYG;2?j+o-5a#9JF-=TW~qhu1wO8@)$%|pC(&hTjcV=dp2dgx$kKn+^;M+<)_E7 zc()}wUNmO;Xkpe47?UabWS$Lixcirp;hDDE;LTf5|!if85Af>nF(;`yZZarm9M2dt+U}cDmY}=s= z!cV&3-W!LMF4=t$xTSs6iF_!6#7^6Onb9!b$I2*8QN{&dBsTm~eiMqP7#b~Vz^ zjv-^+RmtTG%u5Q_F@$h~`mV45#m(K+%^h@5q(9Jw^8F}4G!-63H`)al2g&`UH$&E_vHN#?y3e-nn(|k!VH>;DIW^1TGFT#@AJ92 zm05E5#=-{gg+YG4n4B3WS(ySmXxE3%RcogK)&Y8Fwa8&I=GiXID0fV98d}?w^&4!#N%G(YysMo{K z2orq^qIOl7B-u=aF0111`CxoFJJhiToK);ETiR|oH@iGHI|rmp@sU74SpMc&$FHEG znjOsCLu?ACFtSPIo*7qYnalh+?n(Kd9)msRiR6aTGAxB;g~_Sr(lT%&=|v*xE((Pa zcC2&Fsi|9%$Jg9Kk-EjW4V#B~^9*X8XrB8=TKh*;g{e>#G+;p^aYYT|nK>2}Rgarl zcYPQldz?_O#)b#+KG9M1QJugvqczGs9`QHtT}) zVV`b6AS4l7M89JlN!JhVXwqswwQ2a!csFSay#y?!Ag6LFt!;J;?&@`Zl1f%E6z-UD zyMCkDkukQ;1+TmXCW{d{5EUHqO8;4f-@7|zFm9`{cEI#vD1_1%F8h4 z9p0v(y=4u4f_@sl@en{8u$x8|x)zxUr1nDVJvp~5ec!Uaa~^fkmjif3xtTj(nd>TE zaHH|zsq#L0ld~Ls2mW29&DX?789@O7jmZ47O8e(YjgP|Y?+fGOPRPdE*v!Pq{;x9{ z4on}jC2J=GeS7+UOs@VL3hTe1Y;A0vY=1-l2M*`I;p}Zp>;VoA|J&n#P z|Ba`EqrRil{||4*mNxp1fd8+m{N`w@Zw;{gAFAO07gfxx^i2Q`^nzxNR{FLM{{#Hr zB-J-G1Xuz-@@ex=y8rD!4fKcGe@)s}wT^$6>gD8+6}yOQfHU*rj+g#; zjX6S$wawj;`My7+Rh_tctIznLDgcAcmjRPy%Qx@-D7RjmYs`cfSa`bLowrC8x{@GpZ zv!`B^k=l~!uqL`Rff{V}nQ0ID(5I^VbDXZrJ!Px;dseUbX~hg=2Am1b{me(*3d_<$ z4_SUe0pU79@WI6T1U%6OJdDpF2~lM1UAWHmxrtH67YwcW-S?<+a1tzGBz`1R_WpN|1JfI=*sI%(P;Z)SGw)3&pOYemM_-;vsCdx-A)(&th6P z(ds9AmbHe+fRtk(ns_dFcaN2aW`eh+D}$w-XEkHaNGP`|+`o=o=0Krx83z@G?57~| zbO6}K_c34Vlze0r?iKy5HR~0`p`~Mp-PRJ53}NA#uh;Ji--6rtE3bugiK{@EeW;!) z!CN=j2o??4=hzk2GlD+Ogmyb=8%)7Z-^}xigfHNw)Q;IPo20{S!kplfuMMZ#3FVgT zW{_J*`zd@q46sSr>H4J8_*421z@suXBBH1}s|As??9$W&G46rvnXe}{ zToH{>d6e`nqs{U|NGHh)?LE|`PSOY95i`i$Gb9L6EPRR`lj$MZ%UT~>o&ia*VXzUi z7|7dm<`(rQG)rxz26yR$A@m*=9 z>@_5By6MiNPk_n3U8~*oSeEj93yg>GKmxr?6n8(VT4QDd@Aq zByot%)d?w`r^av89(s+_~fm z>^Ci>z5#jDZ*;z{yEC0Ck>oR(#01OW0FjCnPO<6^P(UMT=`0Lj1-}#&n@*4rs9^WgT`*X;4)ssXao5zbd*ey6g@REudqyqIvg2im_7y(c+QZ6FZWaLJO`Vx z3V3BR`97Z$ck=|IW6Zy4$EnV+#Rzjg101CmVq?+ zxP6Zm<){Qby>l@=5td{EuGUR*%*J?`JMn-Rzv~App}}DX7jI8lhS)l$5GlnRQD-N zyQ3{2^3lBZo?EdycHA>R6_JuFapVi z@Jr`76(~p=$mE(8F#48PU{)*PgCu|Qc&}ORUC6=<)uwYtxl0u$-QwP=-qL>aDu!xV zk6u2n%<~;nd(NARxm-1xxexo{BsLrNBAzUSC}Dg?<^p>bVJveNmfj%8$0VY5f6@c) zYB(b1U@~BPB^G5d3AflgY&NexsR!odK)6?ETZTVl{PC6dUL_CM{jt_KNRjXt>bB+cL_a+5>8ZX9OJ$Zca zhZsRXSes#9C!s@IAkett2|dWo$=;IO@T+^io{V67o?j&9e6BOLupO|s^KEmqn$x#Y zkDxeq+9|DNETrRB&=EUp<}9WbgD|NMfbp@@t`2v!Yw<$?MYj@YR?nuynq2miqWmJV zEuzJsS&?g(ht)G$`4t1yRN7XJXX1bpIWmka9?_kj5hHzji|E^Eh3tU!H#Uf}g%HP9 zRU3p7gLna7;tfc#^KZR5T-g{R?EbYlC>Vs^JV}fSZMaxPyiaH19f`n3a5)}7zuk8Z z`MDt|-P6@Srb6iRTb5PuC*(CsawW=_uIZSbp_s#+=`Qklcp_r=WU`?L_#Y}=y{$R6lk_^xzb4;^it6?oDsSiC_I0#;Tvto}&iSU8IlHdA1AD*)GxS{B`h(FmSj>t1?-hwwUBzgr&|OeC z^-Jmy6=|iLSx~05`|O%k+Zl%N&!&3y_?K$GE|VSyKSGmL{)K-m$h=|oX7om0P2i+@ z{W^)e%*yg5$kDq|zF)q%;b`5o6#s`2HUo7^H!g|CEwVqpE(jm!+kofxbLQLj^XEW= zl^4Js(5TA8o8~*Ez&)4=%DM|u%>;+84u2PLvqr@ci1Ep?So4BjN&A~#*YXR(?*hF{ z6Ajz?qd@Ou`)7gv->Nj&k1EYd-`dO=;NVDSZ)80F{r|QwxB~$bzxe6F!0ahTTFkS$ zS%cKU=&w?d*E*xVt19G|9%apLSBf&PN7bjD>f;QB*B19Evlvp6j)v8LkCOAMrCgSDKj%cXElz2=r{C+eAFw-bjQtdD|(!iy9% zyWR1`;+WWiGFDS?JkE}ByC>iYU*#;xu7%cbRO|?DB#8CpkA#vQ32^ksX_b{4U{1VN z;ONOY-TLvhW5z$1`|AaD)a0+V5ZJ<9-HndwGj0EM&jeHVGedW$nSsl7;`p!WOlNXO zZCq~e`)_oU@0eRv_0GbU{1bU5Pci%TSNJMoRlnt{zc-x*`&fnc|Mb7)gZYr}-xi-& zZMMH4`*d{)+WHEG`_o9-<7hQW{3JP;vDUhQ@hTu4QB6X2BEcp1XnubU$|sSE0?e2t zS3QyH#`dLbj@bk;*U#g3c8rEPgkw&c+A&@P=lS}FCzEN^G-JHn9p9fhUYzdo@lLUf z8{m+#=s?E+$F2buKWVviWG|NAHAkio_RS0$-EK(Y@ay_~xr6^aE?yj9`=RhFSKEI9i)UVwC}eq8cn zax2HWbG3HGq6)RvZm+AY#sc^g=%y}nj9}zOA;qAzpJ6XOpXorVz8Ier4;?t$gWS#Y z$Rik$DQ^~k7EPc+VGS%U*dHYUW3 zx7hj#dsG($Z^Kmd;I|`p*;*iwj3}6UvXXfmeFt@1KVodZ<)G>~ln*Uv5S2w;UU1)R zYagyFnq*n`I2?Y4eKmA~$&zc@uyl{GE}txlsBA*@k8M za~-IWl8W68X+E9vtGHlvzkhgEaF3q!Gnv-PUcIY?a2R??ZXwnD+9X>_sfkq6P%?bZQGRrUed(C$%y+<1|@Dx~ySJ1TJOhttH`g>)T}9aO4euLX=6 z%hfM^S74lE7$@F7?Znfz;(1I7gMQ>rj_)`5Pg+RkpNIub%Tu(2bn6BGuv=hV<)1;WGm zG7$|w#`V1K|LNF&*c)680=1blyL%28tP-Bm){Ecw_!G1?zWl~h3<%pt6GwLUI53#C z9~8^nRVke&Q@So}&{{MWr#BDXnG`?eiuhWs7e`b4 ztlOB^Fy`K^_T}On`OV1wcf$h&+!Qsu0^MYTw%0MREMYZ-q{eBWF!!gnaDJufS1!)6X3tw|3Bu zoc(`N&!0h1Woq`Fx*q1SgeoZMc1rAI$SF52K~vUYz&H>5(sLX@166t%`nHs&-&?e5 z(uHydSil{WfD*~&$}?}(8Jw<?8}IMKj3F?WS#i1ze# z#qxar9M6bkySFBgflKuZ+IgD5SW`gF4C8!HvJI4xA#+TmmG9U|@eOT8LgGBsAM09|8M>z>_6zR@TNUp%%8TrU2mFJ` zQ0Shl5uA-L;TnjP>-Bi&_nYV!+36SA!HaVIR~gx5$XI(y#vfC(PP0Ca3Tm~ACey)3oYK(>Rp;0n^Ur={Bl!YFe*@2_BPzs zbyUTS#b41q-~AbbEU{bD*lp1!@g+q+nBC(ZcZ;lsBi0r~i@e0<4hwOrW3+1YHCA7V z(;aYb<^l$!6Z{OB`fyqP?iAJG9$C>YaD@?j8k<^!no#d^mV3)(oRRgb7~(eCc2;h= z%hu!3=Xb4yCeUhh{qd(fBDMcjEB*Day}wV&$k}WYAP$^AQ_|Q}eE}s`jliM0mA{>u ztDIFnqP72e1PCVt(KhLNU3!pPq6+SC3tE2|_mE%9#767zcbY!XX_vIa@!b;@*E!$X zfAy-3v{`JLZts+YSH@WTlI=D9tt!`BnM+fPaF*`v^fi=d)=6gxP*TH6gke%FntP>k zMVIr8Cx_B^L1$f2SZF`3pu@URyg!@HKZ$(PJ6%1m4$~=~p;_h^vjK?;D+FILjh4Dt z7x#3!WL%a@AuNC2Kf^ESv4})9!-oOArmzG|~2hsasDeH1EBH3exkICRC zk@+=lV;s*g6)ird{@0#{thjEx=^%KfR&jgHiNqICF_-ydHpqTY`5+7d@%42JB2BGF z-OSge@4;|y0`qdDt+JkYJ3cKSKZelV&7&>huq+Y1;>BS2{8@#+P)gLruW(DQW+Kop zzrOeC7guu&?mv@eBymG~>EWW0tkf^v_Y4|-_g9oc z*eG zx^l0Nk&x?s23~dpDkJOR27kb69tZNb%>jY_A_@R99zl;kme?hOaoXf5Qo zz{z#Cz$6xqfRF)(7arO(GYmNqU#hm5t`0#f7V8>i(pjL$}4Dg%}waZ~d_>4Br^k1_&%dVU2AZE{Hb%mW@^1wRL6K!uZybw`$;A-;)KkF^gMDMm zu@ZD4j-1ekco!TZFc8*3anoxKpdGgf{se2TSB)MtJblpDp?bVg4YE*QU6Ul7v!~E4 zM$`$qWf*EK62b*Bg~3LftyhvJjy+>CzWYEEnuP$CWV*7>I z4#NrJv!$g=+iBPl$TnQiNO7pKu*@BXXh=SVV${Kd!#w-x4yTN*1_lspFo4xntYhAg^*aY6J3u!-*G`?lOsEy@hx`L7Kx|95}7TS+;;YY1B`?P%R z!H~CNt85nFaMs1?vn>9e=o#KHy)HirdN3>mr4*C=nhsY*bpobWQg?!u5neQ@xOs&y zo+S!f06+G*SpCF}0|8Oz1z8=I|h_KL0PjD9})9*|01}T@uk5`lJ7T4&Re?k6MnX)J`}Vt* z#&P%4J+64wfcBh(;t#*>n$@(?UU;e30T2@_uD|v;1Mende}V!5^^yJackQ3M zmHDC#K)swmf4zS19V(kTSs7UCn^`*0JO1;Q&eqx_R9;pL4jSwCUKpH&xUeD+5U@26 z5C{4S)$U3(;H>gQ;!1@U*Uen6Lt)8GjZJ!M`oin3FWI9>Asi-pJpA>a?-1 zE#!pzn~A)Ru8;XgYyn)rTkt6C zl!0$01zPOg*c1gfIAAJ75b<|~nnqVnU!9u+IbHjDl4`$6Ac{!_+j5{1>+;LNv8mY> z@l%pk!(y+r!-7Dc`ox@Jv;v24mb;^nuKH0m1JEDw&IaYmrNM0z2#RFp8rvLU1ZMu z8-ZAS9FTLCsM)HMY;@ai+m<6o(0>}I90&q&dWMwlP9i@D-@m>{&DAhRC9)%}2p-dj zn#|v(Wi{vkX(ro)n}u@LYln+9OVQ(B^^ze1Pok!ogg8%8p7Ks>#U!7^soR;ojD>O` zHteN0wB(!WwlVRTbU*TO^0!~c=Hgb3&=OB&efM}0Ew@!rd4ZE~#o+bvu?Y!%1%Y_g z6DQeq!=}ds*BxL-x!?TM3sY3=E$7EL-_ibPEK%vh+jZfvy73t^$f@J<73QX@3K7WA z`+IHE&xV%gDVMA+obxWt`^qAwRCN~@AK3Ofigh%fH8rZaa7Z}sO6(QJWXAhtne0_1Lsvw`&3P{m5bY@B#%+VW|8qt|F~aqhRUh`s$bGL=O@7Bt!a4d# zvQbL(PaR6h^{Tf{S2cOXdy3U|*caHY*<{ztY-^dZHm4ry#;FFQ6194K@usR*$=-a^ zxu3HziMIy$*AK^0MwFb zYV9~-42uu~iB3Gg%kAzbxvxtbQ3a6Q(ci|7&~tGfME5xNXtjV+t#d4HO9}GdziAQr zRlze_6LE(K4b3*xOS-`7!ZHk{@Sg}$TG%RqjEa97e8@#b$gz!BAzs0ZFVoyAXq~4B z!K5FmVMI3uIf>4TTrfv?lxekiS;64%otoV#v>0ns!l<_&JlE|mzZ~P0C*w7U6CmwI zIWqO9;A}x`r9z=<7;`?tzr`7T5qBn4f~cHZPC80=eLxBVW5(W9NZF}AO|w^(6wbgu z^h0TUz=I!*YU6`<0S3cnU~28jpomrOdhqkBp>0fdDa12nbgU5WRPlS-R6R`lrN;b` zJ;EQe_l$b^2~a8opNordH~klHEtC$d)I-F`i_Sodt<%G7roRAw&D*X{q-qiieZeVZ z%Xt5?L}Z&HyAfw+hs?p5^0rclCFZ3hrZEBi9Pl_rpBcBv>PYJmC@58TpT9hy-qc9u zCfI#k5aL@eDKVx?(Sn^@C*Cb0q`N6;Pl#qt7@n;f6iYpiK0N%X$zl6BdHD0#s$t&` zK5nCG$rX--<$ETdHM|`??xixwU*R9ei0o|No^&z^gm05T_rf4`KOXRU$9~VTo1f7! zk{q)T&O%$GwjTcA0?8O}uwxWOf8!+k8pNmt8;X+qHo=n(>Tii^LrqC!3x!FK z+EplxIt2d^zN6qbH%gYKG)Pu}3G(?Adb5Y=X)cwvq(Iyuqj7_zS^g!}k;@L%gG30R zumew%&acfJG3G9@)uW!*??6UU7LE$C=>NSDM`%Ys4pE&BqpMt+p^BUWlo6OL7>Gak zaFtzht3`Xp0+(GOq-Gf$g`&VcvFX=Q z;#jt|N$}wA5ZnnC91;lb?ykWnxCfV@!GgPMa2VX(9cF?%4DOJ8lXLFAd+&44{#O5) zd7iGftE;NJy53srUCJyRF0!c~ce)V~%^%v6zgaDU>#L4%{Tnd9!x@vl-lGaoVN5c) zA?@}@O;F|Jz^y~9S`pQ&X%=V1i@nA)VDM7_UORc$3nk7VaMIr)7FG))`g4!isWd6l zd%sks#pJve0_fK3&m9$^^jCLPMq(&j=MvWNN$R-S5!OrYZh5pBAkc+8e7!XO*?~H{ z6KcqjfYZ%dH8nyDCIBr0*E@b63-Gs&6&#bFyX^HwDq7e5+KI!>9ap`_GB@*7`ZrsR9 zav9u!zxAGBJ(jzLzb&7~3K%y}wnc$En7_ZQLxB)PQm+|rEup(3FlO~_1U~MJ$f$|h zKbF95R}vVy-IA=VV)(rV3kUnLu{D48H30ld?)B>Sm4QMvurj~qpB6se zFJMw_uwDsUj;5Y$FXv6>XSbEgXQ==QqzUD|M!z*sr zhU_yI!p^IvRBx=_!uEM4SjFRBVSYK~3V^$8?0Qtj;Y+_&gz=4aIh5>UggN^4@1 zCT*eqv79@WO&=O4iQIb40ARMaEQB%jY4w{t@1!9RBzB&!;`fp`ReJVo#+xbnL}h{9 zYH$6yM-MAXZE8f0R)x)n1S+aB7WW6rDy3Y z;TZ~E)k&|JO*gKmBL@!FOE|16Z0Ej=5;cxyFW^v=^9wqn($88titMNPR%rxNLzflk z=3CNW>}%L`_S)4GEKwcNE}Q0V))v^4_>wSUQo&3!)(c{;zPTduM7E}3YAa=E{94i> z%BLsInY%4LucJk=q!;c zcVo`;43_14A^(2b_}2&Fcvw(U7F?m5M6g~2a7(#Ns_|pX08ZC@D&H(jRUkWm7`M&m z*Xx-TgP;Nuc)duzo@g;}PM$Ur`g@e7Wr-Q-Cc4#pt9Xb-9Py;3slXgVpe1*$sgC zW;aLH7%qH|`M_Zc?o-mfCJcJBJR5pfN&Tx3S9R0yZ2LYFWx7(I&?K>pbxXXjW6t)7 zQt*W)m>#wXjT~>abpU3Yc$LSx_4VbXj@#<$DClsNEz4#N7t`wSFET8t=Hm8%<+bBX zN4X!T7hE;8NOD~o(2r;Jb~+33Ze;_CKL*;W@9>(^Wte)my+;GDg$(q0ODbp(ZJi6b zI*9$eGCv}*-%=;yvM71CqjX+$M0|ap2Ekr*l)i2FDFj+vulohl6n7DLs!F#P+={%% zacurek}ChpZgE#P=IXh%<}VI!trqRrw^zKTtvWpW!CI!RS;`H^ z@W$WXYZ-Dbo*S2+CKGYn&Yw?zW86Nheb>#hk+h^J&DPA~qZgK$8I@zZiAb2LJN%U| zv`Pi|D9xC_bCqX^F4COZfu5CDZbI8QOCaQ2F}%nPU@I`fW*ODE#Q+-{zmeTH?rzHHmO8L#idvHt^XkG&n? zsm@B%+nP*(Kr7&g(6)2g$G@VZAI*V9JUt0m#XBl462!^T=cbL!=|At-x}P{E4opwy zGA1@tqkEC)i;SEs$la4car+cl8F7ML`}##de{XGWkWEG*!9?#=b+jK4x^O-@3zLA8 z9+`g6D^u`OD9M^4)lS+jtX0=q&GlQ%5zr>~O8*-W=!*%?AUHXDg3tx*h1*;jsifv8 z^qd7fZ|RId)=*R|w!v8=8T#UwjT=9Q$lG5(C^T1J!vZ4ZqTU>cFoV?kwS|XUyxv_c z@n~h2(>C+N*LWs95;r9dtP2V!U*OV9<$bbTX6_93s%rN!QPe^vS71TdV9VvEEDidJ zPtwK@bAy2VEklrfh#|^}DAZ)65|8vvN9RDR#CIk9X<9JDvNP9_*qGN>mLTbDbVa>m zFM)UM@+rXb%MINlArje+p3MHA1B%s=o4gh?u(>d5#pb#=8Q~H|E725_nbcLnkd!GG zhq?)u@mcne0tHCksy5?KwESBp`kd z{uoRl^IbI1UW|8G$lOe2@M@E%zB-+l0_ zfG8WN=C26avI}44ornzySWssQV~;jKs_ZSDgUzR^Ra=i73}k9$-1l-6I4P@ZA*n`4 zJl5qnP7f6^HS$jBr9G-To-stdUO{^9+~=uB6pVDeZ@Un-^f(4A2k3AO! zaT>Z#-_>z-_c>@4aiMK&_t=cnll+9EmNvFn4PP@!1vey>6xNl5_NK3tw}U_OH2g&M zM5FfROa$^u7?_%lwuEh7E?{PnM3CrdILiO#g0n_zDvKXT4*0am2BdE6^@w=?Qjh~p z+Idmb@{U`Y*s-VWJ^sNr`lImEOBSy)CNW!`Ws!^s^sWc(>dCe6RCWv)q3N>EZ~IXx zT*Z}b@m=37P=1?jkU}nABcibJhSX`#qByY9cN{=Ih<~37Tons3mr1vj!6;k79pyZm zgy(gq$__nF%K3F$g4{E1jo)l8mj&)`#Tk+m!g4nE@r9*L_$z9B@Sn0B7DE!msvrj??YE((rv}nHO%_lz4W~c9vtuH(zYK&~I)^l}p|445kx3#A4 z6_^YUxVKNap|N0cB&ng*&|mdtf$&w%rm;H)5YD;q=Sn`ct>X|jsFt6wa|Pr-+<(t@ zh?_}u)vo+bqv~=UUUYqxIq-y(jO*Yv>&NEqXp@fgax+VZaoZoN%DhWr>KPv02u&AH z!erz8i0;^m9mHshsq&Q)3^lCAiQPm?m_+=5 zktl{4z~W4l(C8$4nRJ}rS|q|?+7nBLBbMlJLr#bJ(Qqyyc1hAJ@uNFVccr7L)6A5h$#1q z-#4u+lWo;1HxpdcXxC=~x=k zPs*A-g_k(`V~FWMlf=+yNBK@==`p zgXRn@rfFD7F-!D~dfXrD*P2UL|iqMYB*eD7x z=n?D`)u)ahT%yLeB}B}kBkS-RyP~XNx;;qEF#K8off?Kzyo?r$>T-q*;$}$ zh}t^&$$pMwpQP4gXZD2!-{Q+MY8VM{GMZ70yb;XehyVv9OF126Iee_9bSRi;}<*W9$ZoFLn#}#S&Ivo0AKCiDY%aKSRS+ds@bzX-=?7ogbpJlzyren}q0{VJNUgQm8@c7X%E9Hl1@Kd+@K z=(VsbV+K_^*AW_W9sfJ_qM@g{CNXefs8K8y*5H+A2BGJwB#Gfy64*5_pZXd=}(g!5)^zT zx=q;@>)CfIj?r(LQijj$^%OG-X)d)ss8d8SJ}e5zb)P%-JR4PYqx7r=Kk5>Ipp>X_ z+S9-W^fS)4vsL;C+W*faI}UJ4{Ol^Y9Y#4YHvugT^_r%wZ0xk3m}|&ZCd4A|T)toq zEuQGCa1;95=h|g1t(d&6Ap;&u>_IA(1F9Sh6N{@R-Xm>Y=8gk2HLIV@np7X=bk%z> zS7i=%^t3T=0`J}m>SX&hFMF56^7r=8drRp@oX7{oG%dK>nzmL|QXbm4#b4Z2Q*+fD zG76@7C+fDfy#-n7$`Fo{Tz|6)j}@RjQW}2f^jPNr^#@0>4j8utc=LBbKk;S@f-|B? zdux=+TybS&EWvmTJM8w8Pk6?KY(7`VUNk&lFL;t&-G{q}5%=TKljr%<~z3dC6* z9_LKWp2j8}d;4zRuMpvw=!bx3(X}*&t>Xm3cSiW*EKdJSu?&9%TG?Z?T~PRmB{q#@ zh+UuCqX31@)!w$?O7B>~P@cn&t-1R7f*wjpEp#H@mJ8ra^VpQ%JX@7f>S&6z zw$w1#L))IY)@^dPLPNdDorp2VT3c9SUr?7TyrZ9~EorGLjJWXn0YUDBr_R70hZ{tR|9HoHrn8Aqe1c^ z1Gcg{N9DNjsdf`8zy{6Fp>G#74B}mg=j=r< zhVxwVIj!Awb(Y@Ne{6Io3a6_)$|~OtCi#GAt6)bqgSmP=gIoqGU|mPM^!kELQ%PdP zbCTi7NKZ^JSvKk|Q^`+4Qj__T>q}1q{Z9ka)*Wlx*M8iVoSmucI7;cu_oYWte&TlY zo@qw8-4t;UTLVBgAwohHrQn<2chAa5;Q<@j zmuuW`o~Yirlh`&64f~)5I}v4Bu>#0tiCGN{&r+GS-VzZ-RC;f|?_I)H92x|RVSVX1 zp-FmL*C~L5f5%#UVLyz=R1lS)n8K2}kqds%c8mu92ZDRL6Bq7}Cc){)*vcgA2$OT$ z4|Zg()QvctEKfEe-e@Xdcw-ESnv8uR@lTcnYJB#34p_jUP1lM#eleaZmm@p}GJmvi z*kH)3m3BPqs-Dk>;wxeq3{ysc8=2R385u>%keUXz%)w1Ng|Jlj31$hFM0r zVlhqP*jNfiK;tRE23I`j_|p}31g3XhIU#JmPBm~WX`l0z%FK7Z9f>6`3;^aJy3;n- z)uPrI-yYU+HabQF;t$@mmEIzqA=_Ii{=gd{ho_O zyjAz@pEI8)Vm*uANckn-I}osOw^U%S`Jr7{Tw_L9oQ~6+T90(khgCJ{Lpw5T;2bim zUu(wUcLym(@L{XgFa2XN=9fzeR*{I`$MrH9K3Wy?8x>l9@FH(j<(ua8Uf2Xjo~B!3 zm3X$GIZaP5n024OmvThu;(;_z`Z5Ko^tOkZPu8>h(OB|Jkf9^5_*yWWZgidm0tOs!g7R0ZtGoA~3v<8I<-gikPv`L_gU^a1i3%d_-`$Pfp~^Zip&32OFz$m-{Sf6sP{56~bB zEQj-JEyJVMndh>J;3mOV6356)N;m5-mR}Q`duGfG3kATO<}Ksv7pk^(V%$2HN~VHa z4!P9Ufei`y5P^iK$wmAI<#!UN)L}HWgax`#8sR8131I z=)Lr7>~cr$fssPxKy|*x7@P2uV3yK2xi)lIkH{qlr8igCfzkfEeqkEd=LXzQG$ceE zi{ z(K+HgfOhB;0F^1@7|J}J$d4{wqWkO2tUIlJZoJJn;f!b9l~RPv(mW=tFxN`1a9K{Tyic3>98$>nIwnpw$s0$046x}^6?SaHh{if%qqfzUE^e+Dfn zRuOrz_kAsVU|tXTB!bY0KC*z8I3Jhfsj{R>AG%bPfFslDUu7Zeh`mZ1u~E!q>dI@_ z@&m{hE(o%ol;Q@5@MXF6CATru!rw~T6=Pl}K%<^(-&lGnf!{w}awOb_pZq{k_GHf_ z#yNMEdh}m{7?d-Xy@~r3|mWbY#S7haTm#X(Nkckv`s17`|7?hzA26UvYC$nwOR zKMm-h`5lV!Vgu^&vF3ArLJGg%s5Ula_?HwDc7A55v1dX*kM|s76wC~0T@62R8ikL0 z*3B?*jP?_N(X%Z%`IKxsN%%m`m{Tw>UKCcEtN@@vtju@AEvYBJF0sl zf+o&jswTK{7A4(93&v1{;!!j>{_J&57}XZrO}j$;ycL<+npD=3S>y_JceE>bsVrbc zLtBIHaNmN|c-BTQbgB0KB?P;rgH&Fcyl^$F06BNLaqQ(2T_JE}sjK|Rt< z9LO@Z2Ege+c2C!hieawISE~iymPP&~8;0+~&J`VG{yRsJY;Q_*$@E@)86GayEji~vAjB+I%C%I?KVdCmXl+{~Q zQ9pLLfAf91IvuIb+4;!AWFNswI>&6Qj6Op$l0p~PR#M4M3R64Fq}3VxX;U%G?t^4J z&2kJ1QQP~&q_zBmJ2>#S8#p1~9|dFihCk+z_rG}``Dx$ECC4CgIirur^FdW(b^QUtvjcP7CMiAE79YI?Nf|dW@h%>WG)^2=;J}dnkpRAcyz(19f8{we zvh+56t0gALmn?Y}Md8o}s{-3S-Lr@bIo)M%eFy27taVWvzsWxbxh87e(G4A;jn=A1 zpDq@W*V1`L)1Uxo11@qYPatRpzNJ9{Ri16IrBgd0`n$LT=+_5+AT+U`pC1fRCWzUy zB;8{b|0JvBpL%}J6PA#KrV4wf3jE~WHz@T`@Q7FW?{T^pHYgHiVDuzHUNhRPY5oX@LO|jyyVS_(0@^dVU~|a8 zt>a$dV*b4#L02~an^5AL?oGO{Tl+=TVkb%FaUf@;CF;iX(k-*>?RDkJ@J&g(FgUd| zb6NSI#;j$4_pCMU;VqhPZWhlE_@R5gG_lsOa$U1Dub5M=(0NC@tdrrfC0pG7sXFL9 ze8Lb={^2kIOO#nha-%zG;vN@dMBV6(0r714J%azWr7Loc{mvWkX$p+9hSojli8#AT zp(uYW;P@-ifkOL|GyT#;L**vx!==Z9Owu8r^TA_CM}l5u+mTsczNlePFvYRM6_bv4 zoWgB>lW&-+u29BFd$8r4=r%W6qnJY0JiFfEehYt%-mWJjx?y1q0-Nb2lLX?jO5OJj zMPK7Ly?{4^J|5zewL`9s=)FGz(VL@4(w8$t(p+bi;>Z$*4aR~g5mV@Oud9g|3`{@L zs&qb->yWA1kqzrFVWYm4RAYAtJikXIDeYZ^shA46wt1{gGsHYfq3RR@bdgg9hD@x~ zD>J@VYdl07%j!SueoM2@be-{nEHvqbs#P+5&aD55Dh2^wTYsxUdH~qtRzQaaXQnRx z%RB9XKK(V)1R+&#f}4u29-Fo3d%wMGc<7ZdK?8{byN$FLz(ei(^&jIZmPvh|9Y+da zHUsf30WB&xNvb4p*q`CCMHMJ>%y)X#-Y_~e&|wT{r9F&H-3%bVY= z&+S(6g+OvTDh*KNwvwR_#i?;}B>K_P@}(6OE$>4cvd<{s+sD>MMNGbST(;cAB^1gx z0YA4Hl@FWsE>O8*uLYqzV#;-saihoQG`U~naZM4j7 zOVha}ezfLbbH?JOn5k3NC1qE+bxgT=5qPDH0!$R2^~u65{Bo|QNgFaJaY7_RkQc6X zVEZ&TZkVdo7H^}Zb~CimMCF5s)VB8!!O!S5WN(d75|Bue$a=spuRk15$h-zH8m_z$ zpT^JZFMCAS_ZjdHV7YcD*o5J{zFH9?^{412)-jQu&1bD zh0+sEmX3GF|EUru3NKe(R@_uh>QGKH6j-YxXS@kE{plr>5FOj3>U^gz9UXuKIm5E=3 zorbVkpCa6~!q+^9hvSP>jNJffknSrGRj+y4rt*cGs1W|>3^@8@Z2g6qX)D>+=#i>L zKygtM1}hFxPlZ2&jhBDxT2^kk3hHTQ@4RTJm}r=FqhK?1@gCWMPJC9T+8d1=JtTem zQqkb;N%-gQR@frJ`fRgNN&uL1-glt~UW0rUc`HQi*kVBuGJS+pr# zC?i>%)}I_uKIzS3z{8eb@9^lT(^1Ee_m76)Ur?J0t`%T7(H>&;Nn7v|9fYbQJ2%Pj z9(7mxSj`I~X|xK%qK!r0R*4oyro$D-9ZBujoR=^5MXzKg{p6j=6x9X>qtdyNTU!J^ zI?S11PyU=Dhq{*z!7F_VVoYAH!>_gafH*%ygSHfJpLz%V`j@{z9rdC!Qd=&h9#-k$ zdOtAu()|TZj%-_>#9boVi)@EB_mPDHwhn4Fw}_^+W7NwvD(5Q-F|F>C zdne>>A{!(tVRK$*$>*R+F(8SzdVZeRYlHxvTgw<*uu)Cch zwk9+(M?3u*{rbe+nNs*}Vl8?cIsAU!yz+R=B*IR~D2|KKvw{B{$S-buw-uPqlQPlZ zJBJG%(ji?>CIIQ8?&a22%Yo7~ym_RWVvvapo(OB{RS0#fl?k{}sj;g7w^is%T9^ux z=(qmLyp6mZqA%sS35(u}Di|SQu&tVlhm1s=a2iUTM%R3W@J~fK-1}yqsj+41ZZFu* z`6lkMdKQ%zvyF;ZGrXT&b$bt6TpGO!(?80|AKoM-Y?>V^MB8C4)_x56)@tz!hshP< z(C0>WN9~B*(l$b2gw%u-pn2wxGfIx*z;e4zzzRO?_N_Dud6eDJpLzbJyNMWEwt;_a zKmtgurit|(-HtAiCqaP!MifVH4M+Z!BFoCpnCtZt$;>_5*=3~;+_1Fax9hoeWBzMZ z5#&<;Gh@|X9`^954MCRZ#*T_85__S%)lSTrR=l+UmS6oVhKitKe?gQ321HUU4IJBA zvI(Hb_$Y?i7x^)B8rekTlEPLhB7AEz;irTy;i+Y!@lZ|vn?@-zQ+;mtd?-_$?k8I@ zitD?EJxluiMk;CYWz(uGYq(E|L8L}FF+@fxztMv?_ItAdd%K>cZVeJwiB1!{#~EA@ z)~xg}UXQRE63dDysH+{cj(;`frfW|`1}@EQb)&lo&mZe3lTF5R2+n#HIU_6$ZeTQz zBRr^LT#oPATB-G)yi}eOJPwIc%H~q+b~boDA1IrwbKJmrKuIQAoYZEqNh`-hio1wx z34@VqwKU3rB;3iSvujN*lOKh!&0j}&w^*sH8+-Lo(rPio{75`V*RwLho|mLLTFe0# z&5107y;|1_rCw6uA~+h|n?1RP3cDL1Q58(*W8qc-di5SU?w$^BIE0d=(~D!85|=A0 zil0l$KYyS2cz(>05b{#T5V0qi1NG!9sz_+uudx@gP(pmQ?Uv2V7YkN58Djg)3ECuh zQ-$&`f|URgI5U|n%%U+(Ef@MZnaqXzyz^6ClXv+r^TJ1Cov&b|LPWq9rLuh@t1U~X zFWrKOD}|}&dhbc|`6FH^;#hM zC~zAWFll)cn8Gbb^(|q383kppDLhAyd}F{4eR4Lc1gDbb^F@FRhJL4BqLB`NQJ;^f z8`-#|D|U0N*%wo?^v8e}erS}6!@0u;(|T@Vtp-{G1SOjh>r7DcT4rRQ5)1fWESaXi!UKZN44=AEs1hR9 zT$_sAdpw%Re+B#cAG(aqN11)#FiG81LzPl0F)WREda83Vaa-w=b-z4C9Kbygz)6S~ zv`Y%eQrH%V5KEzpiFX#(OY+7HT_=9`5ymt$JJYM6x+1S`a~~ZM3A+nk>D3< zx&(Haydll1+V1=?S=XxoqRQ5uXA7P;8+=+NXXzX`77=$(-@V&f3PH~^0F7tW8n zh)7R+`9H+eedB#9ouE$i-cVk|ERqt(QL#fB{Av&=6*a}y&56FzyM+@e z!To3+!PH*_jU+GDJD@hA^PM(Dh zuU3r3k4k!xm_`0wdXpVv+k^lJ*M6k}388FNf|Y&mIy@+4TqmO)Pd0XuO^fc%l|_hh zoyf#c{&d2V&x-UKo`lL4XyPc>v1q1%*lY{-3?1>nqUJ+cAtRo!-{o>j#7OZNx?R~b z33?>`v^0%OZN=X0U{dqx7OffT@Kh&?V7oP2iD#qsfYhD^M|C?(3B5zD2aAI}1c!8a zTT7-nEJ!qz0aSlsM>lGMS~lksvr6s06>{cceAC+`bbj)y?y7_op-z)7Qp4f`8+tCf zR$b5_he9$b!w=c0nV8nf+Czszg9+obebh8nDjdZyVt>74hfl?=t|UhVF1PYI5ItuH z90py|5;GU~{3|4)CCMfJdiXm7`U$gC?vEIg@l2_&D($K_KBEQVjn>RRICQ%b-;G;=k{Nx{hm;@H)8gNrBvj+WG zTmqYtHik8O5r4o=oc+FW-mz$;c!hstm2920XZ=-v&B>Fx@iBSJt7gNO-jYhp1Et|} zb^ye*_Yna!WOmVBxeon_4`ov{nybyBtl+O~T0ixhpAvRf{X@W^b3eM=kOw*-eF|zQJxMg&un*v{!LNmH;&bF2WZGg`^W-WPG zJ-h)v>jvK2)xu507M`(?ODV>Wa3}1#yrTtGSP&xWpy-B+L1?F>Du8s!Gw-HbuvR%J z>S4D8v=|cP6m9aBnukS`Cr)<8nO;(wd;2`gAki0IeI14%y{rb7oZmlK zEw|x5cOLxu*kdKBbN3poT6g(8z5eRfwN2wSNGzEF9I0_I z@PkwUv<@vixDZuvFh1>VD(fV<*Oun`=Z3fq{*)U8u zb)Tnxm~NJsDS_B$k=FdEybbE1(M&gB_uPFY*bwg0R`dz`V{?<`T3EA&UQ6#4ZA~v3 zQ^?HYu9JCNU=;J+fss9{%uN+cr99u^*E!2Ic3nE3EILVNwl&JeBV=Vezl$qR#qV9_ z3Je^;LKo$8bC0sF7vD-NIX`?ZiciQlJW9dYJlKLi%)84ET}L$}g!}P&t1F}{du}n} zgDGpbarjA8P6s=jyQv^ewyEn6CeLG%_DEET8od>$qChr@I;L}B_K3}~WR;cOyNUF9 z>(j$V>!Y8i#DQ(4<-n@MdUaPlEfj2f+#B@>%0@0hQQo!npBtMYSXsf5XKEY??%^kp zMMYkIMMiki9o;Yk2_^4po z+QKCA{dUj2@!d4ue1(r0y*DPzz=D1>tUymiMR}Rc@y>&GWk6c)qB}&X@9A;Gi&7sD-XOhPGaNIgZ9JlsmvM1+{^36#_R}JN zHhPUM=&ob0Li?R58rEV+ou&TOn$#-h>M#wPn-WXi?iFPXSe;oNK2bV4FqtlG4DfUh1h_2j;C0mdCLX*wA+D%sWJq&V zQ*_A0+-35DZs3GDAC0G`EsHlkzD0S{2!R(e<*NGn=~5cayvIsJ8YjX;7e^43sbQFb z=dc}o90h?6QL8-Jun8`G$E#hC^@Hc)rVIC^`?tY>M>?>H&E>vcopeLl4s>DKOW9Nh-J>Q}_x#$)4hN-t zi3b1_u;pl?D)4@dWl>DB@idD4mPky@(}|Vpp8{jQOL4$KSzW#nb+Du~V0xv3a4Gy` zhVM(>_k=aN#>c&~iFXKRtsDtW5hs14OIdez+e+(_$gv5kn4K5skDB+crmdgJMWS2f z64xT3e9X5Ed<>5eL+Ct@0{MMFcjx~d!}G7r-QR93{|**`hKl@81i_o%zLL*fN1q`? zk&MG@aplkuQ5YEsMe!;zT*FY#W6 zv4jlq4JorH3l~UFQ8FkOICm>crM{4;-R7wI)lop&kNyg_QN?~6e9-QGsyO4*0#Uer zMQLM2!kMpC@RHe}+X5Rb5UU3}nF*_JhptNiE#8^UtrWCviXv&!;dq+NYf``wZ>n5Ha@sj<_FS@}ikx zXpV6i-(?xS-&8u2lx9%=YX4#W80qa1uw+R<)!n`kNrJM?cUEUr@2OIMA0D3|ee~V% z#z}9}X>7~B2!TE9-cY4w1^cv65G)l(Y)I0T=ROuM!lujJj1G%gder)pLOe5;A}CkT zDhZ-W2-v!=+2&X_g;7Ww@eQ6Gq9>jw%+J-3x=JYT$Qa|8$Ctlw5Pv^rbo}e|3aSD$ zsreCyC`Rhg-rZmPHV;DSzu#B*e?j@He)d1({Jl0^{{`nyJ?(!+`Fm|{{tL=q^|k*Q=eNT4pTDrU4Q%ENPj$)e^q__EiUk<6+)5z`62kL+~IF+mp@I8_3sLie+>RV zuJ~8+pWkwbf7%zezlkIMXTiS;&HUB|`qLVrl9hkt)cVg-f7N98dqsoz|1L@MN69~) z(*M+K`15)(BLA%5@CV8txBJ%@>F*ivPYd<@hxt%h4j%f}g@M6?9sqb47#;85|Nb8j C!=GFL literal 0 HcmV?d00001 diff --git a/archive/unit-tests/allocation-tests/feature-2.test.tmp b/archive/unit-tests/allocation-tests/feature-2.test.tmp new file mode 100644 index 0000000..5d198dd --- /dev/null +++ b/archive/unit-tests/allocation-tests/feature-2.test.tmp @@ -0,0 +1,30 @@ +Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated +"Basecase", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741 +"", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741, 0, 0, 0 +"nil", "Allocation summary allocated 20019 deallocated 253 not deallocated 19766", 20019, 253, 19766, 33, 8, 25 +"()", "Allocation summary allocated 19990 deallocated 249 not deallocated 19741", 19990, 249, 19741, 4, 4, 0 +"(quote ())", "Allocation summary allocated 20025 deallocated 247 not deallocated 19778", 20025, 247, 19778, 39, 2, 37 +"(list)", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25 +"(list )", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25 +"(list 1)", "Allocation summary allocated 20033 deallocated 262 not deallocated 19771", 20033, 262, 19771, 47, 17, 30 +"(list 1 1)", "Allocation summary allocated 20043 deallocated 267 not deallocated 19776", 20043, 267, 19776, 57, 22, 35 +"(list 1 1 1)", "Allocation summary allocated 20053 deallocated 272 not deallocated 19781", 20053, 272, 19781, 67, 27, 40 +"(list 1 2 3)", "Allocation summary allocated 20053 deallocated 272 not deallocated 19781", 20053, 272, 19781, 67, 27, 40 +"(+)", "Allocation summary allocated 20022 deallocated 255 not deallocated 19767", 20022, 255, 19767, 36, 10, 26 +"(+ 1)", "Allocation summary allocated 20030 deallocated 260 not deallocated 19770", 20030, 260, 19770, 44, 15, 29 +"(+ 1 1)", "Allocation summary allocated 20039 deallocated 265 not deallocated 19774", 20039, 265, 19774, 53, 20, 33 +"(+ 1 1 1)", "Allocation summary allocated 20048 deallocated 270 not deallocated 19778", 20048, 270, 19778, 62, 25, 37 +"(+ 1 2 3)", "Allocation summary allocated 20048 deallocated 270 not deallocated 19778", 20048, 270, 19778, 62, 25, 37 +"(list 'a 'a 'a)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118 +"(list 'a 'b 'c)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118 +"(list :a :b :c)", "Allocation summary allocated 20107 deallocated 260 not deallocated 19847", 20107, 260, 19847, 121, 15, 106 +"(list :aa :bb :cc)", "Allocation summary allocated 20185 deallocated 260 not deallocated 19925", 20185, 260, 19925, 199, 15, 184 +"(list :aaa :bbb :ccc)", "Allocation summary allocated 20263 deallocated 260 not deallocated 20003", 20263, 260, 20003, 277, 15, 262 +"(list :alpha :bravo :charlie)", "Allocation summary allocated 20471 deallocated 260 not deallocated 20211", 20471, 260, 20211, 485, 15, 470 +"{}", "Allocation summary allocated 19992 deallocated 251 not deallocated 19741", 19992, 251, 19741, 6, 6, 0 +"{:z 0}", "Allocation summary allocated 20029 deallocated 257 not deallocated 19772", 20029, 257, 19772, 43, 12, 31 +"{:zero 0}", "Allocation summary allocated 20107 deallocated 257 not deallocated 19850", 20107, 257, 19850, 121, 12, 109 +"{:z 0 :o 1}", "Allocation summary allocated 20066 deallocated 261 not deallocated 19805", 20066, 261, 19805, 80, 16, 64 +"{:zero 0 :one 1}", "Allocation summary allocated 20196 deallocated 263 not deallocated 19933", 20196, 263, 19933, 210, 18, 192 +"{:z 0 :o 1 :t 2}", "Allocation summary allocated 20103 deallocated 265 not deallocated 19838", 20103, 265, 19838, 117, 20, 97 +"{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}", "Allocation summary allocated 21164 deallocated 306 not deallocated 20858", 21164, 306, 20858, 1178, 61, 1117 diff --git a/archive/unit-tests/allocation-tests/grep.bb b/archive/unit-tests/allocation-tests/grep.bb new file mode 100755 index 0000000..23b187a --- /dev/null +++ b/archive/unit-tests/allocation-tests/grep.bb @@ -0,0 +1,19 @@ +#!/home/simon/bin/bb + +(require '[clojure.java.io :as io]) +(import '[java.lang ProcessBuilder$Redirect]) + +(defn grep [input pattern] + (let [proc (-> (ProcessBuilder. ["grep" pattern]) + (.redirectOutput ProcessBuilder$Redirect/INHERIT) + (.redirectError ProcessBuilder$Redirect/INHERIT) + (.start)) + proc-input (.getOutputStream proc)] + (with-open [w (io/writer proc-input)] + (binding [*out* w] + (print input) + (flush))) + (.waitFor proc) + nil)) + +(grep "hello\nbye\n" "e") diff --git a/unit-tests/allocation-tests/test-forms b/archive/unit-tests/allocation-tests/test-forms similarity index 100% rename from unit-tests/allocation-tests/test-forms rename to archive/unit-tests/allocation-tests/test-forms diff --git a/unit-tests/append.sh b/archive/unit-tests/append.sh similarity index 100% rename from unit-tests/append.sh rename to archive/unit-tests/append.sh diff --git a/unit-tests/apply.sh b/archive/unit-tests/apply.sh similarity index 100% rename from unit-tests/apply.sh rename to archive/unit-tests/apply.sh diff --git a/archive/unit-tests/assoc.sh b/archive/unit-tests/assoc.sh new file mode 100644 index 0000000..339c023 --- /dev/null +++ b/archive/unit-tests/assoc.sh @@ -0,0 +1,60 @@ +#!/bin/bash + +result=0 + +expected='1' +actual=`echo "(assoc 'foo '((foo . 1) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1` + + +echo -n "$0 $1: assoc list binding... " + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=`echo "${result} + 1" | bc` +fi + +expected='4' +actual=`echo "(assoc 'froboz '((foo . 1) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1` + + +echo -n "$0 $1: hashmap binding... " + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=`echo "${result} + 1" | bc` +fi + +expected='nil' +actual=`echo "(assoc 'ban '((foo . 1) (bar . 2) {ban nil froboz 4 foo 5} (foobar . 6) (ban . 7)))" | target/psse | tail -1` + + +echo -n "$0 $1: key bound to 'nil' (1)... " + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=`echo "${result} + 1" | bc` +fi + +expected='nil' +actual=`echo "(assoc 'foo '((foo . nil) (bar . 2) {ban 3 froboz 4 foo 5} (foobar . 6)))" | target/psse | tail -1` + + +echo -n "$0 $1: key bound to nil (2)... " + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=`echo "${result} + 1" | bc` +fi + diff --git a/unit-tests/bignum-add.sh b/archive/unit-tests/bignum-add.sh similarity index 100% rename from unit-tests/bignum-add.sh rename to archive/unit-tests/bignum-add.sh diff --git a/unit-tests/bignum-expt.sh b/archive/unit-tests/bignum-expt.sh similarity index 100% rename from unit-tests/bignum-expt.sh rename to archive/unit-tests/bignum-expt.sh diff --git a/unit-tests/bignum-print.sh b/archive/unit-tests/bignum-print.sh similarity index 100% rename from unit-tests/bignum-print.sh rename to archive/unit-tests/bignum-print.sh diff --git a/unit-tests/bignum-subtract.sh b/archive/unit-tests/bignum-subtract.sh similarity index 100% rename from unit-tests/bignum-subtract.sh rename to archive/unit-tests/bignum-subtract.sh diff --git a/unit-tests/bignum.sh b/archive/unit-tests/bignum.sh similarity index 100% rename from unit-tests/bignum.sh rename to archive/unit-tests/bignum.sh diff --git a/unit-tests/complex-list.sh b/archive/unit-tests/complex-list.sh similarity index 100% rename from unit-tests/complex-list.sh rename to archive/unit-tests/complex-list.sh diff --git a/unit-tests/cond.sh b/archive/unit-tests/cond.sh similarity index 100% rename from unit-tests/cond.sh rename to archive/unit-tests/cond.sh diff --git a/unit-tests/empty-list.sh b/archive/unit-tests/empty-list.sh similarity index 100% rename from unit-tests/empty-list.sh rename to archive/unit-tests/empty-list.sh diff --git a/unit-tests/empty-string.sh b/archive/unit-tests/empty-string.sh similarity index 100% rename from unit-tests/empty-string.sh rename to archive/unit-tests/empty-string.sh diff --git a/unit-tests/equal.sh b/archive/unit-tests/equal.sh similarity index 100% rename from unit-tests/equal.sh rename to archive/unit-tests/equal.sh diff --git a/unit-tests/eval-integer.sh b/archive/unit-tests/eval-integer.sh similarity index 100% rename from unit-tests/eval-integer.sh rename to archive/unit-tests/eval-integer.sh diff --git a/unit-tests/eval-quote-sexpr.sh b/archive/unit-tests/eval-quote-sexpr.sh similarity index 100% rename from unit-tests/eval-quote-sexpr.sh rename to archive/unit-tests/eval-quote-sexpr.sh diff --git a/unit-tests/eval-quote-symbol.sh b/archive/unit-tests/eval-quote-symbol.sh similarity index 100% rename from unit-tests/eval-quote-symbol.sh rename to archive/unit-tests/eval-quote-symbol.sh diff --git a/unit-tests/eval-real.sh b/archive/unit-tests/eval-real.sh similarity index 100% rename from unit-tests/eval-real.sh rename to archive/unit-tests/eval-real.sh diff --git a/unit-tests/eval-string.sh b/archive/unit-tests/eval-string.sh similarity index 100% rename from unit-tests/eval-string.sh rename to archive/unit-tests/eval-string.sh diff --git a/unit-tests/fred.sh b/archive/unit-tests/fred.sh similarity index 100% rename from unit-tests/fred.sh rename to archive/unit-tests/fred.sh diff --git a/unit-tests/integer-allocation.sh b/archive/unit-tests/integer-allocation.sh similarity index 100% rename from unit-tests/integer-allocation.sh rename to archive/unit-tests/integer-allocation.sh diff --git a/unit-tests/integer.sh b/archive/unit-tests/integer.sh similarity index 100% rename from unit-tests/integer.sh rename to archive/unit-tests/integer.sh diff --git a/unit-tests/interpreter.sh b/archive/unit-tests/interpreter.sh similarity index 100% rename from unit-tests/interpreter.sh rename to archive/unit-tests/interpreter.sh diff --git a/unit-tests/lambda.sh b/archive/unit-tests/lambda.sh similarity index 100% rename from unit-tests/lambda.sh rename to archive/unit-tests/lambda.sh diff --git a/unit-tests/let.sh b/archive/unit-tests/let.sh similarity index 100% rename from unit-tests/let.sh rename to archive/unit-tests/let.sh diff --git a/unit-tests/list-test.sh b/archive/unit-tests/list-test.sh similarity index 100% rename from unit-tests/list-test.sh rename to archive/unit-tests/list-test.sh diff --git a/unit-tests/many-args.sh b/archive/unit-tests/many-args.sh similarity index 100% rename from unit-tests/many-args.sh rename to archive/unit-tests/many-args.sh diff --git a/unit-tests/map.sh b/archive/unit-tests/map.sh similarity index 100% rename from unit-tests/map.sh rename to archive/unit-tests/map.sh diff --git a/archive/unit-tests/mapcar.sh b/archive/unit-tests/mapcar.sh new file mode 100644 index 0000000..70b41b0 --- /dev/null +++ b/archive/unit-tests/mapcar.sh @@ -0,0 +1,31 @@ +#!/bin/bash + +result=0 + +##################################################################### +# Create an empty map using map notation +expected='(2 3 4)' +actual=`echo "(mapcar (lambda (n) (+ n 1)) '(1 2 3))" | target/psse | tail -1` + +echo -n "$0: Mapping interpreted function across list: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=1 +fi + +##################################################################### +# Create an empty map using make-map +expected='("INTR" "REAL" "RTIO" "KEYW")' +actual=`echo "(mapcar type '(1 1.0 1/2 :one))" | target/psse | tail -1` + +echo -n "$0: Mapping primitive function across list: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + result=1 +fi diff --git a/unit-tests/memberp.sh b/archive/unit-tests/memberp.sh similarity index 100% rename from unit-tests/memberp.sh rename to archive/unit-tests/memberp.sh diff --git a/unit-tests/memory.sh b/archive/unit-tests/memory.sh similarity index 100% rename from unit-tests/memory.sh rename to archive/unit-tests/memory.sh diff --git a/unit-tests/multiply.sh b/archive/unit-tests/multiply.sh similarity index 100% rename from unit-tests/multiply.sh rename to archive/unit-tests/multiply.sh diff --git a/unit-tests/nil.sh b/archive/unit-tests/nil.sh similarity index 100% rename from unit-tests/nil.sh rename to archive/unit-tests/nil.sh diff --git a/unit-tests/nlambda.sh b/archive/unit-tests/nlambda.sh similarity index 100% rename from unit-tests/nlambda.sh rename to archive/unit-tests/nlambda.sh diff --git a/unit-tests/path-notation.sh b/archive/unit-tests/path-notation.sh similarity index 100% rename from unit-tests/path-notation.sh rename to archive/unit-tests/path-notation.sh diff --git a/unit-tests/progn.sh b/archive/unit-tests/progn.sh similarity index 100% rename from unit-tests/progn.sh rename to archive/unit-tests/progn.sh diff --git a/unit-tests/quote.sh b/archive/unit-tests/quote.sh similarity index 100% rename from unit-tests/quote.sh rename to archive/unit-tests/quote.sh diff --git a/unit-tests/quoted-list.sh b/archive/unit-tests/quoted-list.sh similarity index 100% rename from unit-tests/quoted-list.sh rename to archive/unit-tests/quoted-list.sh diff --git a/unit-tests/ratio-addition.sh b/archive/unit-tests/ratio-addition.sh similarity index 100% rename from unit-tests/ratio-addition.sh rename to archive/unit-tests/ratio-addition.sh diff --git a/unit-tests/recursion.sh b/archive/unit-tests/recursion.sh similarity index 100% rename from unit-tests/recursion.sh rename to archive/unit-tests/recursion.sh diff --git a/unit-tests/reverse.sh b/archive/unit-tests/reverse.sh similarity index 100% rename from unit-tests/reverse.sh rename to archive/unit-tests/reverse.sh diff --git a/unit-tests/simple-list.sh b/archive/unit-tests/simple-list.sh similarity index 100% rename from unit-tests/simple-list.sh rename to archive/unit-tests/simple-list.sh diff --git a/unit-tests/slurp.sh b/archive/unit-tests/slurp.sh similarity index 100% rename from unit-tests/slurp.sh rename to archive/unit-tests/slurp.sh diff --git a/unit-tests/string-allocation.sh b/archive/unit-tests/string-allocation.sh similarity index 100% rename from unit-tests/string-allocation.sh rename to archive/unit-tests/string-allocation.sh diff --git a/unit-tests/string-cons.sh b/archive/unit-tests/string-cons.sh similarity index 100% rename from unit-tests/string-cons.sh rename to archive/unit-tests/string-cons.sh diff --git a/unit-tests/string-with-spaces.sh b/archive/unit-tests/string-with-spaces.sh similarity index 100% rename from unit-tests/string-with-spaces.sh rename to archive/unit-tests/string-with-spaces.sh diff --git a/unit-tests/subtract.sh b/archive/unit-tests/subtract.sh similarity index 100% rename from unit-tests/subtract.sh rename to archive/unit-tests/subtract.sh diff --git a/unit-tests/try.sh b/archive/unit-tests/try.sh similarity index 100% rename from unit-tests/try.sh rename to archive/unit-tests/try.sh diff --git a/unit-tests/varargs.sh b/archive/unit-tests/varargs.sh similarity index 100% rename from unit-tests/varargs.sh rename to archive/unit-tests/varargs.sh diff --git a/unit-tests/wide-character.sh b/archive/unit-tests/wide-character.sh similarity index 100% rename from unit-tests/wide-character.sh rename to archive/unit-tests/wide-character.sh diff --git a/docs/Paged-space-objects.md b/docs/Paged-space-objects.md index 6885b70..8ecbd11 100644 --- a/docs/Paged-space-objects.md +++ b/docs/Paged-space-objects.md @@ -3,7 +3,7 @@ *Antecedents for this essay: 1. [Reference counting, and the garbage collection of equal sized objects](https://www.journeyman.cc/blog/posts-output/2013-08-25-reference-counting-and-the-garbage-collection-of-equal-sized-objects/); -2. [Vector space, Pages, Mark-but-don't-sweep, and the world's slowest ever rapid prototype](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/). +2. [Vector space, Pages, Mark-but-don't-sweep, and the world's slowest ever rapid prototype](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/).* The post-scarcity software environment needs to store data in objects. Much of the data will be in objects which will fit in the memory footpring ot a cons cell, but some won't, and those that won't will be in a variety of sizes. diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 55d9bab..ffa4e79 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,29 @@ # State of Play +## 20260323 + +I started an investigastion of the [Zig language](https://ziglang.org/) and +come away frustrated. It's definitely an interesting language, and *I think* +one capable of doing what I want. But in trying to learn, I checked out +someone else's [Lisp interpreter in Zig](https://github.com/cryptocode/bio). +The last commit to this project is six months ago, so fairly current; project +documentation is polished, implying the project is well advanced and by someone +competent. + +It won't build. + +It won't build because there are breaking changes to the build system in the +current version of Zig, and, according to helpful people on the Zig language +Discord, breaking changes in Zig versions are quite frequent. + +Post-scarcity is a project which procedes slowly, and is very large indeed. I +will certainly not complete it before I die. + +I don't feel unstable tools are a good choice. + +I have, however, done more thinking about [Paged space objects], and think I +now have a buildable specification. + ## 20260319 Right, the `member?` bug [is fixed](https://git.journeyman.cc/simon/post-scarcity/issues/11). From 19d6b0df29226af22758c85e4547e0fdf240904f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 24 Mar 2026 16:53:54 +0000 Subject: [PATCH 05/29] Firming up the roadmap for the 0.1.X prototype --- docs/0-1-0-design-decistions.md | 89 +++++++++++++++++++++++++++++++++ docs/Roadmap.md | 77 +++++++++++++++++++++------- 2 files changed, 147 insertions(+), 19 deletions(-) create mode 100644 docs/0-1-0-design-decistions.md diff --git a/docs/0-1-0-design-decistions.md b/docs/0-1-0-design-decistions.md new file mode 100644 index 0000000..3ec5401 --- /dev/null +++ b/docs/0-1-0-design-decistions.md @@ -0,0 +1,89 @@ +# Design decisions for 0.1.0 + +This is a document that is likely to be revisited, probably frequently. + +## Retire the 0.0.X codebase + +Move the existing codebase out of the compile space altogether; it is to be +treated as a finished rapid prototype, not extended further, and code largely +not copied but learned from. + +## Remain open to new substrate languages, but continue in C for now + +I'm disappointed with [Zig](https://ziglang.org/). While the language +concepts are beautiful, and if it were stable it would be an excellent tool, it +isn't stable. I'm still open to build some of the 0.1.X prototype in Zig, but +it isn't the main tool. + +I haven't yet evaluated [Nim](https://nim-lang.org/). I'm prejudiced against +its syntax, but, again, I'm open to using it for some of this prototype. + +But for now, I will continue to work in C. + +## Substrate is shallow + +In the 0.0.X prototype, I tried to do too much in the substrate. I tried to +write bignums in C, and in this I failed; I would have done much better to +get a very small Lisp working well sooner, and build new features in that. + +In 0.1.X the substrate will be much less feature rich, but support the creation +of novel types of data object in Lisp. + +## Paged Space Objects + +Paged space objects will be implemented largely in line with [this document](Paged-space-objects.md). + +## Tags + +Tags will continue to be 32 bit objects, which can be considered as unsigned +integer values or as four bytes. However, only the first three bytes will be +mnemonic. The fourth byte will indicate the size class of the object; where +the size class represents the allocation size, *not* the payload size. The +encoding is as in this table: + +| Tag | | | Size of payload | | +| ---- | ----------- | --- | --------------- | --------------- | +| Bits | Field value | Hex | Number of words | Number of bytes | +| ---- | ----------- | --- | --------------- | --------------- | +| 0000 | 0 | 0 | 1 | 8 | +| 0001 | 1 | 1 | 2 | 16 | +| 0010 | 2 | 2 | 4 | 32 | +| 0011 | 3 | 3 | 8 | 64 | +| 0100 | 4 | 4 | 16 | 128 | +| 0101 | 5 | 5 | 32 | 256 | +| 0110 | 6 | 6 | 64 | 512 | +| 0111 | 7 | 7 | 128 | 1024 | +| 1000 | 8 | 8 | 256 | 2048 | +| 1001 | 9 | 9 | 512 | 4096 | +| 1010 | 10 | A | 1024 | 8192 | +| 1011 | 11 | B | 2048 | 16384 | +| 1100 | 12 | C | 4096 | 32768 | +| 1101 | 13 | D | 8192 | 65536 | +| 1110 | 14 | E | 16384 | 131072 | +| 1111 | 15 | F | 32768 | 262144 | + +Consequently, an object of size class F will have an allocation size of 32,768 words, but a payload size of 32,766 words. This obviously means that size classes 0 and 1 will not exist, since they would not have any payload. + +## Page size + +Every page will be 1,048,576 bytes. + +## Namespaces + +Namespaces will be implemented; in addition to the root namespace, there will be at least the following namespaces: + +### :bootstrap + +Functions written in the substrate language, intended to be replaced for all normal purposes by functions written in Lisp which may call these bootstrap functions. Not ever available to user code. + +### :substrate + +Functions written in the substrate language which *may* be available to user-written code. + +### :system + +Functions, written either in Lisp or in the substrate language, which modify system memory in ways that only trusted and privileged users are permitted to do. + +## Access control + +Obviously, for this to work, access control lists must be implemented and must work. \ No newline at end of file diff --git a/docs/Roadmap.md b/docs/Roadmap.md index fb83875..fd227d2 100644 --- a/docs/Roadmap.md +++ b/docs/Roadmap.md @@ -1,17 +1,23 @@ # Roadmap -With the release of 0.0.6 close, it's time to look at a plan for the future development of the project. +With the release of 0.0.6 close, it's time to look at a plan for the future +development of the project. -I have an almost-working Lisp interpreter, which, as an interpreter, has many of the features of the language I want. It runs in one thread on one processor. +I have an almost-working Lisp interpreter, which, as an interpreter, has many +of the features of the language I want. It runs in one thread on one processor. -Given how experimental this all is, I don't think I need it to be a polished interpreter, and polished it isn't. Lots of things are broken. +Given how experimental this all is, I don't think I need it to be a polished +interpreter, and polished it isn't. Lots of things are broken. -* garbage collection is pretty broken, and I'n beginning to doubt my whole garbage collection strategy; +* garbage collection is pretty broken, and I'n beginning to doubt my whole + garbage collection strategy; * bignums are horribly broken; -* there's something very broken in shallow-bound symbols, and that matters and wil have to be fixed; +* there's something very broken in shallow-bound symbols, and that matters + and will have to be fixed; * there are undoubtedly many other bugs I don't know about. -However, while I will fix bugs where I can, it's good enough for other people to play with if they're mad enough, and it's time to move on. +However, while I will fix bugs where I can, it's good enough for other people +to play with if they're mad enough, and it's time to move on. ## Next major milestones @@ -50,44 +56,77 @@ So release 0.1.0, which I'll target for 1st January 2027, will essentially be a Lisp interpreter running on the new substrate and memory architecture, without any significant new features. +See [0.1.0 design decisions](0-1-0-design-decisions.md) for more detail. + ### Simulated hypercube -There is really no point to this whole project while it remains a single thread running on a single processor. Until I can pass off computation to peer neighbours, I can't begin to understand what the right strategies are for when to do so. +There is really no point to this whole project while it remains a single thread +running on a single processor. Until I can pass off computation to peer +neighbours, I can't begin to understand what the right strategies are for when +to do so. -`cond` is explicitly sequential, since later clauses should not be executed at all if earlier ones succeed. `progn` is sort of implicitly sequential, since it's the value of the last form in the sequence which will be returned. +`cond` is explicitly sequential, since later clauses should not be executed at +all if earlier ones succeed. `progn` is sort of implicitly sequential, since +it's the value of the last form in the sequence which will be returned. -For `mapcar`, the right strategy might be to partition the list argument between each of the idle neighbours, and then reassemble the results that come bask. +For `mapcar`, the right strategy might be to partition the list argument +between each of the idle neighbours, and then reassemble the results that come +bask. -For most other things, my hunch is that you pass args which are not self-evaluating to idle neighbours, keeping (at least) one on the originating node to work on while they're busy. +For most other things, my hunch is that you pass args which are not +self-evaluating to idle neighbours, keeping (at least) one on the originating +node to work on while they're busy. -But before that can happen, we need a router on each node which can monitor concurrent traffic on six bidirectional links. I think at least initially what gets written across those links is just S-expressions. +But before that can happen, we need a router on each node which can monitor +concurrent traffic on six bidirectional links. I think at least initially what +gets written across those links is just S-expressions. -I think a working simulated hypercube is the key milestone for version 0.1.1. +I think a working simulated hypercube is the key milestone for version 0.2.0. ### Sysout, sysin, and system persistance -Doctrine is that the post scarcity computing environment doesn't have a file system, but nevertheless we need some way of making an image of a working system so that, after a catastrophic crash or a power outage, it can be brought back up to a known good state. This also really needs to be in 0.1.1. +Doctrine is that the post scarcity computing environment doesn't have a file +system, but nevertheless we need some way of making an image of a working +system so that, after a catastrophic crash or a power outage, it can be brought +back up to a known good state. This really needs to be in 0.1.1. ### Better command line experience -The current command line experience is embarrassingly poor. Recallable input history, input line editing, and a proper structure editor are all things that I will need for my comfort. +The current command line experience is embarrassingly poor. Recallable input +history, input line editing, and a proper structure editor are all things that +I will need for my comfort. ### Users, groups and ACLs -Allowing multiple users to work together within the same post scarcity computing environment while retaining security and privacy is a major goal. So working out ways for users to sign on and be authenticated, and to configure their own environment, and to set up their own access control lists on objects they create, needs to be another nearish term goal. Probably 0.1.2. +Allowing multiple users to work together within the same post scarcity +computing environment while retaining security and privacy is a major goal. So +working out ways for users to sign on and be authenticated, and to configure +their own environment, and to set up their own access control lists on objects +they create, needs to be another nearish term goal. Probably 0.1.2. ### Homogeneities, regularities, slots, migration, permeability -There are a lot of good ideas about the categorisation and organisation of data which are sketched in my original [Post scarcity software](Post-scarcity-software.md) essay which I've never really developed further because I didn't have the right software environment for them, which now I shall have. It would be good to build them. +There are a lot of good ideas about the categorisation and organisation of data +which are sketched in my original +[Post scarcity software](Post-scarcity-software.md) essay which I've never +really developed further because I didn't have the right software environment +for them, which now I shall have. It would be good to build them. ### Compiler -I do want this system to have a compiler. I do want compiled functions to be the default. And I do want to understand how to write my own compiler for a system like this. But until I know what the processor architecture of the system I'm targetting is, worrying too much about a compiler seems premature. +I do want this system to have a compiler. I do want compiled functions to be +the default. And I do want to understand how to write my own compiler for a +system like this. But until I know what the processor architecture of the +system I'm targetting is, worrying too much about a compiler seems premature. ### Graphical User Interface -Ultimately I want a graphical user interface at least as fluid and flexible as what we had on Interlisp machines 40 years ago. It's not a near term goal there. +Ultimately I want a graphical user interface at least as fluid and flexible as +what we had on Interlisp machines 40 years ago. It's not a near term goal yet. ### Real hardware -This machine would be **very** expensive to build, and there's no way I'm ever going to afford more than a sixty-four node machine. But it would be nice to have software which would run effectively on a four billion node machine, if one could ever be built. I think that has to be the target for version 1.0.0. \ No newline at end of file +This machine would be **very** expensive to build, and there's no way I'm ever +going to afford more than a sixty-four node machine. But it would be nice to +have software which would run effectively on a four billion node machine, if +one could ever be built. I think that has to be the target for version 1.0.0. \ No newline at end of file From cb84e7ef95e6565ecf14e020b8eb7090f7ff8012 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 24 Mar 2026 16:58:12 +0000 Subject: [PATCH 06/29] Copied latest roadmap and 0.1.X design document from develop branch --- docs/0-1-0-design-decisions.md | 111 ++++++++++++++++++++++++++++++++ docs/Roadmap.md | 112 +++++++++++++++++++++++++++------ 2 files changed, 204 insertions(+), 19 deletions(-) create mode 100644 docs/0-1-0-design-decisions.md diff --git a/docs/0-1-0-design-decisions.md b/docs/0-1-0-design-decisions.md new file mode 100644 index 0000000..af170f4 --- /dev/null +++ b/docs/0-1-0-design-decisions.md @@ -0,0 +1,111 @@ +# Design decisions for 0.1.0 + +This is a document that is likely to be revisited, probably frequently. + +## Retire the 0.0.X codebase + +Move the existing codebase out of the compile space altogether; it is to be +treated as a finished rapid prototype, not extended further, and code largely +not copied but learned from. + +## Remain open to new substrate languages, but continue in C for now + +I'm disappointed with [Zig](https://ziglang.org/). While the language +concepts are beautiful, and if it were stable it would be an excellent tool, it +isn't stable. I'm still open to build some of the 0.1.X prototype in Zig, but +it isn't the main tool. + +I haven't yet evaluated [Nim](https://nim-lang.org/). I'm prejudiced against +its syntax, but, again, I'm open to using it for some of this prototype. + +But for now, I will continue to work in C. + +## Substrate is shallow + +In the 0.0.X prototype, I tried to do too much in the substrate. I tried to +write bignums in C, and in this I failed; I would have done much better to +get a very small Lisp working well sooner, and build new features in that. + +In 0.1.X the substrate will be much less feature rich, but support the creation +of novel types of data object in Lisp. + +## Sysin and sysout are urgent + +If a significant proportion of the system is written in Lisp, it must be +possible to save a working Lisp image to file and recover it. + +## Compiler is urgent + +I still don't know how to write a compiler, and writing a compiler will still +be a major challenge. But I am now much closer to knowing how to write a +compiler than I was. I think it's important to have a compiler, both for +performance and for security. Given that we do not have a separate execute ACL, +if a user can execute an interpreted function, they can also read its source. + +Generally this is a good thing. For things low down in the stack, it may not +be. + +## Paged Space Objects + +Paged space objects will be implemented largely in line with +[this document](Paged-space-objects.md). + +## Tags + +Tags will continue to be 32 bit objects, which can be considered as unsigned +integer values or as four bytes. However, only the first three bytes will be +mnemonic. The fourth byte will indicate the size class of the object; where +the size class represents the allocation size, *not* the payload size. The +encoding is as in this table: + +| Tag | | | Size of payload | | +| ---- | ----------- | --- | --------------- | --------------- | +| Bits | Field value | Hex | Number of words | Number of bytes | +| ---- | ----------- | --- | --------------- | --------------- | +| 0000 | 0 | 0 | 1 | 8 | +| 0001 | 1 | 1 | 2 | 16 | +| 0010 | 2 | 2 | 4 | 32 | +| 0011 | 3 | 3 | 8 | 64 | +| 0100 | 4 | 4 | 16 | 128 | +| 0101 | 5 | 5 | 32 | 256 | +| 0110 | 6 | 6 | 64 | 512 | +| 0111 | 7 | 7 | 128 | 1024 | +| 1000 | 8 | 8 | 256 | 2048 | +| 1001 | 9 | 9 | 512 | 4096 | +| 1010 | 10 | A | 1024 | 8192 | +| 1011 | 11 | B | 2048 | 16384 | +| 1100 | 12 | C | 4096 | 32768 | +| 1101 | 13 | D | 8192 | 65536 | +| 1110 | 14 | E | 16384 | 131072 | +| 1111 | 15 | F | 32768 | 262144 | + +Consequently, an object of size class F will have an allocation size of 32,768 words, but a payload size of 32,766 words. This obviously means that size classes 0 and 1 will not exist, since they would not have any payload. + +## Page size + +Every page will be 1,048,576 bytes. + +## Namespaces + +Namespaces will be implemented; in addition to the root namespace, there will be at least the following namespaces: + +### :bootstrap + +Functions written in the substrate language, intended to be replaced for all normal purposes by functions written in Lisp which may call these bootstrap functions. Not ever available to user code. + +### :substrate + +Functions written in the substrate language which *may* be available to user-written code. + +### :system + +Functions, written either in Lisp or in the substrate language, which modify system memory in ways that only trusted and privileged users are permitted to do. + +## Access control + +Obviously, for this to work, access control lists must be implemented and must work. + +## Router is deferred to 0.2.X + +This generation is about producing a better single thread Lisp (but hopefully +to build it fast); the hypercube topology is deferred. \ No newline at end of file diff --git a/docs/Roadmap.md b/docs/Roadmap.md index 7cd654b..fd227d2 100644 --- a/docs/Roadmap.md +++ b/docs/Roadmap.md @@ -1,58 +1,132 @@ # Roadmap -With the release of 0.0.6 close, it's time to look at a plan for the future development of the project. +With the release of 0.0.6 close, it's time to look at a plan for the future +development of the project. -I have an almost-working Lisp interpreter, which, as an interpreter, has many of the features of the language I want. It runs in one thread on one processor. +I have an almost-working Lisp interpreter, which, as an interpreter, has many +of the features of the language I want. It runs in one thread on one processor. -Given how experimental this all is, I don't think I need it to be a polished interpreter, and polished it isn't. Lots of things are broken. +Given how experimental this all is, I don't think I need it to be a polished +interpreter, and polished it isn't. Lots of things are broken. -* garbage collection is pretty broken, and I'n beginning to doubt my whole garbage collection strategy; +* garbage collection is pretty broken, and I'n beginning to doubt my whole + garbage collection strategy; * bignums are horribly broken; -* there's something very broken in shallow-bound symbols, and that matters and wil have to be fixed; +* there's something very broken in shallow-bound symbols, and that matters + and will have to be fixed; * there are undoubtedly many other bugs I don't know about. -However, while I will fix bugs where I can, it's good enough for other people to play with if they're mad enough, and it's time to move on. +However, while I will fix bugs where I can, it's good enough for other people +to play with if they're mad enough, and it's time to move on. ## Next major milestones +### New substrate language? + +I really don't feel competent to write the substrate in C, and I don't think +that what exists of the substrate is of sufficient quality. It's too big and +too complex. I think what the system needs is a smaller substrate written in +a more modern language. + +I propose to evaluate both [Zig](https://ziglang.org/) and +[Rust](https://rust-lang.org/), and see whether I can feel more productive in +either of those. + +### Smaller substrate + +However, I also think the substrate ought to be smaller. I +do not think the substrate should include things like bignum or ratio +arithmetic, for example. I'm not convinced that it should include things like +hashmaps. If these things are to be written in Lisp, though, it means that +there have to be Lisp functions which manipulate memory a long way below the +'[don't know, don't care](Post-scarcity-software.md#store-name-and-value)' +dictum; this means that these functions have to be system private. But they +can be, because access control lists on arbitrary objects have always been +part of this architecture. + +### The 0.1.0 branch + +I'm therefore proposing, immediately, to upversion the `develop` branch to +0.1.0, and restart pretty much from scratch. For now, the C code will remain in +the development tree, and I may fix bugs which annoy me (and possibly other +people), but I doubt there now will be a 0.0.7 release, unless I decide that +the new substrate languages are a bust. + +So release 0.1.0, which I'll target for 1st January 2027, will +essentially be a Lisp interpreter running on the new substrate and memory +architecture, without any significant new features. + +See [0.1.0 design decisions](0-1-0-design-decisions.md) for more detail. + ### Simulated hypercube -There is really no point to this whole project while it remains a single thread running on a single processor. Until I can pass off computation to peer neighbours, I can't begin to understand what the right strategies are for when to do so. +There is really no point to this whole project while it remains a single thread +running on a single processor. Until I can pass off computation to peer +neighbours, I can't begin to understand what the right strategies are for when +to do so. -`cond` is explicitly sequential, since later clauses should not be executed at all if earlier ones succeed. `progn` is sort of implicitly sequential, since it's the value of the last form in the sequence which will be returned. +`cond` is explicitly sequential, since later clauses should not be executed at +all if earlier ones succeed. `progn` is sort of implicitly sequential, since +it's the value of the last form in the sequence which will be returned. -For `mapcar`, the right strategy might be to partition the list argument between each of the idle neighbours, and then reassemble the results that come bask. +For `mapcar`, the right strategy might be to partition the list argument +between each of the idle neighbours, and then reassemble the results that come +bask. -For most other things, my hunch is that you pass args which are not self-evaluating to idle neighbours, keeping (at least) one on the originating node to work on while they're busy. +For most other things, my hunch is that you pass args which are not +self-evaluating to idle neighbours, keeping (at least) one on the originating +node to work on while they're busy. -But before that can happen, we need a router on each node which can monitor concurrent traffic on six bidirectional links. I think at least initially what gets written across those links is just S-expressions. +But before that can happen, we need a router on each node which can monitor +concurrent traffic on six bidirectional links. I think at least initially what +gets written across those links is just S-expressions. -I think a working simulated hypercube is the key milestone for version 0.0.7. +I think a working simulated hypercube is the key milestone for version 0.2.0. ### Sysout, sysin, and system persistance -Doctrine is that the post scarcity computing environment doesn't have a file system, but nevertheless we need some way of making an image of a working system so that, after a catastrophic crash or a power outage, it can be brought back up to a known good state. This also really needs to be in 0.0.7. +Doctrine is that the post scarcity computing environment doesn't have a file +system, but nevertheless we need some way of making an image of a working +system so that, after a catastrophic crash or a power outage, it can be brought +back up to a known good state. This really needs to be in 0.1.1. ### Better command line experience -The current command line experience is embarrassingly poor. Recallable input history, input line editing, and a proper structure editor are all things that I will need for my comfort. +The current command line experience is embarrassingly poor. Recallable input +history, input line editing, and a proper structure editor are all things that +I will need for my comfort. ### Users, groups and ACLs -Allowing multiple users to work together within the same post scarcity computing environment while retaining security and privacy is a major goal. So working out ways for users to sign on and be authenticated, and to configure their own environment, and to set up their own access control lists on objects they create, needs to be another nearish term goal. Probably 0.0.8. +Allowing multiple users to work together within the same post scarcity +computing environment while retaining security and privacy is a major goal. So +working out ways for users to sign on and be authenticated, and to configure +their own environment, and to set up their own access control lists on objects +they create, needs to be another nearish term goal. Probably 0.1.2. ### Homogeneities, regularities, slots, migration, permeability -There are a lot of good ideas about the categorisation and organisation of data which are sketched in my original [Post scarcity software](Post-scarcity-software.md) essay which I've never really developed further because I didn't have the right software environment for them, which now I shall have. It would be good to build them. +There are a lot of good ideas about the categorisation and organisation of data +which are sketched in my original +[Post scarcity software](Post-scarcity-software.md) essay which I've never +really developed further because I didn't have the right software environment +for them, which now I shall have. It would be good to build them. ### Compiler -I do want this system to have a compiler. I do want compiled functions to be the default. And I do want to understand how to write my own compiler for a system like this. But until I know what the processor architecture of the system I'm targetting is, worrying too much about a compiler seems premature. +I do want this system to have a compiler. I do want compiled functions to be +the default. And I do want to understand how to write my own compiler for a +system like this. But until I know what the processor architecture of the +system I'm targetting is, worrying too much about a compiler seems premature. ### Graphical User Interface -Ultimately I want a graphical user interface at least as fluid and flexible as what we had on Interlisp machines 40 years ago. It's not a near term goal there. +Ultimately I want a graphical user interface at least as fluid and flexible as +what we had on Interlisp machines 40 years ago. It's not a near term goal yet. ### Real hardware -This machine would be **very** expensive to build, and there's no way I'm ever going to afford more than a sixty-four node machine. But it would be nice to have software which would run effectively on a four billion node machine, if one could ever be built. I think that has to be the target for version 1.0.0. \ No newline at end of file +This machine would be **very** expensive to build, and there's no way I'm ever +going to afford more than a sixty-four node machine. But it would be nice to +have software which would run effectively on a four billion node machine, if +one could ever be built. I think that has to be the target for version 1.0.0. \ No newline at end of file From f65f2a7c3c24a1e500a1a988b9a116d45e970a7e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 24 Mar 2026 17:05:12 +0000 Subject: [PATCH 07/29] Added the changelog, which should have been in git, but wasn't. --- docs/CHANGELOG.md | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 docs/CHANGELOG.md diff --git a/docs/CHANGELOG.md b/docs/CHANGELOG.md new file mode 100644 index 0000000..149abdd --- /dev/null +++ b/docs/CHANGELOG.md @@ -0,0 +1,37 @@ +# Change log + +## Version 0.0.6 + +The **MY MONSTER, SHE LIVES** release. But also, the *pretend the problems aren't there* release. + +You can hack on this. It mostly doesn't blow up. Bignum arithmetic is broken, but doesn't either segfault or go into non-terminating guru meditations. A lot of garbage isn't getting collected and probably in a long session you will run out of memory, but I haven't yet really characterised how bad this problem is. Subtraction of rationals is broken, which is probably a shallow bug. Map equality is broken, which is also probably fixable. + +### There is no hypercube + +The hypercube router is not yet written. That is the next major milestone, although it will be for a simulated hypercube running on a single conventional UN*X machine rather than for an actual hardware hypercube. + +### There is no compiler + +No compiler has been written. That's partly because I don't really know how to write a computer, but it's also because I don't yet know what processor architecture the compiler needs to target. + +### There's not much user interface + +The user interface is just a very basic REPL. You can't currently even persist your session. You can't edit the input line. You can't save or load files. There is no editor and no debugger. There's certainly no graphics. Exit the REPL by typing [ctrl]-D. + +### So what is there? + +However, there is a basic Lisp environment in which you can write and evaluate functions. It's not as good as any fully developed Lisp, you won't want to use this for anything at all yet except just experimenting with it and perhaps hacking on it. + +### Unit tests known to fail at this release + +Broadly, all the bignum unit tests fail. There are major problems in the bignum subsystem, which I'm ashamed of but I'm stuck on, and rather than bashing my head on a problem on which I was making no progress I've decided to leave that for now and concentrate on other things. + +Apart from the bignum tests, the following unit tests fail: + +| Test | Comment | +| ---- | ------- | +| unit-tests/equal.sh: maps... Fail: expected 't', got 'nil' | Maps in which the same keys have the same values should be equal. Currently they're not. This is a bug. It will be fixed | +| unit-tests/memory.sh => Fail: expected '7106', got '54' | Memory which should be being recovered currently isn't, and this is a major issue. It may mean my garbage collection strategy is fundamentally flawed and may have to be replaced. | +| unit-tests/subtract.sh: (- 4/5 5)... Fail: expected '-3/5', got '3/5' | Subtraction of rational numbers is failing. This is a bug. It will be fixed. | + +There are probably many other bugs. If you find them, please report them [here]() \ No newline at end of file From b8bb9235607b7491bbb63dbed808b56c8fe06f03 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Mar 2026 07:46:28 +0000 Subject: [PATCH 08/29] Minor formatting --- .gitmodules | 3 + Doxyfile | 977 ++++++++++++++++++++++----------- docs/0-1-0-design-decisions.md | 21 +- 3 files changed, 689 insertions(+), 312 deletions(-) create mode 100644 .gitmodules diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..1bfece3 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "munit"] + path = munit + url = https://github.com/nemequ/munit.git diff --git a/Doxyfile b/Doxyfile index c608536..ab3e9da 100644 --- a/Doxyfile +++ b/Doxyfile @@ -1,4 +1,4 @@ -# Doxyfile 1.8.13 +# Doxyfile 1.9.8 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -12,16 +12,26 @@ # For lists, items can also be appended using: # TAG += value [value, ...] # Values that contain spaces should be placed between quotes (\" \"). +# +# Note: +# +# Use doxygen to compare the used configuration file with the template +# configuration file: +# doxygen -x [configFile] +# Use doxygen to compare the used configuration file with the template +# configuration file without replacing the environment variables or CMake type +# replacement variables: +# doxygen -x_noenv [configFile] #--------------------------------------------------------------------------- # Project related configuration options #--------------------------------------------------------------------------- -# This tag specifies the encoding used for all characters in the config file -# that follow. The default is UTF-8 which is also the encoding used for all text -# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv -# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv -# for the list of possible encodings. +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. # The default value is: UTF-8. DOXYFILE_ENCODING = UTF-8 @@ -38,7 +48,7 @@ PROJECT_NAME = "Post Scarcity" # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = +PROJECT_NUMBER = 0.0.6 # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -60,16 +70,28 @@ PROJECT_LOGO = OUTPUT_DIRECTORY = doc -# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- -# directories (in 2 levels) under the output directory of each output format and -# will distribute the generated files over these directories. Enabling this +# If the CREATE_SUBDIRS tag is set to YES then doxygen will create up to 4096 +# sub-directories (in 2 levels) under the output directory of each output format +# and will distribute the generated files over these directories. Enabling this # option can be useful when feeding doxygen a huge amount of source files, where # putting all generated files in the same directory would otherwise causes -# performance problems for the file system. +# performance problems for the file system. Adapt CREATE_SUBDIRS_LEVEL to +# control the number of sub-directories. # The default value is: NO. CREATE_SUBDIRS = NO +# Controls the number of sub-directories that will be created when +# CREATE_SUBDIRS tag is set to YES. Level 0 represents 16 directories, and every +# level increment doubles the number of directories, resulting in 4096 +# directories at level 8 which is the default and also the maximum value. The +# sub-directories are organized in 2 levels, the first level always has a fixed +# number of 16 directories. +# Minimum value: 0, maximum value: 8, default value: 8. +# This tag requires that the tag CREATE_SUBDIRS is set to YES. + +CREATE_SUBDIRS_LEVEL = 8 + # If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII # characters to appear in the names of generated files. If set to NO, non-ASCII # characters will be escaped, for example _xE3_x81_x84 will be used for Unicode @@ -81,14 +103,14 @@ ALLOW_UNICODE_NAMES = YES # The OUTPUT_LANGUAGE tag is used to specify the language in which all # documentation generated by doxygen is written. Doxygen will use this # information to generate all constant output in the proper language. -# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese, -# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States), -# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian, -# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages), -# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian, -# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian, -# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish, -# Ukrainian and Vietnamese. +# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Bulgarian, +# Catalan, Chinese, Chinese-Traditional, Croatian, Czech, Danish, Dutch, English +# (United States), Esperanto, Farsi (Persian), Finnish, French, German, Greek, +# Hindi, Hungarian, Indonesian, Italian, Japanese, Japanese-en (Japanese with +# English messages), Korean, Korean-en (Korean with English messages), Latvian, +# Lithuanian, Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, +# Romanian, Russian, Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, +# Swedish, Turkish, Ukrainian and Vietnamese. # The default value is: English. OUTPUT_LANGUAGE = English @@ -162,7 +184,7 @@ FULL_PATH_NAMES = YES # will be relative from the directory where doxygen is started. # This tag requires that the tag FULL_PATH_NAMES is set to YES. -STRIP_FROM_PATH = ../../ +STRIP_FROM_PATH = ../../ # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # path mentioned in the documentation of a class, which tells the reader which @@ -189,6 +211,16 @@ SHORT_NAMES = NO JAVADOC_AUTOBRIEF = YES +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If # set to NO, the Qt-style will behave just like regular Qt-style comments (thus @@ -209,6 +241,14 @@ QT_AUTOBRIEF = NO MULTILINE_CPP_IS_BRIEF = NO +# By default Python docstrings are displayed as preformatted text and doxygen's +# special commands cannot be used. By setting PYTHON_DOCSTRING to NO the +# doxygen's special commands can be used and the contents of the docstring +# documentation blocks is shown as doxygen documentation. +# The default value is: YES. + +PYTHON_DOCSTRING = YES + # If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the # documentation from any documented member that it re-implements. # The default value is: YES. @@ -232,20 +272,19 @@ TAB_SIZE = 4 # the documentation. An alias has the form: # name=value # For example adding -# "sideeffect=@par Side Effects:\n" +# "sideeffect=@par Side Effects:^^" # will allow you to put the command \sideeffect (or @sideeffect) in the # documentation, which will result in a user-defined paragraph with heading -# "Side Effects:". You can put \n's in the value part of an alias to insert -# newlines. +# "Side Effects:". Note that you cannot put \n's in the value part of an alias +# to insert newlines (in the resulting output). You can put ^^ in the value part +# of an alias to insert a newline as if a physical newline was in the original +# file. When you need a literal { or } or , in the value part of an alias you +# have to escape them by means of a backslash (\), this can lead to conflicts +# with the commands \{ and \} for these it is advised to use the version @{ and +# @} or use a double escape (\\{ and \\}) ALIASES = -# This tag can be used to specify a number of word-keyword mappings (TCL only). -# A mapping has the form "name=value". For example adding "class=itcl::class" -# will allow you to use the command class in the itcl::class meaning. - -TCL_SUBST = - # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For # instance, some of the names that are used will be different. The list of all @@ -274,28 +313,40 @@ OPTIMIZE_FOR_FORTRAN = NO OPTIMIZE_OUTPUT_VHDL = NO +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + # Doxygen selects the parser to use depending on the extension of the files it # parses. With this tag you can assign which parser to use for a given # extension. Doxygen has a built-in mapping, but you can override or extend it # using this tag. The format is ext=language, where ext is a file extension, and -# language is one of the parsers supported by doxygen: IDL, Java, Javascript, -# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran: -# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran: -# Fortran. In the later case the parser tries to guess whether the code is fixed -# or free formatted code, this is the default for Fortran type files), VHDL. For -# instance to make doxygen treat .inc files as Fortran files (default is PHP), -# and .f files as C (default is Fortran), use: inc=Fortran f=C. +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, Lex, D, PHP, md (Markdown), Objective-C, Python, Slice, +# VHDL, Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. # # Note: For files without extension you can use no_extension as a placeholder. # # Note that for custom extensions you also need to set FILE_PATTERNS otherwise -# the files are not read by doxygen. +# the files are not read by doxygen. When specifying no_extension you should add +# * to the FILE_PATTERNS. +# +# Note see also the list of default file extension mappings. EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable -# documentation. See http://daringfireball.net/projects/markdown/ for details. +# documentation. See https://daringfireball.net/projects/markdown/ for details. # The output of markdown processing is further processed by doxygen, so you can # mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in # case of backward compatibilities issues. @@ -307,11 +358,22 @@ MARKDOWN_SUPPORT = YES # to that level are automatically included in the table of contents, even if # they do not have an id attribute. # Note: This feature currently applies only to Markdown headings. -# Minimum value: 0, maximum value: 99, default value: 0. +# Minimum value: 0, maximum value: 99, default value: 5. # This tag requires that the tag MARKDOWN_SUPPORT is set to YES. TOC_INCLUDE_HEADINGS = 5 +# The MARKDOWN_ID_STYLE tag can be used to specify the algorithm used to +# generate identifiers for the Markdown headings. Note: Every identifier is +# unique. +# Possible values are: DOXYGEN use a fixed 'autotoc_md' string followed by a +# sequence number starting at 0 and GITHUB use the lower case version of title +# with any whitespace replaced by '-' and punctuation characters removed. +# The default value is: DOXYGEN. +# This tag requires that the tag MARKDOWN_SUPPORT is set to YES. + +MARKDOWN_ID_STYLE = DOXYGEN + # When enabled doxygen tries to link words that correspond to documented # classes, or namespaces to their corresponding documentation. Such a link can # be prevented in individual cases by putting a % sign in front of the word or @@ -337,7 +399,7 @@ BUILTIN_STL_SUPPORT = NO CPP_CLI_SUPPORT = NO # Set the SIP_SUPPORT tag to YES if your project consists of sip (see: -# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen # will parse them like normal C++ but will assume all classes use public instead # of private inheritance when no explicit protection keyword is present. # The default value is: NO. @@ -423,6 +485,27 @@ TYPEDEF_HIDES_STRUCT = NO LOOKUP_CACHE_SIZE = 0 +# The NUM_PROC_THREADS specifies the number of threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which effectively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + +# If the TIMESTAMP tag is set different from NO then each generated page will +# contain the date or date and time when the page was generated. Setting this to +# NO can help when comparing the output of multiple runs. +# Possible values are: YES, NO, DATETIME and DATE. +# The default value is: NO. + +TIMESTAMP = NO + #--------------------------------------------------------------------------- # Build related configuration options #--------------------------------------------------------------------------- @@ -443,6 +526,12 @@ EXTRACT_ALL = YES EXTRACT_PRIVATE = NO +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + # If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal # scope will be included in the documentation. # The default value is: NO. @@ -480,6 +569,13 @@ EXTRACT_LOCAL_METHODS = NO EXTRACT_ANON_NSPACES = NO +# If this flag is set to YES, the name of an unnamed parameter in a declaration +# will be determined by the corresponding definition. By default unnamed +# parameters remain unnamed in the output. +# The default value is: YES. + +RESOLVE_UNNAMED_PARAMS = YES + # If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all # undocumented members inside documented classes or files. If set to NO these # members will be included in the various overviews, but no documentation @@ -491,14 +587,15 @@ HIDE_UNDOC_MEMBERS = NO # If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all # undocumented classes that are normally visible in the class hierarchy. If set # to NO, these classes will be included in the various overviews. This option -# has no effect if EXTRACT_ALL is enabled. +# will also hide undocumented C++ concepts if enabled. This option has no effect +# if EXTRACT_ALL is enabled. # The default value is: NO. HIDE_UNDOC_CLASSES = NO # If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend -# (class|struct|union) declarations. If set to NO, these declarations will be -# included in the documentation. +# declarations. If set to NO, these declarations will be included in the +# documentation. # The default value is: NO. HIDE_FRIEND_COMPOUNDS = NO @@ -517,12 +614,20 @@ HIDE_IN_BODY_DOCS = NO INTERNAL_DOCS = NO -# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file -# names in lower-case letters. If set to YES, upper-case letters are also -# allowed. This is useful if you have classes or files whose names only differ -# in case and if your file system supports case sensitive file names. Windows -# and Mac users are advised to set this option to NO. -# The default value is: system dependent. +# With the correct setting of option CASE_SENSE_NAMES doxygen will better be +# able to match the capabilities of the underlying filesystem. In case the +# filesystem is case sensitive (i.e. it supports files in the same directory +# whose names only differ in casing), the option must be set to YES to properly +# deal with such files in case they appear in the input. For filesystems that +# are not case sensitive the option should be set to NO to properly deal with +# output files written for symbols that only differ in casing, such as for two +# classes, one named CLASS and the other named Class, and to also support +# references to files without having to specify the exact matching casing. On +# Windows (including Cygwin) and MacOS, users should typically set this option +# to NO, whereas on Linux or other Unix flavors it should typically be set to +# YES. +# Possible values are: SYSTEM, NO and YES. +# The default value is: SYSTEM. CASE_SENSE_NAMES = NO @@ -540,6 +645,12 @@ HIDE_SCOPE_NAMES = YES HIDE_COMPOUND_REFERENCE= NO +# If the SHOW_HEADERFILE tag is set to YES then the documentation for a class +# will show which file needs to be included to use the class. +# The default value is: YES. + +SHOW_HEADERFILE = YES + # If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of # the files that are included by a file in the documentation of that file. # The default value is: YES. @@ -697,7 +808,8 @@ FILE_VERSION_FILTER = # output files in an output format independent way. To create the layout file # that represents doxygen's defaults, run doxygen with the -l option. You can # optionally specify a file name after the option, if omitted DoxygenLayout.xml -# will be used as the name of the layout file. +# will be used as the name of the layout file. See also section "Changing the +# layout of pages" for information. # # Note that if you run doxygen from a directory containing a file called # DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE @@ -708,7 +820,7 @@ LAYOUT_FILE = # The CITE_BIB_FILES tag can be used to specify one or more bib files containing # the reference definitions. This must be a list of .bib files. The .bib # extension is automatically appended if omitted. This requires the bibtex tool -# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info. +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. # For LaTeX the style of the bibliography can be controlled using # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. @@ -743,23 +855,50 @@ WARNINGS = YES WARN_IF_UNDOCUMENTED = YES # If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for -# potential errors in the documentation, such as not documenting some parameters -# in a documented function, or documenting parameters that don't exist or using -# markup commands wrongly. +# potential errors in the documentation, such as documenting some parameters in +# a documented function twice, or documenting parameters that don't exist or +# using markup commands wrongly. # The default value is: YES. WARN_IF_DOC_ERROR = YES +# If WARN_IF_INCOMPLETE_DOC is set to YES, doxygen will warn about incomplete +# function parameter documentation. If set to NO, doxygen will accept that some +# parameters have no documentation without warning. +# The default value is: YES. + +WARN_IF_INCOMPLETE_DOC = YES + # This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that # are documented, but have no documentation for their parameters or return -# value. If set to NO, doxygen will only warn about wrong or incomplete -# parameter documentation, but not about the absence of documentation. +# value. If set to NO, doxygen will only warn about wrong parameter +# documentation, but not about the absence of documentation. If EXTRACT_ALL is +# set to YES then this flag will automatically be disabled. See also +# WARN_IF_INCOMPLETE_DOC # The default value is: NO. WARN_NO_PARAMDOC = YES +# If WARN_IF_UNDOC_ENUM_VAL option is set to YES, doxygen will warn about +# undocumented enumeration values. If set to NO, doxygen will accept +# undocumented enumeration values. If EXTRACT_ALL is set to YES then this flag +# will automatically be disabled. +# The default value is: NO. + +WARN_IF_UNDOC_ENUM_VAL = NO + # If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when -# a warning is encountered. +# a warning is encountered. If the WARN_AS_ERROR tag is set to FAIL_ON_WARNINGS +# then doxygen will continue running as if WARN_AS_ERROR tag is set to NO, but +# at the end of the doxygen process doxygen will return with a non-zero status. +# If the WARN_AS_ERROR tag is set to FAIL_ON_WARNINGS_PRINT then doxygen behaves +# like FAIL_ON_WARNINGS but in case no WARN_LOGFILE is defined doxygen will not +# write the warning messages in between other messages but write them at the end +# of a run, in case a WARN_LOGFILE is defined the warning messages will be +# besides being in the defined file also be shown at the end of a run, unless +# the WARN_LOGFILE is defined as - i.e. standard output (stdout) in that case +# the behavior will remain as with the setting FAIL_ON_WARNINGS. +# Possible values are: NO, YES, FAIL_ON_WARNINGS and FAIL_ON_WARNINGS_PRINT. # The default value is: NO. WARN_AS_ERROR = NO @@ -770,13 +909,27 @@ WARN_AS_ERROR = NO # and the warning text. Optionally the format may contain $version, which will # be replaced by the version of the file (if it could be obtained via # FILE_VERSION_FILTER) +# See also: WARN_LINE_FORMAT # The default value is: $file:$line: $text. WARN_FORMAT = "$file:$line: $text" +# In the $text part of the WARN_FORMAT command it is possible that a reference +# to a more specific place is given. To make it easier to jump to this place +# (outside of doxygen) the user can define a custom "cut" / "paste" string. +# Example: +# WARN_LINE_FORMAT = "'vi $file +$line'" +# See also: WARN_FORMAT +# The default value is: at line $line of file $file. + +WARN_LINE_FORMAT = "at line $line of file $file" + # The WARN_LOGFILE tag can be used to specify a file to which warning and error # messages should be written. If left blank the output is written to standard -# error (stderr). +# error (stderr). In case the file specified cannot be opened for writing the +# warning and error messages are written to standard error. When as file - is +# specified the warning and error messages are written to standard output +# (stdout). WARN_LOGFILE = doxy.log @@ -790,17 +943,30 @@ WARN_LOGFILE = doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src docs lisp +INPUT = src \ + docs \ + lisp # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # libiconv (or the iconv built into libc) for the transcoding. See the libiconv -# documentation (see: http://www.gnu.org/software/libiconv) for the list of -# possible encodings. +# documentation (see: +# https://www.gnu.org/software/libiconv/) for the list of possible encodings. +# See also: INPUT_FILE_ENCODING # The default value is: UTF-8. INPUT_ENCODING = UTF-8 +# This tag can be used to specify the character encoding of the source files +# that doxygen parses The INPUT_FILE_ENCODING tag can be used to specify +# character encoding on a per file pattern basis. Doxygen will compare the file +# name with each pattern and apply the encoding instead of the default +# INPUT_ENCODING) if there is a match. The character encodings are a list of the +# form: pattern=encoding (like *.php=ISO-8859-1). See cfg_input_encoding +# "INPUT_ENCODING" for further information on supported encodings. + +INPUT_FILE_ENCODING = + # If the value of the INPUT tag contains directories, you can use the # FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and # *.h) to filter out the source-files in the directories. @@ -809,18 +975,22 @@ INPUT_ENCODING = UTF-8 # need to set EXTENSION_MAPPING for the extension otherwise the files are not # read by doxygen. # -# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, -# *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, -# *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, -# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, -# *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf and *.qsf. +# Note the list of default checked file patterns might differ from the list of +# default file extension mappings. +# +# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cxxm, +# *.cpp, *.cppm, *.c++, *.c++m, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, +# *.ddl, *.odl, *.h, *.hh, *.hxx, *.hpp, *.h++, *.ixx, *.l, *.cs, *.d, *.php, +# *.php4, *.php5, *.phtml, *.inc, *.m, *.markdown, *.md, *.mm, *.dox (to be +# provided as doxygen C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, +# *.f18, *.f, *.for, *.vhd, *.vhdl, *.ucf, *.qsf and *.ice. FILE_PATTERNS = *.c \ *.h \ *.lisp \ *.markdown \ - *.md - + *.md + # The RECURSIVE tag can be used to specify whether or not subdirectories should # be searched for input files as well. # The default value is: NO. @@ -856,10 +1026,7 @@ EXCLUDE_PATTERNS = # (namespaces, classes, functions, etc.) that should be excluded from the # output. The symbol name can be a fully qualified name, a word, or if the # wildcard * is used, a substring. Examples: ANamespace, AClass, -# AClass::ANamespace, ANamespace::*Test -# -# Note that the wildcards are matched against the file with absolute path, so to -# exclude all test directories use the pattern */test/* +# ANamespace::AClass, ANamespace::*Test EXCLUDE_SYMBOLS = @@ -904,6 +1071,11 @@ IMAGE_PATH = # code is scanned, but not when the output code is generated. If lines are added # or removed, the anchors will not be placed correctly. # +# Note that doxygen will use the data processed and written to standard output +# for further processing, therefore nothing else, like debug statements or used +# commands (so in case of a Windows batch file always use @echo OFF), should be +# written to standard output. +# # Note that for custom extensions or not directly supported extensions you also # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. @@ -945,6 +1117,15 @@ FILTER_SOURCE_PATTERNS = USE_MDFILE_AS_MAINPAGE = docs/Home.md +# The Fortran standard specifies that for fixed formatted Fortran code all +# characters from position 72 are to be considered as comment. A common +# extension is to allow longer lines before the automatic comment starts. The +# setting FORTRAN_COMMENT_AFTER will also make it possible that longer lines can +# be processed before the automatic comment starts. +# Minimum value: 7, maximum value: 10000, default value: 72. + +FORTRAN_COMMENT_AFTER = 72 + #--------------------------------------------------------------------------- # Configuration options related to source browsing #--------------------------------------------------------------------------- @@ -972,7 +1153,7 @@ INLINE_SOURCES = NO STRIP_CODE_COMMENTS = NO # If the REFERENCED_BY_RELATION tag is set to YES then for each documented -# function all documented functions referencing it will be listed. +# entity all documented functions referencing it will be listed. # The default value is: NO. REFERENCED_BY_RELATION = YES @@ -1004,12 +1185,12 @@ SOURCE_TOOLTIPS = YES # If the USE_HTAGS tag is set to YES then the references to source code will # point to the HTML generated by the htags(1) tool instead of doxygen built-in # source browser. The htags tool is part of GNU's global source tagging system -# (see http://www.gnu.org/software/global/global.html). You will need version +# (see https://www.gnu.org/software/global/global.html). You will need version # 4.8.6 or higher. # # To use it do the following: # - Install the latest version of global -# - Enable SOURCE_BROWSER and USE_HTAGS in the config file +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file # - Make sure the INPUT points to the root of the source tree # - Run doxygen as normal # @@ -1032,16 +1213,24 @@ USE_HTAGS = NO VERBATIM_HEADERS = YES # If the CLANG_ASSISTED_PARSING tag is set to YES then doxygen will use the -# clang parser (see: http://clang.llvm.org/) for more accurate parsing at the -# cost of reduced performance. This can be particularly helpful with template -# rich C++ code for which doxygen's built-in parser lacks the necessary type -# information. +# clang parser (see: +# http://clang.llvm.org/) for more accurate parsing at the cost of reduced +# performance. This can be particularly helpful with template rich C++ code for +# which doxygen's built-in parser lacks the necessary type information. # Note: The availability of this option depends on whether or not doxygen was -# generated with the -Duse-libclang=ON option for CMake. +# generated with the -Duse_libclang=ON option for CMake. # The default value is: NO. CLANG_ASSISTED_PARSING = NO +# If the CLANG_ASSISTED_PARSING tag is set to YES and the CLANG_ADD_INC_PATHS +# tag is set to YES then doxygen will add the directory of each input to the +# include path. +# The default value is: YES. +# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. + +CLANG_ADD_INC_PATHS = YES + # If clang assisted parsing is enabled you can provide the compiler with command # line options that you would normally use when invoking the compiler. Note that # the include paths will already be set by doxygen for the files and directories @@ -1050,6 +1239,19 @@ CLANG_ASSISTED_PARSING = NO CLANG_OPTIONS = +# If clang assisted parsing is enabled you can provide the clang parser with the +# path to the directory containing a file called compile_commands.json. This +# file is the compilation database (see: +# http://clang.llvm.org/docs/HowToSetupToolingForLLVM.html) containing the +# options used when the source files were built. This is equivalent to +# specifying the -p option to a clang tool, such as clang-check. These options +# will then be passed to the parser. Any options specified with CLANG_OPTIONS +# will be added as well. +# Note: The availability of this option depends on whether or not doxygen was +# generated with the -Duse_libclang=ON option for CMake. + +CLANG_DATABASE_PATH = + #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index #--------------------------------------------------------------------------- @@ -1061,17 +1263,11 @@ CLANG_OPTIONS = ALPHABETICAL_INDEX = YES -# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in -# which the alphabetical index list will be split. -# Minimum value: 1, maximum value: 20, default value: 5. -# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. - -COLS_IN_ALPHA_INDEX = 5 - -# In case all classes in a project start with a common prefix, all classes will -# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag -# can be used to specify a prefix (or a list of prefixes) that should be ignored -# while generating the index headers. +# The IGNORE_PREFIX tag can be used to specify a prefix (or a list of prefixes) +# that should be ignored while generating the index headers. The IGNORE_PREFIX +# tag works for classes, function and member names. The entity will be placed in +# the alphabetical list under the first letter of the entity name that remains +# after removing the prefix. # This tag requires that the tag ALPHABETICAL_INDEX is set to YES. IGNORE_PREFIX = @@ -1150,7 +1346,12 @@ HTML_STYLESHEET = # Doxygen will copy the style sheet files to the output directory. # Note: The order of the extra style sheet files is of importance (e.g. the last # style sheet in the list overrules the setting of the previous ones in the -# list). For an example see the documentation. +# list). +# Note: Since the styling of scrollbars can currently not be overruled in +# Webkit/Chromium, the styling will be left out of the default doxygen.css if +# one or more extra stylesheets have been specified. So if scrollbar +# customization is desired it has to be added explicitly. For an example see the +# documentation. # This tag requires that the tag GENERATE_HTML is set to YES. HTML_EXTRA_STYLESHEET = @@ -1165,10 +1366,23 @@ HTML_EXTRA_STYLESHEET = HTML_EXTRA_FILES = +# The HTML_COLORSTYLE tag can be used to specify if the generated HTML output +# should be rendered with a dark or light theme. +# Possible values are: LIGHT always generate light mode output, DARK always +# generate dark mode output, AUTO_LIGHT automatically set the mode according to +# the user preference, use light mode if no preference is set (the default), +# AUTO_DARK automatically set the mode according to the user preference, use +# dark mode if no preference is set and TOGGLE allow to user to switch between +# light and dark mode via a button. +# The default value is: AUTO_LIGHT. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE = AUTO_DARK + # The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen # will adjust the colors in the style sheet and background images according to -# this color. Hue is specified as an angle on a colorwheel, see -# http://en.wikipedia.org/wiki/Hue for more information. For instance the value +# this color. Hue is specified as an angle on a color-wheel, see +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value # 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 # purple, and 360 is red again. # Minimum value: 0, maximum value: 359, default value: 220. @@ -1177,7 +1391,7 @@ HTML_EXTRA_FILES = HTML_COLORSTYLE_HUE = 220 # The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors -# in the HTML output. For a value of 0 the output will use grayscales only. A +# in the HTML output. For a value of 0 the output will use gray-scales only. A # value of 255 will produce the most vivid colors. # Minimum value: 0, maximum value: 255, default value: 100. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1195,14 +1409,16 @@ HTML_COLORSTYLE_SAT = 100 HTML_COLORSTYLE_GAMMA = 80 -# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML -# page will contain the date and time when the page was generated. Setting this -# to YES can help to show when doxygen was last run and thus if the -# documentation is up to date. -# The default value is: NO. +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via JavaScript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have JavaScript, +# like the Qt help browser. +# The default value is: YES. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_TIMESTAMP = NO +HTML_DYNAMIC_MENUS = YES # If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML # documentation will contain sections that can be hidden and shown after the @@ -1212,6 +1428,13 @@ HTML_TIMESTAMP = NO HTML_DYNAMIC_SECTIONS = NO +# If the HTML_CODE_FOLDING tag is set to YES then classes and functions can be +# dynamically folded and expanded in the generated HTML source code. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_CODE_FOLDING = YES + # With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries # shown in the various tree structured indices initially; the user can expand # and collapse entries dynamically later on. Doxygen will expand the tree to @@ -1227,13 +1450,14 @@ HTML_INDEX_NUM_ENTRIES = 100 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: http://developer.apple.com/tools/xcode/), introduced with -# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a -# Makefile in the HTML output directory. Running make will produce the docset in -# that directory and running make install will install the docset in +# environment (see: +# https://developer.apple.com/xcode/), introduced with OSX 10.5 (Leopard). To +# create a documentation set, doxygen will generate a Makefile in the HTML +# output directory. Running make will produce the docset in that directory and +# running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at -# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html -# for more information. +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1247,6 +1471,13 @@ GENERATE_DOCSET = NO DOCSET_FEEDNAME = "Doxygen generated docs" +# This tag determines the URL of the docset feed. A documentation feed provides +# an umbrella under which multiple documentation sets from a single provider +# (such as a company or product suite) can be grouped. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_FEEDURL = + # This tag specifies a string that should uniquely identify the documentation # set bundle. This should be a reverse domain-name style string, e.g. # com.mycompany.MyDocSet. Doxygen will append .docset to the name. @@ -1272,8 +1503,12 @@ DOCSET_PUBLISHER_NAME = Publisher # If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three # additional HTML index files: index.hhp, index.hhc, and index.hhk. The # index.hhp is a project file that can be read by Microsoft's HTML Help Workshop -# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on -# Windows. +# on Windows. In the beginning of 2021 Microsoft took the original page, with +# a.o. the download links, offline the HTML help workshop was already many years +# in maintenance mode). You can download the HTML help workshop from the web +# archives at Installation executable (see: +# http://web.archive.org/web/20160201063255/http://download.microsoft.com/downlo +# ad/0/A/9/0A939EF6-E31C-430F-A3DF-DFAE7960D564/htmlhelp.exe). # # The HTML Help Workshop contains a compiler that can convert all HTML output # generated by doxygen into a single compiled HTML file (.chm). Compiled HTML @@ -1303,7 +1538,7 @@ CHM_FILE = HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated -# (YES) or that it should be included in the master .chm file (NO). +# (YES) or that it should be included in the main .chm file (NO). # The default value is: NO. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. @@ -1330,6 +1565,16 @@ BINARY_TOC = NO TOC_EXPAND = NO +# The SITEMAP_URL tag is used to specify the full URL of the place where the +# generated documentation will be placed on the server by the user during the +# deployment of the documentation. The generated sitemap is called sitemap.xml +# and placed on the directory specified by HTML_OUTPUT. In case no SITEMAP_URL +# is specified no sitemap is generated. For information about the sitemap +# protocol see https://www.sitemaps.org +# This tag requires that the tag GENERATE_HTML is set to YES. + +SITEMAP_URL = + # If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and # QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that # can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help @@ -1348,7 +1593,8 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace). +# (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1356,8 +1602,8 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual- -# folders). +# Folders (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual-folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1365,30 +1611,30 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: -# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_SECT_FILTER_ATTRS = -# The QHG_LOCATION tag can be used to specify the location of Qt's -# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the -# generated .qhp file. +# The QHG_LOCATION tag can be used to specify the location (absolute path +# including file name) of Qt's qhelpgenerator. If non-empty doxygen will try to +# run qhelpgenerator on the generated .qhp file. # This tag requires that the tag GENERATE_QHP is set to YES. QHG_LOCATION = @@ -1431,16 +1677,28 @@ DISABLE_INDEX = NO # to work a browser that supports JavaScript, DHTML, CSS and frames is required # (i.e. any modern browser). Windows users are probably better off using the # HTML help feature. Via custom style sheets (see HTML_EXTRA_STYLESHEET) one can -# further fine-tune the look of the index. As an example, the default style -# sheet generated by doxygen has an example that shows how to put an image at -# the root of the tree instead of the PROJECT_NAME. Since the tree basically has -# the same information as the tab index, you could consider setting -# DISABLE_INDEX to YES when enabling this option. +# further fine tune the look of the index (see "Fine-tuning the output"). As an +# example, the default style sheet generated by doxygen has an example that +# shows how to put an image at the root of the tree instead of the PROJECT_NAME. +# Since the tree basically has the same information as the tab index, you could +# consider setting DISABLE_INDEX to YES when enabling this option. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. GENERATE_TREEVIEW = YES +# When both GENERATE_TREEVIEW and DISABLE_INDEX are set to YES, then the +# FULL_SIDEBAR option determines if the side bar is limited to only the treeview +# area (value NO) or if it should extend to the full height of the window (value +# YES). Setting this to YES gives a layout similar to +# https://docs.readthedocs.io with more room for contents, but less room for the +# project logo, title, and description. If either GENERATE_TREEVIEW or +# DISABLE_INDEX is set to NO, this option has no effect. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FULL_SIDEBAR = NO + # The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that # doxygen will group on one line in the generated HTML documentation. # @@ -1465,6 +1723,24 @@ TREEVIEW_WIDTH = 250 EXT_LINKS_IN_WINDOW = NO +# If the OBFUSCATE_EMAILS tag is set to YES, doxygen will obfuscate email +# addresses. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +OBFUSCATE_EMAILS = YES + +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = png + # Use this tag to change the font size of LaTeX formulas included as images in # the HTML documentation. When you change the font size after a successful # doxygen run you need to manually remove any form_*.png images from the HTML @@ -1474,19 +1750,14 @@ EXT_LINKS_IN_WINDOW = NO FORMULA_FONTSIZE = 10 -# Use the FORMULA_TRANPARENT tag to determine whether or not the images -# generated for formulas are transparent PNGs. Transparent PNGs are not -# supported properly for IE 6.0, but are supported on all modern browsers. -# -# Note that when changing this option you need to delete any form_*.png files in -# the HTML output directory before the changes have effect. -# The default value is: YES. -# This tag requires that the tag GENERATE_HTML is set to YES. +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. -FORMULA_TRANSPARENT = YES +FORMULA_MACROFILE = # Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see -# http://www.mathjax.org) which uses client side Javascript for the rendering +# https://www.mathjax.org) which uses client side JavaScript for the rendering # instead of using pre-rendered bitmaps. Use this if you do not have LaTeX # installed or if you want to formulas look prettier in the HTML output. When # enabled you may also need to install MathJax separately and configure the path @@ -1496,11 +1767,29 @@ FORMULA_TRANSPARENT = YES USE_MATHJAX = YES +# With MATHJAX_VERSION it is possible to specify the MathJax version to be used. +# Note that the different versions of MathJax have different requirements with +# regards to the different settings, so it is possible that also other MathJax +# settings have to be changed when switching between the different MathJax +# versions. +# Possible values are: MathJax_2 and MathJax_3. +# The default value is: MathJax_2. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_VERSION = MathJax_2 + # When MathJax is enabled you can set the default output format to be used for -# the MathJax output. See the MathJax site (see: -# http://docs.mathjax.org/en/latest/output.html) for more details. +# the MathJax output. For more details about the output format see MathJax +# version 2 (see: +# http://docs.mathjax.org/en/v2.7-latest/output.html) and MathJax version 3 +# (see: +# http://docs.mathjax.org/en/latest/web/components/output.html). # Possible values are: HTML-CSS (which is slower, but has the best -# compatibility), NativeMML (i.e. MathML) and SVG. +# compatibility. This is the name for Mathjax version 2, for MathJax version 3 +# this will be translated into chtml), NativeMML (i.e. MathML. Only supported +# for NathJax 2. For MathJax version 3 chtml will be used instead.), chtml (This +# is the name for Mathjax version 3, for MathJax version 2 this will be +# translated into HTML-CSS) and SVG. # The default value is: HTML-CSS. # This tag requires that the tag USE_MATHJAX is set to YES. @@ -1513,22 +1802,29 @@ MATHJAX_FORMAT = HTML-CSS # MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of -# MathJax from http://www.mathjax.org before deployment. -# The default value is: http://cdn.mathjax.org/mathjax/latest. +# MathJax from https://www.mathjax.org before deployment. The default value is: +# - in case of MathJax version 2: https://cdn.jsdelivr.net/npm/mathjax@2 +# - in case of MathJax version 3: https://cdn.jsdelivr.net/npm/mathjax@3 # This tag requires that the tag USE_MATHJAX is set to YES. MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest # The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax # extension names that should be enabled during MathJax rendering. For example +# for MathJax version 2 (see +# https://docs.mathjax.org/en/v2.7-latest/tex.html#tex-and-latex-extensions): # MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols +# For example for MathJax version 3 (see +# http://docs.mathjax.org/en/latest/input/tex/extensions/index.html): +# MATHJAX_EXTENSIONS = ams # This tag requires that the tag USE_MATHJAX is set to YES. MATHJAX_EXTENSIONS = # The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces # of code that will be used on startup of the MathJax code. See the MathJax site -# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# (see: +# http://docs.mathjax.org/en/v2.7-latest/output.html) for more details. For an # example see the documentation. # This tag requires that the tag USE_MATHJAX is set to YES. @@ -1556,7 +1852,7 @@ MATHJAX_CODEFILE = SEARCHENGINE = YES # When the SERVER_BASED_SEARCH tag is enabled the search engine will be -# implemented using a web server instead of a web client using Javascript. There +# implemented using a web server instead of a web client using JavaScript. There # are two flavors of web server based searching depending on the EXTERNAL_SEARCH # setting. When disabled, doxygen will generate a PHP script for searching and # an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing @@ -1575,7 +1871,8 @@ SERVER_BASED_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). +# Xapian (see: +# https://xapian.org/). # # See the section "External Indexing and Searching" for details. # The default value is: NO. @@ -1588,8 +1885,9 @@ EXTERNAL_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). See the section "External Indexing and -# Searching" for details. +# Xapian (see: +# https://xapian.org/). See the section "External Indexing and Searching" for +# details. # This tag requires that the tag SEARCHENGINE is set to YES. SEARCHENGINE_URL = @@ -1640,21 +1938,35 @@ LATEX_OUTPUT = latex # The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be # invoked. # -# Note that when enabling USE_PDFLATEX this option is only used for generating -# bitmaps for formulas in the HTML output, but not in the Makefile that is -# written to the output directory. -# The default file is: latex. +# Note that when not enabling USE_PDFLATEX the default is latex when enabling +# USE_PDFLATEX the default is pdflatex and when in the later case latex is +# chosen this is overwritten by pdflatex. For specific output languages the +# default can have been set differently, this depends on the implementation of +# the output language. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_CMD_NAME = latex # The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate # index for LaTeX. +# Note: This tag is used in the Makefile / make.bat. +# See also: LATEX_MAKEINDEX_CMD for the part in the generated output file +# (.tex). # The default file is: makeindex. # This tag requires that the tag GENERATE_LATEX is set to YES. MAKEINDEX_CMD_NAME = makeindex +# The LATEX_MAKEINDEX_CMD tag can be used to specify the command name to +# generate index for LaTeX. In case there is no backslash (\) as first character +# it will be automatically added in the LaTeX code. +# Note: This tag is used in the generated output file (.tex). +# See also: MAKEINDEX_CMD_NAME for the part in the Makefile / make.bat. +# The default value is: makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_MAKEINDEX_CMD = makeindex + # If the COMPACT_LATEX tag is set to YES, doxygen generates more compact LaTeX # documents. This may be useful for small projects and may help to save some # trees in general. @@ -1684,29 +1996,31 @@ PAPER_TYPE = a4 EXTRA_PACKAGES = -# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the -# generated LaTeX document. The header should contain everything until the first -# chapter. If it is left blank doxygen will generate a standard header. See -# section "Doxygen usage" for information on how to let doxygen write the -# default header to a separate file. +# The LATEX_HEADER tag can be used to specify a user-defined LaTeX header for +# the generated LaTeX document. The header should contain everything until the +# first chapter. If it is left blank doxygen will generate a standard header. It +# is highly recommended to start with a default header using +# doxygen -w latex new_header.tex new_footer.tex new_stylesheet.sty +# and then modify the file new_header.tex. See also section "Doxygen usage" for +# information on how to generate the default header that doxygen normally uses. # -# Note: Only use a user-defined header if you know what you are doing! The -# following commands have a special meaning inside the header: $title, -# $datetime, $date, $doxygenversion, $projectname, $projectnumber, -# $projectbrief, $projectlogo. Doxygen will replace $title with the empty -# string, for the replacement values of the other commands the user is referred -# to HTML_HEADER. +# Note: Only use a user-defined header if you know what you are doing! +# Note: The header is subject to change so you typically have to regenerate the +# default header when upgrading to a newer version of doxygen. The following +# commands have a special meaning inside the header (and footer): For a +# description of the possible markers and block names see the documentation. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_HEADER = -# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the -# generated LaTeX document. The footer should contain everything after the last -# chapter. If it is left blank doxygen will generate a standard footer. See +# The LATEX_FOOTER tag can be used to specify a user-defined LaTeX footer for +# the generated LaTeX document. The footer should contain everything after the +# last chapter. If it is left blank doxygen will generate a standard footer. See # LATEX_HEADER for more information on how to generate a default footer and what -# special commands can be used inside the footer. -# -# Note: Only use a user-defined footer if you know what you are doing! +# special commands can be used inside the footer. See also section "Doxygen +# usage" for information on how to generate the default footer that doxygen +# normally uses. Note: Only use a user-defined footer if you know what you are +# doing! # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_FOOTER = @@ -1739,18 +2053,26 @@ LATEX_EXTRA_FILES = PDF_HYPERLINKS = YES -# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate -# the PDF file directly from the LaTeX files. Set this option to YES, to get a -# higher quality PDF documentation. +# If the USE_PDFLATEX tag is set to YES, doxygen will use the engine as +# specified with LATEX_CMD_NAME to generate the PDF file directly from the LaTeX +# files. Set this option to YES, to get a higher quality PDF documentation. +# +# See also section LATEX_CMD_NAME for selecting the engine. # The default value is: YES. # This tag requires that the tag GENERATE_LATEX is set to YES. USE_PDFLATEX = YES -# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \batchmode -# command to the generated LaTeX files. This will instruct LaTeX to keep running -# if errors occur, instead of asking the user for help. This option is also used -# when generating formulas in HTML. +# The LATEX_BATCHMODE tag signals the behavior of LaTeX in case of an error. +# Possible values are: NO same as ERROR_STOP, YES same as BATCH, BATCH In batch +# mode nothing is printed on the terminal, errors are scrolled as if is +# hit at every error; missing files that TeX tries to input or request from +# keyboard input (\read on a not open input stream) cause the job to abort, +# NON_STOP In nonstop mode the diagnostic message will appear on the terminal, +# but there is no possibility of user interaction just like in batch mode, +# SCROLL In scroll mode, TeX will stop only for missing files to input or if +# keyboard input is necessary and ERROR_STOP In errorstop mode, TeX will stop at +# each error, asking for user intervention. # The default value is: NO. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -1763,31 +2085,21 @@ LATEX_BATCHMODE = NO LATEX_HIDE_INDICES = NO -# If the LATEX_SOURCE_CODE tag is set to YES then doxygen will include source -# code with syntax highlighting in the LaTeX output. -# -# Note that which sources are shown also depends on other settings such as -# SOURCE_BROWSER. -# The default value is: NO. -# This tag requires that the tag GENERATE_LATEX is set to YES. - -LATEX_SOURCE_CODE = NO - # The LATEX_BIB_STYLE tag can be used to specify the style to use for the # bibliography, e.g. plainnat, or ieeetr. See -# http://en.wikipedia.org/wiki/BibTeX and \cite for more info. +# https://en.wikipedia.org/wiki/BibTeX and \cite for more info. # The default value is: plain. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_BIB_STYLE = plain -# If the LATEX_TIMESTAMP tag is set to YES then the footer of each generated -# page will contain the date and time when the page was generated. Setting this -# to NO can help when comparing the output of multiple runs. -# The default value is: NO. +# The LATEX_EMOJI_DIRECTORY tag is used to specify the (relative or absolute) +# path from which the emoji images will be read. If a relative path is entered, +# it will be relative to the LATEX_OUTPUT directory. If left blank the +# LATEX_OUTPUT directory will be used. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_TIMESTAMP = NO +LATEX_EMOJI_DIRECTORY = #--------------------------------------------------------------------------- # Configuration options related to the RTF output @@ -1828,9 +2140,9 @@ COMPACT_RTF = NO RTF_HYPERLINKS = NO -# Load stylesheet definitions from file. Syntax is similar to doxygen's config -# file, i.e. a series of assignments. You only have to provide replacements, -# missing definitions are set to their default value. +# Load stylesheet definitions from file. Syntax is similar to doxygen's +# configuration file, i.e. a series of assignments. You only have to provide +# replacements, missing definitions are set to their default value. # # See also section "Doxygen usage" for information on how to generate the # default style sheet that doxygen normally uses. @@ -1839,22 +2151,12 @@ RTF_HYPERLINKS = NO RTF_STYLESHEET_FILE = # Set optional variables used in the generation of an RTF document. Syntax is -# similar to doxygen's config file. A template extensions file can be generated -# using doxygen -e rtf extensionFile. +# similar to doxygen's configuration file. A template extensions file can be +# generated using doxygen -e rtf extensionFile. # This tag requires that the tag GENERATE_RTF is set to YES. RTF_EXTENSIONS_FILE = -# If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code -# with syntax highlighting in the RTF output. -# -# Note that which sources are shown also depends on other settings such as -# SOURCE_BROWSER. -# The default value is: NO. -# This tag requires that the tag GENERATE_RTF is set to YES. - -RTF_SOURCE_CODE = NO - #--------------------------------------------------------------------------- # Configuration options related to the man page output #--------------------------------------------------------------------------- @@ -1926,6 +2228,13 @@ XML_OUTPUT = xml XML_PROGRAMLISTING = YES +# If the XML_NS_MEMB_FILE_SCOPE tag is set to YES, doxygen will include +# namespace members in file scope as well, matching the HTML output. +# The default value is: NO. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_NS_MEMB_FILE_SCOPE = NO + #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output #--------------------------------------------------------------------------- @@ -1944,27 +2253,44 @@ GENERATE_DOCBOOK = NO DOCBOOK_OUTPUT = docbook -# If the DOCBOOK_PROGRAMLISTING tag is set to YES, doxygen will include the -# program listings (including syntax highlighting and cross-referencing -# information) to the DOCBOOK output. Note that enabling this will significantly -# increase the size of the DOCBOOK output. -# The default value is: NO. -# This tag requires that the tag GENERATE_DOCBOOK is set to YES. - -DOCBOOK_PROGRAMLISTING = NO - #--------------------------------------------------------------------------- # Configuration options for the AutoGen Definitions output #--------------------------------------------------------------------------- # If the GENERATE_AUTOGEN_DEF tag is set to YES, doxygen will generate an -# AutoGen Definitions (see http://autogen.sf.net) file that captures the -# structure of the code including all documentation. Note that this feature is -# still experimental and incomplete at the moment. +# AutoGen Definitions (see https://autogen.sourceforge.net/) file that captures +# the structure of the code including all documentation. Note that this feature +# is still experimental and incomplete at the moment. # The default value is: NO. GENERATE_AUTOGEN_DEF = NO +#--------------------------------------------------------------------------- +# Configuration options related to Sqlite3 output +#--------------------------------------------------------------------------- + +# If the GENERATE_SQLITE3 tag is set to YES doxygen will generate a Sqlite3 +# database with symbols found by doxygen stored in tables. +# The default value is: NO. + +GENERATE_SQLITE3 = NO + +# The SQLITE3_OUTPUT tag is used to specify where the Sqlite3 database will be +# put. If a relative path is entered the value of OUTPUT_DIRECTORY will be put +# in front of it. +# The default directory is: sqlite3. +# This tag requires that the tag GENERATE_SQLITE3 is set to YES. + +SQLITE3_OUTPUT = sqlite3 + +# The SQLITE3_OVERWRITE_DB tag is set to YES, the existing doxygen_sqlite3.db +# database file will be recreated with each doxygen run. If set to NO, doxygen +# will warn if an a database file is already found and not modify it. +# The default value is: YES. +# This tag requires that the tag GENERATE_SQLITE3 is set to YES. + +SQLITE3_RECREATE_DB = YES + #--------------------------------------------------------------------------- # Configuration options related to the Perl module output #--------------------------------------------------------------------------- @@ -2039,7 +2365,8 @@ SEARCH_INCLUDES = YES # The INCLUDE_PATH tag can be used to specify one or more directories that # contain include files that are not input files but should be processed by the -# preprocessor. +# preprocessor. Note that the INCLUDE_PATH is not recursive, so the setting of +# RECURSIVE has no effect here. # This tag requires that the tag SEARCH_INCLUDES is set to YES. INCLUDE_PATH = @@ -2106,15 +2433,15 @@ TAGFILES = GENERATE_TAGFILE = -# If the ALLEXTERNALS tag is set to YES, all external class will be listed in -# the class index. If set to NO, only the inherited external classes will be -# listed. +# If the ALLEXTERNALS tag is set to YES, all external classes and namespaces +# will be listed in the class and namespace index. If set to NO, only the +# inherited external classes will be listed. # The default value is: NO. ALLEXTERNALS = NO # If the EXTERNAL_GROUPS tag is set to YES, all external groups will be listed -# in the modules index. If set to NO, only the current project's groups will be +# in the topic index. If set to NO, only the current project's groups will be # listed. # The default value is: YES. @@ -2127,41 +2454,10 @@ EXTERNAL_GROUPS = YES EXTERNAL_PAGES = YES -# The PERL_PATH should be the absolute path and name of the perl script -# interpreter (i.e. the result of 'which perl'). -# The default file (with absolute path) is: /usr/bin/perl. - -PERL_PATH = /usr/bin/perl - #--------------------------------------------------------------------------- -# Configuration options related to the dot tool +# Configuration options related to diagram generator tools #--------------------------------------------------------------------------- -# If the CLASS_DIAGRAMS tag is set to YES, doxygen will generate a class diagram -# (in HTML and LaTeX) for classes with base or super classes. Setting the tag to -# NO turns the diagrams off. Note that this option also works with HAVE_DOT -# disabled, but it is recommended to install and use dot, since it yields more -# powerful graphs. -# The default value is: YES. - -CLASS_DIAGRAMS = YES - -# You can define message sequence charts within doxygen comments using the \msc -# command. Doxygen will then run the mscgen tool (see: -# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the -# documentation. The MSCGEN_PATH tag allows you to specify the directory where -# the mscgen tool resides. If left empty the tool is assumed to be found in the -# default search path. - -MSCGEN_PATH = - -# You can include diagrams made with dia in doxygen documentation. Doxygen will -# then run dia to produce the diagram and insert it in the documentation. The -# DIA_PATH tag allows you to specify the directory where the dia binary resides. -# If left empty dia is assumed to be found in the default search path. - -DIA_PATH = - # If set to YES the inheritance and collaboration graphs will hide inheritance # and usage relations if the target is undocumented or is not a class. # The default value is: YES. @@ -2170,7 +2466,7 @@ HIDE_UNDOC_RELATIONS = YES # If you set the HAVE_DOT tag to YES then doxygen will assume the dot tool is # available from the path. This tool is part of Graphviz (see: -# http://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent +# https://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent # Bell Labs. The other options in this section have no effect if this option is # set to NO # The default value is: YES. @@ -2187,49 +2483,73 @@ HAVE_DOT = YES DOT_NUM_THREADS = 0 -# When you want a differently looking font in the dot files that doxygen -# generates you can specify the font name using DOT_FONTNAME. You need to make -# sure dot is able to find the font, which can be done by putting it in a -# standard location or by setting the DOTFONTPATH environment variable or by -# setting DOT_FONTPATH to the directory containing the font. -# The default value is: Helvetica. +# DOT_COMMON_ATTR is common attributes for nodes, edges and labels of +# subgraphs. When you want a differently looking font in the dot files that +# doxygen generates you can specify fontname, fontcolor and fontsize attributes. +# For details please see Node, +# Edge and Graph Attributes specification You need to make sure dot is able +# to find the font, which can be done by putting it in a standard location or by +# setting the DOTFONTPATH environment variable or by setting DOT_FONTPATH to the +# directory containing the font. Default graphviz fontsize is 14. +# The default value is: fontname=Helvetica,fontsize=10. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_FONTNAME = Helvetica +DOT_COMMON_ATTR = "fontname=Helvetica,fontsize=10" -# The DOT_FONTSIZE tag can be used to set the size (in points) of the font of -# dot graphs. -# Minimum value: 4, maximum value: 24, default value: 10. +# DOT_EDGE_ATTR is concatenated with DOT_COMMON_ATTR. For elegant style you can +# add 'arrowhead=open, arrowtail=open, arrowsize=0.5'. Complete documentation about +# arrows shapes. +# The default value is: labelfontname=Helvetica,labelfontsize=10. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_FONTSIZE = 10 +DOT_EDGE_ATTR = "labelfontname=Helvetica,labelfontsize=10" -# By default doxygen will tell dot to use the default font as specified with -# DOT_FONTNAME. If you specify a different font using DOT_FONTNAME you can set -# the path where dot can find it using this tag. +# DOT_NODE_ATTR is concatenated with DOT_COMMON_ATTR. For view without boxes +# around nodes set 'shape=plain' or 'shape=plaintext' Shapes specification +# The default value is: shape=box,height=0.2,width=0.4. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_NODE_ATTR = "shape=box,height=0.2,width=0.4" + +# You can set the path where dot can find font specified with fontname in +# DOT_COMMON_ATTR and others dot attributes. # This tag requires that the tag HAVE_DOT is set to YES. DOT_FONTPATH = -# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for -# each documented class showing the direct and indirect inheritance relations. -# Setting this tag to YES will force the CLASS_DIAGRAMS tag to NO. +# If the CLASS_GRAPH tag is set to YES or GRAPH or BUILTIN then doxygen will +# generate a graph for each documented class showing the direct and indirect +# inheritance relations. In case the CLASS_GRAPH tag is set to YES or GRAPH and +# HAVE_DOT is enabled as well, then dot will be used to draw the graph. In case +# the CLASS_GRAPH tag is set to YES and HAVE_DOT is disabled or if the +# CLASS_GRAPH tag is set to BUILTIN, then the built-in generator will be used. +# If the CLASS_GRAPH tag is set to TEXT the direct and indirect inheritance +# relations will be shown as texts / links. +# Possible values are: NO, YES, TEXT, GRAPH and BUILTIN. # The default value is: YES. -# This tag requires that the tag HAVE_DOT is set to YES. CLASS_GRAPH = YES # If the COLLABORATION_GRAPH tag is set to YES then doxygen will generate a # graph for each documented class showing the direct and indirect implementation # dependencies (inheritance, containment, and class references variables) of the -# class with other documented classes. +# class with other documented classes. Explicit enabling a collaboration graph, +# when COLLABORATION_GRAPH is set to NO, can be accomplished by means of the +# command \collaborationgraph. Disabling a collaboration graph can be +# accomplished by means of the command \hidecollaborationgraph. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. COLLABORATION_GRAPH = YES # If the GROUP_GRAPHS tag is set to YES then doxygen will generate a graph for -# groups, showing the direct groups dependencies. +# groups, showing the direct groups dependencies. Explicit enabling a group +# dependency graph, when GROUP_GRAPHS is set to NO, can be accomplished by means +# of the command \groupgraph. Disabling a directory graph can be accomplished by +# means of the command \hidegroupgraph. See also the chapter Grouping in the +# manual. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. @@ -2252,10 +2572,32 @@ UML_LOOK = NO # but if the number exceeds 15, the total amount of fields shown is limited to # 10. # Minimum value: 0, maximum value: 100, default value: 10. -# This tag requires that the tag HAVE_DOT is set to YES. +# This tag requires that the tag UML_LOOK is set to YES. UML_LIMIT_NUM_FIELDS = 10 +# If the DOT_UML_DETAILS tag is set to NO, doxygen will show attributes and +# methods without types and arguments in the UML graphs. If the DOT_UML_DETAILS +# tag is set to YES, doxygen will add type and arguments for attributes and +# methods in the UML graphs. If the DOT_UML_DETAILS tag is set to NONE, doxygen +# will not generate fields with class member information in the UML graphs. The +# class diagrams will look similar to the default class diagrams but using UML +# notation for the relationships. +# Possible values are: NO, YES and NONE. +# The default value is: NO. +# This tag requires that the tag UML_LOOK is set to YES. + +DOT_UML_DETAILS = NO + +# The DOT_WRAP_THRESHOLD tag can be used to set the maximum number of characters +# to display on a single line. If the actual line length exceeds this threshold +# significantly it will wrapped across multiple lines. Some heuristics are apply +# to avoid ugly line breaks. +# Minimum value: 0, maximum value: 1000, default value: 17. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_WRAP_THRESHOLD = 17 + # If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and # collaboration graphs will show the relations between templates and their # instances. @@ -2267,7 +2609,9 @@ TEMPLATE_RELATIONS = NO # If the INCLUDE_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are set to # YES then doxygen will generate a graph for each documented file showing the # direct and indirect include dependencies of the file with other documented -# files. +# files. Explicit enabling an include graph, when INCLUDE_GRAPH is is set to NO, +# can be accomplished by means of the command \includegraph. Disabling an +# include graph can be accomplished by means of the command \hideincludegraph. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. @@ -2276,7 +2620,10 @@ INCLUDE_GRAPH = YES # If the INCLUDED_BY_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are # set to YES then doxygen will generate a graph for each documented file showing # the direct and indirect include dependencies of the file with other documented -# files. +# files. Explicit enabling an included by graph, when INCLUDED_BY_GRAPH is set +# to NO, can be accomplished by means of the command \includedbygraph. Disabling +# an included by graph can be accomplished by means of the command +# \hideincludedbygraph. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. @@ -2316,23 +2663,32 @@ GRAPHICAL_HIERARCHY = YES # If the DIRECTORY_GRAPH tag is set to YES then doxygen will show the # dependencies a directory has on other directories in a graphical way. The # dependency relations are determined by the #include relations between the -# files in the directories. +# files in the directories. Explicit enabling a directory graph, when +# DIRECTORY_GRAPH is set to NO, can be accomplished by means of the command +# \directorygraph. Disabling a directory graph can be accomplished by means of +# the command \hidedirectorygraph. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. DIRECTORY_GRAPH = YES +# The DIR_GRAPH_MAX_DEPTH tag can be used to limit the maximum number of levels +# of child directories generated in directory dependency graphs by dot. +# Minimum value: 1, maximum value: 25, default value: 1. +# This tag requires that the tag DIRECTORY_GRAPH is set to YES. + +DIR_GRAPH_MAX_DEPTH = 1 + # The DOT_IMAGE_FORMAT tag can be used to set the image format of the images # generated by dot. For an explanation of the image formats see the section # output formats in the documentation of the dot tool (Graphviz (see: -# http://www.graphviz.org/)). +# https://www.graphviz.org/)). # Note: If you choose svg you need to set HTML_FILE_EXTENSION to xhtml in order # to make the SVG files visible in IE 9+ (other browsers do not have this # requirement). -# Possible values are: png, png:cairo, png:cairo:cairo, png:cairo:gd, png:gd, -# png:gd:gd, jpg, jpg:cairo, jpg:cairo:gd, jpg:gd, jpg:gd:gd, gif, gif:cairo, -# gif:cairo:gd, gif:gd, gif:gd:gd, svg, png:gd, png:gd:gd, png:cairo, -# png:cairo:gd, png:cairo:cairo, png:cairo:gdiplus, png:gdiplus and +# Possible values are: png, jpg, jpg:cairo, jpg:cairo:gd, jpg:gd, jpg:gd:gd, +# gif, gif:cairo, gif:cairo:gd, gif:gd, gif:gd:gd, svg, png:gd, png:gd:gd, +# png:cairo, png:cairo:gd, png:cairo:cairo, png:cairo:gdiplus, png:gdiplus and # png:gdiplus:gdiplus. # The default value is: png. # This tag requires that the tag HAVE_DOT is set to YES. @@ -2364,11 +2720,12 @@ DOT_PATH = DOTFILE_DIRS = -# The MSCFILE_DIRS tag can be used to specify one or more directories that -# contain msc files that are included in the documentation (see the \mscfile -# command). +# You can include diagrams made with dia in doxygen documentation. Doxygen will +# then run dia to produce the diagram and insert it in the documentation. The +# DIA_PATH tag allows you to specify the directory where the dia binary resides. +# If left empty dia is assumed to be found in the default search path. -MSCFILE_DIRS = +DIA_PATH = # The DIAFILE_DIRS tag can be used to specify one or more directories that # contain dia files that are included in the documentation (see the \diafile @@ -2377,10 +2734,10 @@ MSCFILE_DIRS = DIAFILE_DIRS = # When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the -# path where java can find the plantuml.jar file. If left blank, it is assumed -# PlantUML is not used or called during a preprocessing step. Doxygen will -# generate a warning when it encounters a \startuml command in this case and -# will not generate output for the diagram. +# path where java can find the plantuml.jar file or to the filename of jar file +# to be used. If left blank, it is assumed PlantUML is not used or called during +# a preprocessing step. Doxygen will generate a warning when it encounters a +# \startuml command in this case and will not generate output for the diagram. PLANTUML_JAR_PATH = @@ -2418,18 +2775,6 @@ DOT_GRAPH_MAX_NODES = 50 MAX_DOT_GRAPH_DEPTH = 0 -# Set the DOT_TRANSPARENT tag to YES to generate images with a transparent -# background. This is disabled by default, because dot on Windows does not seem -# to support this out of the box. -# -# Warning: Depending on the platform used, enabling this option may lead to -# badly anti-aliased labels on the edges of a graph (i.e. they become hard to -# read). -# The default value is: NO. -# This tag requires that the tag HAVE_DOT is set to YES. - -DOT_TRANSPARENT = NO - # Set the DOT_MULTI_TARGETS tag to YES to allow dot to generate multiple output # files in one run (i.e. multiple -o and -T options on the command line). This # makes dot run faster, but since only newer versions of dot (>1.8.10) support @@ -2442,14 +2787,34 @@ DOT_MULTI_TARGETS = NO # If the GENERATE_LEGEND tag is set to YES doxygen will generate a legend page # explaining the meaning of the various boxes and arrows in the dot generated # graphs. +# Note: This tag requires that UML_LOOK isn't set, i.e. the doxygen internal +# graphical representation for inheritance and collaboration diagrams is used. # The default value is: YES. # This tag requires that the tag HAVE_DOT is set to YES. GENERATE_LEGEND = YES -# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate dot +# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate # files that are used to generate the various graphs. +# +# Note: This setting is not only used for dot files but also for msc temporary +# files. # The default value is: YES. -# This tag requires that the tag HAVE_DOT is set to YES. DOT_CLEANUP = YES + +# You can define message sequence charts within doxygen comments using the \msc +# command. If the MSCGEN_TOOL tag is left empty (the default), then doxygen will +# use a built-in version of mscgen tool to produce the charts. Alternatively, +# the MSCGEN_TOOL tag can also specify the name an external tool. For instance, +# specifying prog as the value, doxygen will call the tool as prog -T +# -o . The external tool should support +# output file formats "png", "eps", "svg", and "ismap". + +MSCGEN_TOOL = + +# The MSCFILE_DIRS tag can be used to specify one or more directories that +# contain msc files that are included in the documentation (see the \mscfile +# command). + +MSCFILE_DIRS = diff --git a/docs/0-1-0-design-decisions.md b/docs/0-1-0-design-decisions.md index af170f4..7488cf4 100644 --- a/docs/0-1-0-design-decisions.md +++ b/docs/0-1-0-design-decisions.md @@ -79,7 +79,9 @@ encoding is as in this table: | 1110 | 14 | E | 16384 | 131072 | | 1111 | 15 | F | 32768 | 262144 | -Consequently, an object of size class F will have an allocation size of 32,768 words, but a payload size of 32,766 words. This obviously means that size classes 0 and 1 will not exist, since they would not have any payload. +Consequently, an object of size class F will have an allocation size of 32,768 +words, but a payload size of 32,766 words. This obviously means that size +classes 0 and 1 will not exist, since they would not have any payload. ## Page size @@ -87,23 +89,30 @@ Every page will be 1,048,576 bytes. ## Namespaces -Namespaces will be implemented; in addition to the root namespace, there will be at least the following namespaces: +Namespaces will be implemented; in addition to the root namespace, there will +be at least the following namespaces: ### :bootstrap -Functions written in the substrate language, intended to be replaced for all normal purposes by functions written in Lisp which may call these bootstrap functions. Not ever available to user code. +Functions written in the substrate language, intended to be replaced for all +normal purposes by functions written in Lisp which may call these bootstrap +functions. Not ever available to user code. ### :substrate -Functions written in the substrate language which *may* be available to user-written code. +Functions written in the substrate language which *may* be available to +user-written code. ### :system -Functions, written either in Lisp or in the substrate language, which modify system memory in ways that only trusted and privileged users are permitted to do. +Functions, written either in Lisp or in the substrate language, which modify +system memory in ways that only trusted and privileged users are permitted to +do. ## Access control -Obviously, for this to work, access control lists must be implemented and must work. +Obviously, for this to work, access control lists must be implemented and must +work. ## Router is deferred to 0.2.X From 604fca3c245b53d55aa2648f26fceaadf6c1341c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Mar 2026 11:24:33 +0000 Subject: [PATCH 09/29] Got most of the new memory architecture roughed out. --- .gitmodules | 3 ++ munit | 1 + src/c/memory/header.h | 40 +++++++++++++++++++++ src/c/memory/page.h | 61 +++++++++++++++++++++++++++++++++ src/c/memory/pointer.h | 39 +++++++++++++++++++++ src/c/memory/pso2.h | 53 ++++++++++++++++++++++++++++ src/c/memory/pso3.h | 35 +++++++++++++++++++ src/c/memory/pso4.h | 32 +++++++++++++++++ src/c/memory/pso5.h | 30 ++++++++++++++++ src/c/memory/pso6.h | 30 ++++++++++++++++ src/c/memory/pso7.h | 30 ++++++++++++++++ src/c/memory/pso8.h | 30 ++++++++++++++++ src/c/memory/pso9.h | 30 ++++++++++++++++ src/c/memory/psoa.h | 30 ++++++++++++++++ src/c/memory/psob.h | 30 ++++++++++++++++ src/c/memory/psoc.h | 30 ++++++++++++++++ src/c/memory/psod.h | 30 ++++++++++++++++ src/c/memory/psoe.h | 30 ++++++++++++++++ src/c/memory/psof.h | 30 ++++++++++++++++ src/c/payloads/cons.h | 32 +++++++++++++++++ src/c/payloads/exception.h | 28 +++++++++++++++ src/c/payloads/free.h | 30 ++++++++++++++++ src/c/payloads/function.h | 47 +++++++++++++++++++++++++ src/c/payloads/integer.h | 27 +++++++++++++++ src/c/payloads/keyword.h | 24 +++++++++++++ src/c/payloads/lambda.h | 32 +++++++++++++++++ src/c/payloads/nlambda.h | 22 ++++++++++++ src/c/payloads/read_stream.h | 34 ++++++++++++++++++ src/c/payloads/special.h | 43 +++++++++++++++++++++++ src/c/payloads/stack_frame.h | 38 ++++++++++++++++++++ src/c/payloads/string.h | 42 +++++++++++++++++++++++ src/c/payloads/symbol.h | 25 ++++++++++++++ src/c/payloads/time.h | 29 ++++++++++++++++ src/c/payloads/vector_pointer.h | 39 +++++++++++++++++++++ src/c/payloads/write_stream.h | 21 ++++++++++++ src/c/version.h | 11 ++++++ 36 files changed, 1118 insertions(+) create mode 100644 .gitmodules create mode 160000 munit create mode 100644 src/c/memory/header.h create mode 100644 src/c/memory/page.h create mode 100644 src/c/memory/pointer.h create mode 100644 src/c/memory/pso2.h create mode 100644 src/c/memory/pso3.h create mode 100644 src/c/memory/pso4.h create mode 100644 src/c/memory/pso5.h create mode 100644 src/c/memory/pso6.h create mode 100644 src/c/memory/pso7.h create mode 100644 src/c/memory/pso8.h create mode 100644 src/c/memory/pso9.h create mode 100644 src/c/memory/psoa.h create mode 100644 src/c/memory/psob.h create mode 100644 src/c/memory/psoc.h create mode 100644 src/c/memory/psod.h create mode 100644 src/c/memory/psoe.h create mode 100644 src/c/memory/psof.h create mode 100644 src/c/payloads/cons.h create mode 100644 src/c/payloads/exception.h create mode 100644 src/c/payloads/free.h create mode 100644 src/c/payloads/function.h create mode 100644 src/c/payloads/integer.h create mode 100644 src/c/payloads/keyword.h create mode 100644 src/c/payloads/lambda.h create mode 100644 src/c/payloads/nlambda.h create mode 100644 src/c/payloads/read_stream.h create mode 100644 src/c/payloads/special.h create mode 100644 src/c/payloads/stack_frame.h create mode 100644 src/c/payloads/string.h create mode 100644 src/c/payloads/symbol.h create mode 100644 src/c/payloads/time.h create mode 100644 src/c/payloads/vector_pointer.h create mode 100644 src/c/payloads/write_stream.h create mode 100644 src/c/version.h diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..1bfece3 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "munit"] + path = munit + url = https://github.com/nemequ/munit.git diff --git a/munit b/munit new file mode 160000 index 0000000..fbbdf14 --- /dev/null +++ b/munit @@ -0,0 +1 @@ +Subproject commit fbbdf1467eb0d04a6ee465def2e529e4c87f2118 diff --git a/src/c/memory/header.h b/src/c/memory/header.h new file mode 100644 index 0000000..ebd101d --- /dev/null +++ b/src/c/memory/header.h @@ -0,0 +1,40 @@ +/** + * memory/header.h + * + * Header for all page space objects + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_header_h +#define __psse_memory_header_h + +#include + +#define TAGLENGTH 3 + +/** + * @brief Header for all paged space objects. + * + */ +struct pso_header { + union { + /** the tag (type) of this cell, + * considered as bytes */ + struct { + /** mnemonic for this type; */ + char mnemonic[TAGLENGTH]; + /** sizetag for this object */ + uint8_t sizetag; + } tag; + /** the tag considered as a number */ + uint32_t value; + } tag; + /** the count of the number of references to this cell */ + uint32_t count; + /** cons pointer to the access control list of this cell */ + struct cons_pointer access; +}; + +#endif diff --git a/src/c/memory/page.h b/src/c/memory/page.h new file mode 100644 index 0000000..c4e1fe8 --- /dev/null +++ b/src/c/memory/page.h @@ -0,0 +1,61 @@ +/** + * memory/page.h + * + * Page for paged space psoects. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_page_h +#define __psse_memory_page_h + +#include "memory/pso2.h" +#include "memory/pso3.h" +#include "memory/pso4.h" +#include "memory/pso5.h" +#include "memory/pso6.h" +#include "memory/pso7.h" +#include "memory/pso8.h" +#include "memory/pso9.h" +#include "memory/psoa.h" +#include "memory/psob.h" +#include "memory/psoc.h" +#include "memory/psod.h" +#include "memory/psoe.h" +#include "memory/psof.h" + +#define PAGE_SIZE 1048576 + +/** + * @brief A page is a megabyte of memory which contains objects all of which + * are of the same size class. + * + * No page will contain both pso2s and pso4s, for example. We know what size + * objects are in a page by looking at the size tag of the first object, which + * will always be the fourth byte in the page (i.e page.bytes[3]). However, we + * will not normally have to worry about what size class the objects on a page + * are, since on creation all objects will be linked onto the freelist for + * their size class, they will be allocated from that free list, and on garbage + * collection they will be returned to that freelist. + */ +union page { + uint8_t[PAGE_SIZE] bytes; + uint64_t[PAGE_SIZE / 8] words; + struct pso2[PAGE_SIZE / 32] pso2s; + struct pso3[PAGE_SIZE / 64] pso3s; + struct pso4[PAGE_SIZE / 128] pso4s; + struct pso5[PAGE_SIZE / 256] pso5s; + struct pso6[PAGE_SIZE / 512] pso6s; + struct pso7[PAGE_SIZE / 1024] pso7s; + struct pso8[PAGE_SIZE / 2048] pso8s; + struct pso9[PAGE_SIZE / 4096] pso9s; + struct psoa[PAGE_SIZE / 8192] psoas; + struct psob[PAGE_SIZE / 16384] psobs; + struct psoc[PAGE_SIZE / 32768] psocs; + struct psod[PAGE_SIZE / 65536] psods; + struct psoe[PAGE_SIZE / 131072] psoes; + struct psof[PAGE_SIZE / 262144] psofs; +}; + +#endif diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h new file mode 100644 index 0000000..8b3b3bf --- /dev/null +++ b/src/c/memory/pointer.h @@ -0,0 +1,39 @@ +/** + * memory/pointer.h + * + * A pointer to a paged space object. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pointer_h +#define __psse_memory_pointer_h + +#include + +/** + * @brief A pointer to an object in page space. + * + */ +struct pso_pointer { + /** + * @brief The index of the node on which this object is curated. + * + * NOTE: This will always be NULL until we have the hypercube router + * working. + */ + uint32_t node; + /** + * @brief The index of the allocated page in which this object is stored. + */ + uint16_t page; + /** + * @brief The offset of the object within the page **in words**. + * + * NOTE THAT: This value is always **in words**, regardless of the size + * class of the objects stored in the page, because until we've got hold + * of the page we don't know its size class. + */ + uint16_t offset; +}; diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h new file mode 100644 index 0000000..86febbc --- /dev/null +++ b/src/c/memory/pso2.h @@ -0,0 +1,53 @@ +/** + * memory/pso2.h + * + * Paged space object of size class 2, four words total, two words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso2_h +#define __psse_memory_pso2_h + +#include + +#include "memory/header.h" +#include "payloads/cons.h" +#include "payloads/free.h" +#include "payloads/function.h" +#include "payloads/integer.h" +#include "payloads/ketwod.h" +#include "payloads/lambda.h" +#include "payloads/nlambda.h" +#include "payloads/read_stream.h" +#include "payloads/special.h" +#include "payloads/string.h" +#include "payloads/symbol.h" +#include "payloads/time.h" +#include "payloads/vector_pointer.h" +#include "payloads/write_stream.h" + +/** + * @brief A paged space object of size class 2, four words total, two words + * payload. + * + */ +struct pso2 { + struct pso_header header; + union { + char[16] bytes; + uint64_t[2] words; + struct cons_payload cons; + struct free_payload free; + struct function_payload function; + struct integer_payload integer; + struct lambda_payload lambda; + struct special_payload special; + struct stream_payload stream; + struct time_payload time; + struct vectorp_payload vectorp; + } payload; +}; + +#endif diff --git a/src/c/memory/pso3.h b/src/c/memory/pso3.h new file mode 100644 index 0000000..c3e03ce --- /dev/null +++ b/src/c/memory/pso3.h @@ -0,0 +1,35 @@ +/** + * memory/pso3.h + * + * Paged space object of size class 3, 8 words total, 6 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso3_h +#define __psse_memory_pso3_h + +#include + +#include "memory/header.h" +#include "payloads/exception.h" +#include "payloads/free.h" + + +/** + * @brief A paged space object of size class 3, 8 words total, 6 words + * payload. + * + */ +struct pso3 { + struct pso_header header; + union { + char[48] bytes; + uint64_t[6] words; + struct exception_payload exception; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h new file mode 100644 index 0000000..68a351d --- /dev/null +++ b/src/c/memory/pso4.h @@ -0,0 +1,32 @@ +/** + * memory/pso4.h + * + * Paged space object of size class 4, 16 words total, 14 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso4_h +#define __psse_memory_pso4_h + +#include + +#include "memory/header.h" +#include "payloads/stack_frame.h" + +/** + * @brief A paged space object of size class 4, 16 words total, 14 words + * payload. + * + */ +struct pso4 { + struct pso_header header; + union { + char[112] bytes; + uint64_t[14] words; + struct stack_frame_payload stack_frame; + } payload; +}; + +#endif diff --git a/src/c/memory/pso5.h b/src/c/memory/pso5.h new file mode 100644 index 0000000..311b544 --- /dev/null +++ b/src/c/memory/pso5.h @@ -0,0 +1,30 @@ +/** + * memory/pso5.h + * + * Paged space object of size class 5, 32 words total, 30 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso5_h +#define __psse_memory_pso5_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class 5, 32 words total, 30 words + * payload. + * + */ +struct pso5 { + struct pso_header header; + union { + char[240] bytes; + uint64_t[30] words; + } payload; +}; + +#endif diff --git a/src/c/memory/pso6.h b/src/c/memory/pso6.h new file mode 100644 index 0000000..8f94393 --- /dev/null +++ b/src/c/memory/pso6.h @@ -0,0 +1,30 @@ +/** + * memory/pso6.h + * + * Paged space object of size class 6, 64 words total, 62 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso6_h +#define __psse_memory_pso6_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class 6, 64 words total, 62 words + * payload. + * + */ +struct pso6 { + struct pso_header header; + union { + char[496] bytes; + uint64_t[62] words; + } payload; +}; + +#endif diff --git a/src/c/memory/pso7.h b/src/c/memory/pso7.h new file mode 100644 index 0000000..2ef9ad3 --- /dev/null +++ b/src/c/memory/pso7.h @@ -0,0 +1,30 @@ +/** + * memory/pso7.h + * + * Paged space object of size class 7, 128 words total, 126 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso7_h +#define __psse_memory_pso7_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class 7, 128 words total, 126 words + * payload. + * + */ +struct pso7 { + struct pso_header header; + union { + char[1008] bytes; + uint64_t[126] words; + } payload; +}; + +#endif diff --git a/src/c/memory/pso8.h b/src/c/memory/pso8.h new file mode 100644 index 0000000..c46a2c1 --- /dev/null +++ b/src/c/memory/pso8.h @@ -0,0 +1,30 @@ +/** + * memory/pso8.h + * + * Paged space object of size class 8, 256 words total, 254 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso8_h +#define __psse_memory_pso8_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class 8, 256 words total, 254 words + * payload. + * + */ +struct pso8 { + struct pso_header header; + union { + char[2032] bytes; + uint64_t[254] words; + } payload; +}; + +#endif diff --git a/src/c/memory/pso9.h b/src/c/memory/pso9.h new file mode 100644 index 0000000..4d07231 --- /dev/null +++ b/src/c/memory/pso9.h @@ -0,0 +1,30 @@ +/** + * memory/pso9.h + * + * Paged space object of size class 9, 512 words total, 510 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso9_h +#define __psse_memory_pso9_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class 9, 512 words total, 510 words + * payload. + * + */ +struct pso9 { + struct pso_header header; + union { + char[4080] bytes; + uint64_t[510] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psoa.h b/src/c/memory/psoa.h new file mode 100644 index 0000000..a7d7d19 --- /dev/null +++ b/src/c/memory/psoa.h @@ -0,0 +1,30 @@ +/** + * memory/psoa.h + * + * Paged space object of size class a, 1024 words total, 1022 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoa_h +#define __psse_memory_psoa_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class a, 1024 words total, 1022 words + * payload. + * + */ +struct psoa { + struct pso_header header; + union { + char[8176] bytes; + uint64_t[1022] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psob.h b/src/c/memory/psob.h new file mode 100644 index 0000000..24a9fa2 --- /dev/null +++ b/src/c/memory/psob.h @@ -0,0 +1,30 @@ +/** + * memory/psob.h + * + * Paged space object of size class b, 2048 words total, 2046 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psob_h +#define __psse_memory_psob_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class b, 2048 words total, 2046 words + * payload. + * + */ +struct psob { + struct pso_header header; + union { + char[16368] bytes; + uint64_t[2046] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psoc.h b/src/c/memory/psoc.h new file mode 100644 index 0000000..99c2a55 --- /dev/null +++ b/src/c/memory/psoc.h @@ -0,0 +1,30 @@ +/** + * memory/psoc.h + * + * Paged space object of size class c, 4096 words total, 4094 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoc_h +#define __psse_memory_psoc_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class c, 4096 words total, 4094 words + * payload. + * + */ +struct psoc { + struct pso_header header; + union { + char[32752] bytes; + uint64_t[4094] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psod.h b/src/c/memory/psod.h new file mode 100644 index 0000000..803cf90 --- /dev/null +++ b/src/c/memory/psod.h @@ -0,0 +1,30 @@ +/** + * memory/psod.h + * + * Paged space object of size class d, 8192 words total, 8190 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psod_h +#define __psse_memory_psod_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class d, 8192 words total, 8190 words + * payload. + * + */ +struct psod { + struct pso_header header; + union { + char[65520] bytes; + uint64_t[8190] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psoe.h b/src/c/memory/psoe.h new file mode 100644 index 0000000..d0313f7 --- /dev/null +++ b/src/c/memory/psoe.h @@ -0,0 +1,30 @@ +/** + * memory/psoe.h + * + * Paged space object of size class e, 16384 words total, 16382 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoe_h +#define __psse_memory_psoe_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class e, 16384 words total, 16382 words + * payload. + * + */ +struct psoe { + struct pso_header header; + union { + char[131056] bytes; + uint64_t[16382] words; + } payload; +}; + +#endif diff --git a/src/c/memory/psof.h b/src/c/memory/psof.h new file mode 100644 index 0000000..30ead84 --- /dev/null +++ b/src/c/memory/psof.h @@ -0,0 +1,30 @@ +/** + * memory/psof.h + * + * Paged space object of size class f, 32768 words total, 32766 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psof_h +#define __psse_memory_psof_h + +#include + +#include "memory/header.h" + +/** + * @brief A paged space object of size class f, 32768 words total, 32766 words + * payload. + * + */ +struct psof { + struct pso_header header; + union { + char[262128] bytes; + uint64_t[32766] words; + } payload; +}; + +#endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h new file mode 100644 index 0000000..a1b0d4d --- /dev/null +++ b/src/c/payloads/cons.h @@ -0,0 +1,32 @@ +/** + * payloads/cons.h + * + * A cons cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_cons_h +#define __psse_payloads_cons_h + +#include "memory/pointer.h" + +/** + * An ordinary cons cell: + */ +#define CONSTAG "CNS" + +/** + * @brief A cons cell. + * + */ +struct cons_payload { + /** Contents of the Address Register, naturally. */ + struct pso_pointer car; + /** Contents of the Decrement Register, naturally. */ + struct pso_pointer cdr; +}; + + +#endif diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h new file mode 100644 index 0000000..0363daa --- /dev/null +++ b/src/c/payloads/exception.h @@ -0,0 +1,28 @@ +/** + * payloads/exception.h + * + * An exception; required three pointers, so use object of size class 3. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_exception_h +#define __psse_payloads_exception_h + +#include "memory/pointer.h" + +/** + * @brief An exception; required three pointers, so use object of size class 3. + */ +struct exception_payload { + /** @brief the exception message. Expected to be a string, but may be anything printable. */ + struct pso_pointer message; + /** @brief the stack frame at which the exception was thrown. */ + struct pso_pointer stack; + /** @brief the cause; expected to be another exception, or (usually) `nil`. */ + struct cons_pointer cause; +}; + + +#endif diff --git a/src/c/payloads/free.h b/src/c/payloads/free.h new file mode 100644 index 0000000..3871c36 --- /dev/null +++ b/src/c/payloads/free.h @@ -0,0 +1,30 @@ +/** + * payloads/free.h + * + * An unassigned object, on a freelist; may be of any size class. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_free_h +#define __psse_payloads_free_h + +#include "memory/pointer.h" + +/** + * @brief Tag for an unassigned object; may be of any size class. + */ +#define FREETAG "FRE" + +/** + * @brief An unassigned object, on a freelist; may be of any size class. + * + */ +struct free_payload { + /** the next object on the free list for my size class */ + struct pso_pointer next; +}; + + +#endif diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h new file mode 100644 index 0000000..66ac8bc --- /dev/null +++ b/src/c/payloads/function.h @@ -0,0 +1,47 @@ +/** + * payloads/function.h + * + * an ordinary Lisp function - one whose arguments are pre-evaluated. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_function_h +#define __psse_payloads_function_h + +#include "memory/pointer.h" + +/** + * @brief Tag for an ordinary Lisp function - one whose arguments are pre-evaluated. + * \see LAMBDATAG for interpretable functions. + * \see SPECIALTAG for functions whose arguments are not pre-evaluated. + */ +#define FUNCTIONTAG "FUN" + +/** + * @brief Payload of a function cell. + * `source` points to the source from which the function was compiled, or NIL + * if it is a primitive. + * `executable` points to a function which takes a pointer to a stack frame + * (representing its stack frame) and a cons pointer (representing its + * environment) as arguments and returns a cons pointer (representing its + * result). + */ +struct function_payload { + /** + * pointer to metadata (e.g. the source from which the function was compiled). + */ + struct cons_pointer meta; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * \todo check this documentation is current! + */ + struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, + struct cons_pointer ); +}; + +#endif diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h new file mode 100644 index 0000000..69d0617 --- /dev/null +++ b/src/c/payloads/integer.h @@ -0,0 +1,27 @@ +/** + * payloads/integer.h + * + * An integer. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_integer_h +#define __psse_payloads_integer_h + +#include + +/** + * @brief An integer . + * + * Integers can in principal store a 128 bit value, but in practice we'll start + * promoting them to bignums when they pass the 64 bit barrier. However, that's + * in the Lisp layer, not the substrate. + */ +struct integer_payload { + int128_t value; +}; + + +#endif diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h new file mode 100644 index 0000000..164d31c --- /dev/null +++ b/src/c/payloads/keyword.h @@ -0,0 +1,24 @@ +/** + * payloads/keyword.h + * + * A keyword cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_keyword_h +#define __psse_payloads_keyword_h + +#include "memory/pointer.h" + +/** + * Tag for a keyword - an interned, self-evaluating string. + */ +#define KEYTAG "KEY" + +/* TODO: for now, Keyword shares a payload with String, but this may change. + * Strings are of indefinite length, but keywords are really not, and might + * fit into any size class. */ + +#endif diff --git a/src/c/payloads/lambda.h b/src/c/payloads/lambda.h new file mode 100644 index 0000000..f457339 --- /dev/null +++ b/src/c/payloads/lambda.h @@ -0,0 +1,32 @@ +/** + * payloads/lambda.h + * + * A lambda cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_lambda_h +#define __psse_payloads_lambda_h + +#include "memory/pointer.h" + +/** + * @brief Tag for lambda cell. Lambdas are the interpretable (source) versions of functions. + * \see FUNCTIONTAG. + */ +#define LAMBDATAG "LMD" + +/** + * @brief payload for lambda and nlambda cells. + */ +struct lambda_payload { + /** the arument list */ + struct pso_pointer args; + /** the body of the function to be applied to the arguments. */ + struct pso_pointer body; +}; + + +#endif diff --git a/src/c/payloads/nlambda.h b/src/c/payloads/nlambda.h new file mode 100644 index 0000000..bf96361 --- /dev/null +++ b/src/c/payloads/nlambda.h @@ -0,0 +1,22 @@ +/** + * payloads/nlambda.h + * + * A nlambda cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_nlambda_h +#define __psse_payloads_nlambda_h + +#include "memory/pointer.h" + +/** + * An ordinary nlambda cell: + */ +#define CONSTAG "CNS" + +/* nlambda shares a payload with lambda */ + +#endif diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h new file mode 100644 index 0000000..5489308 --- /dev/null +++ b/src/c/payloads/read_stream.h @@ -0,0 +1,34 @@ +/** + * payloads/read_stream.h + * + * A read stream. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_read_stream_h +#define __psse_payloads_read_stream_h + +#include + +#include "memory/pointer.h" + +/** + * An open read stream. + */ +#define READTAG "REA" + +/** + * payload of a read or write stream cell. + */ +struct stream_payload { + /** the stream to read from or write to. */ + URL_FILE *stream; + /** metadata on the stream (e.g. its file attributes if a file, its HTTP + * headers if a URL, etc). Expected to be an association, or nil. Not yet + * implemented. */ + struct cons_pointer meta; +}; + +#endif diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h new file mode 100644 index 0000000..96f616d --- /dev/null +++ b/src/c/payloads/special.h @@ -0,0 +1,43 @@ +/** + * payloads/special.h + * + * A special form. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_special_h +#define __psse_payloads_special_h + +#include "memory/pointer.h" + +/** + * A special form - one whose arguments are not pre-evaluated but passed as + * provided. + * \see NLAMBDATAG. + */ +#define SPECIALTAG "SFM" + +/** + * @brief Payload of a special form cell. + * + * Currently identical to the payload of a function cell. + * \see function_payload + */ +struct special_payload { + /** + * pointer to the source from which the special form was compiled, or NIL + * if it is a primitive. + */ + struct cons_pointer meta; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). */ + struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, + struct cons_pointer ); +}; + +#endif diff --git a/src/c/payloads/stack_frame.h b/src/c/payloads/stack_frame.h new file mode 100644 index 0000000..2aefcfc --- /dev/null +++ b/src/c/payloads/stack_frame.h @@ -0,0 +1,38 @@ +/** + * payloads/stack_frame.h + * + * A stack frame. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_stack_frame_h +#define __psse_payloads_stack_frame_h +#include + +#include "memory/pointer.h" +/* + * number of arguments stored in a stack frame + */ +#define args_in_frame 8 + +/** + * A stack frame. + */ +struct stack_frame_payload { + /** the previous frame. */ + struct cons_pointer previous; + /** first 8 arument bindings. */ + struct cons_pointer arg[args_in_frame]; + /** list of any further argument bindings. */ + struct cons_pointer more; + /** the function to be called. */ + struct cons_pointer function; + /** the number of arguments provided. */ + int args; + /** the depth of the stack below this frame */ + int depth; +}; + +#endif diff --git a/src/c/payloads/string.h b/src/c/payloads/string.h new file mode 100644 index 0000000..dbc45ca --- /dev/null +++ b/src/c/payloads/string.h @@ -0,0 +1,42 @@ +/** + * payloads/string.h + * + * A string cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_string_h +#define __psse_payloads_string_h +/* + * wide characters + */ +#include +#include + +#include "memory/pointer.h" + + +/** + * @brief Tag for string of characters, organised as a linked list. + */ +#define STRINGTAG "STR" + +/** + * @brief payload of a string cell. + * + * At least at first, only one UTF character will be stored in each cell. At + * present the payload of a symbol or keyword cell is identical + * to the payload of a string cell. + */ +struct string_payload { + /** the actual character stored in this cell */ + wint_t character; + /** a hash of the string value, computed at store time. */ + uint32_t hash; + /** the remainder of the string following this character. */ + struct cons_pointer cdr; +}; + +#endif diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h new file mode 100644 index 0000000..9e7afd5 --- /dev/null +++ b/src/c/payloads/symbol.h @@ -0,0 +1,25 @@ +/** + * payloads/symbol.h + * + * A symbol cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_symbol_h +#define __psse_payloads_symbol_h + +#include "memory/pointer.h" + + +/** + * Tag for a symbol: just like a keyword except not self-evaluating. + */ +#define SYMBOLTAG "SYM" + +/* TODO: for now, Symbol shares a payload with String, but this may change. + * Strings are of indefinite length, but symbols are really not, and might + * fit into any size class. */ + +#endif diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h new file mode 100644 index 0000000..e304e67 --- /dev/null +++ b/src/c/payloads/time.h @@ -0,0 +1,29 @@ +/** + * payloads/cons.h + * + * A cons cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_cons_h +#define __psse_payloads_cons_h + +#include "memory/pointer.h" + +/** + * @brief Tag for a time stamp. + */ +#define TIMETAG "TIME" + +/** + * The payload of a time cell: an unsigned 128 bit value representing micro- + * seconds since the estimated date of the Big Bang (actually, for + * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch)) + */ +struct time_payload { + unsigned __int128 value; +}; + +#endif diff --git a/src/c/payloads/vector_pointer.h b/src/c/payloads/vector_pointer.h new file mode 100644 index 0000000..b5e5f1c --- /dev/null +++ b/src/c/payloads/vector_pointer.h @@ -0,0 +1,39 @@ +/** + * payloads/vector_pointer.h + * + * A pointer to an object in vector space. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_vector_pointer_h +#define __psse_payloads_vector_pointer_h + +#include "memory/pointer.h" + +/** + * A pointer to an object in vector space. + */ +#define VECTORPOINTTAG "VSP" + +/** + * @brief payload of a vector pointer cell. + */ +struct vectorp_payload { + /** the tag of the vector-space object. NOTE that the vector space object + * should itself have the identical tag. */ + union { + /** the tag (type) of the vector-space object this cell + * points to, considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; + } tag; + /** unused padding to word-align the address */ + uint32_t padding; + /** the address of the actual vector space object */ + void *address; +}; + +#endif diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h new file mode 100644 index 0000000..757f7d0 --- /dev/null +++ b/src/c/payloads/write_stream.h @@ -0,0 +1,21 @@ +/** + * payloads/write_stream.h + * + * A write_stream cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_write_stream_h +#define __psse_payloads_write_stream_h + +#include "memory/pointer.h" + +/** + * @brief Tag for an open write stream. + */ +#define WRITETAG "WRT" + +/* write stream shares a payload with /see read_streem.h */ +#endif diff --git a/src/c/version.h b/src/c/version.h new file mode 100644 index 0000000..d6b3f2b --- /dev/null +++ b/src/c/version.h @@ -0,0 +1,11 @@ +/** + * version.h + * + * Just the version number. There's DEFINITELY a better way to do this! + * + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#define VERSION "0.1.0-SNAPSHOT" From 6c4be8f28358da2b294f05c29cccf9f66fe6c395 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 26 Mar 2026 09:01:46 +0000 Subject: [PATCH 10/29] Lots more code written, and I think most of it's OK; but it doesn't compile yet. --- src/c/arith/READMDE.md | 24 ++++ src/c/debug.c | 16 +++ src/c/debug.h | 96 ++++++++++++++++ src/c/memory/memory.c | 14 +++ src/c/memory/memory.h | 15 +++ src/c/memory/node.c | 55 +++++++++ src/c/memory/node.h | 31 ++++++ src/c/memory/page.c | 36 ++++++ src/c/memory/pointer.h | 2 + src/c/memory/pso4.h | 2 +- src/c/memory/stack.c | 38 +++++++ .../stack_frame.h => memory/stack.h} | 19 +++- src/c/ops/README.md | 16 +++ src/c/ops/eq.c | 56 ++++++++++ src/c/ops/eq.h | 21 ++++ src/c/ops/eval.c | 65 +++++++++++ src/c/ops/repl.h | 0 src/c/psse.c | 105 ++++++++++++++++++ src/c/psse.h | 30 +++++ 19 files changed, 634 insertions(+), 7 deletions(-) create mode 100644 src/c/arith/READMDE.md create mode 100644 src/c/debug.c create mode 100644 src/c/debug.h create mode 100644 src/c/memory/memory.c create mode 100644 src/c/memory/memory.h create mode 100644 src/c/memory/node.c create mode 100644 src/c/memory/node.h create mode 100644 src/c/memory/page.c create mode 100644 src/c/memory/stack.c rename src/c/{payloads/stack_frame.h => memory/stack.h} (67%) create mode 100644 src/c/ops/README.md create mode 100644 src/c/ops/eq.c create mode 100644 src/c/ops/eq.h create mode 100644 src/c/ops/eval.c create mode 100644 src/c/ops/repl.h create mode 100644 src/c/psse.c create mode 100644 src/c/psse.h diff --git a/src/c/arith/READMDE.md b/src/c/arith/READMDE.md new file mode 100644 index 0000000..f59b772 --- /dev/null +++ b/src/c/arith/READMDE.md @@ -0,0 +1,24 @@ +# README: PSSE substrate arithmetic + +This folder/pseudo package is to implement enough of arithmetic for bootstrap: +that is, enough that all more sophisticated arithmetic can be built on top of +it. + +Ratio arithmetic will not be implemented in the substrate, but `make-ratio` +will. The signature for `make-ratio` will be: + +`(make-ratio dividend divisor) => ratio` + +Both divisor and dividend should be integers. If the divisor is `1` it will +return the dividend (as an integer). If the divisor is 0 it will return ∞. + +This implies we need a privileged data item representing infinity... + +Bignum arithmetic will not be implemented in the substrate, but `make-bignum` +will be. The signature for `make-bignum` will be + +`(make-bignum integer) => bignum` + +If the integer argument is less than 64 bits, the argument will be returned +unmodified. If it is more than 64 bits, a bignum of the same value will be +returned. \ No newline at end of file diff --git a/src/c/debug.c b/src/c/debug.c new file mode 100644 index 0000000..2bd417d --- /dev/null +++ b/src/c/debug.c @@ -0,0 +1,16 @@ +/** + * debug.h + * + * Post Scarcity Software Environment: entry point. + * + * Print debugging output. + * + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + #include "debug.h" + + int verbosity = 0; + \ No newline at end of file diff --git a/src/c/debug.h b/src/c/debug.h new file mode 100644 index 0000000..deb4487 --- /dev/null +++ b/src/c/debug.h @@ -0,0 +1,96 @@ +/** + * debug.h + * + * Post Scarcity Software Environment: entry point. + * + * Print debugging output. + * + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_debug_h +#define __psse_debug_h +#include +#include +#include + +/** + * @brief Print messages debugging memory allocation. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_ALLOC 1 + +/** + * @brief Print messages debugging arithmetic operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_ARITH 2 + +/** + * @brief Print messages debugging symbol binding. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_BIND 4 + +/** + * @brief Print messages debugging bootstrapping and teardown. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_BOOTSTRAP 8 + +/** + * @brief Print messages debugging evaluation. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_EVAL 16 + +/** + * @brief Print messages debugging input/output operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_IO 32 + +/** + * @brief Print messages debugging lambda functions (interpretation). + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_LAMBDA 64 + +/** + * @brief Print messages debugging the read eval print loop. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_REPL 128 + +/** + * @brief Print messages debugging stack operations. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_STACK 256 + +/** + * @brief Print messages about equality tests. + * + * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v. + */ +#define DEBUG_EQUAL 512 + +/** + * @brief Verbosity (and content) of debugging output + * + * Interpreted as a sequence of topic-specific flags, see above. + */ +extern int verbosity; + +#endif \ No newline at end of file diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c new file mode 100644 index 0000000..570083e --- /dev/null +++ b/src/c/memory/memory.c @@ -0,0 +1,14 @@ +/** + * memory/memory.c + * + * The memory management subsystem. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + #include + + int initialise_memory() { + fprintf( stderr, "TODO: Implement initialise_memory()"); + } \ No newline at end of file diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h new file mode 100644 index 0000000..a632520 --- /dev/null +++ b/src/c/memory/memory.h @@ -0,0 +1,15 @@ +/** + * memory/memory.h + * + * The memory management subsystem. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso4_h +#define __psse_memory_pso4_h + +int initialise_memory(); + +#endif diff --git a/src/c/memory/node.c b/src/c/memory/node.c new file mode 100644 index 0000000..efbb9d4 --- /dev/null +++ b/src/c/memory/node.c @@ -0,0 +1,55 @@ +/** + * memory/node.c + * + * Top level data about the actual node on which this memory system sits. + * May not belong in `memory`. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/memory.h" +#include "memory/pointer.h" + +/** + * @brief Flag to prevent the node being initialised more than once. + * + */ +bool node_initialised = false; + +/** + * @brief The index of this node in the hypercube. + * + */ +uint32_t node_index = 0; + +/** + * @brief The canonical `nil` pointer + * + */ +struct pso_pointer nil = struct pso_pointer{ 0, 0, 0}; + +/** + * @brief the canonical `t` (true) pointer. + * + */ +struct pso_pointer t = struct pso_pointer{ 0, 0, 1}; + +/** + * @brief Set up the basic informetion about this node + * + * @param index + * @return struct pso_pointer + */ +struct pso_pointer initialise_node( uint32_t index) { + node_index = index; + nil = pso_pointer{ index, 0, 0}; + t = pso_pointer( index, 0, 1); + pso_pointer result = initialise_memory(index); + + if ( eq( result, t)) { + result = initialise_environment(); + } + + return result; +} diff --git a/src/c/memory/node.h b/src/c/memory/node.h new file mode 100644 index 0000000..e21ec86 --- /dev/null +++ b/src/c/memory/node.h @@ -0,0 +1,31 @@ +/** + * memory/node.h + * + * Top level data about the actual node on which this memory system sits. + * May not belong in `memory`. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_node_h +#define __psse_memory_node_h + + +/** + * @brief The index of this node in the hypercube. + * + */ +extern int node_index; + +/** + * @brief The canonical `nil` pointer + * + */ +extern struct pso_pointer nil; + +/** + * @brief the canonical `t` (true) pointer. + * + */ +extern struct pso_pointer t; diff --git a/src/c/memory/page.c b/src/c/memory/page.c new file mode 100644 index 0000000..4b9fe0f --- /dev/null +++ b/src/c/memory/page.c @@ -0,0 +1,36 @@ +/** + * memory/page.c + * + * Page for paged space psoects. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/page.h" +#include "memory/pso2.h" +#include "memory/pso3.h" +#include "memory/pso4.h" +#include "memory/pso5.h" +#include "memory/pso6.h" +#include "memory/pso7.h" +#include "memory/pso8.h" +#include "memory/pso9.h" +#include "memory/psoa.h" +#include "memory/psob.h" +#include "memory/psoc.h" +#include "memory/psod.h" +#include "memory/psoe.h" +#include "memory/psof.h" + +void * malloc_page( uint8_t size_class) { + void * result = malloc( sizeof( page)); + + if (result != NULL) { + + } + + return result; +} \ No newline at end of file diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index 8b3b3bf..18c3aa9 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -37,3 +37,5 @@ struct pso_pointer { */ uint16_t offset; }; + +#endif diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index 68a351d..1384d12 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -13,7 +13,7 @@ #include #include "memory/header.h" -#include "payloads/stack_frame.h" +#include "memory/stack.h" /** * @brief A paged space object of size class 4, 16 words total, 14 words diff --git a/src/c/memory/stack.c b/src/c/memory/stack.c new file mode 100644 index 0000000..ab98c93 --- /dev/null +++ b/src/c/memory/stack.c @@ -0,0 +1,38 @@ +/** + * memory/stack.c + * + * The execution stack. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/stack.h" + +/** + * @brief The maximum depth of stack before we throw an exception. + * + * `0` is interpeted as `unlimited`. + */ +uint32_t stack_limit = 0; + +/** + * Fetch a pointer to the value of the local variable at this index. + */ +struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) { + struct cons_pointer result = NIL; + + if ( index < args_in_frame ) { + result = frame->arg[index]; + } else { + struct cons_pointer p = frame->more; + + for ( int i = args_in_frame; i < index; i++ ) { + p = pointer2cell( p ).payload.cons.cdr; + } + + result = pointer2cell( p ).payload.cons.car; + } + + return result; +} diff --git a/src/c/payloads/stack_frame.h b/src/c/memory/stack.h similarity index 67% rename from src/c/payloads/stack_frame.h rename to src/c/memory/stack.h index 2aefcfc..7e0b2b0 100644 --- a/src/c/payloads/stack_frame.h +++ b/src/c/memory/stack.h @@ -1,7 +1,7 @@ /** - * payloads/stack_frame.h + * memory/stack.h * - * A stack frame. + * The execution stack. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -17,18 +17,25 @@ */ #define args_in_frame 8 +/** + * @brief The maximum depth of stack before we throw an exception. + * + * `0` is interpeted as `unlimited`. + */ +extern uint32_t stack_limit; + /** * A stack frame. */ struct stack_frame_payload { /** the previous frame. */ - struct cons_pointer previous; + struct pso_pointer previous; /** first 8 arument bindings. */ - struct cons_pointer arg[args_in_frame]; + struct pso_pointer arg[args_in_frame]; /** list of any further argument bindings. */ - struct cons_pointer more; + struct pso_pointer more; /** the function to be called. */ - struct cons_pointer function; + struct pso_pointer function; /** the number of arguments provided. */ int args; /** the depth of the stack below this frame */ diff --git a/src/c/ops/README.md b/src/c/ops/README.md new file mode 100644 index 0000000..80f3ccd --- /dev/null +++ b/src/c/ops/README.md @@ -0,0 +1,16 @@ +# README: PSSE substrate operations + +This folder/pseudo-package is for things which implement basic Lisp functions. +These will be the functions which make up the `:bootstrap` and `:substrate` +packages in Lisp. + +For each basic function the intention is that there should be one `.c` file +(and normally one `.h` file as well). This file will provide one version of the +function with Lisp calling conventions, called `lisp_xxxx`, and one with C +calling conventions, called `xxxx`. It does not matter whether the lisp version +calls the C version or vice versa, but one should call the other so there are +not two different versions of the logic. + +Substrate I/O functions will not be provided in this pseudo-package but in `io`. +Substrate arithmetic functions will not be provided in this pseudo-package but +in `arith`. \ No newline at end of file diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c new file mode 100644 index 0000000..0c2e192 --- /dev/null +++ b/src/c/ops/eq.c @@ -0,0 +1,56 @@ +/** + * ops/eq.c + * + * Post Scarcity Software Environment: eq. + * + * Test for pointer equality. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/memory.h" +#include "memory/pointer.h" +#include "memory/stack.h" + +/** + * @brief Function; do these two pointers point to the same object? + * + * Shallow, cheap equality. + * + * TODO: if either of these pointers points to a cache cell, then what + * we need to check is the cached value, which is not so cheap. Ouch! + * + * @param a a pointer; + * @param b another pointer; + * @return `true` if they are the same, else `false` + */ +bool eq( struct pso_pointer a, struct pso_pointer b) { + return ( a.node == b.node && a.page == b.page && a.offset == b.offset); +} + +/** + * Function; do all arguments to this finction point to the same object? + * + * Shallow, cheap equality. + * + * * (eq? args...) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if all args are pointers to the same object, else `nil`; + */ +struct pso_pointer lisp_eq( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = t; + + if ( frame->args > 1 ) { + for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { + result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? t : nil; + } + } + + return result; +} diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h new file mode 100644 index 0000000..febb5af --- /dev/null +++ b/src/c/ops/eq.h @@ -0,0 +1,21 @@ +/** + * ops/eq.h + * + * Post Scarcity Software Environment: eq. + * + * Test for pointer equality. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_eq_h +#define __psse_ops_eq_h + +bool eq( struct pso_pointer a, struct pso_pointer b); + +struct pso_pointer lisp_eq( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +#endif \ No newline at end of file diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c new file mode 100644 index 0000000..d76da2b --- /dev/null +++ b/src/c/ops/eval.c @@ -0,0 +1,65 @@ +/** + * ops/eval.c + * + * Post Scarcity Software Environment: eval. + * + * Evaluate an arbitrary Lisp expression. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer" +#include "memory/stack.h" +#include "payloads/cons.h" +#include "payloads/function.h" +#include "payloads/keyword.h" +#include "payloads/lambda.h" +#include "payloads/nlambda.h" +#include "payloads/special.h" + +/** + * @brief Despatch eval based on tag of the form in the first position. + * + * @param frame The current stack frame; + * @param frame_pointer A pointer to the current stack frame; + * @param env the evaluation environment. + * @return struct pso_pointer + */ +struct pso_pointer eval_despatch( struct stack_frame *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = frame->arg[0]; + + // switch ( get_tag_value( result)) { + // case CONSTV: + // result = eval_cons( frame, frame_pointer, env); + // break; + // case KEYTV: + // case SYMBOLTV: + // result = eval_symbol( frame, frame_pointer, env); + // break; + // case LAMBDATV: + // result = eval_lambda( frame, frame_pointer, env); + // break; + // case NLAMBDATV: + // result = eval_nlambda( frame, frame_pointer, env); + // break; + // case SPECIALTV: + // result = eval_special( frame, frame_pointer, env); + // break; + // } + + return result; +} + +struct pso_pointer lisp_eval( struct stack_frame *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = eval_despatch( frame, frame_pointer, env); + + if (exceptionp( result)) { + // todo: if result doesn't have a stack frame, create a new exception wrapping + // result with this stack frame. + } + + return result; +} \ No newline at end of file diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/psse.c b/src/c/psse.c new file mode 100644 index 0000000..636cde5 --- /dev/null +++ b/src/c/psse.c @@ -0,0 +1,105 @@ + +/** + * psse.c + * + * Post Scarcity Software Environment: entry point. + * + * Start up and initialise the environement - just enough to get working + * and (ultimately) hand off to the executive. + * + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "psse.h" +#include "memory/node.h" + +void print_banner( ) { + fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", + VERSION ); +} + +/** + * Print command line options to this `stream`. + * + * @stream the stream to print to. + */ +void print_options( FILE *stream ) { + fwprintf( stream, L"Expected options are:\n" ); + fwprintf( stream, + L"\t-d\tDump memory to standard out at end of run (copious!);\n" ); + fwprintf( stream, L"\t-h\tPrint this message and exit;\n" ); + fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" ); + fwprintf( stream, + L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" ); +#ifdef DEBUG + fwprintf( stream, + L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" ); + fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); + fwprintf( stream, L"\t\t1\tALLOC;\n" ); + fwprintf( stream, L"\t\t2\tARITH;\n" ); + fwprintf( stream, L"\t\t4\tBIND;\n" ); + fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" ); + fwprintf( stream, L"\t\t16\tEVAL;\n" ); + fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" ); + fwprintf( stream, L"\t\t64\tLAMBDA;\n" ); + fwprintf( stream, L"\t\t128\tREPL;\n" ); + fwprintf( stream, L"\t\t256\tSTACK;\n" ); + fwprintf( stream, L"\t\t512\tEQUAL.\n" ); +#endif +} + + + /** + * main entry point; parse command line arguments, initialise the environment, + * and enter the read-eval-print loop. + */ +int main( int argc, char *argv[] ) { + int option; + bool dump_at_end = false; + bool show_prompt = false; + char *infilename = NULL; + + setlocale( LC_ALL, "" ); + // if ( io_init( ) != 0 ) { + // fputs( "Failed to initialise I/O subsystem\n", stderr ); + // exit( 1 ); + // } + + while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { + switch ( option ) { + case 'd': + dump_at_end = true; + break; + case 'h': + print_banner( ); + print_options( stdout ); + exit( 0 ); + break; + case 'i': + infilename = optarg; + break; + case 'p': + show_prompt = true; + break; + case 's': + stack_limit = atoi( optarg ); + break; + case 'v': + verbosity = atoi( optarg ); + break; + default: + fwprintf( stderr, L"Unexpected option %c\n", option ); + print_options( stderr ); + exit( 1 ); + break; + } + } + + initialise_node( 0); + + repl(); + + exit( 0); +} \ No newline at end of file diff --git a/src/c/psse.h b/src/c/psse.h new file mode 100644 index 0000000..759c33c --- /dev/null +++ b/src/c/psse.h @@ -0,0 +1,30 @@ +/** + * psse.h + * + * Post Scarcity Software Environment: entry point. + * + * Start up and initialise the environement - just enough to get working + * and (ultimately) hand off to the executive. + * + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_psse_h +#define __psse_psse_h + +#include +#include +#include +#include +#include +#include +#include + +#include "debug.h" +#include "memory/memory.h" +#include "memory/stack.h" +#include "version.h" + +#endif \ No newline at end of file From 57c5fe314a7f0068a047c83ac624d300e43d4e55 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 26 Mar 2026 09:03:27 +0000 Subject: [PATCH 11/29] Things which should have been saved before the last commit. Sigh. --- src/c/memory/memory.c | 9 +++++++-- src/c/memory/memory.h | 8 ++++++-- src/c/memory/node.h | 2 ++ 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 570083e..4a365e3 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -7,8 +7,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #include +#include - int initialise_memory() { +#include "memory/pointer.h" + + + +int initialise_memory( int node) { fprintf( stderr, "TODO: Implement initialise_memory()"); + } \ No newline at end of file diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index a632520..37bd39c 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -7,9 +7,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef __psse_memory_pso4_h -#define __psse_memory_pso4_h +#ifndef __psse_memory_memory_h +#define __psse_memory_memory_h + +#include "memory/pointer.h" int initialise_memory(); +extern struct pso_pointer out_of_memory_exception; + #endif diff --git a/src/c/memory/node.h b/src/c/memory/node.h index e21ec86..cae61e6 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -29,3 +29,5 @@ extern struct pso_pointer nil; * */ extern struct pso_pointer t; + +#endif From 154cda8da33fe9148d5b5801b29a2920f921e57e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 26 Mar 2026 09:20:41 +0000 Subject: [PATCH 12/29] Added a 'state of play' update; changed the strapline in Home.md --- docs/Home.md | 4 ++-- docs/State-of-play.md | 7 +++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/docs/Home.md b/docs/Home.md index b4dfc0e..8937653 100644 --- a/docs/Home.md +++ b/docs/Home.md @@ -1,6 +1,6 @@ # Post Scarcity Software Environment: general documentation -Work towards the implementation of a software system like that described in [Post Scarcity Software](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/). +Work towards the implementation of a software system for the hardware of the deep future. ## Note on canonicity @@ -12,7 +12,7 @@ You can read about the current [state of play](State-of-play.md). ## Roadmap -There is now a [roadmap](Roadmap.md) for the project. +There is now a [roadmap](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_roadmap.html) for the project. ## AWFUL WARNING 1 diff --git a/docs/State-of-play.md b/docs/State-of-play.md index ffa4e79..393f1aa 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,12 @@ # State of Play +## 20260326 + +Most of the memory architecture of the new prototype is now roughed out, but +in C, not in a more modern language. It doesn't compile yet. + +My C is getting better... but it needed to! + ## 20260323 I started an investigastion of the [Zig language](https://ziglang.org/) and From 0a22222042df874ada17d60b3e1a361c827ab87e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 26 Mar 2026 09:27:35 +0000 Subject: [PATCH 13/29] The idea of symlinking README.md to docs/Home.md didn't work for autogeneration. For the `master` branch I'm going back to having a separate README.md. Thought should be given into making that update from docs/Home.md from time to time, but URLs need to be fixed up which is awkward. --- README.md | 191 +++++++++++++++++++++++++++++++++++++++++- docs/Home.md | 4 +- docs/State-of-play.md | 31 +++++++ 3 files changed, 223 insertions(+), 3 deletions(-) mode change 120000 => 100644 README.md diff --git a/README.md b/README.md deleted file mode 120000 index 88165ce..0000000 --- a/README.md +++ /dev/null @@ -1 +0,0 @@ -docs/Home.md \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..d9a8e32 --- /dev/null +++ b/README.md @@ -0,0 +1,190 @@ +# Post Scarcity Software Environment: general documentation + +Work towards the implementation of a software system for the hardware of the deep future. + +## Note on canonicity + +*Originally most of this documentation was on a wiki attached to the [GitHub project](https://github.com/simon-brooke/post-scarcity); when that was transferred to [my own foregejo instance](https://git.journeyman.cc/simon/post-scarcity) the wiki was copied. However, it's more convenient to keep documentation in the project with the source files, and version controlled in the same Git repository. So while both wikis still exist, they should no longer be considered canonical. The canonical version is in `/docs`, and is incorporated by [Doxygen](https://www.doxygen.nl/) into the generated documentation — which is generated into `/doc` using the command `make doc`.* + +## State of Play + +You can read about the current [state of play](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_state-of-play.html). + +## Roadmap + +There is now a [roadmap](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_roadmap.html) for the project. + +## AWFUL WARNING 1 + +This does not work. It isn't likely to work any time soon. If you want to learn Lisp, don't start here; try Clojure, Scheme or Common Lisp (in which case I recommend Steel Bank Common Lisp). If you want to learn how Lisp works, still don't start here. This isn't ever going to be anything like a conventional Lisp environment. + +What it sets out to be is a Lisp-like system which: + +* Can make use (albeit not, at least at first, very efficiently) of machines with at least [Zettabytes](http://highscalability.com/blog/2012/9/11/how-big-is-a-petabyte-exabyte-zettabyte-or-a-yottabyte.html) of RAM; +* Can make reasonable use of machines with at least billions of processors; +* Can concurrently support significant numbers of users, all doing different things, without them ever interfering with one another; +* Can ensure that users cannot escalate privilege; +* Can ensure users private data remains private. + +When Linus Torvalds sat down in his bedroom to write Linux, he had something usable in only a few months. BUT: + +* Linus was young, energetic, and extremely talented; I am none of those things. +* Linus was trying to build a clone of something which already existed and was known to work. Nothing like what I'm aiming for exists. +* Linus was able to adopt the GNU user space stack. There is no user space stack for this idea; I don't even know what one would look like. + +## AWFUL WARNING 2 + +This project is necessarily experimental and exploratory. I write code, it reveals new problems, I think about them, and I mutate the design. This documentation does not always keep up with the developing source code. + +## Building + +The substrate of this version is written in plain old fashioned C and built with a Makefile. I regret this decision; I think either Zig or Rust would have been better places to start; but neither of them were sufficiently well developed to support what I wanted to do when I did start. + +To build, you need a C compiler; I use GCC, others may work. You need a make utility; I use GNU Make. You need [libcurl](https://curl.se/libcurl/). + +With these dependencies in place, clone the repository from [here](https://git.journeyman.cc/simon/post-scarcity/), and run `make` in the resulting project directory. If all goes well you will find and executable, `psse`, in the target directory. + +This has been developed on Debian but probably builds on any 64 bit UN*X; however I do **not** guarantee this. + +### Make targets + +#### default + +The default `make` target will produce an executable as `target/psse`. + +#### clean + +`make clean` will remove all compilation detritus; it will also remove temporary files. + +#### doc + +`make doc` will generate documentation in the `doc` directory. Depends on `doxygen` being present on your system. + +#### format + +`make format` will standardise the formay of C code. Depends on the GNU `indent` program being present on your system. + +#### REPL + +`make repl` will start a read-eval-print loop. `*log*` is directed to `tmp/psse.log`. + +#### test + +`make test` will run all unit tests. + +## In use + +What works just now is a not very good, not very efficient Lisp interpreter which does not conform to any existing Lisp standard. You can start a REPL, and you can write and evaluate functions. You can't yet save or load your functions. It's interesting mainly because of its architecture, and where it's intended to go, rather than where it is now. + +### Documentation + +There is [documentation](https://www.journeyman.cc/post-scarcity/doc/html/). + +### Invoking + +The binary is canonically named `psse`. When invoking the system, the following invocation arguments may be passed: +``` + -d Dump memory to standard out at end of run (copious!); + -h Print this message and exit; + -p Show a prompt (default is no prompt); + -s LIMIT + Set a limit to the depth the stack can extend to; + -v LEVEL + Set verbosity to the specified level (0...1024) + Where bits are interpreted as follows: + 1 ALLOC; + 2 ARITH; + 4 BIND; + 8 BOOTSTRAP; + 16 EVAL; + 32 INPUT/OUTPUT; + 64 LAMBDA; + 128 REPL; + 256 STACK; + 512 EQUAL. +``` + +Note that any verbosity level produces a great deal of output, and although standardising the output to make it more legible is something I'm continually working on, it's still hard to read the output. It is printed to stderr, so can be redirected to a file for later analysis, which is the best plan. + +### Functions and symbols + +The following functions are provided as of release 0.0.6: + +| Symbol | Type | Documentation | +| ------ | ---- | ------------- | +| `*` | FUNC | `(* args...)` Multiplies these `args`, all of which should be numbers, and return the product. | +| `*in*` | READ | The standard input stream. | +| `*log*` | WRIT | The standard logging stream (stderr). | +| `*out*` | WRIT | The standard output stream. | +| + | FUNC | `(+ args...)`: If `args` are all numbers, returns the sum of those numbers. | +| - | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. | +| / | FUNC | `(/ a b)`: Divides `a` by `b` and returns the result. Expects both arguments to be numbers. | +| = | FUNC | `(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`. | +| absolute | FUNC | `(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`. | +| add | FUNC | `(+ args...)`: If `args` are all numbers, return the sum of those numbers. | +| and | FUNC | `(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`. | +| append | FUNC | `(append args...)`: If `args` are all sequences, return the concatenation of those sequences. | +| apply | FUNC | `(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value. | +| assoc | FUNC | `(assoc key store)`: Return the value associated with this `key` in this `store`. | +| car | FUNC | `(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence. | +| cdr | FUNC | `(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed. | +| close | FUNC | `(close stream)`: If `stream` is a stream, close that stream. | +| cond | SPFM | `(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated. | +| cons | FUNC | `(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`. | +| count | FUNC | `(count s)`: Return the number of items in the sequence `s`. | +| divide | FUNC | `(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`. | +| eq? | FUNC | `(eq? args...)`: Return `t` if all args are the exact same object, else `nil`. | +| equal? | FUNC | `(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`. | +| eval | FUNC | `(eval form)`: Evaluates `form` and returns the result. | +| exception | FUNC | `(exception message)`: Return (throw) an exception with this `message`. | +| get-hash | FUNC | `(get-hash arg)`: Returns the natural number hash value of `arg`. This is the default hash function used by hashmaps and namespaces, but obviously others can be supplied. | +| hashmap | FUNC | `(hashmap n-buckets hashfn store write-acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`, and protected by the write access control list `write-acl`. All arguments are optional. The intended difference between a namespace and a hashmap is that a namespace has a write acl and a hashmap doesn't (is not writable), but currently (0.0.6) this functionality is not yet written. | +| inspect | FUNC | `(inspect object ouput-stream)`: Print details of this `object` to this `output-stream`, or `*out*` if no `output-stream` is specified. | +| keys | FUNC | `(keys store)`: Return a list of all keys in this `store`. | +| lambda | SPFM | `(lambda arg-list forms...)`: Construct an interpretable λ funtion. | +| let | SPFM | `(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last. | +| list | FUNC | `(list args...)`: Return a list of these `args`. | +| mapcar | FUNC | `(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results. | +| meta | FUNC | `(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`. | +| metadata | FUNC | `(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`. | +| multiply | FUNC | `(multiply args...)` Multiply these `args`, all of which should be numbers, and return the product. | +| negative? | FUNC | `(negative? n)`: Return `t` if `n` is a negative number, else `nil`. | +| nlambda | SPFM | `(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated. | +| not | FUNC | `(not arg)`: Return `t` only if `arg` is `nil`, else `nil`. | +| nλ | SPFM | `(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated. | +| oblist | FUNC | `(oblist)`: Return the current top-level symbol bindings, as a map. | +| open | FUNC | `(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading. | +| or | FUNC | `(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`. | +| print | FUNC | `(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`. | +| progn | SPFM | `(progn forms...)`: Evaluate these `forms` sequentially, and return the value of the last. | +| put! | FUNC | `(put! store key value)`: Stores a value in a namespace; currently (0.0.6), also stores a value in a hashmap, but in future if the `store` is a hashmap then `put!` will return a clone of that hashmap with this `key value` pair added. Expects `store` to be a hashmap or namespace; `key` to be a symbol or a keyword; `value` to be any value. | +| put-all! | FUNC | `(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`. At present (0.0.6) it does this for hashmaps as well, but in future if `dest` is a hashmap or a namespace which the user does not have permission to write, will return a copy of `dest` with all the key-value pairs from `source` added. `dest` must be a hashmap or a namespace; `source` may be either of those or an association list. | +| quote | SPFM | `(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`. | +| ratio->real | FUNC | `(ratio->real r)`: If `r` is a rational number, return the real number equivalent. | +| read | FUNC | `(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. | +| read-char | FUNC | `(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. | +| repl | FUNC | `(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional. If `prompt` is present, it will be used as the prompt. If `input` is present and is a readable stream, takes input from that stream. If `output` is present and is a writable stream, prints output to that stream. | +| reverse | FUNC | `(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order. | +| set | FUNC | `(set symbol value namespace)`: Binds the value `symbol` in the specified `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. | +| set! | SPFM | `(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. | +| slurp | FUNC | `(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string. | +| source | FUNC | `(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil. Once we get a compiler working, will also return the source code of compiled functions and special forms. | +| subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. | +| throw | FUNC | `(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).| +| time | FUNC | `(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch. | +| try | SPFM | `(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these. | +| type | FUNC | `(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change. | +| λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ function. | + +## Known bugs + +The following bugs are known in 0.0.6: + +1. bignum arithmetic does not work (returns wrong answers, does not throw exception); +2. subtraction of ratios is broken (returns wrong answers, does not throw exception); +3. equality of hashmaps is broken (returns wrong answers, does not throw exception); +4. The garbage collector doesn't work at all well. + +There are certainly very many unknown bugs. + + diff --git a/docs/Home.md b/docs/Home.md index be2fad6..b27a276 100644 --- a/docs/Home.md +++ b/docs/Home.md @@ -1,6 +1,6 @@ # Post Scarcity Software Environment: general documentation -Work towards the implementation of a software system like that described in [Post Scarcity Software](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/). +Work towards the implementation of a software system for the hardware of the deep future. ## Note on canonicity @@ -172,7 +172,7 @@ The following functions are provided as of release 0.0.6: | subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. | | throw | FUNC | `(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).| | time | FUNC | `(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch. | -| try | SPFM | `(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these. | +| try | SPFM | `(try forms... (catch symbol forms...))`: Doesn't work yet! | | type | FUNC | `(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change. | | λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ function. | diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 55d9bab..393f1aa 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,36 @@ # State of Play +## 20260326 + +Most of the memory architecture of the new prototype is now roughed out, but +in C, not in a more modern language. It doesn't compile yet. + +My C is getting better... but it needed to! + +## 20260323 + +I started an investigastion of the [Zig language](https://ziglang.org/) and +come away frustrated. It's definitely an interesting language, and *I think* +one capable of doing what I want. But in trying to learn, I checked out +someone else's [Lisp interpreter in Zig](https://github.com/cryptocode/bio). +The last commit to this project is six months ago, so fairly current; project +documentation is polished, implying the project is well advanced and by someone +competent. + +It won't build. + +It won't build because there are breaking changes to the build system in the +current version of Zig, and, according to helpful people on the Zig language +Discord, breaking changes in Zig versions are quite frequent. + +Post-scarcity is a project which procedes slowly, and is very large indeed. I +will certainly not complete it before I die. + +I don't feel unstable tools are a good choice. + +I have, however, done more thinking about [Paged space objects], and think I +now have a buildable specification. + ## 20260319 Right, the `member?` bug [is fixed](https://git.journeyman.cc/simon/post-scarcity/issues/11). From 1afb1b9fad9a28e5cc8d3cf5b0bdad93457054f8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2026 11:56:36 +0000 Subject: [PATCH 14/29] Added work on making namespaces threadsafe. --- Doxyfile | 2 +- docs/Nodes-threads-locks-links.md | 141 ++++++++++++++++++ src/c/debug.c | 118 ++++++++++++++- src/c/debug.h | 8 + src/c/memory/header.h | 6 +- src/c/memory/memory.c | 18 ++- src/c/memory/memory.h | 15 +- src/c/memory/node.c | 31 ++-- src/c/memory/page.c | 102 ++++++++++++- src/c/memory/page.h | 47 +++--- src/c/memory/pointer.c | 47 ++++++ src/c/memory/pointer.h | 2 + src/c/memory/pso.c | 47 ++++++ src/c/memory/pso.h | 240 ++++++++++++++++++++++++++++++ src/c/memory/pso2.h | 53 ------- src/c/memory/pso3.h | 35 ----- src/c/memory/pso4.h | 32 ---- src/c/memory/pso5.h | 30 ---- src/c/memory/pso6.h | 30 ---- src/c/memory/pso7.h | 30 ---- src/c/memory/pso8.h | 30 ---- src/c/memory/pso9.h | 30 ---- src/c/memory/psoa.h | 30 ---- src/c/memory/psob.h | 30 ---- src/c/memory/psoc.h | 30 ---- src/c/memory/psod.h | 30 ---- src/c/memory/psoe.h | 30 ---- src/c/memory/psof.h | 30 ---- src/c/ops/eq.c | 8 +- src/c/ops/eq.h | 8 +- src/c/ops/eval.c | 16 +- src/c/ops/truth.c | 94 ++++++++++++ src/c/ops/truth.h | 33 ++++ src/c/payloads/hashtable.h | 40 +++++ src/c/payloads/mutex.h | 66 ++++++++ src/c/payloads/namespace.h | 42 ++++++ src/c/psse.c | 8 +- src/c/psse.h | 2 +- 38 files changed, 1074 insertions(+), 517 deletions(-) create mode 100644 docs/Nodes-threads-locks-links.md create mode 100644 src/c/memory/pointer.c create mode 100644 src/c/memory/pso.c create mode 100644 src/c/memory/pso.h delete mode 100644 src/c/memory/pso2.h delete mode 100644 src/c/memory/pso3.h delete mode 100644 src/c/memory/pso4.h delete mode 100644 src/c/memory/pso5.h delete mode 100644 src/c/memory/pso6.h delete mode 100644 src/c/memory/pso7.h delete mode 100644 src/c/memory/pso8.h delete mode 100644 src/c/memory/pso9.h delete mode 100644 src/c/memory/psoa.h delete mode 100644 src/c/memory/psob.h delete mode 100644 src/c/memory/psoc.h delete mode 100644 src/c/memory/psod.h delete mode 100644 src/c/memory/psoe.h delete mode 100644 src/c/memory/psof.h create mode 100644 src/c/ops/truth.c create mode 100644 src/c/ops/truth.h create mode 100644 src/c/payloads/hashtable.h create mode 100644 src/c/payloads/mutex.h create mode 100644 src/c/payloads/namespace.h diff --git a/Doxyfile b/Doxyfile index c608536..bb8427d 100644 --- a/Doxyfile +++ b/Doxyfile @@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = doxy.log +WARN_LOGFILE = tmp/doxy.log #--------------------------------------------------------------------------- # Configuration options related to the input files diff --git a/docs/Nodes-threads-locks-links.md b/docs/Nodes-threads-locks-links.md new file mode 100644 index 0000000..1f2a9dd --- /dev/null +++ b/docs/Nodes-threads-locks-links.md @@ -0,0 +1,141 @@ +# Nodes, threads, locks and links + +## The problem + +Up to now, I've been building a single threaded Lisp. I haven't had to worry about who is mutating memory while I'm trying to read it. The idea that this is a mostly immutable Lisp has encouraged me to be blasé about this. But actually, it isn't entirely immutable, and that matters. + +Whenever *any* new datum is created, the freelist pointers have to mutate; whenever any new value is written to any namespace, the namespace has to mutate. The freelist pointers also mutate when objects are allocated and when objects are freed. + +Earlier in the design, I had the idea that in the hypercube system, each node would have a two core processor, one core doing execution — actually evaluating Lisp functions — the other handling inter-node communication. I had at one stage the idea that the memory on the node would be partitioned into fixed areas: + +| Partition | Contents | Core written by | +| --------- | -------- | --------------- | +| Local cons space | Small objects curated locally | Execution | +| Local vector space | Large objects curated locally | Excecution | +| Cache cons space | Copies of small objects curated elsewhere | Communications | +| Cache vector space | Copies of large objects curated elsewhere | Communications | + +So, the execution thread is chuntering merrily along, and it encounters a data item it needs to get from another node. This is intended to happen all the time: every time a function of more than one argument is evaluated, the node will seek to farm out some of the arguments to idle neighbours for evaluation. So the results will often be curated by them. My original vague idea was that the execution node would choose the argument which seemed most costly to evaluate to evaluate locally, pass off the others to neighbours, evaluate the hard one, and by the time that was done probably all the farmed out results would already be back. + +The move from cons space objects to the more flexible [paged space objects](Paged-space-objects.md) doesn't really change this, in principle. There will still be a need for some objects which do not fit into pages, and will thus have to lurk in the outer darkness of vector space. Paged space should make the allocation of objects more efficient, but it doesn't change the fundamental issue + +But there's an inevitable overhead to copying objects over inter-node links. Even if we have 64 bit (plus housekeeping) wide links, copying a four word object still takes four clock ticks. Of course, in the best case, we could be receiving six four word objects over the six links in those four clock ticks, but + +1. The best case only applies to the node initiating a computation; +2. This ignores contention on the communication mesh consequent on hoppity-hop communications between more distant nodes. + +So, even if the execution core correctly chose the most expensive argument to evaluate locally, it's quite likely that when it returns to the stack frame, some results from other nodes have still not arrived. What does it do then? Twiddle its thumbs? + +It could start another thread, declare itself idle, accept a work request from a neighbour, execute that, and return to the frame to see whether its original task was ready to continue. One of the benefits of having the stack in managed space is that a single stack frame can have arbitrarily many 'next' frames, in arbitrarily many threads. This is exactly how [Interlisp](https://dl.acm.org/doi/10.1145/362375.362379) manages multitasking, after all. + +If we do it like that I think we're still safe, because it can't have left any data item in a half-modified state when it switched contexts. + +But nevertheless, we still have the issue of contention between the execution process and the communications process. They both need to be able to mutate freelist pointers; and they both need to be able to mutate explicitly mutable objects, which for the present is just namespaces but this will change. + +We can work around the freelist problem by assigning separate freelists for each size of paged-space objects to each processor, that's just sixteen more words. But if a foreign node wants to change a value in a local namespace, then the communications process needs to be able to make that change. + +Which means we have to be able to lock objects. Which is something I didn't want to have to do. + +## Mutexes + +It's part of the underlying philosophy of the post scarcity project that one person can't be expert in every part of the stack. I don't fully understand the subtleties of thread safe locking. In my initial draft of this essay, I was planning to reserve one bit in the tag of an object as a thread lock. + +There is a well respected standard thread locking library, [`pthreads`](https://www.cs.cmu.edu/afs/cs/academic/class/15492-f07/www/pthreads.html), part of the [POSIX](https://en.wikipedia.org/wiki/POSIX) standard, which implements thread locks. The lock object it implements is called a `mutex` ('mutual exclusion'), and the size of a `mutex` is... complicated. It is declared as a union: + +```c +typedef union +{ + struct __pthread_mutex_s __data; + char __size[__SIZEOF_PTHREAD_MUTEX_T]; + long int __align; +} pthread_mutex_t; + +``` + +I guessed that the `long int __align` member was intended as a contract that this would be *no bigger* than a `long int`, but `long int` may mean 32 or 64 bits depending on context. The payload is clearly `__pthread_mutex_s`; so how big is that? Answer: it varies, dependent on the hardware architecture. But `__SIZEOF_PTHREAD_MUTEX_T` also varies dependent on architecture, and is defined as 40 *bytes* on 64 bit Intel machines: + +```c +#ifdef __x86_64__ +# if __WORDSIZE == 64 +# define __SIZEOF_PTHREAD_MUTEX_T 40 +... +``` + +The header file I have access to declares that for 32 bit Intel machines it's 32 bytes and for all non-Intel machines the size is only 24 bytes, but + +1. the machines I'm working on are actually AMD, but x86 64 bit Intel architecture; and +2. I don't currently have a 64 bit ARM version of this library, and ARM is quite likely to be the architecture I would use for a hardware implementation; + +So let's be cautious. + +Let's also be realistic: what I'm building now is the 0.1.0 prototype, which is not planned to run on even a simulated hypercube, so it doesn't need to have locks at all. I am crossing a bridge I do not yet strictly need to cross. + +## Where to put the lock? + +Currently, we have namespaces implemented as hashtables (or hashmaps, if you prefer, but I appreciate that it's old fashioned). We have hashtables implemented as an array of buckets. We have buckets implemented, currently, as association lists (lists of dotted pairs), although they could later be implemented as further hashtables. We can always cons a new `(key . value)` pair onto the front of an association list; the fact that there may be a different binding of the same key further down the association list doesn't matter, except in so far as it slows further searches down that association list. + +Changing the pointer to the bucket happens in one clock tick: we're writing one 64 bit word to memory over a 64 bit wide address bus. The replacement bucket can — must! — be prepared in advance. So changing the bucket is pretty much an atomic operation. + +But the size of a mutex is uncertain, and **must** fit within the footprint of the namespace object. + +Forty bytes is (on a 64 bit machine) five words; but, more relevantly, our `pso_pointer` object is 64 bits irrespective of hardware architecture, so forty bytes is the size of five (pointers to) buckets. This means that namespaces are no longer 'the same' as hashtables; hashtables can accommodate (at least) five more buckets within a given [paged space object](Paged-space-objects.md) size. But obviously we can — the whole paged space objects architecture is predicated on ensuring that we can — accommodate any moderately sized fixed size datum into a paged space object, so we can accommodate a mutex into the footprint of a namespace object. + +Oh, but wait. + +Oh, but wait, here's a more beautiful idea. + +### First class mutexes + +We can make the mutex a first class object in paged space in its own right. + +This has a number of advantages: + +1. the space we need to reserve in the namespace object is just a pointer like any other pointer, and is not implementation dependent; +2. we can change the implementation of the mutex object, if we need to do so when changing architecture, without changing the implementation of anything which relies on a mutex; +3. mutexes then become available as ordinary objects in the Lisp system, to be used by any Lisp functions which need to do thread-safe locking. + +So we need a new Lisp function, + +```lisp +(with-lock mutex forms...) +``` + +which, when called + +1. waits until it can lock the specified mutex; +2. evaluates each of the forms sequentially in the context of that locked mutex; +3. if evaluation of any of the forms results in the throwing of an exception, catches the exception, unlocks the mutex, and then re-throws the exception; +4. on successful completion of the evaluation of the forms, unlocks the mutex and returns the value of the last form. + +This means that I *could* write the bootstrap layer namespace handling code non-thread-safe, and then reimplement it for the user layer in Lisp, thread-safe. But it also means that users could write thread safe handlers for any new types of mutable object they need to define. + +### Other types + +We don't currently have any other mutable objects, but in future at least lazy objects will be mutable; we may have other things that are mutable. It doesn't seem silly to have a single consistent way to store locks, even if it will only be used in the case of a small minority of objects. + +## Procedure for using the lock + +### Reading namespaces + +Secondly, reading from a namespace does not happen in a single clock tick, it takes quite a long time. So it's no good setting a lock bit on the namespace object itself and then immediately assuming that it's now mutable. A reading process could already have started, and be proceeding. + +So what I think is, that we have a single top level function, `(::substrate:search-store key store return-key?)` (which we already sort of have in the 0.0.6 prototype, [here](https://www.journeyman.cc/post-scarcity/doc/html/intern_8c.html#a2189c0ab60e57a70adeb32aca99dbc43)). This searches a store (hashmap, namespace, association list, or hybrid association list) to find a binding for a key, and, having found that binding, then, if there is a namespace on the search path, checks whether the lock on the any namespace on the search path is set, and it it is, aborts the search and tries again; but otherwise returns either the key found (if `return-key?` is non-`nil`), or the value found otherwise. + +This function implements the user-level Lisp functions `assoc`, `interned`, and `interned?`. It also implements *hashmap-in-function-position* and *keyword-in-function-position*, in so far as both of these are treated as calls to `assoc`. + +### Writing namespaces + +When writing to a namespace, top level function [`(::substrate:set key value store)`](https://www.journeyman.cc/post-scarcity/doc/html/intern_8c.html#af8e370c233928d41c268874a6aa5d9e2), we first try to acquire the lock on the namespace. If it is not available, we pause a short time, and try again. It it is clear, we lock it, then identify the right bucket, then cons the new `(key . value)` pair onto the front of the bucket[^1], then update the bucket pointer, and finally unlock the lock. + +This function implements the user-level Lisp functions `set` and `set!`. + +### Allocating/deallocating objects + +When allocating a new object from a freelist... Actually, a lock on the tag of the `car` of the freelist doesn't work here. The lock has to be somewhere else. We could have a single lock for all freelists; that feels like a bad idea because it means e.g. that you can't allocate stack frames while allocating cons cells, and you're bound to get in a mess there. But actually, allocating and deallocating objects of size class 2 — cons cells, integers, other numbers, links in strings, many other small things — is going to be happening all the time, so I'm not sure that it makes much difference. Most of the contention is going to be in size class 2. Nevertheless, one lock per size class is probably not a bad idea, and doesn't take up much space. + +So: one lock per freelist. + +When allocating *or deallocating* objects, we first try to obtain the lock for the freelist. If it is already locked, wait and try again. If it is clear, lock it, make the necessary change to the freelist, then unlock it. + +[^1]: We probably remove any older bindings of the same key from the bucket at this point, too, because it will speed later searches, but this is not critical. + diff --git a/src/c/debug.c b/src/c/debug.c index 2bd417d..9145a66 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -10,7 +10,119 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #include "debug.h" +#include "debug.h" - int verbosity = 0; - \ No newline at end of file +int verbosity = 0; + + +/** + * @brief print this debug `message` to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + * + * NOTE THAT: contrary to behaviour in the 0.0.X prototypes, a line feed is + * always printed before a debug_print message. Hopefully this will result + * in clearer formatting. + * + * @param message The message to be printed, in *wide* (32 bit) characters. + * @param level a mask for `verbosity`. If a bitwise and of `verbosity` and + * `level` is non-zero, print this `message`, else don't. + * @param indent print `indent` spaces before the message. + */ +void debug_print( wchar_t *message, int level, int indent ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( L"\n", stderr ); + for ( int i = 0; i < indent; i++ ) { + fputws( L" ", stderr ); + } + fputws( message, stderr ); + } +#endif +} + +/** + * @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + * + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + * + * @param n the large integer to print. + * @param level a mask for `verbosity`. If a bitwise and of `verbosity` and + * `level` is non-zero, print this `message`, else don't. + */ +void debug_print_128bit( __int128_t n, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf( stderr, L"%s", s ); + } + } +#endif +} + +/** + * @brief print a line feed to stderr, if `verbosity` matches `level`. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + * + * @param level a mask for `verbosity`. If a bitwise and of `verbosity` and + * `level` is non-zero, print this `message`, else don't. + */ +void debug_println( int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( L"\n", stderr ); + } +#endif +} + + +/** + * @brief `wprintf` adapted for the debug logging system. + * + * Print to stderr only if `verbosity` matches `level`. All other arguments + * as for `wprintf`. + * + * @param level a mask for `verbosity`. If a bitwise and of `verbosity` and + * `level` is non-zero, print this `message`, else don't. + * @param indent print `indent` spaces before the message. + * @param format Format string in *wide characters*, but otherwise as used by + * `printf` and friends. + * + * Remaining arguments should match the slots in the format string. + */ +void debug_printf( int level, int indent, wchar_t *format, ... ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( L"\n", stderr ); + for ( int i = 0; i < indent; i++ ) { + fputws( L" ", stderr ); + } + va_list( args ); + va_start( args, format ); + vfwprintf( stderr, format, args ); + } +#endif +} + +// debug_dump_object, debug_print_binding, debug_print_exception, debug_print_object, +// not yet implemented but probably will be. \ No newline at end of file diff --git a/src/c/debug.h b/src/c/debug.h index deb4487..c9c2a26 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -93,4 +93,12 @@ */ extern int verbosity; +void debug_print( wchar_t *message, int level, int indent ); + +void debug_print_128bit( __int128_t n, int level ); + +void debug_println( int level ); + +void debug_printf( int level, int indent, wchar_t *format, ... ); + #endif \ No newline at end of file diff --git a/src/c/memory/header.h b/src/c/memory/header.h index ebd101d..71a449f 100644 --- a/src/c/memory/header.h +++ b/src/c/memory/header.h @@ -10,7 +10,7 @@ #ifndef __psse_memory_header_h #define __psse_memory_header_h -#include +#include #define TAGLENGTH 3 @@ -25,8 +25,8 @@ struct pso_header { struct { /** mnemonic for this type; */ char mnemonic[TAGLENGTH]; - /** sizetag for this object */ - uint8_t sizetag; + /** size class for this object */ + uint8_t size_class; } tag; /** the tag considered as a number */ uint32_t value; diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 4a365e3..d3dbe24 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -9,11 +9,19 @@ #include -#include "memory/pointer.h" +/** + * @brief Freelists for each size class. + * + * TODO: I don't know if that +1 is needed, my mind gets confused by arrays + * indexed from zero. But it does little harm. + */ +struct pso_pointer freelists[MAX_SIZE_CLASS + 1]; +int initialise_memory( int node ) { + fprintf( stderr, "TODO: Implement initialise_memory()" ); -int initialise_memory( int node) { - fprintf( stderr, "TODO: Implement initialise_memory()"); - - } \ No newline at end of file + for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { + freelists[i] = nil;S + } +} diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index 37bd39c..49f45e2 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -10,10 +10,19 @@ #ifndef __psse_memory_memory_h #define __psse_memory_memory_h -#include "memory/pointer.h" +/** + * @brief Maximum size class + * + * Size classes are poweres of 2, in words; so an object of size class 2 + * has an allocation size of four words; of size class 3, of eight words, + * and so on. Size classes of 0 and 1 do not work for managed objects, + * since managed objects require a two word header; it's unlikely that + * these undersized size classes will be used at all. + */ +#define MAX_SIZE_CLASS = 0xf -int initialise_memory(); +int initialise_memory( ); extern struct pso_pointer out_of_memory_exception; - +extern struct pso_pointer freelists[]; #endif diff --git a/src/c/memory/node.c b/src/c/memory/node.c index efbb9d4..81f6aea 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -8,8 +8,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "memory/memory.h" -#include "memory/pointer.h" +#include "node.h" + +#include + +#include "ops/equal.h" +#include "memory.h" +#include "pointer.h" /** * @brief Flag to prevent the node being initialised more than once. @@ -20,6 +25,9 @@ bool node_initialised = false; /** * @brief The index of this node in the hypercube. * + * TODO: once we have a hypercube, this must be set to the correct value + * IMMEDIATELY on startup, before starting to initalise any other part of + * the Lisp system. */ uint32_t node_index = 0; @@ -27,28 +35,29 @@ uint32_t node_index = 0; * @brief The canonical `nil` pointer * */ -struct pso_pointer nil = struct pso_pointer{ 0, 0, 0}; +struct pso_pointer nil = struct pso_pointer { 0, 0, 0 }; /** * @brief the canonical `t` (true) pointer. * */ -struct pso_pointer t = struct pso_pointer{ 0, 0, 1}; +struct pso_pointer t = struct pso_pointer { 0, 0, 1 }; /** - * @brief Set up the basic informetion about this node + * @brief Set up the basic informetion about this node. * * @param index * @return struct pso_pointer */ -struct pso_pointer initialise_node( uint32_t index) { +struct pso_pointer initialise_node( uint32_t index ) { node_index = index; - nil = pso_pointer{ index, 0, 0}; - t = pso_pointer( index, 0, 1); - pso_pointer result = initialise_memory(index); + nil = pso_pointer { index, 0, 0}; + t = pso_pointer( index, 0, 1 ); - if ( eq( result, t)) { - result = initialise_environment(); + pso_pointer result = initialise_memory( index ); + + if ( eq( result, t ) ) { + result = initialise_environment( index ); } return result; diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 4b9fe0f..3d5643c 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -7,8 +7,11 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include +#include "memory/memory.h" +#include "memory/node.h" #include "memory/page.h" #include "memory/pso2.h" #include "memory/pso3.h" @@ -24,13 +27,104 @@ #include "memory/psod.h" #include "memory/psoe.h" #include "memory/psof.h" +#include "payloads/free.h" -void * malloc_page( uint8_t size_class) { - void * result = malloc( sizeof( page)); +/** + * @brief The pages which have so far been initialised. + * + * TODO: This is temporary. We cannot afford to allocate an array big enough + * to hold the number of pages we *might* create at start up time. We need a + * way to grow the number of pages, while keeping access to them cheap. + */ +struct page * pages[NPAGES]; - if (result != NULL) { +/** + * @brief the number of pages which have thus far been allocated. + * + */ +uint32_t npages_allocated = 0 +struct cons_pointer initialise_page( struct page * result, uint16_t page_index, uint8_t size_class, pso_pointer freelist) { + struct cons_pointer result = freelist; + int obj_size = pow(2, size_class); + int obj_bytes = obj_size * sizeof(uint64_t); + int objs_in_page = PAGE_BYTES/obj_bytes; + + for (int i = objs_in_page - 1; i >= 0; i--) { + // it should be safe to cast any pso object to a pso2 + struct pso2* object = (pso2 *)(result + (i * obj_bytes)); + + object->header.tag.size_class = size_class; + strncpy( (char *)(object->header.tag.mnemonic), FREETAG, TAGLENGTH); + object->payload.free.next = result; + + result = make_pointer( node_index, page_index, (uint16_t)( i * obj_size)); } return result; -} \ No newline at end of file +} + +/** + * @brief Allocate a page for objects of this size class, initialise it, and + * link the objects in it into the freelist for this size class. + * + * Because we can't return an exception at this low level, and because there + * are multiple possible causes of failure, for the present this function will + * print errors to stderr. We cast the error stream to wide, since we've + * probably (but not certainly) already cast it to wide, and we can't reliably + * cast it back. + * + * @param size_class an integer in the range 0...MAX_SIZE_CLASS. + * @return a pointer to the page, or NULL if an error occurred. + */ +void *allocate_page( uint8_t size_class ) { + void *result = NULL; + + if ( npages_allocated == 0) { + for (int i = 0; i < NPAGES; i++) { + pages[i] = NULL; + } + debug_print( L"Pages array zeroed.\n", DEBUG_ALLOC, 0); + } + + if ( npages_allocated < NPAGES) { + if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { + result = malloc( sizeof( page ) ); + + if ( result != NULL ) { + memset( result, 0, sizeof( page ) ); + pages[ npages_allocated] = result; + debug_printf( DEBUG_ALLOC, 0, + L"Allocated page %d for objects of size class %x.\n", + npages_allocated, size_class); + + freelists[size_class] = + initialise_page( result, npages_allocated, size_class, freelists[size_class] ); + + debug_printf( DEBUG_ALLOC, 0, + L"Initialised page %d; freelist for size class %x updated.\n", + npages_allocated, + size_class); + + npages_allocated ++; + } else { + fwide( stderr, 1 ); + fwprintf( stderr, + L"\nCannot allocate page: heap exhausted,\n", + size_class, MAX_SIZE_CLASS ); + } + } else { + fwide( stderr, 1 ); + fwprintf( stderr, + L"\nCannot allocate page for size class %x, min is 2 max is %x.\n", + size_class, MAX_SIZE_CLASS ); + } + } else { + fwide( stderr, 1 ); + fwprintf( stderr, + L"\nCannot allocate page: page space exhausted.\n", + size_class, MAX_SIZE_CLASS ); + } + + return result; +} diff --git a/src/c/memory/page.h b/src/c/memory/page.h index c4e1fe8..522b2fa 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -25,7 +25,20 @@ #include "memory/psoe.h" #include "memory/psof.h" -#define PAGE_SIZE 1048576 +/** + * the size of a page, **in bytes**. + */ +#define PAGE_BYTES 1048576 + +/** + * the number of pages we will initially allow for. For + * convenience we'll set up an array of cons pages this big; however, + * TODO: later we will want a mechanism for this to be able to grow + * dynamically to the maximum we can allow. + */ +#define NPAGES 64 + +extern struct page *pages[NPAGES]; /** * @brief A page is a megabyte of memory which contains objects all of which @@ -40,22 +53,22 @@ * collection they will be returned to that freelist. */ union page { - uint8_t[PAGE_SIZE] bytes; - uint64_t[PAGE_SIZE / 8] words; - struct pso2[PAGE_SIZE / 32] pso2s; - struct pso3[PAGE_SIZE / 64] pso3s; - struct pso4[PAGE_SIZE / 128] pso4s; - struct pso5[PAGE_SIZE / 256] pso5s; - struct pso6[PAGE_SIZE / 512] pso6s; - struct pso7[PAGE_SIZE / 1024] pso7s; - struct pso8[PAGE_SIZE / 2048] pso8s; - struct pso9[PAGE_SIZE / 4096] pso9s; - struct psoa[PAGE_SIZE / 8192] psoas; - struct psob[PAGE_SIZE / 16384] psobs; - struct psoc[PAGE_SIZE / 32768] psocs; - struct psod[PAGE_SIZE / 65536] psods; - struct psoe[PAGE_SIZE / 131072] psoes; - struct psof[PAGE_SIZE / 262144] psofs; + uint8_t[PAGE_BYTES] bytes; + uint64_t[PAGE_BYTES / 8] words; + struct pso2[PAGE_BYTES / 32] pso2s; + struct pso3[PAGE_BYTES / 64] pso3s; + struct pso4[PAGE_BYTES / 128] pso4s; + struct pso5[PAGE_BYTES / 256] pso5s; + struct pso6[PAGE_BYTES / 512] pso6s; + struct pso7[PAGE_BYTES / 1024] pso7s; + struct pso8[PAGE_BYTES / 2048] pso8s; + struct pso9[PAGE_BYTES / 4096] pso9s; + struct psoa[PAGE_BYTES / 8192] psoas; + struct psob[PAGE_BYTES / 16384] psobs; + struct psoc[PAGE_BYTES / 32768] psocs; + struct psod[PAGE_BYTES / 65536] psods; + struct psoe[PAGE_BYTES / 131072] psoes; + struct psof[PAGE_BYTES / 262144] psofs; }; #endif diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c new file mode 100644 index 0000000..8a47439 --- /dev/null +++ b/src/c/memory/pointer.c @@ -0,0 +1,47 @@ +/** + * memory/pointer.h + * + * A pointer to a paged space object. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" + +/** + * @brief Make a pointer to a paged-space object. + * + * @param node The index of the node on which the object is curated; + * @param page The memory page in which the object resides; + * @param offset The offset, in words, within that page, of the object. + * @return struct pso_pointer a pointer referencing the specified object. + */ +struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset) { + return struct pso_pointer{ node, page, pointer}; +} + +/** + * @brief returns the in-memory address of the object indicated by this + * pointer. TODO: Yhe reason I'm doing it this way is because I'm not + * certain reference counter updates work right it we work with 'the object' + * rather than 'the address of the object'. I really ought to have a + * conversation with someone who understands this bloody language. + * + * @param pointer a pso_pointer which references an object. + * @return struct pso2* the actual address in memory of that object. + */ +struct pso2* pointer_to_object( struct pso_pointer pointer) { + struct pso2* result = NULL; + + if ( pointer.node == node_index) { + result = (struct pso2*) &(pages[pointer.node] + (pointer.offset * sizeof( uint64_t))); + } + // TODO: else if we have a copy of the object in cache, return that; + // else request a copy of the object from the node which curates it. + + return result; +} + \ No newline at end of file diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index 18c3aa9..fad04cd 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -38,4 +38,6 @@ struct pso_pointer { uint16_t offset; }; +struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset); + #endif diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c new file mode 100644 index 0000000..2914700 --- /dev/null +++ b/src/c/memory/pso.c @@ -0,0 +1,47 @@ +/** + * memory/pso.c + * + * Paged space objects. + * + * Broadly, it should be save to cast any paged space object to a pso2, since + * that is the smallest actually used size class. This should work to extract + * the tag and size class fields from the header, for example. I'm not + * confident enough of my understanding of C to know whether it is similarly + * safe to cast something passed to you as a pso2 up to something larger, even + * if you know from the size class field that it actually is something larger. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +struct cons_pointer allocate( char* tag, uint8_t size_class) { + struct cons_pointer result = nil; + + if (size_class <= MAX_SIZE_CLASS) { + if ( not( freelists[size_class] ) ) { + result = freelists[size_class]; + struct pso2* object = pointer_to_object( result); + freelists[size_class] = object->payload.free.next; + + strncpy( (char *)(object->header.tag.mnemonic), tag, TAGLENGTH); + + /* the object ought already to have the right size class in its tag + * because it was popped off the freelist for that size class. */ + if ( object->header.tag.size_class != size_class) { + // TODO: return an exception instead? Or warn, set it, and continue? + } + /* the objext ought to have a reference count ot zero, because it's + * on the freelist, but again we should sanity check. */ + if ( object->header.count != 0) { + // TODO: return an exception instead? Or warn, set it, and continue? + } + + } + } // TODO: else throw exception + + return result; +} + +struct cons_pointer get_tag_value( struct cons_pointer pointer) { + result = +} \ No newline at end of file diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h new file mode 100644 index 0000000..90b9d57 --- /dev/null +++ b/src/c/memory/pso.h @@ -0,0 +1,240 @@ +/** + * memory/pso.h + * + * Paged space objects. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso_h +#define __psse_memory_pso_h + +#include + +#include "memory/header.h" +#include "payloads/cons.h" +#include "payloads/free.h" +#include "payloads/function.h" +#include "payloads/integer.h" +#include "payloads/ketwod.h" +#include "payloads/lambda.h" +#include "payloads/mutex.h" +#include "payloads/nlambda.h" +#include "payloads/read_stream.h" +#include "payloads/special.h" +#include "payloads/stack.h" +#include "payloads/string.h" +#include "payloads/symbol.h" +#include "payloads/time.h" +#include "payloads/vector_pointer.h" +#include "payloads/write_stream.h" + +/** + * @brief A paged space object of size class 2, four words total, two words + * payload. + * + */ +struct pso2 { + struct pso_header header; + union { + char[16] bytes; + uint64_t[2] words; + struct cons_payload cons; + struct free_payload free; + struct function_payload function; + struct integer_payload integer; + struct lambda_payload lambda; + struct special_payload special; + struct stream_payload stream; + struct time_payload time; + struct vectorp_payload vectorp; + } payload; +}; + +/** + * @brief A paged space object of size class 3, 8 words total, 6 words + * payload. + * + */ +struct pso3 { + struct pso_header header; + union { + char[48] bytes; + uint64_t[6] words; + struct exception_payload exception; + struct free_payload free; + struct mutex_payload mutex; + } payload; +}; + +/** + * @brief A paged space object of size class 4, 16 words total, 14 words + * payload. + * + */ +struct pso4 { + struct pso_header header; + union { + char[112] bytes; + uint64_t[14] words; + struct free_payload free; + struct stack_frame_payload stack_frame; + } payload; +}; + +/** + * @brief A paged space object of size class 5, 32 words total, 30 words + * payload. + * + */ +struct pso5 { + struct pso_header header; + union { + char[240] bytes; + uint64_t[30] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class 6, 64 words total, 62 words + * payload. + * + */ +struct pso6 { + struct pso_header header; + union { + char[496] bytes; + uint64_t[62] words; + struct free_payload free; + struct hashtable_payload hashtable; + struct namespace_payload namespace; + } payload; +}; + +/** + * @brief A paged space object of size class 7, 128 words total, 126 words + * payload. + * + */ +struct pso7 { + struct pso_header header; + union { + char[1008] bytes; + uint64_t[126] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class 8, 256 words total, 254 words + * payload. + * + */ +struct pso8 { + struct pso_header header; + union { + char[2032] bytes; + uint64_t[254] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class 9, 512 words total, 510 words + * payload. + * + */ +struct pso9 { + struct pso_header header; + union { + char[4080] bytes; + uint64_t[510] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class a, 1024 words total, 1022 words + * payload. + * + */ +struct psoa { + struct pso_header header; + union { + char[8176] bytes; + uint64_t[1022] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class b, 2048 words total, 2046 words + * payload. + * + */ +struct psob { + struct pso_header header; + union { + char[16368] bytes; + uint64_t[2046] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class c, 4096 words total, 4094 words + * payload. + * + */ +struct psoc { + struct pso_header header; + union { + char[32752] bytes; + uint64_t[4094] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class d, 8192 words total, 8190 words + * payload. + * + */ +struct psod { + struct pso_header header; + union { + char[65520] bytes; + uint64_t[8190] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class e, 16384 words total, 16382 words + * payload. + * + */ +struct psoe { + struct pso_header header; + union { + char[131056] bytes; + uint64_t[16382] words; + struct free_payload free; + } payload; +}; + +/** + * @brief A paged space object of size class f, 32768 words total, 32766 words + * payload. + * + */ +struct psof { + struct pso_header header; + union { + char[262128] bytes; + uint64_t[32766] words; + struct free_payload free; + } payload; +}; diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h deleted file mode 100644 index 86febbc..0000000 --- a/src/c/memory/pso2.h +++ /dev/null @@ -1,53 +0,0 @@ -/** - * memory/pso2.h - * - * Paged space object of size class 2, four words total, two words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso2_h -#define __psse_memory_pso2_h - -#include - -#include "memory/header.h" -#include "payloads/cons.h" -#include "payloads/free.h" -#include "payloads/function.h" -#include "payloads/integer.h" -#include "payloads/ketwod.h" -#include "payloads/lambda.h" -#include "payloads/nlambda.h" -#include "payloads/read_stream.h" -#include "payloads/special.h" -#include "payloads/string.h" -#include "payloads/symbol.h" -#include "payloads/time.h" -#include "payloads/vector_pointer.h" -#include "payloads/write_stream.h" - -/** - * @brief A paged space object of size class 2, four words total, two words - * payload. - * - */ -struct pso2 { - struct pso_header header; - union { - char[16] bytes; - uint64_t[2] words; - struct cons_payload cons; - struct free_payload free; - struct function_payload function; - struct integer_payload integer; - struct lambda_payload lambda; - struct special_payload special; - struct stream_payload stream; - struct time_payload time; - struct vectorp_payload vectorp; - } payload; -}; - -#endif diff --git a/src/c/memory/pso3.h b/src/c/memory/pso3.h deleted file mode 100644 index c3e03ce..0000000 --- a/src/c/memory/pso3.h +++ /dev/null @@ -1,35 +0,0 @@ -/** - * memory/pso3.h - * - * Paged space object of size class 3, 8 words total, 6 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso3_h -#define __psse_memory_pso3_h - -#include - -#include "memory/header.h" -#include "payloads/exception.h" -#include "payloads/free.h" - - -/** - * @brief A paged space object of size class 3, 8 words total, 6 words - * payload. - * - */ -struct pso3 { - struct pso_header header; - union { - char[48] bytes; - uint64_t[6] words; - struct exception_payload exception; - struct free_payload free; - } payload; -}; - -#endif diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h deleted file mode 100644 index 1384d12..0000000 --- a/src/c/memory/pso4.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * memory/pso4.h - * - * Paged space object of size class 4, 16 words total, 14 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso4_h -#define __psse_memory_pso4_h - -#include - -#include "memory/header.h" -#include "memory/stack.h" - -/** - * @brief A paged space object of size class 4, 16 words total, 14 words - * payload. - * - */ -struct pso4 { - struct pso_header header; - union { - char[112] bytes; - uint64_t[14] words; - struct stack_frame_payload stack_frame; - } payload; -}; - -#endif diff --git a/src/c/memory/pso5.h b/src/c/memory/pso5.h deleted file mode 100644 index 311b544..0000000 --- a/src/c/memory/pso5.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/pso5.h - * - * Paged space object of size class 5, 32 words total, 30 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso5_h -#define __psse_memory_pso5_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class 5, 32 words total, 30 words - * payload. - * - */ -struct pso5 { - struct pso_header header; - union { - char[240] bytes; - uint64_t[30] words; - } payload; -}; - -#endif diff --git a/src/c/memory/pso6.h b/src/c/memory/pso6.h deleted file mode 100644 index 8f94393..0000000 --- a/src/c/memory/pso6.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/pso6.h - * - * Paged space object of size class 6, 64 words total, 62 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso6_h -#define __psse_memory_pso6_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class 6, 64 words total, 62 words - * payload. - * - */ -struct pso6 { - struct pso_header header; - union { - char[496] bytes; - uint64_t[62] words; - } payload; -}; - -#endif diff --git a/src/c/memory/pso7.h b/src/c/memory/pso7.h deleted file mode 100644 index 2ef9ad3..0000000 --- a/src/c/memory/pso7.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/pso7.h - * - * Paged space object of size class 7, 128 words total, 126 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso7_h -#define __psse_memory_pso7_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class 7, 128 words total, 126 words - * payload. - * - */ -struct pso7 { - struct pso_header header; - union { - char[1008] bytes; - uint64_t[126] words; - } payload; -}; - -#endif diff --git a/src/c/memory/pso8.h b/src/c/memory/pso8.h deleted file mode 100644 index c46a2c1..0000000 --- a/src/c/memory/pso8.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/pso8.h - * - * Paged space object of size class 8, 256 words total, 254 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso8_h -#define __psse_memory_pso8_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class 8, 256 words total, 254 words - * payload. - * - */ -struct pso8 { - struct pso_header header; - union { - char[2032] bytes; - uint64_t[254] words; - } payload; -}; - -#endif diff --git a/src/c/memory/pso9.h b/src/c/memory/pso9.h deleted file mode 100644 index 4d07231..0000000 --- a/src/c/memory/pso9.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/pso9.h - * - * Paged space object of size class 9, 512 words total, 510 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_pso9_h -#define __psse_memory_pso9_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class 9, 512 words total, 510 words - * payload. - * - */ -struct pso9 { - struct pso_header header; - union { - char[4080] bytes; - uint64_t[510] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psoa.h b/src/c/memory/psoa.h deleted file mode 100644 index a7d7d19..0000000 --- a/src/c/memory/psoa.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psoa.h - * - * Paged space object of size class a, 1024 words total, 1022 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psoa_h -#define __psse_memory_psoa_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class a, 1024 words total, 1022 words - * payload. - * - */ -struct psoa { - struct pso_header header; - union { - char[8176] bytes; - uint64_t[1022] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psob.h b/src/c/memory/psob.h deleted file mode 100644 index 24a9fa2..0000000 --- a/src/c/memory/psob.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psob.h - * - * Paged space object of size class b, 2048 words total, 2046 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psob_h -#define __psse_memory_psob_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class b, 2048 words total, 2046 words - * payload. - * - */ -struct psob { - struct pso_header header; - union { - char[16368] bytes; - uint64_t[2046] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psoc.h b/src/c/memory/psoc.h deleted file mode 100644 index 99c2a55..0000000 --- a/src/c/memory/psoc.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psoc.h - * - * Paged space object of size class c, 4096 words total, 4094 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psoc_h -#define __psse_memory_psoc_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class c, 4096 words total, 4094 words - * payload. - * - */ -struct psoc { - struct pso_header header; - union { - char[32752] bytes; - uint64_t[4094] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psod.h b/src/c/memory/psod.h deleted file mode 100644 index 803cf90..0000000 --- a/src/c/memory/psod.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psod.h - * - * Paged space object of size class d, 8192 words total, 8190 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psod_h -#define __psse_memory_psod_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class d, 8192 words total, 8190 words - * payload. - * - */ -struct psod { - struct pso_header header; - union { - char[65520] bytes; - uint64_t[8190] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psoe.h b/src/c/memory/psoe.h deleted file mode 100644 index d0313f7..0000000 --- a/src/c/memory/psoe.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psoe.h - * - * Paged space object of size class e, 16384 words total, 16382 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psoe_h -#define __psse_memory_psoe_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class e, 16384 words total, 16382 words - * payload. - * - */ -struct psoe { - struct pso_header header; - union { - char[131056] bytes; - uint64_t[16382] words; - } payload; -}; - -#endif diff --git a/src/c/memory/psof.h b/src/c/memory/psof.h deleted file mode 100644 index 30ead84..0000000 --- a/src/c/memory/psof.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * memory/psof.h - * - * Paged space object of size class f, 32768 words total, 32766 words payload. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_memory_psof_h -#define __psse_memory_psof_h - -#include - -#include "memory/header.h" - -/** - * @brief A paged space object of size class f, 32768 words total, 32766 words - * payload. - * - */ -struct psof { - struct pso_header header; - union { - char[262128] bytes; - uint64_t[32766] words; - } payload; -}; - -#endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 0c2e192..d5f7228 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -25,8 +25,8 @@ * @param b another pointer; * @return `true` if they are the same, else `false` */ -bool eq( struct pso_pointer a, struct pso_pointer b) { - return ( a.node == b.node && a.page == b.page && a.offset == b.offset); +bool eq( struct pso_pointer a, struct pso_pointer b ) { + return ( a.node == b.node && a.page == b.page && a.offset == b.offset ); } /** @@ -42,8 +42,8 @@ bool eq( struct pso_pointer a, struct pso_pointer b) { * @return `t` if all args are pointers to the same object, else `nil`; */ struct pso_pointer lisp_eq( struct stack_frame *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { struct pso_pointer result = t; if ( frame->args > 1 ) { diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index febb5af..204c297 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -12,10 +12,10 @@ #ifndef __psse_ops_eq_h #define __psse_ops_eq_h -bool eq( struct pso_pointer a, struct pso_pointer b); +bool eq( struct pso_pointer a, struct pso_pointer b ); struct pso_pointer lisp_eq( struct stack_frame *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer, + struct pso_pointer env ); -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index d76da2b..c5d7a35 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -26,8 +26,9 @@ * @param env the evaluation environment. * @return struct pso_pointer */ -struct pso_pointer eval_despatch( struct stack_frame *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer eval_despatch( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { struct pso_pointer result = frame->arg[0]; // switch ( get_tag_value( result)) { @@ -52,14 +53,15 @@ struct pso_pointer eval_despatch( struct stack_frame *frame, struct pso_pointer return result; } -struct pso_pointer lisp_eval( struct stack_frame *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = eval_despatch( frame, frame_pointer, env); +struct pso_pointer lisp_eval( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = eval_despatch( frame, frame_pointer, env ); - if (exceptionp( result)) { + if ( exceptionp( result ) ) { // todo: if result doesn't have a stack frame, create a new exception wrapping // result with this stack frame. } return result; -} \ No newline at end of file +} diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c new file mode 100644 index 0000000..631f38d --- /dev/null +++ b/src/c/ops/truth.c @@ -0,0 +1,94 @@ +/** + * ops/truth.c + * + * Post Scarcity Software Environment: nil? true? not. + * + * Functions associated with truthiness. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/** + * @brief true if `p` points to `nil`, else false. + * + * Note that every node has its own copy of `t` and `nil`, and each instance of + * each is considered equivalent. So we don't check the node when considering + * whether `nil` really is `nil`, or `t` really is `t`. + * + * @param p a pointer + * @return true if `p` points to `nil`. + * @return false otherwise. + */ +bool nilp( struct pso_pointer p) { + return (p.page == 0 && p.offset = 0); +} + +/** + * @brief Return `true` if `p` points to `nil`, else `false`. + * + * @param p a pointer + * @return true if `p` points to `nil`; + * @return false otherwise. + */ +bool not( struct pso_pointer p) { + return !nilp( p); +} + +/** + * @brief `true` if `p` points to `t`, else `false`. + * + * Note that every node has its own copy of `t` and `nil`, and each instance of + * each is considered equivalent. So we don't check the node when considering + * whether `nil` really is `nil`, or `t` really is `t`. + * + * @param p a pointer + * @return true if `p` points to `t`. + * @return false otherwise. + */ +bool truep( struct pso_pointer p) { + return (p.page == 0 && p.offset = 1); +} + +/** + * @brief return `t` if the first argument in this frame is `nil`, else `t`. + * + * @param frame The current stack frame; + * @param frame_pointer A pointer to the current stack frame; + * @param env the evaluation environment. + * @return `t` if the first argument in this frame is `nil`, else `t` + */ +pso_pointer lisp_nilp( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ){ + return (nilp(frame->arg[0]) ? t : nil); +} + +/** + * @brief return `t` if the first argument in this frame is `t`, else `nil`. + * + * @param frame The current stack frame; + * @param frame_pointer A pointer to the current stack frame; + * @param env the evaluation environment. + * @return `t` if the first argument in this frame is `t`, else `nil`. + */ +pso_pointer lisp_truep( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ){ + return (truep(frame->arg[0]) ? t : nil); +} + +/** + * @brief return `t` if the first argument in this frame is not `nil`, else + * `t`. + * + * @param frame The current stack frame; + * @param frame_pointer A pointer to the current stack frame; + * @param env the evaluation environment. + * @return `t` if the first argument in this frame is not `nil`, else `t`. + */ +pso_pointer lisp_not( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ){ + return (not(frame->arg[0]) ? t : nil); +} \ No newline at end of file diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h new file mode 100644 index 0000000..c59ced9 --- /dev/null +++ b/src/c/ops/truth.h @@ -0,0 +1,33 @@ +/** + * ops/truth.h + * + * Post Scarcity Software Environment: truth functions. + * + * Tests for truth. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_truth_h +#define __psse_ops_truth_h + +bool nilp( struct pso_pointer a, struct pso_pointer b ); + +struct pso_pointer lisp_nilp( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +bool not( struct pso_pointer a, struct pso_pointer b ); + +struct pso_pointer lisp_not( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +bool truep( struct pso_pointer a, struct pso_pointer b ); + +struct pso_pointer lisp_truep( struct stack_frame *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +#endif diff --git a/src/c/payloads/hashtable.h b/src/c/payloads/hashtable.h new file mode 100644 index 0000000..5fcced5 --- /dev/null +++ b/src/c/payloads/hashtable.h @@ -0,0 +1,40 @@ +/** + * payloads/hashtable.h + * + * an ordinary Lisp hashtable - one whose contents are immutable. + * + * Can sensibly sit in any pso from size class 6 upwards. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_hashtable_h +#define __psse_payloads_hashtable_h + +#include "memory/pointer.h" + +/** + * @brief Tag for an ordinary Lisp hashtable - one whose contents are immutable. + * \see NAMESPACETAG for mutable hashtables. + */ +#define HASHTABLETAG "HTB" +/** + * The payload of a hashtable. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further hashtable. + */ +struct hashtable_payload { + struct cons_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use + the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashtable and a + * namespace is that a hashtable has a write ACL + * of `NIL`, meaning not writeable by anyone */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashtables. */ +}; + +#endif \ No newline at end of file diff --git a/src/c/payloads/mutex.h b/src/c/payloads/mutex.h new file mode 100644 index 0000000..11a81df --- /dev/null +++ b/src/c/payloads/mutex.h @@ -0,0 +1,66 @@ +/** + * payloads/mutex.h + * + * A mutex (mutual exclusion lock) cell. Requires a size class 3 object. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_mutex_h +#define __psse_payloads_mutex_h + +#include + +#include "memory/pointer.h" + +/** + * @brief Tag for mutex cell. mutexes are thread-safe locks, required by + * mutable objects. + * \see FUNCTIONTAG. + */ +#define MUTEXTAG "MTX" + +/** + * @brief payload for mutex objects. + * + * NOTE that the size of `pthread_mutex_t` is variable dependent on hardware + * architecture, but the largest known size is 40 bytes (five words). + */ +struct mutex_payload { + pthread_mutex_t mutex; +} + +struct pso_pointer make_mutex(); + +/** + * @brief evaluates these forms within the context of a thread-safe lock. + * + * 1. wait until the specified mutex can be locked; + * 2. evaluate each of the forms sequentially in the context of that locked + * mutex; + * 3. if evaluation of any of the forms results in the throwing of an + * exception, catch the exception, unlock the mutex, and then re-throw the + * exception; + * 4. on successful completion of the evaluation of the forms, unlock the mutex + * and return the value of the last form. + * + * @param lock the lock: a mutex (MTX) object; + * @param forms a list of arbitrary Lisp forms. + * @return struct pso_pointer the result. + */ +struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms); + +/** + * @brief as with_lock, q.v. but attempts to obtain a lock and returns an + * exception on failure + * + * 1. attempt to lock the specified mutex; + * 2. if successful, proceed as `with_lock`; + * 3. otherwise, return a specific exception which can be trapped for. + * + * @param lock the lock: a mutex (MTX) object; + * @param forms a list of arbitrary Lisp forms. + * @return struct pso_pointer the result. + */ +struct pso_pointer attempt_with_lock( struct pso_pointer lock, struct pso_pointer forms); \ No newline at end of file diff --git a/src/c/payloads/namespace.h b/src/c/payloads/namespace.h new file mode 100644 index 0000000..4bb5ae0 --- /dev/null +++ b/src/c/payloads/namespace.h @@ -0,0 +1,42 @@ +/** + * payloads/namespace.h + * + * a Lisp namespace - a hashtable whose contents are mutable. + * + * Can sensibly sit in any pso from size class 6 upwards. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_namespace_h +#define __psse_payloads_namespace_h + +#include "memory/pointer.h" + +/** + * @brief Tag for a Lisp namespace - a hashtable whose contents are mutable. + * \see HASHTABLETAG for mutable hashtables. + */ +#define NAMESPACETAG "NSP" + +/** + * The payload of a namespace. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further namespace. + */ +struct namespace_payload { + struct cons_pointer hash_fn; /* function for hashing values in this namespace, or + * `NIL` to use the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashtable and a + * namespace is that a hashtable has a write ACL + * of `NIL`, meaning not writeable by anyone */ + struct cons_pointer mutex; /* the mutex to lock when modifying this namespace.*/ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashtables. */ +}; + +#endif \ No newline at end of file diff --git a/src/c/psse.c b/src/c/psse.c index 636cde5..5c67b6f 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -97,9 +97,9 @@ int main( int argc, char *argv[] ) { } } - initialise_node( 0); + initialise_node( 0 ); - repl(); + repl( ); - exit( 0); -} \ No newline at end of file + exit( 0 ); +} diff --git a/src/c/psse.h b/src/c/psse.h index 759c33c..0c57020 100644 --- a/src/c/psse.h +++ b/src/c/psse.h @@ -27,4 +27,4 @@ #include "memory/stack.h" #include "version.h" -#endif \ No newline at end of file +#endif From cae27731b7ea84c745455f76e84a05cfddffa94b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2026 23:46:14 +0000 Subject: [PATCH 15/29] Huge amount of work. Does not even nearly compile, but it's nearer. --- src/c/debug.c | 6 +- src/c/debug.h | 2 + src/c/memory/header.h | 10 ++- src/c/memory/memory.c | 5 +- src/c/memory/memory.h | 2 + src/c/memory/node.h | 5 +- src/c/memory/page.c | 36 ++++++--- src/c/memory/pointer.h | 3 + src/c/memory/pso.c | 118 +++++++++++++++++++++++++++-- src/c/memory/pso.h | 72 +++++++++++------- src/c/payloads/cons.c | 86 +++++++++++++++++++++ src/c/payloads/cons.h | 9 +++ src/c/payloads/exception.h | 5 +- src/c/payloads/free.h | 1 + src/c/payloads/function.h | 10 ++- src/c/payloads/hashtable.h | 27 +++++-- src/c/payloads/integer.h | 5 +- src/c/payloads/keyword.h | 1 + src/c/payloads/lambda.h | 1 + src/c/payloads/mutex.h | 7 +- src/c/payloads/namespace.h | 28 ++++++- src/c/payloads/nlambda.h | 3 +- src/c/payloads/read_stream.h | 3 + src/c/payloads/special.h | 9 ++- src/c/{memory => payloads}/stack.c | 19 +++-- src/c/{memory => payloads}/stack.h | 18 +++-- src/c/payloads/string.h | 3 +- src/c/payloads/symbol.h | 1 + src/c/payloads/time.h | 3 +- src/c/payloads/write_stream.h | 1 + utils_src/tagvalcalc/tagvalcalc.c | 4 +- 31 files changed, 407 insertions(+), 96 deletions(-) create mode 100644 src/c/payloads/cons.c rename src/c/{memory => payloads}/stack.c (51%) rename src/c/{memory => payloads}/stack.h (81%) diff --git a/src/c/debug.c b/src/c/debug.c index 9145a66..ae57c16 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -1,7 +1,7 @@ /** - * debug.h + * debug.c * - * Post Scarcity Software Environment: entry point. + * Post Scarcity Software Environment: debugging messages. * * Print debugging output. * @@ -10,6 +10,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include + #include "debug.h" int verbosity = 0; diff --git a/src/c/debug.h b/src/c/debug.h index c9c2a26..dc833dd 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -14,8 +14,10 @@ #define __psse_debug_h #include #include +#include #include + /** * @brief Print messages debugging memory allocation. * diff --git a/src/c/memory/header.h b/src/c/memory/header.h index 71a449f..429cda1 100644 --- a/src/c/memory/header.h +++ b/src/c/memory/header.h @@ -12,6 +12,8 @@ #include +#include "memory/pointer.h" + #define TAGLENGTH 3 /** @@ -20,7 +22,7 @@ */ struct pso_header { union { - /** the tag (type) of this cell, + /** the tag (type) of this object, * considered as bytes */ struct { /** mnemonic for this type; */ @@ -31,10 +33,10 @@ struct pso_header { /** the tag considered as a number */ uint32_t value; } tag; - /** the count of the number of references to this cell */ + /** the count of the number of references to this object */ uint32_t count; - /** cons pointer to the access control list of this cell */ - struct cons_pointer access; + /** pointer to the access control list of this object */ + struct pso_pointer access; }; #endif diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index d3dbe24..85754bc 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -19,9 +19,8 @@ struct pso_pointer freelists[MAX_SIZE_CLASS + 1]; int initialise_memory( int node ) { - fprintf( stderr, "TODO: Implement initialise_memory()" ); - for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { - freelists[i] = nil;S + freelists[i] = nil; } + } diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index 49f45e2..fc242c2 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -10,6 +10,8 @@ #ifndef __psse_memory_memory_h #define __psse_memory_memory_h +#include "memory/pointer.h" + /** * @brief Maximum size class * diff --git a/src/c/memory/node.h b/src/c/memory/node.h index cae61e6..fbc177a 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -11,12 +11,13 @@ #ifndef __psse_memory_node_h #define __psse_memory_node_h +#include /** * @brief The index of this node in the hypercube. * */ -extern int node_index; +extern uint32_t node_index; /** * @brief The canonical `nil` pointer @@ -30,4 +31,6 @@ extern struct pso_pointer nil; */ extern struct pso_pointer t; +struct pso_pointer initialise_node( uint32_t index ); + #endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 3d5643c..1486301 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -44,15 +44,27 @@ struct page * pages[NPAGES]; */ uint32_t npages_allocated = 0 -struct cons_pointer initialise_page( struct page * result, uint16_t page_index, uint8_t size_class, pso_pointer freelist) { +/** + * @brief private to allocate_page; do not use. + * + * @param page_addr address of the newly allocated page to be initialised; + * @param page_index its location in the pages[] array; + * @param size_class the size class of objects in this page; + * @param freelist the freelist for objects of this size class. + * @return struct cons_pointer the new head for the freelist for this size_class, + */ +struct cons_pointer initialise_page( struct page * page_addr, uint16_t page_index, uint8_t size_class, pso_pointer freelist) { struct cons_pointer result = freelist; int obj_size = pow(2, size_class); int obj_bytes = obj_size * sizeof(uint64_t); int objs_in_page = PAGE_BYTES/obj_bytes; + // we do this backwards (i--) so that object {0, 0, 0} will be first on the + // freelist when the first page is initiated, so we can grab that one for + // `nil` and the next on for `t`. for (int i = objs_in_page - 1; i >= 0; i--) { // it should be safe to cast any pso object to a pso2 - struct pso2* object = (pso2 *)(result + (i * obj_bytes)); + struct pso2* object = (pso2 *)(page_addr + (i * obj_bytes)); object->header.tag.size_class = size_class; strncpy( (char *)(object->header.tag.mnemonic), FREETAG, TAGLENGTH); @@ -75,10 +87,10 @@ struct cons_pointer initialise_page( struct page * result, uint16_t page_index, * cast it back. * * @param size_class an integer in the range 0...MAX_SIZE_CLASS. - * @return a pointer to the page, or NULL if an error occurred. + * @return t on success, an exception if an error occurred. */ -void *allocate_page( uint8_t size_class ) { - void *result = NULL; +struct cons_pointer allocate_page( uint8_t size_class ) { + struct cons_pointer result = t; if ( npages_allocated == 0) { for (int i = 0; i < NPAGES; i++) { @@ -108,22 +120,28 @@ void *allocate_page( uint8_t size_class ) { npages_allocated ++; } else { + // TODO: exception when we have one. + result = nil; fwide( stderr, 1 ); fwprintf( stderr, L"\nCannot allocate page: heap exhausted,\n", size_class, MAX_SIZE_CLASS ); } } else { + // TODO: exception when we have one. + result = nil; fwide( stderr, 1 ); fwprintf( stderr, L"\nCannot allocate page for size class %x, min is 2 max is %x.\n", size_class, MAX_SIZE_CLASS ); } } else { - fwide( stderr, 1 ); - fwprintf( stderr, - L"\nCannot allocate page: page space exhausted.\n", - size_class, MAX_SIZE_CLASS ); + // TODO: exception when we have one. + result = nil; + fwide( stderr, 1 ); + fwprintf( stderr, + L"\nCannot allocate page: page space exhausted.\n", + size_class, MAX_SIZE_CLASS ); } return result; diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index fad04cd..902fce2 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -38,6 +38,9 @@ struct pso_pointer { uint16_t offset; }; + struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset); +struct pso2* pointer_to_object( struct pso_pointer pointer); + #endif diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 2914700..f76890d 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -14,11 +14,26 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -struct cons_pointer allocate( char* tag, uint8_t size_class) { - struct cons_pointer result = nil; + #include "memory/page.h" + #include "memory/pointer.h" + #include "memory/pso.h" + + /** + * @brief Allocate an object of this size_class with this tag. + * + * @param tag The tag. Only the first three bytes will be used; + * @param size_class The size class for the object to be allocated; + * @return struct pso_pointer a pointer to the newly allocated object + */ +struct pso_pointer allocate( char* tag, uint8_t size_class) { + struct pso_pointer result = nil; if (size_class <= MAX_SIZE_CLASS) { - if ( not( freelists[size_class] ) ) { + if (freelists[size_class] == nil) { + result = allocate_page(size_class) + } + + if ( !exceptionp( result) && not( freelists[size_class] ) ) { result = freelists[size_class]; struct pso2* object = pointer_to_object( result); freelists[size_class] = object->payload.free.next; @@ -32,7 +47,7 @@ struct cons_pointer allocate( char* tag, uint8_t size_class) { } /* the objext ought to have a reference count ot zero, because it's * on the freelist, but again we should sanity check. */ - if ( object->header.count != 0) { + if ( object->header.header.count != 0) { // TODO: return an exception instead? Or warn, set it, and continue? } @@ -42,6 +57,97 @@ struct cons_pointer allocate( char* tag, uint8_t size_class) { return result; } -struct cons_pointer get_tag_value( struct cons_pointer pointer) { - result = +/** + * increment the reference count of the object at this cons pointer. + * + * You can't roll over the reference count. Once it hits the maximum + * value you cannot increment further. + * + * Returns the `pointer`. + */ +struct pso_pointer inc_ref( struct pso_pointer pointer ) { + struct pso2 *object = pointer_to_object( pointer ); + + if ( object->header.count < MAXREFERENCE ) { + object->header.count++; +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, + L"\nIncremented object of type %4.4s at page %u, offset %u to count %u", + ( ( char * ) object->header.tag.bytes ), pointer.page, + pointer.offset, object->header.count ); + if ( strncmp( object->header.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + debug_printf( DEBUG_ALLOC, + L"; pointer to vector object of type %4.4s.\n", + ( ( char * ) ( object->header.payload.vectorp.tag.bytes ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } +#endif + } + + return pointer; +} + +/** + * Decrement the reference count of the object at this cons pointer. + * + * If a count has reached MAXREFERENCE it cannot be decremented. + * If a count is decremented to zero the object should be freed. + * + * Returns the `pointer`, or, if the object has been freed, a pointer to `nil`. + */ +struct pso_pointer dec_ref( struct pso_pointer pointer ) { + struct pso2 *object = pointer_to_object( pointer ); + + if ( object->count > 0 && object->count != MAXREFERENCE ) { + object->count--; +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, + L"\nDecremented object of type %4.4s at page %d, offset %d to count %d", + ( ( char * ) object->tag.bytes ), pointer.page, + pointer.offset, object->count ); + if ( strncmp( ( char * ) object->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) + == 0 ) { + debug_printf( DEBUG_ALLOC, + L"; pointer to vector object of type %4.4s.\n", + ( ( char * ) ( object->payload.vectorp.tag.bytes ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } +#endif + + if ( object->header.count == 0 ) { + free_cell( pointer ); + pointer = NIL; + } + } + + return pointer; +} + +/** + * @brief Prevent an object ever being dereferenced. + * + * @param pointer pointer to an object to lock. + */ +void lock_object( struct pso_pointer pointer) { + struct pso2* object = pointer_to_object( pointer ); + + object->header.header.count = MAXREFERENCE; +} + + +/** + * @brief Get the numeric value of the tag bytes of the object indicated + * by this pointer + * + * @param pointer a pointer to an object. + * @return the tag value of the object indicated. + */ +uint32_t get_tag_value( struct pso_pointer pointer) { + result = (pointer_to_object( pointer)->tag.value & 0xffffff; + + // TODO: deal with the vector pointer issue + + return result; } \ No newline at end of file diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 90b9d57..9fd7cc1 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -13,13 +13,17 @@ #include #include "memory/header.h" +#include "memory/pointer.h" #include "payloads/cons.h" +#include "payloads/exception.h" #include "payloads/free.h" #include "payloads/function.h" +#include "payloads/hashtable.h" #include "payloads/integer.h" -#include "payloads/ketwod.h" +#include "payloads/keyword.h" #include "payloads/lambda.h" #include "payloads/mutex.h" +#include "payloads/namespace.h" #include "payloads/nlambda.h" #include "payloads/read_stream.h" #include "payloads/special.h" @@ -38,8 +42,8 @@ struct pso2 { struct pso_header header; union { - char[16] bytes; - uint64_t[2] words; + char bytes[16]; + uint64_t words[2]; struct cons_payload cons; struct free_payload free; struct function_payload function; @@ -60,8 +64,8 @@ struct pso2 { struct pso3 { struct pso_header header; union { - char[48] bytes; - uint64_t[6] words; + char bytes[48]; + uint64_t words[6]; struct exception_payload exception; struct free_payload free; struct mutex_payload mutex; @@ -76,8 +80,8 @@ struct pso3 { struct pso4 { struct pso_header header; union { - char[112] bytes; - uint64_t[14] words; + char bytes[112]; + uint64_t words[14]; struct free_payload free; struct stack_frame_payload stack_frame; } payload; @@ -91,8 +95,8 @@ struct pso4 { struct pso5 { struct pso_header header; union { - char[240] bytes; - uint64_t[30] words; + char bytes[240]; + uint64_t words[30]; struct free_payload free; } payload; }; @@ -105,8 +109,8 @@ struct pso5 { struct pso6 { struct pso_header header; union { - char[496] bytes; - uint64_t[62] words; + char bytes[496]; + uint64_t words[62]; struct free_payload free; struct hashtable_payload hashtable; struct namespace_payload namespace; @@ -121,8 +125,8 @@ struct pso6 { struct pso7 { struct pso_header header; union { - char[1008] bytes; - uint64_t[126] words; + char bytes[1008]; + uint64_t words[126]; struct free_payload free; } payload; }; @@ -135,8 +139,8 @@ struct pso7 { struct pso8 { struct pso_header header; union { - char[2032] bytes; - uint64_t[254] words; + char bytes[2032]; + uint64_t words[254]; struct free_payload free; } payload; }; @@ -149,8 +153,8 @@ struct pso8 { struct pso9 { struct pso_header header; union { - char[4080] bytes; - uint64_t[510] words; + char bytes[4080]; + uint64_t words[510]; struct free_payload free; } payload; }; @@ -163,8 +167,8 @@ struct pso9 { struct psoa { struct pso_header header; union { - char[8176] bytes; - uint64_t[1022] words; + char bytes[8176]; + uint64_t words[1022]; struct free_payload free; } payload; }; @@ -177,8 +181,8 @@ struct psoa { struct psob { struct pso_header header; union { - char[16368] bytes; - uint64_t[2046] words; + char bytes[16368]; + uint64_t words[2046]; struct free_payload free; } payload; }; @@ -191,8 +195,8 @@ struct psob { struct psoc { struct pso_header header; union { - char[32752] bytes; - uint64_t[4094] words; + char bytes[32752]; + uint64_t words[4094]; struct free_payload free; } payload; }; @@ -205,8 +209,8 @@ struct psoc { struct psod { struct pso_header header; union { - char[65520] bytes; - uint64_t[8190] words; + char bytes[65520]; + uint64_t words[8190]; struct free_payload free; } payload; }; @@ -219,8 +223,8 @@ struct psod { struct psoe { struct pso_header header; union { - char[131056] bytes; - uint64_t[16382] words; + char bytes[131056]; + uint64_t words[16382]; struct free_payload free; } payload; }; @@ -233,8 +237,18 @@ struct psoe { struct psof { struct pso_header header; union { - char[262128] bytes; - uint64_t[32766] words; + char bytes[262128]; + uint64_t words[32766]; struct free_payload free; } payload; }; + +struct pso_pointer allocate( char* tag, uint8_t size_class); + +struct pso_pointer dec_ref( struct pso_pointer pointer ); + +struct pso_pointer inc_ref( struct pso_pointer pointer ); + +void lock_object( struct pso_pointer pointer); + +#endif \ No newline at end of file diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c new file mode 100644 index 0000000..5eaf2b6 --- /dev/null +++ b/src/c/payloads/cons.c @@ -0,0 +1,86 @@ +/** + * payloads/cons.h + * + * A cons cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "payloads/cons.h" + +/** + * @brief allocate a cons cell with this car and this cdr, and return a pointer + * to it. + * + * @param car the pointer which should form the car of this cons cell; + * @param cdr the pointer which should form the cdr of this cons cell. + * @return struct pso_pointer a pointer to the newly allocated cons cell. + */ +struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr) { + struct pso_pointer result = allocate( CONSTAG, 2); + + struct pso2 *object = pointer_to_object( result ); + object->payload.cons.car = car; + object->payload.cons.cdr = cdr; + + inc_ref( car); + inc_ref( cdr); + + return result; +} + +/** + * @brief return true if `ptr` indicates a cons cell, else false. + * + * @param ptr a pointer. + * @return true if `ptr` indicates a cons cell. + * @return false otherwise + */ +bool consp( struct pso_pointer ptr) { + // TODO: make it actually work! + return false; +} + +/** + * @brief return the car of this cons cell. + * + * @param cons a pointer to the cell. + * @return the car of the indicated cell. + * @exception if the pointer does not indicate a cons cell. + */ +struct pso_pointer car( struct pso_pointer cons) { + struct pso_pointer result = nil; + struct pso2 *object = pointer_to_object( result ); + + if ( consp( cons)) { + result = object->payload.cons.car; + } + // TODO: else throw an exception + + return result; +} + +/** + * @brief return the cdr of this cons cell. + * + * @param cons a pointer to the cell. + * @return the cdr of the indicated cell. + * @exception if the pointer does not indicate a cons cell. + */ +struct pso_pointer cdr( struct pso_pointer cons) { + struct pso_pointer result = nil; + struct pso2 *object = pointer_to_object( result ); + + if ( consp( cons)) { + result = object->payload.cons.cdr; + } + // TODO: else throw an exception + + return result; +} \ No newline at end of file diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index a1b0d4d..a2e8129 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -9,6 +9,7 @@ #ifndef __psse_payloads_cons_h #define __psse_payloads_cons_h +#include #include "memory/pointer.h" @@ -16,6 +17,7 @@ * An ordinary cons cell: */ #define CONSTAG "CNS" +#define CONSTV 5459523 /** * @brief A cons cell. @@ -28,5 +30,12 @@ struct cons_payload { struct pso_pointer cdr; }; +struct pso_pointer car( struct pso_pointer cons); + +struct pso_pointer cdr( struct pso_pointer cons); + +struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr); + +bool consp( struct pso_pointer ptr); #endif diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 0363daa..d6fdc03 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -12,6 +12,9 @@ #include "memory/pointer.h" +#define EXCEPTIONTAG "EXP" +#define EXCEPTIONTV 5265477 + /** * @brief An exception; required three pointers, so use object of size class 3. */ @@ -21,7 +24,7 @@ struct exception_payload { /** @brief the stack frame at which the exception was thrown. */ struct pso_pointer stack; /** @brief the cause; expected to be another exception, or (usually) `nil`. */ - struct cons_pointer cause; + struct pso_pointer cause; }; diff --git a/src/c/payloads/free.h b/src/c/payloads/free.h index 3871c36..947a3e4 100644 --- a/src/c/payloads/free.h +++ b/src/c/payloads/free.h @@ -16,6 +16,7 @@ * @brief Tag for an unassigned object; may be of any size class. */ #define FREETAG "FRE" +#define FREETV 4543046 /** * @brief An unassigned object, on a freelist; may be of any size class. diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 66ac8bc..2ef45c4 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -11,6 +11,7 @@ #define __psse_payloads_function_h #include "memory/pointer.h" +#include "memory/pso.h" /** * @brief Tag for an ordinary Lisp function - one whose arguments are pre-evaluated. @@ -18,6 +19,7 @@ * \see SPECIALTAG for functions whose arguments are not pre-evaluated. */ #define FUNCTIONTAG "FUN" +#define FUNCTIONTV 5133638 /** * @brief Payload of a function cell. @@ -32,16 +34,16 @@ struct function_payload { /** * pointer to metadata (e.g. the source from which the function was compiled). */ - struct cons_pointer meta; + struct pso_pointer meta; /** pointer to a function which takes a cons pointer (representing * its argument list) and a cons pointer (representing its environment) and a * stack frame (representing the previous stack frame) as arguments and returns * a cons pointer (representing its result). * \todo check this documentation is current! */ - struct cons_pointer ( *executable ) ( struct stack_frame *, - struct cons_pointer, - struct cons_pointer ); + struct pso_pointer ( *executable ) ( struct pso4 *, + struct pso_pointer, + struct pso_pointer ); }; #endif diff --git a/src/c/payloads/hashtable.h b/src/c/payloads/hashtable.h index 5fcced5..86664e5 100644 --- a/src/c/payloads/hashtable.h +++ b/src/c/payloads/hashtable.h @@ -3,7 +3,25 @@ * * an ordinary Lisp hashtable - one whose contents are immutable. * - * Can sensibly sit in any pso from size class 6 upwards. + * Can sensibly sit in any pso from size class 6 upwards. However, it's often + * considered a good thing to have a prime number of buckets in a hash table. + * Our total overhead on the full object size is two words header, and, for + * hashtables, one word for the pointer to the (optional) hash function, and + * one for the number of buckets, total four. + * + * | size class | words | less overhead | nearest prime | wasted | + * | ---------- | ----- | ------------- | ------------- | ------ | + * | 5 | 32 | 28 | 23 | 5 | + * | 6 | 64 | 60 | 59 | 1 | + * | 7 | 128 | 124 | 113 | 11 | + * | 8 | 256 | 252 | 251 | 1 | + * | 9 | 512 | 508 | 503 | 5 | + * | 10 | 1024 | 1020 | 1019 | 1 | + * + * So we can fit 59 buckets into a 64 word class 6 pso, wasting one word; + * 251 buckets in a 256 word class 8 again wasting one word; 1019 in a size + * class 10, also wasting only one word. In a 32 word class 5, the best prime + * we can do is 23 buckets, wasting five words. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -19,6 +37,8 @@ * \see NAMESPACETAG for mutable hashtables. */ #define HASHTABLETAG "HTB" +#define HASHTABLETV 4346952 + /** * The payload of a hashtable. The number of buckets is assigned at run-time, * and is stored in n_buckets. Each bucket is something ASSOC can consume: @@ -27,12 +47,7 @@ struct hashtable_payload { struct cons_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use the default hashing function */ - struct cons_pointer write_acl; /* it seems to me that it is likely that the - * principal difference between a hashtable and a - * namespace is that a hashtable has a write ACL - * of `NIL`, meaning not writeable by anyone */ uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` * or assoc lists or (possibly) further hashtables. */ }; diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index 69d0617..00ee92d 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -12,6 +12,9 @@ #include +#define INTEGERTAG "INT" +#define INTEGERTV 5525065 + /** * @brief An integer . * @@ -20,7 +23,7 @@ * in the Lisp layer, not the substrate. */ struct integer_payload { - int128_t value; + __int128_t value; }; diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h index 164d31c..de89749 100644 --- a/src/c/payloads/keyword.h +++ b/src/c/payloads/keyword.h @@ -16,6 +16,7 @@ * Tag for a keyword - an interned, self-evaluating string. */ #define KEYTAG "KEY" +#define KEYTV 5850443 /* TODO: for now, Keyword shares a payload with String, but this may change. * Strings are of indefinite length, but keywords are really not, and might diff --git a/src/c/payloads/lambda.h b/src/c/payloads/lambda.h index f457339..cfa9bde 100644 --- a/src/c/payloads/lambda.h +++ b/src/c/payloads/lambda.h @@ -17,6 +17,7 @@ * \see FUNCTIONTAG. */ #define LAMBDATAG "LMD" +#define LAMBDATV 4345164 /** * @brief payload for lambda and nlambda cells. diff --git a/src/c/payloads/mutex.h b/src/c/payloads/mutex.h index 11a81df..ca5704b 100644 --- a/src/c/payloads/mutex.h +++ b/src/c/payloads/mutex.h @@ -20,6 +20,7 @@ * \see FUNCTIONTAG. */ #define MUTEXTAG "MTX" +#define MUTEXTV 5788749 /** * @brief payload for mutex objects. @@ -29,7 +30,7 @@ */ struct mutex_payload { pthread_mutex_t mutex; -} +}; struct pso_pointer make_mutex(); @@ -63,4 +64,6 @@ struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms) * @param forms a list of arbitrary Lisp forms. * @return struct pso_pointer the result. */ -struct pso_pointer attempt_with_lock( struct pso_pointer lock, struct pso_pointer forms); \ No newline at end of file +struct pso_pointer attempt_with_lock( struct pso_pointer lock, struct pso_pointer forms); + +#endif diff --git a/src/c/payloads/namespace.h b/src/c/payloads/namespace.h index 4bb5ae0..b494e93 100644 --- a/src/c/payloads/namespace.h +++ b/src/c/payloads/namespace.h @@ -3,7 +3,28 @@ * * a Lisp namespace - a hashtable whose contents are mutable. * - * Can sensibly sit in any pso from size class 6 upwards. + * Can sensibly sit in any pso from size class 6 upwards. However, it's often + * considered a good thing to have a prime number of buckets in a hash table. + * Our total overhead on the full object size is two words header, and, for + * namespaces, one word for the pointer to the (optional) hash function, + * one for the number of buckets, one for the pointer to the write ACL, one + * for the pointer to the mutex, total six. + * + * There are no really good fits until you get up to class 9, which might + * make sense for some namespaces, but it's quite large! + * + * | size class | words | less overhead | nearest prime | wasted | + * | ---------- | ----- | ------------- | ------------- | ------ | + * | 5 | 32 | 26 | 23 | 3 | + * | 6 | 64 | 58 | 53 | 5 | + * | 7 | 128 | 122 | 113 | 9 | + * | 8 | 256 | 250 | 241 | 9 | + * | 9 | 512 | 506 | 503 | 3 | + * | 10 | 1024 | 1018 | 1013 | 5 | + * + * Although it may be *better* to have prime numbers of buckets, how much + * better is it? Is a bucket with 23 slots sufficiently better than one + * with 26 slots to make up for its inevitably-longer hash buckets? * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -19,6 +40,7 @@ * \see HASHTABLETAG for mutable hashtables. */ #define NAMESPACETAG "NSP" +#define NAMESPACETV 5264206 /** * The payload of a namespace. The number of buckets is assigned at run-time, @@ -28,13 +50,13 @@ struct namespace_payload { struct cons_pointer hash_fn; /* function for hashing values in this namespace, or * `NIL` to use the default hashing function */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ struct cons_pointer write_acl; /* it seems to me that it is likely that the * principal difference between a hashtable and a * namespace is that a hashtable has a write ACL * of `NIL`, meaning not writeable by anyone */ struct cons_pointer mutex; /* the mutex to lock when modifying this namespace.*/ - uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` * or assoc lists or (possibly) further hashtables. */ }; diff --git a/src/c/payloads/nlambda.h b/src/c/payloads/nlambda.h index bf96361..1f0771f 100644 --- a/src/c/payloads/nlambda.h +++ b/src/c/payloads/nlambda.h @@ -15,7 +15,8 @@ /** * An ordinary nlambda cell: */ -#define CONSTAG "CNS" +#define NLAMBDATAG "NLM" +#define NLAMBDATV 5065806 /* nlambda shares a payload with lambda */ diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index 5489308..e271489 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -12,12 +12,15 @@ #include +#include + #include "memory/pointer.h" /** * An open read stream. */ #define READTAG "REA" +#define READTV 4277586 /** * payload of a read or write stream cell. diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index 96f616d..4c64545 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -18,6 +18,7 @@ * \see NLAMBDATAG. */ #define SPECIALTAG "SFM" +#define SPECIALTV 5064275 /** * @brief Payload of a special form cell. @@ -30,14 +31,14 @@ struct special_payload { * pointer to the source from which the special form was compiled, or NIL * if it is a primitive. */ - struct cons_pointer meta; + struct pso_pointer meta; /** pointer to a function which takes a cons pointer (representing * its argument list) and a cons pointer (representing its environment) and a * stack frame (representing the previous stack frame) as arguments and returns * a cons pointer (representing its result). */ - struct cons_pointer ( *executable ) ( struct stack_frame *, - struct cons_pointer, - struct cons_pointer ); + struct pso_pointer ( *executable ) ( struct pso4 *, + struct pso_pointer, + struct pso_pointer ); }; #endif diff --git a/src/c/memory/stack.c b/src/c/payloads/stack.c similarity index 51% rename from src/c/memory/stack.c rename to src/c/payloads/stack.c index ab98c93..a814699 100644 --- a/src/c/memory/stack.c +++ b/src/c/payloads/stack.c @@ -1,5 +1,5 @@ /** - * memory/stack.c + * payloads/stack.c * * The execution stack. * @@ -7,7 +7,9 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "memory/stack.h" +#include "memory/node.h" +#include "memory/pso.h" +#include "payloads/stack.h" /** * @brief The maximum depth of stack before we throw an exception. @@ -19,19 +21,20 @@ uint32_t stack_limit = 0; /** * Fetch a pointer to the value of the local variable at this index. */ -struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) { - struct cons_pointer result = NIL; +struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { + struct pso_pointer result = nil; + // TODO check that the frame is indeed a frame! if ( index < args_in_frame ) { - result = frame->arg[index]; + result = frame->payload.stack_frame.arg[index]; } else { - struct cons_pointer p = frame->more; + struct pso_pointer p = frame->payload.stack_frame.more; for ( int i = args_in_frame; i < index; i++ ) { - p = pointer2cell( p ).payload.cons.cdr; + p = pointer_to_object( p)->payload.cons.cdr; } - result = pointer2cell( p ).payload.cons.car; + result = pointer_to_object( p)->payload.cons.car; } return result; diff --git a/src/c/memory/stack.h b/src/c/payloads/stack.h similarity index 81% rename from src/c/memory/stack.h rename to src/c/payloads/stack.h index 7e0b2b0..ba0abd8 100644 --- a/src/c/memory/stack.h +++ b/src/c/payloads/stack.h @@ -1,17 +1,19 @@ /** - * memory/stack.h + * payloads/stack.h * - * The execution stack. + * a Lisp stack frame. + * + * Sits in a pso4. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef __psse_payloads_stack_frame_h -#define __psse_payloads_stack_frame_h -#include +#ifndef __psse_payloads_stack_h +#define __psse_payloads_stack_h #include "memory/pointer.h" + /* * number of arguments stored in a stack frame */ @@ -25,7 +27,7 @@ extern uint32_t stack_limit; /** - * A stack frame. + * A stack frame. */ struct stack_frame_payload { /** the previous frame. */ @@ -37,9 +39,9 @@ struct stack_frame_payload { /** the function to be called. */ struct pso_pointer function; /** the number of arguments provided. */ - int args; + uint32_t args; /** the depth of the stack below this frame */ - int depth; + uint32_t depth; }; #endif diff --git a/src/c/payloads/string.h b/src/c/payloads/string.h index dbc45ca..c08690d 100644 --- a/src/c/payloads/string.h +++ b/src/c/payloads/string.h @@ -22,6 +22,7 @@ * @brief Tag for string of characters, organised as a linked list. */ #define STRINGTAG "STR" +#define STRINGTV 5395539 /** * @brief payload of a string cell. @@ -36,7 +37,7 @@ struct string_payload { /** a hash of the string value, computed at store time. */ uint32_t hash; /** the remainder of the string following this character. */ - struct cons_pointer cdr; + struct pso_pointer cdr; }; #endif diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index 9e7afd5..fdc01c1 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -17,6 +17,7 @@ * Tag for a symbol: just like a keyword except not self-evaluating. */ #define SYMBOLTAG "SYM" +#define SYMBOLTV 5069139 /* TODO: for now, Symbol shares a payload with String, but this may change. * Strings are of indefinite length, but symbols are really not, and might diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index e304e67..d9870b4 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -15,7 +15,8 @@ /** * @brief Tag for a time stamp. */ -#define TIMETAG "TIME" +#define TIMETAG "TIM" +#define TIMETV 5065044 /** * The payload of a time cell: an unsigned 128 bit value representing micro- diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index 757f7d0..deda598 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -16,6 +16,7 @@ * @brief Tag for an open write stream. */ #define WRITETAG "WRT" +#define WRITETV 5264214 /* write stream shares a payload with /see read_streem.h */ #endif diff --git a/utils_src/tagvalcalc/tagvalcalc.c b/utils_src/tagvalcalc/tagvalcalc.c index 67828bd..ad2e1a9 100644 --- a/utils_src/tagvalcalc/tagvalcalc.c +++ b/utils_src/tagvalcalc/tagvalcalc.c @@ -3,7 +3,7 @@ #include #include -#define TAGLENGTH 4 +#define TAGLENGTH 3 struct dummy { union { @@ -21,6 +21,6 @@ int main( int argc, char *argv[] ) { strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH ); - printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value); + printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value & 0xffffff); } } From 00997d3c90a71d0d6babf9967d5e73d950895c0c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 29 Mar 2026 11:07:30 +0100 Subject: [PATCH 16/29] Down to to compilation errors. Had to reinstate individual size-class headers. --- docs/Nodes-threads-locks-links.md | 2 +- src/c/memory/pso.h | 428 +++++++++++++++--------------- src/c/memory/pso2.h | 53 ++++ src/c/memory/pso3.h | 37 +++ src/c/memory/pso4.h | 34 +++ src/c/memory/pso5.h | 32 +++ src/c/memory/pso6.h | 32 +++ src/c/memory/pso7.h | 32 +++ src/c/memory/pso8.h | 32 +++ src/c/memory/pso9.h | 32 +++ src/c/memory/psoa.h | 32 +++ src/c/memory/psob.h | 32 +++ src/c/memory/psoc.h | 32 +++ src/c/memory/psod.h | 32 +++ src/c/memory/psoe.h | 32 +++ src/c/memory/psof.h | 32 +++ src/c/payloads/function.h | 4 +- src/c/payloads/hashtable.h | 6 +- src/c/payloads/namespace.h | 10 +- src/c/payloads/read_stream.h | 3 +- src/c/payloads/special.h | 41 +-- src/c/payloads/stack.c | 3 + src/c/payloads/stack.h | 2 + src/c/payloads/time.h | 2 + src/c/payloads/vector_pointer.h | 1 + src/c/payloads/write_stream.h | 1 + 26 files changed, 733 insertions(+), 246 deletions(-) create mode 100644 src/c/memory/pso2.h create mode 100644 src/c/memory/pso3.h create mode 100644 src/c/memory/pso4.h create mode 100644 src/c/memory/pso5.h create mode 100644 src/c/memory/pso6.h create mode 100644 src/c/memory/pso7.h create mode 100644 src/c/memory/pso8.h create mode 100644 src/c/memory/pso9.h create mode 100644 src/c/memory/psoa.h create mode 100644 src/c/memory/psob.h create mode 100644 src/c/memory/psoc.h create mode 100644 src/c/memory/psod.h create mode 100644 src/c/memory/psoe.h create mode 100644 src/c/memory/psof.h diff --git a/docs/Nodes-threads-locks-links.md b/docs/Nodes-threads-locks-links.md index 1f2a9dd..8108168 100644 --- a/docs/Nodes-threads-locks-links.md +++ b/docs/Nodes-threads-locks-links.md @@ -119,7 +119,7 @@ We don't currently have any other mutable objects, but in future at least lazy o Secondly, reading from a namespace does not happen in a single clock tick, it takes quite a long time. So it's no good setting a lock bit on the namespace object itself and then immediately assuming that it's now mutable. A reading process could already have started, and be proceeding. -So what I think is, that we have a single top level function, `(::substrate:search-store key store return-key?)` (which we already sort of have in the 0.0.6 prototype, [here](https://www.journeyman.cc/post-scarcity/doc/html/intern_8c.html#a2189c0ab60e57a70adeb32aca99dbc43)). This searches a store (hashmap, namespace, association list, or hybrid association list) to find a binding for a key, and, having found that binding, then, if there is a namespace on the search path, checks whether the lock on the any namespace on the search path is set, and it it is, aborts the search and tries again; but otherwise returns either the key found (if `return-key?` is non-`nil`), or the value found otherwise. +So what I think is, that we have a single top level function, `(::substrate:search-store key store return-key?)` (which we already sort of have in the 0.0.6 prototype, [here](https://www.journeyman.cc/post-scarcity/doc/html/intern_8c.html#a2189c0ab60e57a70adeb32aca99dbc43)). This searches a store (hashmap, namespace, association list, or hybrid association list) to find a binding for a key, and, having found that binding, then, if there is a namespace on the search path, checks whether the lock on the any namespace on the search path is set, and if it is, aborts the search and tries again; but otherwise returns either the key found (if `return-key?` is non-`nil`), or the value found otherwise. This function implements the user-level Lisp functions `assoc`, `interned`, and `interned?`. It also implements *hashmap-in-function-position* and *keyword-in-function-position*, in so far as both of these are treated as calls to `assoc`. diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 9fd7cc1..5f91bca 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -14,234 +14,234 @@ #include "memory/header.h" #include "memory/pointer.h" -#include "payloads/cons.h" -#include "payloads/exception.h" -#include "payloads/free.h" -#include "payloads/function.h" -#include "payloads/hashtable.h" -#include "payloads/integer.h" -#include "payloads/keyword.h" -#include "payloads/lambda.h" -#include "payloads/mutex.h" -#include "payloads/namespace.h" -#include "payloads/nlambda.h" -#include "payloads/read_stream.h" -#include "payloads/special.h" -#include "payloads/stack.h" -#include "payloads/string.h" -#include "payloads/symbol.h" -#include "payloads/time.h" -#include "payloads/vector_pointer.h" -#include "payloads/write_stream.h" +// #include "payloads/cons.h" +// #include "payloads/exception.h" +// #include "payloads/free.h" +// #include "payloads/function.h" +// #include "payloads/hashtable.h" +// #include "payloads/integer.h" +// #include "payloads/keyword.h" +// #include "payloads/lambda.h" +// #include "payloads/mutex.h" +// #include "payloads/namespace.h" +// #include "payloads/nlambda.h" +// #include "payloads/read_stream.h" +// #include "payloads/special.h" +// #include "payloads/stack.h" +// #include "payloads/string.h" +// #include "payloads/symbol.h" +// #include "payloads/time.h" +// #include "payloads/vector_pointer.h" +// #include "payloads/write_stream.h" -/** - * @brief A paged space object of size class 2, four words total, two words - * payload. - * - */ -struct pso2 { - struct pso_header header; - union { - char bytes[16]; - uint64_t words[2]; - struct cons_payload cons; - struct free_payload free; - struct function_payload function; - struct integer_payload integer; - struct lambda_payload lambda; - struct special_payload special; - struct stream_payload stream; - struct time_payload time; - struct vectorp_payload vectorp; - } payload; -}; +// /** +// * @brief A paged space object of size class 2, four words total, two words +// * payload. +// * +// */ +// struct pso2 { +// struct pso_header header; +// union { +// char bytes[16]; +// uint64_t words[2]; +// struct cons_payload cons; +// struct free_payload free; +// struct function_payload function; +// struct integer_payload integer; +// struct lambda_payload lambda; +// struct special_payload special; +// struct stream_payload stream; +// struct time_payload time; +// struct vectorp_payload vectorp; +// } payload; +// }; -/** - * @brief A paged space object of size class 3, 8 words total, 6 words - * payload. - * - */ -struct pso3 { - struct pso_header header; - union { - char bytes[48]; - uint64_t words[6]; - struct exception_payload exception; - struct free_payload free; - struct mutex_payload mutex; - } payload; -}; +// /** +// * @brief A paged space object of size class 3, 8 words total, 6 words +// * payload. +// * +// */ +// struct pso3 { +// struct pso_header header; +// union { +// char bytes[48]; +// uint64_t words[6]; +// struct exception_payload exception; +// struct free_payload free; +// struct mutex_payload mutex; +// } payload; +// }; -/** - * @brief A paged space object of size class 4, 16 words total, 14 words - * payload. - * - */ -struct pso4 { - struct pso_header header; - union { - char bytes[112]; - uint64_t words[14]; - struct free_payload free; - struct stack_frame_payload stack_frame; - } payload; -}; +// /** +// * @brief A paged space object of size class 4, 16 words total, 14 words +// * payload. +// * +// */ +// struct pso4 { +// struct pso_header header; +// union { +// char bytes[112]; +// uint64_t words[14]; +// struct free_payload free; +// struct stack_frame_payload stack_frame; +// } payload; +// }; -/** - * @brief A paged space object of size class 5, 32 words total, 30 words - * payload. - * - */ -struct pso5 { - struct pso_header header; - union { - char bytes[240]; - uint64_t words[30]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class 5, 32 words total, 30 words +// * payload. +// * +// */ +// struct pso5 { +// struct pso_header header; +// union { +// char bytes[240]; +// uint64_t words[30]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class 6, 64 words total, 62 words - * payload. - * - */ -struct pso6 { - struct pso_header header; - union { - char bytes[496]; - uint64_t words[62]; - struct free_payload free; - struct hashtable_payload hashtable; - struct namespace_payload namespace; - } payload; -}; +// /** +// * @brief A paged space object of size class 6, 64 words total, 62 words +// * payload. +// * +// */ +// struct pso6 { +// struct pso_header header; +// union { +// char bytes[496]; +// uint64_t words[62]; +// struct free_payload free; +// struct hashtable_payload hashtable; +// struct namespace_payload namespace; +// } payload; +// }; -/** - * @brief A paged space object of size class 7, 128 words total, 126 words - * payload. - * - */ -struct pso7 { - struct pso_header header; - union { - char bytes[1008]; - uint64_t words[126]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class 7, 128 words total, 126 words +// * payload. +// * +// */ +// struct pso7 { +// struct pso_header header; +// union { +// char bytes[1008]; +// uint64_t words[126]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class 8, 256 words total, 254 words - * payload. - * - */ -struct pso8 { - struct pso_header header; - union { - char bytes[2032]; - uint64_t words[254]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class 8, 256 words total, 254 words +// * payload. +// * +// */ +// struct pso8 { +// struct pso_header header; +// union { +// char bytes[2032]; +// uint64_t words[254]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class 9, 512 words total, 510 words - * payload. - * - */ -struct pso9 { - struct pso_header header; - union { - char bytes[4080]; - uint64_t words[510]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class 9, 512 words total, 510 words +// * payload. +// * +// */ +// struct pso9 { +// struct pso_header header; +// union { +// char bytes[4080]; +// uint64_t words[510]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class a, 1024 words total, 1022 words - * payload. - * - */ -struct psoa { - struct pso_header header; - union { - char bytes[8176]; - uint64_t words[1022]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class a, 1024 words total, 1022 words +// * payload. +// * +// */ +// struct psoa { +// struct pso_header header; +// union { +// char bytes[8176]; +// uint64_t words[1022]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class b, 2048 words total, 2046 words - * payload. - * - */ -struct psob { - struct pso_header header; - union { - char bytes[16368]; - uint64_t words[2046]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class b, 2048 words total, 2046 words +// * payload. +// * +// */ +// struct psob { +// struct pso_header header; +// union { +// char bytes[16368]; +// uint64_t words[2046]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class c, 4096 words total, 4094 words - * payload. - * - */ -struct psoc { - struct pso_header header; - union { - char bytes[32752]; - uint64_t words[4094]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class c, 4096 words total, 4094 words +// * payload. +// * +// */ +// struct psoc { +// struct pso_header header; +// union { +// char bytes[32752]; +// uint64_t words[4094]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class d, 8192 words total, 8190 words - * payload. - * - */ -struct psod { - struct pso_header header; - union { - char bytes[65520]; - uint64_t words[8190]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class d, 8192 words total, 8190 words +// * payload. +// * +// */ +// struct psod { +// struct pso_header header; +// union { +// char bytes[65520]; +// uint64_t words[8190]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class e, 16384 words total, 16382 words - * payload. - * - */ -struct psoe { - struct pso_header header; - union { - char bytes[131056]; - uint64_t words[16382]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class e, 16384 words total, 16382 words +// * payload. +// * +// */ +// struct psoe { +// struct pso_header header; +// union { +// char bytes[131056]; +// uint64_t words[16382]; +// struct free_payload free; +// } payload; +// }; -/** - * @brief A paged space object of size class f, 32768 words total, 32766 words - * payload. - * - */ -struct psof { - struct pso_header header; - union { - char bytes[262128]; - uint64_t words[32766]; - struct free_payload free; - } payload; -}; +// /** +// * @brief A paged space object of size class f, 32768 words total, 32766 words +// * payload. +// * +// */ +// struct psof { +// struct pso_header header; +// union { +// char bytes[262128]; +// uint64_t words[32766]; +// struct free_payload free; +// } payload; +// }; struct pso_pointer allocate( char* tag, uint8_t size_class); diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h new file mode 100644 index 0000000..9e838c4 --- /dev/null +++ b/src/c/memory/pso2.h @@ -0,0 +1,53 @@ +/** + * memory/pso2.h + * + * Paged space object of size class 2, four words total, two words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso2_h +#define __psse_memory_pso2_h + +#include + +#include "memory/header.h" +#include "payloads/cons.h" +#include "payloads/free.h" +#include "payloads/function.h" +#include "payloads/integer.h" +#include "payloads/keyword.h" +#include "payloads/lambda.h" +#include "payloads/nlambda.h" +#include "payloads/read_stream.h" +#include "payloads/special.h" +#include "payloads/string.h" +#include "payloads/symbol.h" +#include "payloads/time.h" +#include "payloads/vector_pointer.h" +#include "payloads/write_stream.h" + +/** + * @brief A paged space object of size class 2, four words total, two words + * payload. + * + */ +struct pso2 { + struct pso_header header; + union { + char bytes[16]; + uint64_t words[2]; + struct cons_payload cons; + struct free_payload free; + struct function_payload function; + struct integer_payload integer; + struct lambda_payload lambda; +// struct special_payload special; + struct stream_payload stream; + struct time_payload time; + struct vectorp_payload vectorp; + } payload; +}; + +#endif diff --git a/src/c/memory/pso3.h b/src/c/memory/pso3.h new file mode 100644 index 0000000..c4975b1 --- /dev/null +++ b/src/c/memory/pso3.h @@ -0,0 +1,37 @@ +/** + * memory/pso3.h + * + * Paged space object of size class 3, 8 words total, 6 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso3_h +#define __psse_memory_pso3_h + +#include + +#include "memory/header.h" +#include "payloads/exception.h" +#include "payloads/free.h" +#include "payloads/mutex.h" + + +/** + * @brief A paged space object of size class 3, 8 words total, 6 words + * payload. + * + */ +struct pso3 { + struct pso_header header; + union { + char bytes[48]; + uint64_t words[6]; + struct exception_payload exception; + struct free_payload free; + struct mutex_payload mutex; + } payload; +}; + +#endif diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h new file mode 100644 index 0000000..9ffc337 --- /dev/null +++ b/src/c/memory/pso4.h @@ -0,0 +1,34 @@ +/** + * memory/pso4.h + * + * Paged space object of size class 4, 16 words total, 14 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso4_h +#define __psse_memory_pso4_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" +#include "payloads/stack.h" + +/** + * @brief A paged space object of size class 4, 16 words total, 14 words + * payload. + * + */ +struct pso4 { + struct pso_header header; + union { + char bytes[112]; + uint64_t words[14]; + struct free_payload free; + struct stack_frame_payload stack_frame; + } payload; +}; + +#endif diff --git a/src/c/memory/pso5.h b/src/c/memory/pso5.h new file mode 100644 index 0000000..585332c --- /dev/null +++ b/src/c/memory/pso5.h @@ -0,0 +1,32 @@ +/** + * memory/pso5.h + * + * Paged space object of size class 5, 32 words total, 30 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso5_h +#define __psse_memory_pso5_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class 5, 32 words total, 30 words + * payload. + * + */ +struct pso5 { + struct pso_header header; + union { + char bytes[240]; + uint64_t words[30]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/pso6.h b/src/c/memory/pso6.h new file mode 100644 index 0000000..3bd9290 --- /dev/null +++ b/src/c/memory/pso6.h @@ -0,0 +1,32 @@ +/** + * memory/pso6.h + * + * Paged space object of size class 6, 64 words total, 62 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso6_h +#define __psse_memory_pso6_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class 6, 64 words total, 62 words + * payload. + * + */ +struct pso6 { + struct pso_header header; + union { + char bytes[496]; + uint64_t words[62]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/pso7.h b/src/c/memory/pso7.h new file mode 100644 index 0000000..04ee61b --- /dev/null +++ b/src/c/memory/pso7.h @@ -0,0 +1,32 @@ +/** + * memory/pso7.h + * + * Paged space object of size class 7, 128 words total, 126 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso7_h +#define __psse_memory_pso7_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class 7, 128 words total, 126 words + * payload. + * + */ +struct pso7 { + struct pso_header header; + union { + char bytes[1008]; + uint64_t words[126]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/pso8.h b/src/c/memory/pso8.h new file mode 100644 index 0000000..b3a00bc --- /dev/null +++ b/src/c/memory/pso8.h @@ -0,0 +1,32 @@ +/** + * memory/pso8.h + * + * Paged space object of size class 8, 256 words total, 254 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso8_h +#define __psse_memory_pso8_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class 8, 256 words total, 254 words + * payload. + * + */ +struct pso8 { + struct pso_header header; + union { + char bytes[2032]; + uint64_t words[254]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/pso9.h b/src/c/memory/pso9.h new file mode 100644 index 0000000..3fa5eab --- /dev/null +++ b/src/c/memory/pso9.h @@ -0,0 +1,32 @@ +/** + * memory/pso9.h + * + * Paged space object of size class 9, 512 words total, 510 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_pso9_h +#define __psse_memory_pso9_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class 9, 512 words total, 510 words + * payload. + * + */ +struct pso9 { + struct pso_header header; + union { + char bytes[4080]; + uint64_t words[510]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psoa.h b/src/c/memory/psoa.h new file mode 100644 index 0000000..1c8e9c7 --- /dev/null +++ b/src/c/memory/psoa.h @@ -0,0 +1,32 @@ +/** + * memory/psoa.h + * + * Paged space object of size class a, 1024 words total, 1022 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoa_h +#define __psse_memory_psoa_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class a, 1024 words total, 1022 words + * payload. + * + */ +struct psoa { + struct pso_header header; + union { + char bytes[8176]; + uint64_t words[1022]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psob.h b/src/c/memory/psob.h new file mode 100644 index 0000000..d6b235a --- /dev/null +++ b/src/c/memory/psob.h @@ -0,0 +1,32 @@ +/** + * memory/psob.h + * + * Paged space object of size class b, 2048 words total, 2046 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psob_h +#define __psse_memory_psob_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class b, 2048 words total, 2046 words + * payload. + * + */ +struct psob { + struct pso_header header; + union { + char bytes[16368]; + uint64_t words[2046]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psoc.h b/src/c/memory/psoc.h new file mode 100644 index 0000000..934c8b3 --- /dev/null +++ b/src/c/memory/psoc.h @@ -0,0 +1,32 @@ +/** + * memory/psoc.h + * + * Paged space object of size class c, 4096 words total, 4094 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoc_h +#define __psse_memory_psoc_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class c, 4096 words total, 4094 words + * payload. + * + */ +struct psoc { + struct pso_header header; + union { + char bytes[32752]; + uint64_t words[4094]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psod.h b/src/c/memory/psod.h new file mode 100644 index 0000000..5ed7711 --- /dev/null +++ b/src/c/memory/psod.h @@ -0,0 +1,32 @@ +/** + * memory/psod.h + * + * Paged space object of size class d, 8192 words total, 8190 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psod_h +#define __psse_memory_psod_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class d, 8192 words total, 8190 words + * payload. + * + */ +struct psod { + struct pso_header header; + union { + char bytes[65520]; + uint64_t words[8190]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psoe.h b/src/c/memory/psoe.h new file mode 100644 index 0000000..5f2b619 --- /dev/null +++ b/src/c/memory/psoe.h @@ -0,0 +1,32 @@ +/** + * memory/psoe.h + * + * Paged space object of size class e, 16384 words total, 16382 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psoe_h +#define __psse_memory_psoe_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class e, 16384 words total, 16382 words + * payload. + * + */ +struct psoe { + struct pso_header header; + union { + char bytes[131056]; + uint64_t words[16382]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/memory/psof.h b/src/c/memory/psof.h new file mode 100644 index 0000000..58615de --- /dev/null +++ b/src/c/memory/psof.h @@ -0,0 +1,32 @@ +/** + * memory/psof.h + * + * Paged space object of size class f, 32768 words total, 32766 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_psof_h +#define __psse_memory_psof_h + +#include + +#include "memory/header.h" +#include "payloads/free.h" + +/** + * @brief A paged space object of size class f, 32768 words total, 32766 words + * payload. + * + */ +struct psof { + struct pso_header header; + union { + char bytes[262128]; + uint64_t words[32766]; + struct free_payload free; + } payload; +}; + +#endif diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 2ef45c4..2f43bef 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -11,7 +11,7 @@ #define __psse_payloads_function_h #include "memory/pointer.h" -#include "memory/pso.h" +#include "memory/pso4.h" /** * @brief Tag for an ordinary Lisp function - one whose arguments are pre-evaluated. @@ -41,7 +41,7 @@ struct function_payload { * a cons pointer (representing its result). * \todo check this documentation is current! */ - struct pso_pointer ( *executable ) ( struct pso4 *, + struct pso_pointer ( *executable ) ( struct pso4*, struct pso_pointer, struct pso_pointer ); }; diff --git a/src/c/payloads/hashtable.h b/src/c/payloads/hashtable.h index 86664e5..3619847 100644 --- a/src/c/payloads/hashtable.h +++ b/src/c/payloads/hashtable.h @@ -45,11 +45,11 @@ * i.e. either an assoc list or a further hashtable. */ struct hashtable_payload { - struct cons_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use + struct pso_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use the default hashing function */ uint32_t n_buckets; /* number of hash buckets */ - struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` * or assoc lists or (possibly) further hashtables. */ }; -#endif \ No newline at end of file +#endif diff --git a/src/c/payloads/namespace.h b/src/c/payloads/namespace.h index b494e93..bb1b1b3 100644 --- a/src/c/payloads/namespace.h +++ b/src/c/payloads/namespace.h @@ -48,17 +48,17 @@ * i.e. either an assoc list or a further namespace. */ struct namespace_payload { - struct cons_pointer hash_fn; /* function for hashing values in this namespace, or + struct pso_pointer hash_fn; /* function for hashing values in this namespace, or * `NIL` to use the default hashing function */ uint32_t n_buckets; /* number of hash buckets */ uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer write_acl; /* it seems to me that it is likely that the + struct pso_pointer write_acl; /* it seems to me that it is likely that the * principal difference between a hashtable and a * namespace is that a hashtable has a write ACL * of `NIL`, meaning not writeable by anyone */ - struct cons_pointer mutex; /* the mutex to lock when modifying this namespace.*/ - struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + struct pso_pointer mutex; /* the mutex to lock when modifying this namespace.*/ + struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` * or assoc lists or (possibly) further hashtables. */ }; -#endif \ No newline at end of file +#endif diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index e271489..ef2f5cc 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -14,6 +14,7 @@ #include +#include "io/fopen.h" #include "memory/pointer.h" /** @@ -31,7 +32,7 @@ struct stream_payload { /** metadata on the stream (e.g. its file attributes if a file, its HTTP * headers if a URL, etc). Expected to be an association, or nil. Not yet * implemented. */ - struct cons_pointer meta; + struct pso_pointer meta; }; #endif diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index 4c64545..4dcf7c2 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -11,6 +11,7 @@ #define __psse_payloads_special_h #include "memory/pointer.h" +#include "memory/pso4.h" /** * A special form - one whose arguments are not pre-evaluated but passed as @@ -20,25 +21,25 @@ #define SPECIALTAG "SFM" #define SPECIALTV 5064275 -/** - * @brief Payload of a special form cell. - * - * Currently identical to the payload of a function cell. - * \see function_payload - */ -struct special_payload { - /** - * pointer to the source from which the special form was compiled, or NIL - * if it is a primitive. - */ - struct pso_pointer meta; - /** pointer to a function which takes a cons pointer (representing - * its argument list) and a cons pointer (representing its environment) and a - * stack frame (representing the previous stack frame) as arguments and returns - * a cons pointer (representing its result). */ - struct pso_pointer ( *executable ) ( struct pso4 *, - struct pso_pointer, - struct pso_pointer ); -}; +// /** +// * @brief Payload of a special form cell. +// * +// * Currently identical to the payload of a function cell. +// * \see function_payload +// */ +// struct special_payload { +// /** +// * pointer to the source from which the special form was compiled, or NIL +// * if it is a primitive. +// */ +// struct pso_pointer meta; +// /** pointer to a function which takes a cons pointer (representing +// * its argument list) and a cons pointer (representing its environment) and a +// * stack frame (representing the previous stack frame) as arguments and returns +// * a cons pointer (representing its result). */ +// struct pso_pointer ( *executable ) ( struct pso4*, +// struct pso_pointer, +// struct pso_pointer ); +// }; #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index a814699..484c13d 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -11,6 +11,9 @@ #include "memory/pso.h" #include "payloads/stack.h" +#define STACKTAG "STK" +#define STACKTV 4936787 + /** * @brief The maximum depth of stack before we throw an exception. * diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index ba0abd8..23fb8e5 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,6 +13,8 @@ #define __psse_payloads_stack_h #include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/pso4.h" /* * number of arguments stored in a stack frame diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index d9870b4..fd67716 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -10,6 +10,8 @@ #ifndef __psse_payloads_cons_h #define __psse_payloads_cons_h +#include + #include "memory/pointer.h" /** diff --git a/src/c/payloads/vector_pointer.h b/src/c/payloads/vector_pointer.h index b5e5f1c..8fda0f3 100644 --- a/src/c/payloads/vector_pointer.h +++ b/src/c/payloads/vector_pointer.h @@ -16,6 +16,7 @@ * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VSP" +#define VECTORPOINTTV 5264214 /** * @brief payload of a vector pointer cell. diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index deda598..1197d73 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -10,6 +10,7 @@ #ifndef __psse_payloads_write_stream_h #define __psse_payloads_write_stream_h +#include "io/fopen.h" #include "memory/pointer.h" /** From 04bf001652864981a6d7819299ff1d875c8a4fd9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 29 Mar 2026 12:03:31 +0100 Subject: [PATCH 17/29] Progress, but it still doesn't build. I think I'm close, now... --- src/c/debug.h | 5 +++++ src/c/memory/header.h | 2 +- src/c/memory/memory.h | 2 +- src/c/memory/page.c | 36 +++++++++++++++++++----------------- src/c/memory/page.h | 38 +++++++++++++++++++++----------------- src/c/memory/pso2.h | 4 ++-- src/c/payloads/cons.c | 1 + src/c/payloads/stack.c | 6 ++---- src/c/payloads/stack.h | 5 +++-- src/c/payloads/time.h | 2 +- src/c/psse.c | 2 +- src/c/psse.h | 2 +- 12 files changed, 58 insertions(+), 47 deletions(-) diff --git a/src/c/debug.h b/src/c/debug.h index dc833dd..1f66a9f 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -17,6 +17,11 @@ #include #include +/* + * wide characters + */ +#include +#include /** * @brief Print messages debugging memory allocation. diff --git a/src/c/memory/header.h b/src/c/memory/header.h index 429cda1..42fa488 100644 --- a/src/c/memory/header.h +++ b/src/c/memory/header.h @@ -29,7 +29,7 @@ struct pso_header { char mnemonic[TAGLENGTH]; /** size class for this object */ uint8_t size_class; - } tag; + } bytes; /** the tag considered as a number */ uint32_t value; } tag; diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index fc242c2..33e9d39 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -21,7 +21,7 @@ * since managed objects require a two word header; it's unlikely that * these undersized size classes will be used at all. */ -#define MAX_SIZE_CLASS = 0xf +#define MAX_SIZE_CLASS 0xf int initialise_memory( ); diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 1486301..2fdaf79 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -9,7 +9,10 @@ #include #include +#include +#include +#include "debug.h" #include "memory/memory.h" #include "memory/node.h" #include "memory/page.h" @@ -36,13 +39,13 @@ * to hold the number of pages we *might* create at start up time. We need a * way to grow the number of pages, while keeping access to them cheap. */ -struct page * pages[NPAGES]; +union page * pages[NPAGES]; /** * @brief the number of pages which have thus far been allocated. * */ -uint32_t npages_allocated = 0 +uint32_t npages_allocated = 0; /** * @brief private to allocate_page; do not use. @@ -51,10 +54,11 @@ uint32_t npages_allocated = 0 * @param page_index its location in the pages[] array; * @param size_class the size class of objects in this page; * @param freelist the freelist for objects of this size class. - * @return struct cons_pointer the new head for the freelist for this size_class, + * @return struct pso_pointer the new head for the freelist for this size_class, */ -struct cons_pointer initialise_page( struct page * page_addr, uint16_t page_index, uint8_t size_class, pso_pointer freelist) { - struct cons_pointer result = freelist; +struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, + uint8_t size_class, struct pso_pointer freelist) { + struct pso_pointer result = freelist; int obj_size = pow(2, size_class); int obj_bytes = obj_size * sizeof(uint64_t); int objs_in_page = PAGE_BYTES/obj_bytes; @@ -64,16 +68,14 @@ struct cons_pointer initialise_page( struct page * page_addr, uint16_t page_inde // `nil` and the next on for `t`. for (int i = objs_in_page - 1; i >= 0; i--) { // it should be safe to cast any pso object to a pso2 - struct pso2* object = (pso2 *)(page_addr + (i * obj_bytes)); + struct pso2* object = (struct pso2 *)(page_addr + (i * obj_bytes)); - object->header.tag.size_class = size_class; - strncpy( (char *)(object->header.tag.mnemonic), FREETAG, TAGLENGTH); + object->header.tag.bytes.size_class = size_class; + strncpy( (char *)(object->header.tag.bytes.mnemonic), FREETAG, TAGLENGTH); object->payload.free.next = result; result = make_pointer( node_index, page_index, (uint16_t)( i * obj_size)); } - - return result; } /** @@ -89,8 +91,8 @@ struct cons_pointer initialise_page( struct page * page_addr, uint16_t page_inde * @param size_class an integer in the range 0...MAX_SIZE_CLASS. * @return t on success, an exception if an error occurred. */ -struct cons_pointer allocate_page( uint8_t size_class ) { - struct cons_pointer result = t; +struct pso_pointer allocate_page( uint8_t size_class ) { + struct pso_pointer result = t; if ( npages_allocated == 0) { for (int i = 0; i < NPAGES; i++) { @@ -101,17 +103,17 @@ struct cons_pointer allocate_page( uint8_t size_class ) { if ( npages_allocated < NPAGES) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { - result = malloc( sizeof( page ) ); + void* pg = malloc( sizeof( union page ) ); - if ( result != NULL ) { - memset( result, 0, sizeof( page ) ); - pages[ npages_allocated] = result; + if ( pg != NULL ) { + memset( pg, 0, sizeof( union page ) ); + pages[ npages_allocated] = pg; debug_printf( DEBUG_ALLOC, 0, L"Allocated page %d for objects of size class %x.\n", npages_allocated, size_class); freelists[size_class] = - initialise_page( result, npages_allocated, size_class, freelists[size_class] ); + initialise_page( (union page*)pg, npages_allocated, size_class, freelists[size_class] ); debug_printf( DEBUG_ALLOC, 0, L"Initialised page %d; freelist for size class %x updated.\n", diff --git a/src/c/memory/page.h b/src/c/memory/page.h index 522b2fa..b5285f5 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -10,6 +10,7 @@ #ifndef __psse_memory_page_h #define __psse_memory_page_h +#include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" @@ -38,7 +39,7 @@ */ #define NPAGES 64 -extern struct page *pages[NPAGES]; +extern union page *pages[NPAGES]; /** * @brief A page is a megabyte of memory which contains objects all of which @@ -53,22 +54,25 @@ extern struct page *pages[NPAGES]; * collection they will be returned to that freelist. */ union page { - uint8_t[PAGE_BYTES] bytes; - uint64_t[PAGE_BYTES / 8] words; - struct pso2[PAGE_BYTES / 32] pso2s; - struct pso3[PAGE_BYTES / 64] pso3s; - struct pso4[PAGE_BYTES / 128] pso4s; - struct pso5[PAGE_BYTES / 256] pso5s; - struct pso6[PAGE_BYTES / 512] pso6s; - struct pso7[PAGE_BYTES / 1024] pso7s; - struct pso8[PAGE_BYTES / 2048] pso8s; - struct pso9[PAGE_BYTES / 4096] pso9s; - struct psoa[PAGE_BYTES / 8192] psoas; - struct psob[PAGE_BYTES / 16384] psobs; - struct psoc[PAGE_BYTES / 32768] psocs; - struct psod[PAGE_BYTES / 65536] psods; - struct psoe[PAGE_BYTES / 131072] psoes; - struct psof[PAGE_BYTES / 262144] psofs; + uint8_t bytes[PAGE_BYTES]; + uint64_t words[PAGE_BYTES / 8]; + struct pso2 pso2s[PAGE_BYTES / 32]; + struct pso3 pso3s[PAGE_BYTES / 64]; + struct pso4 pso4s[PAGE_BYTES / 128]; + struct pso5 pso5s[PAGE_BYTES / 256]; + struct pso6 pso6s[PAGE_BYTES / 512]; + struct pso7 pso7s[PAGE_BYTES / 1024]; + struct pso8 pso8s[PAGE_BYTES / 2048]; + struct pso9 pso9s[PAGE_BYTES / 4096]; + struct psoa psoas[PAGE_BYTES / 8192]; + struct psob psobs[PAGE_BYTES / 16384]; + struct psoc psocs[PAGE_BYTES / 32768]; + struct psod psods[PAGE_BYTES / 65536]; + struct psoe psoes[PAGE_BYTES / 131072]; + struct psof psofs[PAGE_BYTES / 262144]; }; +struct pso_pointer initialise_page( union page * page_addr, uint16_t page_index, + uint8_t size_class, struct pso_pointer freelist); + #endif diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 9e838c4..e8305d0 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -24,7 +24,7 @@ #include "payloads/special.h" #include "payloads/string.h" #include "payloads/symbol.h" -#include "payloads/time.h" +// #include "payloads/time.h" #include "payloads/vector_pointer.h" #include "payloads/write_stream.h" @@ -45,7 +45,7 @@ struct pso2 { struct lambda_payload lambda; // struct special_payload special; struct stream_payload stream; - struct time_payload time; +// struct time_payload time; struct vectorp_payload vectorp; } payload; }; diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 5eaf2b6..6a002c8 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -12,6 +12,7 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso2.h" #include "payloads/cons.h" /** diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 484c13d..5cb2113 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -8,12 +8,10 @@ */ #include "memory/node.h" -#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso4.h" #include "payloads/stack.h" -#define STACKTAG "STK" -#define STACKTV 4936787 - /** * @brief The maximum depth of stack before we throw an exception. * diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 23fb8e5..4225dbc 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,8 +13,9 @@ #define __psse_payloads_stack_h #include "memory/pointer.h" -#include "memory/pso2.h" -#include "memory/pso4.h" + +#define STACKTAG "STK" +#define STACKTV 4936787 /* * number of arguments stored in a stack frame diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index fd67716..cc1ef0a 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -26,7 +26,7 @@ * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch)) */ struct time_payload { - unsigned __int128 value; + unsigned __int128_t value; }; #endif diff --git a/src/c/psse.c b/src/c/psse.c index 5c67b6f..5f5f2fb 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -99,7 +99,7 @@ int main( int argc, char *argv[] ) { initialise_node( 0 ); - repl( ); + // repl( ); exit( 0 ); } diff --git a/src/c/psse.h b/src/c/psse.h index 0c57020..0fe9b43 100644 --- a/src/c/psse.h +++ b/src/c/psse.h @@ -24,7 +24,7 @@ #include "debug.h" #include "memory/memory.h" -#include "memory/stack.h" +#include "payloads/stack.h" #include "version.h" #endif From 1ce9fbda774380cb760f9e4b25e9c535545e6a5e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 29 Mar 2026 17:25:08 +0100 Subject: [PATCH 18/29] Still not fixed... --- src/c/memory/page.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 2fdaf79..7e28524 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -71,11 +71,13 @@ struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, struct pso2* object = (struct pso2 *)(page_addr + (i * obj_bytes)); object->header.tag.bytes.size_class = size_class; - strncpy( (char *)(object->header.tag.bytes.mnemonic), FREETAG, TAGLENGTH); + strncpy( &(object->header.tag.bytes.mnemonic[0]), FREETAG, TAGLENGTH); object->payload.free.next = result; result = make_pointer( node_index, page_index, (uint16_t)( i * obj_size)); } + + return result; } /** From 60921be3d499f25d4b0444fa70ef74a328b272f1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 30 Mar 2026 09:35:34 +0100 Subject: [PATCH 19/29] Much more progress, still doesn't compile. --- src/c/environment/environment.c | 36 +++++++++ src/c/environment/environment.h | 15 ++++ src/c/io/fopen.h | 83 +++++++++++++++++++ src/c/memory/header.h | 2 + src/c/memory/memory.c | 37 +++++++-- src/c/memory/memory.h | 2 +- src/c/memory/node.c | 21 ++--- src/c/memory/node.h | 1 + src/c/memory/page.c | 9 +-- src/c/memory/page.h | 3 +- src/c/memory/pointer.c | 16 ++-- src/c/memory/pso.c | 92 +++++++++++++++------- src/c/memory/pso.h | 4 +- src/c/memory/pso2.h | 2 +- src/c/ops/eq.c | 8 +- src/c/ops/eq.h | 6 +- src/c/ops/eval.c | 12 +-- src/c/ops/truth.c | 14 ++-- src/c/ops/truth.h | 12 +-- src/c/payloads/exception.c | 13 +++ src/c/payloads/exception.h | 2 + src/c/payloads/{string.h => psse-string.h} | 0 src/c/payloads/stack.h | 3 + src/c/payloads/vector_pointer.c | 18 +++++ src/c/payloads/vector_pointer.h | 4 + 25 files changed, 326 insertions(+), 89 deletions(-) create mode 100644 src/c/environment/environment.c create mode 100644 src/c/environment/environment.h create mode 100644 src/c/io/fopen.h create mode 100644 src/c/payloads/exception.c rename src/c/payloads/{string.h => psse-string.h} (100%) create mode 100644 src/c/payloads/vector_pointer.c diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c new file mode 100644 index 0000000..f7ec199 --- /dev/null +++ b/src/c/environment/environment.c @@ -0,0 +1,36 @@ +/** + * environment/environment.c + * + * Initialise a MINIMAL environment. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" + +/** + * @brief Flag to prevent re-initialisation. + */ +bool environment_initialised = false; + +/** + * @brief Initialise a minimal environment, so that Lisp can be bootstrapped. + * + * @param node theindex of the node we are initialising. + * @return struct pso_pointer t on success, else an exception. + */ + +struct pso_pointer initialise_environment( uint32_t node) { + struct pso_pointer result = t; + if (environment_initialised) { + // TODO: throw an exception "Attempt to reinitialise environment" + } else { + // TODO: actually initialise it. + } + + return result; +} \ No newline at end of file diff --git a/src/c/environment/environment.h b/src/c/environment/environment.h new file mode 100644 index 0000000..87a40aa --- /dev/null +++ b/src/c/environment/environment.h @@ -0,0 +1,15 @@ +/** + * environment/environment.h + * + * Initialise a MINIMAL environment. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_environment_environment_h +#define __psse_environment_environment_h + +struct pso_pointer initialise_environment( uint32_t node); + +#endif \ No newline at end of file diff --git a/src/c/io/fopen.h b/src/c/io/fopen.h new file mode 100644 index 0000000..5f87bd2 --- /dev/null +++ b/src/c/io/fopen.h @@ -0,0 +1,83 @@ +/* + * fopen.h + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#ifndef __fopen_h +#define __fopen_h +#include +/* + * wide characters + */ +#include +#include + +#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1) +#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0) +#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0) + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data { + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data */ + size_t buffer_len; /* currently allocated buffer's length */ + size_t buffer_pos; /* cursor into in buffer */ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); + +#endif diff --git a/src/c/memory/header.h b/src/c/memory/header.h index 42fa488..c470074 100644 --- a/src/c/memory/header.h +++ b/src/c/memory/header.h @@ -16,6 +16,8 @@ #define TAGLENGTH 3 +#define MAXREFERENCE 4294967295 + /** * @brief Header for all paged space objects. * diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 85754bc..530d3e6 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -7,20 +7,41 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include +#include "memory/memory.h" +#include "memory/node.h" +#include "memory/pointer.h" + /** * @brief Freelists for each size class. - * - * TODO: I don't know if that +1 is needed, my mind gets confused by arrays - * indexed from zero. But it does little harm. */ -struct pso_pointer freelists[MAX_SIZE_CLASS + 1]; +struct pso_pointer freelists[MAX_SIZE_CLASS]; +/** + * @brief Flag to prevent re-initialisation. + */ +bool memory_initialised = false; -int initialise_memory( int node ) { - for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { - freelists[i] = nil; +/** + * @brief Initialise the memory allocation system. + * + * Essentially, just set up the freelists; allocating pages will then happen + * automatically as objects are requested. + * + * @param node the index number of the node we are initialising. + * @return int + */ +struct pso_pointer initialise_memory( uint32_t node ) { + if (memory_initialised) { + // TODO: throw an exception + } else { + for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { + freelists[i] = nil; + } + memory_initialised = true; } - + + return t; } diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index 33e9d39..5911f2f 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -23,7 +23,7 @@ */ #define MAX_SIZE_CLASS 0xf -int initialise_memory( ); +struct pso_pointer initialise_memory( ); extern struct pso_pointer out_of_memory_exception; extern struct pso_pointer freelists[]; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 81f6aea..84228c4 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -12,9 +12,10 @@ #include -#include "ops/equal.h" -#include "memory.h" -#include "pointer.h" +#include "environment/environment.h" +#include "memory/memory.h" +#include "memory/pointer.h" +#include "ops/eq.h" /** * @brief Flag to prevent the node being initialised more than once. @@ -31,17 +32,19 @@ bool node_initialised = false; */ uint32_t node_index = 0; + /** * @brief The canonical `nil` pointer - * + * */ -struct pso_pointer nil = struct pso_pointer { 0, 0, 0 }; +struct pso_pointer nil = (struct pso_pointer) { 0, 0, 0}; /** * @brief the canonical `t` (true) pointer. - * + * */ -struct pso_pointer t = struct pso_pointer { 0, 0, 1 }; +struct pso_pointer t = (struct pso_pointer) { 0, 0, 1 }; + /** * @brief Set up the basic informetion about this node. @@ -51,10 +54,8 @@ struct pso_pointer t = struct pso_pointer { 0, 0, 1 }; */ struct pso_pointer initialise_node( uint32_t index ) { node_index = index; - nil = pso_pointer { index, 0, 0}; - t = pso_pointer( index, 0, 1 ); - pso_pointer result = initialise_memory( index ); + struct pso_pointer result = initialise_memory( index ); if ( eq( result, t ) ) { result = initialise_environment( index ); diff --git a/src/c/memory/node.h b/src/c/memory/node.h index fbc177a..1e94956 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -34,3 +34,4 @@ extern struct pso_pointer t; struct pso_pointer initialise_node( uint32_t index ); #endif + diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 7e28524..eb424e7 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -8,10 +8,9 @@ */ #include +#include #include #include -#include - #include "debug.h" #include "memory/memory.h" #include "memory/node.h" @@ -84,12 +83,6 @@ struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, * @brief Allocate a page for objects of this size class, initialise it, and * link the objects in it into the freelist for this size class. * - * Because we can't return an exception at this low level, and because there - * are multiple possible causes of failure, for the present this function will - * print errors to stderr. We cast the error stream to wide, since we've - * probably (but not certainly) already cast it to wide, and we can't reliably - * cast it back. - * * @param size_class an integer in the range 0...MAX_SIZE_CLASS. * @return t on success, an exception if an error occurred. */ diff --git a/src/c/memory/page.h b/src/c/memory/page.h index b5285f5..ba64d38 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -72,7 +72,6 @@ union page { struct psof psofs[PAGE_BYTES / 262144]; }; -struct pso_pointer initialise_page( union page * page_addr, uint16_t page_index, - uint8_t size_class, struct pso_pointer freelist); +struct pso_pointer allocate_page( uint8_t size_class ); #endif diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 8a47439..5c46540 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -1,13 +1,16 @@ /** - * memory/pointer.h + * memory/node.h * - * A pointer to a paged space object. + * The node on which this instance resides. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include + #include "memory/node.h" +#include "memory/page.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -20,7 +23,7 @@ * @return struct pso_pointer a pointer referencing the specified object. */ struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset) { - return struct pso_pointer{ node, page, pointer}; + return (struct pso_pointer){ node, page, offset}; } /** @@ -37,11 +40,12 @@ struct pso2* pointer_to_object( struct pso_pointer pointer) { struct pso2* result = NULL; if ( pointer.node == node_index) { - result = (struct pso2*) &(pages[pointer.node] + (pointer.offset * sizeof( uint64_t))); - } + union page* pg = pages[pointer.page]; + result = (struct pso2*) &pg->words[pointer.offset]; + } // TODO: else if we have a copy of the object in cache, return that; // else request a copy of the object from the node which curates it. return result; } - \ No newline at end of file + diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index f76890d..c4fc711 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -14,9 +14,17 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #include "memory/page.h" - #include "memory/pointer.h" - #include "memory/pso.h" +#include +#include + +#include "debug.h" +#include "memory/header.h" +#include "memory/memory.h" +#include "memory/node.h" +#include "memory/page.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "ops/truth.h" /** * @brief Allocate an object of this size_class with this tag. @@ -29,8 +37,8 @@ struct pso_pointer allocate( char* tag, uint8_t size_class) { struct pso_pointer result = nil; if (size_class <= MAX_SIZE_CLASS) { - if (freelists[size_class] == nil) { - result = allocate_page(size_class) + if (nilp( freelists[size_class])) { + result = allocate_page(size_class); } if ( !exceptionp( result) && not( freelists[size_class] ) ) { @@ -38,16 +46,16 @@ struct pso_pointer allocate( char* tag, uint8_t size_class) { struct pso2* object = pointer_to_object( result); freelists[size_class] = object->payload.free.next; - strncpy( (char *)(object->header.tag.mnemonic), tag, TAGLENGTH); + strncpy( (char *)(object->header.tag.bytes.mnemonic), tag, TAGLENGTH); /* the object ought already to have the right size class in its tag * because it was popped off the freelist for that size class. */ - if ( object->header.tag.size_class != size_class) { + if ( object->header.tag.bytes.size_class != size_class) { // TODO: return an exception instead? Or warn, set it, and continue? } /* the objext ought to have a reference count ot zero, because it's * on the freelist, but again we should sanity check. */ - if ( object->header.header.count != 0) { + if ( object->header.count != 0) { // TODO: return an exception instead? Or warn, set it, and continue? } @@ -57,6 +65,28 @@ struct pso_pointer allocate( char* tag, uint8_t size_class) { return result; } +uint32_t payload_size( struct pso2* object) { + // TODO: Unit tests DEFINITELY needed! + return ((1 << object->header.tag.bytes.size_class) - sizeof( struct pso_header)); +} + +void free_cell( struct pso_pointer p) { + struct pso2* p2 = pointer_to_object( p); + uint32_t array_size = payload_size(p2); + uint8_t size_class = p2->header.tag.bytes.size_class; + + strncpy( (char *)(p2->header.tag.bytes.mnemonic), FREETAG, TAGLENGTH); + + /* will C just let me cheerfully walk off the end of the array I've declared? */ + for (int i = 0; i < array_size; i++) { + p2->payload.words[i] = 0; + } + + /* TODO: obtain mutex on freelist */ + p2->payload.free.next = freelists[size_class]; + freelists[size_class] = p; +} + /** * increment the reference count of the object at this cons pointer. * @@ -71,14 +101,14 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { if ( object->header.count < MAXREFERENCE ) { object->header.count++; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, - L"\nIncremented object of type %4.4s at page %u, offset %u to count %u", - ( ( char * ) object->header.tag.bytes ), pointer.page, + debug_printf( DEBUG_ALLOC, 0, + L"\nIncremented object of type %3.3s at page %u, offset %u to count %u", + ( ( char * ) &object->header.tag.bytes.mnemonic[0] ), pointer.page, pointer.offset, object->header.count ); - if ( strncmp( object->header.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { - debug_printf( DEBUG_ALLOC, - L"; pointer to vector object of type %4.4s.\n", - ( ( char * ) ( object->header.payload.vectorp.tag.bytes ) ) ); + if ( vectorpointp( pointer) ) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) &( object->payload.vectorp.tag.bytes[0] ) ) ); } else { debug_println( DEBUG_ALLOC ); } @@ -99,18 +129,17 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { struct pso_pointer dec_ref( struct pso_pointer pointer ) { struct pso2 *object = pointer_to_object( pointer ); - if ( object->count > 0 && object->count != MAXREFERENCE ) { - object->count--; + if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) { + object->header.count--; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, + debug_printf( DEBUG_ALLOC, 0, L"\nDecremented object of type %4.4s at page %d, offset %d to count %d", - ( ( char * ) object->tag.bytes ), pointer.page, - pointer.offset, object->count ); - if ( strncmp( ( char * ) object->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) - == 0 ) { - debug_printf( DEBUG_ALLOC, - L"; pointer to vector object of type %4.4s.\n", - ( ( char * ) ( object->payload.vectorp.tag.bytes ) ) ); + ( ( char * ) (object->header.tag.bytes.mnemonic )), pointer.page, + pointer.offset, object->header.count ); + if ( vectorpointp( pointer)) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) &( object->payload.vectorp.tag.bytes ) ) ); } else { debug_println( DEBUG_ALLOC ); } @@ -118,7 +147,7 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { if ( object->header.count == 0 ) { free_cell( pointer ); - pointer = NIL; + pointer = nil; } } @@ -133,7 +162,7 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { void lock_object( struct pso_pointer pointer) { struct pso2* object = pointer_to_object( pointer ); - object->header.header.count = MAXREFERENCE; + object->header.count = MAXREFERENCE; } @@ -145,9 +174,12 @@ void lock_object( struct pso_pointer pointer) { * @return the tag value of the object indicated. */ uint32_t get_tag_value( struct pso_pointer pointer) { - result = (pointer_to_object( pointer)->tag.value & 0xffffff; + struct pso2* object = pointer_to_object( pointer); + uint32_t result = (object->header.tag.value & 0xffffff); - // TODO: deal with the vector pointer issue + if (vectorpointp( pointer)) { + result = (object->payload.vectorp.tag.value & 0xffffff); + } return result; -} \ No newline at end of file +} diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 5f91bca..1ce7bf2 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -251,4 +251,6 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ); void lock_object( struct pso_pointer pointer); -#endif \ No newline at end of file +uint32_t get_tag_value( struct pso_pointer pointer); + +#endif diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index e8305d0..4cbad4a 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -12,6 +12,7 @@ #include +#include "../payloads/psse-string.h" #include "memory/header.h" #include "payloads/cons.h" #include "payloads/free.h" @@ -22,7 +23,6 @@ #include "payloads/nlambda.h" #include "payloads/read_stream.h" #include "payloads/special.h" -#include "payloads/string.h" #include "payloads/symbol.h" // #include "payloads/time.h" #include "payloads/vector_pointer.h" diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index d5f7228..9830b96 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -10,8 +10,10 @@ */ #include "memory/memory.h" +#include "memory/node.h" #include "memory/pointer.h" -#include "memory/stack.h" +#include "payloads/stack.h" +#include "ops/truth.h" /** * @brief Function; do these two pointers point to the same object? @@ -41,14 +43,14 @@ bool eq( struct pso_pointer a, struct pso_pointer b ) { * @param env my environment (ignored). * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer lisp_eq( struct stack_frame *frame, +struct pso_pointer lisp_eq( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso_pointer result = t; if ( frame->args > 1 ) { for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? t : nil; + result = eq( fetch_arg(frame, 0), fetch_arg( frame, b ) ) ? t : nil; } } diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 204c297..ca330f4 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -11,10 +11,14 @@ #ifndef __psse_ops_eq_h #define __psse_ops_eq_h +#include + +#include "memory/pointer.h" +#include "memory/pso4.h" bool eq( struct pso_pointer a, struct pso_pointer b ); -struct pso_pointer lisp_eq( struct stack_frame *frame, +struct pso_pointer lisp_eq( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index c5d7a35..5e20b71 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -9,14 +9,16 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "memory/pointer" -#include "memory/stack.h" +#include "memory/pointer.h" +#include "memory/pso4.h" #include "payloads/cons.h" +#include "payloads/exception.h" #include "payloads/function.h" #include "payloads/keyword.h" #include "payloads/lambda.h" #include "payloads/nlambda.h" #include "payloads/special.h" +#include "payloads/stack.h" /** * @brief Despatch eval based on tag of the form in the first position. @@ -26,10 +28,10 @@ * @param env the evaluation environment. * @return struct pso_pointer */ -struct pso_pointer eval_despatch( struct stack_frame *frame, +struct pso_pointer eval_despatch( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ) { - struct pso_pointer result = frame->arg[0]; + struct pso_pointer result = frame->payload.stack_frame.arg[0]; // switch ( get_tag_value( result)) { // case CONSTV: @@ -53,7 +55,7 @@ struct pso_pointer eval_despatch( struct stack_frame *frame, return result; } -struct pso_pointer lisp_eval( struct stack_frame *frame, +struct pso_pointer lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso_pointer result = eval_despatch( frame, frame_pointer, env ); diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 631f38d..8e10dd6 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -58,10 +58,10 @@ bool truep( struct pso_pointer p) { * @param env the evaluation environment. * @return `t` if the first argument in this frame is `nil`, else `t` */ -pso_pointer lisp_nilp( struct stack_frame *frame, +pso_pointer lisp_nilp( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ){ - return (nilp(frame->arg[0]) ? t : nil); + return (nilp(frame->payload.stack_frame.arg[0]) ? t : nil); } /** @@ -72,10 +72,10 @@ pso_pointer lisp_nilp( struct stack_frame *frame, * @param env the evaluation environment. * @return `t` if the first argument in this frame is `t`, else `nil`. */ -pso_pointer lisp_truep( struct stack_frame *frame, +pso_pointer lisp_truep( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ){ - return (truep(frame->arg[0]) ? t : nil); + return (truep(frame->payload.stack_frame.arg[0]) ? t : nil); } /** @@ -87,8 +87,8 @@ pso_pointer lisp_truep( struct stack_frame *frame, * @param env the evaluation environment. * @return `t` if the first argument in this frame is not `nil`, else `t`. */ -pso_pointer lisp_not( struct stack_frame *frame, +pso_pointer lisp_not( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ){ - return (not(frame->arg[0]) ? t : nil); -} \ No newline at end of file + return (not(frame->payload.stack_frame.arg[0]) ? t : nil); +} diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index c59ced9..50fa6e5 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -12,21 +12,21 @@ #ifndef __psse_ops_truth_h #define __psse_ops_truth_h -bool nilp( struct pso_pointer a, struct pso_pointer b ); +bool nilp( struct pso_pointer p ); -struct pso_pointer lisp_nilp( struct stack_frame *frame, +struct pso_pointer lisp_nilp( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); -bool not( struct pso_pointer a, struct pso_pointer b ); +bool not( struct pso_pointer p ); -struct pso_pointer lisp_not( struct stack_frame *frame, +struct pso_pointer lisp_not( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); -bool truep( struct pso_pointer a, struct pso_pointer b ); +bool truep( struct pso_pointer p ); -struct pso_pointer lisp_truep( struct stack_frame *frame, +struct pso_pointer lisp_truep( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c new file mode 100644 index 0000000..ea9a1df --- /dev/null +++ b/src/c/payloads/exception.c @@ -0,0 +1,13 @@ + + +#import "memory/pointer.h" +#import "memory/pso.h" +#import "payloads/exception.h" + +/** + * @param p a pointer to an object. + * @return true if that object is an exception, else false. + */ +bool exceptionp( struct pso_pointer p) { + return (get_tag_value( p) == EXCEPTIONTV); +} diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index d6fdc03..edc95ec 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -9,6 +9,7 @@ #ifndef __psse_payloads_exception_h #define __psse_payloads_exception_h +#include #include "memory/pointer.h" @@ -27,5 +28,6 @@ struct exception_payload { struct pso_pointer cause; }; +bool exceptionp( struct pso_pointer p); #endif diff --git a/src/c/payloads/string.h b/src/c/payloads/psse-string.h similarity index 100% rename from src/c/payloads/string.h rename to src/c/payloads/psse-string.h diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 4225dbc..b8510c1 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,6 +13,7 @@ #define __psse_payloads_stack_h #include "memory/pointer.h" +#include "memory/pso4.h" #define STACKTAG "STK" #define STACKTV 4936787 @@ -47,4 +48,6 @@ struct stack_frame_payload { uint32_t depth; }; +struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); + #endif diff --git a/src/c/payloads/vector_pointer.c b/src/c/payloads/vector_pointer.c new file mode 100644 index 0000000..6a09cd1 --- /dev/null +++ b/src/c/payloads/vector_pointer.c @@ -0,0 +1,18 @@ +/** + * payloads/vector_pointer.c + * + * A pointer to an object in vector space. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "payloads/vector_pointer.h" + +bool vectorpointp( struct pso_pointer p) { + return (get_tag_value( p) == VECTORPOINTTV); +} diff --git a/src/c/payloads/vector_pointer.h b/src/c/payloads/vector_pointer.h index 8fda0f3..31b45f0 100644 --- a/src/c/payloads/vector_pointer.h +++ b/src/c/payloads/vector_pointer.h @@ -10,6 +10,8 @@ #ifndef __psse_payloads_vector_pointer_h #define __psse_payloads_vector_pointer_h +#include + #include "memory/pointer.h" /** @@ -37,4 +39,6 @@ struct vectorp_payload { void *address; }; +bool vectorpointp( struct pso_pointer p); + #endif From a8b4a6e69d570f365cec274865c0cbdf627e9878 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 30 Mar 2026 11:52:41 +0100 Subject: [PATCH 20/29] My monster, it not only compiles, it now runs! --- Makefile | 5 +- src/c/debug.c | 2 +- src/c/environment/environment.c | 8 +- src/c/memory/memory.c | 4 +- src/c/memory/node.c | 4 +- src/c/memory/page.c | 75 +++++++++--------- src/c/memory/pointer.c | 16 ++-- src/c/memory/pso.c | 85 +++++++++++---------- src/c/ops/eq.c | 10 ++- src/c/ops/repl.h | 15 ++++ src/c/{payloads/stack.c => ops/stack_ops.c} | 4 +- src/c/ops/stack_ops.h | 30 ++++++++ src/c/ops/truth.c | 42 +++++----- src/c/ops/truth.h | 4 + src/c/payloads/cons.c | 20 ++--- src/c/payloads/cons.h | 8 +- src/c/payloads/exception.c | 18 +++-- src/c/payloads/exception.h | 2 +- src/c/payloads/function.h | 6 +- src/c/payloads/hashtable.h | 10 +-- src/c/payloads/mutex.h | 8 +- src/c/payloads/namespace.h | 22 +++--- src/c/payloads/stack.h | 11 +-- src/c/payloads/vector_pointer.c | 4 +- src/c/payloads/vector_pointer.h | 2 +- src/c/psse.c | 1 + 26 files changed, 244 insertions(+), 172 deletions(-) rename src/c/{payloads/stack.c => ops/stack_ops.c} (88%) create mode 100644 src/c/ops/stack_ops.h diff --git a/Makefile b/Makefile index b662908..49bf5e1 100644 --- a/Makefile +++ b/Makefile @@ -8,8 +8,9 @@ DEPS := $(OBJS:.o=.d) TESTS := $(shell find unit-tests -name *.sh) -INC_DIRS := $(shell find $(SRC_DIRS) -type d) -INC_FLAGS := $(addprefix -I,$(INC_DIRS)) +# INC_DIRS := $(shell find $(SRC_DIRS) -type d) +# INC_FLAGS := $(addprefix -I,$(INC_DIRS)) +INC_FLAGS := -I $(SRC_DIRS) TMP_DIR ?= ./tmp diff --git a/src/c/debug.c b/src/c/debug.c index ae57c16..d6c5c27 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -127,4 +127,4 @@ void debug_printf( int level, int indent, wchar_t *format, ... ) { } // debug_dump_object, debug_print_binding, debug_print_exception, debug_print_object, -// not yet implemented but probably will be. \ No newline at end of file +// not yet implemented but probably will be. diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index f7ec199..cf512c4 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -23,14 +23,14 @@ bool environment_initialised = false; * @param node theindex of the node we are initialising. * @return struct pso_pointer t on success, else an exception. */ - -struct pso_pointer initialise_environment( uint32_t node) { + +struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = t; - if (environment_initialised) { + if ( environment_initialised ) { // TODO: throw an exception "Attempt to reinitialise environment" } else { // TODO: actually initialise it. } return result; -} \ No newline at end of file +} diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 530d3e6..ca41d67 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -34,10 +34,10 @@ bool memory_initialised = false; * @return int */ struct pso_pointer initialise_memory( uint32_t node ) { - if (memory_initialised) { + if ( memory_initialised ) { // TODO: throw an exception } else { - for (uint8_t i = 0; i <= MAX_SIZE_CLASS; i++) { + for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; } memory_initialised = true; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 84228c4..ebf470e 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -37,13 +37,13 @@ uint32_t node_index = 0; * @brief The canonical `nil` pointer * */ -struct pso_pointer nil = (struct pso_pointer) { 0, 0, 0}; +struct pso_pointer nil = ( struct pso_pointer ) { 0, 0, 0 }; /** * @brief the canonical `t` (true) pointer. * */ -struct pso_pointer t = (struct pso_pointer) { 0, 0, 1 }; +struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 }; /** diff --git a/src/c/memory/page.c b/src/c/memory/page.c index eb424e7..b0afe4f 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -38,7 +38,7 @@ * to hold the number of pages we *might* create at start up time. We need a * way to grow the number of pages, while keeping access to them cheap. */ -union page * pages[NPAGES]; +union page *pages[NPAGES]; /** * @brief the number of pages which have thus far been allocated. @@ -55,25 +55,30 @@ uint32_t npages_allocated = 0; * @param freelist the freelist for objects of this size class. * @return struct pso_pointer the new head for the freelist for this size_class, */ -struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, - uint8_t size_class, struct pso_pointer freelist) { +struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, + uint8_t size_class, + struct pso_pointer freelist ) { struct pso_pointer result = freelist; - int obj_size = pow(2, size_class); - int obj_bytes = obj_size * sizeof(uint64_t); - int objs_in_page = PAGE_BYTES/obj_bytes; + int obj_size = pow( 2, size_class ); + int obj_bytes = obj_size * sizeof( uint64_t ); + int objs_in_page = PAGE_BYTES / obj_bytes; // we do this backwards (i--) so that object {0, 0, 0} will be first on the // freelist when the first page is initiated, so we can grab that one for // `nil` and the next on for `t`. - for (int i = objs_in_page - 1; i >= 0; i--) { + for ( int i = objs_in_page - 1; i >= 0; i-- ) { // it should be safe to cast any pso object to a pso2 - struct pso2* object = (struct pso2 *)(page_addr + (i * obj_bytes)); + struct pso2 *object = + ( struct pso2 * ) ( page_addr + ( i * obj_bytes ) ); object->header.tag.bytes.size_class = size_class; - strncpy( &(object->header.tag.bytes.mnemonic[0]), FREETAG, TAGLENGTH); + strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, + TAGLENGTH ); object->payload.free.next = result; - result = make_pointer( node_index, page_index, (uint16_t)( i * obj_size)); + result = + make_pointer( node_index, page_index, + ( uint16_t ) ( i * obj_size ) ); } return result; @@ -89,56 +94,56 @@ struct pso_pointer initialise_page( union page* page_addr, uint16_t page_index, struct pso_pointer allocate_page( uint8_t size_class ) { struct pso_pointer result = t; - if ( npages_allocated == 0) { - for (int i = 0; i < NPAGES; i++) { + if ( npages_allocated == 0 ) { + for ( int i = 0; i < NPAGES; i++ ) { pages[i] = NULL; } - debug_print( L"Pages array zeroed.\n", DEBUG_ALLOC, 0); + debug_print( L"Pages array zeroed.\n", DEBUG_ALLOC, 0 ); } - if ( npages_allocated < NPAGES) { + if ( npages_allocated < NPAGES ) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { - void* pg = malloc( sizeof( union page ) ); + void *pg = malloc( sizeof( union page ) ); if ( pg != NULL ) { memset( pg, 0, sizeof( union page ) ); - pages[ npages_allocated] = pg; - debug_printf( DEBUG_ALLOC, 0, - L"Allocated page %d for objects of size class %x.\n", - npages_allocated, size_class); + pages[npages_allocated] = pg; + debug_printf( DEBUG_ALLOC, 0, + L"Allocated page %d for objects of size class %x.\n", + npages_allocated, size_class ); freelists[size_class] = - initialise_page( (union page*)pg, npages_allocated, size_class, freelists[size_class] ); + initialise_page( ( union page * ) pg, npages_allocated, + size_class, freelists[size_class] ); - debug_printf( DEBUG_ALLOC, 0, - L"Initialised page %d; freelist for size class %x updated.\n", - npages_allocated, - size_class); + debug_printf( DEBUG_ALLOC, 0, + L"Initialised page %d; freelist for size class %x updated.\n", + npages_allocated, size_class ); - npages_allocated ++; + npages_allocated++; } else { // TODO: exception when we have one. result = nil; fwide( stderr, 1 ); - fwprintf( stderr, - L"\nCannot allocate page: heap exhausted,\n", - size_class, MAX_SIZE_CLASS ); + fwprintf( stderr, + L"\nCannot allocate page: heap exhausted,\n", + size_class, MAX_SIZE_CLASS ); } } else { // TODO: exception when we have one. result = nil; fwide( stderr, 1 ); - fwprintf( stderr, - L"\nCannot allocate page for size class %x, min is 2 max is %x.\n", - size_class, MAX_SIZE_CLASS ); + fwprintf( stderr, + L"\nCannot allocate page for size class %x, min is 2 max is %x.\n", + size_class, MAX_SIZE_CLASS ); } } else { // TODO: exception when we have one. - result = nil; + result = nil; fwide( stderr, 1 ); - fwprintf( stderr, - L"\nCannot allocate page: page space exhausted.\n", - size_class, MAX_SIZE_CLASS ); + fwprintf( stderr, + L"\nCannot allocate page: page space exhausted.\n", + size_class, MAX_SIZE_CLASS ); } return result; diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 5c46540..8227151 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -22,8 +22,9 @@ * @param offset The offset, in words, within that page, of the object. * @return struct pso_pointer a pointer referencing the specified object. */ -struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset) { - return (struct pso_pointer){ node, page, offset}; +struct pso_pointer make_pointer( uint32_t node, uint16_t page, + uint16_t offset ) { + return ( struct pso_pointer ) { node, page, offset }; } /** @@ -36,16 +37,15 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset) * @param pointer a pso_pointer which references an object. * @return struct pso2* the actual address in memory of that object. */ -struct pso2* pointer_to_object( struct pso_pointer pointer) { - struct pso2* result = NULL; +struct pso2 *pointer_to_object( struct pso_pointer pointer ) { + struct pso2 *result = NULL; - if ( pointer.node == node_index) { - union page* pg = pages[pointer.page]; - result = (struct pso2*) &pg->words[pointer.offset]; + if ( pointer.node == node_index ) { + union page *pg = pages[pointer.page]; + result = ( struct pso2 * ) &pg->words[pointer.offset]; } // TODO: else if we have a copy of the object in cache, return that; // else request a copy of the object from the node which curates it. return result; } - diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index c4fc711..6982ca8 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -33,58 +33,61 @@ * @param size_class The size class for the object to be allocated; * @return struct pso_pointer a pointer to the newly allocated object */ -struct pso_pointer allocate( char* tag, uint8_t size_class) { +struct pso_pointer allocate( char *tag, uint8_t size_class ) { struct pso_pointer result = nil; - if (size_class <= MAX_SIZE_CLASS) { - if (nilp( freelists[size_class])) { - result = allocate_page(size_class); + if ( size_class <= MAX_SIZE_CLASS ) { + if ( nilp( freelists[size_class] ) ) { + result = allocate_page( size_class ); } - if ( !exceptionp( result) && not( freelists[size_class] ) ) { + if ( !exceptionp( result ) && not( freelists[size_class] ) ) { result = freelists[size_class]; - struct pso2* object = pointer_to_object( result); + struct pso2 *object = pointer_to_object( result ); freelists[size_class] = object->payload.free.next; - strncpy( (char *)(object->header.tag.bytes.mnemonic), tag, TAGLENGTH); + strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag, + TAGLENGTH ); /* the object ought already to have the right size class in its tag * because it was popped off the freelist for that size class. */ - if ( object->header.tag.bytes.size_class != size_class) { + if ( object->header.tag.bytes.size_class != size_class ) { // TODO: return an exception instead? Or warn, set it, and continue? } /* the objext ought to have a reference count ot zero, because it's * on the freelist, but again we should sanity check. */ - if ( object->header.count != 0) { + if ( object->header.count != 0 ) { // TODO: return an exception instead? Or warn, set it, and continue? } } - } // TODO: else throw exception + } // TODO: else throw exception return result; } -uint32_t payload_size( struct pso2* object) { - // TODO: Unit tests DEFINITELY needed! - return ((1 << object->header.tag.bytes.size_class) - sizeof( struct pso_header)); +uint32_t payload_size( struct pso2 *object ) { + // TODO: Unit tests DEFINITELY needed! + return ( ( 1 << object->header.tag.bytes.size_class ) - + sizeof( struct pso_header ) ); } -void free_cell( struct pso_pointer p) { - struct pso2* p2 = pointer_to_object( p); - uint32_t array_size = payload_size(p2); - uint8_t size_class = p2->header.tag.bytes.size_class; +void free_cell( struct pso_pointer p ) { + struct pso2 *p2 = pointer_to_object( p ); + uint32_t array_size = payload_size( p2 ); + uint8_t size_class = p2->header.tag.bytes.size_class; - strncpy( (char *)(p2->header.tag.bytes.mnemonic), FREETAG, TAGLENGTH); + strncpy( ( char * ) ( p2->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); - /* will C just let me cheerfully walk off the end of the array I've declared? */ - for (int i = 0; i < array_size; i++) { - p2->payload.words[i] = 0; - } + /* will C just let me cheerfully walk off the end of the array I've declared? */ + for ( int i = 0; i < array_size; i++ ) { + p2->payload.words[i] = 0; + } - /* TODO: obtain mutex on freelist */ - p2->payload.free.next = freelists[size_class]; - freelists[size_class] = p; + /* TODO: obtain mutex on freelist */ + p2->payload.free.next = freelists[size_class]; + freelists[size_class] = p; } /** @@ -103,12 +106,13 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nIncremented object of type %3.3s at page %u, offset %u to count %u", - ( ( char * ) &object->header.tag.bytes.mnemonic[0] ), pointer.page, - pointer.offset, object->header.count ); - if ( vectorpointp( pointer) ) { + ( ( char * ) &object->header.tag.bytes.mnemonic[0] ), + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) &( object->payload.vectorp.tag.bytes[0] ) ) ); + ( ( char * ) + &( object->payload.vectorp.tag.bytes[0] ) ) ); } else { debug_println( DEBUG_ALLOC ); } @@ -134,12 +138,13 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nDecremented object of type %4.4s at page %d, offset %d to count %d", - ( ( char * ) (object->header.tag.bytes.mnemonic )), pointer.page, - pointer.offset, object->header.count ); - if ( vectorpointp( pointer)) { + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) &( object->payload.vectorp.tag.bytes ) ) ); + ( ( char * ) + &( object->payload.vectorp.tag.bytes ) ) ); } else { debug_println( DEBUG_ALLOC ); } @@ -159,8 +164,8 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { * * @param pointer pointer to an object to lock. */ -void lock_object( struct pso_pointer pointer) { - struct pso2* object = pointer_to_object( pointer ); +void lock_object( struct pso_pointer pointer ) { + struct pso2 *object = pointer_to_object( pointer ); object->header.count = MAXREFERENCE; } @@ -173,12 +178,12 @@ void lock_object( struct pso_pointer pointer) { * @param pointer a pointer to an object. * @return the tag value of the object indicated. */ -uint32_t get_tag_value( struct pso_pointer pointer) { - struct pso2* object = pointer_to_object( pointer); - uint32_t result = (object->header.tag.value & 0xffffff); +uint32_t get_tag_value( struct pso_pointer pointer ) { + struct pso2 *object = pointer_to_object( pointer ); + uint32_t result = ( object->header.tag.value & 0xffffff ); - if (vectorpointp( pointer)) { - result = (object->payload.vectorp.tag.value & 0xffffff); + if ( vectorpointp( pointer ) ) { + result = ( object->payload.vectorp.tag.value & 0xffffff ); } return result; diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 9830b96..8ca0550 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -13,6 +13,7 @@ #include "memory/node.h" #include "memory/pointer.h" #include "payloads/stack.h" +#include "ops/stack_ops.h" #include "ops/truth.h" /** @@ -48,9 +49,12 @@ struct pso_pointer lisp_eq( struct pso4 *frame, struct pso_pointer env ) { struct pso_pointer result = t; - if ( frame->args > 1 ) { - for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = eq( fetch_arg(frame, 0), fetch_arg( frame, b ) ) ? t : nil; + if ( frame->payload.stack_frame.args > 1 ) { + for ( int b = 1; + ( truep( result ) ) && ( b < frame->payload.stack_frame.args ); + b++ ) { + result = + eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil; } } diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index e69de29..7a99f48 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -0,0 +1,15 @@ +/** + * ops/repl.h + * + * The read/eval/print loop. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_repl_h +#define __psse_ops_repl_h + +// struct pso_pointer repl( struct pso_pointer prompt, struct pso_pointer readtable); + +#endif \ No newline at end of file diff --git a/src/c/payloads/stack.c b/src/c/ops/stack_ops.c similarity index 88% rename from src/c/payloads/stack.c rename to src/c/ops/stack_ops.c index 5cb2113..0fd28c5 100644 --- a/src/c/payloads/stack.c +++ b/src/c/ops/stack_ops.c @@ -32,10 +32,10 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { struct pso_pointer p = frame->payload.stack_frame.more; for ( int i = args_in_frame; i < index; i++ ) { - p = pointer_to_object( p)->payload.cons.cdr; + p = pointer_to_object( p )->payload.cons.cdr; } - result = pointer_to_object( p)->payload.cons.car; + result = pointer_to_object( p )->payload.cons.car; } return result; diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h new file mode 100644 index 0000000..837d49a --- /dev/null +++ b/src/c/ops/stack_ops.h @@ -0,0 +1,30 @@ +/** + * ops/stack_ops.h + * + * Operations on a Lisp stack frame. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_stack_ops_h +#define __psse_ops_stack_ops_h + +#include "memory/pointer.h" +#include "memory/pso4.h" + +/* + * number of arguments stored in a stack frame + */ +#define args_in_frame 8 + +/** + * @brief The maximum depth of stack before we throw an exception. + * + * `0` is interpeted as `unlimited`. + */ +extern uint32_t stack_limit; + +struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); + +#endif diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 8e10dd6..5d3db10 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -9,6 +9,12 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "ops/stack_ops.h" + /** * @brief true if `p` points to `nil`, else false. * @@ -20,8 +26,8 @@ * @return true if `p` points to `nil`. * @return false otherwise. */ -bool nilp( struct pso_pointer p) { - return (p.page == 0 && p.offset = 0); +bool nilp( struct pso_pointer p ) { + return ( p.page == 0 && p.offset == 0 ); } /** @@ -31,8 +37,8 @@ bool nilp( struct pso_pointer p) { * @return true if `p` points to `nil`; * @return false otherwise. */ -bool not( struct pso_pointer p) { - return !nilp( p); +bool not( struct pso_pointer p ) { + return !nilp( p ); } /** @@ -46,8 +52,8 @@ bool not( struct pso_pointer p) { * @return true if `p` points to `t`. * @return false otherwise. */ -bool truep( struct pso_pointer p) { - return (p.page == 0 && p.offset = 1); +bool truep( struct pso_pointer p ) { + return ( p.page == 0 && p.offset == 1 ); } /** @@ -58,10 +64,10 @@ bool truep( struct pso_pointer p) { * @param env the evaluation environment. * @return `t` if the first argument in this frame is `nil`, else `t` */ -pso_pointer lisp_nilp( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ){ - return (nilp(frame->payload.stack_frame.arg[0]) ? t : nil); +struct pso_pointer lisp_nilp( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +return ( nilp( fetch_arg( frame, 0 )) ? t : nil ); } /** @@ -72,10 +78,10 @@ pso_pointer lisp_nilp( struct pso4 *frame, * @param env the evaluation environment. * @return `t` if the first argument in this frame is `t`, else `nil`. */ -pso_pointer lisp_truep( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ){ - return (truep(frame->payload.stack_frame.arg[0]) ? t : nil); +struct pso_pointer lisp_truep( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return ( truep( fetch_arg( frame, 0 ) ) ? t : nil ); } /** @@ -87,8 +93,8 @@ pso_pointer lisp_truep( struct pso4 *frame, * @param env the evaluation environment. * @return `t` if the first argument in this frame is not `nil`, else `t`. */ -pso_pointer lisp_not( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ){ - return (not(frame->payload.stack_frame.arg[0]) ? t : nil); +struct pso_pointer lisp_not( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return ( not( fetch_arg( frame, 0 ) ) ? t : nil ); } diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index 50fa6e5..e81eacd 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -11,6 +11,10 @@ #ifndef __psse_ops_truth_h #define __psse_ops_truth_h +#include + +#include "memory/pointer.h" +#include "memory/pso4.h" bool nilp( struct pso_pointer p ); diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 6a002c8..00219e7 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -23,15 +23,15 @@ * @param cdr the pointer which should form the cdr of this cons cell. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr) { - struct pso_pointer result = allocate( CONSTAG, 2); +struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { + struct pso_pointer result = allocate( CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); object->payload.cons.car = car; object->payload.cons.cdr = cdr; - inc_ref( car); - inc_ref( cdr); + inc_ref( car ); + inc_ref( cdr ); return result; } @@ -43,7 +43,7 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr) { * @return true if `ptr` indicates a cons cell. * @return false otherwise */ -bool consp( struct pso_pointer ptr) { +bool consp( struct pso_pointer ptr ) { // TODO: make it actually work! return false; } @@ -55,11 +55,11 @@ bool consp( struct pso_pointer ptr) { * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer car( struct pso_pointer cons) { +struct pso_pointer car( struct pso_pointer cons ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); - if ( consp( cons)) { + if ( consp( cons ) ) { result = object->payload.cons.car; } // TODO: else throw an exception @@ -74,14 +74,14 @@ struct pso_pointer car( struct pso_pointer cons) { * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr( struct pso_pointer cons) { +struct pso_pointer cdr( struct pso_pointer cons ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); - if ( consp( cons)) { + if ( consp( cons ) ) { result = object->payload.cons.cdr; } // TODO: else throw an exception return result; -} \ No newline at end of file +} diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index a2e8129..91d1f1b 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -30,12 +30,12 @@ struct cons_payload { struct pso_pointer cdr; }; -struct pso_pointer car( struct pso_pointer cons); +struct pso_pointer car( struct pso_pointer cons ); -struct pso_pointer cdr( struct pso_pointer cons); +struct pso_pointer cdr( struct pso_pointer cons ); -struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr); +struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); -bool consp( struct pso_pointer ptr); +bool consp( struct pso_pointer ptr ); #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index ea9a1df..507b804 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -1,13 +1,21 @@ +/** + * payloads/exception.c + * + * An exception; required three pointers, so use object of size class 3. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ -#import "memory/pointer.h" -#import "memory/pso.h" -#import "payloads/exception.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "payloads/exception.h" /** * @param p a pointer to an object. * @return true if that object is an exception, else false. */ -bool exceptionp( struct pso_pointer p) { - return (get_tag_value( p) == EXCEPTIONTV); +bool exceptionp( struct pso_pointer p ) { + return ( get_tag_value( p ) == EXCEPTIONTV ); } diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index edc95ec..38314ee 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -28,6 +28,6 @@ struct exception_payload { struct pso_pointer cause; }; -bool exceptionp( struct pso_pointer p); +bool exceptionp( struct pso_pointer p ); #endif diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 2f43bef..bd02836 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -41,9 +41,9 @@ struct function_payload { * a cons pointer (representing its result). * \todo check this documentation is current! */ - struct pso_pointer ( *executable ) ( struct pso4*, - struct pso_pointer, - struct pso_pointer ); + struct pso_pointer ( *executable ) ( struct pso4 *, + struct pso_pointer, + struct pso_pointer ); }; #endif diff --git a/src/c/payloads/hashtable.h b/src/c/payloads/hashtable.h index 3619847..b235b0b 100644 --- a/src/c/payloads/hashtable.h +++ b/src/c/payloads/hashtable.h @@ -45,11 +45,11 @@ * i.e. either an assoc list or a further hashtable. */ struct hashtable_payload { - struct pso_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use - the default hashing function */ - uint32_t n_buckets; /* number of hash buckets */ - struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` - * or assoc lists or (possibly) further hashtables. */ + struct pso_pointer hash_fn; /* function for hashing values in this hashtable, or `NIL` to use + the default hashing function */ + uint32_t n_buckets; /* number of hash buckets */ + struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashtables. */ }; #endif diff --git a/src/c/payloads/mutex.h b/src/c/payloads/mutex.h index ca5704b..f158b0d 100644 --- a/src/c/payloads/mutex.h +++ b/src/c/payloads/mutex.h @@ -32,7 +32,7 @@ struct mutex_payload { pthread_mutex_t mutex; }; -struct pso_pointer make_mutex(); +struct pso_pointer make_mutex( ); /** * @brief evaluates these forms within the context of a thread-safe lock. @@ -50,7 +50,8 @@ struct pso_pointer make_mutex(); * @param forms a list of arbitrary Lisp forms. * @return struct pso_pointer the result. */ -struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms); +struct pso_pointer with_lock( struct pso_pointer lock, + struct pso_pointer forms ); /** * @brief as with_lock, q.v. but attempts to obtain a lock and returns an @@ -64,6 +65,7 @@ struct pso_pointer with_lock( struct pso_pointer lock, struct pso_pointer forms) * @param forms a list of arbitrary Lisp forms. * @return struct pso_pointer the result. */ -struct pso_pointer attempt_with_lock( struct pso_pointer lock, struct pso_pointer forms); +struct pso_pointer attempt_with_lock( struct pso_pointer lock, + struct pso_pointer forms ); #endif diff --git a/src/c/payloads/namespace.h b/src/c/payloads/namespace.h index bb1b1b3..229c8e4 100644 --- a/src/c/payloads/namespace.h +++ b/src/c/payloads/namespace.h @@ -48,17 +48,17 @@ * i.e. either an assoc list or a further namespace. */ struct namespace_payload { - struct pso_pointer hash_fn; /* function for hashing values in this namespace, or - * `NIL` to use the default hashing function */ - uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ - struct pso_pointer write_acl; /* it seems to me that it is likely that the - * principal difference between a hashtable and a - * namespace is that a hashtable has a write ACL - * of `NIL`, meaning not writeable by anyone */ - struct pso_pointer mutex; /* the mutex to lock when modifying this namespace.*/ - struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` - * or assoc lists or (possibly) further hashtables. */ + struct pso_pointer hash_fn; /* function for hashing values in this namespace, or + * `NIL` to use the default hashing function */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct pso_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashtable and a + * namespace is that a hashtable has a write ACL + * of `NIL`, meaning not writeable by anyone */ + struct pso_pointer mutex; /* the mutex to lock when modifying this namespace. */ + struct pso_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashtables. */ }; #endif diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index b8510c1..b02e8f0 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,7 +13,7 @@ #define __psse_payloads_stack_h #include "memory/pointer.h" -#include "memory/pso4.h" +// #include "memory/pso4.h" #define STACKTAG "STK" #define STACKTV 4936787 @@ -23,13 +23,6 @@ */ #define args_in_frame 8 -/** - * @brief The maximum depth of stack before we throw an exception. - * - * `0` is interpeted as `unlimited`. - */ -extern uint32_t stack_limit; - /** * A stack frame. */ @@ -48,6 +41,4 @@ struct stack_frame_payload { uint32_t depth; }; -struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); - #endif diff --git a/src/c/payloads/vector_pointer.c b/src/c/payloads/vector_pointer.c index 6a09cd1..e575874 100644 --- a/src/c/payloads/vector_pointer.c +++ b/src/c/payloads/vector_pointer.c @@ -13,6 +13,6 @@ #include "memory/pso.h" #include "payloads/vector_pointer.h" -bool vectorpointp( struct pso_pointer p) { - return (get_tag_value( p) == VECTORPOINTTV); +bool vectorpointp( struct pso_pointer p ) { + return ( get_tag_value( p ) == VECTORPOINTTV ); } diff --git a/src/c/payloads/vector_pointer.h b/src/c/payloads/vector_pointer.h index 31b45f0..e527bb1 100644 --- a/src/c/payloads/vector_pointer.h +++ b/src/c/payloads/vector_pointer.h @@ -39,6 +39,6 @@ struct vectorp_payload { void *address; }; -bool vectorpointp( struct pso_pointer p); +bool vectorpointp( struct pso_pointer p ); #endif diff --git a/src/c/psse.c b/src/c/psse.c index 5f5f2fb..fc1293b 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -14,6 +14,7 @@ #include "psse.h" #include "memory/node.h" +#include "ops/stack_ops.h" void print_banner( ) { fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", From e3f922a8bf3229687a98950e953789c768d21d57 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 30 Mar 2026 13:29:26 +0100 Subject: [PATCH 21/29] Added character as a first class object. Stepped through a run; it all works. --- src/c/memory/pso2.h | 11 +++++++---- src/c/payloads/character.h | 39 +++++++++++++++++++++++++++++++++++++ src/c/payloads/special.h | 24 +++-------------------- src/c/payloads/time.h | 4 +++- utils_src/tagvalcalc/tvc | Bin 16848 -> 16064 bytes 5 files changed, 52 insertions(+), 26 deletions(-) create mode 100644 src/c/payloads/character.h diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 4cbad4a..0c36b29 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -12,8 +12,8 @@ #include -#include "../payloads/psse-string.h" #include "memory/header.h" +#include "payloads/character.h" #include "payloads/cons.h" #include "payloads/free.h" #include "payloads/function.h" @@ -22,9 +22,9 @@ #include "payloads/lambda.h" #include "payloads/nlambda.h" #include "payloads/read_stream.h" -#include "payloads/special.h" +#include "payloads/psse-string.h" #include "payloads/symbol.h" -// #include "payloads/time.h" +#include "payloads/time.h" #include "payloads/vector_pointer.h" #include "payloads/write_stream.h" @@ -38,13 +38,16 @@ struct pso2 { union { char bytes[16]; uint64_t words[2]; + struct character_payload character; struct cons_payload cons; struct free_payload free; struct function_payload function; struct integer_payload integer; struct lambda_payload lambda; -// struct special_payload special; + struct function_payload special; struct stream_payload stream; + struct string_payload string; +// TODO: this isn't working and I don't know why (error: field ‘time’ has incomplete type) // struct time_payload time; struct vectorp_payload vectorp; } payload; diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h new file mode 100644 index 0000000..81a6dfa --- /dev/null +++ b/src/c/payloads/character.h @@ -0,0 +1,39 @@ +/** + * payloads/character.h + * + * A character object. + * + * Note that, instead of instantiating actual character objects, it would be + * possible to reserve one special page index, outside the normal page range, + * possibly even page 0, such that a character would be represented by a + * pso_pointer {node, special_page, character_code}. The special page wouldn't + * actually have to exist. This wouldn't prevent `nil` being 'the object at + * {n, 0, 0}, since the UTF character with the index 0 is NULL, which feels + * entirely compatible. UTF 1 is 'Start of heading', which is not used by + * anything I'm aware of these days, and is canonically not NULL, so I don't + * see why we should not continue to treat {n, 0, 1} as `t`. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_character_h +#define __psse_payloads_character_h +/* + * wide characters + */ +#include +#include + + +#define CHARTAG "CHR" +#define CHARTV 5392451 + +/** + * @brief a single character, as returned by the reader. + */ +struct character_payload { + wchar_t character; +}; + +#endif \ No newline at end of file diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index 4dcf7c2..b0ff91b 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -3,6 +3,9 @@ * * A special form. * + * No payload here; it would be identical to function_payload, q.v., so + * use that instead. + * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ @@ -21,25 +24,4 @@ #define SPECIALTAG "SFM" #define SPECIALTV 5064275 -// /** -// * @brief Payload of a special form cell. -// * -// * Currently identical to the payload of a function cell. -// * \see function_payload -// */ -// struct special_payload { -// /** -// * pointer to the source from which the special form was compiled, or NIL -// * if it is a primitive. -// */ -// struct pso_pointer meta; -// /** pointer to a function which takes a cons pointer (representing -// * its argument list) and a cons pointer (representing its environment) and a -// * stack frame (representing the previous stack frame) as arguments and returns -// * a cons pointer (representing its result). */ -// struct pso_pointer ( *executable ) ( struct pso4*, -// struct pso_pointer, -// struct pso_pointer ); -// }; - #endif diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index cc1ef0a..d808c0e 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -10,7 +10,9 @@ #ifndef __psse_payloads_cons_h #define __psse_payloads_cons_h +#include #include +#include #include "memory/pointer.h" @@ -26,7 +28,7 @@ * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch)) */ struct time_payload { - unsigned __int128_t value; + unsigned __int128 value; }; #endif diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc index acd850a02231fc7f80d1516dc01c995fcc0d848b..374be1af28337f8ce0bb611058cab9ad29b93f2e 100755 GIT binary patch literal 16064 zcmeHOZ)_B48Gm z$&urN8rOzPFK5i%2MsZ~c!?K-$;B8FW8v=LP(xZj@c}Q@NK#@wxp?ZSC+qXfJiqC5 z*u4)X#%SgZGr#xw^Lw9no_S~b4*R~(Bo6n5Lm`FIpgylyDnuMj9EQ)LqEuY%RZVnm zRh!jvQa?mTT+DuqG&lxeqxi9!dEXMdA3rXBK=hE2dG*SR+#xDJCD*~cWo!`Hk1NA$ zR0;^Y8!u{`mGa>#cAx_E^0+HA?Y3FX>|csslz68F!DEqmbHbYwo{JK1P7wLzobWLy z`SfFyY+R!DSt&oSAUr>A6@MVd;KInqLX=Ka{1~;hi}AoaamPw=-QPdRejfTcD7=U` z`0+Cm4~Tfjh$llrJU$#SJdR7ediSqG?i)~Uhn*8{gU8yTfs-nHPEB)Py!N#ubGq5y za{X7wjy|z@cHif&RR6j#_k$Z3&&}@0q=)x(?Z~9sGwED;ynTG{p7uRmu~I&^Q*l_% z3Ag85*Rxbxyq~k?&8)4cbK<_OsbS;xYUxjrK3c=SvyOkcj{nL!{$H)*zlHRCJWxtj zF_$b%sH~C63*X_DiHK9bHEne-V`6^iMcHKN#yGq^_`I^5sW ztM82MjO}*oySkL#KXgP-nMHFnU9!yL(2?FuK4%UY!x@vB9L?r)5=3`gYdR{rKMizm zyhoVcmW!{Q^2Ri!qCxeD?zQK?O}8)=r zBYbaB-ty?>k+)4V9=-jZ6v8c!egzsKob%`r+cw7?C-x0HRr}l+cLdhs*|4Ajm+Ffgl6_p$ur}7aFz6WpD0KO8eTh6|T-`=ig|2-Hle= z{c|!^+kQ#s=GHjXSRP~h-MK22wyP}j6!Y$kEnjAtr+#;*ZTSqzBU4P^()ow}%IsIP z%5Syvzq>a$l<1u9yrEs#f0InrbvwxQy^&aRD}NO@@yPZpX|)T>xE<}$_pNo*-6pP6 zcUM;Dnp@AY@9To(f6VsZ{W!z+` mcIBM|+LiYkw9qwe_P({28u)e0X`rz>H`3gC zaFPF~=FNXUw|_NpRr%8=we$Nglc&-ucdS*~wPklm4t<$oyYZQS z_bD=-Bn~CFqjL7PRw>W?j3>SGZ{M$0wMyciHkr6LsVa$u>xmCIb-y2-Onjids9jk5 zCP|9SGg@dyn{3oBBo;37JYB2Y)GF8K&r$=EiG?-_pek2|w8}$zOPeI$Ym~1~HZkk^ zPq@MPlf*kuv52uRar^1#ZS4)Z&G!9Ya>v;}C_x5-3nc6AvMu!y`kLL;u#bO3<aj^)&78_ zI{%i*C3NPv3XMlXn^vu8oC>Xou%3Ur=Qg&mgOu9-N^K=O`%nF`T8*=BQ>3qH{o~CK zKh=0n9oV?%`l%n*VQZJ=l$J@xlhnhp?EJ7s_v%9*TcQ5mxnJ>k60nsM95#< z{M#!R{lm13?CY3uSid_;Z8ESckYtWPEFF6dCIg`MZk??0>#r&9i)oKdh)=E#W2pprnE|ez(L< zpPY92uHeIh>jl>d0)(dKW&I((-86B)_a)XUeoXX(5*Yd^=@|MwEq=UCl?&qkqv~7_ zsccvJ9o4?R)5518Vr?0Drq54X9uWKAL`J{u#{UZ^tRMG>-Xr6nPw)$Z@QcQs+M(Xw z$D-Q~n!{-$7wzn#)w3P#osVvpD!d;=&dWpU-KyWhc@C*Z+;!toad?EVmj7nbhiTWr zMSuT9KjYKy5R z{r9O-tN-<`>ovQbHEKSJ78bEqJ6CQ0k1GHD{DnRHmagf}RRTj;;ZdfsFqBzYaFmq=eL?yIDa&^YOcqXh>?ZT}{Bf6Nv!|495XuE6@K z_@9#Z^2=hlN_y_6-~T4*qab^5p7e<2QLBb9=ab%=zVWY4B#TyOEKh6Kjp4Lz8Ka66 zC96C#5=*MZb?&;A)swu^y+od=ygr)A4;vXhW#x+{-6)T%WIkKSn3kD}b=3CYrS@sv zC>D(g-OO3V2{lqQvZkIYXR{MT@kly(T1#B1Ur!pDB>kga>3ZMs?js33F>p|)RrUu@ z4Rjyr?|0pc zl$lFW6T_vFG$;EQXb%E%!J89m?l@Sw+hJ+5oNc9IrHQO%3=>*K2ggv$pgCtK0X z7)+2_A!Bii)Ug;F0; z@r-ObNu9}C9EZBfH#0^lRxujUSsJL`r|93W^ZbbC6!aL{1^bwQQPBf1-+;`k%e?%8 zOca3p|Ki?)_ZD>BRH0Xc8^7K@I{34%xA5P?zt9{7{l6sffru~D8F!wCHcn85=WO6( zUgx4XVjl{wAM>j(k)1<=k9i^x^FnFHzE;#3lXUPL41CPHfOxl~|L_AAh|hC6$e7mw zJ2(gxfBzk=QqNF@?+N&rR|2QS5%K-kUlD$f_+g$3)I5C7nVG+;vUhV!JkiQ3* z|4K73CLja9=i_7FDeyVpfJJmu{^#e1!pHqnQE?QcnaYyl=l__j+(qy){{mt^A{z1Y-|+F{QO6VbDu{x} z8`L+c;(dSA+lL8%fBf5IXrezn|c@dY!2bz85iey{?)xI3*qX t1R42}LVxi7=I0B2_wsM?2N)H1KeZ#e@kOLLd2Rl0b~_#$(a}2me*r4IBar|A literal 16848 zcmeHOeQZB$=-#PYs zFOI0H{kL}&``q(8ANSsK@4LP?@7`|*JKCHMhv4KAUlGVncyz>10?#(e0P%}vu^7JV z#DiiU@D&o%<$j%jR8Nd(3PEBjs2ylmi2~xS z^cK~VDa(uHdC?e>SAG|1H!474YP7?uj5SEH7~5{9161B1QMN-C?Z(M&oa~rRQ+Z4| zo){DSG*djS)C)39UimGA)$SnKS!pZjGsQA69k{MVK2Lf3$j;-HZiJO`IZU~{C%}%n zRyVxIH+S=XDsQfS=%)BHrSOXN@mSB6ruFeiLp+wu4mJ!nZ)w=lMq!kFQA0e+&%Zb`dh*u8l@@|vX&GS*FmD-r8DQn~*UW(j=D=S9+zTITdIW%S{=Wyf z*QyLWMtgM`TtNSXu{*YijFwJ@2Zn^IX0%ZFX*JycwAver#l=86mehJhA{39O!XOS0 zhSc6zG8B(J8wD0Uph;R&6QNjA?CNN5*{N>yH5GFkeVc{a-nm)bU|-ofAR;L>0XqVA1ndad5wIg*N8qzX;N$8C z|E&!Fqe>a6{L^|Nl$RznXJJwqK38>CIw)*@0pOWJ{V-5<70J50N^V*?^WhHV%x#zAIImp1tJQ#mSII$D;Yx3H9kh$>F+Rt) zqgZ4g=~9NbzkpdKcU@bgjBGyvOn&Nap^%S2aL!jA1>SKOY)$r4M?i>cq*Wt?d|nd*S(1Klj93VGKNo%^Ww;sV*AUEfE@ul0(J!K2-p#@BVb3s zj({BjI|BbV5y1CP^-aE}%(eyfk^5lxxytnzY|{k3Q}Ij}3WGqqfsO$k0E+v&aiHBm ze{iEvm;~BAQz%RWodnv9dre6A?h}*a+5N&X=y9xCG{5Q;$PmYO`U?1f4Y&}k^X03r zHIQwB|Jg?)&-J#FsV$Ez0}sX8uptlakSrZuY(M*BnXISqQ!5J5a_& z0XqVA1ndad5wIg*N5GDN9f8jh0Y2Zy=lN)RRXjVlh@H@82wu#|l&3?MD~RWFgR6+= zvwACu=ktTOU&6%lTXzd7G9fcD zM(6qP)iI`S`CZya@)^JT2_K+Ch>VX@#kk%Rq{n9ux%>wSXTARv^!7nqB?NCOWqXg4 zKX~&hd5$}5BPHKU@=u88c98r38R2u^R)>w$-+rR|h;|dT>fej!bD_I-?%d{G+trgz zYFY1A-zHyU!-hw*lHG7@W23LJX`K$=%OS{JFiLC71P0H+^7(Y58y8sc`ExT~A)YJi zr?NOM&HD3--E@b-{mE4wltlUObO%*8hUw`NWLh zFUpN)7t9X){G0V*_VODMJ?|1Lg{Lgevs=jqpW6y?qfkQh9L}3g=#*(oJl%wQ>HIX? zeTi_MhZ%nqG7dw1c%EpJ`0O~~VSOxj%;JAY>d%hnD}a})|6J{QRr;wBhp@tyRL;+D zrOxtM{dEp-hnU@8e;|GSJ>ep*$jt2V^D*Es3(V@@tIz_T#z0AF1O7vZ#)(Xw!& zCoD?0FjOs}hVdRo2JT=)Qfgm3)f0-V5iOO@sG;nj2&WPQ@u(J!_?jEHG?rJwyC5+& zlun0+)M!#m4~gD%C=pd7*+c?wlNdM^G&Pf|7V3K@6c586R7_Rd_6K$c)!?316|RAp zwIf1p{o0?2TK5ZeSI6F#K!>`wt?fXtQ|%12bOh0>ysr|@ zWM#ei){EcI*H-R%StS|?X(8}qz9my~&_owzN{Do6y(eQ8qgVY34EQ$RhfyP$l-eIk zM)0mo`(DtB#FA<@6NQ+RnuD>WOFCBHJ(&!-mN#@%6|UcKl<{6p*~>QOi#}$T!j~CJ zXrUgUT3V<5oP*0k(e!}uB~x0|*O$!t2GXg4Xj&UGKt0(QTnURs2nw{cH^4{`QoTQv z=@-7pP!fvJsg~9y&qULiSSo2^RFI{k@emqNZXm7+pNxhNvcA3)u$ak2!@{RU2Z6;Q z3)(5!mA+^{4buJycwyW`c z1aDV)oy_--t@_L}y#cn^Mz-gD)N2g@LSj9gEAfoq0RfI(w&(p8-zVpL<2Zj{Vmt2t zUjT+pWP9G1jnP7|8)U}B_Dtu2vC&@mNxM;}Tn_tSJLVUGF=AXkuOB^RZ`H@LjA;p# zPwGVx+do`H^bFe@DUThas-GNo)5P!q2z~J3`tbaV|8L^D8|}yNhY8YNi*qhlm*U#K Qy!}Vby2eV2frS Date: Mon, 30 Mar 2026 21:49:08 +0100 Subject: [PATCH 22/29] This once again does NOT compile. I've done work on macros; they don't work yet.. --- src/c/io/fopen.h | 2 +- src/c/io/print.c | 122 +++++++++++++++++ src/c/io/print.h | 19 +++ src/c/io/read.h | 0 src/c/memory/page.c | 4 + src/c/memory/pso.c | 19 +-- src/c/memory/pso.h | 2 +- src/c/memory/pso2.h | 2 + src/c/memory/tags.h | 125 ++++++++++++++++++ src/c/ops/eval.c | 2 + src/c/payloads/cons.c | 12 +- src/c/payloads/cons.h | 5 - src/c/payloads/exception.c | 7 - src/c/payloads/exception.h | 5 - src/c/payloads/free.h | 6 - src/c/payloads/function.h | 8 -- src/c/payloads/hashtable.h | 7 - src/c/payloads/integer.h | 3 - src/c/payloads/keyword.h | 6 - src/c/payloads/mutex.h | 8 -- src/c/payloads/namespace.h | 7 - src/c/payloads/nlambda.h | 6 - src/c/payloads/psse-string.h | 7 - src/c/payloads/read_stream.h | 6 - src/c/payloads/special.h | 2 - src/c/payloads/stack.h | 4 - src/c/payloads/symbol.h | 7 - src/c/payloads/vector_pointer.c | 18 --- src/c/payloads/vector_pointer.h | 2 - src/c/payloads/write_stream.h | 9 -- {archive/unit-tests => unit-tests}/add.sh | 0 .../allocation-tests/allocation-tester.sh | 0 .../allocation-tests/allocation-tests.csv | 0 .../allocation-tests/allocation-tests.ods | Bin .../allocation-tests/feature-2.test.tmp | 0 .../allocation-tests/grep.bb | 0 .../allocation-tests/test-forms | 0 {archive/unit-tests => unit-tests}/append.sh | 0 {archive/unit-tests => unit-tests}/apply.sh | 0 {archive/unit-tests => unit-tests}/assoc.sh | 0 .../unit-tests => unit-tests}/bignum-add.sh | 0 .../unit-tests => unit-tests}/bignum-expt.sh | 0 .../unit-tests => unit-tests}/bignum-print.sh | 0 .../bignum-subtract.sh | 0 {archive/unit-tests => unit-tests}/bignum.sh | 0 .../unit-tests => unit-tests}/complex-list.sh | 0 {archive/unit-tests => unit-tests}/cond.sh | 0 .../unit-tests => unit-tests}/empty-list.sh | 0 .../unit-tests => unit-tests}/empty-string.sh | 0 {archive/unit-tests => unit-tests}/equal.sh | 0 .../unit-tests => unit-tests}/eval-integer.sh | 0 .../eval-quote-sexpr.sh | 0 .../eval-quote-symbol.sh | 0 .../unit-tests => unit-tests}/eval-real.sh | 0 .../unit-tests => unit-tests}/eval-string.sh | 0 {archive/unit-tests => unit-tests}/fred.sh | 0 .../integer-allocation.sh | 0 {archive/unit-tests => unit-tests}/integer.sh | 0 .../unit-tests => unit-tests}/interpreter.sh | 0 {archive/unit-tests => unit-tests}/lambda.sh | 0 {archive/unit-tests => unit-tests}/let.sh | 0 .../unit-tests => unit-tests}/list-test.sh | 0 .../unit-tests => unit-tests}/many-args.sh | 0 {archive/unit-tests => unit-tests}/map.sh | 0 {archive/unit-tests => unit-tests}/mapcar.sh | 0 {archive/unit-tests => unit-tests}/memberp.sh | 0 {archive/unit-tests => unit-tests}/memory.sh | 0 .../unit-tests => unit-tests}/multiply.sh | 0 {archive/unit-tests => unit-tests}/nil.sh | 0 {archive/unit-tests => unit-tests}/nlambda.sh | 0 .../path-notation.sh | 0 {archive/unit-tests => unit-tests}/progn.sh | 0 {archive/unit-tests => unit-tests}/quote.sh | 0 .../unit-tests => unit-tests}/quoted-list.sh | 0 .../ratio-addition.sh | 0 .../unit-tests => unit-tests}/recursion.sh | 0 {archive/unit-tests => unit-tests}/reverse.sh | 0 .../unit-tests => unit-tests}/simple-list.sh | 0 {archive/unit-tests => unit-tests}/slurp.sh | 0 .../string-allocation.sh | 0 .../unit-tests => unit-tests}/string-cons.sh | 0 .../string-with-spaces.sh | 0 .../unit-tests => unit-tests}/subtract.sh | 0 {archive/unit-tests => unit-tests}/try.sh | 0 {archive/unit-tests => unit-tests}/varargs.sh | 0 .../wide-character.sh | 0 86 files changed, 279 insertions(+), 153 deletions(-) create mode 100644 src/c/io/print.c create mode 100644 src/c/io/print.h create mode 100644 src/c/io/read.h create mode 100644 src/c/memory/tags.h delete mode 100644 src/c/payloads/vector_pointer.c rename {archive/unit-tests => unit-tests}/add.sh (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/allocation-tester.sh (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/allocation-tests.csv (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/allocation-tests.ods (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/feature-2.test.tmp (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/grep.bb (100%) rename {archive/unit-tests => unit-tests}/allocation-tests/test-forms (100%) rename {archive/unit-tests => unit-tests}/append.sh (100%) rename {archive/unit-tests => unit-tests}/apply.sh (100%) rename {archive/unit-tests => unit-tests}/assoc.sh (100%) rename {archive/unit-tests => unit-tests}/bignum-add.sh (100%) rename {archive/unit-tests => unit-tests}/bignum-expt.sh (100%) rename {archive/unit-tests => unit-tests}/bignum-print.sh (100%) rename {archive/unit-tests => unit-tests}/bignum-subtract.sh (100%) rename {archive/unit-tests => unit-tests}/bignum.sh (100%) rename {archive/unit-tests => unit-tests}/complex-list.sh (100%) rename {archive/unit-tests => unit-tests}/cond.sh (100%) rename {archive/unit-tests => unit-tests}/empty-list.sh (100%) rename {archive/unit-tests => unit-tests}/empty-string.sh (100%) rename {archive/unit-tests => unit-tests}/equal.sh (100%) rename {archive/unit-tests => unit-tests}/eval-integer.sh (100%) rename {archive/unit-tests => unit-tests}/eval-quote-sexpr.sh (100%) rename {archive/unit-tests => unit-tests}/eval-quote-symbol.sh (100%) rename {archive/unit-tests => unit-tests}/eval-real.sh (100%) rename {archive/unit-tests => unit-tests}/eval-string.sh (100%) rename {archive/unit-tests => unit-tests}/fred.sh (100%) rename {archive/unit-tests => unit-tests}/integer-allocation.sh (100%) rename {archive/unit-tests => unit-tests}/integer.sh (100%) rename {archive/unit-tests => unit-tests}/interpreter.sh (100%) rename {archive/unit-tests => unit-tests}/lambda.sh (100%) rename {archive/unit-tests => unit-tests}/let.sh (100%) rename {archive/unit-tests => unit-tests}/list-test.sh (100%) rename {archive/unit-tests => unit-tests}/many-args.sh (100%) rename {archive/unit-tests => unit-tests}/map.sh (100%) rename {archive/unit-tests => unit-tests}/mapcar.sh (100%) rename {archive/unit-tests => unit-tests}/memberp.sh (100%) rename {archive/unit-tests => unit-tests}/memory.sh (100%) rename {archive/unit-tests => unit-tests}/multiply.sh (100%) rename {archive/unit-tests => unit-tests}/nil.sh (100%) rename {archive/unit-tests => unit-tests}/nlambda.sh (100%) rename {archive/unit-tests => unit-tests}/path-notation.sh (100%) rename {archive/unit-tests => unit-tests}/progn.sh (100%) rename {archive/unit-tests => unit-tests}/quote.sh (100%) rename {archive/unit-tests => unit-tests}/quoted-list.sh (100%) rename {archive/unit-tests => unit-tests}/ratio-addition.sh (100%) rename {archive/unit-tests => unit-tests}/recursion.sh (100%) rename {archive/unit-tests => unit-tests}/reverse.sh (100%) rename {archive/unit-tests => unit-tests}/simple-list.sh (100%) rename {archive/unit-tests => unit-tests}/slurp.sh (100%) rename {archive/unit-tests => unit-tests}/string-allocation.sh (100%) rename {archive/unit-tests => unit-tests}/string-cons.sh (100%) rename {archive/unit-tests => unit-tests}/string-with-spaces.sh (100%) rename {archive/unit-tests => unit-tests}/subtract.sh (100%) rename {archive/unit-tests => unit-tests}/try.sh (100%) rename {archive/unit-tests => unit-tests}/varargs.sh (100%) rename {archive/unit-tests => unit-tests}/wide-character.sh (100%) diff --git a/src/c/io/fopen.h b/src/c/io/fopen.h index 5f87bd2..5bffe92 100644 --- a/src/c/io/fopen.h +++ b/src/c/io/fopen.h @@ -1,5 +1,5 @@ /* - * fopen.h + * io/fopen.h * * adapted from https://curl.haxx.se/libcurl/c/fopen.html. * diff --git a/src/c/io/print.c b/src/c/io/print.c new file mode 100644 index 0000000..227c958 --- /dev/null +++ b/src/c/io/print.c @@ -0,0 +1,122 @@ +/** + * io/print.c + * + * Post Scarcity Software Environment: print. + * + * Print basic Lisp objects..This is :bootstrap layer print; it needs to be + * able to print characters, symbols, integers, lists and dotted pairs. I + * don't think it needs to be able to print anything else. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "io/fopen.h" + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/character.h" +#include "payloads/cons.h" +#include "payloads/integer.h" + +struct pso_pointer in_print( pso_pointer p, URL_FILE * stream); + +struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) { + struct pso_pointer result = nil; + + if (consp(p)) { + for (; consp( p); p = cdr(p)) { + stuct pso2* object = pointer_to_object(cursor); + + result = in_print( object->payload.cons.car, stream); + + if (exceptionp(result)) break; + + switch (get_tag_value(object->payload.cons.cdr)) { + case NILTV : + break; + case CONSTV : + url_fputwc( L'\ ', output ); + break; + default : + url_fputws( L" . ", output); + result = in_print( object->payload.cons.cdr, stream); + } + + } + + struct pso_pointer cdr = object->payload.cons.cdr; + + switchb( get) + } else { + // TODO: return exception + } + + return result; +} + +struct pso_pointer in_print( pso_pointer p, URL_FILE * stream) { + stuct pso2* object = pointer_to_object(p); + struct pso_pointer result = nil; + + if )object != NULL) { + switch (get_tag_value( p)) { + case CHARACTERTV : + url_fputwc( object->payload.character.character, output); + break; + case CONSTV : + url_fputwc( L'\(', output ); + result = print_list_content( object, stream); + url_fputwc( L'\)', output ); + break; + case INTEGERTV : + fwprintf( output, "%d", (int64_t)(object->payload.integer.value)); + break; + case TRUETV : + url_fputwc( L'\t', output ); + break; + case NILTV : + url_fputws( L"nil", output ); + default : + // TODO: return exception + } + } else { + // TODO: return exception + } + + return result; +} + +/** + * @brief Simple print for bootstrap layer. + * + * @param p pointer to the object to print. + * @param stream if a pointer to an open write stream, print to there. + * @return struct pso_pointer `nil`, or an exception if some erroe occurred. + */ +struct pso_pointer print( pso_pointer p, pso_pointer stream) { + URL_FILE *output = writep( stream) ? + pointer_to_object( stream )->payload.stream.stream: + stdout; + + if ( writep( stream)) { inc_ref( stream); } + + struct pso_pointer result = in_print(p, output); + + if ( writep( stream)) { dec_ref( stream); } + + return result; +} diff --git a/src/c/io/print.h b/src/c/io/print.h new file mode 100644 index 0000000..9aa793f --- /dev/null +++ b/src/c/io/print.h @@ -0,0 +1,19 @@ +/** + * io/print.c + * + * Post Scarcity Software Environment: print. + * + * Print basic Lisp objects..This is :bootstrap layer print; it needs to be + * able to print characters, symbols, integers, lists and dotted pairs. I + * don't think it needs to be able to print anything else. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_print_h +#define __psse_io_print_h + +struct pso_pointer print( pso_pointer p, pso_pointer stream); + +#endif \ No newline at end of file diff --git a/src/c/io/read.h b/src/c/io/read.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/memory/page.c b/src/c/memory/page.c index b0afe4f..2d3319d 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -11,7 +11,9 @@ #include #include #include + #include "debug.h" + #include "memory/memory.h" #include "memory/node.h" #include "memory/page.h" @@ -29,6 +31,8 @@ #include "memory/psod.h" #include "memory/psoe.h" #include "memory/psof.h" +#include "memory/tags.h" + #include "payloads/free.h" /** diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 6982ca8..a3a48e7 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -24,6 +24,8 @@ #include "memory/page.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/tags.h" + #include "ops/truth.h" /** @@ -171,20 +173,3 @@ void lock_object( struct pso_pointer pointer ) { } -/** - * @brief Get the numeric value of the tag bytes of the object indicated - * by this pointer - * - * @param pointer a pointer to an object. - * @return the tag value of the object indicated. - */ -uint32_t get_tag_value( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); - uint32_t result = ( object->header.tag.value & 0xffffff ); - - if ( vectorpointp( pointer ) ) { - result = ( object->payload.vectorp.tag.value & 0xffffff ); - } - - return result; -} diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 1ce7bf2..3d74fe7 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -251,6 +251,6 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ); void lock_object( struct pso_pointer pointer); -uint32_t get_tag_value( struct pso_pointer pointer); +// uint32_t get_tag_value( struct pso_pointer pointer); #endif diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 0c36b29..e0080cb 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -13,6 +13,8 @@ #include #include "memory/header.h" +#include "memory/tags.h" + #include "payloads/character.h" #include "payloads/cons.h" #include "payloads/free.h" diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h new file mode 100644 index 0000000..f513699 --- /dev/null +++ b/src/c/memory/tags.h @@ -0,0 +1,125 @@ +/** + * memory/tags.h + * + * Tags for all page space and vector objects known to the bootstrap layer. + * + * All macros! + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_tags_h +#define __psse_memory_tags_h + +#define TAGLENGTH 3 + +#define CONSTAG "CNS" +#define EXCEPTIONTAG "EXP" +#define FREETAG "FRE" +#define FUNCTIONTAG "FUN" +#define HASHTAG "HTB" +#define INTEGERTAG "INT" +#define KEYTAG "KEY" +#define LAMBDATAG "LMD" +#define LOOPTAG "LOP" +#define LAZYCONSTAG "LZY" +#define LAZYSTRTAG "LZS" +#define LAZYWRKRTAG "WRK" +#define MUTEXTAG "MTX" +#define NAMESPACETAG "NSP" +#define NILTAG "NIL" +#define NLAMBDATAG "NLM" +#define RATIOTAG "RAT" +#define READTAG "RED" +#define REALTAG "REA" +#define SPECIALTAG "SFM" +#define STACKTAG "STK" +#define STRINGTAG "STR" +#define SYMBOLTAG "SYM" +#define TIMETAG "TIM" +#define TRUETAG "TRU" +#define VECTORTAG "VEC" +#define VECTORPOINTTAG "VSP" +#define WRITETAG "WRT" + +// TODO: all these tag values are WRONG, recalculate! + +#define CONSTV 5459523 +#define EXCEPTIONTV 5265477 +#define FREETV 4543046 +#define FUNCTIONTV 5133638 +#define HASHTV 4346952 +#define INTEGERTV 5525065 +#define KEYTV 5850443 +#define LAMBDATV 4345164 +#define LOOPTV 5263180 +#define MUTEXTV 5788749 +#define NAMESPACETV 5264206 +#define NILTV 4999502 +#define NLAMBDATV 5065806 +#define RATIOTV 5521746 +#define READTV 4474194 +#define REALTV 4277586 +#define SPECIALTV 5064275 +#define STACKTV 4936787 +#define STRINGTV 5395539 +#define SYMBOLTV 5069139 +#define TIMETV 5065044 +#define TRUETV 5591636 +#define VECTORTV 4408662 +#define VECTORPOINTTV 5264214 +#define WRITETV 5264214 + +#define consp(p) (check_tag(p,CONSTV)) +#define exceptionp(p) (check_tag(p,EXCEPTIONTV)) +#define freep(p) (check_tag(p,FREETV)) +#define functionp(p) (check_tag(p,FUNCTIONTV)) +#define integerp(p) (check_tag(p,INTEGERTV)) +#define keywordp(p) (check_tag(p,KEYTV)) +#define lambdap(p) (check_tag(p,LAMBDATV)) +#define loopp(p) (check_tag(p,LOOPTV)) +#define namespacep(p)(check_tag(p,NAMESPACETV)) +// the version of nilp in ops/truth.c is better than this, because it does not +// require a fetch, and will see nils curated by other nodes as nil. +// #define nilp(p) (check_tag(p,NILTV)) +#define numberp(p) (check_tag(p,INTEGERTV)||check_tag(p,RATIOTV)||check_tag(p,REALTV)) +#define ratiop(p) (check_tag(p,RATIOTV)) +#define readp(p) (check_tag(p,READTV)) +#define realp(p) (check_tag(p,REALTV)) +#define sequencep(p) (check_tag(p,CONSTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV)) +#define specialp(p) (check_tag(p,SPECIALTV)) +#define streamp(p) (check_tag(p,READTV)||check_tag(p,WRITETV)) +#define stringp(p) (check_tag(p,STRINGTV)) +#define symbolp(p) (check_tag(p,SYMBOLTV)) +#define timep(p) (check_tag(p,TIMETV)) +// the version of truep in ops/truth.c is better than this, because it does not +// require a fetch, and will see ntsils curated by other nodes as t. +// #define tp(p) (check_tag(p,TRUETV)) +// #define truep(p) ( !check_tag(p,NILTV)) +#define vectorpointp(p) (check_tag(p,VECTORPOINTTV)) +#define vectorp(p) (check_tag(p,VECTORTV)) +#define writep(p) (check_tag(p,WRITETV)) + +/** + * @brief return the numerical value of the tag of the object indicated by + * pointer `p`. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + * + * @return the numerical value of the tag, as a uint32_t. + */ +#define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) + +/** + * @brief check that the tag of the object indicated by this poiner has this + * value. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + * @param v should be an integer, ideally uint32_t, the expected value of a tag. + * + * @return true if the tag at p matches v, else false. + */ +#define check_tag(p,v) (get_tag_value(p) == v) + +#endif \ No newline at end of file diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index 5e20b71..17e4c15 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -11,6 +11,8 @@ #include "memory/pointer.h" #include "memory/pso4.h" +#include "memory/tags.h" + #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/function.h" diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 00219e7..2417385 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -13,6 +13,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/tags.h" #include "payloads/cons.h" /** @@ -36,17 +37,6 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { return result; } -/** - * @brief return true if `ptr` indicates a cons cell, else false. - * - * @param ptr a pointer. - * @return true if `ptr` indicates a cons cell. - * @return false otherwise - */ -bool consp( struct pso_pointer ptr ) { - // TODO: make it actually work! - return false; -} /** * @brief return the car of this cons cell. diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 91d1f1b..48e6782 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -13,11 +13,6 @@ #include "memory/pointer.h" -/** - * An ordinary cons cell: - */ -#define CONSTAG "CNS" -#define CONSTV 5459523 /** * @brief A cons cell. diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 507b804..b61f401 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -12,10 +12,3 @@ #include "memory/pso.h" #include "payloads/exception.h" -/** - * @param p a pointer to an object. - * @return true if that object is an exception, else false. - */ -bool exceptionp( struct pso_pointer p ) { - return ( get_tag_value( p ) == EXCEPTIONTV ); -} diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 38314ee..c522f96 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -13,9 +13,6 @@ #include "memory/pointer.h" -#define EXCEPTIONTAG "EXP" -#define EXCEPTIONTV 5265477 - /** * @brief An exception; required three pointers, so use object of size class 3. */ @@ -28,6 +25,4 @@ struct exception_payload { struct pso_pointer cause; }; -bool exceptionp( struct pso_pointer p ); - #endif diff --git a/src/c/payloads/free.h b/src/c/payloads/free.h index 947a3e4..cf4706f 100644 --- a/src/c/payloads/free.h +++ b/src/c/payloads/free.h @@ -12,12 +12,6 @@ #include "memory/pointer.h" -/** - * @brief Tag for an unassigned object; may be of any size class. - */ -#define FREETAG "FRE" -#define FREETV 4543046 - /** * @brief An unassigned object, on a freelist; may be of any size class. * diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index bd02836..ea54051 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -13,14 +13,6 @@ #include "memory/pointer.h" #include "memory/pso4.h" -/** - * @brief Tag for an ordinary Lisp function - one whose arguments are pre-evaluated. - * \see LAMBDATAG for interpretable functions. - * \see SPECIALTAG for functions whose arguments are not pre-evaluated. - */ -#define FUNCTIONTAG "FUN" -#define FUNCTIONTV 5133638 - /** * @brief Payload of a function cell. * `source` points to the source from which the function was compiled, or NIL diff --git a/src/c/payloads/hashtable.h b/src/c/payloads/hashtable.h index b235b0b..6cf8144 100644 --- a/src/c/payloads/hashtable.h +++ b/src/c/payloads/hashtable.h @@ -32,13 +32,6 @@ #include "memory/pointer.h" -/** - * @brief Tag for an ordinary Lisp hashtable - one whose contents are immutable. - * \see NAMESPACETAG for mutable hashtables. - */ -#define HASHTABLETAG "HTB" -#define HASHTABLETV 4346952 - /** * The payload of a hashtable. The number of buckets is assigned at run-time, * and is stored in n_buckets. Each bucket is something ASSOC can consume: diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index 00ee92d..025882c 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -12,9 +12,6 @@ #include -#define INTEGERTAG "INT" -#define INTEGERTV 5525065 - /** * @brief An integer . * diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h index de89749..4728066 100644 --- a/src/c/payloads/keyword.h +++ b/src/c/payloads/keyword.h @@ -12,12 +12,6 @@ #include "memory/pointer.h" -/** - * Tag for a keyword - an interned, self-evaluating string. - */ -#define KEYTAG "KEY" -#define KEYTV 5850443 - /* TODO: for now, Keyword shares a payload with String, but this may change. * Strings are of indefinite length, but keywords are really not, and might * fit into any size class. */ diff --git a/src/c/payloads/mutex.h b/src/c/payloads/mutex.h index f158b0d..5b6346f 100644 --- a/src/c/payloads/mutex.h +++ b/src/c/payloads/mutex.h @@ -14,14 +14,6 @@ #include "memory/pointer.h" -/** - * @brief Tag for mutex cell. mutexes are thread-safe locks, required by - * mutable objects. - * \see FUNCTIONTAG. - */ -#define MUTEXTAG "MTX" -#define MUTEXTV 5788749 - /** * @brief payload for mutex objects. * diff --git a/src/c/payloads/namespace.h b/src/c/payloads/namespace.h index 229c8e4..cba0112 100644 --- a/src/c/payloads/namespace.h +++ b/src/c/payloads/namespace.h @@ -35,13 +35,6 @@ #include "memory/pointer.h" -/** - * @brief Tag for a Lisp namespace - a hashtable whose contents are mutable. - * \see HASHTABLETAG for mutable hashtables. - */ -#define NAMESPACETAG "NSP" -#define NAMESPACETV 5264206 - /** * The payload of a namespace. The number of buckets is assigned at run-time, * and is stored in n_buckets. Each bucket is something ASSOC can consume: diff --git a/src/c/payloads/nlambda.h b/src/c/payloads/nlambda.h index 1f0771f..d82d2e3 100644 --- a/src/c/payloads/nlambda.h +++ b/src/c/payloads/nlambda.h @@ -12,12 +12,6 @@ #include "memory/pointer.h" -/** - * An ordinary nlambda cell: - */ -#define NLAMBDATAG "NLM" -#define NLAMBDATV 5065806 - /* nlambda shares a payload with lambda */ #endif diff --git a/src/c/payloads/psse-string.h b/src/c/payloads/psse-string.h index c08690d..90d87da 100644 --- a/src/c/payloads/psse-string.h +++ b/src/c/payloads/psse-string.h @@ -17,13 +17,6 @@ #include "memory/pointer.h" - -/** - * @brief Tag for string of characters, organised as a linked list. - */ -#define STRINGTAG "STR" -#define STRINGTV 5395539 - /** * @brief payload of a string cell. * diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index ef2f5cc..bb0e000 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -17,12 +17,6 @@ #include "io/fopen.h" #include "memory/pointer.h" -/** - * An open read stream. - */ -#define READTAG "REA" -#define READTV 4277586 - /** * payload of a read or write stream cell. */ diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index b0ff91b..5ccdb1f 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -21,7 +21,5 @@ * provided. * \see NLAMBDATAG. */ -#define SPECIALTAG "SFM" -#define SPECIALTV 5064275 #endif diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index b02e8f0..b33d7a3 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,10 +13,6 @@ #define __psse_payloads_stack_h #include "memory/pointer.h" -// #include "memory/pso4.h" - -#define STACKTAG "STK" -#define STACKTV 4936787 /* * number of arguments stored in a stack frame diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index fdc01c1..cddd293 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -12,13 +12,6 @@ #include "memory/pointer.h" - -/** - * Tag for a symbol: just like a keyword except not self-evaluating. - */ -#define SYMBOLTAG "SYM" -#define SYMBOLTV 5069139 - /* TODO: for now, Symbol shares a payload with String, but this may change. * Strings are of indefinite length, but symbols are really not, and might * fit into any size class. */ diff --git a/src/c/payloads/vector_pointer.c b/src/c/payloads/vector_pointer.c deleted file mode 100644 index e575874..0000000 --- a/src/c/payloads/vector_pointer.c +++ /dev/null @@ -1,18 +0,0 @@ -/** - * payloads/vector_pointer.c - * - * A pointer to an object in vector space. - * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#include "memory/pointer.h" -#include "memory/pso.h" -#include "payloads/vector_pointer.h" - -bool vectorpointp( struct pso_pointer p ) { - return ( get_tag_value( p ) == VECTORPOINTTV ); -} diff --git a/src/c/payloads/vector_pointer.h b/src/c/payloads/vector_pointer.h index e527bb1..4be88b6 100644 --- a/src/c/payloads/vector_pointer.h +++ b/src/c/payloads/vector_pointer.h @@ -39,6 +39,4 @@ struct vectorp_payload { void *address; }; -bool vectorpointp( struct pso_pointer p ); - #endif diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index 1197d73..d647575 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -10,14 +10,5 @@ #ifndef __psse_payloads_write_stream_h #define __psse_payloads_write_stream_h -#include "io/fopen.h" -#include "memory/pointer.h" - -/** - * @brief Tag for an open write stream. - */ -#define WRITETAG "WRT" -#define WRITETV 5264214 - /* write stream shares a payload with /see read_streem.h */ #endif diff --git a/archive/unit-tests/add.sh b/unit-tests/add.sh similarity index 100% rename from archive/unit-tests/add.sh rename to unit-tests/add.sh diff --git a/archive/unit-tests/allocation-tests/allocation-tester.sh b/unit-tests/allocation-tests/allocation-tester.sh similarity index 100% rename from archive/unit-tests/allocation-tests/allocation-tester.sh rename to unit-tests/allocation-tests/allocation-tester.sh diff --git a/archive/unit-tests/allocation-tests/allocation-tests.csv b/unit-tests/allocation-tests/allocation-tests.csv similarity index 100% rename from archive/unit-tests/allocation-tests/allocation-tests.csv rename to unit-tests/allocation-tests/allocation-tests.csv diff --git a/archive/unit-tests/allocation-tests/allocation-tests.ods b/unit-tests/allocation-tests/allocation-tests.ods similarity index 100% rename from archive/unit-tests/allocation-tests/allocation-tests.ods rename to unit-tests/allocation-tests/allocation-tests.ods diff --git a/archive/unit-tests/allocation-tests/feature-2.test.tmp b/unit-tests/allocation-tests/feature-2.test.tmp similarity index 100% rename from archive/unit-tests/allocation-tests/feature-2.test.tmp rename to unit-tests/allocation-tests/feature-2.test.tmp diff --git a/archive/unit-tests/allocation-tests/grep.bb b/unit-tests/allocation-tests/grep.bb similarity index 100% rename from archive/unit-tests/allocation-tests/grep.bb rename to unit-tests/allocation-tests/grep.bb diff --git a/archive/unit-tests/allocation-tests/test-forms b/unit-tests/allocation-tests/test-forms similarity index 100% rename from archive/unit-tests/allocation-tests/test-forms rename to unit-tests/allocation-tests/test-forms diff --git a/archive/unit-tests/append.sh b/unit-tests/append.sh similarity index 100% rename from archive/unit-tests/append.sh rename to unit-tests/append.sh diff --git a/archive/unit-tests/apply.sh b/unit-tests/apply.sh similarity index 100% rename from archive/unit-tests/apply.sh rename to unit-tests/apply.sh diff --git a/archive/unit-tests/assoc.sh b/unit-tests/assoc.sh similarity index 100% rename from archive/unit-tests/assoc.sh rename to unit-tests/assoc.sh diff --git a/archive/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh similarity index 100% rename from archive/unit-tests/bignum-add.sh rename to unit-tests/bignum-add.sh diff --git a/archive/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh similarity index 100% rename from archive/unit-tests/bignum-expt.sh rename to unit-tests/bignum-expt.sh diff --git a/archive/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh similarity index 100% rename from archive/unit-tests/bignum-print.sh rename to unit-tests/bignum-print.sh diff --git a/archive/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh similarity index 100% rename from archive/unit-tests/bignum-subtract.sh rename to unit-tests/bignum-subtract.sh diff --git a/archive/unit-tests/bignum.sh b/unit-tests/bignum.sh similarity index 100% rename from archive/unit-tests/bignum.sh rename to unit-tests/bignum.sh diff --git a/archive/unit-tests/complex-list.sh b/unit-tests/complex-list.sh similarity index 100% rename from archive/unit-tests/complex-list.sh rename to unit-tests/complex-list.sh diff --git a/archive/unit-tests/cond.sh b/unit-tests/cond.sh similarity index 100% rename from archive/unit-tests/cond.sh rename to unit-tests/cond.sh diff --git a/archive/unit-tests/empty-list.sh b/unit-tests/empty-list.sh similarity index 100% rename from archive/unit-tests/empty-list.sh rename to unit-tests/empty-list.sh diff --git a/archive/unit-tests/empty-string.sh b/unit-tests/empty-string.sh similarity index 100% rename from archive/unit-tests/empty-string.sh rename to unit-tests/empty-string.sh diff --git a/archive/unit-tests/equal.sh b/unit-tests/equal.sh similarity index 100% rename from archive/unit-tests/equal.sh rename to unit-tests/equal.sh diff --git a/archive/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh similarity index 100% rename from archive/unit-tests/eval-integer.sh rename to unit-tests/eval-integer.sh diff --git a/archive/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh similarity index 100% rename from archive/unit-tests/eval-quote-sexpr.sh rename to unit-tests/eval-quote-sexpr.sh diff --git a/archive/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh similarity index 100% rename from archive/unit-tests/eval-quote-symbol.sh rename to unit-tests/eval-quote-symbol.sh diff --git a/archive/unit-tests/eval-real.sh b/unit-tests/eval-real.sh similarity index 100% rename from archive/unit-tests/eval-real.sh rename to unit-tests/eval-real.sh diff --git a/archive/unit-tests/eval-string.sh b/unit-tests/eval-string.sh similarity index 100% rename from archive/unit-tests/eval-string.sh rename to unit-tests/eval-string.sh diff --git a/archive/unit-tests/fred.sh b/unit-tests/fred.sh similarity index 100% rename from archive/unit-tests/fred.sh rename to unit-tests/fred.sh diff --git a/archive/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh similarity index 100% rename from archive/unit-tests/integer-allocation.sh rename to unit-tests/integer-allocation.sh diff --git a/archive/unit-tests/integer.sh b/unit-tests/integer.sh similarity index 100% rename from archive/unit-tests/integer.sh rename to unit-tests/integer.sh diff --git a/archive/unit-tests/interpreter.sh b/unit-tests/interpreter.sh similarity index 100% rename from archive/unit-tests/interpreter.sh rename to unit-tests/interpreter.sh diff --git a/archive/unit-tests/lambda.sh b/unit-tests/lambda.sh similarity index 100% rename from archive/unit-tests/lambda.sh rename to unit-tests/lambda.sh diff --git a/archive/unit-tests/let.sh b/unit-tests/let.sh similarity index 100% rename from archive/unit-tests/let.sh rename to unit-tests/let.sh diff --git a/archive/unit-tests/list-test.sh b/unit-tests/list-test.sh similarity index 100% rename from archive/unit-tests/list-test.sh rename to unit-tests/list-test.sh diff --git a/archive/unit-tests/many-args.sh b/unit-tests/many-args.sh similarity index 100% rename from archive/unit-tests/many-args.sh rename to unit-tests/many-args.sh diff --git a/archive/unit-tests/map.sh b/unit-tests/map.sh similarity index 100% rename from archive/unit-tests/map.sh rename to unit-tests/map.sh diff --git a/archive/unit-tests/mapcar.sh b/unit-tests/mapcar.sh similarity index 100% rename from archive/unit-tests/mapcar.sh rename to unit-tests/mapcar.sh diff --git a/archive/unit-tests/memberp.sh b/unit-tests/memberp.sh similarity index 100% rename from archive/unit-tests/memberp.sh rename to unit-tests/memberp.sh diff --git a/archive/unit-tests/memory.sh b/unit-tests/memory.sh similarity index 100% rename from archive/unit-tests/memory.sh rename to unit-tests/memory.sh diff --git a/archive/unit-tests/multiply.sh b/unit-tests/multiply.sh similarity index 100% rename from archive/unit-tests/multiply.sh rename to unit-tests/multiply.sh diff --git a/archive/unit-tests/nil.sh b/unit-tests/nil.sh similarity index 100% rename from archive/unit-tests/nil.sh rename to unit-tests/nil.sh diff --git a/archive/unit-tests/nlambda.sh b/unit-tests/nlambda.sh similarity index 100% rename from archive/unit-tests/nlambda.sh rename to unit-tests/nlambda.sh diff --git a/archive/unit-tests/path-notation.sh b/unit-tests/path-notation.sh similarity index 100% rename from archive/unit-tests/path-notation.sh rename to unit-tests/path-notation.sh diff --git a/archive/unit-tests/progn.sh b/unit-tests/progn.sh similarity index 100% rename from archive/unit-tests/progn.sh rename to unit-tests/progn.sh diff --git a/archive/unit-tests/quote.sh b/unit-tests/quote.sh similarity index 100% rename from archive/unit-tests/quote.sh rename to unit-tests/quote.sh diff --git a/archive/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh similarity index 100% rename from archive/unit-tests/quoted-list.sh rename to unit-tests/quoted-list.sh diff --git a/archive/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh similarity index 100% rename from archive/unit-tests/ratio-addition.sh rename to unit-tests/ratio-addition.sh diff --git a/archive/unit-tests/recursion.sh b/unit-tests/recursion.sh similarity index 100% rename from archive/unit-tests/recursion.sh rename to unit-tests/recursion.sh diff --git a/archive/unit-tests/reverse.sh b/unit-tests/reverse.sh similarity index 100% rename from archive/unit-tests/reverse.sh rename to unit-tests/reverse.sh diff --git a/archive/unit-tests/simple-list.sh b/unit-tests/simple-list.sh similarity index 100% rename from archive/unit-tests/simple-list.sh rename to unit-tests/simple-list.sh diff --git a/archive/unit-tests/slurp.sh b/unit-tests/slurp.sh similarity index 100% rename from archive/unit-tests/slurp.sh rename to unit-tests/slurp.sh diff --git a/archive/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh similarity index 100% rename from archive/unit-tests/string-allocation.sh rename to unit-tests/string-allocation.sh diff --git a/archive/unit-tests/string-cons.sh b/unit-tests/string-cons.sh similarity index 100% rename from archive/unit-tests/string-cons.sh rename to unit-tests/string-cons.sh diff --git a/archive/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh similarity index 100% rename from archive/unit-tests/string-with-spaces.sh rename to unit-tests/string-with-spaces.sh diff --git a/archive/unit-tests/subtract.sh b/unit-tests/subtract.sh similarity index 100% rename from archive/unit-tests/subtract.sh rename to unit-tests/subtract.sh diff --git a/archive/unit-tests/try.sh b/unit-tests/try.sh similarity index 100% rename from archive/unit-tests/try.sh rename to unit-tests/try.sh diff --git a/archive/unit-tests/varargs.sh b/unit-tests/varargs.sh similarity index 100% rename from archive/unit-tests/varargs.sh rename to unit-tests/varargs.sh diff --git a/archive/unit-tests/wide-character.sh b/unit-tests/wide-character.sh similarity index 100% rename from archive/unit-tests/wide-character.sh rename to unit-tests/wide-character.sh From 364d7d2c7bc6581d1f5f5d2b133f3447d22e6741 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 31 Mar 2026 15:05:44 +0100 Subject: [PATCH 23/29] Compiles again, now with bootstrap-layer print implemented, but not yet tested. To get print implemented, I also had to implement a lot of other things. --- src/c/debug.c | 8 + src/c/debug.h | 8 +- src/c/io/fopen.c | 526 ++++++++++++++++++++++++++++++++ src/c/io/io.c | 574 +++++++++++++++++++++++++++++++++++ src/c/io/io.h | 49 +++ src/c/io/print.c | 42 +-- src/c/io/print.h | 2 +- src/c/memory/pso2.h | 2 - src/c/memory/tags.c | 53 ++++ src/c/memory/tags.h | 68 +++-- src/c/ops/eval.c | 1 + src/c/ops/string_ops.c | 164 ++++++++++ src/c/ops/string_ops.h | 32 ++ src/c/payloads/cons.h | 1 + src/c/payloads/exception.c | 6 + src/c/payloads/exception.h | 3 +- src/c/payloads/integer.c | 39 +++ src/c/payloads/integer.h | 1 + src/c/payloads/psse-string.h | 2 + src/c/payloads/psse_string.c | 25 ++ src/c/utils.c | 33 ++ src/c/utils.h | 17 ++ src/sed/convert.sed | 17 ++ 23 files changed, 1616 insertions(+), 57 deletions(-) create mode 100644 src/c/io/fopen.c create mode 100644 src/c/io/io.c create mode 100644 src/c/io/io.h create mode 100644 src/c/memory/tags.c create mode 100644 src/c/ops/string_ops.c create mode 100644 src/c/ops/string_ops.h create mode 100644 src/c/payloads/integer.c create mode 100644 src/c/payloads/psse_string.c create mode 100644 src/c/utils.c create mode 100644 src/c/utils.h create mode 100644 src/sed/convert.sed diff --git a/src/c/debug.c b/src/c/debug.c index d6c5c27..3c7b1bc 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -45,6 +45,14 @@ void debug_print( wchar_t *message, int level, int indent ) { #endif } +void debug_print_object( struct pso_pointer object, int level, int indent ) { + // TODO: not yet implemented +} + +void debug_dump_object( struct pso_pointer object, int level, int indent ) { + // TODO: not yet implemented +} + /** * @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`. * diff --git a/src/c/debug.h b/src/c/debug.h index 1f66a9f..be9d166 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -23,6 +23,8 @@ #include #include +#include "memory/pointer.h" + /** * @brief Print messages debugging memory allocation. * @@ -102,10 +104,14 @@ extern int verbosity; void debug_print( wchar_t *message, int level, int indent ); +void debug_print_object( struct pso_pointer object, int level, int indent ); + +void debug_dump_object( struct pso_pointer object, int level, int indent ); + void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); void debug_printf( int level, int indent, wchar_t *format, ... ); -#endif \ No newline at end of file +#endif diff --git a/src/c/io/fopen.c b/src/c/io/fopen.c new file mode 100644 index 0000000..983fcd1 --- /dev/null +++ b/src/c/io/fopen.c @@ -0,0 +1,526 @@ +/* + * fopen.c + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#include +#include +#ifndef WIN32 +#include +#endif +#include +#include + +#include + +#include "io/fopen.h" +#ifdef FOPEN_STANDALONE +CURLSH *io_share; +#else +#include "memory/pso2.h" +#include "io/io.h" +#include "utils.h" +#endif + + +/* exported functions */ +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); + +/* we use a global one for convenience */ +static CURLM *multi_handle; + +/* curl calls this routine to get more data */ +static size_t write_callback( char *buffer, + size_t size, size_t nitems, void *userp ) { + char *newbuff; + size_t rembuff; + + URL_FILE *url = ( URL_FILE * ) userp; + size *= nitems; + + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + + if ( size > rembuff ) { + /* not enough space in buffer */ + newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); + if ( newbuff == NULL ) { + fprintf( stderr, "callback buffer grow failed\n" ); + size = rembuff; + } else { + /* realloc succeeded increase buffer size */ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } + + memcpy( &url->buffer[url->buffer_pos], buffer, size ); + url->buffer_pos += size; + + return size; +} + +/* use to attempt to fill the read buffer up to requested number of bytes */ +static int fill_buffer( URL_FILE *file, size_t want ) { + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ + + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) + return 0; + + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; + + FD_ZERO( &fdread ); + FD_ZERO( &fdwrite ); + FD_ZERO( &fdexcep ); + + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; + + curl_multi_timeout( multi_handle, &curl_timeo ); + if ( curl_timeo >= 0 ) { + timeout.tv_sec = curl_timeo / 1000; + if ( timeout.tv_sec > 1 ) + timeout.tv_sec = 1; + else + timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; + } + + /* get file descriptors from the transfers */ + mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, + &maxfd ); + + if ( mc != CURLM_OK ) { + fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); + break; + } + + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ + + if ( maxfd == -1 ) { +#ifdef _WIN32 + Sleep( 100 ); + rc = 0; +#else + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select( 0, NULL, NULL, NULL, &wait ); +#endif + } else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); + } + + switch ( rc ) { + case -1: + /* select error */ + break; + + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform( multi_handle, &file->still_running ); + break; + } + } while ( file->still_running && ( file->buffer_pos < want ) ); + return 1; +} + +/* use to remove want bytes from the front of a files buffer */ +static int use_buffer( URL_FILE *file, size_t want ) { + /* sort out buffer */ + if ( ( file->buffer_pos - want ) <= 0 ) { + /* ditch buffer - write will recreate */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } else { + /* move rest down make it available for later */ + memmove( file->buffer, + &file->buffer[want], ( file->buffer_pos - want ) ); + + file->buffer_pos -= want; + } + return 0; +} + +URL_FILE *url_fopen( const char *url, const char *operation ) { + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ + + URL_FILE *file; + ( void ) operation; + + file = calloc( 1, sizeof( URL_FILE ) ); + if ( !file ) + return NULL; + + file->handle.file = fopen( url, operation ); + if ( file->handle.file ) { + file->type = CFTYPE_FILE; /* marked as file */ + } else if ( index_of( ':', url ) > -1 ) { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init( ); + + curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); + curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, + write_callback ); + /* use the share object */ + curl_easy_setopt( file->handle.curl, CURLOPT_SHARE, io_share ); + + + if ( !multi_handle ) + multi_handle = curl_multi_init( ); + + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* lets start the fetch */ + curl_multi_perform( multi_handle, &file->still_running ); + + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + + free( file ); + + file = NULL; + } + } else { + file->type = CFTYPE_NONE; + /* not a file, and doesn't look like a URL. */ + } + + return file; +} + +int url_fclose( URL_FILE *file ) { + int ret = 0; /* default is good return */ + + switch ( file->type ) { + case CFTYPE_FILE: + ret = fclose( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free( file->buffer ); /* free any allocated buffer space */ + free( file ); + + return ret; +} + +int url_feof( URL_FILE *file ) { + int ret = 0; + + switch ( file->type ) { + case CFTYPE_FILE: + ret = feof( file->handle.file ); + break; + + case CFTYPE_CURL: + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) { + size_t want; + + switch ( file->type ) { + case CFTYPE_FILE: + want = fread( ptr, size, nmemb, file->handle.file ); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if ( !file->buffer_pos ) + return 0; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + + use_buffer( file, want ); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets( char *ptr, size_t size, URL_FILE *file ) { + size_t want = size - 1; /* always need to leave room for zero termination */ + size_t loop; + + switch ( file->type ) { + case CFTYPE_FILE: + ptr = fgets( ptr, ( int ) size, file->handle.file ); + break; + + case CFTYPE_CURL: + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if ( !file->buffer_pos ) + return NULL; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for ( loop = 0; loop < want; loop++ ) { + if ( file->buffer[loop] == '\n' ) { + want = loop + 1; /* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + ptr[want] = 0; /* always null terminate */ + + use_buffer( file, want ); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr; /*success */ +} + +void url_rewind( URL_FILE *file ) { + switch ( file->type ) { + case CFTYPE_FILE: + rewind( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* restart */ + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* ditch buffer - write will recreate - resets stream pos */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } +} + +#ifdef FOPEN_STANDALONE +#define FGETSFILE "fgets.test" +#define FREADFILE "fread.test" +#define REWINDFILE "rewind.test" + +/* Small main program to retrieve from a url using fgets and fread saving the + * output to two test files (note the fgets method will corrupt binary files if + * they contain 0 chars */ +int main( int argc, char *argv[] ) { + URL_FILE *handle; + FILE *outf; + + size_t nread; + char buffer[256]; + const char *url; + + CURL *curl; + CURLcode res; + + curl_global_init( CURL_GLOBAL_DEFAULT ); + + curl = curl_easy_init( ); + + + if ( argc < 2 ) + url = "http://192.168.7.3/testfile"; /* default to testurl */ + else + url = argv[1]; /* use passed url */ + + /* copy from url line by line with fgets */ + outf = fopen( FGETSFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fgets output file\n" ); + return 1; + } + + handle = url_fopen( url, "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() %s\n", url ); + fclose( outf ); + return 2; + } + + while ( !url_feof( handle ) ) { + url_fgets( buffer, sizeof( buffer ), handle ); + fwrite( buffer, 1, strlen( buffer ), outf ); + } + + url_fclose( handle ); + + fclose( outf ); + + + /* Copy from url with fread */ + outf = fopen( FREADFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } + + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } + + do { + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + } while ( nread ); + + url_fclose( handle ); + + fclose( outf ); + + + /* Test rewind */ + outf = fopen( REWINDFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } + + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } + + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + url_rewind( handle ); + + buffer[0] = '\n'; + fwrite( buffer, 1, 1, outf ); + + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + + url_fclose( handle ); + + fclose( outf ); + + return 0; /* all done */ +} +#endif diff --git a/src/c/io/io.c b/src/c/io/io.c new file mode 100644 index 0000000..5729504 --- /dev/null +++ b/src/c/io/io.c @@ -0,0 +1,574 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. NOTE + * that this file destructively changes metadata on URL connections, + * because the metadata is not available until the stream has been read + * from. It would be better to find a workaround! + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include + +//#include "arith/integer.h" +#include "debug.h" +#include "io/fopen.h" +#include "io/io.h" + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +// #include "ops/intern.h" +// #include "ops/lispops.h" + +#include "ops/stack_ops.h" +#include "ops/string_ops.h" +#include "ops/truth.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/integer.h" +#include "payloads/stack.h" + +#include "utils.h" + +/** + * The sharing hub for all connections. TODO: Ultimately this probably doesn't + * work for a multi-user environment and we will need one sharing hub for each + * user, or else we will need to not share at least cookies and ssl sessions. + */ +CURLSH *io_share; + +/** + * @brief bound to the Lisp string representing C_IO_IN in initialisation. + */ +struct pso_pointer lisp_io_in; +/** + * @brief bound to the Lisp string representing C_IO_OUT in initialisation. + */ +struct pso_pointer lisp_io_out; + + +/** + * Allow a one-character unget facility. This may not be enough - we may need + * to allocate a buffer. + */ +wint_t ungotten = 0; + +/** + * Initialise the I/O subsystem. + * + * @return 0 on success; any other value means failure. + */ +int io_init( ) { + int result = curl_global_init( CURL_GLOBAL_SSL ); + + io_share = curl_share_init( ); + + if ( result == 0 ) { + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, + CURL_LOCK_DATA_SSL_SESSION ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL ); + } + + return result; +} + +/** + * Convert this lisp string-like-thing (also works for symbols, and, later + * keywords) into a UTF-8 string. NOTE that the returned value has been + * malloced and must be freed. TODO: candidate to moving into a utilities + * file. + * + * @param s the lisp string or symbol; + * @return the c string. + */ +char *lisp_string_to_c_string( struct pso_pointer s ) { + char *result = NULL; + + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; + + for ( struct pso_pointer c = s; !nilp( c ); + c = cdr(c)) { + len++; + } + + wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + /* worst case, one wide char = four utf bytes */ + result = calloc( ( len * 4 ) + 1, sizeof( char ) ); + + int i = 0; + for ( struct pso_pointer c = s; !nilp( c ); + c = cdr(c)) { + buffer[i++] = pointer_to_object( c )->payload.string.character; + } + + wcstombs( result, buffer, len ); + free( buffer ); + } + + debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 ); + debug_print_object( s, DEBUG_IO , 0); + debug_printf( DEBUG_IO, 0, L") => '%s'\n", result ); + + return result; +} + + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE *file_to_url_file( FILE *f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); + + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } + + return result; +} + + +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc( URL_FILE *input ) { + wint_t result = -1; + + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", + DEBUG_IO, 0 ); + url_fgets( cbuff, 2, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", + DEBUG_IO, 0 ); + int c = ( int ) cbuff[0]; + // TODO: risk of reading off cbuff? + debug_printf( DEBUG_IO, 0, + L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", + cbuff, c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0xf7 ) { + count = 1; + } else if ( c >= 0xc2 && c <= 0xdf ) { + count = 2; + } else if ( c >= 0xe0 && c <= 0xef ) { + count = 3; + } else if ( c >= 0xf0 && c <= 0xff ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( ( char * ) &cbuff[1], count, input ); + } + mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } + } + + debug_printf( DEBUG_IO, 0, L"url_fgetwc returning %d (%C)\n", result, + result ); + return result; +} + +wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { + wint_t result = -1; + + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + ungotten = wc; + break; + case CFTYPE_NONE: + break; + } + } + + return result; +} + + +/** + * Function, sort-of: close the file indicated by my first arg, and return + * nil. If the first arg is not a stream, does nothing. All other args are + * ignored. + * + * * (close stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack frame. + * @param env my environment. + * @return T if the stream was successfully closed, else nil. + */ +struct pso_pointer +lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + if ( readp( fetch_arg( frame, 0) ) || writep( fetch_arg( frame, 0) ) ) { + if ( url_fclose( pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream ) + == 0 ) { + result = t; + } + } + + return result; +} + +struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, + long int value ) { + return + cons( cons + ( c_string_to_lisp_keyword( key ), + make_integer( value ) ), meta ); +} + +struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, + char *value ) { + value = trim( value ); + wchar_t buffer[strlen( value ) + 1]; + mbstowcs( buffer, value, strlen( value ) + 1 ); + + return cons( cons( c_string_to_lisp_keyword( key ), + c_string_to_lisp_string( buffer ) ), meta ); +} + +struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, + time_t *value ) { + /* I don't yet have a concept of a date-time object, which is a + * bit of an oversight! */ + char datestring[256]; + + strftime( datestring, + sizeof( datestring ), + nl_langinfo( D_T_FMT ), localtime( value ) ); + + return add_meta_string( meta, key, datestring ); +} + +/** + * Callback to assemble metadata for a URL stream. This is naughty because + * it modifies data, but it's really the only way to create metadata. + */ +static size_t write_meta_callback( char *string, size_t size, size_t nmemb, + struct pso_pointer stream ) { + struct pso2 *cell = pointer_to_object( stream ); + + // TODO: reimplement + + /* make a copy of the string that we can destructively change */ + // char *s = calloc( strlen( string ), sizeof( char ) ); + + // strcpy( s, string ); + + // if ( check_tag( cell, READTV) || + // check_tag( cell, WRITETV) ) { + // int offset = index_of( ':', s ); + + // if ( offset != -1 ) { + // s[offset] = ( char ) 0; + // char *name = trim( s ); + // char *value = trim( &s[++offset] ); + // wchar_t wname[strlen( name )]; + + // mbstowcs( wname, name, strlen( name ) + 1 ); + + // cell->payload.stream.meta = + // add_meta_string( cell->payload.stream.meta, wname, value ); + + // debug_printf( DEBUG_IO, + // L"write_meta_callback: added header '%s': value '%s'\n", + // name, value ); + // } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { + // int offset = index_of( ' ', s ); + // char *value = trim( &s[offset] ); + + // cell->payload.stream.meta = + // add_meta_integer( add_meta_string + // ( cell->payload.stream.meta, L"status", + // value ), L"status-code", strtol( value, + // NULL, + // 10 ) ); + + // debug_printf( DEBUG_IO, + // L"write_meta_callback: added header 'status': value '%s'\n", + // value ); + // } else { + // debug_printf( DEBUG_IO, + // L"write_meta_callback: header passed with no colon: '%s'\n", + // s ); + // } + // } else { + // debug_print + // ( L"Pointer passed to write_meta_callback did not point to a stream: ", + // DEBUG_IO ); + // debug_dump_object( stream, DEBUG_IO ); + // } + + // free( s ); + return 0; // strlen( string ); +} + +void collect_meta( struct pso_pointer stream, char *url ) { + struct pso2 *cell = pointer_to_object( stream ); + URL_FILE *s = pointer_to_object( stream )->payload.stream.stream; + struct pso_pointer meta = + add_meta_string( cell->payload.stream.meta, L"url", url ); + struct stat statbuf; + int result = stat( url, &statbuf ); + struct passwd *pwd; + struct group *grp; + + switch ( s->type ) { + case CFTYPE_NONE: + break; + case CFTYPE_FILE: + if ( result == 0 ) { + if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { + meta = add_meta_string( meta, L"owner", pwd->pw_name ); + } else { + meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); + } + + if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { + meta = add_meta_string( meta, L"group", grp->gr_name ); + } else { + meta = add_meta_integer( meta, L"group", statbuf.st_gid ); + } + + meta = + add_meta_integer( meta, L"size", + ( intmax_t ) statbuf.st_size ); + + meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); + } + break; + case CFTYPE_CURL: + curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, + write_meta_callback ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream ); + break; + } + + /* this is destructive change before the cell is released into the + * wild, and consequently permissible, just. */ + cell->payload.stream.meta = meta; +} + +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { + struct pso_pointer result = nil; + // struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out; + + // result = c_assoc( stream_name, env ); + + return result; +} + + +/** + * Function: return a stream open on the URL indicated by the first argument; + * if a second argument is present and is non-nil, open it for writing. At + * present, further arguments are ignored and there is no mechanism to open + * to append, or error if the URL is faulty or indicates an unavailable + * resource. + * + * * (open url) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else nil. + */ +struct pso_pointer +lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + // if ( stringp( fetch_arg( frame, 0) ) ) { + // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); + + // if ( nilp( fetch_arg( frame, 1) ) ) { + // URL_FILE *stream = url_fopen( url, "r" ); + + // debug_printf( DEBUG_IO, 0, + // L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", + // ( long int ) &stream, ( int ) stream->type, + // ( long int ) stream->handle.file ); + + // switch ( stream->type ) { + // case CFTYPE_NONE: + // return + // make_exception( c_string_to_lisp_string + // ( L"Could not open stream" ), + // frame_pointer , nil ); + // break; + // case CFTYPE_FILE: + // if ( stream->handle.file == NULL ) { + // return + // make_exception( c_string_to_lisp_string + // ( L"Could not open file" ), + // frame_pointer , nil); + // } + // break; + // case CFTYPE_CURL: + // /* can't tell whether a URL is bad without reading it */ + // break; + // } + + // result = make_read_stream( stream, nil ); + // } else { + // // TODO: anything more complex is a problem for another day. + // URL_FILE *stream = url_fopen( url, "w" ); + // result = make_write_stream( stream, nil ); + // } + + // if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + // result = nil; + // } else { + // collect_meta( result, url ); + // } + + // free( url ); + // } + + return result; +} + +/** + * Function: return the next character from the stream indicated by arg 0; + * further arguments are ignored. + * + * * (read-char stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else nil. + */ +struct pso_pointer +lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + if ( readp( fetch_arg( frame, 0) ) ) { + result = + make_string( url_fgetwc + ( pointer_to_object( fetch_arg( frame, 0) )->payload. + stream.stream ), nil ); + } + + return result; +} + +/** + * Function: return a string representing all characters from the stream + * indicated by arg 0; further arguments are ignored. + * + * TODO: it should be possible to optionally pass a string URL to this function, + * + * * (slurp stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else nil. + */ +struct pso_pointer +lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + if ( readp( fetch_arg( frame, 0) ) ) { + URL_FILE *stream = pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream; + struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil ); + result = cursor; + + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; + c = url_fgetwc( stream ) ) { + debug_print( L"slurp: cursor is: ", DEBUG_IO, 0); + debug_dump_object( cursor, DEBUG_IO, 0 ); + debug_print( L"; result is: ", DEBUG_IO, 0 ); + debug_dump_object( result, DEBUG_IO, 0 ); + debug_println( DEBUG_IO ); + + struct pso2 *cell = pointer_to_object( cursor ); + cursor = make_string( ( wchar_t ) c, nil ); + cell->payload.string.cdr = cursor; + } + } + + return result; +} diff --git a/src/c/io/io.h b/src/c/io/io.h new file mode 100644 index 0000000..49a79da --- /dev/null +++ b/src/c/io/io.h @@ -0,0 +1,49 @@ + +/* + * io.h + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_h +#define __psse_io_h +#include + +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/pso4.h" + +extern CURLSH *io_share; + +int io_init( ); + +#define C_IO_IN L"*in*" +#define C_IO_OUT L"*out*" + +extern struct pso_pointer lisp_io_in; +extern struct pso_pointer lisp_io_out; + +URL_FILE *file_to_url_file( FILE * f ); +wint_t url_fgetwc( URL_FILE * input ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); + +struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ); + +struct pso_pointer +lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ); +struct pso_pointer +lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ); +struct pso_pointer +lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ); +struct pso_pointer +lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ); + +char *lisp_string_to_c_string( struct pso_pointer s ); +#endif diff --git a/src/c/io/print.c b/src/c/io/print.c index 227c958..1b1bb0b 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -20,9 +20,13 @@ */ #include #include +/* libcurl, used for io */ +#include #include "io/fopen.h" +#include "io/io.h" +#include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" @@ -32,16 +36,16 @@ #include "payloads/cons.h" #include "payloads/integer.h" -struct pso_pointer in_print( pso_pointer p, URL_FILE * stream); +struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output); -struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) { +struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output) { struct pso_pointer result = nil; if (consp(p)) { for (; consp( p); p = cdr(p)) { - stuct pso2* object = pointer_to_object(cursor); + struct pso2* object = pointer_to_object(p); - result = in_print( object->payload.cons.car, stream); + result = in_print( object->payload.cons.car, output); if (exceptionp(result)) break; @@ -49,18 +53,14 @@ struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) { case NILTV : break; case CONSTV : - url_fputwc( L'\ ', output ); + url_fputwc( L' ', output ); break; default : url_fputws( L" . ", output); - result = in_print( object->payload.cons.cdr, stream); + result = in_print( object->payload.cons.cdr, output); } } - - struct pso_pointer cdr = object->payload.cons.cdr; - - switchb( get) } else { // TODO: return exception } @@ -68,25 +68,25 @@ struct pso_pointer print_list_content( pso_pointer p, URL_FILE * stream) { return result; } -struct pso_pointer in_print( pso_pointer p, URL_FILE * stream) { - stuct pso2* object = pointer_to_object(p); +struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) { + struct pso2* object = pointer_to_object(p); struct pso_pointer result = nil; - if )object != NULL) { + if (object != NULL) { switch (get_tag_value( p)) { case CHARACTERTV : url_fputwc( object->payload.character.character, output); break; case CONSTV : - url_fputwc( L'\(', output ); - result = print_list_content( object, stream); - url_fputwc( L'\)', output ); + url_fputwc( L'(', output ); + result = print_list_content( p, output); + url_fputwc( L')', output ); break; case INTEGERTV : - fwprintf( output, "%d", (int64_t)(object->payload.integer.value)); + url_fwprintf( output, L"%d", (int64_t)(object->payload.integer.value)); break; case TRUETV : - url_fputwc( L'\t', output ); + url_fputwc( L't', output ); break; case NILTV : url_fputws( L"nil", output ); @@ -107,10 +107,10 @@ struct pso_pointer in_print( pso_pointer p, URL_FILE * stream) { * @param stream if a pointer to an open write stream, print to there. * @return struct pso_pointer `nil`, or an exception if some erroe occurred. */ -struct pso_pointer print( pso_pointer p, pso_pointer stream) { +struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream) { URL_FILE *output = writep( stream) ? - pointer_to_object( stream )->payload.stream.stream: - stdout; + pointer_to_object( stream )->payload.stream.stream : + file_to_url_file(stdout); if ( writep( stream)) { inc_ref( stream); } diff --git a/src/c/io/print.h b/src/c/io/print.h index 9aa793f..7542076 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -14,6 +14,6 @@ #ifndef __psse_io_print_h #define __psse_io_print_h -struct pso_pointer print( pso_pointer p, pso_pointer stream); +struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream); #endif \ No newline at end of file diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index e0080cb..0c36b29 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -13,8 +13,6 @@ #include #include "memory/header.h" -#include "memory/tags.h" - #include "payloads/character.h" #include "payloads/cons.h" #include "payloads/free.h" diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c new file mode 100644 index 0000000..7718f3e --- /dev/null +++ b/src/c/memory/tags.c @@ -0,0 +1,53 @@ +/** + * memory/tags.h + * + * It would be nice if I could get the macros for tsg operations to work, + * but at present they don't and they're costing me time. So I'm going to + * redo them as functions. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + +#include "memory/pointer.h" +#include "memory/pso2.h" + +uint32_t get_tag_value (struct pso_pointer p) { + struct pso2* object = pointer_to_object( p); + + return object->header.tag.value & 0xffffff; +} + +/** + * @brief check that the tag of the object indicated by this poiner has this + * value. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + * @param v should be an integer, ideally uint32_t, the expected value of a tag. + * + * @return true if the tag at p matches v, else false. + */ +bool check_tag( struct pso_pointer p, uint32_t v) { + return get_tag_value(p) == v; +} + +/** + * @brief Like check_tag, q.v., but comparing with the string value of the tag + * rather than the integer value. Only the first TAGLENGTH characters of `s` + * are considered. + * + * @param p a pointer to an object; + * @param s a string, in C conventions; + * @return true if the first TAGLENGTH characters of `s` are equal to the tag + * of the object. + * @return false otherwise. + */ +bool check_type( struct pso_pointer p, char* s) { + return (strncmp( + &(pointer_to_object(p)->header.tag.bytes.mnemonic[0]), s, TAGLENGTH) + == 0); +} \ No newline at end of file diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index f513699..a6f4218 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -12,8 +12,11 @@ #ifndef __psse_memory_tags_h #define __psse_memory_tags_h +#include + #define TAGLENGTH 3 +#define CHARACTERTAG "CHR" #define CONSTAG "CNS" #define EXCEPTIONTAG "EXP" #define FREETAG "FRE" @@ -43,9 +46,8 @@ #define VECTORPOINTTAG "VSP" #define WRITETAG "WRT" -// TODO: all these tag values are WRONG, recalculate! - -#define CONSTV 5459523 +#define CHARACTERTV 5392451 +#define CONSTV 5459523 #define EXCEPTIONTV 5265477 #define FREETV 4543046 #define FUNCTIONTV 5133638 @@ -71,12 +73,37 @@ #define VECTORPOINTTV 5264214 #define WRITETV 5264214 -#define consp(p) (check_tag(p,CONSTV)) -#define exceptionp(p) (check_tag(p,EXCEPTIONTV)) -#define freep(p) (check_tag(p,FREETV)) -#define functionp(p) (check_tag(p,FUNCTIONTV)) -#define integerp(p) (check_tag(p,INTEGERTV)) -#define keywordp(p) (check_tag(p,KEYTV)) +/** + * @brief return the numerical value of the tag of the object indicated by + * pointer `p`. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + * + * @return the numerical value of the tag, as a uint32_t. + */ +// #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) +uint32_t get_tag_value (struct pso_pointer p); + +/** + * @brief check that the tag of the object indicated by this poiner has this + * value. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + * @param v should be an integer, ideally uint32_t, the expected value of a tag. + * + * @return true if the tag at p matches v, else false. + */ +// #define check_tag(p,v) (get_tag_value(p) == v) +bool check_tag( struct pso_pointer p, uint32_t v); + +bool check_type( struct pso_pointer p, char* s); + +#define consp(p) (check_tag(p, CONSTV)) +#define exceptionp(p) (check_tag(p, EXCEPTIONTV)) +#define freep(p) (check_tag(p, FREETV)) +#define functionp(p) (check_tag(p, FUNCTIONTV)) +#define integerp(p) (check_tag(p, INTEGERTV)) +#define keywordp(p) (check_tag(p, KEYTV)) #define lambdap(p) (check_tag(p,LAMBDATV)) #define loopp(p) (check_tag(p,LOOPTV)) #define namespacep(p)(check_tag(p,NAMESPACETV)) @@ -101,25 +128,4 @@ #define vectorp(p) (check_tag(p,VECTORTV)) #define writep(p) (check_tag(p,WRITETV)) -/** - * @brief return the numerical value of the tag of the object indicated by - * pointer `p`. - * - * @param p must be a struct pso_pointer, indicating the appropriate object. - * - * @return the numerical value of the tag, as a uint32_t. - */ -#define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) - -/** - * @brief check that the tag of the object indicated by this poiner has this - * value. - * - * @param p must be a struct pso_pointer, indicating the appropriate object. - * @param v should be an integer, ideally uint32_t, the expected value of a tag. - * - * @return true if the tag at p matches v, else false. - */ -#define check_tag(p,v) (get_tag_value(p) == v) - -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index 17e4c15..f78f4d6 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -10,6 +10,7 @@ */ #include "memory/pointer.h" +#include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c new file mode 100644 index 0000000..432a7d8 --- /dev/null +++ b/src/c/ops/string_ops.c @@ -0,0 +1,164 @@ +/** + * ops/string_ops.h + * + * Operations on a Lisp string frame. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +/* + * wide characters + */ +#include +#include + +#include "debug.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/truth.h" + +#include "payloads/exception.h" + + +/** + * Return a hash value for this string like thing. + * + * What's important here is that two strings with the same characters in the + * same order should have the same hash value, even if one was created using + * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function + * has that property. I doubt that it's the most efficient hash function to + * have that property. + * + * returns 0 for things which are not string like. + */ +uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { + struct pso2 *cell = pointer_to_object( ptr ); + uint32_t result = 0; + + switch ( get_tag_value(ptr)) { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( nilp( cell->payload.string.cdr ) ) { + result = ( uint32_t ) c; + } else { + result = + ( ( uint32_t ) c * + cell->payload.string.hash ) & 0xffffffff; + } + break; + } + + return result; +} + + /** + * Construct a string from this character (which later will be UTF) and + * this tail. A string is implemented as a flat list of cells each of which + * has one character and a pointer to the next; in the last cell the + * pointer to next is nil. + * + * NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of + * wchar_t in larger pso classes, so this function may be only for strings + * (and thus simpler). + */ +struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, + char* tag ) { + struct pso_pointer pointer = nil; + + if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) { + pointer = allocate( tag, CONS_SIZE_CLASS); + struct pso2 *cell = pointer_to_object( pointer ); + + cell->payload.string.character = c; + cell->payload.string.cdr = tail; + + cell->payload.string.hash = calculate_hash( c, tail); + debug_dump_object( pointer, DEBUG_ALLOC, 0 ); + debug_println( DEBUG_ALLOC ); + } else { + // \todo should throw an exception! + debug_printf( DEBUG_ALLOC, 0, + L"Warning: only %4.4s can be prepended to %4.4s\n", + tag, tag ); + } + + return pointer; +} + +/** + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. + */ +struct pso_pointer make_string( wint_t c, struct pso_pointer tail ) { + return make_string_like_thing( c, tail, STRINGTAG ); +} + +/** + * Construct a keyword from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the keyword which is being built. + */ +struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) { + return make_string_like_thing( c, tail, KEYTAG ); +} + +/** + * Construct a symbol from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. + */ +struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ) { + return make_string_like_thing( c, tail, STRINGTAG ); +} + + +/** + * Return a lisp string representation of this wide character string. + */ +struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { + struct pso_pointer result = nil; + + for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { + if ( iswprint( string[i] ) && string[i] != '"' ) { + result = make_string( string[i], result ); + } + } + + return result; +} + +/** + * Return a lisp keyword representation of this wide character string. In + * keywords, I am accepting only lower case characters and numbers. + */ +struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { + struct pso_pointer result = nil; + + for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { + wchar_t c = towlower( symbol[i] ); + + if ( iswalnum( c ) || c == L'-' ) { + result = make_keyword( c, result ); + } + } + + return result; +} diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h new file mode 100644 index 0000000..b874f2b --- /dev/null +++ b/src/c/ops/string_ops.h @@ -0,0 +1,32 @@ +/** + * ops/string_ops.h + * + * Operations on a Lisp string. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_string_ops_h +#define __psse_ops_string_ops_h + +/* + * wide characters + */ +#include +#include + +struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, + char* tag ); + +struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); + +struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ); + +struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ); + +struct pso_pointer c_string_to_lisp_string( wchar_t *string ); + +struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ); + +#endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 48e6782..b66ce7c 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -13,6 +13,7 @@ #include "memory/pointer.h" +#define CONS_SIZE_CLASS 2 /** * @brief A cons cell. diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index b61f401..a732610 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -8,7 +8,13 @@ */ +#include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" + #include "payloads/exception.h" +struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause) { + // TODO: not yet implemented + return nil; +} \ No newline at end of file diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index c522f96..1b082ae 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -9,7 +9,6 @@ #ifndef __psse_payloads_exception_h #define __psse_payloads_exception_h -#include #include "memory/pointer.h" @@ -25,4 +24,6 @@ struct exception_payload { struct pso_pointer cause; }; +struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause); + #endif diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c new file mode 100644 index 0000000..6b62f47 --- /dev/null +++ b/src/c/payloads/integer.c @@ -0,0 +1,39 @@ +/** + * payloads/integer.c + * + * An integer. Doctrine here is that we are not implementing bignum arithmetic in + * the bootstrap layer; an integer is, for now, just a 64 bit integer. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "debug.h" + +/** + * Allocate an integer cell representing this `value` and return a pso_pointer to it. + * @param value an integer value; + * @param more `nil`, or a pointer to the more significant cell(s) of this number. + * *NOTE* that if `more` is not `nil`, `value` *must not* exceed `MAX_INTEGER`. + */ +struct pso_pointer make_integer( int64_t value ) { + struct pso_pointer result = nil; + debug_print( L"Entering make_integer\n", DEBUG_ALLOC , 0); + + result = allocate( INTEGERTAG, 2); + struct pso2 *cell = pointer_to_object( result ); + cell->payload.integer.value = value; + + debug_print( L"make_integer: returning\n", DEBUG_ALLOC , 0); + debug_dump_object( result, DEBUG_ALLOC, 0 ); + + return result; +} diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index 025882c..0a391aa 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -23,5 +23,6 @@ struct integer_payload { __int128_t value; }; +struct pso_pointer make_integer( int64_t value ); #endif diff --git a/src/c/payloads/psse-string.h b/src/c/payloads/psse-string.h index 90d87da..9af3e78 100644 --- a/src/c/payloads/psse-string.h +++ b/src/c/payloads/psse-string.h @@ -33,4 +33,6 @@ struct string_payload { struct pso_pointer cdr; }; +struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); + #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c new file mode 100644 index 0000000..21753c8 --- /dev/null +++ b/src/c/payloads/psse_string.c @@ -0,0 +1,25 @@ +/** + * payloads/string.c + * + * A string cell. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + +#include + + /* + * wide characters + */ +#include +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/string_ops.h" +#include "ops/truth.h" diff --git a/src/c/utils.c b/src/c/utils.c new file mode 100644 index 0000000..9919dbe --- /dev/null +++ b/src/c/utils.c @@ -0,0 +1,33 @@ +/* + * utils.c + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + + +int index_of( char c, const char *s ) { + int i; + + for ( i = 0; s[i] != c && s[i] != 0; i++ ); + + return s[i] == c ? i : -1; +} + +char *trim( char *s ) { + int i; + + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; + i-- ) { + s[i] = '\0'; + } + for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ ); + + return ( char * ) &s[i]; +} diff --git a/src/c/utils.h b/src/c/utils.h new file mode 100644 index 0000000..456e4d0 --- /dev/null +++ b/src/c/utils.h @@ -0,0 +1,17 @@ +/* + * utils.h + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_utils_h +#define __psse_utils_h + +int index_of( char c, const char *s ); + +char *trim( char *s ); + +#endif diff --git a/src/sed/convert.sed b/src/sed/convert.sed new file mode 100644 index 0000000..d7d681a --- /dev/null +++ b/src/sed/convert.sed @@ -0,0 +1,17 @@ +# sed script to help converting snippets of code from 0.0.X to 0.1.X + +s?allocate_cell( *\([A-Z]*\) *)?allocate( \1, 2)?g +s?c_car(?car(?g +s?c_cdr(?cdr(?g +s?cons_pointer?pso_pointer?g +s?consspaceobject\.h?pso2\.h? +s?cons_space_object?pso2?g +s?debug_print(\([^)]*\))?debug_print(\1, 0)?g +s?frame->arg?frame->payload.stack_frame.arg?g +s?make_cons?cons?g +s?NIL?nil?g +s?nilTAG?NILTAG?g +s?&pointer2cell?pointer_to_object?g +s?stack_frame?pso4?g +s?stack\.h?pso4\.h? +s?tag.value?header.tag.bytes.value \& 0xfffff?g \ No newline at end of file From 1196b3eb1d1e40c335d708f40a4e686e54f92199 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 31 Mar 2026 20:01:01 +0100 Subject: [PATCH 24/29] `read` isn't written yet, but I think all the building blocks I need for it are. Compiles and runs; does nothing yet. --- Makefile | 3 +- archive/c/ops/equal.c | 433 ---- archive/c/ops/equal.h | 36 - archive/c/ops/intern.c | 574 ----- archive/c/ops/intern.h | 81 - archive/c/ops/lispops.c | 1840 ----------------- archive/c/ops/lispops.h | 250 --- archive/c/ops/loop.c | 50 - archive/c/ops/loop.h | 10 - archive/c/ops/meta.c | 45 - archive/c/ops/meta.h | 18 - src/c/memory/page.c | 8 + src/c/memory/page.h | 2 + src/c/memory/pointer.c | 9 +- src/c/memory/pso2.h | 2 +- src/c/ops/eq.c | 42 +- src/c/ops/eq.h | 1 + src/c/payloads/cons.c | 22 +- src/c/payloads/exception.h | 3 +- .../payloads/{psse-string.h => psse_string.h} | 0 src/c/payloads/stack.h | 2 + 21 files changed, 84 insertions(+), 3347 deletions(-) delete mode 100644 archive/c/ops/equal.c delete mode 100644 archive/c/ops/equal.h delete mode 100644 archive/c/ops/intern.c delete mode 100644 archive/c/ops/intern.h delete mode 100644 archive/c/ops/lispops.c delete mode 100644 archive/c/ops/lispops.h delete mode 100644 archive/c/ops/loop.c delete mode 100644 archive/c/ops/loop.h delete mode 100644 archive/c/ops/meta.c delete mode 100644 archive/c/ops/meta.h rename src/c/payloads/{psse-string.h => psse_string.h} (100%) diff --git a/Makefile b/Makefile index 49bf5e1..701b16b 100644 --- a/Makefile +++ b/Makefile @@ -21,13 +21,14 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm -lcurl DEBUGFLAGS := -g3 +GCCFLAGS := -std=gnu23 all: $(TARGET) Debug: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(GCCFLAGS) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c deleted file mode 100644 index 296aea6..0000000 --- a/archive/c/ops/equal.c +++ /dev/null @@ -1,433 +0,0 @@ -/* - * equal.c - * - * Checks for shallow and deep equality - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include - -#include "arith/integer.h" -#include "arith/peano.h" -#include "arith/ratio.h" -#include "debug.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/vectorspace.h" -#include "ops/equal.h" -#include "ops/intern.h" - -/** - * Shallow, and thus cheap, equality: true if these two objects are - * the same object, else false. - */ -bool eq( struct cons_pointer a, struct cons_pointer b ) { - return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); -} - -/** - * True if the objects at these two cons pointers have the same tag, else false. - * @param a a pointer to a cons-space object; - * @param b another pointer to a cons-space object. - * @return true if the objects at these two cons pointers have the same tag, - * else false. - */ -bool same_type( struct cons_pointer a, struct cons_pointer b ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - return cell_a->tag.value == cell_b->tag.value; -} - -/** - * Some strings will be null terminated and some will be NIL terminated... ooops! - * @param string the string to test - * @return true if it's the end of a string. - */ -bool end_of_string( struct cons_pointer string ) { - return nilp( string ) || - pointer2cell( string ).payload.string.character == '\0'; -} - -/** - * @brief compare two long doubles and returns true if they are the same to - * within a tolerance of one part in a billion. - * - * @param a - * @param b - * @return true if `a` and `b` are equal to within one part in a billion. - * @return false otherwise. - */ -bool equal_ld_ld( long double a, long double b ) { - long double fa = fabsl( a ); - long double fb = fabsl( b ); - /* difference of magnitudes */ - long double diff = fabsl( fa - fb ); - /* average magnitude of the two */ - long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff ); - /* amount of difference we will tolerate for equality */ - long double tolerance = av * 0.000000001; - - bool result = ( fabsl( a - b ) < tolerance ); - - debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp integer -- if it isn't an integer, things will break. - * @param b a lisp real -- if it isn't a real, things will break. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal_integer_real: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" = ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - bool result = false; - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - if ( nilp( cell_a->payload.integer.more ) ) { - result = - equal_ld_ld( ( long double ) cell_a->payload.integer.value, - cell_b->payload.real.value ); - } else { - fwprintf( stderr, - L"\nequality is not yet implemented for bignums compared to reals." ); - } - - debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n", - result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp integer -- if it isn't an integer, things will break. - * @param b a lisp number. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal_integer_number: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" = ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - bool result = false; - struct cons_space_object *cell_b = &pointer2cell( b ); - - switch ( cell_b->tag.value ) { - case INTEGERTV: - result = equal_integer_integer( a, b ); - break; - case REALTV: - result = equal_integer_real( a, b ); - break; - case RATIOTV: - result = false; - break; - } - - debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n", - result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a lisp real -- if it isn't an real, things will break. - * @param b a lisp number. - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal_real_number: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" = ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - bool result = false; - struct cons_space_object *cell_b = &pointer2cell( b ); - - switch ( cell_b->tag.value ) { - case INTEGERTV: - result = equal_integer_real( b, a ); - break; - case REALTV:{ - struct cons_space_object *cell_a = &pointer2cell( a ); - result = - equal_ld_ld( cell_a->payload.real.value, - cell_b->payload.real.value ); - } - break; - case RATIOTV: - struct cons_space_object *cell_a = &pointer2cell( a ); - result = - equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value ); - break; - } - - debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result ); - - return result; -} - -/** - * @brief Private function, don't use. It depends on its arguments being - * numbers and doesn't sanity check them. - * - * @param a a number - * @param b a number - * @return true if the two numbers have equal value. - * @return false if they don't. - */ -bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) { - bool result = eq( a, b ); - - debug_print( L"\nequal_number_number: ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L" = ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - - if ( !result ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - switch ( cell_a->tag.value ) { - case INTEGERTV: - result = equal_integer_number( a, b ); - break; - case REALTV: - result = equal_real_number( a, b ); - break; - case RATIOTV: - switch ( cell_b->tag.value ) { - case INTEGERTV: - /* as ratios are simplified by make_ratio, any - * ratio that would simplify to an integer is an - * integer, TODO: no longer always true. */ - result = false; - break; - case REALTV: - result = equal_real_number( b, a ); - break; - case RATIOTV: - result = equal_ratio_ratio( a, b ); - break; - /* can't throw an exception from here, but non-numbers - * shouldn't have been passed in anyway, so no default. */ - } - break; - /* can't throw an exception from here, but non-numbers - * shouldn't have been passed in anyway, so no default. */ - } - } - - debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n", - result ); - - return result; -} - -/** - * @brief equality of two map-like things. - * - * The list returned by `keys` on a map-like thing is not sorted, and is not - * guaranteed always to come out in the same order. So equality is established - * if: - * 1. the length of the keys list is the same; and - * 2. the value of each key in the keys list for map `a` is the same in map `a` - * and in map `b`. - * - * Private function, do not use outside this file, **WILL NOT** work - * unless both arguments are VECPs. - * - * @param a a pointer to a vector space object. - * @param b another pointer to a vector space object. - * @return true if the two objects have the same logical structure. - * @return false otherwise. - */ -bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - struct cons_pointer keys_a = hashmap_keys( a ); - - if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) { - result = true; - - for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) { - struct cons_pointer key = c_car( i ); - if ( !equal - ( hashmap_get( a, key, false ), - hashmap_get( b, key, false ) ) ) { - result = false; - break; - } - } - } - - return result; -} - -/** - * @brief equality of two vector-space things. - * - * Expensive, but we need to be able to check for equality of at least hashmaps - * and namespaces. - * - * Private function, do not use outside this file, not guaranteed to work - * unless both arguments are VECPs pointing to map like things. - * - * @param a a pointer to a vector space object. - * @param b another pointer to a vector space object. - * @return true if the two objects have the same logical structure. - * @return false otherwise. - */ -bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - if ( eq( a, b ) ) { - result = true; // same - /* there shouldn't ever be two separate VECP cells which point to the - * same address in vector space, so I don't believe it's worth checking - * for this. - */ - } else if ( vectorp( a ) && vectorp( b ) ) { - struct vector_space_object *va = pointer_to_vso( a ); - struct vector_space_object *vb = pointer_to_vso( b ); - - /* what we're saying here is that a namespace is not equal to a map, - * even if they have identical logical structure. Is this right? */ - if ( va->header.tag.value == vb->header.tag.value ) { - switch ( va->header.tag.value ) { - case HASHTV: - case NAMESPACETV: - result = equal_map_map( a, b ); - break; - } - } - } - // else can't throw an exception from here but TODO: should log. - - return result; -} - -/** - * Deep, and thus expensive, equality: true if these two objects have - * identical structure, else false. - */ -bool equal( struct cons_pointer a, struct cons_pointer b ) { - debug_print( L"\nequal: ", DEBUG_EQUAL ); - debug_print_object( a, DEBUG_EQUAL ); - debug_print( L" = ", DEBUG_EQUAL ); - debug_print_object( b, DEBUG_EQUAL ); - - bool result = false; - - if ( eq( a, b ) ) { - result = true; - } else if ( !numberp( a ) && same_type( a, b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - switch ( cell_a->tag.value ) { - case CONSTV: - case LAMBDATV: - case NLAMBDATV: - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - result = - equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) - && equal( cell_a->payload.cons.cdr, - cell_b->payload.cons.cdr ); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - /* slightly complex because a string may or may not have a '\0' - * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. - */ - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - if ( cell_a->payload.string.hash == - cell_b->payload.string.hash ) { - wchar_t a_buff[STRING_SHIPYARD_SIZE], - b_buff[STRING_SHIPYARD_SIZE]; - uint32_t tag = cell_a->tag.value; - int i = 0; - - memset( a_buff, 0, sizeof( a_buff ) ); - memset( b_buff, 0, sizeof( b_buff ) ); - - for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) - && !nilp( b ); i++ ) { - a_buff[i] = cell_a->payload.string.character; - a = c_cdr( a ); - cell_a = &pointer2cell( a ); - - b_buff[i] = cell_b->payload.string.character; - b = c_cdr( b ); - cell_b = &pointer2cell( b ); - } - -#ifdef DEBUG - debug_print( L"Comparing '", DEBUG_EQUAL ); - debug_print( a_buff, DEBUG_EQUAL ); - debug_print( L"' to '", DEBUG_EQUAL ); - debug_print( b_buff, DEBUG_EQUAL ); - debug_print( L"'\n", DEBUG_EQUAL ); -#endif - - /* OK, now we have wchar string buffers loaded from the objects. We - * may not have exhausted either string, so the buffers being equal - * isn't sufficient. So we recurse at least once. */ - - result = ( wcsncmp( a_buff, b_buff, i ) == 0 ) - && equal( c_cdr( a ), c_cdr( b ) ); - } - break; - case VECTORPOINTTV: - if ( cell_b->tag.value == VECTORPOINTTV ) { - result = equal_vector_vector( a, b ); - } else { - result = false; - } - break; - default: - result = false; - break; - } - } else if ( numberp( a ) && numberp( b ) ) { - result = equal_number_number( a, b ); - } - - /* - * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq. - * - * I'm not certain what equality means for read and write streams, so - * I'll ignore them, too, for now. - */ - - debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result ); - - return result; -} diff --git a/archive/c/ops/equal.h b/archive/c/ops/equal.h deleted file mode 100644 index 061eb94..0000000 --- a/archive/c/ops/equal.h +++ /dev/null @@ -1,36 +0,0 @@ -/** - * equal.h - * - * Checks for shallow and deep equality - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include - -#include "consspaceobject.h" - -#ifndef __equal_h -#define __equal_h - -/** - * size of buffer for assembling strings. Likely to be useful to - * read, too. - */ -#define STRING_SHIPYARD_SIZE 1024 - -/** - * Shallow, and thus cheap, equality: true if these two objects are - * the same object, else false. - */ -bool eq( struct cons_pointer a, struct cons_pointer b ); - -/** - * Deep, and thus expensive, equality: true if these two objects have - * identical structure, else false. - */ -bool equal( struct cons_pointer a, struct cons_pointer b ); - -#endif diff --git a/archive/c/ops/intern.c b/archive/c/ops/intern.c deleted file mode 100644 index 989686b..0000000 --- a/archive/c/ops/intern.c +++ /dev/null @@ -1,574 +0,0 @@ -/* - * intern.c - * - * For now this implements an oblist and shallow binding; local environments can - * be consed onto the front of the oblist. Later, this won't do; bindings will happen - * in namespaces, which will probably be implemented as hash tables. - * - * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; - * so when a symbol is rebound in the master oblist, what in fact we do is construct - * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' - * environments must do) continues to hold a pointer to the old oblist, and consequently - * doesn't see the change. This is probably good but does mean you cannot use bindings - * on the oblist to signal between threads. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -/* - * wide characters - */ -#include -#include - -#include "authorise.h" -#include "debug.h" -#include "io/io.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/hashmap.h" -#include "ops/equal.h" -#include "ops/intern.h" -#include "ops/lispops.h" -// #include "print.h" - -/** - * @brief The global object list/or, to put it differently, the root namespace. - * What is added to this during system setup is 'global', that is, - * visible to all sessions/threads. What is added during a session/thread is local to - * that session/thread (because shallow binding). There must be some way for a user to - * make the contents of their own environment persistent between threads but I don't - * know what it is yet. At some stage there must be a way to rebind deep values so - * they're visible to all users/threads, but again I don't yet have any idea how - * that will work. - */ -struct cons_pointer oblist = NIL; - -/** - * @brief the symbol `NIL`, which is special! - * - */ -struct cons_pointer privileged_symbol_nil = NIL; - -/** - * Return a hash value for the structure indicated by `ptr` such that if - * `x`,`y` are two separate structures whose print representation is the same - * then `(sxhash x)` and `(sxhash y)` will always be equal. - */ -uint32_t sxhash( struct cons_pointer ptr ) { - // TODO: Not Yet Implemented - /* TODO: should look at the implementation of Common Lisp sxhash? - * My current implementation of `print` only addresses URL_FILE - * streams. It would be better if it also addressed strings but - * currently it doesn't. Creating a print string of the structure - * and taking the hash of that would be one simple (but not necessarily - * cheap) solution. - */ - /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp - * and is EXTREMELY complex, and essentially has a different dispatch for - * every type of object. It's likely we need to do the same. - */ - return 0; -} - -/** - * Get the hash value for the cell indicated by this `ptr`; currently only - * implemented for string like things and integers. - */ -uint32_t get_hash( struct cons_pointer ptr ) { - struct cons_space_object *cell = &pointer2cell( ptr ); - uint32_t result = 0; - - switch ( cell->tag.value ) { - case INTEGERTV: - /* Note that we're only hashing on the least significant word of an - * integer. */ - result = cell->payload.integer.value & 0xffffffff; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.hash; - break; - case TRUETV: - result = 1; // arbitrarily - break; - default: - result = sxhash( ptr ); - break; - } - - return result; -} - -/** - * Free the hashmap indicated by this `pointer`. - */ -void free_hashmap( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - if ( hashmapp( pointer ) ) { - struct vector_space_object *vso = cell->payload.vectorp.address; - - dec_ref( vso->payload.hashmap.hash_fn ); - dec_ref( vso->payload.hashmap.write_acl ); - - for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { - if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { - debug_printf( DEBUG_ALLOC, - L"Decrementing bucket [%d] of hashmap at 0x%lx\n", - i, cell->payload.vectorp.address ); - dec_ref( vso->payload.hashmap.buckets[i] ); - } - } - } else { - debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); - } -} - - -/** - * Make a hashmap with this number of buckets, using this `hash_fn`. If - * `hash_fn` is `NIL`, use the standard hash funtion. - */ -struct cons_pointer make_hashmap( uint32_t n_buckets, - struct cons_pointer hash_fn, - struct cons_pointer write_acl ) { - struct cons_pointer result = make_vso( HASHTV, - ( sizeof( struct cons_pointer ) * - ( n_buckets + 2 ) ) + - ( sizeof( uint32_t ) * 2 ) ); - - struct hashmap_payload *payload = - ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; - - payload->hash_fn = inc_ref( hash_fn ); - payload->write_acl = inc_ref( write_acl ); - - payload->n_buckets = n_buckets; - for ( int i = 0; i < n_buckets; i++ ) { - payload->buckets[i] = NIL; - } - - return result; -} - -/** - * return a flat list of all the keys in the hashmap indicated by `map`. - */ -struct cons_pointer hashmap_keys( struct cons_pointer mapp ) { - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - - for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { - for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; - !nilp( c ); c = c_cdr( c ) ) { - result = make_cons( c_car( c_car( c ) ), result ); - } - } - } - - return result; -} - -/** - * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If - * current user is authorised to write to this hashmap, modifies the hashmap and - * returns it; if not, clones the hashmap, modifies the clone, and returns that. - */ -struct cons_pointer hashmap_put_all( struct cons_pointer mapp, - struct cons_pointer assoc ) { - // TODO: if current user has write access to this hashmap - if ( hashmapp( mapp ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - - if ( consp( assoc ) ) { - for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); - pair = c_car( assoc ) ) { - /* TODO: this is really hammering the memory management system, because - * it will make a new clone for every key/value pair added. Fix. */ - if ( consp( pair ) ) { - mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); - } else if ( hashmapp( pair ) ) { - hashmap_put_all( mapp, pair ); - } else { - hashmap_put( mapp, pair, TRUE ); - } - assoc = c_cdr( assoc ); - } - } else if ( hashmapp( assoc ) ) { - for ( struct cons_pointer keys = hashmap_keys( assoc ); - !nilp( keys ); keys = c_cdr( keys ) ) { - struct cons_pointer key = c_car( keys ); - hashmap_put( mapp, key, hashmap_get( assoc, key, false ) ); - } - } - } - - return mapp; -} - -/** Get a value from a hashmap. - * - * Note that this is here, rather than in memory/hashmap.c, because it is - * closely tied in with search_store, q.v. - */ -struct cons_pointer hashmap_get( struct cons_pointer mapp, - struct cons_pointer key, bool return_key ) { -#ifdef DEBUG - debug_print( L"\nhashmap_get: key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`; store of type `", DEBUG_BIND ); - debug_print_object( c_type( mapp ), DEBUG_BIND ); - debug_printf( DEBUG_BIND, L"`; returning `%s`.\n", - return_key ? "key" : "value" ); -#endif - - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; - - result = - search_store( key, map->payload.hashmap.buckets[bucket_no], - return_key ); - } -#ifdef DEBUG - debug_print( L"\nhashmap_get returning: `", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); -#endif - - return result; -} - -/** - * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; - * else return an exception. - */ -struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { - struct cons_pointer result = NIL; - - if ( truep( authorised( ptr, NIL ) ) ) { - if ( hashmapp( ptr ) ) { - struct vector_space_object const *from = pointer_to_vso( ptr ); - - if ( from != NULL ) { - struct hashmap_payload from_pl = from->payload.hashmap; - result = - make_hashmap( from_pl.n_buckets, from_pl.hash_fn, - from_pl.write_acl ); - struct vector_space_object const *to = - pointer_to_vso( result ); - struct hashmap_payload to_pl = to->payload.hashmap; - - for ( int i = 0; i < to_pl.n_buckets; i++ ) { - to_pl.buckets[i] = from_pl.buckets[i]; - inc_ref( to_pl.buckets[i] ); - } - } - } - } else { - result = - make_exception( c_string_to_lisp_string - ( L"Arg to `clone_hashmap` must " - L"be a readable hashmap.`" ), NIL ); - } - - return result; -} - -/** - * @brief `(search-store key store return-key?)` Search this `store` for this - * a key lexically identical to this `key`. - * - * If found, then, if `return-key?` is non-nil, return the copy found in the - * `store`, else return the value associated with it. - * - * At this stage the following structures are legal stores: - * 1. an association list comprising (key . value) dotted pairs; - * 2. a hashmap; - * 3. a namespace (which for these purposes is identical to a hashmap); - * 4. a hybrid list comprising both (key . value) pairs and hashmaps as first - * level items; - * 5. such a hybrid list, but where the last CDR pointer is to a hashmap - * rather than to a cons sell or to `nil`. - * - * This is over-complex and type 5 should be disallowed, but it will do for - * now. - */ -struct cons_pointer search_store( struct cons_pointer key, - struct cons_pointer store, - bool return_key ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - debug_print( L"\nsearch_store; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`; store of type `", DEBUG_BIND ); - debug_print_object( c_type( store ), DEBUG_BIND ); - debug_printf( DEBUG_BIND, L"`; returning `%s`.\n", - return_key ? "key" : "value" ); -#endif - - switch ( get_tag_value( key ) ) { - case SYMBOLTV: - case KEYTV: - struct cons_space_object *store_cell = &pointer2cell( store ); - - switch ( get_tag_value( store ) ) { - case CONSTV: - for ( struct cons_pointer cursor = store; - nilp( result ) && ( consp( cursor ) - || hashmapp( cursor ) ); - cursor = pointer2cell( cursor ).payload.cons.cdr ) { - switch ( get_tag_value( cursor ) ) { - case CONSTV: - struct cons_pointer entry_ptr = - c_car( cursor ); - - switch ( get_tag_value( entry_ptr ) ) { - case CONSTV: - if ( equal( key, c_car( entry_ptr ) ) ) { - result = - return_key ? c_car( entry_ptr ) - : c_cdr( entry_ptr ); - goto found; - } - break; - case HASHTV: - case NAMESPACETV: - result = - hashmap_get( entry_ptr, key, - return_key ); - break; - default: - result = - throw_exception - ( c_string_to_lisp_symbol - ( L"search-store (entry)" ), - make_cons - ( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( c_car( entry_ptr ) ) ), - NIL ); - - } - break; - case HASHTV: - case NAMESPACETV: - debug_print - ( L"\n\tHashmap as top-level value in list", - DEBUG_BIND ); - result = - hashmap_get( cursor, key, return_key ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (cursor)" ), - make_cons - ( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( cursor ) ), - NIL ); - } - } - break; - case HASHTV: - case NAMESPACETV: - result = hashmap_get( store, key, return_key ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (store)" ), - make_cons( c_string_to_lisp_string - ( L"Unexpected store type: " ), - c_type( store ) ), NIL ); - break; - } - break; - case EXCEPTIONTV: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (exception)" ), - make_cons( c_string_to_lisp_string - ( L"Unexpected key type: " ), - c_type( key ) ), NIL ); - - break; - default: - result = - throw_exception( c_string_to_lisp_symbol - ( L"search-store (key)" ), - make_cons( c_string_to_lisp_string - ( L"Unexpected key type: " ), - c_type( key ) ), NIL ); - } - - found: - - debug_print( L"search-store: returning `", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); - - return result; -} - -struct cons_pointer interned( struct cons_pointer key, - struct cons_pointer store ) { - return search_store( key, store, true ); -} - -/** - * @brief Implementation of `interned?` in C. - * - * @param key the key to search for. - * @param store the store to search in. - * @return struct cons_pointer `t` if the key was found, else `nil`. - */ -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer store ) { - struct cons_pointer result = NIL; - - if ( consp( store ) ) { - for ( struct cons_pointer pair = c_car( store ); - eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) { - if ( consp( pair ) ) { - if ( equal( c_car( pair ), key ) ) { - // yes, this should be `eq`, but if symbols are correctly - // interned this will work efficiently, and if not it will - // still work. - result = TRUE; - } - } else if ( hashmapp( pair ) ) { - result = internedp( key, pair ); - } - - store = c_cdr( store ); - } - } else if ( hashmapp( store ) ) { - struct vector_space_object *map = pointer_to_vso( store ); - - for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { - for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; - !nilp( c ); c = c_cdr( c ) ) { - result = internedp( key, c ); - } - } - } - - return result; -} - -/** - * Implementation of assoc in C. Like interned?, the final implementation will - * deal with stores which can be association lists or hashtables or hybrids of - * the two, but that will almost certainly be implemented in lisp. - * - * If this key is lexically identical to a key in this store, return the value - * of that key from the store; otherwise return NIL. - */ -struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ) { - return search_store( key, store, false ); -} - -/** - * Store this `val` as the value of this `key` in this hashmap `mapp`. If - * current user is authorised to write to this hashmap, modifies the hashmap and - * returns it; if not, clones the hashmap, modifies the clone, and returns that. - */ -struct cons_pointer hashmap_put( struct cons_pointer mapp, - struct cons_pointer key, - struct cons_pointer val ) { - if ( hashmapp( mapp ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - - if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) { - mapp = clone_hashmap( mapp ); - map = pointer_to_vso( mapp ); - } - uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; - - // TODO: if there are too many values in the bucket, rehash the whole - // hashmap to a bigger number of buckets, and return that. - - map->payload.hashmap.buckets[bucket_no] = - make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] ); - } - - debug_print( L"hashmap_put:\n", DEBUG_BIND ); - debug_dump_object( mapp, DEBUG_BIND ); - - return mapp; -} - -/** - * If this store is modifiable, add this key value pair to it. Otherwise, - * return a new key/value store containing all the key/value pairs in this - * store with this key/value pair added to the front. - */ -struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - bool deep = eq( store, oblist ); - debug_print_binding( key, value, deep, DEBUG_BIND ); - - if ( deep ) { - debug_printf( DEBUG_BIND, L"\t-> %4.4s\n", - pointer2cell( store ).payload.vectorp.tag.bytes ); - } -#endif - if ( nilp( store ) || consp( store ) ) { - result = make_cons( make_cons( key, value ), store ); - } else if ( hashmapp( store ) ) { - result = hashmap_put( store, key, value ); - } - - return result; -} - -/** - * @brief Binds this `key` to this `value` in the global oblist, and returns the `key`. - */ -struct cons_pointer -deep_bind( struct cons_pointer key, struct cons_pointer value ) { - debug_print( L"Entering deep_bind\n", DEBUG_BIND ); - - oblist = set( key, value, oblist ); - - debug_print( L"deep_bind returning ", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_println( DEBUG_BIND ); - - return key; -} - -/** - * Ensure that a canonical copy of this key is bound in this environment, and - * return that canonical copy. If there is currently no such binding, create one - * with the value TRUE. - */ -struct cons_pointer -intern( struct cons_pointer key, struct cons_pointer environment ) { - struct cons_pointer result = environment; - struct cons_pointer canonical = internedp( key, environment ); - if ( nilp( canonical ) ) { - /* - * not currently bound. TODO: this should bind to NIL? - */ - result = set( key, TRUE, environment ); - } - - return result; -} diff --git a/archive/c/ops/intern.h b/archive/c/ops/intern.h deleted file mode 100644 index 0b8f657..0000000 --- a/archive/c/ops/intern.h +++ /dev/null @@ -1,81 +0,0 @@ -/* - * intern.h - * - * For now this implements an oblist and shallow binding; local environments can - * be consed onto the front of the oblist. Later, this won't do; bindings will happen - * in namespaces, which will probably be implemented as hash tables. - * - * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; - * so when a symbol is rebound in the master oblist, what in fact we do is construct - * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' - * environments must do) continues to hold a pointer to the old oblist, and consequently - * doesn't see the change. This is probably good but does mean you cannot use bindings - * on the oblist to signal between threads. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __intern_h -#define __intern_h - -#include - - -extern struct cons_pointer privileged_symbol_nil; - -extern struct cons_pointer oblist; - -uint32_t get_hash( struct cons_pointer ptr ); - -void free_hashmap( struct cons_pointer ptr ); - -void dump_map( URL_FILE * output, struct cons_pointer pointer ); - -struct cons_pointer hashmap_get( struct cons_pointer mapp, - struct cons_pointer key, bool return_key ); - -struct cons_pointer hashmap_put( struct cons_pointer mapp, - struct cons_pointer key, - struct cons_pointer val ); - -struct cons_pointer hashmap_put_all( struct cons_pointer mapp, - struct cons_pointer assoc ); - -struct cons_pointer hashmap_keys( struct cons_pointer map ); - -struct cons_pointer make_hashmap( uint32_t n_buckets, - struct cons_pointer hash_fn, - struct cons_pointer write_acl ); - -struct cons_pointer search_store( struct cons_pointer key, - struct cons_pointer store, bool return_key ); - -struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ); - -struct cons_pointer interned( struct cons_pointer key, - struct cons_pointer environment ); - -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer environment ); - -struct cons_pointer hashmap_put( struct cons_pointer mapp, - struct cons_pointer key, - struct cons_pointer val ); - -struct cons_pointer set( struct cons_pointer key, - struct cons_pointer value, - struct cons_pointer store ); - -struct cons_pointer deep_bind( struct cons_pointer key, - struct cons_pointer value ); - -struct cons_pointer intern( struct cons_pointer key, - struct cons_pointer environment ); - -struct cons_pointer internedp( struct cons_pointer key, - struct cons_pointer store ); - -#endif diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c deleted file mode 100644 index a9dd7ea..0000000 --- a/archive/c/ops/lispops.c +++ /dev/null @@ -1,1840 +0,0 @@ -/* - * lispops.c - * - * List processing operations. - * - * The general idea here is that a list processing operation is a - * function which takes two arguments, both cons_pointers: - * - * 1. args, the argument list to this function; - * 2. env, the environment in which this function should be evaluated; - * - * and returns a cons_pointer, the result. - * - * They must all have the same signature so that I can call them as - * function pointers. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - -#include "arith/integer.h" -#include "arith/peano.h" -#include "debug.h" -#include "io/io.h" -#include "io/print.h" -#include "io/read.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "memory/dump.h" -#include "ops/equal.h" -#include "ops/intern.h" -#include "ops/lispops.h" - -/** - * @brief the name of the symbol to which the prompt is bound; - * - * Set in init to `*prompt*` - */ -struct cons_pointer prompt_name; - -/* - * also to create in this section: - * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - * struct stack_frame* frame); - * - * and others I haven't thought of yet. - */ - -/** - * Useful building block; evaluate this single form in the context of this - * parent stack frame and this environment. - * @param parent the parent stack frame. - * @param form the form to be evaluated. - * @param env the evaluation environment. - * @return the result of evaluating the form. - */ -struct cons_pointer eval_form( struct stack_frame *parent, - struct cons_pointer parent_pointer, - struct cons_pointer form, - struct cons_pointer env ) { - debug_print( L"eval_form: ", DEBUG_EVAL ); - debug_print_object( form, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - struct cons_pointer result = form; - switch ( pointer2cell( form ).tag.value ) { - /* things which evaluate to themselves */ - case EXCEPTIONTV: - case FREETV: // shouldn't happen, but anyway... - case INTEGERTV: - case KEYTV: - case LOOPTV: // don't think this should happen... - case NILTV: - case RATIOTV: - case REALTV: - case READTV: - case STRINGTV: - case TIMETV: - case TRUETV: - case WRITETV: - break; - default: - { - struct cons_pointer next_pointer = - make_empty_frame( parent_pointer ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = get_stack_frame( next_pointer ); - set_reg( next, 0, form ); - next->args = 1; - - result = lisp_eval( next, next_pointer, env ); - - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - dec_ref( next_pointer ); - } - } - } - break; - } - - debug_print( L"eval_form ", DEBUG_EVAL ); - debug_print_object( form, DEBUG_EVAL ); - debug_print( L" returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * Evaluate all the forms in this `list` in the context of this stack `frame` - * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return NIL. - * @param frame the stack frame. - * @param list the list of forms to be evaluated. - * @param env the evaluation environment. - * @return a list of the the results of evaluating the forms. - */ -struct cons_pointer eval_forms( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer list, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - while ( consp( list ) ) { - result = - make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), - result ); - list = c_cdr( list ); - } - - return c_reverse( result ); -} - -/** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * special form in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, - * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of - * those is returned. - * - * This is experimental. It almost certainly WILL change. - */ -struct cons_pointer lisp_try( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = - c_progn( frame, frame_pointer, frame->arg[0], env ); - - if ( exceptionp( result ) ) { - // TODO: need to put the exception into the environment! - result = c_progn( frame, frame_pointer, frame->arg[1], - make_cons( make_cons - ( c_string_to_lisp_symbol - ( L"*exception*" ), result ), env ) ); - } - - return result; -} - - -/** - * Return the object list (root namespace). - * - * * (oblist) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the root namespace. - */ -struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return oblist; -} - -/** - * Used to construct the body for `lambda` and `nlambda` expressions. - */ -struct cons_pointer compose_body( struct stack_frame *frame ) { - struct cons_pointer body = frame->more; - - for ( int i = args_in_frame - 1; i > 0; i-- ) { - if ( !nilp( body ) ) { - body = make_cons( frame->arg[i], body ); - } else if ( !nilp( frame->arg[i] ) ) { - body = make_cons( frame->arg[i], body ); - } - } - - debug_print( L"compose_body returning ", DEBUG_LAMBDA ); - debug_dump_object( body, DEBUG_LAMBDA ); - - return body; -} - -/** - * Construct an interpretable function. *NOTE* that if `args` is a single symbol - * rather than a list, a varargs function will be created. - * - * (lambda args body) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return an interpretable function with these `args` and this `body`. - */ -struct cons_pointer -lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_lambda( frame->arg[0], compose_body( frame ) ); -} - -/** - * Construct an interpretable special form. *NOTE* that if `args` is a single symbol - * rather than a list, a varargs special form will be created. - * - * (nlambda args body) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return an interpretable special form with these `args` and this `body`. - */ -struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_nlambda( frame->arg[0], compose_body( frame ) ); -} - - -/** - * Evaluate a lambda or nlambda expression. - */ -struct cons_pointer -eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, - struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = NIL; -#ifdef DEBUG - debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); -#endif - - struct cons_pointer new_env = env; - struct cons_pointer names = cell->payload.lambda.args; - struct cons_pointer body = cell->payload.lambda.body; - - if ( consp( names ) ) { - /* if `names` is a list, bind successive items from that list - * to values of arguments */ - for ( int i = 0; i < frame->args && consp( names ); i++ ) { - struct cons_pointer name = c_car( names ); - struct cons_pointer val = frame->arg[i]; - - new_env = set( name, val, new_env ); - debug_print_binding( name, val, false, DEBUG_BIND ); - - names = c_cdr( names ); - } - - /* \todo if there's more than `args_in_frame` arguments, bind those too. */ - } else if ( symbolp( names ) ) { - /* if `names` is a symbol, rather than a list of symbols, - * then bind a list of the values of args to that symbol. */ - /* \todo eval all the things in frame->more */ - struct cons_pointer vals = - eval_forms( frame, frame_pointer, frame->more, env ); - - for ( int i = args_in_frame - 1; i >= 0; i-- ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, frame->arg[i], env ); - - if ( nilp( val ) && nilp( vals ) ) { /* nothing */ - } else { - vals = make_cons( val, vals ); - } - } - - new_env = set( names, vals, new_env ); - } - - while ( !nilp( body ) ) { - struct cons_pointer sexpr = c_car( body ); - body = c_cdr( body ); - - debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); - debug_print_object( sexpr, DEBUG_LAMBDA ); - // debug_print( L"\t env is: ", DEBUG_LAMBDA ); - // debug_print_object( new_env, DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); - - /* if a result is not the terminal result in the lambda, it's a - * side effect, and needs to be GCed */ - dec_ref( result ); - - result = eval_form( frame, frame_pointer, sexpr, new_env ); - - if ( exceptionp( result ) ) { - break; - } - } - - // TODO: I think we do need to dec_ref everything on new_env back to env - // dec_ref( new_env ); - - debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); - debug_print_object( result, DEBUG_LAMBDA ); - debug_println( DEBUG_LAMBDA ); - - return result; -} - -/** - * if `r` is an exception, and it doesn't have a location, fix up its location from - * the name associated with this fn_pointer, if any. - */ -struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, - struct cons_pointer - fn_pointer ) { - struct cons_pointer result = r; - - if ( exceptionp( result ) - && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); - - struct cons_pointer payload = - pointer2cell( result ).payload.exception.payload; - - switch ( get_tag_value( payload ) ) { - case NILTV: - case CONSTV: - case HASHTV: - { - if ( nilp( c_assoc( privileged_keyword_location, - payload ) ) ) { - pointer2cell( result ).payload.exception.payload = - set( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function.meta ), - payload ); - } - } - break; - default: - pointer2cell( result ).payload.exception.payload = - make_cons( make_cons( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function. - meta ) ), - make_cons( make_cons - ( privileged_keyword_payload, - payload ), NIL ) ); - } - } - - return result; -} - - -/** - * Internal guts of apply. - * @param frame the stack frame, expected to have only one argument, a list - * comprising something that evaluates to a function and its arguments. - * @param env The evaluation environment. - * @return the result of evaluating the function with its arguments. - */ -struct cons_pointer -c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering c_apply\n", DEBUG_EVAL ); - struct cons_pointer result = NIL; - - struct cons_pointer fn_pointer = - eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); - - if ( exceptionp( fn_pointer ) ) { - result = fn_pointer; - } else { - struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); - struct cons_pointer args = c_cdr( frame->arg[0] ); - - switch ( get_tag_value( fn_pointer ) ) { - case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; - - case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - - result = maybe_fixup_exception_location( ( * - ( fn_cell->payload.function.executable ) ) - ( next, - next_pointer, - env ), - fn_pointer ); - dec_ref( next_pointer ); - } - } - break; - - case KEYTV: - result = c_assoc( fn_pointer, - eval_form( frame, - frame_pointer, - c_car( c_cdr( frame->arg[0] ) ), - env ) ); - break; - - case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref( next_pointer ); - } - } - } - break; - - case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ - result = c_assoc( eval_form( frame, - frame_pointer, - c_car( c_cdr - ( frame->arg - [0] ) ), env ), - fn_pointer ); - break; - - case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); - } - } - break; - - case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = maybe_fixup_exception_location( ( * - ( fn_cell->payload.special.executable ) ) - ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); - } - } - break; - - default: - { - int bs = sizeof( wchar_t ) * 1024; - wchar_t *buffer = malloc( bs ); - memset( buffer, '\0', bs ); - swprintf( buffer, bs, - L"Unexpected cell with tag %d (%4.4s) in function position", - fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) ); - struct cons_pointer message = - c_string_to_lisp_string( buffer ); - free( buffer ); - result = - throw_exception( c_string_to_lisp_symbol( L"apply" ), - message, frame_pointer ); - } - } - - } - - debug_print( L"c_apply: returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * Function; evaluate the expression which is the first argument in the frame; - * further arguments are ignored. - * - * * (eval expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return - * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. - * * If `expression` is a symbol, returns the value that expression is bound - * to in the evaluation environment (`env`). - * * If `expression` is a list, expects the car to be something that evaluates to a - * function or special form: - * * If a function, evaluates all the other top level elements in `expression` and - * passes them in a stack frame as arguments to the function; - * * If a special form, passes the cdr of expression to the special form as argument. - * @exception if `expression` is a symbol which is not bound in `env`. - */ -struct cons_pointer -lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Eval: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - - struct cons_pointer result = frame->arg[0]; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = c_apply( frame, frame_pointer, env ); - break; - - case SYMBOLTV: - { - struct cons_pointer canonical = interned( frame->arg[0], env ); - if ( nilp( canonical ) ) { - struct cons_pointer message = - make_cons( c_string_to_lisp_string - ( L"Attempt to take value of unbound symbol." ), - frame->arg[0] ); - result = - throw_exception( c_string_to_lisp_symbol( L"eval" ), - message, frame_pointer ); - } else { - result = c_assoc( canonical, env ); -// inc_ref( result ); - } - } - break; - /* - * \todo - * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; - * H'mmm... this is working, but it isn't here. Where is it? - */ - default: - result = frame->arg[0]; - break; - } - - debug_print( L"Eval returning ", DEBUG_EVAL ); - debug_dump_object( result, DEBUG_EVAL ); - - return result; -} - - -/** - * Function; apply the function which is the result of evaluating the - * first argument to the list of values which is the result of evaluating - * the second argument - * - * * (apply fn args) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return the result of applying `fn` to `args`. - */ -struct cons_pointer -lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Apply: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - - set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); - set_reg( frame, 1, NIL ); - - struct cons_pointer result = c_apply( frame, frame_pointer, env ); - - debug_print( L"Apply returning ", DEBUG_EVAL ); - debug_dump_object( result, DEBUG_EVAL ); - - return result; -} - - -/** - * Special form; - * returns its argument (strictly first argument - only one is expected but - * this isn't at this stage checked) unevaluated. - * - * * (quote a) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `a`, unevaluated, - */ -struct cons_pointer -lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return frame->arg[0]; -} - - -/** - * Function; - * binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. Retuns `value`. - * `namespace` defaults to the oblist. - * \todo doesn't actually work yet for namespaces which are not the oblist. - * - * * (set name value) - * * (set name value namespace) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `value` - */ -struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer namespace = - nilp( frame->arg[2] ) ? oblist : frame->arg[2]; - - if ( symbolp( frame->arg[0] ) ) { - deep_bind( frame->arg[0], frame->arg[1] ); - result = frame->arg[1]; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set" ), - make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); - } - - return result; -} - - -/** - * Special form; - * binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing, and returns value. `namespace` defaults to - * the value of `oblist`. - * \todo doesn't actually work yet for namespaces which are not the oblist. - * - * * (set! symbol value) - * * (set! symbol value namespace) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `value` - */ -struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer namespace = frame->arg[2]; - - if ( symbolp( frame->arg[0] ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, frame->arg[1], env ); - deep_bind( frame->arg[0], val ); - result = val; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set!" ), - make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); - } - - return result; -} - -/** - * @return true if `arg` represents an end of string, else false. - * \todo candidate for moving to a memory/string.c file - */ -bool end_of_stringp( struct cons_pointer arg ) { - return nilp( arg ) || - ( stringp( arg ) && - pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); -} - -/** - * Function; - * returns a cell constructed from a and b. If a is of type string but its - * cdr is nill, and b is of type string, then returns a new string cell; - * otherwise returns a new cons cell. - * - * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")` - * - * * (cons a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. - */ -struct cons_pointer -lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer car = frame->arg[0]; - struct cons_pointer cdr = frame->arg[1]; - struct cons_pointer result; - - if ( nilp( car ) && nilp( cdr ) ) { - return NIL; - } else if ( stringp( car ) && stringp( cdr ) && - end_of_stringp( c_cdr( car ) ) ) { - result = - make_string( pointer2cell( car ).payload.string.character, cdr ); - } else { - result = make_cons( car, cdr ); - } - - return result; -} - -/** - * Function; - * returns the first item (head) of a sequence. Valid for cons cells, - * strings, read streams and TODO other things which can be considered as sequences. - * - * * (car expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the first item (head) of `expression`. - * @exception if `expression` is not a sequence. - */ -struct cons_pointer -lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.car; - break; - case NILTV: - break; - case READTV: - result = - make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); - break; - case STRINGTV: - result = make_string( cell->payload.string.character, NIL ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"car" ), - c_string_to_lisp_string - ( L"Attempt to take CAR of non sequence" ), - frame_pointer ); - } - - return result; -} - -/** - * Function; - * returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, read streams and TODO other things which can be considered as sequences. - * *NOTE* that if the argument is an input stream, the first character is removed AND - * DISCARDED. - * - * * (cdr expression) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the remainder of `expression` when the head is removed. - * @exception if `expression` is not a sequence. - */ -struct cons_pointer -lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case NILTV: - break; - case READTV: - url_fgetwc( cell->payload.stream.stream ); - result = frame->arg[0]; - break; - case STRINGTV: - result = cell->payload.string.cdr; - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"cdr" ), - c_string_to_lisp_string - ( L"Attempt to take CDR of non sequence" ), - frame_pointer ); - } - - return result; -} - -/** - * Function: return, as an integer, the length of the sequence indicated by - * the first argument, or zero if it is not a sequence. - * - * * (length any) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the length of `any`, if it is a sequence, or zero otherwise. - */ -struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( c_length( frame->arg[0] ), NIL ); -} - -/** - * Function; look up the value of a `key` in a `store`. - * - * * (assoc key store) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the value associated with `key` in `store`, or `nil` if not found. - */ -struct cons_pointer -lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_assoc( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : frame->arg[1] ); -} - -/** - * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. - * - * @param frame - * @param frame_pointer - * @param env - * @return struct cons_pointer - */ -struct cons_pointer -lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = internedp( frame->arg[0], - nilp( frame->arg[1] ) ? oblist : - frame->arg[1] ); - - if ( exceptionp( result ) ) { - struct cons_pointer old = result; - struct cons_space_object *cell = &( pointer2cell( result ) ); - result = - throw_exception( c_string_to_lisp_symbol( L"interned?" ), - cell->payload.exception.payload, frame_pointer ); - dec_ref( old ); - } - - return result; -} - -struct cons_pointer c_keys( struct cons_pointer store ) { - struct cons_pointer result = NIL; - - if ( consp( store ) ) { - for ( struct cons_pointer pair = c_car( store ); !nilp( pair ); - pair = c_car( store ) ) { - if ( consp( pair ) ) { - result = make_cons( c_car( pair ), result ); - } else if ( hashmapp( pair ) ) { - result = c_append( hashmap_keys( pair ), result ); - } - - store = c_cdr( store ); - } - } else if ( hashmapp( store ) ) { - result = hashmap_keys( store ); - } - - return result; -} - - - -struct cons_pointer lisp_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_keys( frame->arg[0] ); -} - -/** - * Function; are these two objects the same object? Shallow, cheap equality. - * - * * (eq a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `t` if `a` and `b` are pointers to the same object, else `nil`; - */ -struct cons_pointer lisp_eq( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = TRUE; - - if ( frame->args > 1 ) { - for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; - } - } - - return result; -} - -/** - * Function; are these two arguments identical? Deep, expensive equality. - * - * * (equal a b) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return `t` if `a` and `b` are recursively identical, else `nil`. - */ -struct cons_pointer -lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = TRUE; - - if ( frame->args > 1 ) { - for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { - result = - equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; - } - } - - return result; -} - -long int c_count( struct cons_pointer p ) { - struct cons_space_object *cell = &pointer2cell( p ); - int result = 0; - - switch ( cell->tag.value ) { - case CONSTV: - case STRINGTV: - /* I think doctrine is that you cannot treat symbols or keywords as - * sequences, although internally, of course, they are. Integers are - * also internally sequences, but also should not be treated as such. - */ - for ( p; !nilp( p ); p = c_cdr( p ) ) { - result++; - } - } - - return result; -} - -/** - * Function: return the number of top level forms in the object which is - * the first (and only) argument, if it is a sequence (which for current - * purposes means a list or a string) - * - * * (count l) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the number of top level forms in a list, or characters in a - * string, else 0. - */ -struct cons_pointer -lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return acquire_integer( c_count( frame->arg[0] ), NIL ); -} - -/** - * Function; read one complete lisp form and return it. If read-stream is specified and - * is a read stream, then read from that stream, else the stream which is the value of - * `*in*` in the environment. - * - * * (read) - * * (read read-stream) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return the expression read. - */ -struct cons_pointer -lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { -#ifdef DEBUG - debug_print( L"entering lisp_read\n", DEBUG_IO ); -#endif - URL_FILE *input; - - struct cons_pointer in_stream = readp( frame->arg[0] ) ? - frame->arg[0] : get_default_stream( true, env ); - - if ( readp( in_stream ) ) { - debug_print( L"lisp_read: setting input stream\n", - DEBUG_IO | DEBUG_REPL ); - debug_dump_object( in_stream, DEBUG_IO ); - input = pointer2cell( in_stream ).payload.stream.stream; - inc_ref( in_stream ); - } else { - /* should not happen, but has done. */ - debug_print( L"WARNING: invalid input stream; defaulting!\n", - DEBUG_IO | DEBUG_REPL ); - input = file_to_url_file( stdin ); - } - - struct cons_pointer result = read( frame, frame_pointer, env, input ); - debug_print( L"lisp_read returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - if ( readp( in_stream ) ) { - dec_ref( in_stream ); - } else { - free( input ); - } - - - return result; -} - - -/** - * reverse a sequence (if it is a sequence); else return it unchanged. - */ -struct cons_pointer c_reverse( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( sequencep( arg ) ) { - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = - make_symbol_or_key( o.payload.string.character, result, - SYMBOLTV ); - break; - } - } - } else { - result = arg; - } - - return result; -} - - -/** - * Function; reverse the order of members in s sequence. - * - * * (reverse sequence) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return a sequence like this `sequence` but with the members in the reverse order. - */ -struct cons_pointer lisp_reverse( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_reverse( frame->arg[0] ); -} - -/** - * Function: dump/inspect one complete lisp expression and return NIL. If - * write-stream is specified and is a write stream, then print to that stream, - * else the stream which is the value of - * `*out*` in the environment. - * - * * (inspect expr) - * * (inspect expr write-stream) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (from which the stream may be extracted). - * @return NIL. - */ -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); - struct cons_pointer result = NIL; - struct cons_pointer out_stream = writep( frame->arg[1] ) - ? frame->arg[1] - : get_default_stream( false, env ); - URL_FILE *output; - - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } - - dump_object( output, frame->arg[0] ); - - debug_print( L"Leaving lisp_inspect", DEBUG_IO ); - - return result; -} - - -/** - * Function: get the Lisp type of the single argument. - * - * * (type expression) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return As a Lisp string, the tag of `expression`. - */ -struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_type( frame->arg[0] ); -} - -/** - * Evaluate each of these expressions in this `env`ironment over this `frame`, - * returning only the value of the last. - */ -struct cons_pointer -c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer expressions, struct cons_pointer env ) { - struct cons_pointer result = NIL; - - while ( consp( expressions ) ) { - struct cons_pointer r = result; - - result = eval_form( frame, frame_pointer, c_car( expressions ), env ); - dec_ref( r ); - - expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); - } - - return result; -} - - -/** - * Special form; evaluate the expressions which are listed in my arguments - * sequentially and return the value of the last. This function is called 'do' - * in some dialects of Lisp. - * - * * (progn expressions...) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which expressions are evaluated. - * @return the value of the last `expression` of the sequence which is my single - * argument. - */ -struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - struct cons_pointer r = result; - - result = eval_form( frame, frame_pointer, frame->arg[i], env ); - - dec_ref( r ); - } - - if ( consp( frame->more ) ) { - result = c_progn( frame, frame_pointer, frame->more, env ); - } - - return result; -} - -/** - * @brief evaluate a single cond clause; if the test part succeeds return a - * pair whose car is TRUE and whose cdr is the value of the action part - */ -struct cons_pointer eval_cond_clause( struct cons_pointer clause, - struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - debug_print( L"\n\tCond clause: ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); -#endif - - if ( consp( clause ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, c_car( clause ), - env ); - - if ( !nilp( val ) ) { - result = - make_cons( TRUE, - c_progn( frame, frame_pointer, c_cdr( clause ), - env ) ); - -#ifdef DEBUG - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_print( L" succeeded; returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - } else { - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); - debug_print_object( clause, DEBUG_EVAL ); - debug_print( L" failed.\n", DEBUG_EVAL ); -#endif - } - } else { - result = throw_exception( c_string_to_lisp_symbol( L"cond" ), - c_string_to_lisp_string - ( L"Arguments to `cond` must be lists" ), - frame_pointer ); - } - - return result; -} - -/** - * Special form: conditional. Each `clause` is expected to be a list; if the first - * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg `clause` - * has a first element which evaluates to non NIL, then NIL is returned. - * - * * (cond clauses...) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which arguments will be evaluated. - * @return the value of the last expression of the first successful `clause`. - */ -struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - bool done = false; - - for ( int i = 0; ( i < frame->args ) && !done; i++ ) { - struct cons_pointer clause_pointer = fetch_arg( frame, i ); - - result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); - - if ( !nilp( result ) && truep( c_car( result ) ) ) { - result = c_cdr( result ); - done = true; - break; - } - } -#ifdef DEBUG - debug_print( L"\tCond returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); -#endif - - return result; -} - -/** - * Throw an exception with a cause. - * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a - * lisp function; but it is nevertheless to be preferred to make_exception. A - * real `throw_exception`, which does, will be needed. - * object pointing to it. Then this should become a normal lisp function - * which expects a normally bound frame and environment, such that - * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct cons_pointer throw_exception_with_cause( struct cons_pointer location, - struct cons_pointer message, - struct cons_pointer cause, - struct cons_pointer - frame_pointer ) { - struct cons_pointer result = NIL; - -#ifdef DEBUG - debug_print( L"\nERROR: `", 511 ); - debug_print_object( message, 511 ); - debug_print( L"` at `", 511 ); - debug_print_object( location, 511 ); - debug_print( L"`\n", 511 ); - if ( !nilp( cause ) ) { - debug_print( L"\tCaused by: ", 511 ); - debug_print_object( cause, 511 ); - debug_print( L"`\n", 511 ); - } -#endif - struct cons_space_object *cell = &pointer2cell( message ); - - if ( cell->tag.value == EXCEPTIONTV ) { - result = message; - } else { - result = - make_exception( make_cons - ( make_cons( privileged_keyword_location, - location ), - make_cons( make_cons - ( privileged_keyword_payload, - message ), - ( nilp( cause ) ? NIL : - make_cons( make_cons - ( privileged_keyword_cause, - cause ), NIL ) ) ) ), - frame_pointer ); - } - - return result; - -} - -/** - * Throw an exception. - * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a - * lisp function; but it is nevertheless to be preferred to make_exception. A - * real `throw_exception`, which does, will be needed. - * object pointing to it. Then this should become a normal lisp function - * which expects a normally bound frame and environment, such that - * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct cons_pointer -throw_exception( struct cons_pointer location, - struct cons_pointer payload, - struct cons_pointer frame_pointer ) { - return throw_exception_with_cause( location, payload, NIL, frame_pointer ); -} - -/** - * Function; create an exception. Exceptions are special in as much as if an - * exception is created in the binding of the arguments of any function, the - * function will return the exception rather than whatever else it would - * normally return. A function which detects a problem it cannot resolve - * *should* return an exception. - * - * * (exception message location) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which arguments will be evaluated. - * @return areturns an exception whose message is this `message`, and whose - * stack frame is the parent stack frame when the function is invoked. - * `message` does not have to be a string but should be something intelligible - * which can be read. - * If `message` is itself an exception, returns that instead. - */ -struct cons_pointer -lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer message = frame->arg[0]; - - return exceptionp( message ) ? message : - throw_exception_with_cause( message, frame->arg[1], frame->arg[2], - frame->previous ); -} - -/** - * Function: the read/eval/print loop. - * - * * (repl) - * * (repl prompt) - * * (repl prompt input_stream output_stream) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which epressions will be evaluated. - * @return the value of the last expression read. - */ -struct cons_pointer lisp_repl( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer expr = NIL; - -#ifdef DEBUG - debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL ); - debug_print_object( env, DEBUG_REPL ); - debug_print( L"`\n", DEBUG_REPL ); -#endif - - struct cons_pointer input = get_default_stream( true, env ); - struct cons_pointer output = get_default_stream( false, env ); - struct cons_pointer old_oblist = oblist; - struct cons_pointer new_env = env; - - if ( truep( frame->arg[0] ) ) { - new_env = set( prompt_name, frame->arg[0], new_env ); - } - if ( readp( frame->arg[1] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env ); - input = frame->arg[1]; - } - if ( writep( frame->arg[2] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); - output = frame->arg[2]; - } - - inc_ref( input ); - inc_ref( output ); - inc_ref( prompt_name ); - - /* output should NEVER BE nil; but during development it has happened. - * To allow debugging under such circumstances, we need an emergency - * default. */ - URL_FILE *os = - !writep( output ) ? file_to_url_file( stdout ) : - pointer2cell( output ).payload.stream.stream; - if ( !writep( output ) ) { - debug_print( L"WARNING: invalid output; defaulting!\n", - DEBUG_IO | DEBUG_REPL ); - } - - /* \todo this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - while ( readp( input ) && writep( output ) - && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { - /* OK, here's a really subtle problem: because lists are immutable, anything - * bound in the oblist subsequent to this function being invoked isn't in the - * environment. So, for example, changes to *prompt* or *log* made in the oblist - * are not visible. So copy changes made in the oblist into the enviroment. - * \todo the whole process of resolving symbol values needs to be revisited - * when we get onto namespaces. */ - /* OK, there's something even more subtle here if the root namespace is a map. - * H'mmmm... - * I think that now the oblist is a hashmap masquerading as a namespace, - * we should no longer have to do this. TODO: test, and if so, delete this - * statement. */ - if ( !eq( oblist, old_oblist ) ) { - struct cons_pointer cursor = oblist; - - while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { - struct cons_pointer old_new_env = new_env; - debug_print - ( L"lisp_repl: copying new oblist binding into REPL environment:\n", - DEBUG_REPL ); - debug_print_object( c_car( cursor ), DEBUG_REPL ); - debug_println( DEBUG_REPL ); - - new_env = make_cons( c_car( cursor ), new_env ); - inc_ref( new_env ); - dec_ref( old_new_env ); - cursor = c_cdr( cursor ); - } - old_oblist = oblist; - } - - println( os ); - - struct cons_pointer prompt = c_assoc( prompt_name, new_env ); - if ( !nilp( prompt ) ) { - print( os, prompt ); - } - - expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, - new_env ); - - if ( exceptionp( expr ) - && url_feof( pointer2cell( input ).payload.stream.stream ) ) { - /* suppress printing end of stream exception */ - dec_ref( expr ); - break; - } - - println( os ); - - print( os, eval_form( frame, frame_pointer, expr, new_env ) ); - - dec_ref( expr ); - } - - if ( nilp( output ) ) { - free( os ); - } - dec_ref( input ); - dec_ref( output ); - dec_ref( prompt_name ); - dec_ref( new_env ); - - debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); - - return expr; -} - -/** - * Function. return the source code of the object which is its first argument, - * if it is an executable and has source code. - * - * * (source object) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment (ignored). - * @return the source of the `object` indicated, if it is a function, a lambda, - * an nlambda, or a spcial form; else `nil`. - */ -struct cons_pointer lisp_source( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); - struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); - switch ( cell->tag.value ) { - case FUNCTIONTV: - result = c_assoc( source_key, cell->payload.function.meta ); - break; - case SPECIALTV: - result = c_assoc( source_key, cell->payload.special.meta ); - break; - case LAMBDATV: - result = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); - break; - case NLAMBDATV: - result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); - break; - } - // \todo suffers from premature GC, and I can't see why! - inc_ref( result ); - - return result; -} - -/** - * A version of append which can conveniently be called from C. - */ -struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { - switch ( pointer2cell( l1 ).tag.value ) { - case CONSTV: - if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { - if ( nilp( c_cdr( l1 ) ) ) { - return make_cons( c_car( l1 ), l2 ); - } else { - return make_cons( c_car( l1 ), - c_append( c_cdr( l1 ), l2 ) ); - } - } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not same type" ), NIL ); - } - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { - if ( nilp( c_cdr( l1 ) ) ) { - return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - l2, - pointer2cell( l1 ).tag.value ); - } else { - return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - c_append( c_cdr( l1 ), l2 ), - pointer2cell( l1 ).tag.value ); - } - } else { - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not same type" ), NIL ); - } - break; - default: - throw_exception( c_string_to_lisp_symbol( L"append" ), - c_string_to_lisp_string - ( L"Can't append: not a sequence" ), NIL ); - break; - } -} - -/** - * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp - */ -struct cons_pointer lisp_append( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); - - for ( int a = frame->args - 2; a >= 0; a-- ) { - result = c_append( fetch_arg( frame, a ), result ); - } - - return result; -} - -struct cons_pointer lisp_mapcar( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - debug_print( L"Mapcar: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - int i = 0; - - for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { - struct cons_pointer expr = - make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); - - debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); - debug_print_object( expr, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); - - if ( exceptionp( r ) ) { - result = r; - inc_ref( expr ); // to protect exception from the later dec_ref - break; - } else { - result = make_cons( r, result ); - } - debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - dec_ref( expr ); - } - - result = consp( result ) ? c_reverse( result ) : result; - - debug_print( L"Mapcar returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -/** - * @brief construct and return a list of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = frame->more; - - for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; - a >= 0; a-- ) { - result = make_cons( fetch_arg( frame, a ), result ); - } - - return result; -} - - - -/** - * Special form: evaluate a series of forms in an environment in which - * these bindings are bound. - * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. - */ -struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer bindings = env; - struct cons_pointer result = NIL; - - for ( struct cons_pointer cursor = frame->arg[0]; - truep( cursor ); cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer symbol = c_car( pair ); - - if ( symbolp( symbol ) ) { - struct cons_pointer val = - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ); - - debug_print_binding( symbol, val, false, DEBUG_BIND ); - - bindings = make_cons( make_cons( symbol, val ), bindings ); - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"let" ), - c_string_to_lisp_string - ( L"Let: cannot bind, not a symbol" ), - frame_pointer ); - break; - } - } - - debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND ); - - /* i.e., no exception yet */ - for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { - result = - eval_form( frame, frame_pointer, fetch_arg( frame, form ), - bindings ); - } - - /* release the local bindings as they go out of scope! **BUT** - * bindings were consed onto the front of env, so caution... */ - // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { - // dec_ref( cursor); - // } - - return result; - -} - -/** - * @brief Boolean `and` of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_and( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - bool accumulator = true; - struct cons_pointer result = frame->more; - - for ( int a = 0; accumulator == true && a < frame->args; a++ ) { - accumulator = truthy( fetch_arg( frame, a ) ); - } -# - return accumulator ? TRUE : NIL; -} - -/** - * @brief Boolean `or` of arbitrarily many arguments. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer a pointer to the result - */ -struct cons_pointer lisp_or( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - bool accumulator = false; - struct cons_pointer result = frame->more; - - for ( int a = 0; accumulator == false && a < frame->args; a++ ) { - accumulator = truthy( fetch_arg( frame, a ) ); - } - - return accumulator ? TRUE : NIL; -} - -/** - * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. - * - * @param frame The stack frame. - * @param frame_pointer A pointer to the stack frame. - * @param env The evaluation environment. - * @return struct cons_pointer `t` if the first argument is `nil`, else `nil`. - */ -struct cons_pointer lisp_not( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return nilp( frame->arg[0] ) ? TRUE : NIL; -} diff --git a/archive/c/ops/lispops.h b/archive/c/ops/lispops.h deleted file mode 100644 index 66f46c8..0000000 --- a/archive/c/ops/lispops.h +++ /dev/null @@ -1,250 +0,0 @@ -/** - * lispops.h - * - * List processing operations. - * - * The general idea here is that a list processing operation is a - * function which takes two arguments, both cons_pointers: - * - * 1. args, the argument list to this function; - * 2. env, the environment in which this function should be evaluated; - * - * and returns a cons_pointer, the result. - * - * They must all have the same signature so that I can call them as - * function pointers. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_lispops_h -#define __psse_lispops_h - -extern struct cons_pointer prompt_name; - -/* - * utilities - */ - -struct cons_pointer c_keys( struct cons_pointer store ); - -struct cons_pointer c_reverse( struct cons_pointer arg ); - -struct cons_pointer c_progn( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer expressions, - struct cons_pointer env ); - -/** - * Useful building block; evaluate this single form in the context of this - * parent stack frame and this environment. - * @param parent the parent stack frame. - * @param form the form to be evaluated. - * @param env the evaluation environment. - * @return the result of evaluating the form. - */ -struct cons_pointer eval_form( struct stack_frame *parent, - struct cons_pointer parent_pointer, - struct cons_pointer form, - struct cons_pointer env ); - -/** - * eval all the forms in this `list` in the context of this stack `frame` - * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return nil. - */ -struct cons_pointer eval_forms( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer list, - struct cons_pointer env ); - -/* - * special forms - */ -struct cons_pointer lisp_eval( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_apply( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_oblist( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_set( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_set_shriek( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -/** - * Construct an interpretable function. - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param lexpr the lambda expression to be interpreted; - * @param env the environment in which it is to be intepreted. - */ -struct cons_pointer lisp_lambda( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -/** - * Construct an interpretable special form. - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param env the environment in which it is to be intepreted. - */ -struct cons_pointer lisp_nlambda( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_quote( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -/* - * functions - */ -struct cons_pointer lisp_assoc( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_cons( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_car( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_cdr( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_internedp( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_eq( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_equal( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_read( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_repl( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_reverse( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer -lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - -/** - * Function: Get the Lisp type of the single argument. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return As a Lisp string, the tag of the object which is the argument. - */ -struct cons_pointer lisp_type( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -/** - * Function; evaluate the forms which are listed in my single argument - * sequentially and return the value of the last. This function is called 'do' - * in some dialects of Lisp. - * - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single - * argument. - */ -struct cons_pointer lisp_progn( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -/** - * Special form: conditional. Each arg is expected to be a list; if the first - * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) - * has a first element which evaluates to non NIL, then NIL is returned. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form of the first successful clause. - */ -struct cons_pointer lisp_cond( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer throw_exception_with_cause( struct cons_pointer location, - struct cons_pointer message, - struct cons_pointer cause, - struct cons_pointer - frame_pointer ); -/** - * Throw an exception. - * `throw_exception` is a misnomer, because it doesn't obey the calling - * signature of a lisp function; but it is nevertheless to be preferred to - * make_exception. A real `throw_exception`, which does, will be needed. - */ -struct cons_pointer throw_exception( struct cons_pointer location, - struct cons_pointer message, - struct cons_pointer frame_pointer ); - -struct cons_pointer lisp_exception( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_source( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ); - -struct cons_pointer lisp_append( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_mapcar( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_try( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - - -struct cons_pointer lisp_and( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_or( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_not( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -#endif diff --git a/archive/c/ops/loop.c b/archive/c/ops/loop.c deleted file mode 100644 index 6ccada6..0000000 --- a/archive/c/ops/loop.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * loop.c - * - * Iteration functions. This has *a lot* of similarity to try/catch -- - * essentially what `recur` does is throw a special purpose exception which is - * caught by `loop`. - * - * Essentially the syntax I want is - * - * (defun expt (n e) - * (loop ((n1 . n) (r . n) (e1 . e)) - * (cond ((= e 0) r) - * (t (recur n1 (* n1 r) (- e 1))))) - * - * It might in future be good to allow the body of the loop to comprise many - * expressions, like a `progn`, but for now if you want that you can just - * shove a `progn` in. Note that, given that what `recur` is essentially - * doing is throwing a special purpose exception, the `recur` expression - * doesn't actually have to be in the same function as the `loop` expression. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "consspaceobject.h" -#include "lispops.h" -#include "loop.h" - -/** - * Special form, not dissimilar to `let`. Essentially, - * - * 1. the first arg (`args`) is an assoc list; - * 2. the second arg (`body`) is an expression. - * - * Each of the vals in the assoc list is evaluated, and bound to its - * respective key in a new environment. The body is then evaled in that - * environment. If the result is an object of type LOOP, it should carry - * a list of values of the same arity as args. Each of the keys in args - * is then rebound in a new environment to the respective value from the - * LOOP object, and body is then re-evaled in that environment. - * - * If the result is not a LOOP object, it is simply returned. - */ -struct cons_pointer -lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer keys = c_keys( frame->arg[0] ); - struct cons_pointer body = frame->arg[1]; - -} diff --git a/archive/c/ops/loop.h b/archive/c/ops/loop.h deleted file mode 100644 index 27714a8..0000000 --- a/archive/c/ops/loop.h +++ /dev/null @@ -1,10 +0,0 @@ -/* - * loop.h - * - * Iteration functions. This has *a lot* of similarity to try/catch -- - * essentially what `recur` does is throw a special purpose exception which is - * caught by `loop`. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/ops/meta.c b/archive/c/ops/meta.c deleted file mode 100644 index f00824f..0000000 --- a/archive/c/ops/meta.c +++ /dev/null @@ -1,45 +0,0 @@ -/* - * meta.c - * - * Get metadata from a cell which has it. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "memory/conspage.h" -#include "debug.h" - -/** - * Function: get metadata describing my first argument. - * - * * (metadata any) - * - * @return a pointer to the metadata of my first argument, or nil if none. - */ -struct cons_pointer lisp_metadata( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL ); - debug_dump_object( frame->arg[0], DEBUG_EVAL ); - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - - switch ( cell.tag.value ) { - case FUNCTIONTV: - result = cell.payload.function.meta; - break; - case SPECIALTV: - result = cell.payload.special.meta; - break; - case READTV: - case WRITETV: - result = cell.payload.stream.meta; - break; - } - - return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ), - c_type( frame->arg[0] ) ), result ); - -// return result; -} diff --git a/archive/c/ops/meta.h b/archive/c/ops/meta.h deleted file mode 100644 index f441a50..0000000 --- a/archive/c/ops/meta.h +++ /dev/null @@ -1,18 +0,0 @@ -/* - * meta.h - * - * Get metadata from a cell which has it. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_meta_h -#define __psse_meta_h - - -struct cons_pointer lisp_metadata( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -#endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 2d3319d..c5c735e 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -152,3 +152,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) { return result; } + +/** + * @brief allow other files to see the current value of npages_allocated, but not + * change it. + */ +uint32_t get_pages_allocated() { + return npages_allocated; +} diff --git a/src/c/memory/page.h b/src/c/memory/page.h index ba64d38..3df37e6 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -74,4 +74,6 @@ union page { struct pso_pointer allocate_page( uint8_t size_class ); +uint32_t get_pages_allocated(); + #endif diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 8227151..8120e78 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -41,8 +41,13 @@ struct pso2 *pointer_to_object( struct pso_pointer pointer ) { struct pso2 *result = NULL; if ( pointer.node == node_index ) { - union page *pg = pages[pointer.page]; - result = ( struct pso2 * ) &pg->words[pointer.offset]; + if (pointer.page < get_pages_allocated() && pointer.offset < (PAGE_BYTES / 8)) { + // TODO: that's not really a safe test of whether this is a valid pointer. + union page *pg = pages[pointer.page]; + result = ( struct pso2 * ) &pg->words[pointer.offset]; + } else { + // TODO: throw bad pointer exception. + } } // TODO: else if we have a copy of the object in cache, return that; // else request a copy of the object from the node which curates it. diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 0c36b29..812d582 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -12,6 +12,7 @@ #include +#include "../payloads/psse_string.h" #include "memory/header.h" #include "payloads/character.h" #include "payloads/cons.h" @@ -22,7 +23,6 @@ #include "payloads/lambda.h" #include "payloads/nlambda.h" #include "payloads/read_stream.h" -#include "payloads/psse-string.h" #include "payloads/symbol.h" #include "payloads/time.h" #include "payloads/vector_pointer.h" diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 8ca0550..ed274f9 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -3,7 +3,7 @@ * * Post Scarcity Software Environment: eq. * - * Test for pointer equality. + * Test for pointer equality; bootstrap level tests for object equality. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -12,6 +12,11 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/integer.h" #include "payloads/stack.h" #include "ops/stack_ops.h" #include "ops/truth.h" @@ -32,6 +37,39 @@ bool eq( struct pso_pointer a, struct pso_pointer b ) { return ( a.node == b.node && a.page == b.page && a.offset == b.offset ); } +bool equal( struct pso_pointer a, struct pso_pointer b) { + bool result = false; + + if ( eq( a, b)) { + result = true; + } else if ( get_tag_value(a) == get_tag_value(b)) { + switch ( get_tag_value(a)) { + case CONSTV : + result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b))); + break; + case INTEGERTV : + result = (pointer_to_object(a)->payload.integer.value == + pointer_to_object(b)->payload.integer.value); + break; + case KEYTV: + case STRINGTV : + case SYMBOLTV : + while (result == false && !nilp(a) && !nilp(b)) { + if (pointer_to_object(a)->payload.string.character == + pointer_to_object(b)->payload.string.character) { + a = cdr(a); + b = cdr(b); + } + } + result = nilp(a) && nilp(b); + break; + } + } + + return result; +} + + /** * Function; do all arguments to this finction point to the same object? * @@ -60,3 +98,5 @@ struct pso_pointer lisp_eq( struct pso4 *frame, return result; } + + diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index ca330f4..4b4300c 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -22,4 +22,5 @@ struct pso_pointer lisp_eq( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ); +bool equal( struct pso_pointer a, struct pso_pointer b); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 2417385..8fde4b4 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -14,7 +14,11 @@ #include "memory/pso.h" #include "memory/pso2.h" #include "memory/tags.h" + #include "payloads/cons.h" +#include "payloads/exception.h" + +#include "ops/string_ops.h" /** * @brief allocate a cons cell with this car and this cdr, and return a pointer @@ -58,19 +62,29 @@ struct pso_pointer car( struct pso_pointer cons ) { } /** - * @brief return the cdr of this cons cell. + * @brief return the cdr of this cons (or other sequence) cell. * * @param cons a pointer to the cell. * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr( struct pso_pointer cons ) { +struct pso_pointer cdr( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); - if ( consp( cons ) ) { - result = object->payload.cons.cdr; + switch (get_tag_value( p)) { + case CONSTV : result = object->payload.cons.cdr; break; + case KEYTV : + case STRINGTV : + case SYMBOLTV : + result = object->payload.string.cdr; break; + default : + result = make_exception( + cons(c_string_to_lisp_string(L"Invalid type for cdr"), p), + nil, nil); + break; } + // TODO: else throw an exception return result; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 1b082ae..bb1777f 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -24,6 +24,7 @@ struct exception_payload { struct pso_pointer cause; }; -struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause); +struct pso_pointer make_exception( struct pso_pointer message, + struct pso_pointer frame_pointer, struct pso_pointer cause); #endif diff --git a/src/c/payloads/psse-string.h b/src/c/payloads/psse_string.h similarity index 100% rename from src/c/payloads/psse-string.h rename to src/c/payloads/psse_string.h diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index b33d7a3..a43b1e8 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -37,4 +37,6 @@ struct stack_frame_payload { uint32_t depth; }; +struct pso_pointer make_frame( struct pso_pointer previous, ...); + #endif From a302663b324c8aa099a1254cdf89b55066048a42 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 31 Mar 2026 20:09:37 +0100 Subject: [PATCH 25/29] Well, I really made a mess with the last commit; this one sorts it out. --- archive/c/ops/equal.c | 433 +++++++++ archive/c/ops/equal.h | 36 + archive/c/ops/intern.c | 574 ++++++++++++ archive/c/ops/intern.h | 81 ++ archive/c/ops/lispops.c | 1840 +++++++++++++++++++++++++++++++++++++++ archive/c/ops/lispops.h | 250 ++++++ archive/c/ops/loop.c | 50 ++ archive/c/ops/loop.h | 10 + archive/c/ops/meta.c | 45 + archive/c/ops/meta.h | 18 + src/c/io/read.c | 72 ++ src/c/ops/assoc.c | 92 ++ src/c/ops/assoc.h | 28 + src/c/ops/reverse.c | 55 ++ src/c/ops/reverse.h | 21 + src/c/payloads/stack.c | 66 ++ 16 files changed, 3671 insertions(+) create mode 100644 archive/c/ops/equal.c create mode 100644 archive/c/ops/equal.h create mode 100644 archive/c/ops/intern.c create mode 100644 archive/c/ops/intern.h create mode 100644 archive/c/ops/lispops.c create mode 100644 archive/c/ops/lispops.h create mode 100644 archive/c/ops/loop.c create mode 100644 archive/c/ops/loop.h create mode 100644 archive/c/ops/meta.c create mode 100644 archive/c/ops/meta.h create mode 100644 src/c/io/read.c create mode 100644 src/c/ops/assoc.c create mode 100644 src/c/ops/assoc.h create mode 100644 src/c/ops/reverse.c create mode 100644 src/c/ops/reverse.h create mode 100644 src/c/payloads/stack.c diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c new file mode 100644 index 0000000..296aea6 --- /dev/null +++ b/archive/c/ops/equal.c @@ -0,0 +1,433 @@ +/* + * equal.c + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + +#include "arith/integer.h" +#include "arith/peano.h" +#include "arith/ratio.h" +#include "debug.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/vectorspace.h" +#include "ops/equal.h" +#include "ops/intern.h" + +/** + * Shallow, and thus cheap, equality: true if these two objects are + * the same object, else false. + */ +bool eq( struct cons_pointer a, struct cons_pointer b ) { + return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); +} + +/** + * True if the objects at these two cons pointers have the same tag, else false. + * @param a a pointer to a cons-space object; + * @param b another pointer to a cons-space object. + * @return true if the objects at these two cons pointers have the same tag, + * else false. + */ +bool same_type( struct cons_pointer a, struct cons_pointer b ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + return cell_a->tag.value == cell_b->tag.value; +} + +/** + * Some strings will be null terminated and some will be NIL terminated... ooops! + * @param string the string to test + * @return true if it's the end of a string. + */ +bool end_of_string( struct cons_pointer string ) { + return nilp( string ) || + pointer2cell( string ).payload.string.character == '\0'; +} + +/** + * @brief compare two long doubles and returns true if they are the same to + * within a tolerance of one part in a billion. + * + * @param a + * @param b + * @return true if `a` and `b` are equal to within one part in a billion. + * @return false otherwise. + */ +bool equal_ld_ld( long double a, long double b ) { + long double fa = fabsl( a ); + long double fb = fabsl( b ); + /* difference of magnitudes */ + long double diff = fabsl( fa - fb ); + /* average magnitude of the two */ + long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff ); + /* amount of difference we will tolerate for equality */ + long double tolerance = av * 0.000000001; + + bool result = ( fabsl( a - b ) < tolerance ); + + debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp integer -- if it isn't an integer, things will break. + * @param b a lisp real -- if it isn't a real, things will break. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal_integer_real: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + bool result = false; + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + if ( nilp( cell_a->payload.integer.more ) ) { + result = + equal_ld_ld( ( long double ) cell_a->payload.integer.value, + cell_b->payload.real.value ); + } else { + fwprintf( stderr, + L"\nequality is not yet implemented for bignums compared to reals." ); + } + + debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n", + result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp integer -- if it isn't an integer, things will break. + * @param b a lisp number. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal_integer_number: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + bool result = false; + struct cons_space_object *cell_b = &pointer2cell( b ); + + switch ( cell_b->tag.value ) { + case INTEGERTV: + result = equal_integer_integer( a, b ); + break; + case REALTV: + result = equal_integer_real( a, b ); + break; + case RATIOTV: + result = false; + break; + } + + debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n", + result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp real -- if it isn't an real, things will break. + * @param b a lisp number. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal_real_number: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + bool result = false; + struct cons_space_object *cell_b = &pointer2cell( b ); + + switch ( cell_b->tag.value ) { + case INTEGERTV: + result = equal_integer_real( b, a ); + break; + case REALTV:{ + struct cons_space_object *cell_a = &pointer2cell( a ); + result = + equal_ld_ld( cell_a->payload.real.value, + cell_b->payload.real.value ); + } + break; + case RATIOTV: + struct cons_space_object *cell_a = &pointer2cell( a ); + result = + equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value ); + break; + } + + debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a number + * @param b a number + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) { + bool result = eq( a, b ); + + debug_print( L"\nequal_number_number: ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L" = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + + if ( !result ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + switch ( cell_a->tag.value ) { + case INTEGERTV: + result = equal_integer_number( a, b ); + break; + case REALTV: + result = equal_real_number( a, b ); + break; + case RATIOTV: + switch ( cell_b->tag.value ) { + case INTEGERTV: + /* as ratios are simplified by make_ratio, any + * ratio that would simplify to an integer is an + * integer, TODO: no longer always true. */ + result = false; + break; + case REALTV: + result = equal_real_number( b, a ); + break; + case RATIOTV: + result = equal_ratio_ratio( a, b ); + break; + /* can't throw an exception from here, but non-numbers + * shouldn't have been passed in anyway, so no default. */ + } + break; + /* can't throw an exception from here, but non-numbers + * shouldn't have been passed in anyway, so no default. */ + } + } + + debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n", + result ); + + return result; +} + +/** + * @brief equality of two map-like things. + * + * The list returned by `keys` on a map-like thing is not sorted, and is not + * guaranteed always to come out in the same order. So equality is established + * if: + * 1. the length of the keys list is the same; and + * 2. the value of each key in the keys list for map `a` is the same in map `a` + * and in map `b`. + * + * Private function, do not use outside this file, **WILL NOT** work + * unless both arguments are VECPs. + * + * @param a a pointer to a vector space object. + * @param b another pointer to a vector space object. + * @return true if the two objects have the same logical structure. + * @return false otherwise. + */ +bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) { + bool result = false; + + struct cons_pointer keys_a = hashmap_keys( a ); + + if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) { + result = true; + + for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) { + struct cons_pointer key = c_car( i ); + if ( !equal + ( hashmap_get( a, key, false ), + hashmap_get( b, key, false ) ) ) { + result = false; + break; + } + } + } + + return result; +} + +/** + * @brief equality of two vector-space things. + * + * Expensive, but we need to be able to check for equality of at least hashmaps + * and namespaces. + * + * Private function, do not use outside this file, not guaranteed to work + * unless both arguments are VECPs pointing to map like things. + * + * @param a a pointer to a vector space object. + * @param b another pointer to a vector space object. + * @return true if the two objects have the same logical structure. + * @return false otherwise. + */ +bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) { + bool result = false; + + if ( eq( a, b ) ) { + result = true; // same + /* there shouldn't ever be two separate VECP cells which point to the + * same address in vector space, so I don't believe it's worth checking + * for this. + */ + } else if ( vectorp( a ) && vectorp( b ) ) { + struct vector_space_object *va = pointer_to_vso( a ); + struct vector_space_object *vb = pointer_to_vso( b ); + + /* what we're saying here is that a namespace is not equal to a map, + * even if they have identical logical structure. Is this right? */ + if ( va->header.tag.value == vb->header.tag.value ) { + switch ( va->header.tag.value ) { + case HASHTV: + case NAMESPACETV: + result = equal_map_map( a, b ); + break; + } + } + } + // else can't throw an exception from here but TODO: should log. + + return result; +} + +/** + * Deep, and thus expensive, equality: true if these two objects have + * identical structure, else false. + */ +bool equal( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal: ", DEBUG_EQUAL ); + debug_print_object( a, DEBUG_EQUAL ); + debug_print( L" = ", DEBUG_EQUAL ); + debug_print_object( b, DEBUG_EQUAL ); + + bool result = false; + + if ( eq( a, b ) ) { + result = true; + } else if ( !numberp( a ) && same_type( a, b ) ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + switch ( cell_a->tag.value ) { + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + result = + equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) + && equal( cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + /* slightly complex because a string may or may not have a '\0' + * cell at the end, but I'll ignore that for now. I think in + * practice only the empty string will. + */ + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + if ( cell_a->payload.string.hash == + cell_b->payload.string.hash ) { + wchar_t a_buff[STRING_SHIPYARD_SIZE], + b_buff[STRING_SHIPYARD_SIZE]; + uint32_t tag = cell_a->tag.value; + int i = 0; + + memset( a_buff, 0, sizeof( a_buff ) ); + memset( b_buff, 0, sizeof( b_buff ) ); + + for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a ) + && !nilp( b ); i++ ) { + a_buff[i] = cell_a->payload.string.character; + a = c_cdr( a ); + cell_a = &pointer2cell( a ); + + b_buff[i] = cell_b->payload.string.character; + b = c_cdr( b ); + cell_b = &pointer2cell( b ); + } + +#ifdef DEBUG + debug_print( L"Comparing '", DEBUG_EQUAL ); + debug_print( a_buff, DEBUG_EQUAL ); + debug_print( L"' to '", DEBUG_EQUAL ); + debug_print( b_buff, DEBUG_EQUAL ); + debug_print( L"'\n", DEBUG_EQUAL ); +#endif + + /* OK, now we have wchar string buffers loaded from the objects. We + * may not have exhausted either string, so the buffers being equal + * isn't sufficient. So we recurse at least once. */ + + result = ( wcsncmp( a_buff, b_buff, i ) == 0 ) + && equal( c_cdr( a ), c_cdr( b ) ); + } + break; + case VECTORPOINTTV: + if ( cell_b->tag.value == VECTORPOINTTV ) { + result = equal_vector_vector( a, b ); + } else { + result = false; + } + break; + default: + result = false; + break; + } + } else if ( numberp( a ) && numberp( b ) ) { + result = equal_number_number( a, b ); + } + + /* + * there's only supposed ever to be one T and one NIL cell, so each + * should be caught by eq. + * + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ + + debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result ); + + return result; +} diff --git a/archive/c/ops/equal.h b/archive/c/ops/equal.h new file mode 100644 index 0000000..061eb94 --- /dev/null +++ b/archive/c/ops/equal.h @@ -0,0 +1,36 @@ +/** + * equal.h + * + * Checks for shallow and deep equality + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#include "consspaceobject.h" + +#ifndef __equal_h +#define __equal_h + +/** + * size of buffer for assembling strings. Likely to be useful to + * read, too. + */ +#define STRING_SHIPYARD_SIZE 1024 + +/** + * Shallow, and thus cheap, equality: true if these two objects are + * the same object, else false. + */ +bool eq( struct cons_pointer a, struct cons_pointer b ); + +/** + * Deep, and thus expensive, equality: true if these two objects have + * identical structure, else false. + */ +bool equal( struct cons_pointer a, struct cons_pointer b ); + +#endif diff --git a/archive/c/ops/intern.c b/archive/c/ops/intern.c new file mode 100644 index 0000000..989686b --- /dev/null +++ b/archive/c/ops/intern.c @@ -0,0 +1,574 @@ +/* + * intern.c + * + * For now this implements an oblist and shallow binding; local environments can + * be consed onto the front of the oblist. Later, this won't do; bindings will happen + * in namespaces, which will probably be implemented as hash tables. + * + * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; + * so when a symbol is rebound in the master oblist, what in fact we do is construct + * a new oblist without the previous binding but with the new binding. Anything which, + * prior to this action, held a pointer to the old oblist (as all current threads' + * environments must do) continues to hold a pointer to the old oblist, and consequently + * doesn't see the change. This is probably good but does mean you cannot use bindings + * on the oblist to signal between threads. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +/* + * wide characters + */ +#include +#include + +#include "authorise.h" +#include "debug.h" +#include "io/io.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/hashmap.h" +#include "ops/equal.h" +#include "ops/intern.h" +#include "ops/lispops.h" +// #include "print.h" + +/** + * @brief The global object list/or, to put it differently, the root namespace. + * What is added to this during system setup is 'global', that is, + * visible to all sessions/threads. What is added during a session/thread is local to + * that session/thread (because shallow binding). There must be some way for a user to + * make the contents of their own environment persistent between threads but I don't + * know what it is yet. At some stage there must be a way to rebind deep values so + * they're visible to all users/threads, but again I don't yet have any idea how + * that will work. + */ +struct cons_pointer oblist = NIL; + +/** + * @brief the symbol `NIL`, which is special! + * + */ +struct cons_pointer privileged_symbol_nil = NIL; + +/** + * Return a hash value for the structure indicated by `ptr` such that if + * `x`,`y` are two separate structures whose print representation is the same + * then `(sxhash x)` and `(sxhash y)` will always be equal. + */ +uint32_t sxhash( struct cons_pointer ptr ) { + // TODO: Not Yet Implemented + /* TODO: should look at the implementation of Common Lisp sxhash? + * My current implementation of `print` only addresses URL_FILE + * streams. It would be better if it also addressed strings but + * currently it doesn't. Creating a print string of the structure + * and taking the hash of that would be one simple (but not necessarily + * cheap) solution. + */ + /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp + * and is EXTREMELY complex, and essentially has a different dispatch for + * every type of object. It's likely we need to do the same. + */ + return 0; +} + +/** + * Get the hash value for the cell indicated by this `ptr`; currently only + * implemented for string like things and integers. + */ +uint32_t get_hash( struct cons_pointer ptr ) { + struct cons_space_object *cell = &pointer2cell( ptr ); + uint32_t result = 0; + + switch ( cell->tag.value ) { + case INTEGERTV: + /* Note that we're only hashing on the least significant word of an + * integer. */ + result = cell->payload.integer.value & 0xffffffff; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.hash; + break; + case TRUETV: + result = 1; // arbitrarily + break; + default: + result = sxhash( ptr ); + break; + } + + return result; +} + +/** + * Free the hashmap indicated by this `pointer`. + */ +void free_hashmap( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); + + if ( hashmapp( pointer ) ) { + struct vector_space_object *vso = cell->payload.vectorp.address; + + dec_ref( vso->payload.hashmap.hash_fn ); + dec_ref( vso->payload.hashmap.write_acl ); + + for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { + if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing bucket [%d] of hashmap at 0x%lx\n", + i, cell->payload.vectorp.address ); + dec_ref( vso->payload.hashmap.buckets[i] ); + } + } + } else { + debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); + } +} + + +/** + * Make a hashmap with this number of buckets, using this `hash_fn`. If + * `hash_fn` is `NIL`, use the standard hash funtion. + */ +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn, + struct cons_pointer write_acl ) { + struct cons_pointer result = make_vso( HASHTV, + ( sizeof( struct cons_pointer ) * + ( n_buckets + 2 ) ) + + ( sizeof( uint32_t ) * 2 ) ); + + struct hashmap_payload *payload = + ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; + + payload->hash_fn = inc_ref( hash_fn ); + payload->write_acl = inc_ref( write_acl ); + + payload->n_buckets = n_buckets; + for ( int i = 0; i < n_buckets; i++ ) { + payload->buckets[i] = NIL; + } + + return result; +} + +/** + * return a flat list of all the keys in the hashmap indicated by `map`. + */ +struct cons_pointer hashmap_keys( struct cons_pointer mapp ) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { + for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c_car( c ) ), result ); + } + } + } + + return result; +} + +/** + * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put_all( struct cons_pointer mapp, + struct cons_pointer assoc ) { + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if ( consp( assoc ) ) { + for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); + pair = c_car( assoc ) ) { + /* TODO: this is really hammering the memory management system, because + * it will make a new clone for every key/value pair added. Fix. */ + if ( consp( pair ) ) { + mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); + } else if ( hashmapp( pair ) ) { + hashmap_put_all( mapp, pair ); + } else { + hashmap_put( mapp, pair, TRUE ); + } + assoc = c_cdr( assoc ); + } + } else if ( hashmapp( assoc ) ) { + for ( struct cons_pointer keys = hashmap_keys( assoc ); + !nilp( keys ); keys = c_cdr( keys ) ) { + struct cons_pointer key = c_car( keys ); + hashmap_put( mapp, key, hashmap_get( assoc, key, false ) ); + } + } + } + + return mapp; +} + +/** Get a value from a hashmap. + * + * Note that this is here, rather than in memory/hashmap.c, because it is + * closely tied in with search_store, q.v. + */ +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key, bool return_key ) { +#ifdef DEBUG + debug_print( L"\nhashmap_get: key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`; store of type `", DEBUG_BIND ); + debug_print_object( c_type( mapp ), DEBUG_BIND ); + debug_printf( DEBUG_BIND, L"`; returning `%s`.\n", + return_key ? "key" : "value" ); +#endif + + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + + result = + search_store( key, map->payload.hashmap.buckets[bucket_no], + return_key ); + } +#ifdef DEBUG + debug_print( L"\nhashmap_get returning: `", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); +#endif + + return result; +} + +/** + * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; + * else return an exception. + */ +struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { + struct cons_pointer result = NIL; + + if ( truep( authorised( ptr, NIL ) ) ) { + if ( hashmapp( ptr ) ) { + struct vector_space_object const *from = pointer_to_vso( ptr ); + + if ( from != NULL ) { + struct hashmap_payload from_pl = from->payload.hashmap; + result = + make_hashmap( from_pl.n_buckets, from_pl.hash_fn, + from_pl.write_acl ); + struct vector_space_object const *to = + pointer_to_vso( result ); + struct hashmap_payload to_pl = to->payload.hashmap; + + for ( int i = 0; i < to_pl.n_buckets; i++ ) { + to_pl.buckets[i] = from_pl.buckets[i]; + inc_ref( to_pl.buckets[i] ); + } + } + } + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Arg to `clone_hashmap` must " + L"be a readable hashmap.`" ), NIL ); + } + + return result; +} + +/** + * @brief `(search-store key store return-key?)` Search this `store` for this + * a key lexically identical to this `key`. + * + * If found, then, if `return-key?` is non-nil, return the copy found in the + * `store`, else return the value associated with it. + * + * At this stage the following structures are legal stores: + * 1. an association list comprising (key . value) dotted pairs; + * 2. a hashmap; + * 3. a namespace (which for these purposes is identical to a hashmap); + * 4. a hybrid list comprising both (key . value) pairs and hashmaps as first + * level items; + * 5. such a hybrid list, but where the last CDR pointer is to a hashmap + * rather than to a cons sell or to `nil`. + * + * This is over-complex and type 5 should be disallowed, but it will do for + * now. + */ +struct cons_pointer search_store( struct cons_pointer key, + struct cons_pointer store, + bool return_key ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\nsearch_store; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`; store of type `", DEBUG_BIND ); + debug_print_object( c_type( store ), DEBUG_BIND ); + debug_printf( DEBUG_BIND, L"`; returning `%s`.\n", + return_key ? "key" : "value" ); +#endif + + switch ( get_tag_value( key ) ) { + case SYMBOLTV: + case KEYTV: + struct cons_space_object *store_cell = &pointer2cell( store ); + + switch ( get_tag_value( store ) ) { + case CONSTV: + for ( struct cons_pointer cursor = store; + nilp( result ) && ( consp( cursor ) + || hashmapp( cursor ) ); + cursor = pointer2cell( cursor ).payload.cons.cdr ) { + switch ( get_tag_value( cursor ) ) { + case CONSTV: + struct cons_pointer entry_ptr = + c_car( cursor ); + + switch ( get_tag_value( entry_ptr ) ) { + case CONSTV: + if ( equal( key, c_car( entry_ptr ) ) ) { + result = + return_key ? c_car( entry_ptr ) + : c_cdr( entry_ptr ); + goto found; + } + break; + case HASHTV: + case NAMESPACETV: + result = + hashmap_get( entry_ptr, key, + return_key ); + break; + default: + result = + throw_exception + ( c_string_to_lisp_symbol + ( L"search-store (entry)" ), + make_cons + ( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( c_car( entry_ptr ) ) ), + NIL ); + + } + break; + case HASHTV: + case NAMESPACETV: + debug_print + ( L"\n\tHashmap as top-level value in list", + DEBUG_BIND ); + result = + hashmap_get( cursor, key, return_key ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (cursor)" ), + make_cons + ( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( cursor ) ), + NIL ); + } + } + break; + case HASHTV: + case NAMESPACETV: + result = hashmap_get( store, key, return_key ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (store)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected store type: " ), + c_type( store ) ), NIL ); + break; + } + break; + case EXCEPTIONTV: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (exception)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected key type: " ), + c_type( key ) ), NIL ); + + break; + default: + result = + throw_exception( c_string_to_lisp_symbol + ( L"search-store (key)" ), + make_cons( c_string_to_lisp_string + ( L"Unexpected key type: " ), + c_type( key ) ), NIL ); + } + + found: + + debug_print( L"search-store: returning `", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); + + return result; +} + +struct cons_pointer interned( struct cons_pointer key, + struct cons_pointer store ) { + return search_store( key, store, true ); +} + +/** + * @brief Implementation of `interned?` in C. + * + * @param key the key to search for. + * @param store the store to search in. + * @return struct cons_pointer `t` if the key was found, else `nil`. + */ +struct cons_pointer internedp( struct cons_pointer key, + struct cons_pointer store ) { + struct cons_pointer result = NIL; + + if ( consp( store ) ) { + for ( struct cons_pointer pair = c_car( store ); + eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) { + if ( consp( pair ) ) { + if ( equal( c_car( pair ), key ) ) { + // yes, this should be `eq`, but if symbols are correctly + // interned this will work efficiently, and if not it will + // still work. + result = TRUE; + } + } else if ( hashmapp( pair ) ) { + result = internedp( key, pair ); + } + + store = c_cdr( store ); + } + } else if ( hashmapp( store ) ) { + struct vector_space_object *map = pointer_to_vso( store ); + + for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { + for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp( c ); c = c_cdr( c ) ) { + result = internedp( key, c ); + } + } + } + + return result; +} + +/** + * Implementation of assoc in C. Like interned?, the final implementation will + * deal with stores which can be association lists or hashtables or hybrids of + * the two, but that will almost certainly be implemented in lisp. + * + * If this key is lexically identical to a key in this store, return the value + * of that key from the store; otherwise return NIL. + */ +struct cons_pointer c_assoc( struct cons_pointer key, + struct cons_pointer store ) { + return search_store( key, store, false ); +} + +/** + * Store this `val` as the value of this `key` in this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ) { + if ( hashmapp( mapp ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) { + mapp = clone_hashmap( mapp ); + map = pointer_to_vso( mapp ); + } + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + + // TODO: if there are too many values in the bucket, rehash the whole + // hashmap to a bigger number of buckets, and return that. + + map->payload.hashmap.buckets[bucket_no] = + make_cons( make_cons( key, val ), + map->payload.hashmap.buckets[bucket_no] ); + } + + debug_print( L"hashmap_put:\n", DEBUG_BIND ); + debug_dump_object( mapp, DEBUG_BIND ); + + return mapp; +} + +/** + * If this store is modifiable, add this key value pair to it. Otherwise, + * return a new key/value store containing all the key/value pairs in this + * store with this key/value pair added to the front. + */ +struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + bool deep = eq( store, oblist ); + debug_print_binding( key, value, deep, DEBUG_BIND ); + + if ( deep ) { + debug_printf( DEBUG_BIND, L"\t-> %4.4s\n", + pointer2cell( store ).payload.vectorp.tag.bytes ); + } +#endif + if ( nilp( store ) || consp( store ) ) { + result = make_cons( make_cons( key, value ), store ); + } else if ( hashmapp( store ) ) { + result = hashmap_put( store, key, value ); + } + + return result; +} + +/** + * @brief Binds this `key` to this `value` in the global oblist, and returns the `key`. + */ +struct cons_pointer +deep_bind( struct cons_pointer key, struct cons_pointer value ) { + debug_print( L"Entering deep_bind\n", DEBUG_BIND ); + + oblist = set( key, value, oblist ); + + debug_print( L"deep_bind returning ", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_println( DEBUG_BIND ); + + return key; +} + +/** + * Ensure that a canonical copy of this key is bound in this environment, and + * return that canonical copy. If there is currently no such binding, create one + * with the value TRUE. + */ +struct cons_pointer +intern( struct cons_pointer key, struct cons_pointer environment ) { + struct cons_pointer result = environment; + struct cons_pointer canonical = internedp( key, environment ); + if ( nilp( canonical ) ) { + /* + * not currently bound. TODO: this should bind to NIL? + */ + result = set( key, TRUE, environment ); + } + + return result; +} diff --git a/archive/c/ops/intern.h b/archive/c/ops/intern.h new file mode 100644 index 0000000..0b8f657 --- /dev/null +++ b/archive/c/ops/intern.h @@ -0,0 +1,81 @@ +/* + * intern.h + * + * For now this implements an oblist and shallow binding; local environments can + * be consed onto the front of the oblist. Later, this won't do; bindings will happen + * in namespaces, which will probably be implemented as hash tables. + * + * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; + * so when a symbol is rebound in the master oblist, what in fact we do is construct + * a new oblist without the previous binding but with the new binding. Anything which, + * prior to this action, held a pointer to the old oblist (as all current threads' + * environments must do) continues to hold a pointer to the old oblist, and consequently + * doesn't see the change. This is probably good but does mean you cannot use bindings + * on the oblist to signal between threads. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __intern_h +#define __intern_h + +#include + + +extern struct cons_pointer privileged_symbol_nil; + +extern struct cons_pointer oblist; + +uint32_t get_hash( struct cons_pointer ptr ); + +void free_hashmap( struct cons_pointer ptr ); + +void dump_map( URL_FILE * output, struct cons_pointer pointer ); + +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key, bool return_key ); + +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ); + +struct cons_pointer hashmap_put_all( struct cons_pointer mapp, + struct cons_pointer assoc ); + +struct cons_pointer hashmap_keys( struct cons_pointer map ); + +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn, + struct cons_pointer write_acl ); + +struct cons_pointer search_store( struct cons_pointer key, + struct cons_pointer store, bool return_key ); + +struct cons_pointer c_assoc( struct cons_pointer key, + struct cons_pointer store ); + +struct cons_pointer interned( struct cons_pointer key, + struct cons_pointer environment ); + +struct cons_pointer internedp( struct cons_pointer key, + struct cons_pointer environment ); + +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ); + +struct cons_pointer set( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); + +struct cons_pointer deep_bind( struct cons_pointer key, + struct cons_pointer value ); + +struct cons_pointer intern( struct cons_pointer key, + struct cons_pointer environment ); + +struct cons_pointer internedp( struct cons_pointer key, + struct cons_pointer store ); + +#endif diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c new file mode 100644 index 0000000..a9dd7ea --- /dev/null +++ b/archive/c/ops/lispops.c @@ -0,0 +1,1840 @@ +/* + * lispops.c + * + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both cons_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a cons_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "arith/integer.h" +#include "arith/peano.h" +#include "debug.h" +#include "io/io.h" +#include "io/print.h" +#include "io/read.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" +#include "memory/dump.h" +#include "ops/equal.h" +#include "ops/intern.h" +#include "ops/lispops.h" + +/** + * @brief the name of the symbol to which the prompt is bound; + * + * Set in init to `*prompt*` + */ +struct cons_pointer prompt_name; + +/* + * also to create in this section: + * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, + * struct stack_frame* frame); + * + * and others I haven't thought of yet. + */ + +/** + * Useful building block; evaluate this single form in the context of this + * parent stack frame and this environment. + * @param parent the parent stack frame. + * @param form the form to be evaluated. + * @param env the evaluation environment. + * @return the result of evaluating the form. + */ +struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, + struct cons_pointer form, + struct cons_pointer env ) { + debug_print( L"eval_form: ", DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + struct cons_pointer result = form; + switch ( pointer2cell( form ).tag.value ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + case WRITETV: + break; + default: + { + struct cons_pointer next_pointer = + make_empty_frame( parent_pointer ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; + + result = lisp_eval( next, next_pointer, env ); + + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + } + break; + } + + debug_print( L"eval_form ", DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_print( L" returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * Evaluate all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return NIL. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. + */ +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer list, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return c_reverse( result ); +} + +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = + c_progn( frame, frame_pointer, frame->arg[0], env ); + + if ( exceptionp( result ) ) { + // TODO: need to put the exception into the environment! + result = c_progn( frame, frame_pointer, frame->arg[1], + make_cons( make_cons + ( c_string_to_lisp_symbol + ( L"*exception*" ), result ), env ) ); + } + + return result; +} + + +/** + * Return the object list (root namespace). + * + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. + */ +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return oblist; +} + +/** + * Used to construct the body for `lambda` and `nlambda` expressions. + */ +struct cons_pointer compose_body( struct stack_frame *frame ) { + struct cons_pointer body = frame->more; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !nilp( body ) ) { + body = make_cons( frame->arg[i], body ); + } else if ( !nilp( frame->arg[i] ) ) { + body = make_cons( frame->arg[i], body ); + } + } + + debug_print( L"compose_body returning ", DEBUG_LAMBDA ); + debug_dump_object( body, DEBUG_LAMBDA ); + + return body; +} + +/** + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. + */ +struct cons_pointer +lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_lambda( frame->arg[0], compose_body( frame ) ); +} + +/** + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. + */ +struct cons_pointer +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_nlambda( frame->arg[0], compose_body( frame ) ); +} + + +/** + * Evaluate a lambda or nlambda expression. + */ +struct cons_pointer +eval_lambda( struct cons_space_object *cell, struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { + struct cons_pointer result = NIL; +#ifdef DEBUG + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); +#endif + + struct cons_pointer new_env = env; + struct cons_pointer names = cell->payload.lambda.args; + struct cons_pointer body = cell->payload.lambda.body; + + if ( consp( names ) ) { + /* if `names` is a list, bind successive items from that list + * to values of arguments */ + for ( int i = 0; i < frame->args && consp( names ); i++ ) { + struct cons_pointer name = c_car( names ); + struct cons_pointer val = frame->arg[i]; + + new_env = set( name, val, new_env ); + debug_print_binding( name, val, false, DEBUG_BIND ); + + names = c_cdr( names ); + } + + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ + } else if ( symbolp( names ) ) { + /* if `names` is a symbol, rather than a list of symbols, + * then bind a list of the values of args to that symbol. */ + /* \todo eval all the things in frame->more */ + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); + + for ( int i = args_in_frame - 1; i >= 0; i-- ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[i], env ); + + if ( nilp( val ) && nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( val, vals ); + } + } + + new_env = set( names, vals, new_env ); + } + + while ( !nilp( body ) ) { + struct cons_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); + debug_print_object( sexpr, DEBUG_LAMBDA ); + // debug_print( L"\t env is: ", DEBUG_LAMBDA ); + // debug_print_object( new_env, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + dec_ref( result ); + + result = eval_form( frame, frame_pointer, sexpr, new_env ); + + if ( exceptionp( result ) ) { + break; + } + } + + // TODO: I think we do need to dec_ref everything on new_env back to env + // dec_ref( new_env ); + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + return result; +} + +/** + * if `r` is an exception, and it doesn't have a location, fix up its location from + * the name associated with this fn_pointer, if any. + */ +struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r, + struct cons_pointer + fn_pointer ) { + struct cons_pointer result = r; + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { + struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); + + struct cons_pointer payload = + pointer2cell( result ).payload.exception.payload; + + switch ( get_tag_value( payload ) ) { + case NILTV: + case CONSTV: + case HASHTV: + { + if ( nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { + pointer2cell( result ).payload.exception.payload = + set( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ), + payload ); + } + } + break; + default: + pointer2cell( result ).payload.exception.payload = + make_cons( make_cons( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function. + meta ) ), + make_cons( make_cons + ( privileged_keyword_payload, + payload ), NIL ) ); + } + } + + return result; +} + + +/** + * Internal guts of apply. + * @param frame the stack frame, expected to have only one argument, a list + * comprising something that evaluates to a function and its arguments. + * @param env The evaluation environment. + * @return the result of evaluating the function with its arguments. + */ +struct cons_pointer +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering c_apply\n", DEBUG_EVAL ); + struct cons_pointer result = NIL; + + struct cons_pointer fn_pointer = + eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); + + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { + struct cons_space_object *fn_cell = &pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( frame->arg[0] ); + + switch ( get_tag_value( fn_pointer ) ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + + case FUNCTIONTV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + + result = maybe_fixup_exception_location( ( * + ( fn_cell->payload.function.executable ) ) + ( next, + next_pointer, + env ), + fn_pointer ); + dec_ref( next_pointer ); + } + } + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr( frame->arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; + + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame->arg + [0] ) ), env ), + fn_pointer ); + break; + + case NLAMBDATV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } + } + break; + + case SPECIALTV: + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = maybe_fixup_exception_location( ( * + ( fn_cell->payload.special.executable ) ) + ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); + } + } + break; + + default: + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) ); + struct cons_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = + throw_exception( c_string_to_lisp_symbol( L"apply" ), + message, frame_pointer ); + } + } + + } + + debug_print( L"c_apply: returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. + * + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. + */ +struct cons_pointer +lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + + struct cons_pointer result = frame->arg[0]; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = c_apply( frame, frame_pointer, env ); + break; + + case SYMBOLTV: + { + struct cons_pointer canonical = interned( frame->arg[0], env ); + if ( nilp( canonical ) ) { + struct cons_pointer message = + make_cons( c_string_to_lisp_string + ( L"Attempt to take value of unbound symbol." ), + frame->arg[0] ); + result = + throw_exception( c_string_to_lisp_symbol( L"eval" ), + message, frame_pointer ); + } else { + result = c_assoc( canonical, env ); +// inc_ref( result ); + } + } + break; + /* + * \todo + * the Clojure practice of having a map serve in the function place of + * an s-expression is a good one and I should adopt it; + * H'mmm... this is working, but it isn't here. Where is it? + */ + default: + result = frame->arg[0]; + break; + } + + debug_print( L"Eval returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); + + return result; +} + + +/** + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating + * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. + */ +struct cons_pointer +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Apply: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); + set_reg( frame, 1, NIL ); + + struct cons_pointer result = c_apply( frame, frame_pointer, env ); + + debug_print( L"Apply returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); + + return result; +} + + +/** + * Special form; + * returns its argument (strictly first argument - only one is expected but + * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, + */ +struct cons_pointer +lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return frame->arg[0]; +} + + +/** + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. + * `namespace` defaults to the oblist. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` + */ +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = + nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + deep_bind( frame->arg[0], frame->arg[1] ); + result = frame->arg[1]; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set" ), + make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); + } + + return result; +} + + +/** + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` + */ +struct cons_pointer +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer namespace = frame->arg[2]; + + if ( symbolp( frame->arg[0] ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[1], env ); + deep_bind( frame->arg[0], val ); + result = val; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set!" ), + make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); + } + + return result; +} + +/** + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); +} + +/** + * Function; + * returns a cell constructed from a and b. If a is of type string but its + * cdr is nill, and b is of type string, then returns a new string cell; + * otherwise returns a new cons cell. + * + * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")` + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. + */ +struct cons_pointer +lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer car = frame->arg[0]; + struct cons_pointer cdr = frame->arg[1]; + struct cons_pointer result; + + if ( nilp( car ) && nilp( cdr ) ) { + return NIL; + } else if ( stringp( car ) && stringp( cdr ) && + end_of_stringp( c_cdr( car ) ) ) { + result = + make_string( pointer2cell( car ).payload.string.character, cdr ); + } else { + result = make_cons( car, cdr ); + } + + return result; +} + +/** + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. + */ +struct cons_pointer +lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.car; + break; + case NILTV: + break; + case READTV: + result = + make_string( url_fgetwc( cell->payload.stream.stream ), NIL ); + break; + case STRINGTV: + result = make_string( cell->payload.string.character, NIL ); + break; + default: + result = + throw_exception( c_string_to_lisp_symbol( L"car" ), + c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); + } + + return result; +} + +/** + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND + * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. + */ +struct cons_pointer +lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.cdr; + break; + case NILTV: + break; + case READTV: + url_fgetwc( cell->payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell->payload.string.cdr; + break; + default: + result = + throw_exception( c_string_to_lisp_symbol( L"cdr" ), + c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); + } + + return result; +} + +/** + * Function: return, as an integer, the length of the sequence indicated by + * the first argument, or zero if it is not a sequence. + * + * * (length any) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the length of `any`, if it is a sequence, or zero otherwise. + */ +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0] ), NIL ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. + */ +struct cons_pointer +lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_assoc( frame->arg[0], + nilp( frame->arg[1] ) ? oblist : frame->arg[1] ); +} + +/** + * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`. + * + * @param frame + * @param frame_pointer + * @param env + * @return struct cons_pointer + */ +struct cons_pointer +lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = internedp( frame->arg[0], + nilp( frame->arg[1] ) ? oblist : + frame->arg[1] ); + + if ( exceptionp( result ) ) { + struct cons_pointer old = result; + struct cons_space_object *cell = &( pointer2cell( result ) ); + result = + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; +} + +struct cons_pointer c_keys( struct cons_pointer store ) { + struct cons_pointer result = NIL; + + if ( consp( store ) ) { + for ( struct cons_pointer pair = c_car( store ); !nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = make_cons( c_car( pair ), result ); + } else if ( hashmapp( pair ) ) { + result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + } else if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } + + return result; +} + + + +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_keys( frame->arg[0] ); +} + +/** + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are pointers to the same object, else `nil`; + */ +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = TRUE; + + if ( frame->args > 1 ) { + for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { + result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; + } + } + + return result; +} + +/** + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. + */ +struct cons_pointer +lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = TRUE; + + if ( frame->args > 1 ) { + for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { + result = + equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; + } + } + + return result; +} + +long int c_count( struct cons_pointer p ) { + struct cons_space_object *cell = &pointer2cell( p ); + int result = 0; + + switch ( cell->tag.value ) { + case CONSTV: + case STRINGTV: + /* I think doctrine is that you cannot treat symbols or keywords as + * sequences, although internally, of course, they are. Integers are + * also internally sequences, but also should not be treated as such. + */ + for ( p; !nilp( p ); p = c_cdr( p ) ) { + result++; + } + } + + return result; +} + +/** + * Function: return the number of top level forms in the object which is + * the first (and only) argument, if it is a sequence (which for current + * purposes means a list or a string) + * + * * (count l) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the number of top level forms in a list, or characters in a + * string, else 0. + */ +struct cons_pointer +lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return acquire_integer( c_count( frame->arg[0] ), NIL ); +} + +/** + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. + */ +struct cons_pointer +lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { +#ifdef DEBUG + debug_print( L"entering lisp_read\n", DEBUG_IO ); +#endif + URL_FILE *input; + + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); + + if ( readp( in_stream ) ) { + debug_print( L"lisp_read: setting input stream\n", + DEBUG_IO | DEBUG_REPL ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); + } else { + /* should not happen, but has done. */ + debug_print( L"WARNING: invalid input stream; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + input = file_to_url_file( stdin ); + } + + struct cons_pointer result = read( frame, frame_pointer, env, input ); + debug_print( L"lisp_read returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } else { + free( input ); + } + + + return result; +} + + +/** + * reverse a sequence (if it is a sequence); else return it unchanged. + */ +struct cons_pointer c_reverse( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + if ( sequencep( arg ) ) { + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTV ); + break; + } + } + } else { + result = arg; + } + + return result; +} + + +/** + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. + */ +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_reverse( frame->arg[0] ); +} + +/** + * Function: dump/inspect one complete lisp expression and return NIL. If + * write-stream is specified and is a write stream, then print to that stream, + * else the stream which is the value of + * `*out*` in the environment. + * + * * (inspect expr) + * * (inspect expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (from which the stream may be extracted). + * @return NIL. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + + return result; +} + + +/** + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. + */ +struct cons_pointer +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_type( frame->arg[0] ); +} + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( expressions ) ) { + struct cons_pointer r = result; + + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); + } + + return result; +} + + +/** + * Special form; evaluate the expressions which are listed in my arguments + * sequentially and return the value of the last. This function is called 'do' + * in some dialects of Lisp. + * + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single + * argument. + */ +struct cons_pointer +lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_pointer r = result; + + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); + } + + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); + } + + return result; +} + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is TRUE and whose cdr is the value of the action part + */ +struct cons_pointer eval_cond_clause( struct cons_pointer clause, + struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); +#endif + + if ( consp( clause ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !nilp( val ) ) { + result = + make_cons( TRUE, + c_progn( frame, frame_pointer, c_cdr( clause ), + env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL ); + debug_print_object( clause, DEBUG_EVAL ); + debug_print( L" failed.\n", DEBUG_EVAL ); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_symbol( L"cond" ), + c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); + } + + return result; +} + +/** + * Special form: conditional. Each `clause` is expected to be a list; if the first + * item in such a list evaluates to non-NIL, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg `clause` + * has a first element which evaluates to non NIL, then NIL is returned. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. + */ +struct cons_pointer +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + bool done = false; + + for ( int i = 0; ( i < frame->args ) && !done; i++ ) { + struct cons_pointer clause_pointer = fetch_arg( frame, i ); + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !nilp( result ) && truep( c_car( result ) ) ) { + result = c_cdr( result ); + done = true; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); +#endif + + return result; +} + +/** + * Throw an exception with a cause. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct cons_pointer throw_exception_with_cause( struct cons_pointer location, + struct cons_pointer message, + struct cons_pointer cause, + struct cons_pointer + frame_pointer ) { + struct cons_pointer result = NIL; + +#ifdef DEBUG + debug_print( L"\nERROR: `", 511 ); + debug_print_object( message, 511 ); + debug_print( L"` at `", 511 ); + debug_print_object( location, 511 ); + debug_print( L"`\n", 511 ); + if ( !nilp( cause ) ) { + debug_print( L"\tCaused by: ", 511 ); + debug_print_object( cause, 511 ); + debug_print( L"`\n", 511 ); + } +#endif + struct cons_space_object *cell = &pointer2cell( message ); + + if ( cell->tag.value == EXCEPTIONTV ) { + result = message; + } else { + result = + make_exception( make_cons + ( make_cons( privileged_keyword_location, + location ), + make_cons( make_cons + ( privileged_keyword_payload, + message ), + ( nilp( cause ) ? NIL : + make_cons( make_cons + ( privileged_keyword_cause, + cause ), NIL ) ) ) ), + frame_pointer ); + } + + return result; + +} + +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. + * object pointing to it. Then this should become a normal lisp function + * which expects a normally bound frame and environment, such that + * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct cons_pointer +throw_exception( struct cons_pointer location, + struct cons_pointer payload, + struct cons_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, NIL, frame_pointer ); +} + +/** + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. + * + * * (exception message location) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose + * stack frame is the parent stack frame when the function is invoked. + * `message` does not have to be a string but should be something intelligible + * which can be read. + * If `message` is itself an exception, returns that instead. + */ +struct cons_pointer +lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer message = frame->arg[0]; + + return exceptionp( message ) ? message : + throw_exception_with_cause( message, frame->arg[1], frame->arg[2], + frame->previous ); +} + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + +#ifdef DEBUG + debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL ); + debug_print_object( env, DEBUG_REPL ); + debug_print( L"`\n", DEBUG_REPL ); +#endif + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + + if ( truep( frame->arg[0] ) ) { + new_env = set( prompt_name, frame->arg[0], new_env ); + } + if ( readp( frame->arg[1] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env ); + input = frame->arg[1]; + } + if ( writep( frame->arg[2] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env ); + output = frame->arg[2]; + } + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + + /* output should NEVER BE nil; but during development it has happened. + * To allow debugging under such circumstances, we need an emergency + * default. */ + URL_FILE *os = + !writep( output ) ? file_to_url_file( stdout ) : + pointer2cell( output ).payload.stream.stream; + if ( !writep( output ) ) { + debug_print( L"WARNING: invalid output; defaulting!\n", + DEBUG_IO | DEBUG_REPL ); + } + + /* \todo this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * \todo the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... + * I think that now the oblist is a hashmap masquerading as a namespace, + * we should no longer have to do this. TODO: test, and if so, delete this + * statement. */ + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; + + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + + if ( exceptionp( expr ) + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + dec_ref( expr ); + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + if ( nilp( output ) ) { + free( os ); + } + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( new_env ); + + debug_printf( DEBUG_REPL, L"Leaving inner repl\n" ); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object *cell = &pointer2cell( frame->arg[0] ); + struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell->tag.value ) { + case FUNCTIONTV: + result = c_assoc( source_key, cell->payload.function.meta ); + break; + case SPECIALTV: + result = c_assoc( source_key, cell->payload.special.meta ); + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + } + // \todo suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} + +/** + * A version of append which can conveniently be called from C. + */ +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { + switch ( pointer2cell( l1 ).tag.value ) { + case CONSTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return make_cons( c_car( l1 ), l2 ); + } else { + return make_cons( c_car( l1 ), + c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + l2, + pointer2cell( l1 ).tag.value ); + } else { + return + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + c_append( c_cdr( l1 ), l2 ), + pointer2cell( l1 ).tag.value ); + } + } else { + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + default: + throw_exception( c_string_to_lisp_symbol( L"append" ), + c_string_to_lisp_string + ( L"Can't append: not a sequence" ), NIL ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); + + for ( int a = frame->args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + debug_print( L"Mapcar: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + int i = 0; + + for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { + struct cons_pointer expr = + make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); + + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = make_cons( r, result ); + } + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + + return result; +} + +/** + * @brief construct and return a list of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = frame->more; + + for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons( fetch_arg( frame, a ), result ); + } + + return result; +} + + + +/** + * Special form: evaluate a series of forms in an environment in which + * these bindings are bound. + * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. + */ +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; + + for ( struct cons_pointer cursor = frame->arg[0]; + truep( cursor ); cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer symbol = c_car( pair ); + + if ( symbolp( symbol ) ) { + struct cons_pointer val = + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND ); + + bindings = make_cons( make_cons( symbol, val ), bindings ); + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"let" ), + c_string_to_lisp_string + ( L"Let: cannot bind, not a symbol" ), + frame_pointer ); + break; + } + } + + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND ); + + /* i.e., no exception yet */ + for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { + result = + eval_form( frame, frame_pointer, fetch_arg( frame, form ), + bindings ); + } + + /* release the local bindings as they go out of scope! **BUT** + * bindings were consed onto the front of env, so caution... */ + // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) { + // dec_ref( cursor); + // } + + return result; + +} + +/** + * @brief Boolean `and` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_and( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + bool accumulator = true; + struct cons_pointer result = frame->more; + + for ( int a = 0; accumulator == true && a < frame->args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } +# + return accumulator ? TRUE : NIL; +} + +/** + * @brief Boolean `or` of arbitrarily many arguments. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer a pointer to the result + */ +struct cons_pointer lisp_or( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + bool accumulator = false; + struct cons_pointer result = frame->more; + + for ( int a = 0; accumulator == false && a < frame->args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } + + return accumulator ? TRUE : NIL; +} + +/** + * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`. + * + * @param frame The stack frame. + * @param frame_pointer A pointer to the stack frame. + * @param env The evaluation environment. + * @return struct cons_pointer `t` if the first argument is `nil`, else `nil`. + */ +struct cons_pointer lisp_not( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return nilp( frame->arg[0] ) ? TRUE : NIL; +} diff --git a/archive/c/ops/lispops.h b/archive/c/ops/lispops.h new file mode 100644 index 0000000..66f46c8 --- /dev/null +++ b/archive/c/ops/lispops.h @@ -0,0 +1,250 @@ +/** + * lispops.h + * + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both cons_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a cons_pointer, the result. + * + * They must all have the same signature so that I can call them as + * function pointers. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_lispops_h +#define __psse_lispops_h + +extern struct cons_pointer prompt_name; + +/* + * utilities + */ + +struct cons_pointer c_keys( struct cons_pointer store ); + +struct cons_pointer c_reverse( struct cons_pointer arg ); + +struct cons_pointer c_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer expressions, + struct cons_pointer env ); + +/** + * Useful building block; evaluate this single form in the context of this + * parent stack frame and this environment. + * @param parent the parent stack frame. + * @param form the form to be evaluated. + * @param env the evaluation environment. + * @return the result of evaluating the form. + */ +struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, + struct cons_pointer form, + struct cons_pointer env ); + +/** + * eval all the forms in this `list` in the context of this stack `frame` + * and this `env`, and return a list of their values. If the arg passed as + * `list` is not in fact a list, return nil. + */ +struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer list, + struct cons_pointer env ); + +/* + * special forms + */ +struct cons_pointer lisp_eval( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_apply( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_oblist( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_set( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_set_shriek( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +/** + * Construct an interpretable function. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param lexpr the lambda expression to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer lisp_lambda( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +/** + * Construct an interpretable special form. + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param env the environment in which it is to be intepreted. + */ +struct cons_pointer lisp_nlambda( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_quote( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +/* + * functions + */ +struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_cons( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_car( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_cdr( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_internedp( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_equal( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_read( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + +/** + * Function: Get the Lisp type of the single argument. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return As a Lisp string, the tag of the object which is the argument. + */ +struct cons_pointer lisp_type( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +/** + * Function; evaluate the forms which are listed in my single argument + * sequentially and return the value of the last. This function is called 'do' + * in some dialects of Lisp. + * + * @param frame My stack frame. + * @param env My environment (ignored). + * @return the value of the last form on the sequence which is my single + * argument. + */ +struct cons_pointer lisp_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +/** + * Special form: conditional. Each arg is expected to be a list; if the first + * item in such a list evaluates to non-NIL, the remaining items in that list + * are evaluated in turn and the value of the last returned. If no arg (clause) + * has a first element which evaluates to non NIL, then NIL is returned. + * @param frame My stack frame. + * @param env My environment (ignored). + * @return the value of the last form of the first successful clause. + */ +struct cons_pointer lisp_cond( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer throw_exception_with_cause( struct cons_pointer location, + struct cons_pointer message, + struct cons_pointer cause, + struct cons_pointer + frame_pointer ); +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling + * signature of a lisp function; but it is nevertheless to be preferred to + * make_exception. A real `throw_exception`, which does, will be needed. + */ +struct cons_pointer throw_exception( struct cons_pointer location, + struct cons_pointer message, + struct cons_pointer frame_pointer ); + +struct cons_pointer lisp_exception( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ); + +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + + +struct cons_pointer lisp_and( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_or( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_not( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +#endif diff --git a/archive/c/ops/loop.c b/archive/c/ops/loop.c new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/archive/c/ops/loop.c @@ -0,0 +1,50 @@ +/* + * loop.c + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * Essentially the syntax I want is + * + * (defun expt (n e) + * (loop ((n1 . n) (r . n) (e1 . e)) + * (cond ((= e 0) r) + * (t (recur n1 (* n1 r) (- e 1))))) + * + * It might in future be good to allow the body of the loop to comprise many + * expressions, like a `progn`, but for now if you want that you can just + * shove a `progn` in. Note that, given that what `recur` is essentially + * doing is throwing a special purpose exception, the `recur` expression + * doesn't actually have to be in the same function as the `loop` expression. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" +#include "lispops.h" +#include "loop.h" + +/** + * Special form, not dissimilar to `let`. Essentially, + * + * 1. the first arg (`args`) is an assoc list; + * 2. the second arg (`body`) is an expression. + * + * Each of the vals in the assoc list is evaluated, and bound to its + * respective key in a new environment. The body is then evaled in that + * environment. If the result is an object of type LOOP, it should carry + * a list of values of the same arity as args. Each of the keys in args + * is then rebound in a new environment to the respective value from the + * LOOP object, and body is then re-evaled in that environment. + * + * If the result is not a LOOP object, it is simply returned. + */ +struct cons_pointer +lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer keys = c_keys( frame->arg[0] ); + struct cons_pointer body = frame->arg[1]; + +} diff --git a/archive/c/ops/loop.h b/archive/c/ops/loop.h new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/archive/c/ops/loop.h @@ -0,0 +1,10 @@ +/* + * loop.h + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/archive/c/ops/meta.c b/archive/c/ops/meta.c new file mode 100644 index 0000000..f00824f --- /dev/null +++ b/archive/c/ops/meta.c @@ -0,0 +1,45 @@ +/* + * meta.c + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/conspage.h" +#include "debug.h" + +/** + * Function: get metadata describing my first argument. + * + * * (metadata any) + * + * @return a pointer to the metadata of my first argument, or nil if none. + */ +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL ); + debug_dump_object( frame->arg[0], DEBUG_EVAL ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.meta; + break; + case SPECIALTV: + result = cell.payload.special.meta; + break; + case READTV: + case WRITETV: + result = cell.payload.stream.meta; + break; + } + + return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ), + c_type( frame->arg[0] ) ), result ); + +// return result; +} diff --git a/archive/c/ops/meta.h b/archive/c/ops/meta.h new file mode 100644 index 0000000..f441a50 --- /dev/null +++ b/archive/c/ops/meta.h @@ -0,0 +1,18 @@ +/* + * meta.h + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_meta_h +#define __psse_meta_h + + +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +#endif diff --git a/src/c/io/read.c b/src/c/io/read.c new file mode 100644 index 0000000..9760023 --- /dev/null +++ b/src/c/io/read.c @@ -0,0 +1,72 @@ +/** + * read.c + * + * Read basic Lisp objects..This is :bootstrap layer print; it needs to be + * able to read characters, symbols, integers, lists and dotted pairs. I + * don't think it needs to be able to read anything else. It must, however, + * take a readtable as argument and expand reader macros. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include + +/* + * wide characters + */ +#include +#include + +#include "debug.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" + +#include "io/io.h" +#include "io/read.h" + +#include "payloads/integer.h" +#include "ops/stack_ops.h" + + +// TODO: what I've copied from 0.0.6 is *wierdly* over-complex for just now. +// I think I'm going to essentially delete all this and start again. We need +// to be able to despatch on readttables, and the initial readtable functions +// don't need to be written in Lisp. +// +// In the long run a readtable ought to be a hashtable, but for now an assoc +// list will do. +// +// A readtable function is a Lisp function so needs the stackframe and the +// environment. Other arguments (including the output stream) should be passed +// in the argument, so I think the first arg in the frame is the character read; +// the next is the input stream; the next is the readtable, if any. + +/* + * for the time being things which may be read are: + * * integers + * * lists + * * atoms + * * dotted pairs + */ + +/** + * An example wrapper function while I work out how I'm going to do this. + */ +struct pso_pointer read_example( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso_pointer character = fetch_arg( frame, 0); + struct pso_pointer stream = fetch_arg( frame, 1); + struct pso_pointer readtable = fetch_arg( frame, 2); + + return character; +} + + +// struct pso_pointer read diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c new file mode 100644 index 0000000..8589966 --- /dev/null +++ b/src/c/ops/assoc.c @@ -0,0 +1,92 @@ +/** + * ops/assoc.c + * + * Post Scarcity Software Environment: assoc. + * + * Search a store for the value associated with a key. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/cons.h" + +#include "ops/eq.h" +#include "ops/truth.h" + +/** + * @brief: fundamental search function; only knows about association lists + * + * @param key a pointer indicating the key to search for; + * @param store a pointer indicating the store to search; + * @param return_key if a binding is found for `key` in `store`, if true + * return the key found in the store, else return the value + * + * @return nil if no binding for `key` is found in `store`; otherwise, if + * `return_key` is true, return the key from the store; else + * return the binding. + */ +struct pso_pointer search( struct pso_pointer key, + struct pso_pointer store, + bool return_key ) { + struct pso_pointer result = nil; + bool found = false; + + if (consp( store)) { + for ( struct pso_pointer cursor = store; + consp( store) && found == false; + cursor = cdr( cursor)) { + struct pso_pointer pair = car( cursor); + + if (consp(pair) && equal(car(pair), key)) { + found = true; + result = return_key ? car(pair) : cdr( pair); + } + } + } + + return result; +} + +/** + * @prief: bootstap layer assoc; only knows about association lists. + * + * @param key a pointer indicating the key to search for; + * @param store a pointer indicating the store to search; + * + * @return a pointer to the value of the key in the store, or nil if not found + */ +struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store) { + return search( key, store, false); +} + +/** + * @prief: bootstap layer interned; only knows about association lists. + * + * @param key a pointer indicating the key to search for; + * @param store a pointer indicating the store to search; + * + * @return a pointer to the copy of the key in the store, or nil if not found. + */ +struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store) { + return search( key, store, true); +} + +/** + * @prief: bootstap layer interned; only knows about association lists. + * + * @param key a pointer indicating the key to search for; + * @param store a pointer indicating the store to search; + * + * @return `true` if a pointer the key was found in the store.. + */ +bool internedp(struct pso_pointer key, struct pso_pointer store) { + return !nilp( search( key, store, true)); +} diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h new file mode 100644 index 0000000..e5572f9 --- /dev/null +++ b/src/c/ops/assoc.h @@ -0,0 +1,28 @@ +/** + * ops/assoc.h + * + * Post Scarcity Software Environment: assoc. + * + * Search a store for the value associated with a key. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_assoc_h +#define __psse_ops_assoc_h + +#include + +#include "memory/pointer.h" + +struct cons_pointer search( struct pso_pointer key, + struct pso_pointer store, + bool return_key ); + +struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store); + +struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store); + +bool internedp(struct pso_pointer key, struct pso_pointer store); +#endif diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c new file mode 100644 index 0000000..1b70342 --- /dev/null +++ b/src/c/ops/reverse.c @@ -0,0 +1,55 @@ +/** + * ops/reverse.c + * + * Post Scarcity Software Environment: reverse. + * + * Reverse a sequence. Didn'e want to do this in the substrate, but I need + * if for reading atoms!. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/psse_string.h" + +#include "ops/string_ops.h" +#include "ops/truth.h" + +struct pso_pointer reverse( struct pso_pointer sequence) { + struct pso_pointer result = nil; + + for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) { + struct pso2* object = pointer_to_object( cursor); + switch (get_tag_value(cursor)) { + case CONSTV : + result = cons( car(cursor), result); + break; + case KEYTV : + result = make_string_like_thing( object->payload.string.character, result, KEYTAG); + break; + case STRINGTV : + result = make_string_like_thing( object->payload.string.character, result, STRINGTAG); + break; + case SYMBOLTV : + result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG); + break; + default : + result = make_exception( c_string_to_lisp_string(L"Invalid object in sequence"), nil, nil); + goto exit; + break; + } + } +exit: + + return result; +} diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h new file mode 100644 index 0000000..18cb36e --- /dev/null +++ b/src/c/ops/reverse.h @@ -0,0 +1,21 @@ +/** + * ops/reverse.h + * + * Post Scarcity Software Environment: reverse. + * + * Reverse a sequence. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_reverse_h +#define __psse_ops_reverse_h + +#include + +#include "memory/pointer.h" + +struct pso_pointer reverse( struct pso_pointer sequence); + +#endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c new file mode 100644 index 0000000..7008b20 --- /dev/null +++ b/src/c/payloads/stack.c @@ -0,0 +1,66 @@ +/** + * payloads/stack.h + * + * a Lisp stack frame. + * + * Sits in a pso4. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +/** + * @brief Construct a stack frame with this `previous` pointer, and arguments + * taken from the remaining arguments to this function, which should all be + * struct pso_pointer. + * + * @return a pso_pointer to the stack frame. + */ +struct pso_pointer make_frame( struct pso_pointer previous, ...) { + va_list args; + va_start(args, previous); + int count = va_arg(args, int); + + struct pso_pointer frame_pointer = allocate( STACKTAG, 4); + struct pso4* frame = (struct pso4*)pointer_to_object( frame_pointer); + + frame->payload.stack_frame.previous = previous; + + // I *think* the count starts with the number of args, so there are + // one fewer actual args. Need to test to verify this! + count --; + int cursor = 0; + frame->payload.stack_frame.args = count; + + for ( ; cursor < count && cursor < args_in_frame; cursor++) { + struct pso_pointer argument = va_arg( args, struct pso_pointer); + + frame->payload.stack_frame.arg[cursor] = argument; + } + if ( cursor < count) { + struct pso_pointer more_args = nil; + + for (; cursor < count; cursor++) { + more_args = cons( va_arg( args, struct pso_pointer), more_args); + } + + // should be frame->payload.stack_frame.more = reverse( more_args), but + // we don't have reverse yet. TODO: fix. + frame->payload.stack_frame.more = more_args; + } else { + for (; cursor < args_in_frame; cursor++) { + frame->payload.stack_frame.arg[cursor] = nil; + } + } + + return frame_pointer; +} From cc8e96eda422d608062c2a6e1c148c7b351535b5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 1 Apr 2026 08:50:35 +0100 Subject: [PATCH 26/29] Further small changes on the way to a reader. --- docs/State-of-play.md | 11 +++++++++++ src/c/io/read.c | 15 ++++++++++++++- src/c/payloads/read_stream.c | 33 +++++++++++++++++++++++++++++++++ unit-tests/string-allocation.sh | 4 ++-- 4 files changed, 60 insertions(+), 3 deletions(-) create mode 100644 src/c/payloads/read_stream.c diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 393f1aa..45d553d 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,16 @@ # State of Play +## 20260331 + +Substrate layer `print` is written; all the building blocks for substrate +layer `read` is in place. This will read far less than the 0.0.6, but it +will be extensible with read macros *written in Lisp*, so much more flexible, +and will gradually grow to read more than the non-extensible 0.0.6 reader +was. Pleased with myself. + +The new print may grow to be extensible in Lisp, as well. In fact, it will +have to! + ## 20260326 Most of the memory architecture of the new prototype is now roughed out, but diff --git a/src/c/io/read.c b/src/c/io/read.c index 9760023..9fd059e 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -69,4 +69,17 @@ struct pso_pointer read_example( struct pso4 *frame, } -// struct pso_pointer read +/** + * Read the next object on this input stream and return a pso_pointer to it. + */ +struct pso_pointer read( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer* character = fetch_arg( frame, 0); + struct pso_pointer stream = fetch_arg( frame, 1); + struct pso_pointer readtable = fetch_arg( frame, 2); + + if (nilp(stream)) { + + } +} diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c new file mode 100644 index 0000000..c710ba0 --- /dev/null +++ b/src/c/payloads/read_stream.c @@ -0,0 +1,33 @@ +/** + * payloads/read_stream.h + * + * A read stream. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include + +#include "io/fopen.h" +#include "memory/pointer.h" + + +/** + * Construct a cell which points to a stream open for reading. + * @param input the C stream to wrap. + * @param metadata a pointer to an associaton containing metadata on the stream. + * @return a pointer to the new read stream. + */ +struct pso_pointer make_read_stream( URL_FILE *input, + struct pso_pointer metadata ) { + struct pso_pointer pointer = allocate( READTV, 2); + struct pso2 *cell = pointer_to_object( pointer ); + + cell->payload.stream.stream = input; + cell->payload.stream.meta = metadata; + + return pointer; +} diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh index 1790788..4e83a5c 100755 --- a/unit-tests/string-allocation.sh +++ b/unit-tests/string-allocation.sh @@ -3,9 +3,9 @@ value='"Fred"' expected="String cell: character 'F'" # set! protects "Fred" from the garbage collector. -actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'` +actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" # | sed 's/ *\(.*\) next.*$/\1/'` -if [ $? -eq 0 ] +if [ "${expected}" = "${actual}" ] then echo "OK" exit 0 From 9eb0d3c5a07a171d3506679d9c1b211712921ed1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 1 Apr 2026 16:06:16 +0100 Subject: [PATCH 27/29] I think read will now read integers and symbols, but it's untested. Everything compiles. --- src/c/io/io.c | 40 +++++- src/c/io/io.h | 6 +- src/c/io/read.c | 180 ++++++++++++++++++++++++--- src/c/memory/destroy.c | 58 +++++++++ src/c/memory/destroy.h | 17 +++ src/c/memory/page.c | 7 ++ src/c/memory/pointer.c | 79 ++++++++++-- src/c/memory/pointer.h | 4 + src/c/memory/pso.c | 58 ++++++--- src/c/memory/pso.h | 232 +---------------------------------- src/c/memory/pso4.c | 17 +++ src/c/memory/pso4.h | 2 + src/c/memory/tags.h | 2 + src/c/ops/eq.c | 11 +- src/c/ops/reverse.c | 10 ++ src/c/payloads/character.c | 34 +++++ src/c/payloads/character.h | 3 +- src/c/payloads/cons.c | 17 +++ src/c/payloads/cons.h | 2 +- src/c/payloads/exception.c | 25 +++- src/c/payloads/exception.h | 3 + src/c/payloads/psse_string.c | 20 +++ src/c/payloads/psse_string.h | 3 + src/c/payloads/read_stream.c | 5 +- src/c/payloads/read_stream.h | 3 + src/c/payloads/stack.c | 30 ++++- src/c/payloads/stack.h | 3 + src/c/psse.c | 16 ++- 28 files changed, 594 insertions(+), 293 deletions(-) create mode 100644 src/c/memory/destroy.c create mode 100644 src/c/memory/destroy.h create mode 100644 src/c/memory/pso4.c create mode 100644 src/c/payloads/character.c diff --git a/src/c/io/io.c b/src/c/io/io.c index 5729504..a8cf105 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -46,6 +46,7 @@ #include "ops/string_ops.h" #include "ops/truth.h" +#include "payloads/character.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/integer.h" @@ -81,7 +82,7 @@ wint_t ungotten = 0; * * @return 0 on success; any other value means failure. */ -int io_init( ) { +int initialise_io( ) { int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); @@ -252,6 +253,43 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { return result; } +/** + * @brief Read one character object from this `read_stream`. + * + * @param read_stream a pointer to an object which should be a read stream + * object, + * + * @return a pointer to a character object on success, or `nil` on failure. + */ +struct pso_pointer get_character( struct pso_pointer read_stream ) { + struct pso_pointer result = nil; + + if (readp( read_stream)) { + result = make_character( url_fgetwc( pointer_to_object_of_size_class(read_stream, 2)->payload.stream.stream)); + } + + return result; +} + +/** + * @brief Push back this character `c` onto this read stream `r`. + * + * @param c a pointer to an object which should be a character object; + * @param r a pointer to an object which should be a read stream object, + * + * @return `t` on success, else `nil`. + */ +struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r) { + struct pso_pointer result = nil; + + if (characterp(c) && readp(r)) { + if (url_ungetwc( (wint_t)(pointer_to_object(c)->payload.character.character), + pointer_to_object(r)->payload.stream.stream) >= 0) { + result = t; + } + } + return result; +} /** * Function, sort-of: close the file indicated by my first arg, and return diff --git a/src/c/io/io.h b/src/c/io/io.h index 49a79da..c64114f 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -18,7 +18,7 @@ extern CURLSH *io_share; -int io_init( ); +int initialise_io( ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" @@ -30,6 +30,10 @@ URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input ); +struct pso_pointer get_character( struct pso_pointer read_stream ); + +struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r); + struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ); struct pso_pointer diff --git a/src/c/io/read.c b/src/c/io/read.c index 9fd059e..7811bf1 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -23,16 +23,22 @@ #include #include "debug.h" -#include "memory/node.h" -#include "memory/pointer.h" -#include "memory/pso2.h" #include "io/io.h" #include "io/read.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" #include "payloads/integer.h" -#include "ops/stack_ops.h" +#include "payloads/read_stream.h" +#include "ops/assoc.h" +#include "ops/reverse.h" +#include "ops/stack_ops.h" +#include "ops/string_ops.h" +#include "ops/truth.h" // TODO: what I've copied from 0.0.6 is *wierdly* over-complex for just now. // I think I'm going to essentially delete all this and start again. We need @@ -57,29 +63,167 @@ /** * An example wrapper function while I work out how I'm going to do this. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( struct pso4 *frame, - struct pso_pointer frame_pointer, +struct pso_pointer read_example( struct pso_pointer frame_pointer, struct pso_pointer env) { - struct pso_pointer character = fetch_arg( frame, 0); - struct pso_pointer stream = fetch_arg( frame, 1); - struct pso_pointer readtable = fetch_arg( frame, 2); + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; - return character; + return result; } - /** - * Read the next object on this input stream and return a pso_pointer to it. + * @brief Read one integer from the stream and return it. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. */ -struct pso_pointer read( struct pso4 *frame, - struct pso_pointer frame_pointer, +struct pso_pointer read_number( struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; + + int base = 10; + // TODO: should check for *read-base* in the environment + int64_t value = 0; + + if (readp(stream)) { + if (nilp( character)) { + character = get_character( stream); + } + wchar_t c = nilp(character) ? 0 : + pointer_to_object( character)->payload.character.character; + + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + for ( ; iswdigit( c ); + c = url_fgetwc( input ) ){ + value = (value * base) + ((int)c - (int)L'0'); + } + + url_ungetwc( c, input); + result = make_integer( value); + } // else exception? + + return result; +} + +struct pso_pointer read_symbol( struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer result = nil; + + if (readp(stream)) { + if (nilp( character)) { + character = get_character( stream); + } + + wchar_t c = nilp(character) ? 0 : + pointer_to_object( character)->payload.character.character; + + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + for ( ; iswalnum( c ); + c = url_fgetwc( input ) ){ + result = make_string_like_thing(c, result, SYMBOLTAG); + } + + url_ungetwc( c, input); + result = reverse( result); + } + + return result; +} + +/** + * @brief Read the next object on the input stream indicated by this stack + * frame, and return a pso_pointer to the object read. + * + * For this and all other `read` functions unless documented otherwise, the + * arguments in the frame are expected to be: + * + * 0. The input stream to read from; + * 1. The read table currently in use; + * 2. The character most recently read from that stream. + */ +struct pso_pointer read( struct pso_pointer frame_pointer, struct pso_pointer env ) { - struct pso_pointer* character = fetch_arg( frame, 0); - struct pso_pointer stream = fetch_arg( frame, 1); - struct pso_pointer readtable = fetch_arg( frame, 2); + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer stream = fetch_arg( frame, 0); + struct pso_pointer readtable = fetch_arg( frame, 1); + struct pso_pointer character = fetch_arg( frame, 2); + + struct pso_pointer result = nil; if (nilp(stream)) { - + stream = make_read_stream( file_to_url_file(stdin), nil); } + + if (nilp( readtable)) { + // TODO: check for the value of `*read-table*` in the environment and + // use that. + } + + if (nilp( character)) { + character = get_character( stream); + } + + struct pso_pointer readmacro = assoc(character, readtable); + + if (!nilp( readmacro)) { + // invoke the read macro on the stream + } else if (readp( stream) && characterp(character)) { + wchar_t c = pointer_to_object( character)->payload.character.character; + URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + + switch ( c ) { + case ';': + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); + /* skip all characters from semi-colon to the end of the line */ + break; + case EOF: +// result = throw_exception( c_string_to_lisp_symbol( L"read" ), +// c_string_to_lisp_string +// ( L"End of input while reading" ), +// frame_pointer ); + break; + default: + struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c)); + if ( iswdigit( c ) ) { + result = + read_number( next, env ); + } else if ( iswalpha( c ) ) { + result = read_symbol( next, env ); + } else { +// result = +// throw_exception( c_string_to_lisp_symbol( L"read" ), +// make_cons( c_string_to_lisp_string +// ( L"Unrecognised start of input character" ), +// make_string( c, NIL ) ), +// frame_pointer ); + } + break; + } + } + + return result; } diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c new file mode 100644 index 0000000..b497655 --- /dev/null +++ b/src/c/memory/destroy.c @@ -0,0 +1,58 @@ +/** + * memory/free.c + * + * Centralised point for despatching free methods to types. + * + * TODO: In the long run, we need a type for tags, which defines a constructor + * and a free method, along with the minimum and maximum size classes + * allowable for that tag; and we need a namespace in which tags are + * canonically stored, probably ::system:tags, in which the tag is bound to + * the type record describing it. And this all needs to work in Lisp, not + * in the substrate. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/stack.h" +#include "payloads/psse_string.h" + +/** + * @brief Despatch destroy message to the handler for the type of the + * object indicated by `p`, if there is one. What the destroy handler + * needs to do is dec_ref all the objects pointed to by it. + * + * The handler has 0.1.0 lisp calling convention, since + * 1. we should be able to write destroy handlers in Lisp; and + * 2. in the long run this whole system should be rewritten in Lisp. + * + * The handler returns `nil` on success, an exception pointer on + * failure. This function returns that exception pointer. How we + * handle that exception pointer I simply don't know yet. + */ +struct pso_pointer destroy( struct pso_pointer p) { + struct pso_pointer result = nil; + struct pso_pointer f = make_frame( nil, p); + inc_ref( f); + + switch (get_tag_value(p)) { + case CONSTV: destroy_cons(f, nil); break; + case EXCEPTIONTV: destroy_exception(f, nil); break; + case KEYTV : + case STRINGTV: + case SYMBOLTV: destroy_string(f, nil); break; + case STACKTV: destroy_stack_frame(f, nil); break; + // TODO: others. + } + + dec_ref(f); + return result; +} + diff --git a/src/c/memory/destroy.h b/src/c/memory/destroy.h new file mode 100644 index 0000000..ad2fc84 --- /dev/null +++ b/src/c/memory/destroy.h @@ -0,0 +1,17 @@ +/** + * memory/destroy.h + * + * Despatcher for destructor functions when objects are freed. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_memory_destroy_h +#define __psse_memory_destroy_h + +#include "memory/pointer.h" + +struct pso_pointer destroy( struct pso_pointer p); + +#endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index c5c735e..0d60021 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -17,6 +17,7 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/page.h" +#include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" @@ -124,6 +125,12 @@ struct pso_pointer allocate_page( uint8_t size_class ) { L"Initialised page %d; freelist for size class %x updated.\n", npages_allocated, size_class ); + if (npages_allocated == 0) { + // first page allocated; initialise nil and t + nil = lock_object( allocate(NILTAG, 2)); + t = lock_object( allocate(TRUETAG, 2)); + } + npages_allocated++; } else { // TODO: exception when we have one. diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index 8120e78..fb7c035 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -29,24 +29,35 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, /** * @brief returns the in-memory address of the object indicated by this - * pointer. TODO: Yhe reason I'm doing it this way is because I'm not + * pointer `p`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + * + * NOTE THAT: The return signature of these functions is pso2, because it is + * safe to cast any paged space object to a pso2, but safe to cast an object + * of a smaller size class to a larger one. If you know what size class you + * want, you should prefer `pointer_to_object_of_size_class()`, q.v. + * + * TODO: The reason I'm doing it this way is because I'm not * certain reference counter updates work right it we work with 'the object' * rather than 'the address of the object'. I really ought to have a * conversation with someone who understands this bloody language. * - * @param pointer a pso_pointer which references an object. - * @return struct pso2* the actual address in memory of that object. + * @param p a pso_pointer which references an object. + * + * @return the actual address in memory of that object, or NULL if `p` is + * invalid. */ -struct pso2 *pointer_to_object( struct pso_pointer pointer ) { +struct pso2 *pointer_to_object( struct pso_pointer p ) { struct pso2 *result = NULL; - if ( pointer.node == node_index ) { - if (pointer.page < get_pages_allocated() && pointer.offset < (PAGE_BYTES / 8)) { + if ( p.node == node_index ) { + if (p.page < get_pages_allocated() && p.offset < (PAGE_BYTES / 8)) { // TODO: that's not really a safe test of whether this is a valid pointer. - union page *pg = pages[pointer.page]; - result = ( struct pso2 * ) &pg->words[pointer.offset]; - } else { - // TODO: throw bad pointer exception. + union page *pg = pages[p.page]; + result = ( struct pso2 * ) &pg->words[p.offset]; } } // TODO: else if we have a copy of the object in cache, return that; @@ -54,3 +65,51 @@ struct pso2 *pointer_to_object( struct pso_pointer pointer ) { return result; } + +/** + * @brief returns the memory address of the object indicated by this pointer + * `p`, if it is of this `size_class`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + * + * NOTE THAT: The return signature of these functions is pso2, because it is + * safe to cast any paged space object to a pso2, but safe to cast an object + * of a smaller size class to a larger one. You should check that the object + * returned has the size class you expect. + * + * @param p a pointer to an object; + * @param size_class a size class. + * + * @return the memory address of the object, provided it is a valid object and + * of the specified size class, else NULL. + */ +struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class) { + struct pso2 * result = pointer_to_object( p); + + if (result->header.tag.bytes.size_class != size_class) { + result = NULL; + } + + return result; +} + +/** + * @brief returns the memory address of the object indicated by this pointer + * `p`, if it has this `tag_value`. + * + * NOTE THAT: It's impossible, with our calling conventions, to pass an + * exception back from this function. Consequently, if anything goes wrong + * we return NULL. The caller *should* check for that and throw an exception. + */ +struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value) { + struct pso2 * result = pointer_to_object( p); + + if ((result->header.tag.value & 0xffffff) != tag_value) { + result = NULL; + } + + return result; +} + diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index 902fce2..b467f5e 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -43,4 +43,8 @@ struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset); struct pso2* pointer_to_object( struct pso_pointer pointer); +struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class); + +struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value); + #endif diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index a3a48e7..75df0d5 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -18,6 +18,7 @@ #include #include "debug.h" +#include "memory/destroy.h" #include "memory/header.h" #include "memory/memory.h" #include "memory/node.h" @@ -74,24 +75,6 @@ uint32_t payload_size( struct pso2 *object ) { sizeof( struct pso_header ) ); } -void free_cell( struct pso_pointer p ) { - struct pso2 *p2 = pointer_to_object( p ); - uint32_t array_size = payload_size( p2 ); - uint8_t size_class = p2->header.tag.bytes.size_class; - - strncpy( ( char * ) ( p2->header.tag.bytes.mnemonic ), FREETAG, - TAGLENGTH ); - - /* will C just let me cheerfully walk off the end of the array I've declared? */ - for ( int i = 0; i < array_size; i++ ) { - p2->payload.words[i] = 0; - } - - /* TODO: obtain mutex on freelist */ - p2->payload.free.next = freelists[size_class]; - freelists[size_class] = p; -} - /** * increment the reference count of the object at this cons pointer. * @@ -153,7 +136,7 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { #endif if ( object->header.count == 0 ) { - free_cell( pointer ); + free_object( pointer ); pointer = nil; } } @@ -165,11 +148,46 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { * @brief Prevent an object ever being dereferenced. * * @param pointer pointer to an object to lock. + * + * @return the `pointer` */ -void lock_object( struct pso_pointer pointer ) { +struct pso_pointer lock_object( struct pso_pointer pointer ) { struct pso2 *object = pointer_to_object( pointer ); object->header.count = MAXREFERENCE; + + return pointer; } +/** + * @brief decrement all pointers pointed to by the object at this pointer; + * clear its memory, and return it to the freelist. + */ +struct pso_pointer free_object( struct pso_pointer p ) { + struct pso_pointer result = nil; + struct pso2 *obj = pointer_to_object( p ); + uint32_t array_size = payload_size( obj ); + uint8_t size_class = obj->header.tag.bytes.size_class; + result = destroy( p); + + /* will C just let me cheerfully walk off the end of the array I've declared? */ + for ( int i = 0; i < array_size; i++ ) { + obj->payload.words[i] = 0; + } + + + + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, L"Freeing object of size class %d at {%d, %d, %d}", + size_class, p.node, p.page, p.offset); +#endif + + /* TODO: obtain mutex on freelist */ + obj->payload.free.next = freelists[size_class]; + freelists[size_class] = p; + + return result; +} diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 3d74fe7..5e5f308 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -14,234 +14,6 @@ #include "memory/header.h" #include "memory/pointer.h" -// #include "payloads/cons.h" -// #include "payloads/exception.h" -// #include "payloads/free.h" -// #include "payloads/function.h" -// #include "payloads/hashtable.h" -// #include "payloads/integer.h" -// #include "payloads/keyword.h" -// #include "payloads/lambda.h" -// #include "payloads/mutex.h" -// #include "payloads/namespace.h" -// #include "payloads/nlambda.h" -// #include "payloads/read_stream.h" -// #include "payloads/special.h" -// #include "payloads/stack.h" -// #include "payloads/string.h" -// #include "payloads/symbol.h" -// #include "payloads/time.h" -// #include "payloads/vector_pointer.h" -// #include "payloads/write_stream.h" - -// /** -// * @brief A paged space object of size class 2, four words total, two words -// * payload. -// * -// */ -// struct pso2 { -// struct pso_header header; -// union { -// char bytes[16]; -// uint64_t words[2]; -// struct cons_payload cons; -// struct free_payload free; -// struct function_payload function; -// struct integer_payload integer; -// struct lambda_payload lambda; -// struct special_payload special; -// struct stream_payload stream; -// struct time_payload time; -// struct vectorp_payload vectorp; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 3, 8 words total, 6 words -// * payload. -// * -// */ -// struct pso3 { -// struct pso_header header; -// union { -// char bytes[48]; -// uint64_t words[6]; -// struct exception_payload exception; -// struct free_payload free; -// struct mutex_payload mutex; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 4, 16 words total, 14 words -// * payload. -// * -// */ -// struct pso4 { -// struct pso_header header; -// union { -// char bytes[112]; -// uint64_t words[14]; -// struct free_payload free; -// struct stack_frame_payload stack_frame; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 5, 32 words total, 30 words -// * payload. -// * -// */ -// struct pso5 { -// struct pso_header header; -// union { -// char bytes[240]; -// uint64_t words[30]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 6, 64 words total, 62 words -// * payload. -// * -// */ -// struct pso6 { -// struct pso_header header; -// union { -// char bytes[496]; -// uint64_t words[62]; -// struct free_payload free; -// struct hashtable_payload hashtable; -// struct namespace_payload namespace; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 7, 128 words total, 126 words -// * payload. -// * -// */ -// struct pso7 { -// struct pso_header header; -// union { -// char bytes[1008]; -// uint64_t words[126]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 8, 256 words total, 254 words -// * payload. -// * -// */ -// struct pso8 { -// struct pso_header header; -// union { -// char bytes[2032]; -// uint64_t words[254]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class 9, 512 words total, 510 words -// * payload. -// * -// */ -// struct pso9 { -// struct pso_header header; -// union { -// char bytes[4080]; -// uint64_t words[510]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class a, 1024 words total, 1022 words -// * payload. -// * -// */ -// struct psoa { -// struct pso_header header; -// union { -// char bytes[8176]; -// uint64_t words[1022]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class b, 2048 words total, 2046 words -// * payload. -// * -// */ -// struct psob { -// struct pso_header header; -// union { -// char bytes[16368]; -// uint64_t words[2046]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class c, 4096 words total, 4094 words -// * payload. -// * -// */ -// struct psoc { -// struct pso_header header; -// union { -// char bytes[32752]; -// uint64_t words[4094]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class d, 8192 words total, 8190 words -// * payload. -// * -// */ -// struct psod { -// struct pso_header header; -// union { -// char bytes[65520]; -// uint64_t words[8190]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class e, 16384 words total, 16382 words -// * payload. -// * -// */ -// struct psoe { -// struct pso_header header; -// union { -// char bytes[131056]; -// uint64_t words[16382]; -// struct free_payload free; -// } payload; -// }; - -// /** -// * @brief A paged space object of size class f, 32768 words total, 32766 words -// * payload. -// * -// */ -// struct psof { -// struct pso_header header; -// union { -// char bytes[262128]; -// uint64_t words[32766]; -// struct free_payload free; -// } payload; -// }; struct pso_pointer allocate( char* tag, uint8_t size_class); @@ -249,8 +21,8 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ); struct pso_pointer inc_ref( struct pso_pointer pointer ); -void lock_object( struct pso_pointer pointer); +struct pso_pointer lock_object( struct pso_pointer pointer); -// uint32_t get_tag_value( struct pso_pointer pointer); +struct pso_pointer free_object( struct pso_pointer p ); #endif diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c new file mode 100644 index 0000000..fd604d5 --- /dev/null +++ b/src/c/memory/pso4.c @@ -0,0 +1,17 @@ +/** + * memory/pso4.h + * + * Paged space object of size class 4, 16 words total, 14 words payload. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso4.h" + +struct pso4* pointer_to_pso4( struct pso_pointer p) { + struct pso4* result = (struct pso4*)pointer_to_object_of_size_class( p, 4); +} diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index 9ffc337..819f272 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -31,4 +31,6 @@ struct pso4 { } payload; }; +struct pso4* pointer_to_pso4( struct pso_pointer p); + #endif diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index a6f4218..e152bd2 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -98,6 +98,7 @@ bool check_tag( struct pso_pointer p, uint32_t v); bool check_type( struct pso_pointer p, char* s); +#define characterp(p) (check_tag(p, CHARACTERTV)) #define consp(p) (check_tag(p, CONSTV)) #define exceptionp(p) (check_tag(p, EXCEPTIONTV)) #define freep(p) (check_tag(p, FREETV)) @@ -116,6 +117,7 @@ bool check_type( struct pso_pointer p, char* s); #define realp(p) (check_tag(p,REALTV)) #define sequencep(p) (check_tag(p,CONSTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV)) #define specialp(p) (check_tag(p,SPECIALTV)) +#define stackp(p) (check_tag(p, STACKTV)) #define streamp(p) (check_tag(p,READTV)||check_tag(p,WRITETV)) #define stringp(p) (check_tag(p,STRINGTV)) #define symbolp(p) (check_tag(p,SYMBOLTV)) diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index ed274f9..271e2a5 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -43,13 +43,20 @@ bool equal( struct pso_pointer a, struct pso_pointer b) { if ( eq( a, b)) { result = true; } else if ( get_tag_value(a) == get_tag_value(b)) { + struct pso2 *oa = pointer_to_object(a); + struct pso2 *ob = pointer_to_object(b); + switch ( get_tag_value(a)) { + case CHARACTERTV : + result = (oa->payload.character.character == ob->payload.character.character); + break; case CONSTV : result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b))); break; case INTEGERTV : - result = (pointer_to_object(a)->payload.integer.value == - pointer_to_object(b)->payload.integer.value); + result = (oa->payload.integer.value + == + ob->payload.integer.value); break; case KEYTV: case STRINGTV : diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 1b70342..186af0b 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -25,6 +25,16 @@ #include "ops/string_ops.h" #include "ops/truth.h" +/** + * @brief reverse a sequence. + * + * A sequence is a list or a string-like-thing. A dotted pair is not a + * sequence. + * + * @param sequence a pointer to a sequence. + * @return a sequence like the `sequence` passed, but reversed; or `nil` if + * the argument was not a sequence. + */ struct pso_pointer reverse( struct pso_pointer sequence) { struct pso_pointer result = nil; diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c new file mode 100644 index 0000000..124053a --- /dev/null +++ b/src/c/payloads/character.c @@ -0,0 +1,34 @@ +/** + * payloads/character.c + * + * A character object. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* + * wide characters + */ +#include +#include + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/truth.h" + +#include "payloads/character.h" + +struct pso_pointer make_character( wint_t c) { + struct pso_pointer result = allocate( CHARACTERTAG, 2 ); + + if (!nilp(result)) { + pointer_to_object(result)->payload.character.character = (wchar_t) c; + } + + return result; +} diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 81a6dfa..854cc13 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -36,4 +36,5 @@ struct character_payload { wchar_t character; }; -#endif \ No newline at end of file +struct pso_pointer make_character( wint_t c); +#endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 8fde4b4..5da54bc 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -13,6 +13,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "payloads/cons.h" @@ -89,3 +90,19 @@ struct pso_pointer cdr( struct pso_pointer p ) { return result; } + +/** + * @brief When a cons cell is freed, its car and cdr pointers must be + * decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the cell to + * be destroyed. + */ +struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + dec_ref( car( p)); + dec_ref( cdr( p)); + } +} diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index b66ce7c..8649d13 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -32,6 +32,6 @@ struct pso_pointer cdr( struct pso_pointer cons ); struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); -bool consp( struct pso_pointer ptr ); +struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env); #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index a732610..e29e684 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -11,10 +11,31 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso4.h" +#include "memory/tags.h" #include "payloads/exception.h" -struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause) { +struct pso_pointer make_exception( struct pso_pointer message, + struct pso_pointer frame_pointer, struct pso_pointer cause) { // TODO: not yet implemented return nil; -} \ No newline at end of file +} + +/** + * @brief When an exception is freed, all its pointers must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_exception( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + + // TODO: decrement every pointer indicated by an exception. + } + + return nil; +} diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index bb1777f..a0514e1 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -27,4 +27,7 @@ struct exception_payload { struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, struct pso_pointer cause); +struct pso_pointer destroy_exception( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index 21753c8..e998cc3 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -18,8 +18,28 @@ #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/string_ops.h" #include "ops/truth.h" + +/** + * @brief When an string is freed, its cdr pointer must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_string( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + + dec_ref( cdr(p)); + } + + return nil; +} diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 9af3e78..7997a1a 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -35,4 +35,7 @@ struct string_payload { struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); +struct pso_pointer destroy_string( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index c710ba0..b70d41b 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -13,6 +13,9 @@ #include "io/fopen.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" /** @@ -23,7 +26,7 @@ */ struct pso_pointer make_read_stream( URL_FILE *input, struct pso_pointer metadata ) { - struct pso_pointer pointer = allocate( READTV, 2); + struct pso_pointer pointer = allocate( READTAG, 2); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.stream.stream = input; diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index bb0e000..47167c2 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -29,4 +29,7 @@ struct stream_payload { struct pso_pointer meta; }; +struct pso_pointer make_read_stream( URL_FILE *input, + struct pso_pointer metadata ); + #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 7008b20..aeef298 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -44,7 +44,7 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) { for ( ; cursor < count && cursor < args_in_frame; cursor++) { struct pso_pointer argument = va_arg( args, struct pso_pointer); - frame->payload.stack_frame.arg[cursor] = argument; + frame->payload.stack_frame.arg[cursor] = inc_ref( argument); } if ( cursor < count) { struct pso_pointer more_args = nil; @@ -64,3 +64,31 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) { return frame_pointer; } + +/** + * @brief When a stack frame is freed, all its pointers must be decremented. + * + * Lisp calling conventions; one expected arg, the pointer to the object to + * be destroyed. + */ +struct pso_pointer destroy_stack_frame( struct pso_pointer fp, + struct pso_pointer env) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4( fp); + struct pso4 * casualty = + pointer_to_pso4( frame->payload.stack_frame.arg[0]); + + dec_ref( casualty->payload.stack_frame.previous); + dec_ref( casualty->payload.stack_frame.function); + dec_ref( casualty->payload.stack_frame.more); + + for (int i = 0; i < args_in_frame; i++) { + dec_ref( casualty->payload.stack_frame.arg[0]); + } + + casualty->payload.stack_frame.args = 0; + casualty->payload.stack_frame.depth = 0; + } + + return nil; +} diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index a43b1e8..a2840ad 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -39,4 +39,7 @@ struct stack_frame_payload { struct pso_pointer make_frame( struct pso_pointer previous, ...); +struct pso_pointer destroy_stack_frame( struct pso_pointer fp, + struct pso_pointer env); + #endif diff --git a/src/c/psse.c b/src/c/psse.c index fc1293b..3b95d7e 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -13,8 +13,11 @@ */ #include "psse.h" +#include "io/io.h" #include "memory/node.h" + #include "ops/stack_ops.h" +#include "ops/truth.h" void print_banner( ) { fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", @@ -63,10 +66,10 @@ int main( int argc, char *argv[] ) { char *infilename = NULL; setlocale( LC_ALL, "" ); - // if ( io_init( ) != 0 ) { - // fputs( "Failed to initialise I/O subsystem\n", stderr ); - // exit( 1 ); - // } + if ( initialise_io( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { switch ( option ) { @@ -98,7 +101,10 @@ int main( int argc, char *argv[] ) { } } - initialise_node( 0 ); + if ( nilp( initialise_node( 0 ))) { + fputs( "Failed to initialise node\n", stderr ); + exit( 1 ); + } // repl( ); From f3a26bc02ec4db80433f09e60fb5a940f94225fc Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 1 Apr 2026 16:35:06 +0100 Subject: [PATCH 28/29] Added bind; but mainly, tactical commit before changinh lisp calling convention --- src/c/io/read.c | 3 +++ src/c/ops/bind.c | 45 +++++++++++++++++++++++++++++++++++++++++++ src/c/ops/bind.h | 25 ++++++++++++++++++++++++ src/c/payloads/cons.c | 7 ++----- 4 files changed, 75 insertions(+), 5 deletions(-) create mode 100644 src/c/ops/bind.c create mode 100644 src/c/ops/bind.h diff --git a/src/c/io/read.c b/src/c/io/read.c index 7811bf1..fdef2a4 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -28,6 +28,7 @@ #include "io/read.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" #include "memory/tags.h" @@ -208,6 +209,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer, break; default: struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c)); + inc_ref( next); if ( iswdigit( c ) ) { result = read_number( next, env ); @@ -221,6 +223,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer, // make_string( c, NIL ) ), // frame_pointer ); } + dec_ref( next); break; } } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c new file mode 100644 index 0000000..906423e --- /dev/null +++ b/src/c/ops/bind.c @@ -0,0 +1,45 @@ +/** + * ops/bind.c + * + * Post Scarcity Software Environment: bind. + * + * Add a binding for a key/value pair to a store -- at this stage, just an + * association list. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + +struct pso_pointer bind( struct pso_pointer frame_pointer, + struct pso_pointer env) { + struct pso4 *frame = pointer_to_pso4( frame_pointer); + struct pso_pointer key = fetch_arg( frame, 0); + struct pso_pointer value = fetch_arg( frame, 1); + struct pso_pointer store = fetch_arg( frame, 2); + + return cons( cons(key, value), store); +} + +struct pso_pointer c_bind( struct pso_pointer key, + struct pso_pointer value, + struct pso_pointer store) { + struct pso_pointer result = nil; + struct pso_pointer next = make_frame( nil, key, value, store); + inc_ref( next); + result = bind( next, nil); + dec_ref( next); + + return result; +} + diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h new file mode 100644 index 0000000..093de48 --- /dev/null +++ b/src/c/ops/bind.h @@ -0,0 +1,25 @@ +/** + * ops/bind.h + * + * Post Scarcity Software Environment: bind. + * + * Test for pointer binduality. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_bind_h +#define __psse_ops_bind_h +#include + +#include "memory/pointer.h" + +struct pso_pointer bind( struct pso_pointer frame_pointer, + struct pso_pointer env); + +struct pso_pointer c_bind( struct pso_pointer key, + struct pso_pointer value, + struct pso_pointer store); + +#endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 5da54bc..050af51 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -33,11 +33,8 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { struct pso_pointer result = allocate( CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); - object->payload.cons.car = car; - object->payload.cons.cdr = cdr; - - inc_ref( car ); - inc_ref( cdr ); + object->payload.cons.car = inc_ref( car ); + object->payload.cons.cdr = inc_ref( cdr ); return result; } From b6480aebd520a8623fb2ce34dfdd842a9f8ae4fa Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 1 Apr 2026 17:11:10 +0100 Subject: [PATCH 29/29] Converted everything to the new lisp calling convention. Fixes https://git.journeyman.cc/simon/post-scarcity/issues/19 --- archive/c/ops/equal.c | 10 +- archive/c/ops/equal.h | 2 +- archive/c/ops/intern.c | 4 +- archive/c/ops/lispops.c | 2 +- src/c/environment/environment.h | 4 +- src/c/io/io.c | 90 ++++++++++-------- src/c/io/io.h | 19 ++-- src/c/io/print.c | 78 ++++++++------- src/c/io/print.h | 4 +- src/c/io/read.c | 164 ++++++++++++++++---------------- src/c/io/read.h | 25 +++++ src/c/memory/destroy.c | 39 ++++---- src/c/memory/destroy.h | 2 +- src/c/memory/node.c | 2 +- src/c/memory/node.h | 1 - src/c/memory/page.c | 12 +-- src/c/memory/page.h | 2 +- src/c/memory/pointer.c | 38 ++++---- src/c/memory/pointer.h | 11 ++- src/c/memory/pso.c | 17 ++-- src/c/memory/pso.h | 4 +- src/c/memory/pso4.c | 5 +- src/c/memory/pso4.h | 2 +- src/c/memory/tags.c | 21 ++-- src/c/memory/tags.h | 6 +- src/c/ops/assoc.c | 42 ++++---- src/c/ops/assoc.h | 10 +- src/c/ops/bind.c | 29 +++--- src/c/ops/bind.h | 6 +- src/c/ops/eq.c | 83 ++++++++-------- src/c/ops/eq.h | 9 +- src/c/ops/eval.c | 30 +++--- src/c/ops/repl.h | 2 +- src/c/ops/reverse.c | 60 +++++++----- src/c/ops/reverse.h | 2 +- src/c/ops/string_ops.c | 10 +- src/c/ops/string_ops.h | 2 +- src/c/ops/truth.c | 28 +++--- src/c/ops/truth.h | 15 ++- src/c/payloads/character.c | 13 +-- src/c/payloads/character.h | 2 +- src/c/payloads/cons.c | 43 +++++---- src/c/payloads/cons.h | 3 +- src/c/payloads/exception.c | 17 ++-- src/c/payloads/exception.h | 5 +- src/c/payloads/integer.c | 10 +- src/c/payloads/psse_string.c | 18 ++-- src/c/payloads/psse_string.h | 2 +- src/c/payloads/read_stream.c | 4 +- src/c/payloads/read_stream.h | 4 +- src/c/payloads/stack.c | 90 +++++++++--------- src/c/payloads/stack.h | 4 +- src/c/psse.c | 3 +- 53 files changed, 590 insertions(+), 520 deletions(-) diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c index 296aea6..9a7aded 100644 --- a/archive/c/ops/equal.c +++ b/archive/c/ops/equal.c @@ -272,7 +272,7 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) { for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) { struct cons_pointer key = c_car( i ); - if ( !equal + if ( !c_equal ( hashmap_get( a, key, false ), hashmap_get( b, key, false ) ) ) { result = false; @@ -331,7 +331,7 @@ bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) { * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b ) { +bool c_equal( struct cons_pointer a, struct cons_pointer b ) { debug_print( L"\nequal: ", DEBUG_EQUAL ); debug_print_object( a, DEBUG_EQUAL ); debug_print( L" = ", DEBUG_EQUAL ); @@ -353,8 +353,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * structures can be of indefinite extent. It *must* be done by * iteration (and even that is problematic) */ result = - equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) - && equal( cell_a->payload.cons.cdr, + c_equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) + && c_equal( cell_a->payload.cons.cdr, cell_b->payload.cons.cdr ); break; case KEYTV: @@ -401,7 +401,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * isn't sufficient. So we recurse at least once. */ result = ( wcsncmp( a_buff, b_buff, i ) == 0 ) - && equal( c_cdr( a ), c_cdr( b ) ); + && c_equal( c_cdr( a ), c_cdr( b ) ); } break; case VECTORPOINTTV: diff --git a/archive/c/ops/equal.h b/archive/c/ops/equal.h index 061eb94..a3ae93a 100644 --- a/archive/c/ops/equal.h +++ b/archive/c/ops/equal.h @@ -31,6 +31,6 @@ bool eq( struct cons_pointer a, struct cons_pointer b ); * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b ); +bool c_equal( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/archive/c/ops/intern.c b/archive/c/ops/intern.c index 989686b..f16733d 100644 --- a/archive/c/ops/intern.c +++ b/archive/c/ops/intern.c @@ -334,7 +334,7 @@ struct cons_pointer search_store( struct cons_pointer key, switch ( get_tag_value( entry_ptr ) ) { case CONSTV: - if ( equal( key, c_car( entry_ptr ) ) ) { + if ( c_equal( key, c_car( entry_ptr ) ) ) { result = return_key ? c_car( entry_ptr ) : c_cdr( entry_ptr ); @@ -441,7 +441,7 @@ struct cons_pointer internedp( struct cons_pointer key, for ( struct cons_pointer pair = c_car( store ); eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) { if ( consp( pair ) ) { - if ( equal( c_car( pair ), key ) ) { + if ( c_equal( c_car( pair ), key ) ) { // yes, this should be `eq`, but if symbols are correctly // interned this will work efficiently, and if not it will // still work. diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c index a9dd7ea..2a8cc47 100644 --- a/archive/c/ops/lispops.c +++ b/archive/c/ops/lispops.c @@ -987,7 +987,7 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( frame->args > 1 ) { for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) { result = - equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; + c_equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL; } } diff --git a/src/c/environment/environment.h b/src/c/environment/environment.h index 87a40aa..4ec736a 100644 --- a/src/c/environment/environment.h +++ b/src/c/environment/environment.h @@ -10,6 +10,6 @@ #ifndef __psse_environment_environment_h #define __psse_environment_environment_h -struct pso_pointer initialise_environment( uint32_t node); +struct pso_pointer initialise_environment( uint32_t node ); -#endif \ No newline at end of file +#endif diff --git a/src/c/io/io.c b/src/c/io/io.c index a8cf105..e9b40e1 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,8 +114,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { if ( stringp( s ) || symbolp( s ) ) { int len = 0; - for ( struct pso_pointer c = s; !nilp( c ); - c = cdr(c)) { + for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) { len++; } @@ -124,8 +123,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { result = calloc( ( len * 4 ) + 1, sizeof( char ) ); int i = 0; - for ( struct pso_pointer c = s; !nilp( c ); - c = cdr(c)) { + for ( struct pso_pointer c = s; !nilp( c ); c = cdr( c ) ) { buffer[i++] = pointer_to_object( c )->payload.string.character; } @@ -134,7 +132,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { } debug_print( L"lisp_string_to_c_string( ", DEBUG_IO, 0 ); - debug_print_object( s, DEBUG_IO , 0); + debug_print_object( s, DEBUG_IO, 0 ); debug_printf( DEBUG_IO, 0, L") => '%s'\n", result ); return result; @@ -262,13 +260,16 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { * @return a pointer to a character object on success, or `nil` on failure. */ struct pso_pointer get_character( struct pso_pointer read_stream ) { - struct pso_pointer result = nil; + struct pso_pointer result = nil; - if (readp( read_stream)) { - result = make_character( url_fgetwc( pointer_to_object_of_size_class(read_stream, 2)->payload.stream.stream)); - } + if ( readp( read_stream ) ) { + result = + make_character( url_fgetwc + ( pointer_to_object_of_size_class + ( read_stream, 2 )->payload.stream.stream ) ); + } - return result; + return result; } /** @@ -279,16 +280,20 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) { * * @return `t` on success, else `nil`. */ -struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r) { - struct pso_pointer result = nil; +struct pso_pointer push_back_character( struct pso_pointer c, + struct pso_pointer r ) { + struct pso_pointer result = nil; - if (characterp(c) && readp(r)) { - if (url_ungetwc( (wint_t)(pointer_to_object(c)->payload.character.character), - pointer_to_object(r)->payload.stream.stream) >= 0) { - result = t; - } - } - return result; + if ( characterp( c ) && readp( r ) ) { + if ( url_ungetwc( ( wint_t ) + ( pointer_to_object( c )->payload.character. + character ), + pointer_to_object( r )->payload.stream.stream ) >= + 0 ) { + result = t; + } + } + return result; } /** @@ -304,12 +309,14 @@ struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer * @return T if the stream was successfully closed, else nil. */ struct pso_pointer -lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0) ) || writep( fetch_arg( frame, 0) ) ) { - if ( url_fclose( pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream ) + if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { + if ( url_fclose + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ) == 0 ) { result = t; } @@ -319,25 +326,25 @@ lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, } struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, - long int value ) { + long int value ) { return cons( cons - ( c_string_to_lisp_keyword( key ), - make_integer( value ) ), meta ); + ( c_string_to_lisp_keyword( key ), + make_integer( value ) ), meta ); } struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, - char *value ) { + char *value ) { value = trim( value ); wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); return cons( cons( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + c_string_to_lisp_string( buffer ) ), meta ); } struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, - time_t *value ) { + time_t *value ) { /* I don't yet have a concept of a date-time object, which is a * bit of an oversight! */ char datestring[256]; @@ -409,7 +416,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // } // free( s ); - return 0; // strlen( string ); + return 0; // strlen( string ); } void collect_meta( struct pso_pointer stream, char *url ) { @@ -489,8 +496,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { * on my stream, if any, else nil. */ struct pso_pointer -lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; // if ( stringp( fetch_arg( frame, 0) ) ) { @@ -556,14 +563,14 @@ lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, * on my stream, if any, else nil. */ struct pso_pointer -lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0) ) ) { + if ( readp( fetch_arg( frame, 0 ) ) ) { result = make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0) )->payload. + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. stream.stream ), nil ); } @@ -585,18 +592,19 @@ lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, * on my stream, if any, else nil. */ struct pso_pointer -lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if ( readp( fetch_arg( frame, 0) ) ) { - URL_FILE *stream = pointer_to_object( fetch_arg( frame, 0) )->payload.stream.stream; + if ( readp( fetch_arg( frame, 0 ) ) ) { + URL_FILE *stream = + pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.stream; struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil ); result = cursor; for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; c = url_fgetwc( stream ) ) { - debug_print( L"slurp: cursor is: ", DEBUG_IO, 0); + debug_print( L"slurp: cursor is: ", DEBUG_IO, 0 ); debug_dump_object( cursor, DEBUG_IO, 0 ); debug_print( L"; result is: ", DEBUG_IO, 0 ); debug_dump_object( result, DEBUG_IO, 0 ); diff --git a/src/c/io/io.h b/src/c/io/io.h index c64114f..703ed2e 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -8,8 +8,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef __psse_io_h -#define __psse_io_h +#ifndef __psse_io_io_h +#define __psse_io_io_h #include #include "memory/pointer.h" @@ -32,22 +32,19 @@ wint_t url_ungetwc( wint_t wc, URL_FILE * input ); struct pso_pointer get_character( struct pso_pointer read_stream ); -struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer r); +struct pso_pointer push_back_character( struct pso_pointer c, + struct pso_pointer r ); struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ); struct pso_pointer -lisp_close( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ); +lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer -lisp_open( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ); +lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer -lisp_read_char( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ); +lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer -lisp_slurp( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ); +lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ); char *lisp_string_to_c_string( struct pso_pointer s ); #endif diff --git a/src/c/io/print.c b/src/c/io/print.c index 1b1bb0b..e56babf 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -36,28 +36,29 @@ #include "payloads/cons.h" #include "payloads/integer.h" -struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output); +struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); -struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output) { - struct pso_pointer result = nil; +struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) { + struct pso_pointer result = nil; - if (consp(p)) { - for (; consp( p); p = cdr(p)) { - struct pso2* object = pointer_to_object(p); - - result = in_print( object->payload.cons.car, output); + if ( consp( p ) ) { + for ( ; consp( p ); p = cdr( p ) ) { + struct pso2 *object = pointer_to_object( p ); - if (exceptionp(result)) break; + result = in_print( object->payload.cons.car, output ); - switch (get_tag_value(object->payload.cons.cdr)) { - case NILTV : + if ( exceptionp( result ) ) + break; + + switch ( get_tag_value( object->payload.cons.cdr ) ) { + case NILTV: break; - case CONSTV : + case CONSTV: url_fputwc( L' ', output ); break; - default : - url_fputws( L" . ", output); - result = in_print( object->payload.cons.cdr, output); + default: + url_fputws( L" . ", output ); + result = in_print( object->payload.cons.cdr, output ); } } @@ -68,33 +69,34 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE * output) return result; } -struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) { - struct pso2* object = pointer_to_object(p); +struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { + struct pso2 *object = pointer_to_object( p ); struct pso_pointer result = nil; - if (object != NULL) { - switch (get_tag_value( p)) { - case CHARACTERTV : - url_fputwc( object->payload.character.character, output); + if ( object != NULL ) { + switch ( get_tag_value( p ) ) { + case CHARACTERTV: + url_fputwc( object->payload.character.character, output ); break; - case CONSTV : + case CONSTV: url_fputwc( L'(', output ); - result = print_list_content( p, output); + result = print_list_content( p, output ); url_fputwc( L')', output ); break; - case INTEGERTV : - url_fwprintf( output, L"%d", (int64_t)(object->payload.integer.value)); + case INTEGERTV: + url_fwprintf( output, L"%d", + ( int64_t ) ( object->payload.integer.value ) ); break; - case TRUETV : + case TRUETV: url_fputwc( L't', output ); break; - case NILTV : + case NILTV: url_fputws( L"nil", output ); - default : + default: // TODO: return exception } } else { - // TODO: return exception + // TODO: return exception } return result; @@ -107,16 +109,20 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output) { * @param stream if a pointer to an open write stream, print to there. * @return struct pso_pointer `nil`, or an exception if some erroe occurred. */ -struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream) { - URL_FILE *output = writep( stream) ? - pointer_to_object( stream )->payload.stream.stream : - file_to_url_file(stdout); +struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream ) { + URL_FILE *output = writep( stream ) ? + pointer_to_object( stream )->payload.stream.stream : + file_to_url_file( stdout ); - if ( writep( stream)) { inc_ref( stream); } + if ( writep( stream ) ) { + inc_ref( stream ); + } - struct pso_pointer result = in_print(p, output); + struct pso_pointer result = in_print( p, output ); - if ( writep( stream)) { dec_ref( stream); } + if ( writep( stream ) ) { + dec_ref( stream ); + } return result; } diff --git a/src/c/io/print.h b/src/c/io/print.h index 7542076..eb728c3 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -14,6 +14,6 @@ #ifndef __psse_io_print_h #define __psse_io_print_h -struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream); +struct pso_pointer print( struct pso_pointer p, struct pso_pointer stream ); -#endif \ No newline at end of file +#endif diff --git a/src/c/io/read.c b/src/c/io/read.c index fdef2a4..71c96f8 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -73,14 +73,14 @@ * 2. The character most recently read from that stream. */ struct pso_pointer read_example( struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4( frame_pointer); - struct pso_pointer stream = fetch_arg( frame, 0); - struct pso_pointer readtable = fetch_arg( frame, 1); - struct pso_pointer character = fetch_arg( frame, 2); - struct pso_pointer result = nil; + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer stream = fetch_arg( frame, 0 ); + struct pso_pointer readtable = fetch_arg( frame, 1 ); + struct pso_pointer character = fetch_arg( frame, 2 ); + struct pso_pointer result = nil; - return result; + return result; } /** @@ -94,64 +94,62 @@ struct pso_pointer read_example( struct pso_pointer frame_pointer, * 2. The character most recently read from that stream. */ struct pso_pointer read_number( struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4( frame_pointer); - struct pso_pointer stream = fetch_arg( frame, 0); - struct pso_pointer readtable = fetch_arg( frame, 1); - struct pso_pointer character = fetch_arg( frame, 2); - struct pso_pointer result = nil; + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer stream = fetch_arg( frame, 0 ); + struct pso_pointer readtable = fetch_arg( frame, 1 ); + struct pso_pointer character = fetch_arg( frame, 2 ); + struct pso_pointer result = nil; - int base = 10; - // TODO: should check for *read-base* in the environment - int64_t value = 0; + int base = 10; + // TODO: should check for *read-base* in the environment + int64_t value = 0; - if (readp(stream)) { - if (nilp( character)) { - character = get_character( stream); - } - wchar_t c = nilp(character) ? 0 : - pointer_to_object( character)->payload.character.character; + if ( readp( stream ) ) { + if ( nilp( character ) ) { + character = get_character( stream ); + } + wchar_t c = nilp( character ) ? 0 : + pointer_to_object( character )->payload.character.character; - URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; - for ( ; iswdigit( c ); - c = url_fgetwc( input ) ){ - value = (value * base) + ((int)c - (int)L'0'); - } + URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; + for ( ; iswdigit( c ); c = url_fgetwc( input ) ) { + value = ( value * base ) + ( ( int ) c - ( int ) L'0' ); + } - url_ungetwc( c, input); - result = make_integer( value); - } // else exception? + url_ungetwc( c, input ); + result = make_integer( value ); + } // else exception? - return result; + return result; } struct pso_pointer read_symbol( struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4( frame_pointer); - struct pso_pointer stream = fetch_arg( frame, 0); - struct pso_pointer readtable = fetch_arg( frame, 1); - struct pso_pointer character = fetch_arg( frame, 2); - struct pso_pointer result = nil; + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer stream = fetch_arg( frame, 0 ); + struct pso_pointer readtable = fetch_arg( frame, 1 ); + struct pso_pointer character = fetch_arg( frame, 2 ); + struct pso_pointer result = nil; - if (readp(stream)) { - if (nilp( character)) { - character = get_character( stream); - } + if ( readp( stream ) ) { + if ( nilp( character ) ) { + character = get_character( stream ); + } - wchar_t c = nilp(character) ? 0 : - pointer_to_object( character)->payload.character.character; + wchar_t c = nilp( character ) ? 0 : + pointer_to_object( character )->payload.character.character; - URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; - for ( ; iswalnum( c ); - c = url_fgetwc( input ) ){ - result = make_string_like_thing(c, result, SYMBOLTAG); - } + URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; + for ( ; iswalnum( c ); c = url_fgetwc( input ) ) { + result = make_string_like_thing( c, result, SYMBOLTAG ); + } - url_ungetwc( c, input); - result = reverse( result); - } + url_ungetwc( c, input ); + result = reverse( result ); + } - return result; + return result; } /** @@ -166,34 +164,35 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer, * 2. The character most recently read from that stream. */ struct pso_pointer read( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer); - struct pso_pointer stream = fetch_arg( frame, 0); - struct pso_pointer readtable = fetch_arg( frame, 1); - struct pso_pointer character = fetch_arg( frame, 2); + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer stream = fetch_arg( frame, 0 ); + struct pso_pointer readtable = fetch_arg( frame, 1 ); + struct pso_pointer character = fetch_arg( frame, 2 ); - struct pso_pointer result = nil; + struct pso_pointer result = nil; - if (nilp(stream)) { - stream = make_read_stream( file_to_url_file(stdin), nil); - } + if ( nilp( stream ) ) { + stream = make_read_stream( file_to_url_file( stdin ), nil ); + } - if (nilp( readtable)) { - // TODO: check for the value of `*read-table*` in the environment and - // use that. - } + if ( nilp( readtable ) ) { + // TODO: check for the value of `*read-table*` in the environment and + // use that. + } - if (nilp( character)) { - character = get_character( stream); - } + if ( nilp( character ) ) { + character = get_character( stream ); + } - struct pso_pointer readmacro = assoc(character, readtable); + struct pso_pointer readmacro = assoc( character, readtable ); - if (!nilp( readmacro)) { - // invoke the read macro on the stream - } else if (readp( stream) && characterp(character)) { - wchar_t c = pointer_to_object( character)->payload.character.character; - URL_FILE * input = pointer_to_object(stream)->payload.stream.stream; + if ( !nilp( readmacro ) ) { + // invoke the read macro on the stream + } else if ( readp( stream ) && characterp( character ) ) { + wchar_t c = + pointer_to_object( character )->payload.character.character; + URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; switch ( c ) { case ';': @@ -208,11 +207,12 @@ struct pso_pointer read( struct pso_pointer frame_pointer, // frame_pointer ); break; default: - struct pso_pointer next = make_frame( frame_pointer, stream, readtable, make_character(c)); - inc_ref( next); - if ( iswdigit( c ) ) { - result = - read_number( next, env ); + struct pso_pointer next = + make_frame( frame_pointer, stream, readtable, + make_character( c ) ); + inc_ref( next ); + if ( iswdigit( c ) ) { + result = read_number( next, env ); } else if ( iswalpha( c ) ) { result = read_symbol( next, env ); } else { @@ -223,10 +223,10 @@ struct pso_pointer read( struct pso_pointer frame_pointer, // make_string( c, NIL ) ), // frame_pointer ); } - dec_ref( next); + dec_ref( next ); break; } - } + } - return result; + return result; } diff --git a/src/c/io/read.h b/src/c/io/read.h index e69de29..a3e0ffc 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -0,0 +1,25 @@ +/** + * read.h + * + * Read basic Lisp objects..This is :bootstrap layer print; it needs to be + * able to read characters, symbols, integers, lists and dotted pairs. I + * don't think it needs to be able to read anything else. It must, however, + * take a readtable as argument and expand reader macros. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_read_h +#define __psse_io_read_h +struct pso_pointer read_number( struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer read_symbol( struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer read( struct pso_pointer frame_pointer, + struct pso_pointer env ); + +#endif diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c index b497655..01e493d 100644 --- a/src/c/memory/destroy.c +++ b/src/c/memory/destroy.c @@ -37,22 +37,29 @@ * failure. This function returns that exception pointer. How we * handle that exception pointer I simply don't know yet. */ -struct pso_pointer destroy( struct pso_pointer p) { - struct pso_pointer result = nil; - struct pso_pointer f = make_frame( nil, p); - inc_ref( f); +struct pso_pointer destroy( struct pso_pointer p ) { + struct pso_pointer result = nil; + struct pso_pointer f = make_frame( nil, p ); + inc_ref( f ); - switch (get_tag_value(p)) { - case CONSTV: destroy_cons(f, nil); break; - case EXCEPTIONTV: destroy_exception(f, nil); break; - case KEYTV : - case STRINGTV: - case SYMBOLTV: destroy_string(f, nil); break; - case STACKTV: destroy_stack_frame(f, nil); break; - // TODO: others. - } + switch ( get_tag_value( p ) ) { + case CONSTV: + destroy_cons( f, nil ); + break; + case EXCEPTIONTV: + destroy_exception( f, nil ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + destroy_string( f, nil ); + break; + case STACKTV: + destroy_stack_frame( f, nil ); + break; + // TODO: others. + } - dec_ref(f); - return result; + dec_ref( f ); + return result; } - diff --git a/src/c/memory/destroy.h b/src/c/memory/destroy.h index ad2fc84..d85013e 100644 --- a/src/c/memory/destroy.h +++ b/src/c/memory/destroy.h @@ -12,6 +12,6 @@ #include "memory/pointer.h" -struct pso_pointer destroy( struct pso_pointer p); +struct pso_pointer destroy( struct pso_pointer p ); #endif diff --git a/src/c/memory/node.c b/src/c/memory/node.c index ebf470e..2a650a0 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -57,7 +57,7 @@ struct pso_pointer initialise_node( uint32_t index ) { struct pso_pointer result = initialise_memory( index ); - if ( eq( result, t ) ) { + if ( c_eq( result, t ) ) { result = initialise_environment( index ); } diff --git a/src/c/memory/node.h b/src/c/memory/node.h index 1e94956..fbc177a 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -34,4 +34,3 @@ extern struct pso_pointer t; struct pso_pointer initialise_node( uint32_t index ); #endif - diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 0d60021..60771b4 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -125,10 +125,10 @@ struct pso_pointer allocate_page( uint8_t size_class ) { L"Initialised page %d; freelist for size class %x updated.\n", npages_allocated, size_class ); - if (npages_allocated == 0) { - // first page allocated; initialise nil and t - nil = lock_object( allocate(NILTAG, 2)); - t = lock_object( allocate(TRUETAG, 2)); + if ( npages_allocated == 0 ) { + // first page allocated; initialise nil and t + nil = lock_object( allocate( NILTAG, 2 ) ); + t = lock_object( allocate( TRUETAG, 2 ) ); } npages_allocated++; @@ -164,6 +164,6 @@ struct pso_pointer allocate_page( uint8_t size_class ) { * @brief allow other files to see the current value of npages_allocated, but not * change it. */ -uint32_t get_pages_allocated() { - return npages_allocated; +uint32_t get_pages_allocated( ) { + return npages_allocated; } diff --git a/src/c/memory/page.h b/src/c/memory/page.h index 3df37e6..d30befb 100644 --- a/src/c/memory/page.h +++ b/src/c/memory/page.h @@ -74,6 +74,6 @@ union page { struct pso_pointer allocate_page( uint8_t size_class ); -uint32_t get_pages_allocated(); +uint32_t get_pages_allocated( ); #endif diff --git a/src/c/memory/pointer.c b/src/c/memory/pointer.c index fb7c035..b76f92c 100644 --- a/src/c/memory/pointer.c +++ b/src/c/memory/pointer.c @@ -54,11 +54,12 @@ struct pso2 *pointer_to_object( struct pso_pointer p ) { struct pso2 *result = NULL; if ( p.node == node_index ) { - if (p.page < get_pages_allocated() && p.offset < (PAGE_BYTES / 8)) { - // TODO: that's not really a safe test of whether this is a valid pointer. - union page *pg = pages[p.page]; - result = ( struct pso2 * ) &pg->words[p.offset]; - } + if ( p.page < get_pages_allocated( ) + && p.offset < ( PAGE_BYTES / 8 ) ) { + // TODO: that's not really a safe test of whether this is a valid pointer. + union page *pg = pages[p.page]; + result = ( struct pso2 * ) &pg->words[p.offset]; + } } // TODO: else if we have a copy of the object in cache, return that; // else request a copy of the object from the node which curates it. @@ -85,14 +86,15 @@ struct pso2 *pointer_to_object( struct pso_pointer p ) { * @return the memory address of the object, provided it is a valid object and * of the specified size class, else NULL. */ -struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class) { - struct pso2 * result = pointer_to_object( p); +struct pso2 *pointer_to_object_of_size_class( struct pso_pointer p, + uint8_t size_class ) { + struct pso2 *result = pointer_to_object( p ); - if (result->header.tag.bytes.size_class != size_class) { - result = NULL; - } + if ( result->header.tag.bytes.size_class != size_class ) { + result = NULL; + } - return result; + return result; } /** @@ -103,13 +105,13 @@ struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t siz * exception back from this function. Consequently, if anything goes wrong * we return NULL. The caller *should* check for that and throw an exception. */ -struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value) { - struct pso2 * result = pointer_to_object( p); +struct pso2 *pointer_to_object_with_tag_value( struct pso_pointer p, + uint32_t tag_value ) { + struct pso2 *result = pointer_to_object( p ); - if ((result->header.tag.value & 0xffffff) != tag_value) { - result = NULL; - } + if ( ( result->header.tag.value & 0xffffff ) != tag_value ) { + result = NULL; + } - return result; + return result; } - diff --git a/src/c/memory/pointer.h b/src/c/memory/pointer.h index b467f5e..827bb95 100644 --- a/src/c/memory/pointer.h +++ b/src/c/memory/pointer.h @@ -39,12 +39,15 @@ struct pso_pointer { }; -struct pso_pointer make_pointer( uint32_t node, uint16_t page, uint16_t offset); +struct pso_pointer make_pointer( uint32_t node, uint16_t page, + uint16_t offset ); -struct pso2* pointer_to_object( struct pso_pointer pointer); +struct pso2 *pointer_to_object( struct pso_pointer pointer ); -struct pso2 * pointer_to_object_of_size_class( struct pso_pointer p, uint8_t size_class); +struct pso2 *pointer_to_object_of_size_class( struct pso_pointer p, + uint8_t size_class ); -struct pso2 * pointer_to_object_with_tag_value( struct pso_pointer p, uint32_t tag_value); +struct pso2 *pointer_to_object_with_tag_value( struct pso_pointer p, + uint32_t tag_value ); #endif diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 75df0d5..7409e51 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -164,25 +164,26 @@ struct pso_pointer lock_object( struct pso_pointer pointer ) { * clear its memory, and return it to the freelist. */ struct pso_pointer free_object( struct pso_pointer p ) { - struct pso_pointer result = nil; + struct pso_pointer result = nil; struct pso2 *obj = pointer_to_object( p ); uint32_t array_size = payload_size( obj ); uint8_t size_class = obj->header.tag.bytes.size_class; - result = destroy( p); + result = destroy( p ); - /* will C just let me cheerfully walk off the end of the array I've declared? */ - for ( int i = 0; i < array_size; i++ ) { - obj->payload.words[i] = 0; - } + /* will C just let me cheerfully walk off the end of the array I've declared? */ + for ( int i = 0; i < array_size; i++ ) { + obj->payload.words[i] = 0; + } strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, TAGLENGTH ); #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, L"Freeing object of size class %d at {%d, %d, %d}", - size_class, p.node, p.page, p.offset); + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of size class %d at {%d, %d, %d}", + size_class, p.node, p.page, p.offset ); #endif /* TODO: obtain mutex on freelist */ diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 5e5f308..928a6aa 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -15,13 +15,13 @@ #include "memory/header.h" #include "memory/pointer.h" -struct pso_pointer allocate( char* tag, uint8_t size_class); +struct pso_pointer allocate( char *tag, uint8_t size_class ); struct pso_pointer dec_ref( struct pso_pointer pointer ); struct pso_pointer inc_ref( struct pso_pointer pointer ); -struct pso_pointer lock_object( struct pso_pointer pointer); +struct pso_pointer lock_object( struct pso_pointer pointer ); struct pso_pointer free_object( struct pso_pointer p ); diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c index fd604d5..cfe6722 100644 --- a/src/c/memory/pso4.c +++ b/src/c/memory/pso4.c @@ -12,6 +12,7 @@ #include "memory/pso2.h" #include "memory/pso4.h" -struct pso4* pointer_to_pso4( struct pso_pointer p) { - struct pso4* result = (struct pso4*)pointer_to_object_of_size_class( p, 4); +struct pso4 *pointer_to_pso4( struct pso_pointer p ) { + struct pso4 *result = + ( struct pso4 * ) pointer_to_object_of_size_class( p, 4 ); } diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index 819f272..bafda3f 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -31,6 +31,6 @@ struct pso4 { } payload; }; -struct pso4* pointer_to_pso4( struct pso_pointer p); +struct pso4 *pointer_to_pso4( struct pso_pointer p ); #endif diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 7718f3e..6e4a7c5 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -16,10 +16,10 @@ #include "memory/pointer.h" #include "memory/pso2.h" -uint32_t get_tag_value (struct pso_pointer p) { - struct pso2* object = pointer_to_object( p); +uint32_t get_tag_value( struct pso_pointer p ) { + struct pso2 *object = pointer_to_object( p ); - return object->header.tag.value & 0xffffff; + return object->header.tag.value & 0xffffff; } /** @@ -31,8 +31,8 @@ uint32_t get_tag_value (struct pso_pointer p) { * * @return true if the tag at p matches v, else false. */ -bool check_tag( struct pso_pointer p, uint32_t v) { - return get_tag_value(p) == v; +bool check_tag( struct pso_pointer p, uint32_t v ) { + return get_tag_value( p ) == v; } /** @@ -46,8 +46,9 @@ bool check_tag( struct pso_pointer p, uint32_t v) { * of the object. * @return false otherwise. */ -bool check_type( struct pso_pointer p, char* s) { - return (strncmp( - &(pointer_to_object(p)->header.tag.bytes.mnemonic[0]), s, TAGLENGTH) - == 0); -} \ No newline at end of file +bool check_type( struct pso_pointer p, char *s ) { + return ( strncmp + ( &( pointer_to_object( p )->header.tag.bytes.mnemonic[0] ), s, + TAGLENGTH ) + == 0 ); +} diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index e152bd2..524e805 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -82,7 +82,7 @@ * @return the numerical value of the tag, as a uint32_t. */ // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) -uint32_t get_tag_value (struct pso_pointer p); +uint32_t get_tag_value( struct pso_pointer p ); /** * @brief check that the tag of the object indicated by this poiner has this @@ -94,9 +94,9 @@ uint32_t get_tag_value (struct pso_pointer p); * @return true if the tag at p matches v, else false. */ // #define check_tag(p,v) (get_tag_value(p) == v) -bool check_tag( struct pso_pointer p, uint32_t v); +bool check_tag( struct pso_pointer p, uint32_t v ); -bool check_type( struct pso_pointer p, char* s); +bool check_type( struct pso_pointer p, char *s ); #define characterp(p) (check_tag(p, CHARACTERTV)) #define consp(p) (check_tag(p, CONSTV)) diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 8589966..b1d6acb 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -34,25 +34,23 @@ * return the binding. */ struct pso_pointer search( struct pso_pointer key, - struct pso_pointer store, - bool return_key ) { - struct pso_pointer result = nil; - bool found = false; + struct pso_pointer store, bool return_key ) { + struct pso_pointer result = nil; + bool found = false; - if (consp( store)) { - for ( struct pso_pointer cursor = store; - consp( store) && found == false; - cursor = cdr( cursor)) { - struct pso_pointer pair = car( cursor); + if ( consp( store ) ) { + for ( struct pso_pointer cursor = store; + consp( store ) && found == false; cursor = cdr( cursor ) ) { + struct pso_pointer pair = car( cursor ); - if (consp(pair) && equal(car(pair), key)) { - found = true; - result = return_key ? car(pair) : cdr( pair); - } - } - } + if ( consp( pair ) && c_equal( car( pair ), key ) ) { + found = true; + result = return_key ? car( pair ) : cdr( pair ); + } + } + } - return result; + return result; } /** @@ -63,8 +61,8 @@ struct pso_pointer search( struct pso_pointer key, * * @return a pointer to the value of the key in the store, or nil if not found */ -struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store) { - return search( key, store, false); +struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ) { + return search( key, store, false ); } /** @@ -75,8 +73,8 @@ struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store) { * * @return a pointer to the copy of the key in the store, or nil if not found. */ -struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store) { - return search( key, store, true); +struct pso_pointer interned( struct pso_pointer key, struct pso_pointer store ) { + return search( key, store, true ); } /** @@ -87,6 +85,6 @@ struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store) { * * @return `true` if a pointer the key was found in the store.. */ -bool internedp(struct pso_pointer key, struct pso_pointer store) { - return !nilp( search( key, store, true)); +bool internedp( struct pso_pointer key, struct pso_pointer store ) { + return !nilp( search( key, store, true ) ); } diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index e5572f9..52d8d08 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -17,12 +17,12 @@ #include "memory/pointer.h" struct cons_pointer search( struct pso_pointer key, - struct pso_pointer store, - bool return_key ); + struct pso_pointer store, bool return_key ); -struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store); +struct pso_pointer assoc( struct pso_pointer key, struct pso_pointer store ); -struct pso_pointer interned(struct pso_pointer key, struct pso_pointer store); +struct pso_pointer interned( struct pso_pointer key, + struct pso_pointer store ); -bool internedp(struct pso_pointer key, struct pso_pointer store); +bool internedp( struct pso_pointer key, struct pso_pointer store ); #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 906423e..f812c43 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -22,24 +22,23 @@ #include "payloads/stack.h" struct pso_pointer bind( struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4( frame_pointer); - struct pso_pointer key = fetch_arg( frame, 0); - struct pso_pointer value = fetch_arg( frame, 1); - struct pso_pointer store = fetch_arg( frame, 2); + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer value = fetch_arg( frame, 1 ); + struct pso_pointer store = fetch_arg( frame, 2 ); - return cons( cons(key, value), store); + return cons( cons( key, value ), store ); } struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store) { - struct pso_pointer result = nil; - struct pso_pointer next = make_frame( nil, key, value, store); - inc_ref( next); - result = bind( next, nil); - dec_ref( next); + struct pso_pointer value, + struct pso_pointer store ) { + struct pso_pointer result = nil; + struct pso_pointer next = make_frame( nil, key, value, store ); + inc_ref( next ); + result = bind( next, nil ); + dec_ref( next ); - return result; + return result; } - diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index 093de48..d7cdf42 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -16,10 +16,10 @@ #include "memory/pointer.h" struct pso_pointer bind( struct pso_pointer frame_pointer, - struct pso_pointer env); + struct pso_pointer env ); struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store); + struct pso_pointer value, + struct pso_pointer store ); #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 271e2a5..b3789e5 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -33,47 +33,49 @@ * @param b another pointer; * @return `true` if they are the same, else `false` */ -bool eq( struct pso_pointer a, struct pso_pointer b ) { +bool c_eq( struct pso_pointer a, struct pso_pointer b ) { return ( a.node == b.node && a.page == b.page && a.offset == b.offset ); } -bool equal( struct pso_pointer a, struct pso_pointer b) { - bool result = false; +bool c_equal( struct pso_pointer a, struct pso_pointer b ) { + bool result = false; - if ( eq( a, b)) { - result = true; - } else if ( get_tag_value(a) == get_tag_value(b)) { - struct pso2 *oa = pointer_to_object(a); - struct pso2 *ob = pointer_to_object(b); + if ( c_eq( a, b ) ) { + result = true; + } else if ( get_tag_value( a ) == get_tag_value( b ) ) { + struct pso2 *oa = pointer_to_object( a ); + struct pso2 *ob = pointer_to_object( b ); - switch ( get_tag_value(a)) { - case CHARACTERTV : - result = (oa->payload.character.character == ob->payload.character.character); - break; - case CONSTV : - result = (equal( car(a), car(b)) && equal( cdr(a), cdr(b))); - break; - case INTEGERTV : - result = (oa->payload.integer.value - == - ob->payload.integer.value); - break; - case KEYTV: - case STRINGTV : - case SYMBOLTV : - while (result == false && !nilp(a) && !nilp(b)) { - if (pointer_to_object(a)->payload.string.character == - pointer_to_object(b)->payload.string.character) { - a = cdr(a); - b = cdr(b); - } - } - result = nilp(a) && nilp(b); - break; - } - } + switch ( get_tag_value( a ) ) { + case CHARACTERTV: + result = + ( oa->payload.character.character == + ob->payload.character.character ); + break; + case CONSTV: + result = ( c_equal( car( a ), car( b ) ) + && c_equal( cdr( a ), cdr( b ) ) ); + break; + case INTEGERTV: + result = ( oa->payload.integer.value + == ob->payload.integer.value ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + while ( result == false && !nilp( a ) && !nilp( b ) ) { + if ( pointer_to_object( a )->payload.string.character == + pointer_to_object( b )->payload.string.character ) { + a = cdr( a ); + b = cdr( b ); + } + } + result = nilp( a ) && nilp( b ); + break; + } + } - return result; + return result; } @@ -89,9 +91,10 @@ bool equal( struct pso_pointer a, struct pso_pointer b) { * @param env my environment (ignored). * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer lisp_eq( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer eq( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = t; if ( frame->payload.stack_frame.args > 1 ) { @@ -99,11 +102,9 @@ struct pso_pointer lisp_eq( struct pso4 *frame, ( truep( result ) ) && ( b < frame->payload.stack_frame.args ); b++ ) { result = - eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil; + c_eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil; } } return result; } - - diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 4b4300c..854e40c 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -16,11 +16,10 @@ #include "memory/pointer.h" #include "memory/pso4.h" -bool eq( struct pso_pointer a, struct pso_pointer b ); +bool c_eq( struct pso_pointer a, struct pso_pointer b ); -struct pso_pointer lisp_eq( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer eq( struct pso_pointer frame_pointer, + struct pso_pointer env ); -bool equal( struct pso_pointer a, struct pso_pointer b); +bool c_equal( struct pso_pointer a, struct pso_pointer b ); #endif diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index f78f4d6..830cceb 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -10,7 +10,9 @@ */ #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso3.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -23,6 +25,8 @@ #include "payloads/special.h" #include "payloads/stack.h" +#include "ops/truth.h" + /** * @brief Despatch eval based on tag of the form in the first position. * @@ -31,9 +35,9 @@ * @param env the evaluation environment. * @return struct pso_pointer */ -struct pso_pointer eval_despatch( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_eval( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = frame->payload.stack_frame.arg[0]; // switch ( get_tag_value( result)) { @@ -55,17 +59,17 @@ struct pso_pointer eval_despatch( struct pso4 *frame, // break; // } - return result; -} - -struct pso_pointer lisp_eval( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = eval_despatch( frame, frame_pointer, env ); - if ( exceptionp( result ) ) { - // todo: if result doesn't have a stack frame, create a new exception wrapping - // result with this stack frame. + struct pso3 *x = + ( struct pso3 * ) pointer_to_object_with_tag_value( result, + EXCEPTIONTV ); + + if ( nilp( x->payload.exception.stack ) ) { + inc_ref( result ); + result = + make_exception( x->payload.exception.message, frame_pointer, + result ); + } } return result; diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index 7a99f48..e5b1a9a 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -12,4 +12,4 @@ // struct pso_pointer repl( struct pso_pointer prompt, struct pso_pointer readtable); -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 186af0b..5f59004 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -35,31 +35,41 @@ * @return a sequence like the `sequence` passed, but reversed; or `nil` if * the argument was not a sequence. */ -struct pso_pointer reverse( struct pso_pointer sequence) { - struct pso_pointer result = nil; +struct pso_pointer reverse( struct pso_pointer sequence ) { + struct pso_pointer result = nil; - for (struct pso_pointer cursor = sequence; !nilp( sequence); cursor = cdr(cursor)) { - struct pso2* object = pointer_to_object( cursor); - switch (get_tag_value(cursor)) { - case CONSTV : - result = cons( car(cursor), result); - break; - case KEYTV : - result = make_string_like_thing( object->payload.string.character, result, KEYTAG); - break; - case STRINGTV : - result = make_string_like_thing( object->payload.string.character, result, STRINGTAG); - break; - case SYMBOLTV : - result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG); - break; - default : - result = make_exception( c_string_to_lisp_string(L"Invalid object in sequence"), nil, nil); - goto exit; - break; - } - } -exit: + for ( struct pso_pointer cursor = sequence; !nilp( sequence ); + cursor = cdr( cursor ) ) { + struct pso2 *object = pointer_to_object( cursor ); + switch ( get_tag_value( cursor ) ) { + case CONSTV: + result = cons( car( cursor ), result ); + break; + case KEYTV: + result = + make_string_like_thing( object->payload.string.character, + result, KEYTAG ); + break; + case STRINGTV: + result = + make_string_like_thing( object->payload.string.character, + result, STRINGTAG ); + break; + case SYMBOLTV: + result = + make_string_like_thing( object->payload.string.character, + result, SYMBOLTAG ); + break; + default: + result = + make_exception( c_string_to_lisp_string + ( L"Invalid object in sequence" ), nil, + nil ); + goto exit; + break; + } + } + exit: - return result; + return result; } diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h index 18cb36e..96f6b2f 100644 --- a/src/c/ops/reverse.h +++ b/src/c/ops/reverse.h @@ -16,6 +16,6 @@ #include "memory/pointer.h" -struct pso_pointer reverse( struct pso_pointer sequence); +struct pso_pointer reverse( struct pso_pointer sequence ); #endif diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 432a7d8..14d12a3 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -42,7 +42,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { struct pso2 *cell = pointer_to_object( ptr ); uint32_t result = 0; - switch ( get_tag_value(ptr)) { + switch ( get_tag_value( ptr ) ) { case KEYTV: case STRINGTV: case SYMBOLTV: @@ -70,22 +70,22 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * (and thus simpler). */ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, - char* tag ) { + char *tag ) { struct pso_pointer pointer = nil; if ( check_type( tail, tag ) || check_tag( tail, NILTV ) ) { - pointer = allocate( tag, CONS_SIZE_CLASS); + pointer = allocate( tag, CONS_SIZE_CLASS ); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.string.character = c; cell->payload.string.cdr = tail; - cell->payload.string.hash = calculate_hash( c, tail); + cell->payload.string.hash = calculate_hash( c, tail ); debug_dump_object( pointer, DEBUG_ALLOC, 0 ); debug_println( DEBUG_ALLOC ); } else { // \todo should throw an exception! - debug_printf( DEBUG_ALLOC, 0, + debug_printf( DEBUG_ALLOC, 0, L"Warning: only %4.4s can be prepended to %4.4s\n", tag, tag ); } diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index b874f2b..59ce837 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -17,7 +17,7 @@ #include struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, - char* tag ); + char *tag ); struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 5d3db10..8ffb2f5 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -13,6 +13,7 @@ #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso4.h" #include "ops/stack_ops.h" /** @@ -64,10 +65,11 @@ bool truep( struct pso_pointer p ) { * @param env the evaluation environment. * @return `t` if the first argument in this frame is `nil`, else `t` */ -struct pso_pointer lisp_nilp( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { -return ( nilp( fetch_arg( frame, 0 )) ? t : nil ); +struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return ( nilp( fetch_arg( frame, 0 ) ) ? t : nil ); } /** @@ -78,10 +80,11 @@ return ( nilp( fetch_arg( frame, 0 )) ? t : nil ); * @param env the evaluation environment. * @return `t` if the first argument in this frame is `t`, else `nil`. */ -struct pso_pointer lisp_truep( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return ( truep( fetch_arg( frame, 0 ) ) ? t : nil ); +struct pso_pointer lisp_truep( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return ( truep( fetch_arg( frame, 0 ) ) ? t : nil ); } /** @@ -93,8 +96,9 @@ struct pso_pointer lisp_truep( struct pso4 *frame, * @param env the evaluation environment. * @return `t` if the first argument in this frame is not `nil`, else `t`. */ -struct pso_pointer lisp_not( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return ( not( fetch_arg( frame, 0 ) ) ? t : nil ); +struct pso_pointer lisp_not( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return ( not( fetch_arg( frame, 0 ) ) ? t : nil ); } diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index e81eacd..0fa0574 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -18,20 +18,17 @@ bool nilp( struct pso_pointer p ); -struct pso_pointer lisp_nilp( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer, + struct pso_pointer env ); bool not( struct pso_pointer p ); -struct pso_pointer lisp_not( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer lisp_not( struct pso_pointer frame_pointer, + struct pso_pointer env ); bool truep( struct pso_pointer p ); -struct pso_pointer lisp_truep( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer lisp_truep( struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c index 124053a..aa370e4 100644 --- a/src/c/payloads/character.c +++ b/src/c/payloads/character.c @@ -23,12 +23,13 @@ #include "payloads/character.h" -struct pso_pointer make_character( wint_t c) { - struct pso_pointer result = allocate( CHARACTERTAG, 2 ); +struct pso_pointer make_character( wint_t c ) { + struct pso_pointer result = allocate( CHARACTERTAG, 2 ); - if (!nilp(result)) { - pointer_to_object(result)->payload.character.character = (wchar_t) c; - } + if ( !nilp( result ) ) { + pointer_to_object( result )->payload.character.character = + ( wchar_t ) c; + } - return result; + return result; } diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 854cc13..355b79a 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -36,5 +36,5 @@ struct character_payload { wchar_t character; }; -struct pso_pointer make_character( wint_t c); +struct pso_pointer make_character( wint_t c ); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 050af51..607cca4 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -14,7 +14,7 @@ #include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso4.h" -#include "memory/tags.h" +#include "memory/tags.h" #include "payloads/cons.h" #include "payloads/exception.h" @@ -70,17 +70,21 @@ struct pso_pointer cdr( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); - switch (get_tag_value( p)) { - case CONSTV : result = object->payload.cons.cdr; break; - case KEYTV : - case STRINGTV : - case SYMBOLTV : - result = object->payload.string.cdr; break; - default : - result = make_exception( - cons(c_string_to_lisp_string(L"Invalid type for cdr"), p), - nil, nil); - break; + switch ( get_tag_value( p ) ) { + case CONSTV: + result = object->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = object->payload.string.cdr; + break; + default: + result = + make_exception( cons + ( c_string_to_lisp_string + ( L"Invalid type for cdr" ), p ), nil, nil ); + break; } // TODO: else throw an exception @@ -95,11 +99,12 @@ struct pso_pointer cdr( struct pso_pointer p ) { * Lisp calling conventions; one expected arg, the pointer to the cell to * be destroyed. */ -struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4( fp); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( car( p)); - dec_ref( cdr( p)); - } +struct pso_pointer destroy_cons( struct pso_pointer fp, + struct pso_pointer env ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + dec_ref( car( p ) ); + dec_ref( cdr( p ) ); + } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 8649d13..9ba768f 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -32,6 +32,7 @@ struct pso_pointer cdr( struct pso_pointer cons ); struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); -struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env); +struct pso_pointer destroy_cons( struct pso_pointer fp, + struct pso_pointer env ); #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index e29e684..1b38a76 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -17,7 +17,8 @@ #include "payloads/exception.h" struct pso_pointer make_exception( struct pso_pointer message, - struct pso_pointer frame_pointer, struct pso_pointer cause) { + struct pso_pointer frame_pointer, + struct pso_pointer cause ) { // TODO: not yet implemented return nil; } @@ -29,13 +30,13 @@ struct pso_pointer make_exception( struct pso_pointer message, * be destroyed. */ struct pso_pointer destroy_exception( struct pso_pointer fp, - struct pso_pointer env) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4( fp); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; + struct pso_pointer env ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; - // TODO: decrement every pointer indicated by an exception. - } + // TODO: decrement every pointer indicated by an exception. + } - return nil; + return nil; } diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index a0514e1..5b865e2 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -25,9 +25,10 @@ struct exception_payload { }; struct pso_pointer make_exception( struct pso_pointer message, - struct pso_pointer frame_pointer, struct pso_pointer cause); + struct pso_pointer frame_pointer, + struct pso_pointer cause ); struct pso_pointer destroy_exception( struct pso_pointer fp, - struct pso_pointer env); + struct pso_pointer env ); #endif diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 6b62f47..8437a8b 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -26,13 +26,13 @@ */ struct pso_pointer make_integer( int64_t value ) { struct pso_pointer result = nil; - debug_print( L"Entering make_integer\n", DEBUG_ALLOC , 0); + debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 ); - result = allocate( INTEGERTAG, 2); - struct pso2 *cell = pointer_to_object( result ); - cell->payload.integer.value = value; + result = allocate( INTEGERTAG, 2 ); + struct pso2 *cell = pointer_to_object( result ); + cell->payload.integer.value = value; - debug_print( L"make_integer: returning\n", DEBUG_ALLOC , 0); + debug_print( L"make_integer: returning\n", DEBUG_ALLOC, 0 ); debug_dump_object( result, DEBUG_ALLOC, 0 ); return result; diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index e998cc3..a75037b 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -11,8 +11,8 @@ #include /* - * wide characters - */ + * wide characters + */ #include #include @@ -33,13 +33,13 @@ * be destroyed. */ struct pso_pointer destroy_string( struct pso_pointer fp, - struct pso_pointer env) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4( fp); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; + struct pso_pointer env ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( cdr(p)); - } + dec_ref( cdr( p ) ); + } - return nil; + return nil; } diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 7997a1a..ea232ae 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -36,6 +36,6 @@ struct string_payload { struct pso_pointer make_string( wint_t c, struct pso_pointer tail ); struct pso_pointer destroy_string( struct pso_pointer fp, - struct pso_pointer env); + struct pso_pointer env ); #endif diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index b70d41b..995d454 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -25,8 +25,8 @@ * @return a pointer to the new read stream. */ struct pso_pointer make_read_stream( URL_FILE *input, - struct pso_pointer metadata ) { - struct pso_pointer pointer = allocate( READTAG, 2); + struct pso_pointer metadata ) { + struct pso_pointer pointer = allocate( READTAG, 2 ); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.stream.stream = input; diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index 47167c2..1ea0adb 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -29,7 +29,7 @@ struct stream_payload { struct pso_pointer meta; }; -struct pso_pointer make_read_stream( URL_FILE *input, - struct pso_pointer metadata ); +struct pso_pointer make_read_stream( URL_FILE * input, + struct pso_pointer metadata ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index aeef298..a0591ab 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -25,44 +25,44 @@ * * @return a pso_pointer to the stack frame. */ -struct pso_pointer make_frame( struct pso_pointer previous, ...) { - va_list args; - va_start(args, previous); - int count = va_arg(args, int); +struct pso_pointer make_frame( struct pso_pointer previous, ... ) { + va_list args; + va_start( args, previous ); + int count = va_arg( args, int ); - struct pso_pointer frame_pointer = allocate( STACKTAG, 4); - struct pso4* frame = (struct pso4*)pointer_to_object( frame_pointer); + struct pso_pointer frame_pointer = allocate( STACKTAG, 4 ); + struct pso4 *frame = ( struct pso4 * ) pointer_to_object( frame_pointer ); - frame->payload.stack_frame.previous = previous; + frame->payload.stack_frame.previous = previous; - // I *think* the count starts with the number of args, so there are - // one fewer actual args. Need to test to verify this! - count --; - int cursor = 0; - frame->payload.stack_frame.args = count; + // I *think* the count starts with the number of args, so there are + // one fewer actual args. Need to test to verify this! + count--; + int cursor = 0; + frame->payload.stack_frame.args = count; - for ( ; cursor < count && cursor < args_in_frame; cursor++) { - struct pso_pointer argument = va_arg( args, struct pso_pointer); + for ( ; cursor < count && cursor < args_in_frame; cursor++ ) { + struct pso_pointer argument = va_arg( args, struct pso_pointer ); - frame->payload.stack_frame.arg[cursor] = inc_ref( argument); - } - if ( cursor < count) { - struct pso_pointer more_args = nil; + frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); + } + if ( cursor < count ) { + struct pso_pointer more_args = nil; - for (; cursor < count; cursor++) { - more_args = cons( va_arg( args, struct pso_pointer), more_args); - } + for ( ; cursor < count; cursor++ ) { + more_args = cons( va_arg( args, struct pso_pointer ), more_args ); + } - // should be frame->payload.stack_frame.more = reverse( more_args), but - // we don't have reverse yet. TODO: fix. - frame->payload.stack_frame.more = more_args; - } else { - for (; cursor < args_in_frame; cursor++) { - frame->payload.stack_frame.arg[cursor] = nil; - } - } + // should be frame->payload.stack_frame.more = reverse( more_args), but + // we don't have reverse yet. TODO: fix. + frame->payload.stack_frame.more = more_args; + } else { + for ( ; cursor < args_in_frame; cursor++ ) { + frame->payload.stack_frame.arg[cursor] = nil; + } + } - return frame_pointer; + return frame_pointer; } /** @@ -72,23 +72,23 @@ struct pso_pointer make_frame( struct pso_pointer previous, ...) { * be destroyed. */ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, - struct pso_pointer env) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4( fp); - struct pso4 * casualty = - pointer_to_pso4( frame->payload.stack_frame.arg[0]); + struct pso_pointer env ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso4 *casualty = + pointer_to_pso4( frame->payload.stack_frame.arg[0] ); - dec_ref( casualty->payload.stack_frame.previous); - dec_ref( casualty->payload.stack_frame.function); - dec_ref( casualty->payload.stack_frame.more); + dec_ref( casualty->payload.stack_frame.previous ); + dec_ref( casualty->payload.stack_frame.function ); + dec_ref( casualty->payload.stack_frame.more ); - for (int i = 0; i < args_in_frame; i++) { - dec_ref( casualty->payload.stack_frame.arg[0]); - } + for ( int i = 0; i < args_in_frame; i++ ) { + dec_ref( casualty->payload.stack_frame.arg[0] ); + } - casualty->payload.stack_frame.args = 0; - casualty->payload.stack_frame.depth = 0; - } + casualty->payload.stack_frame.args = 0; + casualty->payload.stack_frame.depth = 0; + } - return nil; + return nil; } diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index a2840ad..7333809 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -37,9 +37,9 @@ struct stack_frame_payload { uint32_t depth; }; -struct pso_pointer make_frame( struct pso_pointer previous, ...); +struct pso_pointer make_frame( struct pso_pointer previous, ... ); struct pso_pointer destroy_stack_frame( struct pso_pointer fp, - struct pso_pointer env); + struct pso_pointer env ); #endif diff --git a/src/c/psse.c b/src/c/psse.c index 3b95d7e..b234103 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -101,11 +101,10 @@ int main( int argc, char *argv[] ) { } } - if ( nilp( initialise_node( 0 ))) { + if ( nilp( initialise_node( 0 ) ) ) { fputs( "Failed to initialise node\n", stderr ); exit( 1 ); } - // repl( ); exit( 0 );