From 99d4794f3bb3deafbb83732799dd7b9ae631feb9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 19 Mar 2026 13:59:06 +0000 Subject: [PATCH 01/77] 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 02/77] 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 03/77] 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 04/77] 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 604fca3c245b53d55aa2648f26fceaadf6c1341c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 25 Mar 2026 11:24:33 +0000 Subject: [PATCH 05/77] 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 06/77] 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 07/77] 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 08/77] 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 1afb1b9fad9a28e5cc8d3cf5b0bdad93457054f8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2026 11:56:36 +0000 Subject: [PATCH 09/77] 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 10/77] 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 11/77] 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 12/77] 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 13/77] 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 14/77] 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 15/77] 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 16/77] 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 17/77] 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 18/77] 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 19/77] `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 20/77] 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 21/77] 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 22/77] 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 23/77] 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 24/77] 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 ); From f5f8e38b914a11f4d0af0752e5a9201e19eb4392 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 3 Apr 2026 11:14:39 +0100 Subject: [PATCH 25/77] Added a note on things to read for the compiler. --- docs/Compiler.md | 108 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100644 docs/Compiler.md diff --git a/docs/Compiler.md b/docs/Compiler.md new file mode 100644 index 0000000..e6c8c3e --- /dev/null +++ b/docs/Compiler.md @@ -0,0 +1,108 @@ +# Towards a Compiler + +Abdulaziz Ghuloum's paper [An Incremental Approach to Compiler Construction](https://bernsteinbear.com/assets/img/11-ghuloum.pdf) starts with the observation: + +> Compilers are perceived to be magical artifacts, carefully crafted +> by the wizards, and unfathomable by the mere mortals. Books on +> compilers are better described as wizard-talk: written by and for +> a clique of all-knowing practitioners. Real-life compilers are too +> complex to serve as an educational tool. And the gap between +> real-life compilers and the educational toy compilers is too wide. +> The novice compiler writer stands puzzled facing an impenetrable +> barrier, “better write an interpreter instead.” + +Well, yes. That *is* what I feel. But the thing is, I've written two Lisp interpreters (and interpreters for a few other languages into one dialect of Lisp or another) now. I still feel [imposter syndrome](https://en.wikipedia.org/wiki/Impostor_syndrome) — that my interpreters are not as good as they should be, that I haven't understood the ideas clearly enough or implemented them cleanly enough, but [Beowulf](https://git.journeyman.cc/simon/beowulf) works (and evaluates Lisp) very well; the [`0.0.6` Post Scarcity](https://git.journeyman.cc/simon/post-scarcity) prototype works, after a fashion; and, after only a week of work, the `0.1.0` Post Scarcity prototype is close to working now. + +Further back in my history, the [MicroWorld rule language](https://git.journeyman.cc/simon/mw-parser) is still easily buildable and works well; and, long before that, my LemonADE adventure game writing language did work well; and KnacqTools suite of rule 'compilers,' which although not strictly speaking either interpreters or compilers in this sense were very similar technology, also worked extremely well. Interpreters — even reasonably good interpreters — are a done problem, but I have really no idea where to start building a compiler. + +So why bother? + +Beowulf is *mostly* written in Lisp — which is to say, it is mostly written in itself. If you check the [list of functions](https://git.journeyman.cc/simon/beowulf#functions-and-symbols-implemented), you'll see that the overwhelming majority of them are described as 'Lisp lambda functions'. This means, they're Beowulf functions written in Beowulf — and you can read the source code of them [here](https://git.journeyman.cc/simon/beowulf/src/branch/master/resources/lisp1.5.lsp). + +But Post Scarcity `0.0.6` is written almost entirely in C. It never got to the point, as Beowulf did, where you could start a Lisp session, hack up a few functions, and save out your system to persistent storage to start again later with the work you'd written already incorporated. And this is mainly because I tried to do too many of the hard parts, like the sophisticated reader and bignum arithmetic, in C. + +I'm not a confident C programmer. Post Scarcity `0.0.6`'s bignum arithmetic doesn't work, and I've failed to make it work. Post Scarcity `0.0.6`'s garbage collector works unacceptably poorly. My goal, in `0.1.0`, is to write far less in the substrate and far more in Lisp. + +Which means, the Lisp must be as performant as possible. Which means, I think, that I need a compiler. Which means I need to learn to be (more of a) wizard. + +So, where do I start? Where is my grimoire? + +## Online tutorials on Lisp compilers + +### Ghuloum + +I've mentioned Abdulaziz Ghuloum's [An Incremental Approach to Compiler Construction](https://bernsteinbear.com/assets/img/11-ghuloum.pdf) at the top. It's PDF, of course. Why do people publish things as PDF? It makes them *so hard* to read! + +However, I very much like his approach: small incremental steps. He writes mainly in Scheme, which is similar enough to Post Scarcity Lisp that it should be reasonably simple to carry over ideas; he targets what he describes as 'Intel-x86' assembler, but I don't yet know whether that means 16, 32 or 64 bit — since the paper dates from 2006 I'm guessing 32 bit. However, his method is to write a C fragment that implements a small step of his process, and then examine assembler output from GCC; that's an approach I could follow. + +He uses test driven development, which should make things easy to reproduce. + +He implements tail-call optimisation. + +The paper is quite brief, and does not include source code; I have not found source code relating to it. + +The paper contains a link to the author's home page at Indiana.edu, but that link is now dead. Archive.org has snapshots dated from [18th September 2006](https://web.archive.org/web/20060918162504/https://www.cs.indiana.edu/~aghuloum/) (the paper is dated from the 16th) to [March 10th 2011](https://web.archive.org/web/20110310092701/http://www.cs.indiana.edu/~aghuloum/). Although the lecture notes appear in both the listed snapshots, the paper itself is not in the first of them. + +Ghuloum appears to have recently been teaching at the American University of Kuwait; he has a [GitHub presence](https://github.com/azizghuloum), but his Scheme compiler is not listed there. He published [a number of technical papers on Scheme](https://scholar.google.com/citations?user=5rd6dWUAAAAJ&hl=en) between 2006 and 2009, but does not appear to have published anything since. + +### Healey + +This blog post by [Andrew Healey](https://github.com/healeycodes), [Compiling Lisp to Bytecode and Running It](https://healeycodes.com/compiling-lisp-to-bytecode-and-running-it) is essentially 'write your own virtual machine,' which, given that I've been thinking about the ideal instruction set for the Post Scarcity processor, isn't a bad idea. [This repository](https://github.com/healeycodes/lisp-to-js) appears to be his implementation. + +His code has virtually no internal documentation, and is in a language I don't even recognise (it might be Rust — it builds and tests with `cargo`); however, it's clearly written in nice small functions, and there is really surprisingly little of it. It does build, and all its tests pass. + +Healey is still active on GitHub, and currently works for Vercel, an 'AI Cloud' company, apparently as a software engineer. + +### Bernstein + +There's a [blog series](https://bernsteinbear.com/blog/lisp/) by [Max Bernstein](https://github.com/tekknolagi) which is nicely clear. He references Ghuloum's work (and indeed the link I found to Ghuloum's paper is on his site), but builds his compiler in C. His repository for the compiler posts appears to be [this one](https://github.com/tekknolagi/ghuloum). + +His code is mainly in C, with a test harness in Python. Again, his code is internally largely undocumented, but builds cleanly, and all his unit tests pass. The way he implements his unit tests is new to me, and worth studying; it's certainly better than the scrappy mess of shell scripts I used for the `0.0.X` series. + +### Others + +That's the list of things I've found so far that look useful to me. If I find others, I'll add them here. + +## Things which inevitably make the Post Scarcity compiler different + +### Tag location + +Objects in Lisp have to know that they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer. + +Modern Lisps still, I think, mostly store the tag on the pointer, but they run on commodity hardware which doesn't have those extra bits in the word size. That means that the size of an integer, or the precision of a real, that you can store in one word of memory is much less. It also means either that they can address much less memory than other programming languages on the same hardware, because for every bit you steal out of the address bus you halve the amount of memory you can address; or else that they bit shift up every address before they fetch it. + +The bit shift works if all memory objects are powers of two words wide, which, in Post Scarcity `0.1.0` they are, see [Paged Space Objects](Paged-space-objects.md); but as I am already doing the upshifting trick so that I can address more than 64 (actually 104, on the current sketch of how memory works) 'bits wide' of memory, this doesn't help me. + +Consequently, in both the `0.0.X` series of prototypes and now in the `0.1.0` prototype, I have the tag in the object, not in the pointer. + +#### Is that a good decision? + +There's a really big inefficiency in that decision. In early versions of Java, numbers (and a few other things) were not objects, but 'primitives'. That is to say, the word of memory which, for objects, would be a pointer, is, for primitives, the actual data; and thus you can operate on it without doing an additional fetch. In modern Java, those primitives still exist, as [unboxed types](https://en.wikipedia.org/wiki/Boxing_(computer_programming)). Java can do this because it is a typed language. Every method knows the type of its arguments. + +In Lisp we don't. So we either have the tag on the pointer, reducing, as I pointed out above, the number of addresses that can be addressed and the amount of data that can be stored in each object, or we have the tag on the object, meaning that (the header of) every object has to be fetched before we even know what it is, and thus how to despatch it further. And, in the Post Scarcity architecture as I conceive it now, in the case of an object which is curated on a node somewhere far distant across the hypercube and not yet in local cache, that means it has to be fetched hoppity hop across the mesh, which is extremely costly. + +But, not only does Post Scarcity need a bigger tag than most Lisps in order to have user extensible types, it also needs to have an access control list on every object in order to have security between users; and, although I failed to make the reference counting garbage collector work in `0.0.X`, and although the thinking I've been doing about the 'mark but don't sweep' garbage collector may make it unnecessary, I still want to experiment with reference counting. So I need space in every header for a reference count. + +So I can't really have unboxed objects, I think[^1] — at least, allowing unboxed integers, reals, and characters would need a very thorough rethink of the security model. + +[^1]: except that, in compiled functions, local variables could potentially be the equivalent of unboxed. That's one of the main speed increases I hope to get from compiling. + +All decisions in engineering are compromises. At present, I am content to proceed with this compromise. + +### Reifying compiled functions + +I don't honestly know where most modern Lisps allocate space for compiled functions, but I suspect that it's on the heap. In the `0.1.0` prototype I'm really trying to limit the use of 'raw' heap allocation, to prevent heap fragmentation, to reduce garbage collection problems. So I want to put each compiled function into a paged space object. Which means they have to be relocatable in memory. + +And certainly, when a compiled function is copied from the node on which it is curated to another node where it will be cached, it will be at a different place in the memory of that node. + +*(Question: should we copy only source functions across the mesh, and compile them 'just in time' on the node where they will be used? Doing that would allow each compiled function to incorporate raw pointers to every other function it called, which would greatly speed execution. However, if any of those functions were subsequently redefined, it would not update to use the new definition without recompilation.)* + +I don't *think* relocatability is a problem. Lisps which use heap-allocated compiled functions and run mark and sweep garbage collectors on their heap, as I'm almost certain Portable Standard Lisp does and imagine most other conventional Lisps must, must have relocatable functions. + +However, it may be. I certainly need to think about relocatability in this design. + +## Conclusion + +Post Scarcity's compiler won't be — can't be — a straight lift of anyone else's Lisp compiler. Post Scarcity is just inevitably a very different beast. The whole idea of a multiple instruction, multiple data, massively parallel processor is one that has not been very much explored because it is hard; and I don't have the technical or mathematical understanding to demonstrate whether, even if a Post Scarcity machine really could use four billion processor nodes petabytes of memory, it could do so efficiently. + +But the compiler is doable; none of the peculiarities of the architecture is a blocker. And even if this won't be a conventional compiler, there is a great deal that can be learned from conventional compilers. \ No newline at end of file From b5a2e09763a64dbdfe0f08baddf7ea5505260bc6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 13 Apr 2026 14:52:05 +0100 Subject: [PATCH 26/77] Things that are self-evaluating can self-evaluate. --- src/c/ops/eval.c | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c index 830cceb..3778a35 100644 --- a/src/c/ops/eval.c +++ b/src/c/ops/eval.c @@ -40,24 +40,24 @@ struct pso_pointer lisp_eval( struct pso_pointer frame_pointer, struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = frame->payload.stack_frame.arg[0]; - // switch ( get_tag_value( result)) { + 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; - // } + case SYMBOLTV: + result = eval_symbol( frame_pointer, env); + break; + case LAMBDATV: + result = eval_lambda( frame_pointer, env); + break; + case NLAMBDATV: + result = eval_nlambda( frame_pointer, env); + break; + case SPECIALTV: + result = eval_special( frame, frame_pointer, env); + break; + } if ( exceptionp( result ) ) { struct pso3 *x = From c9f50572ab7f011d92c75b675a36336479fb74a2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Apr 2026 19:50:10 +0100 Subject: [PATCH 27/77] Many more ops written, and it compiles. Nothing works yet. --- docs/Compiler.md | 2 +- docs/State-of-play.md | 76 ++++++++++++++++++++++++++++++++++++ src/c/io/io.c | 21 +++++----- src/c/io/print.c | 2 +- src/c/io/read.c | 2 +- src/c/ops/assoc.c | 72 ++++++++++++++++++++++++++++++---- src/c/ops/assoc.h | 8 ++-- src/c/ops/bind.c | 17 ++++++-- src/c/ops/bind.h | 11 ++++-- src/c/ops/eq.c | 53 ++++++++++++++++++++----- src/c/ops/eq.h | 20 ++++++++++ src/c/ops/reverse.c | 6 ++- src/c/payloads/cons.c | 13 +++--- src/c/payloads/cons.h | 6 +-- src/c/payloads/function.h | 44 ++++++++++++++------- src/c/payloads/psse_string.c | 2 +- src/c/payloads/stack.c | 6 ++- 17 files changed, 290 insertions(+), 71 deletions(-) diff --git a/docs/Compiler.md b/docs/Compiler.md index e6c8c3e..2894e4f 100644 --- a/docs/Compiler.md +++ b/docs/Compiler.md @@ -67,7 +67,7 @@ That's the list of things I've found so far that look useful to me. If I find ot ### Tag location -Objects in Lisp have to know that they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer. +Objects in Lisp have to know what they are. This is what makes it possible to compute with an 'untyped' language: the type is not encoded in the program but in the data. In most conventional Lisp systems, things are typed by having a tag. Back in the day, when we had hardware specially built to run Lisp, Lisp specific hardware often had a word size — and thus registers, and a data bus — wider than the address bus, wider by the number of bits in the tag, and stored the tag on the pointer. Modern Lisps still, I think, mostly store the tag on the pointer, but they run on commodity hardware which doesn't have those extra bits in the word size. That means that the size of an integer, or the precision of a real, that you can store in one word of memory is much less. It also means either that they can address much less memory than other programming languages on the same hardware, because for every bit you steal out of the address bus you halve the amount of memory you can address; or else that they bit shift up every address before they fetch it. diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 45d553d..f6985aa 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,81 @@ # State of Play +## 20260415 + +OK, I have been diverted down a side-project on a side-project. I decided +that since Post Scarcity definitely needs a compiler, I should learn to write +a compiler, and so I should start by writing one for a simpler Lisp than Post +Scarcity. So I started to write +[one in Guile Scheme for Beowulf](https://git.journeyman.cc/simon/naegling). +This is started but a long way from finished. I'm also not very enamoured of +Guile Scheme, and am starting to wonder whether in fact I should be writing +if in [Beowulf](https://git.journeyman.cc/simon/beowulf) for Beowulf. + +I do believe I can complete the Naegling/Beowulf compiler, and that having +written it, I can write a Post Scarcity compiler in Post Scarcity. But to do +that I still need to have to have at least all of + +* apply +* assoc +* bind! (or put! or set!, but I *think* I prefer `bind!`) +* car +* cdr +* cons +* cond +* eq? +* equal? +* eval +* λ +* nil +* print +* read +* t + +and, essentially, have all the parts of a working REPL. + +My brain is not working very well at present; I can't do more than a very few +hours of focussed work a day, and jumping between Naegling and Post Scarcity +is probably not a good plan; but in periods when I need to do thinking about +where I'm going with Naegling I may switch to Post Scarcity (and vice versa). + +### Standard signature for compiled functions + +While I'm on this, I'm wondering whether I've got the standard signature for +compiled functions right. What we've inherited from the `0.0.X` branch is +documented as: + +```c + /** + * 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 ); +``` + +But actually the documentation here is wrong, because what we actually pass +is a C pointer to a stack frame object (which in `0.0.X` is in vector space), +a cons pointer to the cons space object which is the vector pointer to that +stack frame, and a cons pointer to the environment. + +We definitely don't need to pass a pointer to the argument list (and in fact +we didn't before, the documentation is *wrong*); we also don't need to pass +both a C pointer and a cons pointer to the frame, since the frame is now in +paged space, so passing our managed pointer is enough. + +It *might be* that passing both an unmanaged and a managed pointer is worth +doing, since recovering the managed pointer from the unmanaged pointer is +very expensive, and while recovering the unmanaged pointer from the +managed pointer is cheap, it isn't free. + +But it's worth thinking about. + + + ## 20260331 Substrate layer `print` is written; all the building blocks for substrate diff --git a/src/c/io/io.c b/src/c/io/io.c index e9b40e1..3f31d2c 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,7 +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 = c_cdr( c ) ) { len++; } @@ -123,7 +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 = c_cdr( c ) ) { buffer[i++] = pointer_to_object( c )->payload.string.character; } @@ -286,8 +286,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload.character. - character ), + ( pointer_to_object( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -315,8 +315,8 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( url_fclose - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) == 0 ) { result = t; } @@ -328,8 +328,7 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { 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 ), + c_cons( c_cons( c_string_to_lisp_keyword( key ), make_integer( value ) ), meta ); } @@ -339,7 +338,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return cons( cons( c_string_to_lisp_keyword( key ), + return c_cons( c_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } @@ -570,8 +569,8 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) ) { result = make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ), nil ); + ( pointer_to_object( fetch_arg( frame, 0 ) )-> + payload.stream.stream ), nil ); } return result; diff --git a/src/c/io/print.c b/src/c/io/print.c index e56babf..e22d48b 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -42,7 +42,7 @@ 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 ) ) { + for ( ; consp( p ); p = c_cdr( p ) ) { struct pso2 *object = pointer_to_object( p ); result = in_print( object->payload.cons.car, output ); diff --git a/src/c/io/read.c b/src/c/io/read.c index 71c96f8..f49368d 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -185,7 +185,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer, character = get_character( stream ); } - struct pso_pointer readmacro = assoc( character, readtable ); + struct pso_pointer readmacro = c_assoc( character, readtable ); if ( !nilp( readmacro ) ) { // invoke the read macro on the stream diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index b1d6acb..004fa3e 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -19,6 +19,7 @@ #include "payloads/cons.h" #include "ops/eq.h" +#include "ops/stack_ops.h" #include "ops/truth.h" /** @@ -40,12 +41,12 @@ struct pso_pointer search( struct pso_pointer key, if ( consp( store ) ) { for ( struct pso_pointer cursor = store; - consp( store ) && found == false; cursor = cdr( cursor ) ) { - struct pso_pointer pair = car( cursor ); + consp( store ) && found == false; cursor = c_cdr( cursor ) ) { + struct pso_pointer pair = c_car( cursor ); - if ( consp( pair ) && c_equal( car( pair ), key ) ) { + if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; - result = return_key ? car( pair ) : cdr( pair ); + result = return_key ? c_car( pair ) : c_cdr( pair ); } } } @@ -61,7 +62,7 @@ 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 ) { +struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ) { return search( key, store, false ); } @@ -73,7 +74,7 @@ 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 ) { +struct pso_pointer c_interned( struct pso_pointer key, struct pso_pointer store ) { return search( key, store, true ); } @@ -85,6 +86,63 @@ 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 ) { +bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { return !nilp( search( key, store, true ) ); } + +/** + * @prief: bootstap layer assoc; Lisp calling signature. + * + * @return a pointer to the value of the key in the store, or nil if not found + */ +struct pso_pointer assoc( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_assoc( key, store ); +} + +/** + * @prief: bootstap layer interned; Lisp calling signature. + * + * @return a pointer to the copy of the key in the store, or nil if not found. + */ +struct pso_pointer interned( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_interned( key, store ); +} + +/** + * @prief: bootstap layer interned?; Lisp calling signature. + * + * @return `t` if a pointer to a copy of `key` is found in the store, or `nil` if not found. + */ +struct pso_pointer internedp( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer key = fetch_arg( frame, 0 ); + struct pso_pointer store = fetch_arg( frame, 1 ); + + return c_interned( key, store ); +} \ No newline at end of file diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index 52d8d08..ab59c40 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -16,13 +16,13 @@ #include "memory/pointer.h" -struct cons_pointer search( struct pso_pointer key, +struct pso_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 c_assoc( struct pso_pointer key, struct pso_pointer store ); -struct pso_pointer interned( struct pso_pointer key, +struct pso_pointer c_interned( struct pso_pointer key, struct pso_pointer store ); -bool internedp( struct pso_pointer key, struct pso_pointer store ); +bool c_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 f812c43..75aa476 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -21,14 +21,19 @@ #include "payloads/cons.h" #include "payloads/stack.h" -struct pso_pointer bind( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer bind( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif 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 c_cons( c_cons( key, value ), store ); } struct pso_pointer c_bind( struct pso_pointer key, @@ -37,7 +42,11 @@ struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer result = nil; struct pso_pointer next = make_frame( nil, key, value, store ); inc_ref( next ); - result = bind( next, nil ); + result = bind( +#ifndef MANAGED_POINTER_ONLY + pointer_to_pso4( next), +#endif + next, nil ); dec_ref( next ); return result; diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index d7cdf42..e8e6839 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -15,11 +15,16 @@ #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 ); +struct pso_pointer bind( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index b3789e5..ab8702c 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -16,6 +16,7 @@ #include "memory/tags.h" #include "payloads/cons.h" +#include "payloads/function.h" #include "payloads/integer.h" #include "payloads/stack.h" #include "ops/stack_ops.h" @@ -26,6 +27,8 @@ * * Shallow, cheap equality. * + * Bootstrap function: only knows about character, cons, integer, and + * string-like-thing 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! * @@ -53,8 +56,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { ob->payload.character.character ); break; case CONSTV: - result = ( c_equal( car( a ), car( b ) ) - && c_equal( cdr( a ), cdr( b ) ) ); + result = ( c_equal( c_car( a ), c_car( b ) ) + && c_equal( c_cdr( a ), c_cdr( b ) ) ); break; case INTEGERTV: result = ( oa->payload.integer.value @@ -63,11 +66,11 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { case KEYTV: case STRINGTV: case SYMBOLTV: - while ( result == false && !nilp( a ) && !nilp( b ) ) { + while ( !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 ); + a = c_cdr( a ); + b = c_cdr( b ); } } result = nilp( a ) && nilp( b ); @@ -86,14 +89,17 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { * * * (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 eq( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer eq( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif struct pso_pointer result = t; @@ -108,3 +114,30 @@ struct pso_pointer eq( struct pso_pointer frame_pointer, return result; } + + +/** + * Function; do all arguments to this finction point to the same object? + * + * Deep, expensive equality. Bootstrap version: only knows + * * cons cells + * * integers + * * keywords + * * symbols + * * strings + * + * * (equal? arg1 qrg2) + * + * @return `t` if all args are pointers to the same object, else `nil`; + */ +struct pso_pointer equal( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, struct pso_pointer env) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif + return c_equal( fetch_arg( frame, 0), fetch_arg( frame, 1)) ? t : nil; +} diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 854e40c..90885c5 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -16,10 +16,30 @@ #include "memory/pointer.h" #include "memory/pso4.h" +#include "payloads/function.h" + bool c_eq( struct pso_pointer a, struct pso_pointer b ); struct pso_pointer eq( struct pso_pointer frame_pointer, struct pso_pointer env ); bool c_equal( struct pso_pointer a, struct pso_pointer b ); + +struct pso_pointer eq( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + +struct pso_pointer equal( +#ifndef MANAGED_POINTER_ONLY + struct pso4 * frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env +); + + #endif diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 5f59004..f4385e5 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -39,13 +39,14 @@ struct pso_pointer reverse( struct pso_pointer sequence ) { struct pso_pointer result = nil; for ( struct pso_pointer cursor = sequence; !nilp( sequence ); - cursor = cdr( cursor ) ) { + cursor = c_cdr( cursor ) ) { struct pso2 *object = pointer_to_object( cursor ); switch ( get_tag_value( cursor ) ) { case CONSTV: - result = cons( car( cursor ), result ); + result = c_cons( c_car( cursor ), result ); break; case KEYTV: + // TODO: should you be able to reverse keywords and symbols? result = make_string_like_thing( object->payload.string.character, result, KEYTAG ); @@ -56,6 +57,7 @@ struct pso_pointer reverse( struct pso_pointer sequence ) { result, STRINGTAG ); break; case SYMBOLTV: + // TODO: should you be able to reverse keywords and symbols? result = make_string_like_thing( object->payload.string.character, result, SYMBOLTAG ); diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 607cca4..5e8a4ea 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -19,6 +19,7 @@ #include "payloads/cons.h" #include "payloads/exception.h" +#include "ops/stack_ops.h" #include "ops/string_ops.h" /** @@ -29,7 +30,7 @@ * @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 c_cons( struct pso_pointer car, struct pso_pointer cdr ) { struct pso_pointer result = allocate( CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); @@ -47,7 +48,7 @@ struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ) { * @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 c_car( struct pso_pointer cons ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); @@ -66,7 +67,7 @@ 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 p ) { +struct pso_pointer c_cdr( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( result ); @@ -81,7 +82,7 @@ struct pso_pointer cdr( struct pso_pointer p ) { break; default: result = - make_exception( cons + make_exception( c_cons ( c_string_to_lisp_string ( L"Invalid type for cdr" ), p ), nil, nil ); break; @@ -104,7 +105,7 @@ struct pso_pointer destroy_cons( struct pso_pointer fp, 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 ) ); + dec_ref( c_car( p ) ); + dec_ref( c_cdr( p ) ); } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 9ba768f..c7dd21c 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -26,11 +26,11 @@ struct cons_payload { struct pso_pointer cdr; }; -struct pso_pointer car( struct pso_pointer cons ); +struct pso_pointer c_car( struct pso_pointer cons ); -struct pso_pointer cdr( struct pso_pointer cons ); +struct pso_pointer c_cdr( struct pso_pointer cons ); -struct pso_pointer cons( struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index ea54051..94bbb61 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -13,29 +13,43 @@ #include "memory/pointer.h" #include "memory/pso4.h" +/** + * I don't think it's necessary to pass both an unmanaged and a managed + * frame pointer into a function, but it may prove to be more efficient to do + * so. For the present we'll assume not. See state of play for 15042026. + */ +#define MANAGED_POINTER_ONLY TRUE + /** * @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). + * pointer to metadata (e.g. the source from which the function was compiled, + * something to help estimate the cost of the function?). */ 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! + +#ifdef MANAGED_POINTER_ONLY + /** + * pointer to a C function which takes a managed pointer to the same stack + * frame and a managed pointer to the environment as arguments. Arguments + * to the Lisp function are assumed to be loaded into the frame before + * invocation. */ - struct pso_pointer ( *executable ) ( struct pso4 *, - struct pso_pointer, - struct pso_pointer ); + struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer, + struct pso_pointer env ); +#else + /** + * pointer to a C function which takes an unmanaged pointer to a stack frame, + * a managed pointer to the same stack frame, and a managed pointer to the + * environment as arguments. Arguments to the Lisp function are assumed to be + * loaded into the frame before invocation. + */ + struct pso_pointer ( *executable ) ( struct pso4 * frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ); +#endif }; #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index a75037b..8a4bdbe 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -38,7 +38,7 @@ struct pso_pointer destroy_string( struct pso_pointer fp, struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( cdr( p ) ); + dec_ref( c_cdr( p ) ); } return nil; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index a0591ab..70abaa3 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -18,6 +18,8 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "payloads/cons.h" + /** * @brief Construct a stack frame with this `previous` pointer, and arguments * taken from the remaining arguments to this function, which should all be @@ -50,7 +52,7 @@ struct pso_pointer make_frame( struct pso_pointer previous, ... ) { struct pso_pointer more_args = nil; for ( ; cursor < count; cursor++ ) { - more_args = cons( va_arg( args, struct pso_pointer ), more_args ); + more_args = c_cons( va_arg( args, struct pso_pointer ), more_args ); } // should be frame->payload.stack_frame.more = reverse( more_args), but @@ -83,7 +85,7 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( casualty->payload.stack_frame.more ); for ( int i = 0; i < args_in_frame; i++ ) { - dec_ref( casualty->payload.stack_frame.arg[0] ); + dec_ref( casualty->payload.stack_frame.arg[i] ); } casualty->payload.stack_frame.args = 0; From f751fc8a09573b7960bd1e5c757694d22a88dc6a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Apr 2026 22:47:44 +0100 Subject: [PATCH 28/77] More code, closer to working, still builds. --- src/c/environment/environment.c | 55 +++++++++++++++++++++--- src/c/io/io.c | 4 +- src/c/memory/memory.c | 15 ++++++- src/c/memory/node.c | 6 +-- src/c/ops/assoc.c | 26 ++++++----- src/c/ops/assoc.h | 4 +- src/c/ops/bind.c | 13 +++--- src/c/ops/bind.h | 10 ++--- src/c/ops/eq.c | 20 +++++---- src/c/ops/eq.h | 18 ++++---- src/c/ops/eval.c | 76 --------------------------------- src/c/ops/string_ops.c | 19 +++++++++ src/c/ops/string_ops.h | 2 + src/c/payloads/stack.c | 3 +- 14 files changed, 138 insertions(+), 133 deletions(-) delete mode 100644 src/c/ops/eval.c diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index cf512c4..28c453f 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -9,8 +9,19 @@ #include +#include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/bind.h" +#include "ops/string_ops.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/psse_string.h" /** * @brief Flag to prevent re-initialisation. @@ -25,11 +36,45 @@ bool environment_initialised = false; */ 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. + struct pso_pointer result = initialise_memory( node ); + + if ( !exceptionp( result ) ) { + struct pso_pointer n = allocate( NILTAG, 2 ); + + if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { + struct pso2 *object = pointer_to_object( n ); + object->payload.cons.car = nil; + object->payload.cons.cdr = nil; + + nil = n; + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Unexpected cell while allocating `nil`." ), + nil, n ); + } + } + if ( !exceptionp( result ) ) { + struct pso_pointer n = allocate( TRUETAG, 2 ); + + if ( ( n.page == 0 ) && ( n.offset == 1 ) ) { + struct pso2 *object = pointer_to_object( n ); + object->payload.string.character = L't'; + object->payload.cons.cdr = t; + + t = n; + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Unexpected cell while allocating `t`." ), + nil, n ); + } + } + if ( !exceptionp( result ) ) { + result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); + result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); + + environment_initialised = true; } return result; diff --git a/src/c/io/io.c b/src/c/io/io.c index 3f31d2c..2a897f7 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -329,7 +329,7 @@ struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, long int value ) { return c_cons( c_cons( c_string_to_lisp_keyword( key ), - make_integer( value ) ), meta ); + make_integer( value ) ), meta ); } struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, @@ -339,7 +339,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, mbstowcs( buffer, value, strlen( value ) + 1 ); return c_cons( c_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, diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index ca41d67..6d48334 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -13,6 +13,14 @@ #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/exception.h" + +#include "ops/bind.h" +#include "ops/string_ops.h" /** * @brief Freelists for each size class. @@ -24,6 +32,7 @@ struct pso_pointer freelists[MAX_SIZE_CLASS]; */ bool memory_initialised = false; + /** * @brief Initialise the memory allocation system. * @@ -34,8 +43,12 @@ bool memory_initialised = false; * @return int */ struct pso_pointer initialise_memory( uint32_t node ) { + struct pso_pointer result = nil; if ( memory_initialised ) { - // TODO: throw an exception + result = + make_exception( c_string_to_lisp_string + ( L"Attenpt to reinitialise environment" ), nil, + nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 2a650a0..5c70ec5 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -55,11 +55,7 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 }; struct pso_pointer initialise_node( uint32_t index ) { node_index = index; - struct pso_pointer result = initialise_memory( index ); - - if ( c_eq( result, t ) ) { - result = initialise_environment( index ); - } + struct pso_pointer result = initialise_environment( index ); return result; } diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 004fa3e..fb63afc 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -74,7 +74,8 @@ struct pso_pointer c_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 c_interned( struct pso_pointer key, struct pso_pointer store ) { +struct pso_pointer c_interned( struct pso_pointer key, + struct pso_pointer store ) { return search( key, store, true ); } @@ -95,11 +96,12 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { * * @return a pointer to the value of the key in the store, or nil if not found */ -struct pso_pointer assoc( +struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -114,11 +116,12 @@ struct pso_pointer assoc( * * @return a pointer to the copy of the key in the store, or nil if not found. */ -struct pso_pointer interned( +struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -133,11 +136,12 @@ struct pso_pointer interned( * * @return `t` if a pointer to a copy of `key` is found in the store, or `nil` if not found. */ -struct pso_pointer internedp( +struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -145,4 +149,4 @@ struct pso_pointer internedp( struct pso_pointer store = fetch_arg( frame, 1 ); return c_interned( key, store ); -} \ No newline at end of file +} diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index ab59c40..746a6ea 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -17,12 +17,12 @@ #include "memory/pointer.h" struct pso_pointer search( struct pso_pointer key, - struct pso_pointer store, bool return_key ); + struct pso_pointer store, bool return_key ); struct pso_pointer c_assoc( struct pso_pointer key, struct pso_pointer store ); struct pso_pointer c_interned( struct pso_pointer key, - struct pso_pointer store ); + struct pso_pointer store ); bool c_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 75aa476..799c418 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -21,11 +21,12 @@ #include "payloads/cons.h" #include "payloads/stack.h" -struct pso_pointer bind( +struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -42,11 +43,11 @@ struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer result = nil; struct pso_pointer next = make_frame( nil, key, value, store ); inc_ref( next ); - result = bind( + result = lisp_bind( #ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( next), + pointer_to_pso4( next ), #endif - next, nil ); + next, nil ); dec_ref( next ); return result; diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index e8e6839..f2a799f 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -14,17 +14,17 @@ #include #include "memory/pointer.h" +#include "memory/pso4.h" struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ); -struct pso_pointer bind( +struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index ab8702c..d5b348e 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -91,14 +91,15 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { * * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer eq( +struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); - + #endif struct pso_pointer result = t; @@ -130,14 +131,15 @@ struct pso_pointer eq( * * @return `t` if all args are pointers to the same object, else `nil`; */ -struct pso_pointer equal( +struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, struct pso_pointer env) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); - + #endif - return c_equal( fetch_arg( frame, 0), fetch_arg( frame, 1)) ? t : nil; + return c_equal( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ) ? t : nil; } diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 90885c5..a669a10 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -25,21 +25,19 @@ struct pso_pointer eq( struct pso_pointer frame_pointer, bool c_equal( struct pso_pointer a, struct pso_pointer b ); -struct pso_pointer eq( +struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); -struct pso_pointer equal( +struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY - struct pso4 * frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env -); + struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/ops/eval.c b/src/c/ops/eval.c deleted file mode 100644 index 830cceb..0000000 --- a/src/c/ops/eval.c +++ /dev/null @@ -1,76 +0,0 @@ -/** - * 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.h" -#include "memory/pso.h" -#include "memory/pso2.h" -#include "memory/pso3.h" -#include "memory/pso4.h" -#include "memory/tags.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" - -#include "ops/truth.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 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)) { - // 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; - // } - - if ( exceptionp( result ) ) { - 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/string_ops.c b/src/c/ops/string_ops.c index 14d12a3..0f6741a 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -145,6 +145,25 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { return result; } + +/** + * Return a lisp symbol representation of this wide character string. In + * symbols, I am accepting only lower case characters. + */ +struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { + struct pso_pointer result = nil; + + for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { + wchar_t c = towlower( symbol[i] ); + + if ( iswalpha( c ) || c == L'-' ) { + result = make_symbol( c, result ); + } + } + + return result; +} + /** * Return a lisp keyword representation of this wide character string. In * keywords, I am accepting only lower case characters and numbers. diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 59ce837..e80692e 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -29,4 +29,6 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ); struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ); +struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ); + #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 70abaa3..3f144df 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -52,7 +52,8 @@ struct pso_pointer make_frame( struct pso_pointer previous, ... ) { struct pso_pointer more_args = nil; for ( ; cursor < count; cursor++ ) { - more_args = c_cons( va_arg( args, struct pso_pointer ), more_args ); + more_args = + c_cons( va_arg( args, struct pso_pointer ), more_args ); } // should be frame->payload.stack_frame.more = reverse( more_args), but From 25c87aac6ed686ae59d07bb610439ed359f00ecd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 00:22:24 +0100 Subject: [PATCH 29/77] Added debug messages to initialisation functions, but getting a segfault. Not going to debug that tonight! --- src/c/environment/environment.c | 8 ++++++++ src/c/memory/memory.c | 7 ++++++- src/c/memory/page.c | 6 ++++++ src/c/memory/pso.c | 9 +++++++++ 4 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 28c453f..1c8ad1b 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -9,6 +9,8 @@ #include +#include "debug.h" + #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -39,6 +41,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); if ( !exceptionp( result ) ) { + debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0); struct pso_pointer n = allocate( NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { @@ -47,14 +50,17 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = nil; nil = n; + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `nil`." ), nil, n ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); } } if ( !exceptionp( result ) ) { + debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0); struct pso_pointer n = allocate( TRUETAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 1 ) ) { @@ -63,11 +69,13 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = t; t = n; + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `t`." ), nil, n ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); } } if ( !exceptionp( result ) ) { diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 6d48334..fa49bf1 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -10,6 +10,8 @@ #include #include +#include "debug.h" + #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -47,12 +49,15 @@ struct pso_pointer initialise_memory( uint32_t node ) { if ( memory_initialised ) { result = make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise environment" ), nil, + ( L"Attenpt to reinitialise memory." ), nil, nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; } +#ifdef DEBUG + debug_print(L"Memory initialised", DEBUG_BOOTSTRAP, 0); +#endif memory_initialised = true; } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 60771b4..74ae5c7 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -68,6 +68,10 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, int obj_bytes = obj_size * sizeof( uint64_t ); int objs_in_page = PAGE_BYTES / obj_bytes; + debug_printf(DEBUG_ALLOC, 0, + L"Initialising page %d for objects of size class %d...", + page_index, size_class); + // 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`. @@ -86,6 +90,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, ( uint16_t ) ( i * obj_size ) ); } + debug_print( L"page allocated.\n", DEBUG_ALLOC, 0); + return result; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 7409e51..16ded6e 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" @@ -39,6 +40,10 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { struct pso_pointer result = nil; +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, L"Allocating object of size class %d with tag `%s`... ", size_class, tag); +#endif + if ( size_class <= MAX_SIZE_CLASS ) { if ( nilp( freelists[size_class] ) ) { result = allocate_page( size_class ); @@ -66,6 +71,10 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { } } // TODO: else throw exception +#ifdef DEBUG + debug_print(exceptionp(result)? L"fail\n" : L"success\n", DEBUG_ALLOC, 0); +#endif + return result; } From 04aa32bd5af36d48cb3f8d21f1474b9d7f5b490e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 00:24:03 +0100 Subject: [PATCH 30/77] Whoops! several new files missed from recent commits. --- src/c/ops/eval_apply.c | 106 +++++++++++++++++++++++++++++++++++++++++ src/c/ops/eval_apply.h | 36 ++++++++++++++ src/c/ops/list_ops.c | 72 ++++++++++++++++++++++++++++ src/c/ops/list_ops.h | 39 +++++++++++++++ 4 files changed, 253 insertions(+) create mode 100644 src/c/ops/eval_apply.c create mode 100644 src/c/ops/eval_apply.h create mode 100644 src/c/ops/list_ops.c create mode 100644 src/c/ops/list_ops.h diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c new file mode 100644 index 0000000..b46aa99 --- /dev/null +++ b/src/c/ops/eval_apply.c @@ -0,0 +1,106 @@ +/** + * ops/apply.c + * + * Post Scarcity Software Environment: apply. + * + * Add a applying 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/pso3.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "ops/assoc.h" +#include "ops/stack_ops.h" +#include "ops/string_ops.h" +#include "ops/truth.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + +/** + * @brief Apply a function to arguments in an environment. + * + * * (apply fn args) + */ +struct pso_pointer apply( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + +// TODO. + +} + +/** + * @brief Evaluate a form, in an environment + * + * * (eval form) + */ +struct pso_pointer eval( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + struct pso_pointer result = fetch_arg( frame, 0 ); + + switch ( get_tag_value( result ) ) { + // case CONSTV: + // result = eval_cons( frame, frame_pointer, env); + // break; + case INTEGERTV: + case KEYTV: + case STRINGTV: + // self evaluating + break; + case SYMBOLTV: + result = c_assoc( result, 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; + default: + result = + make_exception( c_cons + ( c_string_to_lisp_string + ( L"Can't yet evaluate things of this type: " ), + result ), frame_pointer, nil ); + } + + if ( exceptionp( result ) ) { + 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/eval_apply.h b/src/c/ops/eval_apply.h new file mode 100644 index 0000000..18b0f01 --- /dev/null +++ b/src/c/ops/eval_apply.h @@ -0,0 +1,36 @@ +/** + * ops/eval_apply.h + * + * Post Scarcity Software Environment: eval, apply. + * + * apply: Apply a function to arguments in an environment. + * eval: Evaluate a form in an environment. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_eval_apply_h +#define __psse_ops_eval_apply_h + +#include "memory/pointer.h" +#include "memory/pso4.h" +#include "payloads/function.h" + +struct pso_pointer apply( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + + +struct pso_pointer eval( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + + +#endif diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c new file mode 100644 index 0000000..10ccc60 --- /dev/null +++ b/src/c/ops/list_ops.c @@ -0,0 +1,72 @@ +/** + * ops/list_ops.h + * + * Post Scarcity Software Environment: list_ops. + * + * Operations on cons cells. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_list_ops_h +#define __psse_ops_list_ops_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 car( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + return c_car( fetch_arg( frame, 0 ) ); +} + +struct pso_pointer cdr( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); +#endif + return c_cdr( fetch_arg( frame, 0 ) ); +} + +/** + * @brief allocate a cons cell from the first two args in this frame, and + * return a pointer to it. + * + * Lisp calling conventions. + * + * @return struct pso_pointer a pointer to the newly allocated cons cell. + */ + +struct pso_pointer cons( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ) { +#ifdef MANAGED_POINTER_ONLY + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + +#endif + return c_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); +} + +#endif diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h new file mode 100644 index 0000000..ae770cd --- /dev/null +++ b/src/c/ops/list_ops.h @@ -0,0 +1,39 @@ +/** + * ops/list_ops.h + * + * Post Scarcity Software Environment: list_ops. + * + * Operations on cons cells. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_list_ops_h +#define __psse_ops_list_ops_h + +#include "memory/pointer.h" +#include "memory/pso4.h" + +struct pso_pointer car( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer cdr( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +struct pso_pointer cons( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + struct pso_pointer frame_pointer, + struct pso_pointer env ); + +#endif From cb3dcb352e5bc564248cad8c010b82aa98816e7d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 12:34:47 +0100 Subject: [PATCH 31/77] OK, the problem is that make_frame fails to put the arguments into the frame. I do not (yet) know why not, but that is the problem. --- src/c/environment/environment.c | 3 +++ src/c/memory/node.c | 5 +++-- src/c/memory/page.c | 2 +- src/c/memory/pso.c | 14 +++++++++++--- src/c/ops/string_ops.c | 2 +- src/c/ops/truth.c | 5 ++++- 6 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 8dbbc1f..8dec0f3 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -52,6 +52,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = nil; nil = n; + lock_object( nil); debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = @@ -72,6 +73,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = t; t = n; + lock_object(t); debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); } else { result = @@ -86,6 +88,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); environment_initialised = true; + debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0); } return result; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 5c70ec5..4cc9db0 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -41,9 +41,10 @@ struct pso_pointer nil = ( struct pso_pointer ) { 0, 0, 0 }; /** * @brief the canonical `t` (true) pointer. - * + * Offset 4, because `t` should be the second pso2 allocated, the offset is + * given in words, and the size of a pso2 should be four words. */ -struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 1 }; +struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 }; /** diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 9a90e8e..4b27abc 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -287,7 +287,7 @@ struct pso_pointer allocate_page( uint8_t size_class ) { 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", + L"\nAllocated page %d for objects of size class %x.\n", npages_allocated, size_class ); freelists[size_class] = diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 0b336ed..3daa4a9 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -15,6 +15,7 @@ */ #include +#include #include #include "debug.h" @@ -38,7 +39,8 @@ * @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; + // `t`, because if `allocate_page` fails it will be set to `nil`. + struct pso_pointer result = t; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"Allocating object of size class %d with tag `%s`... ", size_class, tag); @@ -49,7 +51,14 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { result = allocate_page( size_class ); } - if ( !exceptionp( result ) ) { + if (nilp(result)) { + fputws( L"FATAL: Page space exhausted\n", stderr ); + exit(1); // TODO: we don't want to do this! Somehow, we need to + // recover a workable environment, ideally by throwing a pre-made + // exception. + } + + if ( !exceptionp( result ) && !nilp(result)) { result = freelists[size_class]; struct pso2 *object = pointer_to_object( result ); freelists[size_class] = object->payload.free.next; @@ -69,7 +78,6 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { if ( object->header.count != 0 ) { // TODO: return an exception instead? Or warn, set it, and continue? } - } } // TODO: else throw exception diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 0070be9..cb82abe 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -127,7 +127,7 @@ struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) { * @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 make_string_like_thing( c, tail, SYMBOLTAG ); } diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 8ffb2f5..7b0eb76 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -49,12 +49,15 @@ bool not( struct pso_pointer p ) { * each is considered equivalent. So we don't check the node when considering * whether `nil` really is `nil`, or `t` really is `t`. * + * Note that the offset is 4 because `t` should be the second pso2 allocated, + * the offset is given in words, and the size of a pso2 should be four words + * * @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 ); + return ( p.page == 0 && p.offset == 4 ); } /** From f915a9993f340f6641a170c247b9b53c15755a73 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 17:13:20 +0100 Subject: [PATCH 32/77] Fixed assigning arguments to slots in the frame; also fixed a bug in bind... But did that by switching away from using Lisp calling convention, because that broke horribly. This is bad news and must be sorted out. --- src/c/environment/environment.c | 19 ++--- src/c/io/io.c | 12 ++-- src/c/io/read.c | 4 +- src/c/memory/destroy.c | 2 +- src/c/memory/memory.c | 5 +- src/c/memory/page.c | 120 ++++++++++++++++++++------------ src/c/memory/pso.c | 27 ++++--- src/c/ops/bind.c | 18 ++--- src/c/ops/bind.h | 6 +- src/c/ops/reverse.c | 2 +- src/c/ops/reverse.h | 2 +- src/c/ops/string_ops.c | 4 +- src/c/payloads/stack.c | 46 ++++++++---- src/c/payloads/stack.h | 3 +- 14 files changed, 158 insertions(+), 112 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 8dec0f3..fea9f13 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -43,7 +43,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); if ( truep( result ) ) { - debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0); + debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { @@ -52,18 +52,18 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = nil; nil = n; - lock_object( nil); - debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); + lock_object( nil ); + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `nil`." ), nil, n ); - debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !exceptionp( result ) ) { - debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0); + debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words @@ -73,14 +73,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { object->payload.cons.cdr = t; t = n; - lock_object(t); - debug_print( L"success\n", DEBUG_BOOTSTRAP, 0); + lock_object( t ); + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `t`." ), nil, n ); - debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !exceptionp( result ) ) { @@ -88,7 +88,8 @@ struct pso_pointer initialise_environment( uint32_t node ) { result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); environment_initialised = true; - debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0); + debug_print( L"\nEnvironment initialised successfully.\n", + DEBUG_BOOTSTRAP, 0 ); } return result; diff --git a/src/c/io/io.c b/src/c/io/io.c index 2a897f7..6b61591 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -286,8 +286,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload. - character.character ), + ( pointer_to_object( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -315,8 +315,8 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( url_fclose - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. - stream ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ) == 0 ) { result = t; } @@ -569,8 +569,8 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) ) { result = make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0 ) )-> - payload.stream.stream ), nil ); + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ), nil ); } return result; diff --git a/src/c/io/read.c b/src/c/io/read.c index f49368d..f072a6d 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -146,7 +146,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer, } url_ungetwc( c, input ); - result = reverse( result ); + result = c_reverse( result ); } return result; @@ -208,7 +208,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer, break; default: struct pso_pointer next = - make_frame( frame_pointer, stream, readtable, + make_frame( 3, frame_pointer, stream, readtable, make_character( c ) ); inc_ref( next ); if ( iswdigit( c ) ) { diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c index 01e493d..d8c0db4 100644 --- a/src/c/memory/destroy.c +++ b/src/c/memory/destroy.c @@ -39,7 +39,7 @@ */ struct pso_pointer destroy( struct pso_pointer p ) { struct pso_pointer result = nil; - struct pso_pointer f = make_frame( nil, p ); + struct pso_pointer f = make_frame( 1, nil, p ); inc_ref( f ); switch ( get_tag_value( p ) ) { diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index fa49bf1..f88a9d6 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -49,14 +49,13 @@ struct pso_pointer initialise_memory( uint32_t node ) { if ( memory_initialised ) { result = make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise memory." ), nil, - nil ); + ( L"Attenpt to reinitialise memory." ), nil, nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; } #ifdef DEBUG - debug_print(L"Memory initialised", DEBUG_BOOTSTRAP, 0); + debug_print( L"Memory initialised", DEBUG_BOOTSTRAP, 0 ); #endif memory_initialised = true; } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 4b27abc..0b03b35 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -58,9 +58,10 @@ uint32_t npages_allocated = 0; * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso2_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso2_array( 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 ); @@ -70,8 +71,7 @@ struct pso_pointer initialise_pso2_array(union page *page_addr, uint16_t page_in // 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-- ) { - struct pso2 *object = - ( struct pso2 * ) &page_addr->pso2s[i]; + struct pso2 *object = ( struct pso2 * ) &page_addr->pso2s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -84,22 +84,23 @@ struct pso_pointer initialise_pso2_array(union page *page_addr, uint16_t page_in return result; } + /** * Initialise arrays for objects of different size classes, in this case class 3. * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso3_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso3_array( 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; for ( int i = objs_in_page - 1; i >= 0; i-- ) { - struct pso3 *object = - ( struct pso3 * ) &page_addr->pso3s[i]; + struct pso3 *object = ( struct pso3 * ) &page_addr->pso3s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -112,22 +113,23 @@ struct pso_pointer initialise_pso3_array(union page *page_addr, uint16_t page_in return result; } + /** * Initialise arrays for objects of different size classes, in this case class 4. * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso4_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso4_array( 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; for ( int i = objs_in_page - 1; i >= 0; i-- ) { - struct pso4 *object = - ( struct pso4 * ) &page_addr->pso4s[i]; + struct pso4 *object = ( struct pso4 * ) &page_addr->pso4s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -140,22 +142,23 @@ struct pso_pointer initialise_pso4_array(union page *page_addr, uint16_t page_in return result; } + /** * Initialise arrays for objects of different size classes, in this case class 5. * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso5_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso5_array( 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; for ( int i = objs_in_page - 1; i >= 0; i-- ) { - struct pso5 *object = - ( struct pso5 * ) &page_addr->pso5s[i]; + struct pso5 *object = ( struct pso5 * ) &page_addr->pso5s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -168,22 +171,23 @@ struct pso_pointer initialise_pso5_array(union page *page_addr, uint16_t page_in return result; } + /** * Initialise arrays for objects of different size classes, in this case class 6. * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso6_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso6_array( 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; for ( int i = objs_in_page - 1; i >= 0; i-- ) { - struct pso6 *object = - ( struct pso6 * ) &page_addr->pso6s[i]; + struct pso6 *object = ( struct pso6 * ) &page_addr->pso6s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -196,22 +200,23 @@ struct pso_pointer initialise_pso6_array(union page *page_addr, uint16_t page_in return result; } + /** * Initialise arrays for objects of different size classes, in this case class 7. * This is boilerplate code and there must be some way of doing it better, but I don't * know it. Macro? */ -struct pso_pointer initialise_pso7_array(union page *page_addr, uint16_t page_index, - uint8_t size_class, - struct pso_pointer freelist ) { +struct pso_pointer initialise_pso7_array( 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; for ( int i = objs_in_page - 1; i >= 0; i-- ) { - struct pso7 *object = - ( struct pso7 * ) &page_addr->pso7s[i]; + struct pso7 *object = ( struct pso7 * ) &page_addr->pso7s[i]; object->header.tag.bytes.size_class = size_class; strncpy( &( object->header.tag.bytes.mnemonic[0] ), FREETAG, TAGLENGTH ); @@ -237,27 +242,51 @@ struct pso_pointer initialise_pso7_array(union page *page_addr, uint16_t page_in 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 = nil; + struct pso_pointer result = nil; int obj_size = pow( 2, size_class ); int obj_bytes = obj_size * sizeof( uint64_t ); int objs_in_page = PAGE_BYTES / obj_bytes; - debug_printf(DEBUG_ALLOC, 0, - L"Initialising page %d for objects of size class %d...", - page_index, size_class); + debug_printf( DEBUG_ALLOC, 0, + L"Initialising page %d for objects of size class %d...", + page_index, size_class ); - switch (size_class) { - case 2: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - case 3: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - case 4: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - case 5: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - case 6: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - case 7: result=initialise_pso2_array(page_addr, page_index, size_class, freelist); break; - default: - result = nil; + switch ( size_class ) { + case 2: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + case 3: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + case 4: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + case 5: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + case 6: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + case 7: + result = + initialise_pso2_array( page_addr, page_index, size_class, + freelist ); + break; + default: + result = nil; } - debug_print( nilp(result)? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0); + debug_print( nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0 ); return result; } @@ -299,7 +328,8 @@ struct pso_pointer allocate_page( uint8_t size_class ) { debug_printf( DEBUG_ALLOC, 0, L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n", npages_allocated, size_class, - freelists[size_class].page, freelists[size_class].offset); + freelists[size_class].page, + freelists[size_class].offset ); npages_allocated++; } else { diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 3daa4a9..c925906 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -39,11 +39,13 @@ * @return struct pso_pointer a pointer to the newly allocated object */ struct pso_pointer allocate( char *tag, uint8_t size_class ) { - // `t`, because if `allocate_page` fails it will be set to `nil`. + // `t`, because if `allocate_page` fails it will be set to `nil`. struct pso_pointer result = t; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, L"Allocating object of size class %d with tag `%s`... ", size_class, tag); + debug_printf( DEBUG_ALLOC, 0, + L"Allocating object of size class %d with tag `%s`... ", + size_class, tag ); #endif if ( size_class <= MAX_SIZE_CLASS ) { @@ -51,14 +53,14 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { result = allocate_page( size_class ); } - if (nilp(result)) { - fputws( L"FATAL: Page space exhausted\n", stderr ); - exit(1); // TODO: we don't want to do this! Somehow, we need to - // recover a workable environment, ideally by throwing a pre-made - // exception. + if ( nilp( result ) ) { + fputws( L"FATAL: Page space exhausted\n", stderr ); + exit( 1 ); // TODO: we don't want to do this! Somehow, we need to + // recover a workable environment, ideally by throwing a pre-made + // exception. } - if ( !exceptionp( result ) && !nilp(result)) { + if ( !exceptionp( result ) && !nilp( result ) ) { result = freelists[size_class]; struct pso2 *object = pointer_to_object( result ); freelists[size_class] = object->payload.free.next; @@ -66,7 +68,8 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset); + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", + result.page, result.offset ); /* the object ought already to have the right size class in its tag * because it was popped off the freelist for that size class. */ @@ -82,7 +85,8 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { } // TODO: else throw exception #ifdef DEBUG - debug_print(exceptionp(result)? L"fail\n" : L"success\n", DEBUG_ALLOC, 0); + debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, + 0 ); #endif return result; @@ -137,7 +141,8 @@ 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 ( !nilp(pointer) && object->header.count > 0 && object->header.count != MAXREFERENCE ) { + if ( !nilp( pointer ) && object->header.count > 0 + && object->header.count != MAXREFERENCE ) { object->header.count--; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 799c418..ba25834 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -23,10 +23,10 @@ struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer, + struct pso_pointer env ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -40,15 +40,5 @@ struct pso_pointer lisp_bind( 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 = lisp_bind( -#ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( next ), -#endif - next, nil ); - dec_ref( next ); - - return result; + return c_cons( c_cons( key, value ), store ); } diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index f2a799f..517086a 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -22,9 +22,9 @@ struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer lisp_bind( #ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, + struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer, + struct pso_pointer env ); #endif diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index f4385e5..c5fa7e0 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -35,7 +35,7 @@ * @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 c_reverse( struct pso_pointer sequence ) { struct pso_pointer result = nil; for ( struct pso_pointer cursor = sequence; !nilp( sequence ); diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h index 96f6b2f..5519523 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 c_reverse( struct pso_pointer sequence ); #endif diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index cb82abe..b4dc31c 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -73,7 +73,7 @@ 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 ) || nilp(tail) ) { + if ( check_type( tail, tag ) || nilp( tail ) ) { pointer = allocate( tag, CONS_SIZE_CLASS ); struct pso2 *cell = pointer_to_object( pointer ); @@ -85,7 +85,7 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, debug_println( DEBUG_ALLOC ); } else { // \todo should throw an exception! - struct pso2* tobj = pointer_to_object( tail); + struct pso2 *tobj = pointer_to_object( tail ); debug_printf( DEBUG_ALLOC, 0, L"Warning: %3.3s cannot be prepended to %3.3s\n", tag, tobj->header.tag.bytes.mnemonic ); diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index f342d92..0d81c20 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -11,6 +11,8 @@ #include +#include "debug.h" + #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -20,6 +22,8 @@ #include "payloads/cons.h" +#include "ops/reverse.h" + /** * @brief Construct a stack frame with this `previous` pointer, and arguments * taken from the remaining arguments to this function, which should all be @@ -27,44 +31,60 @@ * * @return a pso_pointer to the stack frame. */ -struct pso_pointer make_frame( struct pso_pointer previous, ... ) { +struct pso_pointer make_frame( int arg_count, 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 ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"\nAllocating stack frame with %d arguments at page %d, " + L"offset %d...\n", + arg_count, frame_pointer.page, frame_pointer.offset ); +#endif + 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; + if ( stackp( previous ) ) { + struct pso4 *op = pointer_to_pso4( previous ); + frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; + } else { + frame->payload.stack_frame.depth = 0; + } - for ( ; cursor < count && cursor < args_in_frame; cursor++ ) { + debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", + frame->payload.stack_frame.depth ); + + int cursor = 0; + frame->payload.stack_frame.args = arg_count; + + for ( ; cursor < arg_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 ) { + if ( cursor < arg_count ) { struct pso_pointer more_args = nil; - for ( ; cursor < count; cursor++ ) { + for ( ; cursor < arg_count; cursor++ ) { more_args = c_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; + frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { frame->payload.stack_frame.arg[cursor] = nil; } } + debug_printf( DEBUG_ALLOC, 1, + L"Allocation of frame at page %d, offset %d completed.\n", + frame_pointer.page, frame_pointer.offset ); + return frame_pointer; } diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 7333809..3cbb853 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -37,7 +37,8 @@ struct stack_frame_payload { uint32_t depth; }; -struct pso_pointer make_frame( struct pso_pointer previous, ... ); +struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, + ... ); struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); From 83537391a63b7bca9a3c756e6e265024b1d04b79 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 21:33:48 +0100 Subject: [PATCH 33/77] Written the constructor for exceptions; in the process, added a metadata slot as a first class slot of exceptions. --- .gitignore | 1 + src/c/environment/environment.c | 4 ++-- src/c/memory/memory.c | 2 +- src/c/memory/tags.c | 20 ++++++++++++++++ src/c/memory/tags.h | 7 ++++-- src/c/ops/eval_apply.c | 7 +++--- src/c/ops/reverse.c | 6 ++--- src/c/ops/string_ops.c | 2 ++ src/c/payloads/cons.c | 8 ++++--- src/c/payloads/exception.c | 41 +++++++++++++++++++++++++++++---- src/c/payloads/exception.h | 7 ++++-- 11 files changed, 85 insertions(+), 20 deletions(-) diff --git a/.gitignore b/.gitignore index a9d1e3e..300398f 100644 --- a/.gitignore +++ b/.gitignore @@ -55,3 +55,4 @@ post-scarcity.kdev4 \.zig-cache/ sq/ tmp/ +utils_src/a.out diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index fea9f13..309818e 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -58,7 +58,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `nil`." ), - nil, n ); + nil, nil, n ); debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } @@ -79,7 +79,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { result = make_exception( c_string_to_lisp_string ( L"Unexpected cell while allocating `t`." ), - nil, n ); + nil, nil, n ); debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index f88a9d6..7a44bc4 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -49,7 +49,7 @@ struct pso_pointer initialise_memory( uint32_t node ) { if ( memory_initialised ) { result = make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise memory." ), nil, nil ); + ( L"Attenpt to reinitialise memory." ), nil, nil, nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 6e4a7c5..a2fc880 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -13,15 +13,35 @@ #include #include +#include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" +#include "ops/string_ops.h" + uint32_t get_tag_value( struct pso_pointer p ) { struct pso2 *object = pointer_to_object( p ); return object->header.tag.value & 0xffffff; } +/** + * @brief Return the tag of the object indicated by this pointer as a Lisp + * string. + * + * @param p must be a struct pso_pointer, indicating the appropriate object. + */ +struct pso_pointer get_tag_string( struct pso_pointer p) { + struct pso_pointer result = nil; + struct pso2 *object = pointer_to_object( p ); + + for ( int i = 2 - 1; i >= 0; i-- ) { + result = make_string( (wchar_t)(object->header.tag.bytes.mnemonic[i]), result ); + } + + return result; +} + /** * @brief check that the tag of the object indicated by this poiner has this * value. diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 524e805..5608c66 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -84,6 +84,8 @@ // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) uint32_t get_tag_value( struct pso_pointer p ); +struct pso_pointer get_tag_string( struct pso_pointer p); + /** * @brief check that the tag of the object indicated by this poiner has this * value. @@ -98,16 +100,17 @@ 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 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)) #define functionp(p) (check_tag(p, FUNCTIONTV)) +#define hashtabp(p) (check_tag(p, HASHTV)) #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)) +#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)) diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index b46aa99..91f47ea 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -86,7 +86,9 @@ struct pso_pointer eval( make_exception( c_cons ( c_string_to_lisp_string ( L"Can't yet evaluate things of this type: " ), - result ), frame_pointer, nil ); + result ), frame_pointer, + c_cons( c_cons( c_string_to_lisp_keyword(L"tag"), + get_tag_string(result)), nil), nil ); } if ( exceptionp( result ) ) { @@ -95,9 +97,8 @@ struct pso_pointer eval( EXCEPTIONTV ); if ( nilp( x->payload.exception.stack ) ) { - inc_ref( result ); result = - make_exception( x->payload.exception.message, frame_pointer, + make_exception( x->payload.exception.message, frame_pointer, nil, result ); } } diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index c5fa7e0..1f44127 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -64,9 +64,9 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) { break; default: result = - make_exception( c_string_to_lisp_string - ( L"Invalid object in sequence" ), nil, - nil ); + make_exception( c_cons( c_string_to_lisp_string + ( L"Invalid object in sequence" ), cursor), nil, + nil , nil); goto exit; break; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index b4dc31c..d00456a 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -182,3 +182,5 @@ struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { return result; } + + diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 5e8a4ea..e1586bf 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -82,9 +82,11 @@ struct pso_pointer c_cdr( struct pso_pointer p ) { break; default: result = - make_exception( c_cons - ( c_string_to_lisp_string - ( L"Invalid type for cdr" ), p ), nil, nil ); + make_exception( + c_cons( + c_string_to_lisp_string( L"Invalid type for cdr" ), + get_tag_string( p) ), + nil, nil, nil ); break; } diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 1b38a76..fa18350 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -11,16 +11,45 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso3.h" #include "memory/pso4.h" #include "memory/tags.h" #include "payloads/exception.h" +#include "ops/truth.h" + +/** + * @brief allocate an exception object, and, if successful, return a pointer + * to it. + * + * Throwing an exception while generating an exception is meaningless. If + * allocation fails utterly (i.e. out of heap, out of page space) this will + * have to return `nil`, which might give rise to hard to trace bugs. But + * otherwise it will return a pointer to a new exception. + * + * @param message expected to be a string, but anything printable is accepted. + * @param frame the stack frame in which the exception was `thrown`, if any. + * @param meta metadata for this exception. Must be an assoc list, hashtable, + * or `nil` + * @param cause the exception that caused this exception to be `thrown`. + */ struct pso_pointer make_exception( struct pso_pointer message, - struct pso_pointer frame_pointer, + struct pso_pointer frame, + struct pso_pointer meta, struct pso_pointer cause ) { - // TODO: not yet implemented - return nil; + struct pso_pointer result = allocate(EXCEPTIONTAG, 3); + + if (!nilp(result) && !exceptionp(result)) { + struct pso3* object = (struct pso3*)pointer_to_object( result); + + object->payload.exception.message = message; + object->payload.exception.stack = stackp(frame) ? frame : nil; + object->payload.exception.meta = (consp(meta) || hashtabp(meta)) ? meta : nil; + object->payload.exception.cause = exceptionp(cause) ? cause : nil; + } + + return result; } /** @@ -34,8 +63,12 @@ struct pso_pointer destroy_exception( struct pso_pointer fp, if ( stackp( fp ) ) { struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; + struct pso3* object = (struct pso3*)pointer_to_object( p); - // TODO: decrement every pointer indicated by an exception. + dec_ref( object->payload.exception.message); + dec_ref( object->payload.exception.stack); + dec_ref( object->payload.exception.meta); + dec_ref( object->payload.exception.cause); } return nil; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 5b865e2..5670c81 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -16,16 +16,19 @@ * @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. */ + /** @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. */ + /** @brief the stack frame at which the exception was thrown. */ struct pso_pointer stack; + /** a store (assoc list or hashtable (or `nil` of metadata */ + struct pso_pointer meta; /** @brief the cause; expected to be another exception, or (usually) `nil`. */ struct pso_pointer cause; }; struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, + struct pso_pointer meta, struct pso_pointer cause ); struct pso_pointer destroy_exception( struct pso_pointer fp, From 4efe9eab87d4b8c7902cb8d6e2ba65ffafc633bb Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 16 Apr 2026 22:28:35 +0100 Subject: [PATCH 34/77] Very close to a basic REPL now. --- archive/c/init.c | 2 +- archive/c/io/print.c | 28 ++++++++-------- archive/c/io/print.h | 2 +- archive/c/memory/dump.c | 16 ++++----- archive/c/memory/hashmap.c | 6 ++-- archive/c/memory/stack.c | 8 ++--- archive/c/ops/lispops.c | 4 +-- src/c/debug.c | 67 ++++++++++++++++++++++++++++++++------ src/c/io/io.c | 12 +++---- src/c/io/print.c | 2 +- src/c/io/print.h | 4 ++- src/c/memory/memory.c | 3 +- src/c/memory/node.c | 5 +++ src/c/memory/node.h | 2 ++ src/c/memory/tags.c | 6 ++-- src/c/memory/tags.h | 2 +- src/c/ops/eval_apply.c | 10 +++--- src/c/ops/reverse.c | 4 +-- src/c/ops/string_ops.c | 2 -- src/c/payloads/cons.c | 9 +++-- src/c/payloads/exception.c | 27 +++++++-------- src/c/payloads/exception.h | 4 +-- src/c/psse.c | 47 +++++++++++++++++++++++++- 23 files changed, 188 insertions(+), 84 deletions(-) diff --git a/archive/c/init.c b/archive/c/init.c index b0d18da..f8b1c1d 100644 --- a/archive/c/init.c +++ b/archive/c/init.c @@ -56,7 +56,7 @@ struct cons_pointer check_exception( struct cons_pointer pointer, fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor ); URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - print( ustderr, object->payload.exception.payload ); + c_print( ustderr, object->payload.exception.payload ); free( ustderr ); dec_ref( pointer ); diff --git a/archive/c/io/print.c b/archive/c/io/print.c index d9d2998..c6e1611 100644 --- a/archive/c/io/print.c +++ b/archive/c/io/print.c @@ -72,7 +72,7 @@ print_list_contents( URL_FILE *output, struct cons_pointer pointer, if ( initial_space ) { url_fputwc( btowc( ' ' ), output ); } - print( output, cell->payload.cons.car ); + c_print( output, cell->payload.cons.car ); print_list_contents( output, cell->payload.cons.cdr, true ); break; @@ -80,7 +80,7 @@ print_list_contents( URL_FILE *output, struct cons_pointer pointer, break; default: url_fwprintf( output, L" . " ); - print( output, pointer ); + c_print( output, pointer ); } } @@ -99,9 +99,9 @@ void print_map( URL_FILE *output, struct cons_pointer map ) { for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); ks = c_cdr( ks ) ) { struct cons_pointer key = c_car( ks ); - print( output, key ); + c_print( output, key ); url_fputwc( btowc( ' ' ), output ); - print( output, hashmap_get( map, key, false ) ); + c_print( output, hashmap_get( map, key, false ) ); if ( !nilp( c_cdr( ks ) ) ) { url_fputws( L", ", output ); @@ -153,7 +153,7 @@ void print_128bit( URL_FILE *output, __int128_t n ) { * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. */ -struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { +struct cons_pointer c_print( URL_FILE *output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -171,7 +171,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { break; case FUNCTIONTV: url_fputws( L"', output ); break; case INTEGERTV: @@ -190,7 +190,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); - print( output, to_print ); + c_print( output, to_print ); dec_ref( to_print ); url_fputwc( L'>', output ); @@ -206,20 +206,20 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); - print( output, to_print ); + c_print( output, to_print ); dec_ref( to_print ); url_fputwc( L'>', output ); } break; case RATIOTV: - print( output, cell.payload.ratio.dividend ); + c_print( output, cell.payload.ratio.dividend ); url_fputws( L"/", output ); - print( output, cell.payload.ratio.divisor ); + c_print( output, cell.payload.ratio.divisor ); break; case READTV: url_fwprintf( output, L"', output ); break; case REALTV: @@ -246,7 +246,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { break; case SPECIALTV: url_fwprintf( output, L"', output ); break; case TIMETV: @@ -264,7 +264,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) { break; case WRITETV: url_fwprintf( output, L"', output ); break; default: @@ -312,7 +312,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"lisp_print: about to print\n", DEBUG_IO ); debug_dump_object( frame->arg[0], DEBUG_IO ); - result = print( output, frame->arg[0] ); + result = c_print( output, frame->arg[0] ); debug_print( L"lisp_print returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); diff --git a/archive/c/io/print.h b/archive/c/io/print.h index bde68fb..0d9aae8 100644 --- a/archive/c/io/print.h +++ b/archive/c/io/print.h @@ -16,7 +16,7 @@ #ifndef __print_h #define __print_h -struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); +struct cons_pointer c_print( URL_FILE * output, struct cons_pointer pointer ); void println( URL_FILE * output ); struct cons_pointer lisp_print( struct stack_frame *frame, diff --git a/archive/c/memory/dump.c b/archive/c/memory/dump.c index 3a83866..24ac48b 100644 --- a/archive/c/memory/dump.c +++ b/archive/c/memory/dump.c @@ -48,7 +48,7 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix, cell.payload.string.cdr.page, cell.payload.string.cdr.offset, cell.count ); url_fwprintf( output, L"\t\t value: " ); - print( output, pointer ); + c_print( output, pointer ); url_fwprintf( output, L"\n" ); } } @@ -71,7 +71,7 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) { cell.payload.cons.car.offset, cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, cell.count ); - print( output, pointer ); + c_print( output, pointer ); url_fputws( L"\n", output ); break; case EXCEPTIONTV: @@ -97,18 +97,18 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) { break; case LAMBDATV: url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell.payload.lambda.args ); + c_print( output, cell.payload.lambda.args ); url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); + c_print( output, cell.payload.lambda.body ); url_fputws( L"\n", output ); break; case NILTV: break; case NLAMBDATV: url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell.payload.lambda.args ); + c_print( output, cell.payload.lambda.args ); url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); + c_print( output, cell.payload.lambda.body ); url_fputws( L"\n", output ); break; case RATIOTV: @@ -121,7 +121,7 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) { break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); + c_print( output, cell.payload.stream.meta ); url_fputws( L"\n", output ); break; case REALTV: @@ -159,7 +159,7 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) { break; case WRITETV: url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); + c_print( output, cell.payload.stream.meta ); url_fputws( L"\n", output ); break; } diff --git a/archive/c/memory/hashmap.c b/archive/c/memory/hashmap.c index eaabca4..96baf39 100644 --- a/archive/c/memory/hashmap.c +++ b/archive/c/memory/hashmap.c @@ -140,13 +140,13 @@ void dump_map( URL_FILE *output, struct cons_pointer pointer ) { &pointer_to_vso( pointer )->payload.hashmap; url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); url_fwprintf( output, L"\tHash function: " ); - print( output, payload->hash_fn ); + c_print( output, payload->hash_fn ); url_fwprintf( output, L"\n\tWrite ACL: " ); - print( output, payload->write_acl ); + c_print( output, payload->write_acl ); url_fwprintf( output, L"\n\tBuckets:" ); for ( int i = 0; i < payload->n_buckets; i++ ) { url_fwprintf( output, L"\n\t\t[%d]: ", i ); - print( output, payload->buckets[i] ); + c_print( output, payload->buckets[i] ); } url_fwprintf( output, L"\n" ); } diff --git a/archive/c/memory/stack.c b/archive/c/memory/stack.c index 0188e6b..9b8df3e 100644 --- a/archive/c/memory/stack.c +++ b/archive/c/memory/stack.c @@ -291,7 +291,7 @@ void dump_frame_context_fragment( URL_FILE *output, if ( frame != NULL ) { url_fwprintf( output, L" <= " ); - print( output, frame->arg[0] ); + c_print( output, frame->arg[0] ); } } @@ -332,12 +332,12 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) { url_fwprintf( output, L"\tArg %d:\t%4.4s\tcount: %10u\tvalue: ", arg, cell.tag.bytes, cell.count ); - print( output, frame->arg[arg] ); + c_print( output, frame->arg[arg] ); url_fputws( L"\n", output ); } if ( !nilp( frame->more ) ) { url_fputws( L"More: \t", output ); - print( output, frame->more ); + c_print( output, frame->more ); url_fputws( L"\n", output ); } } @@ -345,7 +345,7 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE *output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.payload ); + c_print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c index 2a8cc47..b0ab6c9 100644 --- a/archive/c/ops/lispops.c +++ b/archive/c/ops/lispops.c @@ -1526,7 +1526,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer prompt = c_assoc( prompt_name, new_env ); if ( !nilp( prompt ) ) { - print( os, prompt ); + c_print( os, prompt ); } expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, @@ -1541,7 +1541,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, println( os ); - print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + c_print( os, eval_form( frame, frame_pointer, expr, new_env ) ); dec_ref( expr ); } diff --git a/src/c/debug.c b/src/c/debug.c index ecef2dd..637d889 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -11,9 +11,14 @@ */ #include +#include #include "debug.h" +#include "io/fopen.h" +#include "io/io.h" +#include "io/print.h" + int verbosity = 0; @@ -45,14 +50,6 @@ 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`. * @@ -133,5 +130,55 @@ void debug_printf( int level, int indent, wchar_t *format, ... ) { #endif } -// debug_dump_object, debug_print_binding, debug_print_exception, debug_print_object, -// not yet implemented but probably will be. + +/** + * @brief print the object indicated by this `pointer` 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. + */ +void debug_print_object( struct pso_pointer pointer, int level, int indent ) { +#ifdef DEBUG + if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); + fwide( stderr, 1 ); + in_print( pointer, ustderr ); + free( ustderr ); + } +#endif +} + +/** + * @brief Like `dump_object`, q.v., but protected by the verbosity mechanism. + * + * `verbosity` is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + */ +void debug_dump_object( struct pso_pointer pointer, int level, int indent ) { +//#ifdef DEBUG +// if ( level & verbosity ) { +// URL_FILE *ustderr = file_to_url_file( stderr ); +// fwide( stderr, 1 ); +// dump_object( ustderr, pointer ); +// free( ustderr ); +// } +//#endif +} + +///** +// * Standardise printing of binding trace messages. +// */ +//void debug_print_binding( struct cons_pointer key, struct cons_pointer val, +// bool deep, int level, int indent ) { +//#ifdef DEBUG +// // wchar_t * depth = (deep ? L"Deep" : L"Shallow"); +// +// debug_print( ( deep ? L"Deep" : L"Shallow" ), level, indent ); +// debug_print( L" binding `", level, indent ); +// debug_print_object( key, level, indent ); +// debug_print( L"` to `", level, indent ); +// debug_print_object( val, level, indent ); +// debug_print( L"`\n", level, indent ); +//#endif +//} diff --git a/src/c/io/io.c b/src/c/io/io.c index 6b61591..2a897f7 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -286,8 +286,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload.character. - character ), + ( pointer_to_object( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -315,8 +315,8 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { if ( url_fclose - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) == 0 ) { result = t; } @@ -569,8 +569,8 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { if ( readp( fetch_arg( frame, 0 ) ) ) { result = make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. - stream.stream ), nil ); + ( pointer_to_object( fetch_arg( frame, 0 ) )-> + payload.stream.stream ), nil ); } return result; diff --git a/src/c/io/print.c b/src/c/io/print.c index e22d48b..365fb18 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -109,7 +109,7 @@ 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 ) { +struct pso_pointer c_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 ); diff --git a/src/c/io/print.h b/src/c/io/print.h index eb728c3..0a969e0 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -14,6 +14,8 @@ #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 c_print( struct pso_pointer p, struct pso_pointer stream ); + +struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); #endif diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 7a44bc4..eaeecbd 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -49,7 +49,8 @@ struct pso_pointer initialise_memory( uint32_t node ) { if ( memory_initialised ) { result = make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise memory." ), nil, nil, nil ); + ( L"Attenpt to reinitialise memory." ), nil, nil, + nil ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 4cc9db0..5bac51d 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -46,6 +46,11 @@ struct pso_pointer nil = ( struct pso_pointer ) { 0, 0, 0 }; */ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 }; +/** + * @brief The root of the data space. + */ +struct pso_pointer oblist = ( struct pso_pointer ) { 0, 0, 0 }; + /** * @brief Set up the basic informetion about this node. diff --git a/src/c/memory/node.h b/src/c/memory/node.h index fbc177a..5ce48cf 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -31,6 +31,8 @@ extern struct pso_pointer nil; */ extern struct pso_pointer t; +extern struct pso_pointer oblist; + struct pso_pointer initialise_node( uint32_t index ); #endif diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index a2fc880..8b956f1 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -31,12 +31,14 @@ uint32_t get_tag_value( struct pso_pointer p ) { * * @param p must be a struct pso_pointer, indicating the appropriate object. */ -struct pso_pointer get_tag_string( struct pso_pointer p) { +struct pso_pointer get_tag_string( struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( p ); for ( int i = 2 - 1; i >= 0; i-- ) { - result = make_string( (wchar_t)(object->header.tag.bytes.mnemonic[i]), result ); + result = + make_string( ( wchar_t ) ( object->header.tag.bytes.mnemonic[i] ), + result ); } return result; diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 5608c66..575c739 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -84,7 +84,7 @@ // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) uint32_t get_tag_value( struct pso_pointer p ); -struct pso_pointer get_tag_string( struct pso_pointer p); +struct pso_pointer get_tag_string( struct pso_pointer p ); /** * @brief check that the tag of the object indicated by this poiner has this diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 91f47ea..aeb3577 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -87,8 +87,10 @@ struct pso_pointer eval( ( c_string_to_lisp_string ( L"Can't yet evaluate things of this type: " ), result ), frame_pointer, - c_cons( c_cons( c_string_to_lisp_keyword(L"tag"), - get_tag_string(result)), nil), nil ); + c_cons( c_cons + ( c_string_to_lisp_keyword( L"tag" ), + get_tag_string( result ) ), nil ), + nil ); } if ( exceptionp( result ) ) { @@ -98,8 +100,8 @@ struct pso_pointer eval( if ( nilp( x->payload.exception.stack ) ) { result = - make_exception( x->payload.exception.message, frame_pointer, nil, - result ); + make_exception( x->payload.exception.message, frame_pointer, + nil, result ); } } diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 1f44127..5e51204 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -65,8 +65,8 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) { default: result = make_exception( c_cons( c_string_to_lisp_string - ( L"Invalid object in sequence" ), cursor), nil, - nil , nil); + ( L"Invalid object in sequence" ), + cursor ), nil, nil, nil ); goto exit; break; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index d00456a..b4dc31c 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -182,5 +182,3 @@ struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { return result; } - - diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index e1586bf..20e5284 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -82,11 +82,10 @@ struct pso_pointer c_cdr( struct pso_pointer p ) { break; default: result = - make_exception( - c_cons( - c_string_to_lisp_string( L"Invalid type for cdr" ), - get_tag_string( p) ), - nil, nil, nil ); + make_exception( c_cons + ( c_string_to_lisp_string + ( L"Invalid type for cdr" ), + get_tag_string( p ) ), nil, nil, nil ); break; } diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index fa18350..8817894 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -36,17 +36,18 @@ */ struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame, - struct pso_pointer meta, + struct pso_pointer meta, struct pso_pointer cause ) { - struct pso_pointer result = allocate(EXCEPTIONTAG, 3); + struct pso_pointer result = allocate( EXCEPTIONTAG, 3 ); - if (!nilp(result) && !exceptionp(result)) { - struct pso3* object = (struct pso3*)pointer_to_object( result); + if ( !nilp( result ) && !exceptionp( result ) ) { + struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); - object->payload.exception.message = message; - object->payload.exception.stack = stackp(frame) ? frame : nil; - object->payload.exception.meta = (consp(meta) || hashtabp(meta)) ? meta : nil; - object->payload.exception.cause = exceptionp(cause) ? cause : nil; + object->payload.exception.message = message; + object->payload.exception.stack = stackp( frame ) ? frame : nil; + object->payload.exception.meta = ( consp( meta ) + || hashtabp( meta ) ) ? meta : nil; + object->payload.exception.cause = exceptionp( cause ) ? cause : nil; } return result; @@ -63,12 +64,12 @@ struct pso_pointer destroy_exception( struct pso_pointer fp, if ( stackp( fp ) ) { struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; - struct pso3* object = (struct pso3*)pointer_to_object( p); + struct pso3 *object = ( struct pso3 * ) pointer_to_object( p ); - dec_ref( object->payload.exception.message); - dec_ref( object->payload.exception.stack); - dec_ref( object->payload.exception.meta); - dec_ref( object->payload.exception.cause); + dec_ref( object->payload.exception.message ); + dec_ref( object->payload.exception.stack ); + dec_ref( object->payload.exception.meta ); + dec_ref( object->payload.exception.cause ); } return nil; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 5670c81..110252d 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -16,7 +16,7 @@ * @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. */ + /** @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; @@ -28,7 +28,7 @@ struct exception_payload { struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame_pointer, - struct pso_pointer meta, + struct pso_pointer meta, struct pso_pointer cause ); struct pso_pointer destroy_exception( struct pso_pointer fp, diff --git a/src/c/psse.c b/src/c/psse.c index b234103..0c36395 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -12,13 +12,24 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include +#include +#include +#include + +#include "debug.h" #include "psse.h" #include "io/io.h" #include "memory/node.h" +#include "memory/pso.h" +#include "memory/tags.h" #include "ops/stack_ops.h" #include "ops/truth.h" +#include "payloads/cons.h" +#include "payloads/stack.h" + void print_banner( ) { fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION ); @@ -54,6 +65,35 @@ void print_options( FILE *stream ) { #endif } +/** + * @brief Handle an interrupt signal. + * + * @param dummy + */ +void int_handler( int dummy ) { + wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); +} + +/** + * The read/eval/print loop. + */ +void repl( ) { + signal( SIGINT, int_handler ); + debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); + + struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); + + /* bottom of stack */ + struct pso_pointer frame_pointer = make_frame( 1, nil, nil, env ); + + if ( !nilp( frame_pointer ) ) { +// lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); + + dec_ref( frame_pointer ); + } + + debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); +} /** * main entry point; parse command line arguments, initialise the environment, @@ -101,7 +141,12 @@ int main( int argc, char *argv[] ) { } } - if ( nilp( initialise_node( 0 ) ) ) { + oblist = initialise_node( 0 ); + debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); + debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); + debug_println( DEBUG_BOOTSTRAP ); + + if ( nilp( oblist ) ) { fputs( "Failed to initialise node\n", stderr ); exit( 1 ); } From cf05e305404130c979f7edce416aaa76f7727b2c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 17 Apr 2026 14:20:31 +0100 Subject: [PATCH 35/77] Well, we have a REPL. It blows up horribly, but we have one. --- .clangd | 7 ++ Makefile | 2 +- src/c/io/io.c | 187 ++++++++++++++++++++------------ src/c/io/io.h | 3 + src/c/io/print.h | 1 + src/c/io/read.c | 84 +++++++++----- src/c/memory/node.c | 21 +++- src/c/memory/node.h | 2 +- src/c/ops/bind.c | 1 + src/c/ops/bind.h | 2 +- src/c/ops/eval_apply.c | 1 + src/c/ops/list_ops.h | 2 + src/c/ops/repl.c | 90 +++++++++++++++ src/c/ops/repl.h | 21 ++-- src/c/payloads/read_stream.c | 2 +- src/c/payloads/write_stream.c | 36 ++++++ src/c/payloads/write_stream.h | 4 + src/c/psse.c | 34 +----- src/templates/codetemplates.xml | 66 +++++++++++ 19 files changed, 422 insertions(+), 144 deletions(-) create mode 100644 .clangd create mode 100644 src/c/ops/repl.c create mode 100644 src/c/payloads/write_stream.c create mode 100644 src/templates/codetemplates.xml diff --git a/.clangd b/.clangd new file mode 100644 index 0000000..8ae8d15 --- /dev/null +++ b/.clangd @@ -0,0 +1,7 @@ +CompileFlags: {CompilationDatabase: } + +If: + PathMatch: .*\.c + +CompileFlags: + Add: [-std=gnu23, -Wall, -Wextra, -I src/c -I src/c/arith -I src/c/environment -I src/c/io -I src/c/memory -I src/c/ops -I src/c/payloads] \ No newline at end of file diff --git a/Makefile b/Makefile index 701b16b..b6853b9 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ TESTS := $(shell find unit-tests -name *.sh) # INC_DIRS := $(shell find $(SRC_DIRS) -type d) # INC_FLAGS := $(addprefix -I,$(INC_DIRS)) -INC_FLAGS := -I $(SRC_DIRS) +INC_FLAGS := -I $(shell find $(SRC_DIRS) -type d) TMP_DIR ?= ./tmp diff --git a/src/c/io/io.c b/src/c/io/io.c index 2a897f7..61175e8 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -15,9 +15,9 @@ #include #include #include -#include #include #include +#include #include #include /* @@ -28,7 +28,7 @@ #include -//#include "arith/integer.h" +// #include "arith/integer.h" #include "debug.h" #include "io/fopen.h" #include "io/io.h" @@ -42,6 +42,8 @@ // #include "ops/intern.h" // #include "ops/lispops.h" +#include "ops/assoc.h" +#include "ops/bind.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -50,7 +52,9 @@ #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/integer.h" +#include "payloads/read_stream.h" #include "payloads/stack.h" +#include "payloads/write_stream.h" #include "utils.h" @@ -62,21 +66,36 @@ CURLSH *io_share; /** - * @brief bound to the Lisp string representing C_IO_IN in initialisation. + * @brief bound to the Lisp symbol representing C_IO_IN in initialisation. */ struct pso_pointer lisp_io_in; /** - * @brief bound to the Lisp string representing C_IO_OUT in initialisation. + * @brief bound to the Lisp symbol 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; +/** + * 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; +} + /** * Initialise the I/O subsystem. * @@ -99,6 +118,32 @@ int initialise_io( ) { return result; } +struct pso_pointer initialise_default_streams( struct pso_pointer env ) { + lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); + + env = c_bind( lisp_io_in, + make_read_stream( file_to_url_file( stdin ), + c_cons( c_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard input" ) ), + nil ) ), env ); + if ( !nilp( env ) && !exceptionp( env ) ) { + env = c_bind( lisp_io_out, + make_write_stream( file_to_url_file( stdout ), + c_cons( c_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard input" ) ), + nil ) ), env ); + } + + return env; +} + /** * 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 @@ -138,24 +183,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { 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. * @@ -193,13 +220,15 @@ wint_t url_fgetwc( URL_FILE *input ) { 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: + /* 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. + * 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; @@ -219,8 +248,7 @@ wint_t url_fgetwc( URL_FILE *input ) { free( wbuff ); free( cbuff ); - } - break; + } break; case CFTYPE_NONE: break; } @@ -265,8 +293,8 @@ struct pso_pointer get_character( struct pso_pointer read_stream ) { if ( readp( read_stream ) ) { result = make_character( url_fgetwc - ( pointer_to_object_of_size_class - ( read_stream, 2 )->payload.stream.stream ) ); + ( pointer_to_object_of_size_class( read_stream, 2 ) + ->payload.stream.stream ) ); } return result; @@ -286,8 +314,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload. - character.character ), + ( pointer_to_object( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -308,16 +336,14 @@ struct pso_pointer push_back_character( struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer -lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { +struct pso_pointer 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 ) - == 0 ) { + if ( url_fclose( pointer_to_object( fetch_arg( frame, 0 ) ) + ->payload.stream.stream ) == 0 ) { result = t; } } @@ -328,8 +354,9 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, long int value ) { return - c_cons( c_cons( c_string_to_lisp_keyword( key ), - make_integer( value ) ), meta ); + c_cons( c_cons + ( c_string_to_lisp_keyword( key ), make_integer( value ) ), + meta ); } struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, @@ -338,8 +365,10 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return c_cons( c_cons( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + return + c_cons( c_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, @@ -348,9 +377,8 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, * bit of an oversight! */ char datestring[256]; - strftime( datestring, - sizeof( datestring ), - nl_langinfo( D_T_FMT ), localtime( value ) ); + strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), + localtime( value ) ); return add_meta_string( meta, key, datestring ); } @@ -386,8 +414,8 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // 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 ); + // 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] ); @@ -400,16 +428,17 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // 10 ) ); // debug_printf( DEBUG_IO, - // L"write_meta_callback: added header 'status': value '%s'\n", - // value ); + // 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 ); + // 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: ", + // ( L"Pointer passed to write_meta_callback did not point to a + // stream: ", // DEBUG_IO ); // debug_dump_object( stream, DEBUG_IO ); // } @@ -471,13 +500,28 @@ void collect_meta( struct pso_pointer stream, char *url ) { */ 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; + struct pso_pointer stream_name = inputp ? lisp_io_in : lisp_io_out; - // result = c_assoc( stream_name, env ); + result = c_assoc( stream_name, env ); return result; } +/** + * @brief if `s` points to either an input or an output stream, return the + * URL_FILE pointer underlying that stream, else NULL. + */ +URL_FILE *stream_get_url_file( struct pso_pointer s ) { + URL_FILE *result = NULL; + + if ( readp( s ) || writep( s ) ) { + struct pso2 *obj = pointer_to_object( s ); + + result = obj->payload.stream.stream; + } + + return result; +} /** * Function: return a stream open on the URL indicated by the first argument; @@ -494,8 +538,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer -lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) { +struct pso_pointer lisp_open( struct pso_pointer frame_pointer, + struct pso_pointer env ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; @@ -505,10 +549,10 @@ lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) { // 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 ); + // 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: @@ -561,16 +605,16 @@ lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ) { * @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 pso_pointer frame_pointer, struct pso_pointer env ) { +struct pso_pointer 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 ) ) ) { + struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); + if ( readp( stream_pointer ) ) { result = - make_string( url_fgetwc - ( pointer_to_object( fetch_arg( frame, 0 ) )-> - payload.stream.stream ), nil ); + make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ), + nil ); } return result; @@ -590,14 +634,13 @@ lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ) { * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer -lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ) { +struct pso_pointer 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; + URL_FILE *stream = stream_get_url_file( fetch_arg( frame, 0 ) ); struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil ); result = cursor; diff --git a/src/c/io/io.h b/src/c/io/io.h index 703ed2e..995f508 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -19,6 +19,7 @@ extern CURLSH *io_share; int initialise_io( ); +struct pso_pointer initialise_default_streams( struct pso_pointer env ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" @@ -37,6 +38,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ); +URL_FILE *stream_get_url_file( struct pso_pointer s ); + struct pso_pointer lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer diff --git a/src/c/io/print.h b/src/c/io/print.h index 0a969e0..39b7d41 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -14,6 +14,7 @@ #ifndef __psse_io_print_h #define __psse_io_print_h +#include "io/fopen.h" struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ); struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); diff --git a/src/c/io/read.c b/src/c/io/read.c index f072a6d..f78e796 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/function.h" #include "payloads/integer.h" #include "payloads/read_stream.h" @@ -41,7 +42,7 @@ #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. +// TODO: what I've copied from 0.0.6 is *weirdly* 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. @@ -55,9 +56,9 @@ // the next is the input stream; the next is the readtable, if any. /* - * for the time being things which may be read are: + * for the time being things which may be read are: * * integers - * * lists + * * lists * * atoms * * dotted pairs */ @@ -72,8 +73,12 @@ * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_example( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + 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 ); @@ -93,8 +98,12 @@ struct pso_pointer read_example( struct pso_pointer frame_pointer, * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_number( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_number( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + 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 ); @@ -109,8 +118,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer, 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 ( ; iswdigit( c ); c = url_fgetwc( input ) ) { @@ -124,8 +133,12 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer, return result; } -struct pso_pointer read_symbol( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_symbol( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + 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 ); @@ -137,8 +150,8 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer, 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 ) ) { @@ -163,8 +176,12 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer, * 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 read( +#ifndef MANAGED_POINTER_ONLY + struct pso4 *frame, +#endif + 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 ); @@ -201,27 +218,38 @@ struct pso_pointer read( struct pso_pointer frame_pointer, /* 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 ); + // 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( 3, frame_pointer, stream, readtable, - make_character( c ) ); + struct pso_pointer next = make_frame( 3, 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 { -// 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 ); + // 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 ); } dec_ref( next ); break; diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 5bac51d..42638a7 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -8,14 +8,20 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "node.h" - #include #include "environment/environment.h" + +#include "io/io.h" + #include "memory/memory.h" #include "memory/pointer.h" +#include "memory/tags.h" + #include "ops/eq.h" +#include "ops/string_ops.h" +#include "ops/truth.h" +#include "payloads/exception.h" /** * @brief Flag to prevent the node being initialised more than once. @@ -63,5 +69,16 @@ struct pso_pointer initialise_node( uint32_t index ) { struct pso_pointer result = initialise_environment( index ); + if ( !nilp( result ) && !exceptionp( result ) ) { + if ( initialise_io( ) == 0 ) { + result = initialise_default_streams( result ); + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Failed to initialise default streams" ), + nil, nil, nil ); + } + } + return result; } diff --git a/src/c/memory/node.h b/src/c/memory/node.h index 5ce48cf..d8559f1 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -33,6 +33,6 @@ extern struct pso_pointer t; extern struct pso_pointer oblist; -struct pso_pointer initialise_node( uint32_t index ); +struct pso_pointer initialise_node( int node_index ); #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index ba25834..5d66359 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -19,6 +19,7 @@ #include "ops/stack_ops.h" #include "payloads/cons.h" +#include "payloads/function.h" #include "payloads/stack.h" struct pso_pointer lisp_bind( diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index 517086a..2682fe8 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -3,7 +3,7 @@ * * Post Scarcity Software Environment: bind. * - * Test for pointer binduality. + * Bind a name to a value in a store. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index aeb3577..9333a03 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -23,6 +23,7 @@ #include "ops/truth.h" #include "payloads/cons.h" +#include "payloads/function.h" #include "payloads/stack.h" /** diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index ae770cd..0121b57 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -15,6 +15,8 @@ #include "memory/pointer.h" #include "memory/pso4.h" +#include "payloads/function.h" + struct pso_pointer car( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c new file mode 100644 index 0000000..efc8a3b --- /dev/null +++ b/src/c/ops/repl.c @@ -0,0 +1,90 @@ +/** + * repl.c + * + * Post Scarcity Soctware Environment + * + * First cut at a top level read-eval-print loop. + * + * Copyright (c): 17 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + +#include "debug.h" + +#include "io/fopen.h" +#include "io/io.h" +#include "io/print.h" +#include "io/read.h" + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso2.h" +#include "memory/pso2.h" +#include "memory/pso2.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "payloads/cons.h" +#include "payloads/function.h" +#include "payloads/stack.h" + +#include "ops/assoc.h" +#include "ops/eval_apply.h" +#include "ops/truth.h" + +/** + * @brief Handle an interrupt signal. + * + * @param dummy + */ +void int_handler( int dummy ) { + wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); +} + +/** + * Very simple read/eval/print loop for bootstrapping. + */ +void c_repl( ) { + signal( SIGINT, int_handler ); + debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); + + struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); + struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); + struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); + + while ( readp( input_stream ) + && !url_feof( stream_get_url_file( input_stream ) ) ) { + /* bottom of stack */ + struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); + + if ( nilp( frame_pointer ) ) + break; + struct pso_pointer input = read( +#ifndef MANAGED_POINTER_ONLY + pointer_to_pso4( frame_pointer ), +#endif + frame_pointer, env ); + + frame_pointer = make_frame( 1, frame_pointer, input ); + if ( nilp( frame_pointer ) ) + break; + + struct pso_pointer result = eval( +#ifndef MANAGED_POINTER_ONLY + pointer_to_pso4( frame_pointer ), +#endif + frame_pointer, oblist ); + + c_print( result, output_stream ); + + dec_ref( frame_pointer ); + } + + debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); +} diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index e5b1a9a..6706539 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -1,15 +1,20 @@ /** - * ops/repl.h + * repl.h * - * The read/eval/print loop. + * Post Scarcity Soctware Environment * - * (c) 2026 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. + * Read/Eval/Print loop + * + * Copyright (c): 17 Apr 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 +#ifndef SRC_C_OPS_REPL_H_ +#define SRC_C_OPS_REPL_H_ -// struct pso_pointer repl( struct pso_pointer prompt, struct pso_pointer readtable); -#endif + +void c_repl( ); + + +#endif /* SRC_C_OPS_REPL_H_ */ diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index 995d454..a0b0876 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -1,5 +1,5 @@ /** - * payloads/read_stream.h + * payloads/read_stream.c * * A read stream. * diff --git a/src/c/payloads/write_stream.c b/src/c/payloads/write_stream.c new file mode 100644 index 0000000..371f32c --- /dev/null +++ b/src/c/payloads/write_stream.c @@ -0,0 +1,36 @@ +/** + * payloads/read_stream.c + * + * 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" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + + +/** + * Construct a cell which points to a stream open for writing. + * @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_write_stream( URL_FILE *output, + struct pso_pointer metadata ) { + struct pso_pointer pointer = allocate( WRITETAG, 2 ); + struct pso2 *cell = pointer_to_object( pointer ); + + cell->payload.stream.stream = output; + cell->payload.stream.meta = metadata; + + return pointer; +} diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index d647575..69de8a4 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -11,4 +11,8 @@ #define __psse_payloads_write_stream_h /* write stream shares a payload with /see read_streem.h */ + +#include "io/fopen.h" +struct pso_pointer make_write_stream( URL_FILE * output, + struct pso_pointer metadata ); #endif diff --git a/src/c/psse.c b/src/c/psse.c index 0c36395..cd9b092 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -20,10 +20,12 @@ #include "debug.h" #include "psse.h" #include "io/io.h" + #include "memory/node.h" #include "memory/pso.h" #include "memory/tags.h" +#include "ops/repl.h" #include "ops/stack_ops.h" #include "ops/truth.h" @@ -65,37 +67,8 @@ void print_options( FILE *stream ) { #endif } -/** - * @brief Handle an interrupt signal. - * - * @param dummy - */ -void int_handler( int dummy ) { - wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); -} /** - * The read/eval/print loop. - */ -void repl( ) { - signal( SIGINT, int_handler ); - debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); - - struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); - - /* bottom of stack */ - struct pso_pointer frame_pointer = make_frame( 1, nil, nil, env ); - - if ( !nilp( frame_pointer ) ) { -// lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); - - dec_ref( frame_pointer ); - } - - debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); -} - - /** * main entry point; parse command line arguments, initialise the environment, * and enter the read-eval-print loop. */ @@ -150,7 +123,8 @@ int main( int argc, char *argv[] ) { fputs( "Failed to initialise node\n", stderr ); exit( 1 ); } - // repl( ); + + c_repl( ); exit( 0 ); } diff --git a/src/templates/codetemplates.xml b/src/templates/codetemplates.xml new file mode 100644 index 0000000..7140a04 --- /dev/null +++ b/src/templates/codetemplates.xml @@ -0,0 +1,66 @@ + From ca5671f6137f95f055a0461404595a48cd9fd867 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 17 Apr 2026 18:40:32 +0100 Subject: [PATCH 36/77] String-like-things are being created and printed correctly; bind is broken. --- src/c/environment/environment.c | 7 +- src/c/environment/environment.h | 1 + src/c/io/io.c | 736 ++++++++++++++++---------------- src/c/io/print.c | 180 +++++--- src/c/memory/tags.h | 5 +- src/c/ops/assoc.c | 2 +- src/c/ops/repl.c | 9 + src/c/ops/string_ops.c | 18 +- 8 files changed, 508 insertions(+), 450 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 309818e..0fa4e0b 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -36,7 +36,7 @@ bool environment_initialised = false; * @brief Initialise a minimal environment, so that Lisp can be bootstrapped. * * @param node the index of the node we are initialising. - * @return struct pso_pointer t on success, else an exception. + * @return a proto-environment on success, else an exception. */ struct pso_pointer initialise_environment( uint32_t node ) { @@ -85,9 +85,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { } if ( !exceptionp( result ) ) { result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); + debug_print(L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0); + debug_print_object( result, DEBUG_BOOTSTRAP, 0); result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); environment_initialised = true; + debug_print(L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0); + debug_print_object( result, DEBUG_BOOTSTRAP, 0); + debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); } diff --git a/src/c/environment/environment.h b/src/c/environment/environment.h index 4ec736a..9983558 100644 --- a/src/c/environment/environment.h +++ b/src/c/environment/environment.h @@ -10,6 +10,7 @@ #ifndef __psse_environment_environment_h #define __psse_environment_environment_h +#include struct pso_pointer initialise_environment( uint32_t node ); #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 61175e8..cfeca65 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -35,6 +35,7 @@ #include "memory/node.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -86,14 +87,14 @@ wint_t ungotten = 0; * @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 ) ); +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; - } + if (result != NULL) { + result->type = CFTYPE_FILE, result->handle.file = f; + } - return result; + return result; } /** @@ -101,47 +102,54 @@ URL_FILE *file_to_url_file( FILE *f ) { * * @return 0 on success; any other value means failure. */ -int initialise_io( ) { - int result = curl_global_init( CURL_GLOBAL_SSL ); +int initialise_io() { + int result = curl_global_init(CURL_GLOBAL_SSL); - io_share = curl_share_init( ); + 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 ); - } + 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; + return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer env ) { - lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); +struct pso_pointer initialise_default_streams(struct pso_pointer env) { + lisp_io_in = c_string_to_lisp_symbol(C_IO_IN); + lisp_io_out = c_string_to_lisp_symbol(C_IO_OUT); + + debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0); + debug_print_object(env, DEBUG_IO, 0); - env = c_bind( lisp_io_in, - make_read_stream( file_to_url_file( stdin ), - c_cons( c_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - nil ) ), env ); - if ( !nilp( env ) && !exceptionp( env ) ) { - env = c_bind( lisp_io_out, - make_write_stream( file_to_url_file( stdout ), - c_cons( c_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - nil ) ), env ); - } + env = c_bind( + lisp_io_in, + lock_object(make_read_stream( + file_to_url_file(stdin), + c_cons(c_cons(c_string_to_lisp_keyword(L"url"), + c_string_to_lisp_string(L"::system:standard-input")), + nil))), + env); + debug_print_object(env, DEBUG_IO, 0); + if (!nilp(env) && !exceptionp(env)) { + env = c_bind(lisp_io_out, + lock_object(make_write_stream( + file_to_url_file(stdout), + c_cons(c_cons(c_string_to_lisp_keyword(L"url"), + c_string_to_lisp_string( + L"::system:standard-output")), + nil))), + env); + } - return env; + debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0); + debug_print_object(env, DEBUG_IO, 0); + + return env; } /** @@ -153,34 +161,34 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { * @param s the lisp string or symbol; * @return the c string. */ -char *lisp_string_to_c_string( struct pso_pointer s ) { - char *result = NULL; +char *lisp_string_to_c_string(struct pso_pointer s) { + char *result = NULL; - if ( stringp( s ) || symbolp( s ) ) { - int len = 0; + if (stringp(s) || symbolp(s)) { + int len = 0; - for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { - len++; - } + for (struct pso_pointer c = s; !nilp(c); 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 ) ); + 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 = c_cdr( c ) ) { - buffer[i++] = pointer_to_object( c )->payload.string.character; - } + int i = 0; + for (struct pso_pointer c = s; !nilp(c); c = c_cdr(c)) { + buffer[i++] = pointer_to_object(c)->payload.string.character; + } - wcstombs( result, buffer, len ); - free( buffer ); - } + 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 ); + 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; + return result; } /** @@ -189,94 +197,93 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { * @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; +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; + 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 ) ); + case CFTYPE_CURL: { + char *cbuff = calloc(sizeof(wchar_t) + 2, sizeof(char)); + wchar_t *wbuff = calloc(2, sizeof(wchar_t)); - size_t count = 0; + 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; - } + 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]; + 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; - } - } + 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; + 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; +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; + 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; - } - } + case CFTYPE_CURL: { + ungotten = wc; + break; + case CFTYPE_NONE: + break; + } + } - return result; + return result; } /** @@ -287,17 +294,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 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 ) ); - } + 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; } /** @@ -308,20 +314,18 @@ 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; } /** @@ -336,191 +340,186 @@ struct pso_pointer push_back_character( struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer lisp_close( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer 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 ) == 0 ) { - result = t; - } - } + 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; + return result; } -struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, - long int value ) { - return - c_cons( c_cons - ( c_string_to_lisp_keyword( key ), make_integer( value ) ), - meta ); +struct pso_pointer add_meta_integer(struct pso_pointer meta, wchar_t *key, + long int value) { + return c_cons(c_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 ); +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 - c_cons( c_cons - ( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + return c_cons( + c_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]; +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 ) ); + strftime(datestring, sizeof(datestring), nl_langinfo(D_T_FMT), + localtime(value)); - return add_meta_string( meta, key, datestring ); + 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 ); +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 + // TODO: reimplement - /* make a copy of the string that we can destructively change */ - // char *s = calloc( strlen( string ), sizeof( char ) ); + /* make a copy of the string that we can destructively change */ + // char *s = calloc( strlen( string ), sizeof( char ) ); - // strcpy( s, string ); + // strcpy( s, string ); - // if ( check_tag( cell, READTV) || - // check_tag( cell, WRITETV) ) { - // int offset = index_of( ':', s ); + // 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 )]; + // 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 ); + // mbstowcs( wname, name, strlen( name ) + 1 ); - // cell->payload.stream.meta = - // add_meta_string( cell->payload.stream.meta, wname, value ); + // 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] ); + // 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 ) ); + // 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 ); - // } + // 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 ); + // 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; +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 ); - } + 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 ); - } + 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_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; - } + 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; + /* 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; +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 ); + result = c_assoc(stream_name, env); - return result; + return result; } /** * @brief if `s` points to either an input or an output stream, return the * URL_FILE pointer underlying that stream, else NULL. */ -URL_FILE *stream_get_url_file( struct pso_pointer s ) { - URL_FILE *result = NULL; +URL_FILE *stream_get_url_file(struct pso_pointer s) { + URL_FILE *result = NULL; - if ( readp( s ) || writep( s ) ) { - struct pso2 *obj = pointer_to_object( s ); + if (readp(s) || writep(s)) { + struct pso2 *obj = pointer_to_object(s); - result = obj->payload.stream.stream; - } + result = obj->payload.stream.stream; + } - return result; + return result; } /** @@ -538,59 +537,59 @@ URL_FILE *stream_get_url_file( struct pso_pointer s ) { * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer lisp_open( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer 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) ) ) { - // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); + // 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" ); + // 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 ); + // 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; - // } + // 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 ); - // } + // 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 ); - // } + // if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + // result = nil; + // } else { + // collect_meta( result, url ); + // } - // free( url ); - // } + // free( url ); + // } - return result; + return result; } /** @@ -605,19 +604,18 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer, * @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 pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer 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; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); - if ( readp( stream_pointer ) ) { - result = - make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ), - nil ); - } + struct pso_pointer stream_pointer = fetch_arg(frame, 0); + if (readp(stream_pointer)) { + result = + make_string(url_fgetwc(stream_get_url_file(stream_pointer)), nil); + } - return result; + return result; } /** @@ -634,29 +632,29 @@ struct pso_pointer lisp_read_char( struct pso_pointer frame_pointer, * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; +struct pso_pointer 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 = stream_get_url_file( fetch_arg( frame, 0 ) ); - struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil ); - result = cursor; + if (readp(fetch_arg(frame, 0))) { + URL_FILE *stream = stream_get_url_file(fetch_arg(frame, 0)); + 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 ); + 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; - } - } + struct pso2 *cell = pointer_to_object(cursor); + cursor = make_string((wchar_t)c, nil); + cell->payload.string.cdr = cursor; + } + } - return result; + return result; } diff --git a/src/c/io/print.c b/src/c/io/print.c index 365fb18..da89685 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -3,8 +3,8 @@ * * 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 + * 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 @@ -12,6 +12,7 @@ */ #include +#include #include #include #include @@ -36,93 +37,130 @@ #include "payloads/cons.h" #include "payloads/integer.h" -struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); +#include "ops/truth.h" -struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) { - struct pso_pointer result = nil; +struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output); - if ( consp( p ) ) { - for ( ; consp( p ); p = c_cdr( p ) ) { - struct pso2 *object = pointer_to_object( p ); +struct pso_pointer print_string_like_thing(struct pso_pointer p, + URL_FILE *output) { + switch (get_tag_value(p)) { + case KEYTV: + url_fputwc(L':', output); + break; + case STRINGTV: + url_fputwc(L'"', output); + break; + } - result = in_print( object->payload.cons.car, output ); + if (keywordp(p) || stringp(p) || symbolp(p)) { + for (struct pso_pointer cursor = p; !nilp(cursor); + cursor = pointer_to_object(cursor)->payload.string.cdr) { + url_fputwc(pointer_to_object(cursor)->payload.character.character, + output); + } + } - 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, output ); - } - - } - } else { - // TODO: return exception - } - - return result; + if (stringp(p)) { + url_fputwc(L'"', output); + } } -struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { - struct pso2 *object = pointer_to_object( p ); - struct pso_pointer result = nil; +struct pso_pointer print_list_content(struct pso_pointer p, URL_FILE *output) { + 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( p, output ); - url_fputwc( L')', output ); - break; - case INTEGERTV: - url_fwprintf( output, L"%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 - } + if (consp(p)) { + for (; consp(p); p = c_cdr(p)) { + struct pso2 *object = pointer_to_object(p); - return result; + result = in_print(object->payload.cons.car, output); + + 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, output); + } + } + } else { + // TODO: return exception + } + + return result; +} + +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) { + uint32_t v = get_tag_value(p); + switch (v) { + case CHARACTERTV: + url_fputwc(object->payload.character.character, output); + break; + case CONSTV: + url_fputwc(L'(', 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)); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + print_string_like_thing(p, output); + break; + case NILTV: + url_fputws(L"nil", output); + break; + case READTV: + case WRITETV: + url_fwprintf(output, L"<%s stream: ", v == READTV ? "read" : "write"); + in_print(object->payload.stream.meta, output); + url_fputwc(L'>', output); + break; + case TRUETV: + url_fputwc(L't', output); + break; + 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 c_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 c_print(struct pso_pointer p, struct pso_pointer stream) { + struct pso_pointer result = p; + 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 ); + result = in_print(p, output); - if ( writep( stream ) ) { - dec_ref( stream ); - } + dec_ref(stream); + } - return result; + return result; } diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 575c739..5516de1 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -13,6 +13,7 @@ #define __psse_memory_tags_h #include +#include #define TAGLENGTH 3 @@ -71,8 +72,8 @@ #define TRUETV 5591636 #define VECTORTV 4408662 #define VECTORPOINTTV 5264214 -#define WRITETV 5264214 - +#define WRITETV 5526103 +// 5526103 /** * @brief return the numerical value of the tag of the object indicated by * pointer `p`. diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index fb63afc..100806d 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -41,7 +41,7 @@ struct pso_pointer search( struct pso_pointer key, if ( consp( store ) ) { for ( struct pso_pointer cursor = store; - consp( store ) && found == false; cursor = c_cdr( cursor ) ) { + consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index efc8a3b..2bd0c44 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -57,6 +57,15 @@ void c_repl( ) { struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); + + if (!readp(input_stream)) { + debug_print(L"Invalid read stream: ", DEBUG_IO, 0); + debug_print_object(input_stream, DEBUG_IO, 0); + } + if (!writep(output_stream)) { + debug_print(L"Invalid write stream: ", DEBUG_IO, 0); + debug_print_object(output_stream, DEBUG_IO, 0); + } while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index b4dc31c..f565234 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -71,7 +71,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { */ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, char *tag ) { - struct pso_pointer pointer = nil; + struct pso_pointer pointer = tail; if ( check_type( tail, tag ) || nilp( tail ) ) { pointer = allocate( tag, CONS_SIZE_CLASS ); @@ -81,8 +81,11 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, cell->payload.string.cdr = tail; cell->payload.string.hash = calculate_hash( c, tail ); - debug_dump_object( pointer, DEBUG_ALLOC, 0 ); - debug_println( DEBUG_ALLOC ); + debug_printf( DEBUG_ALLOC, 0, + L"Building string-like-thing of type %3.3s: ", + cell->header.tag.bytes.mnemonic); + debug_print_object(pointer, DEBUG_ALLOC, 0); + debug_println(DEBUG_ALLOC); } else { // \todo should throw an exception! struct pso2 *tobj = pointer_to_object( tail ); @@ -91,6 +94,7 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, tag, tobj->header.tag.bytes.mnemonic ); } + return pointer; } @@ -138,9 +142,11 @@ 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] != '"' ) { + if ( string[i] != '"' ) { result = make_string( string[i], result ); - } + } else { + result = make_string( L'\\', make_string( string[i], result)); + } } return result; @@ -157,7 +163,7 @@ struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { wchar_t c = towlower( symbol[i] ); - if ( iswalpha( c ) || c == L'-' ) { + if ( iswalpha( c ) || c == L'-' || c == L'*') { result = make_symbol( c, result ); } } From 02a4bc3e2865ad9fbb45c45955d8ad85195899b2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 18 Apr 2026 11:02:35 +0100 Subject: [PATCH 37/77] Hot damn! When you see an obvious, stupid bug you created, you can't unsee it! --- src/c/environment/environment.c | 9 +- src/c/io/io.c | 785 +++++++++++++++++--------------- src/c/io/io.h | 6 + src/c/io/print.c | 195 ++++---- src/c/ops/repl.c | 27 +- src/c/ops/string_ops.c | 18 +- src/c/payloads/cons.c | 2 +- src/c/psse.c | 16 +- 8 files changed, 563 insertions(+), 495 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 0fa4e0b..f80adc9 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -85,13 +85,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { } if ( !exceptionp( result ) ) { result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); - debug_print(L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0); - debug_print_object( result, DEBUG_BOOTSTRAP, 0); + debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, + 0 ); + debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); environment_initialised = true; - debug_print(L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0); - debug_print_object( result, DEBUG_BOOTSTRAP, 0); + debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); + debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); diff --git a/src/c/io/io.c b/src/c/io/io.c index cfeca65..35bd0b1 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -70,11 +70,35 @@ CURLSH *io_share; * @brief bound to the Lisp symbol representing C_IO_IN in initialisation. */ struct pso_pointer lisp_io_in; + +/** + * nasty hack, do not use except in dire emergency: bound to the actual UN*X + * stdin at startup. + */ +struct pso_pointer lisp_stdin; + /** * @brief bound to the Lisp symbol representing C_IO_OUT in initialisation. */ struct pso_pointer lisp_io_out; +/** + * nasty hack, do not use except in dire emergency: bound to the actual UN*X + * stdout at startup. + */ +struct pso_pointer lisp_stdout; + +/** + * @brief bound to the Lisp symbol representing C_IO_log in initialisation. + */ +struct pso_pointer lisp_io_log; + +/** + * nasty hack, do not use except in dire emergency: bound to the actual UN*X + * stderr at startup. + */ +struct pso_pointer lisp_stderr; + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. @@ -87,14 +111,14 @@ wint_t ungotten = 0; * @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)); +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; - } + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } - return result; + return result; } /** @@ -102,54 +126,75 @@ URL_FILE *file_to_url_file(FILE *f) { * * @return 0 on success; any other value means failure. */ -int initialise_io() { - int result = curl_global_init(CURL_GLOBAL_SSL); +int initialise_io( ) { + int result = curl_global_init( CURL_GLOBAL_SSL ); - io_share = curl_share_init(); + 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); - } + 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; + return result; } -struct pso_pointer initialise_default_streams(struct pso_pointer env) { - lisp_io_in = c_string_to_lisp_symbol(C_IO_IN); - lisp_io_out = c_string_to_lisp_symbol(C_IO_OUT); - - debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0); - debug_print_object(env, DEBUG_IO, 0); +struct pso_pointer initialise_default_streams( struct pso_pointer env ) { + lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); + lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); - env = c_bind( - lisp_io_in, - lock_object(make_read_stream( - file_to_url_file(stdin), - c_cons(c_cons(c_string_to_lisp_keyword(L"url"), - c_string_to_lisp_string(L"::system:standard-input")), - nil))), - env); - debug_print_object(env, DEBUG_IO, 0); - if (!nilp(env) && !exceptionp(env)) { - env = c_bind(lisp_io_out, - lock_object(make_write_stream( - file_to_url_file(stdout), - c_cons(c_cons(c_string_to_lisp_keyword(L"url"), - c_string_to_lisp_string( - L"::system:standard-output")), - nil))), - env); - } + debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, + 0 ); + debug_print_object( env, DEBUG_IO, 0 ); - debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0); - debug_print_object(env, DEBUG_IO, 0); + lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), + c_cons( c_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-input" ) ), + nil ) ) ); - return env; + env = c_bind( lisp_io_in, lisp_stdin, env ); + + debug_print_object( env, DEBUG_IO, 0 ); + + if ( !nilp( env ) && !exceptionp( env ) ) { + lisp_stdout = + lock_object( make_write_stream + ( file_to_url_file( stdout ), + c_cons( c_cons + ( c_string_to_lisp_keyword( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-output" ) ), + nil ) ) ); + + env = c_bind( lisp_io_out, lisp_stdout, env ); + } + + if ( !nilp( env ) && !exceptionp( env ) ) { + lisp_stderr = + lock_object( make_write_stream + ( file_to_url_file( stderr ), + c_cons( c_cons + ( c_string_to_lisp_keyword( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-output" ) ), + nil ) ) ); + + env = c_bind( lisp_io_log, lisp_stderr, env ); + } + + debug_print( L"Leaving initialise_default_streams; environment is: ", + DEBUG_IO, 0 ); + debug_print_object( env, DEBUG_IO, 0 ); + + return env; } /** @@ -161,34 +206,34 @@ struct pso_pointer initialise_default_streams(struct pso_pointer env) { * @param s the lisp string or symbol; * @return the c string. */ -char *lisp_string_to_c_string(struct pso_pointer s) { - char *result = NULL; +char *lisp_string_to_c_string( struct pso_pointer s ) { + char *result = NULL; - if (stringp(s) || symbolp(s)) { - int len = 0; + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; - for (struct pso_pointer c = s; !nilp(c); c = c_cdr(c)) { - len++; - } + for ( struct pso_pointer c = s; !nilp( c ); 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)); + 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 = c_cdr(c)) { - buffer[i++] = pointer_to_object(c)->payload.string.character; - } + int i = 0; + for ( struct pso_pointer c = s; !nilp( c ); c = c_cdr( c ) ) { + buffer[i++] = pointer_to_object( c )->payload.string.character; + } - wcstombs(result, buffer, len); - free(buffer); - } + 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); + 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; + return result; } /** @@ -197,93 +242,94 @@ char *lisp_string_to_c_string(struct pso_pointer s) { * @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; +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; + 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)); + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); - size_t count = 0; + 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; - } + 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]; + 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; - } - } + 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; + 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; +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; + 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; - } - } + case CFTYPE_CURL:{ + ungotten = wc; + break; + case CFTYPE_NONE: + break; + } + } - return result; + return result; } /** @@ -294,16 +340,17 @@ 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 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)); - } + 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; } /** @@ -314,18 +361,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; } /** @@ -340,186 +389,191 @@ struct pso_pointer push_back_character(struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer lisp_close(struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = nil; +struct pso_pointer 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) == 0) { - result = t; - } - } + 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; + return result; } -struct pso_pointer add_meta_integer(struct pso_pointer meta, wchar_t *key, - long int value) { - return c_cons(c_cons(c_string_to_lisp_keyword(key), make_integer(value)), - meta); +struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, + long int value ) { + return + c_cons( c_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); +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 c_cons( - c_cons(c_string_to_lisp_keyword(key), c_string_to_lisp_string(buffer)), - meta); + return + c_cons( c_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]; +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)); + strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), + localtime( value ) ); - return add_meta_string(meta, key, datestring); + 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); +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 + // TODO: reimplement - /* make a copy of the string that we can destructively change */ - // char *s = calloc( strlen( string ), sizeof( char ) ); + /* make a copy of the string that we can destructively change */ + // char *s = calloc( strlen( string ), sizeof( char ) ); - // strcpy( s, string ); + // strcpy( s, string ); - // if ( check_tag( cell, READTV) || - // check_tag( cell, WRITETV) ) { - // int offset = index_of( ':', s ); + // 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 )]; + // 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 ); + // mbstowcs( wname, name, strlen( name ) + 1 ); - // cell->payload.stream.meta = - // add_meta_string( cell->payload.stream.meta, wname, value ); + // 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] ); + // 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 ) ); + // 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 ); - // } + // 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 ); + // 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; +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); - } + 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); - } + 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_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; - } + 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; + /* 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; +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); + result = c_assoc( stream_name, env ); - return result; + return result; } /** * @brief if `s` points to either an input or an output stream, return the * URL_FILE pointer underlying that stream, else NULL. */ -URL_FILE *stream_get_url_file(struct pso_pointer s) { - URL_FILE *result = NULL; +URL_FILE *stream_get_url_file( struct pso_pointer s ) { + URL_FILE *result = NULL; - if (readp(s) || writep(s)) { - struct pso2 *obj = pointer_to_object(s); + if ( readp( s ) || writep( s ) ) { + struct pso2 *obj = pointer_to_object( s ); - result = obj->payload.stream.stream; - } + result = obj->payload.stream.stream; + } - return result; + return result; } /** @@ -537,59 +591,59 @@ URL_FILE *stream_get_url_file(struct pso_pointer s) { * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer lisp_open(struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = nil; +struct pso_pointer 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) ) ) { - // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); + // 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" ); + // 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 ); + // 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; - // } + // 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 ); - // } + // 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 ); - // } + // if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + // result = nil; + // } else { + // collect_meta( result, url ); + // } - // free( url ); - // } + // free( url ); + // } - return result; + return result; } /** @@ -604,18 +658,19 @@ struct pso_pointer lisp_open(struct pso_pointer frame_pointer, * @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 pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = nil; +struct pso_pointer 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; - struct pso_pointer stream_pointer = fetch_arg(frame, 0); - if (readp(stream_pointer)) { - result = - make_string(url_fgetwc(stream_get_url_file(stream_pointer)), nil); - } + struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); + if ( readp( stream_pointer ) ) { + result = + make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ), + nil ); + } - return result; + return result; } /** @@ -632,29 +687,29 @@ struct pso_pointer lisp_read_char(struct pso_pointer frame_pointer, * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer, - struct pso_pointer env) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = nil; +struct pso_pointer 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 = stream_get_url_file(fetch_arg(frame, 0)); - struct pso_pointer cursor = make_string(url_fgetwc(stream), nil); - result = cursor; + if ( readp( fetch_arg( frame, 0 ) ) ) { + URL_FILE *stream = stream_get_url_file( fetch_arg( frame, 0 ) ); + 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); + 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; - } - } + struct pso2 *cell = pointer_to_object( cursor ); + cursor = make_string( ( wchar_t ) c, nil ); + cell->payload.string.cdr = cursor; + } + } - return result; + return result; } diff --git a/src/c/io/io.h b/src/c/io/io.h index 995f508..7b04d75 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -23,9 +23,15 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" +#define C_IO_LOG L"*log*" extern struct pso_pointer lisp_io_in; extern struct pso_pointer lisp_io_out; +extern struct pso_pointer lisp_io_log; + +extern struct pso_pointer lisp_stdin; +extern struct pso_pointer lisp_stdout; +extern struct pso_pointer lisp_stderr; URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); diff --git a/src/c/io/print.c b/src/c/io/print.c index da89685..f65d9aa 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -39,106 +39,107 @@ #include "ops/truth.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_string_like_thing(struct pso_pointer p, - URL_FILE *output) { - switch (get_tag_value(p)) { - case KEYTV: - url_fputwc(L':', output); - break; - case STRINGTV: - url_fputwc(L'"', output); - break; - } +struct pso_pointer print_string_like_thing( struct pso_pointer p, + URL_FILE *output ) { + switch ( get_tag_value( p ) ) { + case KEYTV: + url_fputwc( L':', output ); + break; + case STRINGTV: + url_fputwc( L'"', output ); + break; + } - if (keywordp(p) || stringp(p) || symbolp(p)) { - for (struct pso_pointer cursor = p; !nilp(cursor); - cursor = pointer_to_object(cursor)->payload.string.cdr) { - url_fputwc(pointer_to_object(cursor)->payload.character.character, - output); - } - } + if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { + for ( struct pso_pointer cursor = p; !nilp( cursor ); + cursor = pointer_to_object( cursor )->payload.string.cdr ) { + url_fputwc( pointer_to_object( cursor )->payload.character. + character, output ); + } + } - if (stringp(p)) { - url_fputwc(L'"', output); - } + if ( stringp( p ) ) { + url_fputwc( L'"', 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 = c_cdr(p)) { - struct pso2 *object = pointer_to_object(p); + if ( consp( p ) ) { + for ( ; consp( p ); p = c_cdr( p ) ) { + struct pso2 *object = pointer_to_object( p ); - result = in_print(object->payload.cons.car, output); + result = in_print( object->payload.cons.car, output ); - if (exceptionp(result)) - break; + 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, output); - } - } - } else { - // TODO: return exception - } + 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, output ); + } + } + } else { + // TODO: return exception + } - return result; + return result; } -struct pso_pointer in_print(struct pso_pointer p, URL_FILE *output) { - struct pso2 *object = pointer_to_object(p); - struct pso_pointer result = nil; +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) { - uint32_t v = get_tag_value(p); - switch (v) { - case CHARACTERTV: - url_fputwc(object->payload.character.character, output); - break; - case CONSTV: - url_fputwc(L'(', 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)); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - print_string_like_thing(p, output); - break; - case NILTV: - url_fputws(L"nil", output); - break; - case READTV: - case WRITETV: - url_fwprintf(output, L"<%s stream: ", v == READTV ? "read" : "write"); - in_print(object->payload.stream.meta, output); - url_fputwc(L'>', output); - break; - case TRUETV: - url_fputwc(L't', output); - break; - default: - // TODO: return exception - } - } else { - // TODO: return exception - } + if ( object != NULL ) { + uint32_t v = get_tag_value( p ); + switch ( v ) { + case CHARACTERTV: + url_fputwc( object->payload.character.character, output ); + break; + case CONSTV: + url_fputwc( L'(', 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 ) ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + print_string_like_thing( p, output ); + break; + case NILTV: + url_fputws( L"nil", output ); + break; + case READTV: + case WRITETV: + url_fwprintf( output, L"<%s stream: ", + v == READTV ? "read" : "write" ); + in_print( object->payload.stream.meta, output ); + url_fputwc( L'>', output ); + break; + case TRUETV: + url_fputwc( L't', output ); + break; + default: + // TODO: return exception + } + } else { + // TODO: return exception + } - return result; + return result; } /** @@ -148,19 +149,19 @@ 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 c_print(struct pso_pointer p, struct pso_pointer stream) { - struct pso_pointer result = p; - URL_FILE *output = writep(stream) - ? pointer_to_object(stream)->payload.stream.stream - : file_to_url_file(stdout); +struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) { + struct pso_pointer result = p; + 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 ); - result = in_print(p, output); + result = in_print( p, output ); - dec_ref(stream); - } + dec_ref( stream ); + } - return result; + return result; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 2bd0c44..09e34aa 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -24,9 +24,6 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" -#include "memory/pso2.h" -#include "memory/pso2.h" -#include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -57,18 +54,20 @@ void c_repl( ) { struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); - - if (!readp(input_stream)) { - debug_print(L"Invalid read stream: ", DEBUG_IO, 0); - debug_print_object(input_stream, DEBUG_IO, 0); - } - if (!writep(output_stream)) { - debug_print(L"Invalid write stream: ", DEBUG_IO, 0); - debug_print_object(output_stream, DEBUG_IO, 0); - } - while ( readp( input_stream ) - && !url_feof( stream_get_url_file( input_stream ) ) ) { + if ( !readp( input_stream ) ) { + debug_print( L"Invalid read stream: ", DEBUG_IO, 0 ); + debug_print_object( input_stream, DEBUG_IO, 0 ); + input_stream = lisp_stdin; + } + if ( !writep( output_stream ) ) { + debug_print( L"Invalid write stream: ", DEBUG_IO, 0 ); + debug_print_object( output_stream, DEBUG_IO, 0 ); + output_stream = lisp_stdout; + } + + while ( readp( input_stream ) && + !url_feof( stream_get_url_file( input_stream ) ) ) { /* bottom of stack */ struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index f565234..18c8d55 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -81,11 +81,11 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, cell->payload.string.cdr = tail; cell->payload.string.hash = calculate_hash( c, tail ); - debug_printf( DEBUG_ALLOC, 0, - L"Building string-like-thing of type %3.3s: ", - cell->header.tag.bytes.mnemonic); - debug_print_object(pointer, DEBUG_ALLOC, 0); - debug_println(DEBUG_ALLOC); + debug_printf( DEBUG_ALLOC, 0, + L"Building string-like-thing of type %3.3s: ", + cell->header.tag.bytes.mnemonic ); + debug_print_object( pointer, DEBUG_ALLOC, 0 ); + debug_println( DEBUG_ALLOC ); } else { // \todo should throw an exception! struct pso2 *tobj = pointer_to_object( tail ); @@ -94,7 +94,7 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, tag, tobj->header.tag.bytes.mnemonic ); } - + return pointer; } @@ -145,8 +145,8 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { if ( string[i] != '"' ) { result = make_string( string[i], result ); } else { - result = make_string( L'\\', make_string( string[i], result)); - } + result = make_string( L'\\', make_string( string[i], result ) ); + } } return result; @@ -163,7 +163,7 @@ struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { wchar_t c = towlower( symbol[i] ); - if ( iswalpha( c ) || c == L'-' || c == L'*') { + if ( iswalpha( c ) || c == L'-' || c == L'*' ) { result = make_symbol( c, result ); } } diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 20e5284..0df03b5 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -69,7 +69,7 @@ struct pso_pointer c_car( struct pso_pointer cons ) { */ struct pso_pointer c_cdr( struct pso_pointer p ) { struct pso_pointer result = nil; - struct pso2 *object = pointer_to_object( result ); + struct pso2 *object = pointer_to_object( p ); switch ( get_tag_value( p ) ) { case CONSTV: diff --git a/src/c/psse.c b/src/c/psse.c index cd9b092..e49d614 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -12,21 +12,23 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include -#include #include "debug.h" -#include "psse.h" #include "io/io.h" +#include "psse.h" +#include "io/print.h" #include "memory/node.h" #include "memory/pso.h" #include "memory/tags.h" #include "ops/repl.h" #include "ops/stack_ops.h" +#include "ops/string_ops.h" #include "ops/truth.h" #include "payloads/cons.h" @@ -39,7 +41,7 @@ void print_banner( ) { /** * Print command line options to this `stream`. - * + * * @stream the stream to print to. */ void print_options( FILE *stream ) { @@ -67,7 +69,6 @@ void print_options( FILE *stream ) { #endif } - /** * main entry point; parse command line arguments, initialise the environment, * and enter the read-eval-print loop. @@ -124,7 +125,12 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - c_repl( ); + c_print( c_cons( c_string_to_lisp_keyword( L"a" ), + ( c_cons( c_string_to_lisp_keyword( L"b" ), + c_cons( c_string_to_lisp_keyword( L"c" ), + nil ) ) ) ), lisp_stdout ); + + // c_repl(); exit( 0 ); } From 9a0f186f29aec56952e89b1312ba6f81d31ba86b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 18 Apr 2026 15:44:14 +0100 Subject: [PATCH 38/77] Things working much better now. `assoc` works. Currently printing of string-like-things does not work, but I suspect that's shallow. --- docs/shipnames.md | 268 +++++++++++++++++++++++++++++++++++++++++ src/c/debug.c | 2 +- src/c/io/io.c | 16 ++- src/c/io/io.h | 5 + src/c/io/print.c | 86 ++++++++++--- src/c/io/print.h | 9 +- src/c/memory/destroy.c | 2 +- src/c/memory/pso.c | 17 ++- src/c/ops/eq.c | 10 +- src/c/ops/repl.c | 5 +- src/c/payloads/cons.c | 2 +- src/c/psse.c | 14 ++- src/c/version.h | 2 +- 13 files changed, 400 insertions(+), 38 deletions(-) create mode 100644 docs/shipnames.md diff --git a/docs/shipnames.md b/docs/shipnames.md new file mode 100644 index 0000000..b5186c2 --- /dev/null +++ b/docs/shipnames.md @@ -0,0 +1,268 @@ +# Ship names from Iain M Banks' Culture series + +This list is culled from the Wikipedia page. I don't know if it's comprehensive (although it looks it), and I haven't checked that all the names are either present in the books or spelled correctly here. I *think* they are, and that's good enough. + +Note that these names are not all Culture ships; and I think I should probably prefer only to select ones that are. + +The reason the list is here is that I propose to assign a codename taken from the list to each point release of Post Scarcity. starting from 0.1.0, which will be `A Momentary Lapse Of Sanity`. Names that have already been selected are **highlighted**. + +I think my plan is to assign 0.1.X point releases names starting with `A`, 0.2.X releases names starting with `B`, and so on; but I reserve the right to change my mind or just be wildly inconsistent. + +----- + +- 5Gelish-Oplule +- 7Uagren +- 8401.00 Partial Photic Boundary +- 8Churkun +- Abalule-Sheliz +- Ablation +- Abundance Of Onslaught +- Advanced Case Of Chronic Patheticism +- A Fine Disregard For Awkward Facts +- All The Same, I Saw It First +- **A Momentary Lapse Of Sanity** +- Another Fine Product From The Nonsense Factory +- Anticipation Of A New Lover's Arrival, The +- Anything Legal Considered +- Appeal To Reason +- Arbitrary +- Armchair Traveller +- Arrested Development +- A Series Of Unlikely Explanations +- A Ship With A View +- Attitude Adjuster +- Awkward Customer +- Bad For Business +- Beastly To The Animals +- Beats Working +- Big Sexy Beast +- Bodhisattva, OAQS +- Boo! +- Bora Horza Gobuchul +- Break Even +- But Who's Counting? +- Caconym +- Cantankerous +- Cargo Cult +- CH2OH.(CHOH)4.CHO +- Charitable View +- Charming But Irrational +- Clear Air Turbulence or CAT for short +- Congenital Optimist +- Contents May Differ +- Control Surface +- Conventional Wisdom +- Credibility Problem +- Death And Gravity +- Demented But Determined +- Determinist +- Different Tan +- Displacement Activity +- Don't Try This At Home +- Dramatic Exit +- Dressed Up To Party +- Eight Rounds Rapid +- Empiricist +- Eschatologist (temporary name) +- Ethics Gradient +- Exaltation-Parsimony III +- Excuses And Accusations +- Experiencing A Significant Gravitas Shortfall +- Experiencing A Significant Gravitas Shortfall +- Falling Outside The Normal Moral Constraints +- “Fasilyce, Upon Waking” +- Fate Amenable To Change +- Fine Till You Came Along +- Fixed Grin +- Flexible Demeanour +- Fractious Person +- Frank Exchange Of Views +- Frightspear +- Fulanya-Guang +- Full Refund (formerly MBU 604) +- Funny, It Worked Last Time... +- Furious Purpose +- Gellemtyan-Asool-Anafawaya +- Germane Riposte +- God Told Me To Do It +- Grey Area (aka Meatfucker) +- Grey Area (aka Meatfucker) +- Gunboat Diplomat +- Halation Effect +- Hand Me The Gun And Ask Me Again +- Happy Idiot Talk +- Headcrash +- Heavy Messing +- Helpless In The Face Of Your Beauty +- Hence the Fortress +- Heresiarch +- Hidden Income +- Highpoint +- Honest Mistake +- Hundredth Idiot, The +- Hylozoist +- Iberre +- I Blame My Mother +- I Blame The Parents +- I Blame Your Mother +- Inappropriate Response +- Injury Time +- In One Ear +- Inspiral, Coalescence, Ringdown +- Invincible +- Irregular Apocalypse +- I Said, I've Got A Big Stick +- I Thought He Was With You +- It'll Be Over By Christmas +- It's Character Forming +- It's My Party And I'll Sing If I Want To +- Jaundiced Outlook +- Joiler Veppers (provisional name) +- Just Another Victim Of The Ambient Morality +- Just Passing Through +- Just Read The Instructions +- Just Testing +- Just The Washing Instruction Chip In Life's Rich Tapestry +- Kakistocrat +- Killing Time +- Kiss My Ass +- Kiss The Blade +- Kiss This Then +- Labtebricolephile +- Lacking That Small Match Temperament +- Lapsed Pacifist +- Laskuil-Hliz +- Lasting Damage +- Lasting Damage I +- Lasting Damage II +- later Sleeper Service +- Learned Response +- Lightly Seared On The Reality Grill +- Limiting Factor +- Limivorous +- Little Rascal +- Liveware Problem“Now, Turning to Reason, & its Just Sweetness” +- Long View +- Lucid Nonsense +- Me, I'm Counting +- Melancholia Enshrines All Triumph +- Messenger Of Truth +- Minority Report +- Misophist +- Mistake Not… +- Nervous Energy +- Never Talk To Strangers +- New Toy +- No Fixed Abode +- No More Mr Nice Guy +- No One Knows What The Dead Think +- Not Invented Here +- Not Wanted On Voyage +- Now Look What You've Made Me Do +- Now We Try It My Way +- Nuisance Value +- Oceanic Dissonance +- Of Course I Still Love You +- “On First Seeing Jhiriit” +- Only Slightly Bent +- Outstanding Contribution To The Historical Process +- Passing By And Thought I'd Drop In +- Peace Makes Plenty +- Pelagian +- Perfidy +- Piety +- Poke It With A Stick +- Pressure Drop +- Pride Comes Before A Fall +- Prime Mover +- Problem Child +- Profit Margin +- Prosthetic Conscience +- Pure Big Mad Boat Man +- Qualifier +- Questionable Ethics +- Quiatrea-Anang +- Quietly Confident, +- Rapid Random Response Unit +- Ravished By The Sheer Implausibility Of That Last Statement +- Reasonable Excuse +- Recent Convert +- Reformed Nice Guy +- Refreshingly Unconcerned With The Vulgar Exigencies Of Veracity +- Resistance Is Character-Forming +- Revisionist +- Riptalon +- Rubric Of Ruin +- Sacrificial Victim +- SacSlicer II +- Sanctioned Parts List +- Scar Glamour +- Screw Loose +- Seed Drill +- Sense Amid Madness, Wit Amidst Folly +- Serious Callers Only +- Shoot Them Later +- Size Isn't Everything +- Smile Tolerantly +- Sober Counsel +- Someone Else's Problem +- So Much For Subtlety +- Soulhaven +- Space Monster +- Steely Glint +- Stranger Here Myself +- Subtle Shift In Emphasis +- Sweet and Full of Grace +- Synchronize Your Dogmas +- T3OU 118 +- T3OU 4 +- T3OU 736 +- Tactical Grace +- Teething Problems +- Thank You And Goodnight +- The Ends Of Invention +- The Hand of God 137 +- The Precise Nature Of The Catastrophe +- The Usual But Etymologically Unsatisfactory +- Thorough But... Unreliable +- Total Internal Reflection +- Trade Surplus +- Transient Atmospheric Phenomenon +- Ucalegon +- Ultimate Ship The Second +- Unacceptable Behaviour +- Undesirable Alien +- Unfortunate Conflict Of Evidence +- Uninvited Guest +- Unreliable Witness +- Unwitting Accomplice +- Use Psychology +- Value Judgement +- Very Little Gravitas Indeed +- Vision Of Hope Surpassed +- Vulgarian +- Warm, Considering +- We Haven't Met But You're A Great Fan Of Mine +- Well I Was In The Neighbourhood +- What Are The Civilian Applications? +- What Is The Answer And Why? +- Wingclipper +- Winter Storm +- Wisdom Like Silence +- Within Reason +- Xenoclast +- Xenocrat +- Xenoglossicist +- Xenophobe +- Yawning Angel +- You Call This Clean? +- You'll Clean That Up Before You Leave +- You'll Thank Me Later +- You May Not Be The Coolest Person Here +- You Naughty Monsters +- Youthful Indiscretion +- You Would If You Really Loved Me +- Zealot +- Zero Credibility +- Zero Gravitas +- Zoologist diff --git a/src/c/debug.c b/src/c/debug.c index 637d889..3665459 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -143,7 +143,7 @@ void debug_print_object( struct pso_pointer pointer, int level, int indent ) { if ( level & verbosity ) { URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - in_print( pointer, ustderr ); + in_write( pointer, ustderr, PRINT_VARIANT_PRINT ); free( ustderr ); } #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 35bd0b1..e23b512 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -89,7 +89,7 @@ struct pso_pointer lisp_io_out; struct pso_pointer lisp_stdout; /** - * @brief bound to the Lisp symbol representing C_IO_log in initialisation. + * @brief bound to the Lisp symbol representing C_IO_LOG in initialisation. */ struct pso_pointer lisp_io_log; @@ -99,6 +99,11 @@ struct pso_pointer lisp_io_log; */ struct pso_pointer lisp_stderr; +/** + * @brief bound to the Lisp symbol representing C_IO_PROMPT in initialisation + */ +struct pso_pointer lisp_io_prompt; + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. @@ -147,11 +152,16 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); + lisp_io_prompt = c_string_to_lisp_symbol( C_IO_PROMPT ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); + env = + c_bind( lisp_io_prompt, c_string_to_lisp_string( INITIAL_PROMPT ), + env ); + lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), c_cons( c_cons ( c_string_to_lisp_keyword @@ -367,8 +377,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload.character. - character ), + ( pointer_to_object( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; diff --git a/src/c/io/io.h b/src/c/io/io.h index 7b04d75..a2b733c 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -33,6 +33,11 @@ extern struct pso_pointer lisp_stdin; extern struct pso_pointer lisp_stdout; extern struct pso_pointer lisp_stderr; +#define INITIAL_PROMPT L"psse ]" +#define C_IO_PROMPT L"*prompt*" + +extern struct pso_pointer lisp_io_prompt; + 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 ); diff --git a/src/c/io/print.c b/src/c/io/print.c index f65d9aa..ed097a3 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -11,6 +11,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include @@ -26,6 +27,7 @@ #include "io/fopen.h" #include "io/io.h" +#include "io/print.h" #include "memory/node.h" #include "memory/pointer.h" @@ -33,22 +35,26 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "ops/string_ops.h" #include "payloads/character.h" #include "payloads/cons.h" +#include "payloads/exception.h" #include "payloads/integer.h" #include "ops/truth.h" -struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); +struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, + bool escape ); struct pso_pointer print_string_like_thing( struct pso_pointer p, - URL_FILE *output ) { + URL_FILE *output, bool escape ) { switch ( get_tag_value( p ) ) { case KEYTV: url_fputwc( L':', output ); break; case STRINGTV: - url_fputwc( L'"', output ); + if ( !escape ) + url_fputwc( L'"', output ); break; } @@ -61,18 +67,20 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, } if ( stringp( p ) ) { - url_fputwc( L'"', output ); + if ( !escape ) + url_fputwc( L'"', output ); } } -struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) { +struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output, + bool escape ) { struct pso_pointer result = nil; if ( consp( p ) ) { for ( ; consp( p ); p = c_cdr( p ) ) { struct pso2 *object = pointer_to_object( p ); - result = in_print( object->payload.cons.car, output ); + result = in_write( object->payload.cons.car, output, escape ); if ( exceptionp( result ) ) break; @@ -85,7 +93,8 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output ) break; default: url_fputws( L" . ", output ); - result = in_print( object->payload.cons.cdr, output ); + result = + in_write( object->payload.cons.cdr, output, escape ); } } } else { @@ -95,7 +104,18 @@ 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 ) { +/** + * This is kind of modelled after the implementation of PRIN* variants on page + * 383 of the aluminium book. It is the inner workings of all PRIN* functions. + * + * @param p pointer to the object to print. + * @param output stream to print to. + * @param escape if true, print everything so that it can be read by the Lisp + * reader; otherwise, print it appropriately for human readers. + * @return p on success, exception on failure. + */ +struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, + bool escape ) { struct pso2 *object = pointer_to_object( p ); struct pso_pointer result = nil; @@ -107,7 +127,7 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { break; case CONSTV: url_fputwc( L'(', output ); - result = print_list_content( p, output ); + result = print_list_content( p, output, escape ); url_fputwc( L')', output ); break; case INTEGERTV: @@ -117,7 +137,7 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { case KEYTV: case STRINGTV: case SYMBOLTV: - print_string_like_thing( p, output ); + print_string_like_thing( p, output, escape ); break; case NILTV: url_fputws( L"nil", output ); @@ -126,7 +146,7 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { case WRITETV: url_fwprintf( output, L"<%s stream: ", v == READTV ? "read" : "write" ); - in_print( object->payload.stream.meta, output ); + in_write( object->payload.stream.meta, output, escape ); url_fputwc( L'>', output ); break; case TRUETV: @@ -143,13 +163,19 @@ struct pso_pointer in_print( struct pso_pointer p, URL_FILE *output ) { } /** - * @brief Simple print for bootstrap layer. + * This is kind of modelled after the implementation of PRIN* variants on page + * 383 of the aluminium book. It is the inner workings of all PRIN* functions. * * @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. + * @param output stream to print to. + * @param escape if true, print everything so that it can be read by the Lisp + * reader; otherwise, print it appropriately for human readers. + * @param nl_before if true, print a newline *before* printing `p`. + * @param nl_after if true, print a newline *after* printing `p`; else a space. + * @return p on success, exception on failure. */ -struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) { +struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, + bool escape, bool nl_before, bool nl_after ) { struct pso_pointer result = p; URL_FILE *output = writep( stream ) ? pointer_to_object( stream )->payload.stream.stream @@ -158,10 +184,38 @@ struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) { if ( writep( stream ) ) { inc_ref( stream ); - result = in_print( p, output ); + if ( nl_before ) + url_fputwc( L'\n', output ); + + result = in_write( p, output, true ); + + url_fputwc( nl_after ? L'\n' : L' ', output ); dec_ref( stream ); + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Bad write stream passed to write." ), nil, nil, + nil ); } 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 c_print( struct pso_pointer p, struct pso_pointer stream ) { + return write( p, stream, true, true, false ); +} + +/** + * @brief princ is pretty much like print except things are printed `unescaped` + */ +struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) { + return write( p, stream, false, true, false ); +} diff --git a/src/c/io/print.h b/src/c/io/print.h index 39b7d41..d239913 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -13,10 +13,17 @@ #ifndef __psse_io_print_h #define __psse_io_print_h +#include #include "io/fopen.h" struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ); +struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ); -struct pso_pointer in_print( struct pso_pointer p, URL_FILE * output ); +#define PRINT_VARIANT_PRINT 0 +#define PRINT_VARIANT_PRIN1 1 +#define PRINT_VARIANT_PRINC 2 + +struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, + bool variant ); #endif diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c index d8c0db4..41adcb6 100644 --- a/src/c/memory/destroy.c +++ b/src/c/memory/destroy.c @@ -55,7 +55,7 @@ struct pso_pointer destroy( struct pso_pointer p ) { destroy_string( f, nil ); break; case STACKTV: - destroy_stack_frame( f, nil ); +// destroy_stack_frame( f, nil ); break; // TODO: others. } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index c925906..4b7ba2c 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -14,7 +14,9 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include +#include #include #include @@ -92,10 +94,15 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { return result; } -uint32_t payload_size( struct pso2 *object ) { +int payload_size( struct pso2 *object ) { // TODO: Unit tests DEFINITELY needed! - return ( ( 1 << object->header.tag.bytes.size_class ) - - sizeof( struct pso_header ) ); + int sc = object->header.tag.bytes.size_class; + int hs = sizeof( struct pso_header ) / sizeof( uint64_t ); + int p = pow( 2, sc ); + + int result = abs( p - hs ); + + return result; } /** @@ -190,8 +197,8 @@ struct pso_pointer lock_object( struct pso_pointer pointer ) { 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; + uint32_t array_size = ( uint32_t ) payload_size( obj ); + uint8_t size_class = ( obj->header.tag.bytes.size_class ); result = destroy( p ); diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index d5b348e..101ea51 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -41,7 +41,7 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ) { } bool c_equal( struct pso_pointer a, struct pso_pointer b ) { - bool result = false; + bool result = true; if ( c_eq( a, b ) ) { result = true; @@ -66,15 +66,19 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { case KEYTV: case STRINGTV: case SYMBOLTV: - while ( !nilp( a ) && !nilp( b ) ) { + while ( result && !nilp( a ) && !nilp( b ) ) { if ( pointer_to_object( a )->payload.string.character == pointer_to_object( b )->payload.string.character ) { a = c_cdr( a ); b = c_cdr( b ); + } else { + result = false; } } - result = nilp( a ) && nilp( b ); + result = result && nilp( a ) && nilp( b ); break; + default: + result = false; } } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 09e34aa..24067c6 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -47,7 +47,7 @@ void int_handler( int dummy ) { /** * Very simple read/eval/print loop for bootstrapping. */ -void c_repl( ) { +void c_repl( bool show_prompt ) { signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); @@ -68,6 +68,9 @@ void c_repl( ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { + if ( show_prompt ) + c_princ( c_assoc( lisp_io_prompt, env ), output_stream ); + /* bottom of stack */ struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 0df03b5..4338468 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -50,7 +50,7 @@ struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ) { */ struct pso_pointer c_car( struct pso_pointer cons ) { struct pso_pointer result = nil; - struct pso2 *object = pointer_to_object( result ); + struct pso2 *object = pointer_to_object( cons ); if ( consp( cons ) ) { result = object->payload.cons.car; diff --git a/src/c/psse.c b/src/c/psse.c index e49d614..f1f4e13 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -125,12 +125,16 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - c_print( c_cons( c_string_to_lisp_keyword( L"a" ), - ( c_cons( c_string_to_lisp_keyword( L"b" ), - c_cons( c_string_to_lisp_keyword( L"c" ), - nil ) ) ) ), lisp_stdout ); + if ( show_prompt ) { + fwprintf( stdout, + L"Post-scarcity Software Environment version %s\n'%s'\n\n", + VERSION, VERSION_CODENAME ); + fputws + ( L"Licensed under GPL version 2.0, or, at your option, any later version\n\n", + stdout ); + } - // c_repl(); + c_repl( show_prompt ); exit( 0 ); } diff --git a/src/c/version.h b/src/c/version.h index d6b3f2b..1c99f9f 100644 --- a/src/c/version.h +++ b/src/c/version.h @@ -3,9 +3,9 @@ * * 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" +#define VERSION_CODENAME "A Momentary Lapse Of Sanity" From 0e8712a0760e816bec619232293595ed3e10794d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 18 Apr 2026 17:20:19 +0100 Subject: [PATCH 39/77] Further work on print; still not working properly. --- src/c/io/print.c | 265 +++++++++++++++++++++++++---------------------- 1 file changed, 142 insertions(+), 123 deletions(-) diff --git a/src/c/io/print.c b/src/c/io/print.c index ed097a3..ca0e5c1 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -11,8 +11,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include #include +#include #include #include #include @@ -43,65 +43,85 @@ #include "ops/truth.h" -struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, - bool escape ); - -struct pso_pointer print_string_like_thing( struct pso_pointer p, - URL_FILE *output, bool escape ) { - switch ( get_tag_value( p ) ) { - case KEYTV: - url_fputwc( L':', output ); - break; - case STRINGTV: - if ( !escape ) - url_fputwc( L'"', output ); - break; - } - - if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { - for ( struct pso_pointer cursor = p; !nilp( cursor ); - cursor = pointer_to_object( cursor )->payload.string.cdr ) { - url_fputwc( pointer_to_object( cursor )->payload.character. - character, output ); - } - } - - if ( stringp( p ) ) { - if ( !escape ) - url_fputwc( L'"', output ); - } +struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, + bool escape); + +/** + * @brief write this character `wc` to this `output` stream, escaping it if + * 1. `escape` is true; and + * 2. it is a character which the reader would otherwise not cope with. + * + * TODO: this does not yet even nearly cope with all the possible special + * cases. + */ +void write_char( wchar_t wc, URL_FILE * output, bool escape) { + if (escape && !iswprint(wc)) { + url_fwprintf(output, L"\\%04x", wc); + // url_fputwc(L'\\', output); + } else { + url_fputwc(wc, output); + } } -struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output, - bool escape ) { - struct pso_pointer result = nil; - if ( consp( p ) ) { - for ( ; consp( p ); p = c_cdr( p ) ) { - struct pso2 *object = pointer_to_object( p ); +struct pso_pointer print_string_like_thing(struct pso_pointer p, + URL_FILE *output, bool escape) { + switch (get_tag_value(p)) { + case KEYTV: + url_fputwc(L':', output); + break; + case STRINGTV: + if (escape) + url_fputwc(L'"', output); + break; + } - result = in_write( object->payload.cons.car, output, escape ); + if (keywordp(p) || stringp(p) || symbolp(p)) { + for (struct pso_pointer cursor = p; !nilp(cursor); + cursor = pointer_to_object(cursor)->payload.string.cdr) { + wchar_t wc = pointer_to_object(cursor)->payload.string.character; - if ( exceptionp( result ) ) - break; + write_char( wc, output, escape); + } + } - 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_write( object->payload.cons.cdr, output, escape ); - } - } - } else { - // TODO: return exception - } + if (stringp(p)) { + if (escape) + url_fputwc(L'"', output); + } + + return p; +} - return result; +struct pso_pointer write_list_content(struct pso_pointer p, URL_FILE *output, + bool escape) { + struct pso_pointer result = nil; + + if (consp(p)) { + for (; consp(p); p = c_cdr(p)) { + struct pso2 *object = pointer_to_object(p); + + result = in_write(object->payload.cons.car, output, escape); + + 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_write(object->payload.cons.cdr, output, escape); + } + } + } else { + // TODO: return exception + } + + return result; } /** @@ -110,56 +130,56 @@ struct pso_pointer print_list_content( struct pso_pointer p, URL_FILE *output, * * @param p pointer to the object to print. * @param output stream to print to. - * @param escape if true, print everything so that it can be read by the Lisp + * @param escape if true, print everything so that it can be read by the Lisp * reader; otherwise, print it appropriately for human readers. * @return p on success, exception on failure. */ -struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, - bool escape ) { - struct pso2 *object = pointer_to_object( p ); - struct pso_pointer result = nil; +struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, + bool escape) { + struct pso2 *object = pointer_to_object(p); + struct pso_pointer result = nil; - if ( object != NULL ) { - uint32_t v = get_tag_value( p ); - switch ( v ) { - case CHARACTERTV: - url_fputwc( object->payload.character.character, output ); - break; - case CONSTV: - url_fputwc( L'(', output ); - result = print_list_content( p, output, escape ); - url_fputwc( L')', output ); - break; - case INTEGERTV: - url_fwprintf( output, L"%d", - ( int64_t ) ( object->payload.integer.value ) ); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - print_string_like_thing( p, output, escape ); - break; - case NILTV: - url_fputws( L"nil", output ); - break; - case READTV: - case WRITETV: - url_fwprintf( output, L"<%s stream: ", - v == READTV ? "read" : "write" ); - in_write( object->payload.stream.meta, output, escape ); - url_fputwc( L'>', output ); - break; - case TRUETV: - url_fputwc( L't', output ); - break; - default: - // TODO: return exception - } - } else { - // TODO: return exception - } + if (object != NULL) { + uint32_t v = get_tag_value(p); + switch (v) { + case CHARACTERTV: + write_char(object->payload.character.character, output, escape); + break; + case CONSTV: + url_fputwc(L'(', output); + result = write_list_content(p, output, escape); + url_fputwc(L')', output); + break; + case INTEGERTV: + url_fwprintf(output, L"%d", + (int64_t)(object->payload.integer.value)); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + print_string_like_thing(p, output, escape); + break; + case NILTV: + url_fputws(L"nil", output); + break; + case READTV: + case WRITETV: + url_fwprintf(output, L"<%s stream: ", + v == READTV ? "read" : "write"); + in_write(object->payload.stream.meta, output, escape); + url_fputwc(L'>', output); + break; + case TRUETV: + url_fputwc(L't', output); + break; + default: + // TODO: return exception + } + } else { + // TODO: return exception + } - return result; + return result; } /** @@ -168,38 +188,37 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, * * @param p pointer to the object to print. * @param output stream to print to. - * @param escape if true, print everything so that it can be read by the Lisp + * @param escape if true, print everything so that it can be read by the Lisp * reader; otherwise, print it appropriately for human readers. * @param nl_before if true, print a newline *before* printing `p`. * @param nl_after if true, print a newline *after* printing `p`; else a space. * @return p on success, exception on failure. */ -struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after ) { - struct pso_pointer result = p; - URL_FILE *output = writep( stream ) - ? pointer_to_object( stream )->payload.stream.stream - : file_to_url_file( stdout ); +struct pso_pointer write(struct pso_pointer p, struct pso_pointer stream, + bool escape, bool nl_before, bool nl_after) { + struct pso_pointer result = p; + 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); - if ( nl_before ) - url_fputwc( L'\n', output ); + if (nl_before) + url_fputwc(L'\n', output); - result = in_write( p, output, true ); + result = in_write(p, output, true); - url_fputwc( nl_after ? L'\n' : L' ', output ); + url_fputwc(nl_after ? L'\n' : L' ', output); - dec_ref( stream ); - } else { - result = - make_exception( c_string_to_lisp_string - ( L"Bad write stream passed to write." ), nil, nil, - nil ); - } + dec_ref(stream); + } else { + result = make_exception( + c_string_to_lisp_string(L"Bad write stream passed to write."), nil, + nil, nil); + } - return result; + return result; } /** @@ -209,13 +228,13 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer 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 c_print( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, true, true, false ); +struct pso_pointer c_print(struct pso_pointer p, struct pso_pointer stream) { + return write(p, stream, true, true, false); } /** * @brief princ is pretty much like print except things are printed `unescaped` */ -struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, false, true, false ); +struct pso_pointer c_princ(struct pso_pointer p, struct pso_pointer stream) { + return write(p, stream, false, true, false); } From 521c5d22850580ceed7562106702918ea8a26e44 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 19 Apr 2026 13:32:00 +0100 Subject: [PATCH 40/77] Work on customising Doxygen output. --- .gitignore | 3 + Doxyfile | 975 ++++++++++++++------- customdoxygen.css | 2045 +++++++++++++++++++++++++++++++++++++++++++++ footer.html | 17 + 4 files changed, 2735 insertions(+), 305 deletions(-) create mode 100644 customdoxygen.css create mode 100644 footer.html diff --git a/.gitignore b/.gitignore index 300398f..17fc3a8 100644 --- a/.gitignore +++ b/.gitignore @@ -56,3 +56,6 @@ post-scarcity.kdev4 sq/ tmp/ utils_src/a.out + +header.html +footer.html diff --git a/Doxyfile b/Doxyfile index bb8427d..f05fd15 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 @@ -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 = tmp/doxy.log @@ -790,17 +943,30 @@ WARN_LOGFILE = tmp/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_LIGHT + # 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/customdoxygen.css b/customdoxygen.css new file mode 100644 index 0000000..009a9b5 --- /dev/null +++ b/customdoxygen.css @@ -0,0 +1,2045 @@ +/* The standard CSS for doxygen 1.9.8*/ + +html { +/* page base colors */ +--page-background-color: white; +--page-foreground-color: black; +--page-link-color: #3D578C; +--page-visited-link-color: #4665A2; + +/* index */ +--index-odd-item-bg-color: #F8F9FC; +--index-even-item-bg-color: white; +--index-header-color: black; +--index-separator-color: #A0A0A0; + +/* header */ +--header-background-color: #F9FAFC; +--header-separator-color: #C4CFE5; +--header-gradient-image: url('nav_h.png'); +--group-header-separator-color: #879ECB; +--group-header-color: #354C7B; +--inherit-header-color: gray; + +--footer-foreground-color: #2A3D61; +--footer-logo-width: 104px; +--citation-label-color: #334975; +--glow-color: cyan; + +--title-background-color: white; +--title-separator-color: #5373B4; +--directory-separator-color: #9CAFD4; +--separator-color: #4A6AAA; + +--blockquote-background-color: #F7F8FB; +--blockquote-border-color: #9CAFD4; + +--scrollbar-thumb-color: #9CAFD4; +--scrollbar-background-color: #F9FAFC; + +--icon-background-color: #728DC1; +--icon-foreground-color: white; +--icon-doc-image: url('doc.svg'); +--icon-folder-open-image: url('folderopen.svg'); +--icon-folder-closed-image: url('folderclosed.svg'); + +/* brief member declaration list */ +--memdecl-background-color: #F9FAFC; +--memdecl-separator-color: #DEE4F0; +--memdecl-foreground-color: #555; +--memdecl-template-color: #4665A2; + +/* detailed member list */ +--memdef-border-color: #A8B8D9; +--memdef-title-background-color: #E2E8F2; +--memdef-title-gradient-image: url('nav_f.png'); +--memdef-proto-background-color: #DFE5F1; +--memdef-proto-text-color: #253555; +--memdef-proto-text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); +--memdef-doc-background-color: white; +--memdef-param-name-color: #602020; +--memdef-template-color: #4665A2; + +/* tables */ +--table-cell-border-color: #2D4068; +--table-header-background-color: #374F7F; +--table-header-foreground-color: #FFFFFF; + +/* labels */ +--label-background-color: #728DC1; +--label-left-top-border-color: #5373B4; +--label-right-bottom-border-color: #C4CFE5; +--label-foreground-color: white; + +/** navigation bar/tree/menu */ +--nav-background-color: #F9FAFC; +--nav-foreground-color: #364D7C; +--nav-gradient-image: url('tab_b.png'); +--nav-gradient-hover-image: url('tab_h.png'); +--nav-gradient-active-image: url('tab_a.png'); +--nav-gradient-active-image-parent: url("../tab_a.png"); +--nav-separator-image: url('tab_s.png'); +--nav-breadcrumb-image: url('bc_s.png'); +--nav-breadcrumb-border-color: #C2CDE4; +--nav-splitbar-image: url('splitbar.png'); +--nav-font-size-level1: 13px; +--nav-font-size-level2: 10px; +--nav-font-size-level3: 9px; +--nav-text-normal-color: #283A5D; +--nav-text-hover-color: white; +--nav-text-active-color: white; +--nav-text-normal-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); +--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-menu-button-color: #364D7C; +--nav-menu-background-color: white; +--nav-menu-foreground-color: #555555; +--nav-menu-toggle-color: rgba(255, 255, 255, 0.5); +--nav-arrow-color: #9CAFD4; +--nav-arrow-selected-color: #9CAFD4; + +/* table of contents */ +--toc-background-color: #F4F6FA; +--toc-border-color: #D8DFEE; +--toc-header-color: #4665A2; +--toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); + +/** search field */ +--search-background-color: white; +--search-foreground-color: #909090; +--search-magnification-image: url('mag.svg'); +--search-magnification-select-image: url('mag_sel.svg'); +--search-active-color: black; +--search-filter-background-color: #F9FAFC; +--search-filter-foreground-color: black; +--search-filter-border-color: #90A5CE; +--search-filter-highlight-text-color: white; +--search-filter-highlight-bg-color: #3D578C; +--search-results-foreground-color: #425E97; +--search-results-background-color: #EEF1F7; +--search-results-border-color: black; +--search-box-shadow: inset 0.5px 0.5px 3px 0px #555; + +/** code fragments */ +--code-keyword-color: #008000; +--code-type-keyword-color: #604020; +--code-flow-keyword-color: #E08000; +--code-comment-color: #800000; +--code-preprocessor-color: #806020; +--code-string-literal-color: #002080; +--code-char-literal-color: #008080; +--code-xml-cdata-color: black; +--code-vhdl-digit-color: #FF00FF; +--code-vhdl-char-color: #000000; +--code-vhdl-keyword-color: #700070; +--code-vhdl-logic-color: #FF0000; +--code-link-color: #4665A2; +--code-external-link-color: #4665A2; +--fragment-foreground-color: black; +--fragment-background-color: #FBFCFD; +--fragment-border-color: #C4CFE5; +--fragment-lineno-border-color: #00FF00; +--fragment-lineno-background-color: #E8E8E8; +--fragment-lineno-foreground-color: black; +--fragment-lineno-link-fg-color: #4665A2; +--fragment-lineno-link-bg-color: #D8D8D8; +--fragment-lineno-link-hover-fg-color: #4665A2; +--fragment-lineno-link-hover-bg-color: #C8C8C8; +--tooltip-foreground-color: black; +--tooltip-background-color: white; +--tooltip-border-color: gray; +--tooltip-doc-color: grey; +--tooltip-declaration-color: #006318; +--tooltip-link-color: #4665A2; +--tooltip-shadow: 1px 1px 7px gray; +--fold-line-color: #808080; +--fold-minus-image: url('minus.svg'); +--fold-plus-image: url('plus.svg'); +--fold-minus-image-relpath: url('../../minus.svg'); +--fold-plus-image-relpath: url('../../plus.svg'); + +/** font-family */ +--font-family-normal: Roboto,sans-serif; +--font-family-monospace: 'JetBrains Mono',Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace,fixed; +--font-family-nav: 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; +--font-family-title: Tahoma,Arial,sans-serif; +--font-family-toc: Verdana,'DejaVu Sans',Geneva,sans-serif; +--font-family-search: Arial,Verdana,sans-serif; +--font-family-icon: Arial,Helvetica; +--font-family-tooltip: Roboto,sans-serif; + +} + +@media (prefers-color-scheme: dark) { + html:not(.dark-mode) { + color-scheme: dark; + +/* page base colors */ +--page-background-color: black; +--page-foreground-color: #C9D1D9; +--page-link-color: #90A5CE; +--page-visited-link-color: #A3B4D7; + +/* index */ +--index-odd-item-bg-color: #0B101A; +--index-even-item-bg-color: black; +--index-header-color: #C4CFE5; +--index-separator-color: #334975; + +/* header */ +--header-background-color: #070B11; +--header-separator-color: #141C2E; +--header-gradient-image: url('nav_hd.png'); +--group-header-separator-color: #283A5D; +--group-header-color: #90A5CE; +--inherit-header-color: #A0A0A0; + +--footer-foreground-color: #5B7AB7; +--footer-logo-width: 60px; +--citation-label-color: #90A5CE; +--glow-color: cyan; + +--title-background-color: #090D16; +--title-separator-color: #354C79; +--directory-separator-color: #283A5D; +--separator-color: #283A5D; + +--blockquote-background-color: #101826; +--blockquote-border-color: #283A5D; + +--scrollbar-thumb-color: #283A5D; +--scrollbar-background-color: #070B11; + +--icon-background-color: #334975; +--icon-foreground-color: #C4CFE5; +--icon-doc-image: url('docd.svg'); +--icon-folder-open-image: url('folderopend.svg'); +--icon-folder-closed-image: url('folderclosedd.svg'); + +/* brief member declaration list */ +--memdecl-background-color: #0B101A; +--memdecl-separator-color: #2C3F65; +--memdecl-foreground-color: #BBB; +--memdecl-template-color: #7C95C6; + +/* detailed member list */ +--memdef-border-color: #233250; +--memdef-title-background-color: #1B2840; +--memdef-title-gradient-image: url('nav_fd.png'); +--memdef-proto-background-color: #19243A; +--memdef-proto-text-color: #9DB0D4; +--memdef-proto-text-shadow: 0px 1px 1px rgba(0, 0, 0, 0.9); +--memdef-doc-background-color: black; +--memdef-param-name-color: #D28757; +--memdef-template-color: #7C95C6; + +/* tables */ +--table-cell-border-color: #283A5D; +--table-header-background-color: #283A5D; +--table-header-foreground-color: #C4CFE5; + +/* labels */ +--label-background-color: #354C7B; +--label-left-top-border-color: #4665A2; +--label-right-bottom-border-color: #283A5D; +--label-foreground-color: #CCCCCC; + +/** navigation bar/tree/menu */ +--nav-background-color: #101826; +--nav-foreground-color: #364D7C; +--nav-gradient-image: url('tab_bd.png'); +--nav-gradient-hover-image: url('tab_hd.png'); +--nav-gradient-active-image: url('tab_ad.png'); +--nav-gradient-active-image-parent: url("../tab_ad.png"); +--nav-separator-image: url('tab_sd.png'); +--nav-breadcrumb-image: url('bc_sd.png'); +--nav-breadcrumb-border-color: #2A3D61; +--nav-splitbar-image: url('splitbard.png'); +--nav-font-size-level1: 13px; +--nav-font-size-level2: 10px; +--nav-font-size-level3: 9px; +--nav-text-normal-color: #B6C4DF; +--nav-text-hover-color: #DCE2EF; +--nav-text-active-color: #DCE2EF; +--nav-text-normal-shadow: 0px 1px 1px black; +--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-menu-button-color: #B6C4DF; +--nav-menu-background-color: #05070C; +--nav-menu-foreground-color: #BBBBBB; +--nav-menu-toggle-color: rgba(255, 255, 255, 0.2); +--nav-arrow-color: #334975; +--nav-arrow-selected-color: #90A5CE; + +/* table of contents */ +--toc-background-color: #151E30; +--toc-border-color: #202E4A; +--toc-header-color: #A3B4D7; +--toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); + +/** search field */ +--search-background-color: black; +--search-foreground-color: #C5C5C5; +--search-magnification-image: url('mag_d.svg'); +--search-magnification-select-image: url('mag_seld.svg'); +--search-active-color: #C5C5C5; +--search-filter-background-color: #101826; +--search-filter-foreground-color: #90A5CE; +--search-filter-border-color: #7C95C6; +--search-filter-highlight-text-color: #BCC9E2; +--search-filter-highlight-bg-color: #283A5D; +--search-results-background-color: #101826; +--search-results-foreground-color: #90A5CE; +--search-results-border-color: #7C95C6; +--search-box-shadow: inset 0.5px 0.5px 3px 0px #2F436C; + +/** code fragments */ +--code-keyword-color: #CC99CD; +--code-type-keyword-color: #AB99CD; +--code-flow-keyword-color: #E08000; +--code-comment-color: #717790; +--code-preprocessor-color: #65CABE; +--code-string-literal-color: #7EC699; +--code-char-literal-color: #00E0F0; +--code-xml-cdata-color: #C9D1D9; +--code-vhdl-digit-color: #FF00FF; +--code-vhdl-char-color: #C0C0C0; +--code-vhdl-keyword-color: #CF53C9; +--code-vhdl-logic-color: #FF0000; +--code-link-color: #79C0FF; +--code-external-link-color: #79C0FF; +--fragment-foreground-color: #C9D1D9; +--fragment-background-color: black; +--fragment-border-color: #30363D; +--fragment-lineno-border-color: #30363D; +--fragment-lineno-background-color: black; +--fragment-lineno-foreground-color: #6E7681; +--fragment-lineno-link-fg-color: #6E7681; +--fragment-lineno-link-bg-color: #303030; +--fragment-lineno-link-hover-fg-color: #8E96A1; +--fragment-lineno-link-hover-bg-color: #505050; +--tooltip-foreground-color: #C9D1D9; +--tooltip-background-color: #202020; +--tooltip-border-color: #C9D1D9; +--tooltip-doc-color: #D9E1E9; +--tooltip-declaration-color: #20C348; +--tooltip-link-color: #79C0FF; +--tooltip-shadow: none; +--fold-line-color: #808080; +--fold-minus-image: url('minusd.svg'); +--fold-plus-image: url('plusd.svg'); +--fold-minus-image-relpath: url('../../minusd.svg'); +--fold-plus-image-relpath: url('../../plusd.svg'); + +/** font-family */ +--font-family-normal: Roboto,sans-serif; +--font-family-monospace: 'JetBrains Mono',Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace,fixed; +--font-family-nav: 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; +--font-family-title: Tahoma,Arial,sans-serif; +--font-family-toc: Verdana,'DejaVu Sans',Geneva,sans-serif; +--font-family-search: Arial,Verdana,sans-serif; +--font-family-icon: Arial,Helvetica; +--font-family-tooltip: Roboto,sans-serif; + +}} +body { + background-color: var(--page-background-color); + color: var(--page-foreground-color); +} + +body, table, div, p, dl { + font-weight: 400; + font-size: 14px; + font-family: var(--font-family-normal); + line-height: 22px; +} + +/* @group Heading Levels */ + +.title { + font-weight: 400; + font-size: 14px; + font-family: var(--font-family-normal); + line-height: 28px; + font-size: 150%; + font-weight: bold; + margin: 10px 2px; +} + +h1.groupheader { + font-size: 150%; +} + +h2.groupheader { + border-bottom: 1px solid var(--group-header-separator-color); + color: var(--group-header-color); + font-size: 150%; + font-weight: normal; + margin-top: 1.75em; + padding-top: 8px; + padding-bottom: 4px; + width: 100%; +} + +h3.groupheader { + font-size: 100%; +} + +h1, h2, h3, h4, h5, h6 { + -webkit-transition: text-shadow 0.5s linear; + -moz-transition: text-shadow 0.5s linear; + -ms-transition: text-shadow 0.5s linear; + -o-transition: text-shadow 0.5s linear; + transition: text-shadow 0.5s linear; + margin-right: 15px; +} + +h1.glow, h2.glow, h3.glow, h4.glow, h5.glow, h6.glow { + text-shadow: 0 0 15px var(--glow-color); +} + +dt { + font-weight: bold; +} + +p.startli, p.startdd { + margin-top: 2px; +} + +th p.starttd, th p.intertd, th p.endtd { + font-size: 100%; + font-weight: 700; +} + +p.starttd { + margin-top: 0px; +} + +p.endli { + margin-bottom: 0px; +} + +p.enddd { + margin-bottom: 4px; +} + +p.endtd { + margin-bottom: 2px; +} + +p.interli { +} + +p.interdd { +} + +p.intertd { +} + +/* @end */ + +caption { + font-weight: bold; +} + +span.legend { + font-size: 70%; + text-align: center; +} + +h3.version { + font-size: 90%; + text-align: center; +} + +div.navtab { + padding-right: 15px; + text-align: right; + line-height: 110%; +} + +div.navtab table { + border-spacing: 0; +} + +td.navtab { + padding-right: 6px; + padding-left: 6px; +} + +td.navtabHL { + background-image: var(--nav-gradient-active-image); + background-repeat:repeat-x; + padding-right: 6px; + padding-left: 6px; +} + +td.navtabHL a, td.navtabHL a:visited { + color: var(--nav-text-hover-color); + text-shadow: var(--nav-text-hover-shadow); +} + +a.navtab { + font-weight: bold; +} + +div.qindex{ + text-align: center; + width: 100%; + line-height: 140%; + font-size: 130%; + color: var(--index-separator-color); +} + +#main-menu a:focus { + outline: auto; + z-index: 10; + position: relative; +} + +dt.alphachar{ + font-size: 180%; + font-weight: bold; +} + +.alphachar a{ + color: var(--index-header-color); +} + +.alphachar a:hover, .alphachar a:visited{ + text-decoration: none; +} + +.classindex dl { + padding: 25px; + column-count:1 +} + +.classindex dd { + display:inline-block; + margin-left: 50px; + width: 90%; + line-height: 1.15em; +} + +.classindex dl.even { + background-color: var(--index-even-item-bg-color); +} + +.classindex dl.odd { + background-color: var(--index-odd-item-bg-color); +} + +@media(min-width: 1120px) { + .classindex dl { + column-count:2 + } +} + +@media(min-width: 1320px) { + .classindex dl { + column-count:3 + } +} + + +/* @group Link Styling */ + +a { + color: var(--page-link-color); + font-weight: normal; + text-decoration: none; +} + +.contents a:visited { + color: var(--page-visited-link-color); +} + +a:hover { + text-decoration: underline; +} + +a.el { + font-weight: bold; +} + +a.elRef { +} + +a.code, a.code:visited, a.line, a.line:visited { + color: var(--code-link-color); +} + +a.codeRef, a.codeRef:visited, a.lineRef, a.lineRef:visited { + color: var(--code-external-link-color); +} + +a.code.hl_class { /* style for links to class names in code snippets */ } +a.code.hl_struct { /* style for links to struct names in code snippets */ } +a.code.hl_union { /* style for links to union names in code snippets */ } +a.code.hl_interface { /* style for links to interface names in code snippets */ } +a.code.hl_protocol { /* style for links to protocol names in code snippets */ } +a.code.hl_category { /* style for links to category names in code snippets */ } +a.code.hl_exception { /* style for links to exception names in code snippets */ } +a.code.hl_service { /* style for links to service names in code snippets */ } +a.code.hl_singleton { /* style for links to singleton names in code snippets */ } +a.code.hl_concept { /* style for links to concept names in code snippets */ } +a.code.hl_namespace { /* style for links to namespace names in code snippets */ } +a.code.hl_package { /* style for links to package names in code snippets */ } +a.code.hl_define { /* style for links to macro names in code snippets */ } +a.code.hl_function { /* style for links to function names in code snippets */ } +a.code.hl_variable { /* style for links to variable names in code snippets */ } +a.code.hl_typedef { /* style for links to typedef names in code snippets */ } +a.code.hl_enumvalue { /* style for links to enum value names in code snippets */ } +a.code.hl_enumeration { /* style for links to enumeration names in code snippets */ } +a.code.hl_signal { /* style for links to Qt signal names in code snippets */ } +a.code.hl_slot { /* style for links to Qt slot names in code snippets */ } +a.code.hl_friend { /* style for links to friend names in code snippets */ } +a.code.hl_dcop { /* style for links to KDE3 DCOP names in code snippets */ } +a.code.hl_property { /* style for links to property names in code snippets */ } +a.code.hl_event { /* style for links to event names in code snippets */ } +a.code.hl_sequence { /* style for links to sequence names in code snippets */ } +a.code.hl_dictionary { /* style for links to dictionary names in code snippets */ } + +/* @end */ + +dl.el { + margin-left: -1cm; +} + +ul { + overflow: visible; +} + +ul.multicol { + -moz-column-gap: 1em; + -webkit-column-gap: 1em; + column-gap: 1em; + -moz-column-count: 3; + -webkit-column-count: 3; + column-count: 3; + list-style-type: none; +} + +#side-nav ul { + overflow: visible; /* reset ul rule for scroll bar in GENERATE_TREEVIEW window */ +} + +#main-nav ul { + overflow: visible; /* reset ul rule for the navigation bar drop down lists */ +} + +.fragment { + text-align: left; + direction: ltr; + overflow-x: auto; /*Fixed: fragment lines overlap floating elements*/ + overflow-y: hidden; +} + +pre.fragment { + border: 1px solid var(--fragment-border-color); + background-color: var(--fragment-background-color); + color: var(--fragment-foreground-color); + padding: 4px 6px; + margin: 4px 8px 4px 2px; + overflow: auto; + word-wrap: break-word; + font-size: 9pt; + line-height: 125%; + font-family: var(--font-family-monospace); + font-size: 105%; +} + +div.fragment { + padding: 0 0 1px 0; /*Fixed: last line underline overlap border*/ + margin: 4px 8px 4px 2px; + color: var(--fragment-foreground-color); + background-color: var(--fragment-background-color); + border: 1px solid var(--fragment-border-color); +} + +div.line { + font-family: var(--font-family-monospace); + font-size: 13px; + min-height: 13px; + line-height: 1.2; + text-wrap: unrestricted; + white-space: -moz-pre-wrap; /* Moz */ + white-space: -pre-wrap; /* Opera 4-6 */ + white-space: -o-pre-wrap; /* Opera 7 */ + white-space: pre-wrap; /* CSS3 */ + word-wrap: break-word; /* IE 5.5+ */ + text-indent: -53px; + padding-left: 53px; + padding-bottom: 0px; + margin: 0px; + -webkit-transition-property: background-color, box-shadow; + -webkit-transition-duration: 0.5s; + -moz-transition-property: background-color, box-shadow; + -moz-transition-duration: 0.5s; + -ms-transition-property: background-color, box-shadow; + -ms-transition-duration: 0.5s; + -o-transition-property: background-color, box-shadow; + -o-transition-duration: 0.5s; + transition-property: background-color, box-shadow; + transition-duration: 0.5s; +} + +div.line:after { + content:"\000A"; + white-space: pre; +} + +div.line.glow { + background-color: var(--glow-color); + box-shadow: 0 0 10px var(--glow-color); +} + +span.fold { + margin-left: 5px; + margin-right: 1px; + margin-top: 0px; + margin-bottom: 0px; + padding: 0px; + display: inline-block; + width: 12px; + height: 12px; + background-repeat:no-repeat; + background-position:center; +} + +span.lineno { + padding-right: 4px; + margin-right: 9px; + text-align: right; + border-right: 2px solid var(--fragment-lineno-border-color); + color: var(--fragment-lineno-foreground-color); + background-color: var(--fragment-lineno-background-color); + white-space: pre; +} +span.lineno a, span.lineno a:visited { + color: var(--fragment-lineno-link-fg-color); + background-color: var(--fragment-lineno-link-bg-color); +} + +span.lineno a:hover { + color: var(--fragment-lineno-link-hover-fg-color); + background-color: var(--fragment-lineno-link-hover-bg-color); +} + +.lineno { + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +div.classindex ul { + list-style: none; + padding-left: 0; +} + +div.classindex span.ai { + display: inline-block; +} + +div.groupHeader { + margin-left: 16px; + margin-top: 12px; + font-weight: bold; +} + +div.groupText { + margin-left: 16px; + font-style: italic; +} + +body { + color: var(--page-foreground-color); + margin: 0; +} + +div.contents { + margin-top: 10px; + margin-left: 12px; + margin-right: 8px; +} + +p.formulaDsp { + text-align: center; +} + +img.dark-mode-visible { + display: none; +} +img.light-mode-visible { + display: none; +} + +img.formulaDsp { + +} + +img.formulaInl, img.inline { + vertical-align: middle; +} + +div.center { + text-align: center; + margin-top: 0px; + margin-bottom: 0px; + padding: 0px; +} + +div.center img { + border: 0px; +} + +address.footer { + text-align: right; + padding-right: 12px; +} + +img.footer { + border: 0px; + vertical-align: middle; + width: var(--footer-logo-width); +} + +.compoundTemplParams { + color: var(--memdecl-template-color); + font-size: 80%; + line-height: 120%; +} + +/* @group Code Colorization */ + +span.keyword { + color: var(--code-keyword-color); +} + +span.keywordtype { + color: var(--code-type-keyword-color); +} + +span.keywordflow { + color: var(--code-flow-keyword-color); +} + +span.comment { + color: var(--code-comment-color); +} + +span.preprocessor { + color: var(--code-preprocessor-color); +} + +span.stringliteral { + color: var(--code-string-literal-color); +} + +span.charliteral { + color: var(--code-char-literal-color); +} + +span.xmlcdata { + color: var(--code-xml-cdata-color); +} + +span.vhdldigit { + color: var(--code-vhdl-digit-color); +} + +span.vhdlchar { + color: var(--code-vhdl-char-color); +} + +span.vhdlkeyword { + color: var(--code-vhdl-keyword-color); +} + +span.vhdllogic { + color: var(--code-vhdl-logic-color); +} + +blockquote { + background-color: var(--blockquote-background-color); + border-left: 2px solid var(--blockquote-border-color); + margin: 0 24px 0 4px; + padding: 0 12px 0 16px; +} + +/* @end */ + +td.tiny { + font-size: 75%; +} + +.dirtab { + padding: 4px; + border-collapse: collapse; + border: 1px solid var(--table-cell-border-color); +} + +th.dirtab { + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); + font-weight: bold; +} + +hr { + height: 0px; + border: none; + border-top: 1px solid var(--separator-color); +} + +hr.footer { + height: 1px; +} + +/* @group Member Descriptions */ + +table.memberdecls { + border-spacing: 0px; + padding: 0px; +} + +.memberdecls td, .fieldtable tr { + -webkit-transition-property: background-color, box-shadow; + -webkit-transition-duration: 0.5s; + -moz-transition-property: background-color, box-shadow; + -moz-transition-duration: 0.5s; + -ms-transition-property: background-color, box-shadow; + -ms-transition-duration: 0.5s; + -o-transition-property: background-color, box-shadow; + -o-transition-duration: 0.5s; + transition-property: background-color, box-shadow; + transition-duration: 0.5s; +} + +.memberdecls td.glow, .fieldtable tr.glow { + background-color: var(--glow-color); + box-shadow: 0 0 15px var(--glow-color); +} + +.mdescLeft, .mdescRight, +.memItemLeft, .memItemRight, +.memTemplItemLeft, .memTemplItemRight, .memTemplParams { + background-color: var(--memdecl-background-color); + border: none; + margin: 4px; + padding: 1px 0 0 8px; +} + +.mdescLeft, .mdescRight { + padding: 0px 8px 4px 8px; + color: var(--memdecl-foreground-color); +} + +.memSeparator { + border-bottom: 1px solid var(--memdecl-separator-color); + line-height: 1px; + margin: 0px; + padding: 0px; +} + +.memItemLeft, .memTemplItemLeft { + white-space: nowrap; +} + +.memItemRight, .memTemplItemRight { + width: 100%; +} + +.memTemplParams { + color: var(--memdecl-template-color); + white-space: nowrap; + font-size: 80%; +} + +/* @end */ + +/* @group Member Details */ + +/* Styles for detailed member documentation */ + +.memtitle { + padding: 8px; + border-top: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); + border-top-right-radius: 4px; + border-top-left-radius: 4px; + margin-bottom: -1px; + background-image: var(--memdef-title-gradient-image); + background-repeat: repeat-x; + background-color: var(--memdef-title-background-color); + line-height: 1.25; + font-weight: 300; + float:left; +} + +.permalink +{ + font-size: 65%; + display: inline-block; + vertical-align: middle; +} + +.memtemplate { + font-size: 80%; + color: var(--memdef-template-color); + font-weight: normal; + margin-left: 9px; +} + +.mempage { + width: 100%; +} + +.memitem { + padding: 0; + margin-bottom: 10px; + margin-right: 5px; + -webkit-transition: box-shadow 0.5s linear; + -moz-transition: box-shadow 0.5s linear; + -ms-transition: box-shadow 0.5s linear; + -o-transition: box-shadow 0.5s linear; + transition: box-shadow 0.5s linear; + display: table !important; + width: 100%; +} + +.memitem.glow { + box-shadow: 0 0 15px var(--glow-color); +} + +.memname { + font-weight: 400; + margin-left: 6px; +} + +.memname td { + vertical-align: bottom; +} + +.memproto, dl.reflist dt { + border-top: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); + padding: 6px 0px 6px 0px; + color: var(--memdef-proto-text-color); + font-weight: bold; + text-shadow: var(--memdef-proto-text-shadow); + background-color: var(--memdef-proto-background-color); + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); + border-top-right-radius: 4px; +} + +.overload { + font-family: var(--font-family-monospace); + font-size: 65%; +} + +.memdoc, dl.reflist dd { + border-bottom: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); + padding: 6px 10px 2px 10px; + border-top-width: 0; + background-image:url('nav_g.png'); + background-repeat:repeat-x; + background-color: var(--memdef-doc-background-color); + /* opera specific markup */ + border-bottom-left-radius: 4px; + border-bottom-right-radius: 4px; + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); + /* firefox specific markup */ + -moz-border-radius-bottomleft: 4px; + -moz-border-radius-bottomright: 4px; + -moz-box-shadow: rgba(0, 0, 0, 0.15) 5px 5px 5px; + /* webkit specific markup */ + -webkit-border-bottom-left-radius: 4px; + -webkit-border-bottom-right-radius: 4px; + -webkit-box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); +} + +dl.reflist dt { + padding: 5px; +} + +dl.reflist dd { + margin: 0px 0px 10px 0px; + padding: 5px; +} + +.paramkey { + text-align: right; +} + +.paramtype { + white-space: nowrap; +} + +.paramname { + color: var(--memdef-param-name-color); + white-space: nowrap; +} +.paramname em { + font-style: normal; +} +.paramname code { + line-height: 14px; +} + +.params, .retval, .exception, .tparams { + margin-left: 0px; + padding-left: 0px; +} + +.params .paramname, .retval .paramname, .tparams .paramname, .exception .paramname { + font-weight: bold; + vertical-align: top; +} + +.params .paramtype, .tparams .paramtype { + font-style: italic; + vertical-align: top; +} + +.params .paramdir, .tparams .paramdir { + font-family: var(--font-family-monospace); + vertical-align: top; +} + +table.mlabels { + border-spacing: 0px; +} + +td.mlabels-left { + width: 100%; + padding: 0px; +} + +td.mlabels-right { + vertical-align: bottom; + padding: 0px; + white-space: nowrap; +} + +span.mlabels { + margin-left: 8px; +} + +span.mlabel { + background-color: var(--label-background-color); + border-top:1px solid var(--label-left-top-border-color); + border-left:1px solid var(--label-left-top-border-color); + border-right:1px solid var(--label-right-bottom-border-color); + border-bottom:1px solid var(--label-right-bottom-border-color); + text-shadow: none; + color: var(--label-foreground-color); + margin-right: 4px; + padding: 2px 3px; + border-radius: 3px; + font-size: 7pt; + white-space: nowrap; + vertical-align: middle; +} + + + +/* @end */ + +/* these are for tree view inside a (index) page */ + +div.directory { + margin: 10px 0px; + border-top: 1px solid var(--directory-separator-color); + border-bottom: 1px solid var(--directory-separator-color); + width: 100%; +} + +.directory table { + border-collapse:collapse; +} + +.directory td { + margin: 0px; + padding: 0px; + vertical-align: top; +} + +.directory td.entry { + white-space: nowrap; + padding-right: 6px; + padding-top: 3px; +} + +.directory td.entry a { + outline:none; +} + +.directory td.entry a img { + border: none; +} + +.directory td.desc { + width: 100%; + padding-left: 6px; + padding-right: 6px; + padding-top: 3px; + border-left: 1px solid rgba(0,0,0,0.05); +} + +.directory tr.odd { + padding-left: 6px; + background-color: var(--index-odd-item-bg-color); +} + +.directory tr.even { + padding-left: 6px; + background-color: var(--index-even-item-bg-color); +} + +.directory img { + vertical-align: -30%; +} + +.directory .levels { + white-space: nowrap; + width: 100%; + text-align: right; + font-size: 9pt; +} + +.directory .levels span { + cursor: pointer; + padding-left: 2px; + padding-right: 2px; + color: var(--page-link-color); +} + +.arrow { + color: var(--nav-arrow-color); + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; + cursor: pointer; + font-size: 80%; + display: inline-block; + width: 16px; + height: 22px; +} + +.icon { + font-family: var(--font-family-icon); + line-height: normal; + font-weight: bold; + font-size: 12px; + height: 14px; + width: 16px; + display: inline-block; + background-color: var(--icon-background-color); + color: var(--icon-foreground-color); + text-align: center; + border-radius: 4px; + margin-left: 2px; + margin-right: 2px; +} + +.icona { + width: 24px; + height: 22px; + display: inline-block; +} + +.iconfopen { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:var(--icon-folder-open-image); + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +.iconfclosed { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:var(--icon-folder-closed-image); + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +.icondoc { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:var(--icon-doc-image); + background-position: 0px -4px; + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +/* @end */ + +div.dynheader { + margin-top: 8px; + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +address { + font-style: normal; + color: var(--footer-foreground-color); +} + +table.doxtable caption { + caption-side: top; +} + +table.doxtable { + border-collapse:collapse; + margin-top: 4px; + margin-bottom: 4px; +} + +table.doxtable td, table.doxtable th { + border: 1px solid var(--table-cell-border-color); + padding: 3px 7px 2px; +} + +table.doxtable th { + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); + font-size: 110%; + padding-bottom: 4px; + padding-top: 5px; +} + +table.fieldtable { + margin-bottom: 10px; + border: 1px solid var(--memdef-border-color); + border-spacing: 0px; + border-radius: 4px; + box-shadow: 2px 2px 2px rgba(0, 0, 0, 0.15); +} + +.fieldtable td, .fieldtable th { + padding: 3px 7px 2px; +} + +.fieldtable td.fieldtype, .fieldtable td.fieldname { + white-space: nowrap; + border-right: 1px solid var(--memdef-border-color); + border-bottom: 1px solid var(--memdef-border-color); + vertical-align: top; +} + +.fieldtable td.fieldname { + padding-top: 3px; +} + +.fieldtable td.fielddoc { + border-bottom: 1px solid var(--memdef-border-color); +} + +.fieldtable td.fielddoc p:first-child { + margin-top: 0px; +} + +.fieldtable td.fielddoc p:last-child { + margin-bottom: 2px; +} + +.fieldtable tr:last-child td { + border-bottom: none; +} + +.fieldtable th { + background-image: var(--memdef-title-gradient-image); + background-repeat:repeat-x; + background-color: var(--memdef-title-background-color); + font-size: 90%; + color: var(--memdef-proto-text-color); + padding-bottom: 4px; + padding-top: 5px; + text-align:left; + font-weight: 400; + border-top-left-radius: 4px; + border-top-right-radius: 4px; + border-bottom: 1px solid var(--memdef-border-color); +} + + +.tabsearch { + top: 0px; + left: 10px; + height: 36px; + background-image: var(--nav-gradient-image); + z-index: 101; + overflow: hidden; + font-size: 13px; +} + +.navpath ul +{ + font-size: 11px; + background-image: var(--nav-gradient-image); + background-repeat:repeat-x; + background-position: 0 -5px; + height:30px; + line-height:30px; + color:var(--nav-text-normal-color); + border:solid 1px var(--nav-breadcrumb-border-color); + overflow:hidden; + margin:0px; + padding:0px; +} + +.navpath li +{ + list-style-type:none; + float:left; + padding-left:10px; + padding-right:15px; + background-image:var(--nav-breadcrumb-image); + background-repeat:no-repeat; + background-position:right; + color: var(--nav-foreground-color); +} + +.navpath li.navelem a +{ + height:32px; + display:block; + text-decoration: none; + outline: none; + color: var(--nav-text-normal-color); + font-family: var(--font-family-nav); + text-shadow: var(--nav-text-normal-shadow); + text-decoration: none; +} + +.navpath li.navelem a:hover +{ + color: var(--nav-text-hover-color); + text-shadow: var(--nav-text-hover-shadow); +} + +.navpath li.footer +{ + list-style-type:none; + float:right; + padding-left:10px; + padding-right:15px; + background-image:none; + background-repeat:no-repeat; + background-position:right; + color: var(--footer-foreground-color); + font-size: 8pt; +} + + +div.summary +{ + float: right; + font-size: 8pt; + padding-right: 5px; + width: 50%; + text-align: right; +} + +div.summary a +{ + white-space: nowrap; +} + +table.classindex +{ + margin: 10px; + white-space: nowrap; + margin-left: 3%; + margin-right: 3%; + width: 94%; + border: 0; + border-spacing: 0; + padding: 0; +} + +div.ingroups +{ + font-size: 8pt; + width: 50%; + text-align: left; +} + +div.ingroups a +{ + white-space: nowrap; +} + +div.header +{ + background-image: var(--header-gradient-image); + background-repeat:repeat-x; + background-color: var(--header-background-color); + margin: 0px; + border-bottom: 1px solid var(--header-separator-color); +} + +div.headertitle +{ + padding: 5px 5px 5px 10px; +} + +.PageDocRTL-title div.headertitle { + text-align: right; + direction: rtl; +} + +dl { + padding: 0 0 0 0; +} + +/* dl.note, dl.warning, dl.attention, dl.pre, dl.post, dl.invariant, dl.deprecated, dl.todo, dl.test, dl.bug, dl.examples */ +dl.section { + margin-left: 0px; + padding-left: 0px; +} + +dl.note { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #D0C000; +} + +dl.warning, dl.attention { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #FF0000; +} + +dl.pre, dl.post, dl.invariant { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #00D000; +} + +dl.deprecated { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #505050; +} + +dl.todo { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #00C0E0; +} + +dl.test { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #3030E0; +} + +dl.bug { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #C08050; +} + +dl.section dd { + margin-bottom: 6px; +} + + +#projectrow +{ + height: 56px; +} + +#projectlogo +{ + text-align: center; + vertical-align: bottom; + border-collapse: separate; +} + +#projectlogo img +{ + border: 0px none; +} + +#projectalign +{ + vertical-align: middle; + padding-left: 0.5em; +} + +#projectname +{ + font-size: 200%; + font-family: var(--font-family-title); + margin: 0px; + padding: 2px 0px; +} + +#projectbrief +{ + font-size: 90%; + font-family: var(--font-family-title); + margin: 0px; + padding: 0px; +} + +#projectnumber +{ + font-size: 50%; + font-family: 50% var(--font-family-title); + margin: 0px; + padding: 0px; +} + +#titlearea +{ + padding: 0px; + margin: 0px; + width: 100%; + border-bottom: 1px solid var(--title-separator-color); + background-color: var(--title-background-color); +} + +.image +{ + text-align: center; +} + +.dotgraph +{ + text-align: center; +} + +.mscgraph +{ + text-align: center; +} + +.plantumlgraph +{ + text-align: center; +} + +.diagraph +{ + text-align: center; +} + +.caption +{ + font-weight: bold; +} + +dl.citelist { + margin-bottom:50px; +} + +dl.citelist dt { + color:var(--citation-label-color); + float:left; + font-weight:bold; + margin-right:10px; + padding:5px; + text-align:right; + width:52px; +} + +dl.citelist dd { + margin:2px 0 2px 72px; + padding:5px 0; +} + +div.toc { + padding: 14px 25px; + background-color: var(--toc-background-color); + border: 1px solid var(--toc-border-color); + border-radius: 7px 7px 7px 7px; + float: right; + height: auto; + margin: 0 8px 10px 10px; + width: 200px; +} + +div.toc li { + background: var(--toc-down-arrow-image) no-repeat scroll 0 5px transparent; + font: 10px/1.2 var(--font-family-toc); + margin-top: 5px; + padding-left: 10px; + padding-top: 2px; +} + +div.toc h3 { + font: bold 12px/1.2 var(--font-family-toc); + color: var(--toc-header-color); + border-bottom: 0 none; + margin: 0; +} + +div.toc ul { + list-style: none outside none; + border: medium none; + padding: 0px; +} + +div.toc li.level1 { + margin-left: 0px; +} + +div.toc li.level2 { + margin-left: 15px; +} + +div.toc li.level3 { + margin-left: 15px; +} + +div.toc li.level4 { + margin-left: 15px; +} + +span.emoji { + /* font family used at the site: https://unicode.org/emoji/charts/full-emoji-list.html + * font-family: "Noto Color Emoji", "Apple Color Emoji", "Segoe UI Emoji", Times, Symbola, Aegyptus, Code2000, Code2001, Code2002, Musica, serif, LastResort; + */ +} + +span.obfuscator { + display: none; +} + +.inherit_header { + font-weight: bold; + color: var(--inherit-header-color); + cursor: pointer; + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +.inherit_header td { + padding: 6px 0px 2px 5px; +} + +.inherit { + display: none; +} + +tr.heading h2 { + margin-top: 12px; + margin-bottom: 4px; +} + +/* tooltip related style info */ + +.ttc { + position: absolute; + display: none; +} + +#powerTip { + cursor: default; + /*white-space: nowrap;*/ + color: var(--tooltip-foreground-color); + background-color: var(--tooltip-background-color); + border: 1px solid var(--tooltip-border-color); + border-radius: 4px 4px 4px 4px; + box-shadow: var(--tooltip-shadow); + display: none; + font-size: smaller; + max-width: 80%; + opacity: 0.9; + padding: 1ex 1em 1em; + position: absolute; + z-index: 2147483647; +} + +#powerTip div.ttdoc { + color: var(--tooltip-doc-color); + font-style: italic; +} + +#powerTip div.ttname a { + font-weight: bold; +} + +#powerTip a { + color: var(--tooltip-link-color); +} + +#powerTip div.ttname { + font-weight: bold; +} + +#powerTip div.ttdeci { + color: var(--tooltip-declaration-color); +} + +#powerTip div { + margin: 0px; + padding: 0px; + font-size: 12px; + font-family: var(--font-family-tooltip); + line-height: 16px; +} + +#powerTip:before, #powerTip:after { + content: ""; + position: absolute; + margin: 0px; +} + +#powerTip.n:after, #powerTip.n:before, +#powerTip.s:after, #powerTip.s:before, +#powerTip.w:after, #powerTip.w:before, +#powerTip.e:after, #powerTip.e:before, +#powerTip.ne:after, #powerTip.ne:before, +#powerTip.se:after, #powerTip.se:before, +#powerTip.nw:after, #powerTip.nw:before, +#powerTip.sw:after, #powerTip.sw:before { + border: solid transparent; + content: " "; + height: 0; + width: 0; + position: absolute; +} + +#powerTip.n:after, #powerTip.s:after, +#powerTip.w:after, #powerTip.e:after, +#powerTip.nw:after, #powerTip.ne:after, +#powerTip.sw:after, #powerTip.se:after { + border-color: rgba(255, 255, 255, 0); +} + +#powerTip.n:before, #powerTip.s:before, +#powerTip.w:before, #powerTip.e:before, +#powerTip.nw:before, #powerTip.ne:before, +#powerTip.sw:before, #powerTip.se:before { + border-color: rgba(128, 128, 128, 0); +} + +#powerTip.n:after, #powerTip.n:before, +#powerTip.ne:after, #powerTip.ne:before, +#powerTip.nw:after, #powerTip.nw:before { + top: 100%; +} + +#powerTip.n:after, #powerTip.ne:after, #powerTip.nw:after { + border-top-color: var(--tooltip-background-color); + border-width: 10px; + margin: 0px -10px; +} +#powerTip.n:before, #powerTip.ne:before, #powerTip.nw:before { + border-top-color: var(--tooltip-border-color); + border-width: 11px; + margin: 0px -11px; +} +#powerTip.n:after, #powerTip.n:before { + left: 50%; +} + +#powerTip.nw:after, #powerTip.nw:before { + right: 14px; +} + +#powerTip.ne:after, #powerTip.ne:before { + left: 14px; +} + +#powerTip.s:after, #powerTip.s:before, +#powerTip.se:after, #powerTip.se:before, +#powerTip.sw:after, #powerTip.sw:before { + bottom: 100%; +} + +#powerTip.s:after, #powerTip.se:after, #powerTip.sw:after { + border-bottom-color: var(--tooltip-background-color); + border-width: 10px; + margin: 0px -10px; +} + +#powerTip.s:before, #powerTip.se:before, #powerTip.sw:before { + border-bottom-color: var(--tooltip-border-color); + border-width: 11px; + margin: 0px -11px; +} + +#powerTip.s:after, #powerTip.s:before { + left: 50%; +} + +#powerTip.sw:after, #powerTip.sw:before { + right: 14px; +} + +#powerTip.se:after, #powerTip.se:before { + left: 14px; +} + +#powerTip.e:after, #powerTip.e:before { + left: 100%; +} +#powerTip.e:after { + border-left-color: var(--tooltip-border-color); + border-width: 10px; + top: 50%; + margin-top: -10px; +} +#powerTip.e:before { + border-left-color: var(--tooltip-border-color); + border-width: 11px; + top: 50%; + margin-top: -11px; +} + +#powerTip.w:after, #powerTip.w:before { + right: 100%; +} +#powerTip.w:after { + border-right-color: var(--tooltip-border-color); + border-width: 10px; + top: 50%; + margin-top: -10px; +} +#powerTip.w:before { + border-right-color: var(--tooltip-border-color); + border-width: 11px; + top: 50%; + margin-top: -11px; +} + +@media print +{ + #top { display: none; } + #side-nav { display: none; } + #nav-path { display: none; } + body { overflow:visible; } + h1, h2, h3, h4, h5, h6 { page-break-after: avoid; } + .summary { display: none; } + .memitem { page-break-inside: avoid; } + #doc-content + { + margin-left:0 !important; + height:auto !important; + width:auto !important; + overflow:inherit; + display:inline; + } +} + +/* @group Markdown */ + +table.markdownTable { + border-collapse:collapse; + margin-top: 4px; + margin-bottom: 4px; +} + +table.markdownTable td, table.markdownTable th { + border: 1px solid var(--table-cell-border-color); + padding: 3px 7px 2px; +} + +table.markdownTable tr { +} + +th.markdownTableHeadLeft, th.markdownTableHeadRight, th.markdownTableHeadCenter, th.markdownTableHeadNone { + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); + font-size: 110%; + padding-bottom: 4px; + padding-top: 5px; +} + +th.markdownTableHeadLeft, td.markdownTableBodyLeft { + text-align: left +} + +th.markdownTableHeadRight, td.markdownTableBodyRight { + text-align: right +} + +th.markdownTableHeadCenter, td.markdownTableBodyCenter { + text-align: center +} + +tt, code, kbd, samp +{ + display: inline-block; +} +/* @end */ + +u { + text-decoration: underline; +} + +details>summary { + list-style-type: none; +} + +details > summary::-webkit-details-marker { + display: none; +} + +details>summary::before { + content: "\25ba"; + padding-right:4px; + font-size: 80%; +} + +details[open]>summary::before { + content: "\25bc"; + padding-right:4px; + font-size: 80%; +} + +body { + scrollbar-color: var(--scrollbar-thumb-color) var(--scrollbar-background-color); +} + +::-webkit-scrollbar { + background-color: var(--scrollbar-background-color); + height: 12px; + width: 12px; +} +::-webkit-scrollbar-thumb { + border-radius: 6px; + box-shadow: inset 0 0 12px 12px var(--scrollbar-thumb-color); + border: solid 2px transparent; +} +::-webkit-scrollbar-corner { + background-color: var(--scrollbar-background-color); +} + diff --git a/footer.html b/footer.html new file mode 100644 index 0000000..249d73f --- /dev/null +++ b/footer.html @@ -0,0 +1,17 @@ + + + + + + +
+$generatedby doxygen $doxygenversion +
+ + + From d95262326668fd3f31563c11053337d0525ddd2c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 19 Apr 2026 16:28:50 +0100 Subject: [PATCH 41/77] Preparing for the great documentation reskinning! --- .gitignore | 4 ++-- Doxyfile | 4 ++-- .../customdoxygen.css | 0 footer.html | 17 ----------------- 4 files changed, 4 insertions(+), 21 deletions(-) rename customdoxygen.css => doxyresources/customdoxygen.css (100%) delete mode 100644 footer.html diff --git a/.gitignore b/.gitignore index 17fc3a8..530ee39 100644 --- a/.gitignore +++ b/.gitignore @@ -57,5 +57,5 @@ sq/ tmp/ utils_src/a.out -header.html -footer.html +doxyresources/header.html + diff --git a/Doxyfile b/Doxyfile index f05fd15..6cedb0e 100644 --- a/Doxyfile +++ b/Doxyfile @@ -1314,7 +1314,7 @@ HTML_FILE_EXTENSION = .html # of the possible markers and block names see the documentation. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_HEADER = +HTML_HEADER = doxyresources/header.html # The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each # generated HTML page. If the tag is left blank doxygen will generate a standard @@ -1336,7 +1336,7 @@ HTML_FOOTER = # obsolete. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_STYLESHEET = +HTML_STYLESHEET = doxyresources/customdoxygen.css # The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined # cascading style sheets that are included after the standard style sheets diff --git a/customdoxygen.css b/doxyresources/customdoxygen.css similarity index 100% rename from customdoxygen.css rename to doxyresources/customdoxygen.css diff --git a/footer.html b/footer.html deleted file mode 100644 index 249d73f..0000000 --- a/footer.html +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - -
-$generatedby doxygen $doxygenversion -
- - - From 812a1be7d9eb97c25aa07477eb71605b1af93397 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 20 Apr 2026 10:12:55 +0100 Subject: [PATCH 42/77] Work on simplifying the Doxygen CSS; which was entirely a side project. --- Doxyfile | 4 +- doxyresources/customdoxygen.css | 390 ++++++++++++++++---------------- 2 files changed, 197 insertions(+), 197 deletions(-) diff --git a/Doxyfile b/Doxyfile index 6cedb0e..37dd235 100644 --- a/Doxyfile +++ b/Doxyfile @@ -48,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.1.0 # 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 @@ -943,7 +943,7 @@ WARN_LOGFILE = tmp/doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src \ +INPUT = src/c \ docs \ lisp diff --git a/doxyresources/customdoxygen.css b/doxyresources/customdoxygen.css index 009a9b5..52ec126 100644 --- a/doxyresources/customdoxygen.css +++ b/doxyresources/customdoxygen.css @@ -2,156 +2,156 @@ html { /* page base colors */ ---page-background-color: white; ---page-foreground-color: black; ---page-link-color: #3D578C; ---page-visited-link-color: #4665A2; +--page-background-color: #ffffff; +--page-foreground-color: #000000; +--page-link-color: #204080; +--page-visited-link-color: #4060a0; /* index */ ---index-odd-item-bg-color: #F8F9FC; ---index-even-item-bg-color: white; ---index-header-color: black; ---index-separator-color: #A0A0A0; +--index-odd-item-bg-color: #e0e0e0; +--index-even-item-bg-color: #ffffff; +--index-header-color: #000000; +--index-separator-color: #a0a0a0; /* header */ ---header-background-color: #F9FAFC; ---header-separator-color: #C4CFE5; +--header-background-color: #e0e0e0; +--header-separator-color: #c0c0e0; --header-gradient-image: url('nav_h.png'); ---group-header-separator-color: #879ECB; ---group-header-color: #354C7B; ---inherit-header-color: gray; +--group-header-separator-color: #8080c0; +--group-header-color: #204060; +--inherit-header-color: #808080; ---footer-foreground-color: #2A3D61; +--footer-foreground-color: #202060; --footer-logo-width: 104px; ---citation-label-color: #334975; ---glow-color: cyan; +--citation-label-color: #204060; +--glow-color: #00ffff; ---title-background-color: white; ---title-separator-color: #5373B4; ---directory-separator-color: #9CAFD4; ---separator-color: #4A6AAA; +--title-background-color: #ffffff; +--title-separator-color: #4060a0; +--directory-separator-color: #80a0c0; +--separator-color: #4060a0; ---blockquote-background-color: #F7F8FB; ---blockquote-border-color: #9CAFD4; +--blockquote-background-color: #e0e0e0; +--blockquote-border-color: #80a0c0; ---scrollbar-thumb-color: #9CAFD4; ---scrollbar-background-color: #F9FAFC; +--scrollbar-thumb-color: #80a0c0; +--scrollbar-background-color: #e0e0e0; ---icon-background-color: #728DC1; ---icon-foreground-color: white; +--icon-background-color: #6080c0; +--icon-foreground-color: #ffffff; --icon-doc-image: url('doc.svg'); --icon-folder-open-image: url('folderopen.svg'); --icon-folder-closed-image: url('folderclosed.svg'); /* brief member declaration list */ ---memdecl-background-color: #F9FAFC; ---memdecl-separator-color: #DEE4F0; +--memdecl-background-color: #e0e0e0; +--memdecl-separator-color: #c0e0e0; --memdecl-foreground-color: #555; ---memdecl-template-color: #4665A2; +--memdecl-template-color: #4060a0; /* detailed member list */ ---memdef-border-color: #A8B8D9; ---memdef-title-background-color: #E2E8F2; +--memdef-border-color: #a0a0c0; +--memdef-title-background-color: #e0e0e0; --memdef-title-gradient-image: url('nav_f.png'); ---memdef-proto-background-color: #DFE5F1; ---memdef-proto-text-color: #253555; +--memdef-proto-background-color: #c0e0e0; +--memdef-proto-text-color: #202040; --memdef-proto-text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); ---memdef-doc-background-color: white; +--memdef-doc-background-color: #ffffff; --memdef-param-name-color: #602020; ---memdef-template-color: #4665A2; +--memdef-template-color: #4060a0; /* tables */ ---table-cell-border-color: #2D4068; ---table-header-background-color: #374F7F; ---table-header-foreground-color: #FFFFFF; +--table-cell-border-color: #204060; +--table-header-background-color: #204060; +--table-header-foreground-color: #e0e0e0; /* labels */ ---label-background-color: #728DC1; ---label-left-top-border-color: #5373B4; ---label-right-bottom-border-color: #C4CFE5; ---label-foreground-color: white; +--label-background-color: #6080c0; +--label-left-top-border-color: #4060a0; +--label-right-bottom-border-color: #c0c0e0; +--label-foreground-color: #ffffff; /** navigation bar/tree/menu */ ---nav-background-color: #F9FAFC; ---nav-foreground-color: #364D7C; +--nav-background-color: #e0e0e0; +--nav-foreground-color: #204060; --nav-gradient-image: url('tab_b.png'); --nav-gradient-hover-image: url('tab_h.png'); --nav-gradient-active-image: url('tab_a.png'); --nav-gradient-active-image-parent: url("../tab_a.png"); --nav-separator-image: url('tab_s.png'); --nav-breadcrumb-image: url('bc_s.png'); ---nav-breadcrumb-border-color: #C2CDE4; +--nav-breadcrumb-border-color: #c0c0e0; --nav-splitbar-image: url('splitbar.png'); --nav-font-size-level1: 13px; --nav-font-size-level2: 10px; --nav-font-size-level3: 9px; ---nav-text-normal-color: #283A5D; ---nav-text-hover-color: white; ---nav-text-active-color: white; +--nav-text-normal-color: #202040; +--nav-text-hover-color: #ffffff; +--nav-text-active-color: #ffffff; --nav-text-normal-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); --nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); --nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); ---nav-menu-button-color: #364D7C; ---nav-menu-background-color: white; ---nav-menu-foreground-color: #555555; +--nav-menu-button-color: #204060; +--nav-menu-background-color: #ffffff; +--nav-menu-foreground-color: #404040; --nav-menu-toggle-color: rgba(255, 255, 255, 0.5); ---nav-arrow-color: #9CAFD4; ---nav-arrow-selected-color: #9CAFD4; +--nav-arrow-color: #80a0c0; +--nav-arrow-selected-color: #80a0c0; /* table of contents */ ---toc-background-color: #F4F6FA; ---toc-border-color: #D8DFEE; ---toc-header-color: #4665A2; +--toc-background-color: #e0e0e0; +--toc-border-color: #c0c0e0; +--toc-header-color: #4060a0; --toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); /** search field */ ---search-background-color: white; ---search-foreground-color: #909090; +--search-background-color: #ffffff; +--search-foreground-color: #808080; --search-magnification-image: url('mag.svg'); --search-magnification-select-image: url('mag_sel.svg'); ---search-active-color: black; ---search-filter-background-color: #F9FAFC; ---search-filter-foreground-color: black; ---search-filter-border-color: #90A5CE; ---search-filter-highlight-text-color: white; ---search-filter-highlight-bg-color: #3D578C; ---search-results-foreground-color: #425E97; ---search-results-background-color: #EEF1F7; ---search-results-border-color: black; +--search-active-color: #000000; +--search-filter-background-color: #e0e0e0; +--search-filter-foreground-color: #000000; +--search-filter-border-color: #80a0c0; +--search-filter-highlight-text-color: #ffffff; +--search-filter-highlight-bg-color: #204080; +--search-results-foreground-color: #404080; +--search-results-background-color: #e0e0e0; +--search-results-border-color: #000000; --search-box-shadow: inset 0.5px 0.5px 3px 0px #555; /** code fragments */ --code-keyword-color: #008000; --code-type-keyword-color: #604020; ---code-flow-keyword-color: #E08000; +--code-flow-keyword-color: #e08000; --code-comment-color: #800000; --code-preprocessor-color: #806020; --code-string-literal-color: #002080; --code-char-literal-color: #008080; ---code-xml-cdata-color: black; ---code-vhdl-digit-color: #FF00FF; +--code-xml-cdata-color: #000000; +--code-vhdl-digit-color: #e000e0; --code-vhdl-char-color: #000000; ---code-vhdl-keyword-color: #700070; ---code-vhdl-logic-color: #FF0000; ---code-link-color: #4665A2; ---code-external-link-color: #4665A2; ---fragment-foreground-color: black; ---fragment-background-color: #FBFCFD; ---fragment-border-color: #C4CFE5; ---fragment-lineno-border-color: #00FF00; ---fragment-lineno-background-color: #E8E8E8; ---fragment-lineno-foreground-color: black; ---fragment-lineno-link-fg-color: #4665A2; ---fragment-lineno-link-bg-color: #D8D8D8; ---fragment-lineno-link-hover-fg-color: #4665A2; ---fragment-lineno-link-hover-bg-color: #C8C8C8; ---tooltip-foreground-color: black; ---tooltip-background-color: white; ---tooltip-border-color: gray; +--code-vhdl-keyword-color: #600060; +--code-vhdl-logic-color: #e00000; +--code-link-color: #4060a0; +--code-external-link-color: #4060a0; +--fragment-foreground-color: #000000; +--fragment-background-color: #e0e0e0; +--fragment-border-color: #c0c0e0; +--fragment-lineno-border-color: #00e000; +--fragment-lineno-background-color: #e0e0e0; +--fragment-lineno-foreground-color: #000000; +--fragment-lineno-link-fg-color: #4060a0; +--fragment-lineno-link-bg-color: #c0c0c0; +--fragment-lineno-link-hover-fg-color: #4060a0; +--fragment-lineno-link-hover-bg-color: #c0c0c0; +--tooltip-foreground-color: #000000; +--tooltip-background-color: #ffffff; +--tooltip-border-color: #808080; --tooltip-doc-color: grey; ---tooltip-declaration-color: #006318; ---tooltip-link-color: #4665A2; ---tooltip-shadow: 1px 1px 7px gray; +--tooltip-declaration-color: #006000; +--tooltip-link-color: #4060a0; +--tooltip-shadow: 1px 1px 7px #808080; --fold-line-color: #808080; --fold-minus-image: url('minus.svg'); --fold-plus-image: url('plus.svg'); @@ -175,155 +175,155 @@ html { color-scheme: dark; /* page base colors */ ---page-background-color: black; ---page-foreground-color: #C9D1D9; ---page-link-color: #90A5CE; ---page-visited-link-color: #A3B4D7; +--page-background-color: #000000; +--page-foreground-color: #c0c0c0; +--page-link-color: #80a0c0; +--page-visited-link-color: #a0a0c0; /* index */ ---index-odd-item-bg-color: #0B101A; ---index-even-item-bg-color: black; ---index-header-color: #C4CFE5; ---index-separator-color: #334975; +--index-odd-item-bg-color: #000000; +--index-even-item-bg-color: #000000; +--index-header-color: #c0c0e0; +--index-separator-color: #204060; /* header */ ---header-background-color: #070B11; ---header-separator-color: #141C2E; +--header-background-color: #000000; +--header-separator-color: #000020; --header-gradient-image: url('nav_hd.png'); ---group-header-separator-color: #283A5D; ---group-header-color: #90A5CE; ---inherit-header-color: #A0A0A0; +--group-header-separator-color: #202040; +--group-header-color: #80a0c0; +--inherit-header-color: #a0a0a0; ---footer-foreground-color: #5B7AB7; +--footer-foreground-color: #4060a0; --footer-logo-width: 60px; ---citation-label-color: #90A5CE; ---glow-color: cyan; +--citation-label-color: #80a0c0; +--glow-color: #00ffff; ---title-background-color: #090D16; ---title-separator-color: #354C79; ---directory-separator-color: #283A5D; ---separator-color: #283A5D; +--title-background-color: #000000; +--title-separator-color: #204060; +--directory-separator-color: #202040; +--separator-color: #202040; ---blockquote-background-color: #101826; ---blockquote-border-color: #283A5D; +--blockquote-background-color: #000020; +--blockquote-border-color: #202040; ---scrollbar-thumb-color: #283A5D; ---scrollbar-background-color: #070B11; +--scrollbar-thumb-color: #202040; +--scrollbar-background-color: #000000; ---icon-background-color: #334975; ---icon-foreground-color: #C4CFE5; +--icon-background-color: #204060; +--icon-foreground-color: #c0c0e0; --icon-doc-image: url('docd.svg'); --icon-folder-open-image: url('folderopend.svg'); --icon-folder-closed-image: url('folderclosedd.svg'); /* brief member declaration list */ ---memdecl-background-color: #0B101A; ---memdecl-separator-color: #2C3F65; +--memdecl-background-color: #000000; +--memdecl-separator-color: #202060; --memdecl-foreground-color: #BBB; ---memdecl-template-color: #7C95C6; +--memdecl-template-color: #6080c0; /* detailed member list */ ---memdef-border-color: #233250; ---memdef-title-background-color: #1B2840; +--memdef-border-color: #202040; +--memdef-title-background-color: #002040; --memdef-title-gradient-image: url('nav_fd.png'); ---memdef-proto-background-color: #19243A; ---memdef-proto-text-color: #9DB0D4; +--memdef-proto-background-color: #002020; +--memdef-proto-text-color: #80a0c0; --memdef-proto-text-shadow: 0px 1px 1px rgba(0, 0, 0, 0.9); ---memdef-doc-background-color: black; ---memdef-param-name-color: #D28757; ---memdef-template-color: #7C95C6; +--memdef-doc-background-color: #000000; +--memdef-param-name-color: #c08040; +--memdef-template-color: #6080c0; /* tables */ ---table-cell-border-color: #283A5D; ---table-header-background-color: #283A5D; ---table-header-foreground-color: #C4CFE5; +--table-cell-border-color: #202040; +--table-header-background-color: #202040; +--table-header-foreground-color: #c0c0e0; /* labels */ ---label-background-color: #354C7B; ---label-left-top-border-color: #4665A2; ---label-right-bottom-border-color: #283A5D; ---label-foreground-color: #CCCCCC; +--label-background-color: #204060; +--label-left-top-border-color: #4060a0; +--label-right-bottom-border-color: #202040; +--label-foreground-color: #c0c0c0; /** navigation bar/tree/menu */ ---nav-background-color: #101826; ---nav-foreground-color: #364D7C; +--nav-background-color: #000020; +--nav-foreground-color: #204060; --nav-gradient-image: url('tab_bd.png'); --nav-gradient-hover-image: url('tab_hd.png'); --nav-gradient-active-image: url('tab_ad.png'); --nav-gradient-active-image-parent: url("../tab_ad.png"); --nav-separator-image: url('tab_sd.png'); --nav-breadcrumb-image: url('bc_sd.png'); ---nav-breadcrumb-border-color: #2A3D61; +--nav-breadcrumb-border-color: #202060; --nav-splitbar-image: url('splitbard.png'); --nav-font-size-level1: 13px; --nav-font-size-level2: 10px; --nav-font-size-level3: 9px; ---nav-text-normal-color: #B6C4DF; ---nav-text-hover-color: #DCE2EF; ---nav-text-active-color: #DCE2EF; ---nav-text-normal-shadow: 0px 1px 1px black; +--nav-text-normal-color: #a0c0c0; +--nav-text-hover-color: #c0e0e0; +--nav-text-active-color: #c0e0e0; +--nav-text-normal-shadow: 0px 1px 1px #000000; --nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); --nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); ---nav-menu-button-color: #B6C4DF; ---nav-menu-background-color: #05070C; ---nav-menu-foreground-color: #BBBBBB; +--nav-menu-button-color: #a0c0c0; +--nav-menu-background-color: #000000; +--nav-menu-foreground-color: #a0a0a0; --nav-menu-toggle-color: rgba(255, 255, 255, 0.2); ---nav-arrow-color: #334975; ---nav-arrow-selected-color: #90A5CE; +--nav-arrow-color: #204060; +--nav-arrow-selected-color: #80a0c0; /* table of contents */ ---toc-background-color: #151E30; ---toc-border-color: #202E4A; ---toc-header-color: #A3B4D7; +--toc-background-color: #000020; +--toc-border-color: #202040; +--toc-header-color: #a0a0c0; --toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); /** search field */ ---search-background-color: black; ---search-foreground-color: #C5C5C5; +--search-background-color: #000000; +--search-foreground-color: #c0c0c0; --search-magnification-image: url('mag_d.svg'); --search-magnification-select-image: url('mag_seld.svg'); ---search-active-color: #C5C5C5; ---search-filter-background-color: #101826; ---search-filter-foreground-color: #90A5CE; ---search-filter-border-color: #7C95C6; ---search-filter-highlight-text-color: #BCC9E2; ---search-filter-highlight-bg-color: #283A5D; ---search-results-background-color: #101826; ---search-results-foreground-color: #90A5CE; ---search-results-border-color: #7C95C6; +--search-active-color: #c0c0c0; +--search-filter-background-color: #000020; +--search-filter-foreground-color: #80a0c0; +--search-filter-border-color: #6080c0; +--search-filter-highlight-text-color: #a0c0e0; +--search-filter-highlight-bg-color: #202040; +--search-results-background-color: #000020; +--search-results-foreground-color: #80a0c0; +--search-results-border-color: #6080c0; --search-box-shadow: inset 0.5px 0.5px 3px 0px #2F436C; /** code fragments */ ---code-keyword-color: #CC99CD; ---code-type-keyword-color: #AB99CD; ---code-flow-keyword-color: #E08000; ---code-comment-color: #717790; ---code-preprocessor-color: #65CABE; ---code-string-literal-color: #7EC699; ---code-char-literal-color: #00E0F0; ---code-xml-cdata-color: #C9D1D9; ---code-vhdl-digit-color: #FF00FF; ---code-vhdl-char-color: #C0C0C0; ---code-vhdl-keyword-color: #CF53C9; ---code-vhdl-logic-color: #FF0000; ---code-link-color: #79C0FF; ---code-external-link-color: #79C0FF; ---fragment-foreground-color: #C9D1D9; ---fragment-background-color: black; ---fragment-border-color: #30363D; ---fragment-lineno-border-color: #30363D; ---fragment-lineno-background-color: black; ---fragment-lineno-foreground-color: #6E7681; ---fragment-lineno-link-fg-color: #6E7681; ---fragment-lineno-link-bg-color: #303030; ---fragment-lineno-link-hover-fg-color: #8E96A1; ---fragment-lineno-link-hover-bg-color: #505050; ---tooltip-foreground-color: #C9D1D9; +--code-keyword-color: #c080c0; +--code-type-keyword-color: #a080c0; +--code-flow-keyword-color: #e08000; +--code-comment-color: #606080; +--code-preprocessor-color: #60c0a0; +--code-string-literal-color: #60c080; +--code-char-literal-color: #00e0e0; +--code-xml-cdata-color: #c0c0c0; +--code-vhdl-digit-color: #e000e0; +--code-vhdl-char-color: #c0c0c0; +--code-vhdl-keyword-color: #c040c0; +--code-vhdl-logic-color: #e00000; +--code-link-color: #60c0e0; +--code-external-link-color: #60c0e0; +--fragment-foreground-color: #c0c0c0; +--fragment-background-color: #000000; +--fragment-border-color: #202020; +--fragment-lineno-border-color: #202020; +--fragment-lineno-background-color: #000000; +--fragment-lineno-foreground-color: #606080; +--fragment-lineno-link-fg-color: #606080; +--fragment-lineno-link-bg-color: #202020; +--fragment-lineno-link-hover-fg-color: #8080a0; +--fragment-lineno-link-hover-bg-color: #404040; +--tooltip-foreground-color: #c0c0c0; --tooltip-background-color: #202020; ---tooltip-border-color: #C9D1D9; ---tooltip-doc-color: #D9E1E9; ---tooltip-declaration-color: #20C348; ---tooltip-link-color: #79C0FF; +--tooltip-border-color: #c0c0c0; +--tooltip-doc-color: #c0e0e0; +--tooltip-declaration-color: #20c040; +--tooltip-link-color: #60c0e0; --tooltip-shadow: none; --fold-line-color: #808080; --fold-minus-image: url('minusd.svg'); @@ -1524,49 +1524,49 @@ dl.note { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #D0C000; + border-color: #c0c000; } dl.warning, dl.attention { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #FF0000; + border-color: #e00000; } dl.pre, dl.post, dl.invariant { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #00D000; + border-color: #00c000; } dl.deprecated { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #505050; + border-color: #404040; } dl.todo { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #00C0E0; + border-color: #00c0e0; } dl.test { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #3030E0; + border-color: #2020e0; } dl.bug { margin-left: -7px; padding-left: 3px; border-left: 4px solid; - border-color: #C08050; + border-color: #c08040; } dl.section dd { From c59825d7feb6dd22161f6bdb119de7a33dae2c8f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 20 Apr 2026 12:10:38 +0100 Subject: [PATCH 43/77] Closes #18. Change to `char32_t` everywhere; builds fine, behaviour as before. --- archive/c/debug.c | 6 +++--- archive/c/debug.h | 4 ++-- archive/c/init.c | 10 +++++----- archive/c/io/io.c | 18 +++++++++--------- archive/c/io/print.c | 2 +- archive/c/memory/consspaceobject.c | 14 +++++++------- archive/c/memory/consspaceobject.h | 6 +++--- archive/c/memory/dump.c | 2 +- archive/c/memory/dump.h | 2 +- archive/c/ops/equal.c | 2 +- archive/c/ops/lispops.c | 4 ++-- archive/c/time/psse_time.c | 2 +- docs/State-of-play.md | 26 +++++++++++++++++++++++--- src/c/debug.c | 6 +++--- src/c/debug.h | 6 ++++-- src/c/io/io.c | 27 ++++++++++++++++----------- src/c/io/print.c | 5 +++-- src/c/io/read.c | 6 +++--- src/c/memory/pso.c | 1 + src/c/memory/pso.h | 1 + src/c/memory/tags.c | 2 +- src/c/ops/bind.c | 1 + src/c/ops/repl.c | 1 + src/c/ops/repl.h | 2 +- src/c/ops/reverse.c | 1 + src/c/ops/string_ops.c | 12 ++++++------ src/c/ops/string_ops.h | 7 ++++--- src/c/payloads/character.c | 3 ++- src/c/payloads/character.h | 3 ++- src/c/payloads/cons.c | 6 ++++-- src/c/payloads/cons.h | 1 + src/c/payloads/stack.c | 1 + utils_src/readprintwc/readprintwc.c | 2 +- 33 files changed, 116 insertions(+), 76 deletions(-) diff --git a/archive/c/debug.c b/archive/c/debug.c index 631149d..3df7dc1 100644 --- a/archive/c/debug.c +++ b/archive/c/debug.c @@ -57,7 +57,7 @@ void debug_print_exception( struct cons_pointer ex_ptr ) { * `verbosity` is a set of flags, see debug_print.h; so you can * turn debugging on for only one part of the system. */ -void debug_print( wchar_t *message, int level ) { +void debug_print( char32_t *message, int level ) { #ifdef DEBUG if ( level & verbosity ) { fwide( stderr, 1 ); @@ -117,7 +117,7 @@ void debug_println( int level ) { * Print to stderr only if `verbosity` matches `level`. All other arguments * as for `wprintf`. */ -void debug_printf( int level, wchar_t *format, ... ) { +void debug_printf( int level, char32_t *format, ... ) { #ifdef DEBUG if ( level & verbosity ) { fwide( stderr, 1 ); @@ -169,7 +169,7 @@ void debug_dump_object( struct cons_pointer pointer, int level ) { void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level ) { #ifdef DEBUG - // wchar_t * depth = (deep ? L"Deep" : L"Shallow"); + // char32_t * depth = (deep ? L"Deep" : L"Shallow"); debug_print( ( deep ? L"Deep" : L"Shallow" ), level ); debug_print( L" binding `", level ); diff --git a/archive/c/debug.h b/archive/c/debug.h index d08df7e..cccf3ff 100644 --- a/archive/c/debug.h +++ b/archive/c/debug.h @@ -89,10 +89,10 @@ extern int verbosity; void debug_print_exception( struct cons_pointer ex_ptr ); -void debug_print( wchar_t *message, int level ); +void debug_print( char32_t *message, int level ); void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); -void debug_printf( int level, wchar_t *format, ... ); +void debug_printf( int level, char32_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); void debug_print_binding( struct cons_pointer key, struct cons_pointer val, diff --git a/archive/c/init.c b/archive/c/init.c index f8b1c1d..fbfdb2f 100644 --- a/archive/c/init.c +++ b/archive/c/init.c @@ -110,8 +110,8 @@ void free_init_symbols( ) { * the name on the source pointer. Would make stack frames potentially * more readable and aid debugging generally. */ -struct cons_pointer bind_function( wchar_t *name, - wchar_t *doc, +struct cons_pointer bind_function( char32_t *name, + char32_t *doc, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, @@ -141,8 +141,8 @@ struct cons_pointer bind_function( wchar_t *name, * Bind this compiled `executable` function, as a Lisp special form, to * this `name` in the `oblist`. */ -struct cons_pointer bind_special( wchar_t *name, - wchar_t *doc, +struct cons_pointer bind_special( char32_t *name, + char32_t *doc, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { @@ -188,7 +188,7 @@ bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value, /** * Bind this `value` to this `name` in the `oblist`. */ -struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value, +struct cons_pointer bind_value( char32_t *name, struct cons_pointer value, bool lock ) { struct cons_pointer p = c_string_to_lisp_symbol( name ); diff --git a/archive/c/io/io.c b/archive/c/io/io.c index cf0894f..f8a400c 100644 --- a/archive/c/io/io.c +++ b/archive/c/io/io.c @@ -103,7 +103,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) { len++; } - wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + char32_t *buffer = calloc( len + 1, sizeof( char32_t ) ); /* worst case, one wide char = four utf bytes */ result = calloc( ( len * 4 ) + 1, sizeof( char ) ); @@ -164,8 +164,8 @@ wint_t url_fgetwc( URL_FILE *input ) { case CFTYPE_CURL:{ char *cbuff = - calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + calloc( sizeof( char32_t ) + 2, sizeof( char ) ); + char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); size_t count = 0; @@ -265,7 +265,7 @@ lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, return result; } -struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, +struct cons_pointer add_meta_integer( struct cons_pointer meta, char32_t *key, long int value ) { return make_cons( make_cons @@ -273,17 +273,17 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, make_integer( value, NIL ) ), meta ); } -struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, +struct cons_pointer add_meta_string( struct cons_pointer meta, char32_t *key, char *value ) { value = trim( value ); - wchar_t buffer[strlen( value ) + 1]; + char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); return make_cons( make_cons( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } -struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, +struct cons_pointer add_meta_time( struct cons_pointer meta, char32_t *key, time_t *value ) { /* I don't yet have a concept of a date-time object, which is a * bit of an oversight! */ @@ -317,7 +317,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, s[offset] = ( char ) 0; char *name = trim( s ); char *value = trim( &s[++offset] ); - wchar_t wname[strlen( name )]; + char32_t wname[strlen( name )]; mbstowcs( wname, name, strlen( name ) + 1 ); @@ -548,7 +548,7 @@ lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_println( DEBUG_IO ); struct cons_space_object *cell = &pointer2cell( cursor ); - cursor = make_string( ( wchar_t ) c, NIL ); + cursor = make_string( ( char32_t ) c, NIL ); cell->payload.string.cdr = cursor; } } diff --git a/archive/c/io/print.c b/archive/c/io/print.c index c6e1611..c945943 100644 --- a/archive/c/io/print.c +++ b/archive/c/io/print.c @@ -37,7 +37,7 @@ void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); - wchar_t c = cell->payload.string.character; + char32_t c = cell->payload.string.character; if ( c != '\0' ) { url_fputwc( c, output ); diff --git a/archive/c/memory/consspaceobject.c b/archive/c/memory/consspaceobject.c index 2c0ab6a..4220618 100644 --- a/archive/c/memory/consspaceobject.c +++ b/archive/c/memory/consspaceobject.c @@ -181,7 +181,7 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * strings made with NIL termination. The question is which should be * fixed, and actually that's probably strings read by `read`. However, * for now, it was easier to add a null character here. */ - struct cons_pointer result = make_string( ( wchar_t ) 0, NIL ); + struct cons_pointer result = make_string( ( char32_t ) 0, NIL ); struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->tag.value == VECTORPOINTTV ) { @@ -189,11 +189,11 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { result = - make_string( ( wchar_t ) vec->header.tag.bytes[i], result ); + make_string( ( char32_t ) vec->header.tag.bytes[i], result ); } } else { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( wchar_t ) cell->tag.bytes[i], result ); + result = make_string( ( char32_t ) cell->tag.bytes[i], result ); } } @@ -518,11 +518,11 @@ struct cons_pointer make_write_stream( URL_FILE *output, * Return a lisp keyword representation of this wide character string. In * keywords, I am accepting only lower case characters and numbers. */ -struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { +struct cons_pointer c_string_to_lisp_keyword( char32_t *symbol ) { struct cons_pointer result = NIL; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - wchar_t c = towlower( symbol[i] ); + char32_t c = towlower( symbol[i] ); if ( iswalnum( c ) || c == L'-' ) { result = make_keyword( c, result ); @@ -535,7 +535,7 @@ struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { /** * Return a lisp string representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { +struct cons_pointer c_string_to_lisp_string( char32_t *string ) { struct cons_pointer result = NIL; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { @@ -550,7 +550,7 @@ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { /** * Return a lisp symbol representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { +struct cons_pointer c_string_to_lisp_symbol( char32_t *symbol ) { struct cons_pointer result = NIL; for ( int i = wcslen( symbol ); i > 0; i-- ) { diff --git a/archive/c/memory/consspaceobject.h b/archive/c/memory/consspaceobject.h index 25f68e3..62713bb 100644 --- a/archive/c/memory/consspaceobject.h +++ b/archive/c/memory/consspaceobject.h @@ -773,7 +773,7 @@ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer, struct cons_pointer ) ); -struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ); +struct cons_pointer c_string_to_lisp_keyword( char32_t *symbol ); struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); @@ -805,8 +805,8 @@ struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer metadata ); -struct cons_pointer c_string_to_lisp_string( wchar_t *string ); +struct cons_pointer c_string_to_lisp_string( char32_t *string ); -struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); +struct cons_pointer c_string_to_lisp_symbol( char32_t *symbol ); #endif diff --git a/archive/c/memory/dump.c b/archive/c/memory/dump.c index 24ac48b..edaf269 100644 --- a/archive/c/memory/dump.c +++ b/archive/c/memory/dump.c @@ -29,7 +29,7 @@ #include "memory/vectorspace.h" -void dump_string_cell( URL_FILE *output, wchar_t *prefix, +void dump_string_cell( URL_FILE *output, char32_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { diff --git a/archive/c/memory/dump.h b/archive/c/memory/dump.h index 0a69626..e3a4fc2 100644 --- a/archive/c/memory/dump.h +++ b/archive/c/memory/dump.h @@ -19,7 +19,7 @@ #ifndef __dump_h #define __dump_h -void dump_string_cell( URL_FILE * output, wchar_t *prefix, +void dump_string_cell( URL_FILE * output, char32_t *prefix, struct cons_pointer pointer ); void dump_object( URL_FILE * output, struct cons_pointer pointer ); diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c index 9a7aded..77e07c4 100644 --- a/archive/c/ops/equal.c +++ b/archive/c/ops/equal.c @@ -369,7 +369,7 @@ bool c_equal( struct cons_pointer a, struct cons_pointer b ) { * iteration (and even that is problematic) */ if ( cell_a->payload.string.hash == cell_b->payload.string.hash ) { - wchar_t a_buff[STRING_SHIPYARD_SIZE], + char32_t a_buff[STRING_SHIPYARD_SIZE], b_buff[STRING_SHIPYARD_SIZE]; uint32_t tag = cell_a->tag.value; int i = 0; diff --git a/archive/c/ops/lispops.c b/archive/c/ops/lispops.c index b0ab6c9..3b0d5c1 100644 --- a/archive/c/ops/lispops.c +++ b/archive/c/ops/lispops.c @@ -502,8 +502,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, default: { - int bs = sizeof( wchar_t ) * 1024; - wchar_t *buffer = malloc( bs ); + int bs = sizeof( char32_t ) * 1024; + char32_t *buffer = malloc( bs ); memset( buffer, '\0', bs ); swprintf( buffer, bs, L"Unexpected cell with tag %d (%4.4s) in function position", diff --git a/archive/c/time/psse_time.c b/archive/c/time/psse_time.c index 06c1b58..a2deb86 100644 --- a/archive/c/time/psse_time.c +++ b/archive/c/time/psse_time.c @@ -99,7 +99,7 @@ struct cons_pointer time_to_string( struct cons_pointer pointer ) { if ( t != 0 ) { char *bytes = ctime( &t ); int l = strlen( bytes ) + 1; - wchar_t buffer[l]; + char32_t buffer[l]; mbstowcs( buffer, bytes, l ); result = c_string_to_lisp_string( buffer ); diff --git a/docs/State-of-play.md b/docs/State-of-play.md index f6985aa..8ebf29c 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,12 +1,32 @@ # State of Play +## 20260420 + +Still on side projects, but those side-projects are giving me thinking time; +and over the past few days I've logged four issues that I've tagged +[`Architecture change`](https://git.journeyman.cc/simon/post-scarcity/issues?q=&type=all&state=open&labels=15&milestone=0&assignee=0&poster=0). + +These are: + +* 17: [Add readtables; implement quote and keyword through readtables.](https://git.journeyman.cc/simon/post-scarcity/issues/17) +* 18: [Consider converting from `char32_t` to `char32_t`, everywhere.](https://git.journeyman.cc/simon/post-scarcity/issues/18) +* 20: [Environment in stack frame.](https://git.journeyman.cc/simon/post-scarcity/issues/20) +* 21: [Temporary objects in a function must be bound to a locals slot in the stack frame](https://git.journeyman.cc/simon/post-scarcity/issues/21) + +These, especially the last, mean a fundamental change not only to the Lisp calling convention, but also to everything which may create objects — even if they're never expected to be called directly from Lisp. Generally, **every** such thing must be called with the standard Lisp calling convention (and so potentially could be called directly from Lisp), except for those very rare things where calling them with the standard calling convention would cause a runaway infinite recursion (the obvious ones are the constructors for `stack_frame` and `cons`, but there may be others); and the Lisp calling convention has to change. Which means a lot of things which have already been written for `0.1.0` have to change. + +So I have this morning started a new feature branch, `feature/reengineering-17-21`, to work on these four issues together; and I think the first thing to do is to audit the existing code for functions that are affected by these changes (I mean: *every* Lisp-callable function is affected by 20, but apart from that). This may also resolve the `[MANAGED_POINTER_ONLY](https://git.journeyman.cc/simon/post-scarcity/src/commit/812a1be7d9eb97c25aa07477eb71605b1af93397/src/c/payloads/function.h#L16)` issue (see [20260415](#20260415)). I *may* leave that in as a compile time switch because passing the unmanaged pointer is certainly a performance optimisation, but it will make writing the compiler a bit harder. + +I'm not ignoring the fact that a lot of stuff in `0.1.0` is still fundamentally broken, and the REPL still doesn't work; but getting the calling convention right at this point is still the right thing to do, and won't make any of those problems worse. Indeed, it may resolve some of them. + +I think this week is going to be mostly a thinking week — partly because the weather forecast is unusually benign, and it would be sensible get some outdoor work done. + ## 20260415 OK, I have been diverted down a side-project on a side-project. I decided that since Post Scarcity definitely needs a compiler, I should learn to write a compiler, and so I should start by writing one for a simpler Lisp than Post -Scarcity. So I started to write -[one in Guile Scheme for Beowulf](https://git.journeyman.cc/simon/naegling). +Scarcity. So I started to write [one in Guile Scheme for Beowulf](https://git.journeyman.cc/simon/naegling). This is started but a long way from finished. I'm also not very enamoured of Guile Scheme, and am starting to wonder whether in fact I should be writing if in [Beowulf](https://git.journeyman.cc/simon/beowulf) for Beowulf. @@ -75,7 +95,7 @@ managed pointer is cheap, it isn't free. But it's worth thinking about. - + ## 20260331 Substrate layer `print` is written; all the building blocks for substrate diff --git a/src/c/debug.c b/src/c/debug.c index 3665459..a551b19 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -37,7 +37,7 @@ int verbosity = 0; * `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 ) { +void debug_print( char32_t *message, int level, int indent ) { #ifdef DEBUG if ( level & verbosity ) { fwide( stderr, 1 ); @@ -116,7 +116,7 @@ void debug_println( int level ) { * * Remaining arguments should match the slots in the format string. */ -void debug_printf( int level, int indent, wchar_t *format, ... ) { +void debug_printf( int level, int indent, char32_t *format, ... ) { #ifdef DEBUG if ( level & verbosity ) { fwide( stderr, 1 ); @@ -172,7 +172,7 @@ void debug_dump_object( struct pso_pointer pointer, int level, int indent ) { //void debug_print_binding( struct cons_pointer key, struct cons_pointer val, // bool deep, int level, int indent ) { //#ifdef DEBUG -// // wchar_t * depth = (deep ? L"Deep" : L"Shallow"); +// // char32_t * depth = (deep ? L"Deep" : L"Shallow"); // // debug_print( ( deep ? L"Deep" : L"Shallow" ), level, indent ); // debug_print( L" binding `", level, indent ); diff --git a/src/c/debug.h b/src/c/debug.h index be9d166..2c4f3d0 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -20,6 +20,8 @@ /* * wide characters */ +#include +#include #include #include @@ -102,7 +104,7 @@ */ extern int verbosity; -void debug_print( wchar_t *message, int level, int indent ); +void debug_print( char32_t *message, int level, int indent ); void debug_print_object( struct pso_pointer object, int level, int indent ); @@ -112,6 +114,6 @@ void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); -void debug_printf( int level, int indent, wchar_t *format, ... ); +void debug_printf( int level, int indent, char32_t *format, ... ); #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index e23b512..96089fa 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -18,6 +18,7 @@ #include #include #include +#include #include #include /* @@ -149,6 +150,9 @@ int initialise_io( ) { } struct pso_pointer initialise_default_streams( struct pso_pointer env ) { + // todo: issue #21: should this have stack frame passed in? + // It's called in initialisation before everything else is set + // up, so **possibly** not? lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); @@ -226,7 +230,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { len++; } - wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + char32_t *buffer = calloc( len + 1, sizeof( char32_t ) ); /* worst case, one wide char = four utf bytes */ result = calloc( ( len * 4 ) + 1, sizeof( char ) ); @@ -268,8 +272,8 @@ wint_t url_fgetwc( URL_FILE *input ) { case CFTYPE_CURL:{ char *cbuff = - calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); - wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + calloc( sizeof( char32_t ) + 2, sizeof( char ) ); + char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); size_t count = 0; @@ -414,18 +418,20 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, return result; } -struct pso_pointer add_meta_integer( struct pso_pointer meta, wchar_t *key, +struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, long int value ) { + // todo: issue #21: must have stack frame passed in. return c_cons( c_cons ( c_string_to_lisp_keyword( key ), make_integer( value ) ), meta ); } -struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, +struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, char *value ) { + // todo: issue #21: must have stack frame passed in. value = trim( value ); - wchar_t buffer[strlen( value ) + 1]; + char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); return @@ -434,10 +440,9 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, wchar_t *key, c_string_to_lisp_string( buffer ) ), meta ); } -struct pso_pointer add_meta_time( struct pso_pointer meta, wchar_t *key, +struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, time_t *value ) { - /* I don't yet have a concept of a date-time object, which is a - * bit of an oversight! */ + // todo: issue #21: must have stack frame passed in. char datestring[256]; strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), @@ -469,7 +474,7 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // s[offset] = ( char ) 0; // char *name = trim( s ); // char *value = trim( &s[++offset] ); - // wchar_t wname[strlen( name )]; + // char32_t wname[strlen( name )]; // mbstowcs( wname, name, strlen( name ) + 1 ); @@ -716,7 +721,7 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, debug_println( DEBUG_IO ); struct pso2 *cell = pointer_to_object( cursor ); - cursor = make_string( ( wchar_t ) c, nil ); + cursor = make_string( ( char32_t ) c, nil ); cell->payload.string.cdr = cursor; } } diff --git a/src/c/io/print.c b/src/c/io/print.c index ca0e5c1..fbe2845 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -20,6 +20,7 @@ /* * wide characters */ +#include #include #include /* libcurl, used for io */ @@ -54,7 +55,7 @@ struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, * TODO: this does not yet even nearly cope with all the possible special * cases. */ -void write_char( wchar_t wc, URL_FILE * output, bool escape) { +void write_char( char32_t wc, URL_FILE * output, bool escape) { if (escape && !iswprint(wc)) { url_fwprintf(output, L"\\%04x", wc); // url_fputwc(L'\\', output); @@ -79,7 +80,7 @@ struct pso_pointer print_string_like_thing(struct pso_pointer p, if (keywordp(p) || stringp(p) || symbolp(p)) { for (struct pso_pointer cursor = p; !nilp(cursor); cursor = pointer_to_object(cursor)->payload.string.cdr) { - wchar_t wc = pointer_to_object(cursor)->payload.string.character; + char32_t wc = pointer_to_object(cursor)->payload.string.character; write_char( wc, output, escape); } diff --git a/src/c/io/read.c b/src/c/io/read.c index f78e796..c2d0335 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -118,7 +118,7 @@ struct pso_pointer read_number( if ( nilp( character ) ) { character = get_character( stream ); } - wchar_t c = nilp( character ) + char32_t c = nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -150,7 +150,7 @@ struct pso_pointer read_symbol( character = get_character( stream ); } - wchar_t c = nilp( character ) + char32_t c = nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -207,7 +207,7 @@ struct pso_pointer read( if ( !nilp( readmacro ) ) { // invoke the read macro on the stream } else if ( readp( stream ) && characterp( character ) ) { - wchar_t c = + char32_t c = pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 4b7ba2c..df2d4de 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -41,6 +41,7 @@ * @return struct pso_pointer a pointer to the newly allocated object */ struct pso_pointer allocate( char *tag, uint8_t size_class ) { + // todo: issue #21: must have stack frame passed in. // `t`, because if `allocate_page` fails it will be set to `nil`. struct pso_pointer result = t; diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 928a6aa..c9894cf 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -15,6 +15,7 @@ #include "memory/header.h" #include "memory/pointer.h" +// todo: issue #21: must have stack frame passed in. struct pso_pointer allocate( char *tag, uint8_t size_class ); struct pso_pointer dec_ref( struct pso_pointer pointer ); diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 8b956f1..721ba1e 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -37,7 +37,7 @@ struct pso_pointer get_tag_string( struct pso_pointer p ) { for ( int i = 2 - 1; i >= 0; i-- ) { result = - make_string( ( wchar_t ) ( object->header.tag.bytes.mnemonic[i] ), + make_string( ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), result ); } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 5d66359..b048658 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -41,5 +41,6 @@ struct pso_pointer lisp_bind( struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ) { + // todo: issue #21: must have stack frame passed in. return c_cons( c_cons( key, value ), store ); } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 24067c6..5af6136 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -48,6 +48,7 @@ void int_handler( int dummy ) { * Very simple read/eval/print loop for bootstrapping. */ void c_repl( bool show_prompt ) { + // todo: issue #21: must have stack frame passed in. signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index 6706539..aa8c416 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -13,7 +13,7 @@ #define SRC_C_OPS_REPL_H_ - + // todo: issue #21: must have stack frame passed in. void c_repl( ); diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 5e51204..43ea132 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -36,6 +36,7 @@ * the argument was not a sequence. */ struct pso_pointer c_reverse( struct pso_pointer sequence ) { + // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; for ( struct pso_pointer cursor = sequence; !nilp( sequence ); diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 18c8d55..f84d327 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -66,7 +66,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * 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 + * char32_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, @@ -138,7 +138,7 @@ struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ) { /** * Return a lisp string representation of this wide character string. */ -struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { +struct pso_pointer c_string_to_lisp_string( char32_t *string ) { struct pso_pointer result = nil; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { @@ -157,11 +157,11 @@ struct pso_pointer c_string_to_lisp_string( wchar_t *string ) { * Return a lisp symbol representation of this wide character string. In * symbols, I am accepting only lower case characters. */ -struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { +struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - wchar_t c = towlower( symbol[i] ); + char32_t c = towlower( symbol[i] ); if ( iswalpha( c ) || c == L'-' || c == L'*' ) { result = make_symbol( c, result ); @@ -175,11 +175,11 @@ struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { * 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 c_string_to_lisp_keyword( char32_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - wchar_t c = towlower( symbol[i] ); + char32_t c = towlower( symbol[i] ); if ( iswalnum( c ) || c == L'-' ) { result = make_keyword( c, result ); diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index e80692e..d17d9fc 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -13,6 +13,7 @@ /* * wide characters */ +#include #include #include @@ -25,10 +26,10 @@ 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_string( char32_t *string ); -struct pso_pointer c_string_to_lisp_keyword( wchar_t *symbol ); +struct pso_pointer c_string_to_lisp_keyword( char32_t *symbol ); -struct pso_pointer c_string_to_lisp_symbol( wchar_t *symbol ); +struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ); #endif diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c index aa370e4..cb807c1 100644 --- a/src/c/payloads/character.c +++ b/src/c/payloads/character.c @@ -10,6 +10,7 @@ /* * wide characters */ +#include #include #include @@ -28,7 +29,7 @@ struct pso_pointer make_character( wint_t c ) { if ( !nilp( result ) ) { pointer_to_object( result )->payload.character.character = - ( wchar_t ) c; + ( char32_t ) c; } return result; diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 355b79a..1f5e099 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -22,6 +22,7 @@ /* * wide characters */ +#include #include #include @@ -33,7 +34,7 @@ * @brief a single character, as returned by the reader. */ struct character_payload { - wchar_t character; + char32_t character; }; struct pso_pointer make_character( wint_t c ); diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 4338468..04e5251 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -30,7 +30,8 @@ * @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 c_cons( struct pso_pointer car, struct pso_pointer cdr ) { +struct pso_pointer c_cons(struct pso_pointer car, struct pso_pointer cdr) { + // todo: issue #21: must have stack frame passed in. struct pso_pointer result = allocate( CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); @@ -67,7 +68,8 @@ struct pso_pointer c_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 c_cdr( struct pso_pointer p ) { +struct pso_pointer c_cdr(struct pso_pointer p) { + // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( p ); diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index c7dd21c..61eaf87 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -30,6 +30,7 @@ struct pso_pointer c_car( struct pso_pointer cons ); struct pso_pointer c_cdr( struct pso_pointer cons ); +// todo: issue #21: must have stack frame passed in. struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ); struct pso_pointer destroy_cons( struct pso_pointer fp, diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 0d81c20..d59ce85 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -33,6 +33,7 @@ */ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ) { + // todo: issue #21: must have stack frame passed in. va_list args; va_start( args, previous ); diff --git a/utils_src/readprintwc/readprintwc.c b/utils_src/readprintwc/readprintwc.c index e221c9c..8a002e4 100644 --- a/utils_src/readprintwc/readprintwc.c +++ b/utils_src/readprintwc/readprintwc.c @@ -7,7 +7,7 @@ int main( int argc, char *argv[] ) { fwide( stdin, 1 ); fwide( stdout, 1 ); - for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) { + for (char32_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) { if (c != '\n') { fwprintf( stdout, L"Read character %d, %C\t", (int)c, c); fputwc( c, stdout); From f05d1af9d6924e870760644b339ec2344c13436e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 20 Apr 2026 13:59:47 +0100 Subject: [PATCH 44/77] Successfully added mutexes protecting freelist access. No behaviour change. --- src/c/io/io.c | 10 ++--- src/c/memory/memory.c | 71 ++++++++++++++++++++++++++++++++++++ src/c/memory/memory.h | 5 +++ src/c/memory/page.c | 4 +- src/c/memory/pso.c | 83 +++++++++++++++++------------------------- src/c/ops/bind.c | 4 +- src/c/ops/eval_apply.c | 4 +- src/c/ops/list_ops.c | 2 +- src/c/ops/repl.c | 2 +- src/c/ops/reverse.c | 4 +- src/c/payloads/cons.c | 4 +- src/c/payloads/cons.h | 2 +- src/c/payloads/stack.c | 2 +- src/c/payloads/stack.h | 4 ++ 14 files changed, 132 insertions(+), 69 deletions(-) diff --git a/src/c/io/io.c b/src/c/io/io.c index 96089fa..3d4de7c 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -167,7 +167,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { env ); lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword ( L"url" ), c_string_to_lisp_string @@ -182,7 +182,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lisp_stdout = lock_object( make_write_stream ( file_to_url_file( stdout ), - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword( L"url" ), c_string_to_lisp_string ( L"::system:standard-output" ) ), @@ -195,7 +195,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lisp_stderr = lock_object( make_write_stream ( file_to_url_file( stderr ), - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword( L"url" ), c_string_to_lisp_string ( L"::system:standard-output" ) ), @@ -422,7 +422,7 @@ struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, long int value ) { // todo: issue #21: must have stack frame passed in. return - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword( key ), make_integer( value ) ), meta ); } @@ -435,7 +435,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, mbstowcs( buffer, value, strlen( value ) + 1 ); return - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword( key ), c_string_to_lisp_string( buffer ) ), meta ); } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index eaeecbd..b4b84cd 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -7,18 +7,23 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include +#include +#include #include "debug.h" #include "memory/memory.h" #include "memory/node.h" +#include "memory/page.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" #include "ops/bind.h" @@ -29,6 +34,11 @@ */ struct pso_pointer freelists[MAX_SIZE_CLASS]; +/** + * Mutices to lock the freelists during access. + */ +pthread_mutex_t freelists_mutices[MAX_SIZE_CLASS]; + /** * @brief Flag to prevent re-initialisation. */ @@ -63,3 +73,64 @@ struct pso_pointer initialise_memory( uint32_t node ) { return t; } + +/** + * @brief Pop an object off the freelist for the specified `size_class`. + */ +struct pso_pointer pop_freelist( uint8_t size_class) { + // `t`, because if `allocate_page` fails it will be set to `nil`. + struct pso_pointer result = t; + + if ( size_class <= MAX_SIZE_CLASS ) { + if ( nilp( freelists[size_class] ) ) { + result = allocate_page( size_class ); + } + + if ( nilp( result ) ) { + fputws( L"FATAL: Page space exhausted\n", stderr ); + exit( 1 ); // TODO: we don't want to do this! Somehow, we need to + // recover a workable environment, ideally by throwing a pre-made + // exception. + } + + if ( !exceptionp( result ) && !nilp( result ) ) { + pthread_mutex_lock( &freelists_mutices[size_class]); + result = freelists[size_class]; + struct pso2 *object = pointer_to_object( result ); + freelists[size_class] = object->payload.free.next; + pthread_mutex_unlock(&freelists_mutices[size_class]); + + /* 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 ) { + // 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 ) { + fwprintf( stderr, + L"WARNING: Request to allocate object of size class %d, which is not implemented", + size_class); + } + } + } // TODO: else throw exception + + return result; +} + +void push_freelist( struct pso_pointer p) { + struct pso2 *obj = pointer_to_object( p ); + uint8_t size_class = ( obj->header.tag.bytes.size_class ); + + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); + + pthread_mutex_lock( &freelists_mutices[size_class]); + + if ( size_class <= MAX_SIZE_CLASS ) { + obj->payload.free.next = freelists[size_class]; + freelists[size_class] = p; + } + + pthread_mutex_unlock(&freelists_mutices[size_class]); +} diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index 5911f2f..720bf1d 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -9,6 +9,7 @@ #ifndef __psse_memory_memory_h #define __psse_memory_memory_h +#include #include "memory/pointer.h" @@ -25,6 +26,10 @@ struct pso_pointer initialise_memory( ); +struct pso_pointer pop_freelist( uint8_t size_class); +void push_freelist( struct pso_pointer p); + extern struct pso_pointer out_of_memory_exception; extern struct pso_pointer freelists[]; +extern pthread_mutex_t freelists_mutices[]; #endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 0b03b35..2cc12c7 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -319,11 +319,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) { L"\nAllocated page %d for objects of size class %x.\n", npages_allocated, size_class ); + pthread_mutex_lock( &freelists_mutices[size_class]); freelists[size_class] = initialise_page( ( union page * ) pg, npages_allocated, size_class, freelists[size_class] ); - -// result = freelists[size_class]; + pthread_mutex_unlock( &freelists_mutices[size_class]); debug_printf( DEBUG_ALLOC, 0, L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n", diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index df2d4de..1a25c26 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -19,6 +19,7 @@ #include #include #include +#include #include "debug.h" @@ -35,15 +36,24 @@ /** * @brief Allocate an object of this size_class with this tag. + * + * All objects that are allocated (after completion of init)) should be linked + * onto the `locals` slot on a stack frame. This guarantees + * 1. that they get `inc_ref`ed; and that, + * 2. if nothing else hangs onto them they will be reclaimed when that stack + * frame is reclaimed. + * for some objects (e.g. those cons cells on the locals list) this isn't + * possible due to infinite recursion, but those special cases need to be + * audited carefully * + * @param stack_pointer C (NOT Lisp!) pointer to an active stack frame (or + * NULL, but only during initialisation). * @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 allocate( /* struct pso4 * stack_pointer,*/ char *tag, uint8_t size_class ) { // todo: issue #21: must have stack frame passed in. - // `t`, because if `allocate_page` fails it will be set to `nil`. - struct pso_pointer result = t; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -51,41 +61,26 @@ struct pso_pointer allocate( char *tag, uint8_t size_class ) { size_class, tag ); #endif - if ( size_class <= MAX_SIZE_CLASS ) { - if ( nilp( freelists[size_class] ) ) { - result = allocate_page( size_class ); - } + struct pso_pointer result = pop_freelist(size_class); - if ( nilp( result ) ) { - fputws( L"FATAL: Page space exhausted\n", stderr ); - exit( 1 ); // TODO: we don't want to do this! Somehow, we need to - // recover a workable environment, ideally by throwing a pre-made - // exception. - } - - if ( !exceptionp( result ) && !nilp( result ) ) { - result = freelists[size_class]; - struct pso2 *object = pointer_to_object( result ); - freelists[size_class] = object->payload.free.next; - - strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), tag, - TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", - result.page, result.offset ); - - /* 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 ) { - // 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 + if (!nilp( result)) { + strncpy( ( char * ) ( pointer_to_object(result)->header.tag.bytes.mnemonic ), tag, + TAGLENGTH ); + + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", + result.page, result.offset ); +// if ( stack_pointer != NULL && +// (stack_pointer->header.tag.value & 0xffffff) == STACKTV) { +// struct pso_pointer locals = make_cons(result, +// stack_pointer->payload.stack_frame.locals); +// stack_pointer->payload.stack_frame.locals = locals; +// +// } else { +// fputws( L"WARNING: No stack frame passed to `allocate`.\n", stderr); +// } + } else { + // TODO: throw exception + } #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, @@ -208,19 +203,7 @@ struct pso_pointer free_object( struct pso_pointer p ) { 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; + push_freelist(p); return result; } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index b048658..e34122c 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -35,12 +35,12 @@ struct pso_pointer lisp_bind( struct pso_pointer value = fetch_arg( frame, 1 ); struct pso_pointer store = fetch_arg( frame, 2 ); - return c_cons( c_cons( key, value ), store ); + return make_cons( make_cons( key, value ), store ); } struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ) { // todo: issue #21: must have stack frame passed in. - return c_cons( c_cons( key, value ), store ); + return make_cons( make_cons( key, value ), store ); } diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 9333a03..819a2eb 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -84,11 +84,11 @@ struct pso_pointer eval( // break; default: result = - make_exception( c_cons + make_exception( make_cons ( c_string_to_lisp_string ( L"Can't yet evaluate things of this type: " ), result ), frame_pointer, - c_cons( c_cons + make_cons( make_cons ( c_string_to_lisp_keyword( L"tag" ), get_tag_string( result ) ), nil ), nil ); diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 10ccc60..4e58600 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -66,7 +66,7 @@ struct pso_pointer cons( struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif - return c_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); + return make_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); } #endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 5af6136..c3fa5a1 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -52,7 +52,7 @@ void c_repl( bool show_prompt ) { signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); - struct pso_pointer env = consp( oblist ) ? oblist : c_cons( oblist, nil ); + struct pso_pointer env = consp( oblist ) ? oblist : make_cons( oblist, nil ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 43ea132..4e2704b 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -44,7 +44,7 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) { struct pso2 *object = pointer_to_object( cursor ); switch ( get_tag_value( cursor ) ) { case CONSTV: - result = c_cons( c_car( cursor ), result ); + result = make_cons( c_car( cursor ), result ); break; case KEYTV: // TODO: should you be able to reverse keywords and symbols? @@ -65,7 +65,7 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) { break; default: result = - make_exception( c_cons( c_string_to_lisp_string + make_exception( make_cons( c_string_to_lisp_string ( L"Invalid object in sequence" ), cursor ), nil, nil, nil ); goto exit; diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 04e5251..8a05088 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -30,7 +30,7 @@ * @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 c_cons(struct pso_pointer car, struct pso_pointer cdr) { +struct pso_pointer make_cons(struct pso_pointer car, struct pso_pointer cdr) { // todo: issue #21: must have stack frame passed in. struct pso_pointer result = allocate( CONSTAG, 2 ); @@ -84,7 +84,7 @@ struct pso_pointer c_cdr(struct pso_pointer p) { break; default: result = - make_exception( c_cons + make_exception( make_cons ( c_string_to_lisp_string ( L"Invalid type for cdr" ), get_tag_string( p ) ), nil, nil, nil ); diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 61eaf87..0192f4e 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -31,7 +31,7 @@ struct pso_pointer c_car( struct pso_pointer cons ); struct pso_pointer c_cdr( struct pso_pointer cons ); // todo: issue #21: must have stack frame passed in. -struct pso_pointer c_cons( struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer make_cons( struct pso_pointer car, struct pso_pointer cdr ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index d59ce85..89fb617 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -72,7 +72,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, for ( ; cursor < arg_count; cursor++ ) { more_args = - c_cons( va_arg( args, struct pso_pointer ), more_args ); + make_cons( va_arg( args, struct pso_pointer ), more_args ); } frame->payload.stack_frame.more = c_reverse( more_args ); diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 3cbb853..ed02588 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -31,6 +31,10 @@ struct stack_frame_payload { struct pso_pointer more; /** the function to be called. */ struct pso_pointer function; + /** the execute-time environment */ + struct pso_pointer env; + /** a list of objects created in the context of this frame */ + struct pso_pointer locals; /** the number of arguments provided. */ uint32_t args; /** the depth of the stack below this frame */ From 6148d3699fe07f416ceae7f1170140a3c7dd01c3 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 20 Apr 2026 18:29:28 +0100 Subject: [PATCH 45/77] Right, I'm committing this session because I'm too cold and tired to go on. It does not at present build (and it's going to take a good bit more work before it does). --- docs/State-of-play.md | 2 +- src/c/debug.h | 4 +- src/c/io/io.c | 46 +++--- src/c/io/io.h | 2 +- src/c/io/print.c | 256 +++++++++++++++++----------------- src/c/memory/memory.c | 98 ++++++------- src/c/memory/memory.h | 6 +- src/c/memory/page.c | 4 +- src/c/memory/pso.c | 60 ++++---- src/c/memory/pso.h | 5 +- src/c/ops/bind.c | 2 +- src/c/ops/eval_apply.c | 18 ++- src/c/ops/list_ops.c | 4 +- src/c/ops/repl.c | 6 +- src/c/ops/repl.h | 2 +- src/c/ops/reverse.c | 6 +- src/c/ops/string_ops.c | 39 ++++-- src/c/ops/string_ops.h | 21 ++- src/c/payloads/character.c | 4 +- src/c/payloads/character.h | 3 +- src/c/payloads/cons.c | 18 +-- src/c/payloads/cons.h | 7 +- src/c/payloads/exception.c | 3 +- src/c/payloads/integer.c | 5 +- src/c/payloads/integer.h | 4 +- src/c/payloads/psse_string.c | 10 +- src/c/payloads/read_stream.c | 6 +- src/c/payloads/read_stream.h | 3 +- src/c/payloads/stack.c | 12 +- src/c/payloads/stack.h | 8 +- src/c/payloads/write_stream.c | 6 +- src/c/payloads/write_stream.h | 3 +- 32 files changed, 364 insertions(+), 309 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 8ebf29c..2faad50 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -9,7 +9,7 @@ and over the past few days I've logged four issues that I've tagged These are: * 17: [Add readtables; implement quote and keyword through readtables.](https://git.journeyman.cc/simon/post-scarcity/issues/17) -* 18: [Consider converting from `char32_t` to `char32_t`, everywhere.](https://git.journeyman.cc/simon/post-scarcity/issues/18) +* 18: [Consider converting from `wchar_t` to `char32_t`, everywhere.](https://git.journeyman.cc/simon/post-scarcity/issues/18) * 20: [Environment in stack frame.](https://git.journeyman.cc/simon/post-scarcity/issues/20) * 21: [Temporary objects in a function must be bound to a locals slot in the stack frame](https://git.journeyman.cc/simon/post-scarcity/issues/21) diff --git a/src/c/debug.h b/src/c/debug.h index 2c4f3d0..4c3a8b3 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -104,7 +104,7 @@ */ extern int verbosity; -void debug_print( char32_t *message, int level, int indent ); +void debug_print( char32_t * message, int level, int indent ); void debug_print_object( struct pso_pointer object, int level, int indent ); @@ -114,6 +114,6 @@ void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); -void debug_printf( int level, int indent, char32_t *format, ... ); +void debug_printf( int level, int indent, char32_t * format, ... ); #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 3d4de7c..db69b73 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -150,9 +150,9 @@ int initialise_io( ) { } struct pso_pointer initialise_default_streams( struct pso_pointer env ) { - // todo: issue #21: should this have stack frame passed in? - // It's called in initialisation before everything else is set - // up, so **possibly** not? + // todo: issue #21: should this have stack frame passed in? + // It's called in initialisation before everything else is set + // up, so **possibly** not? lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); @@ -168,11 +168,11 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-input" ) ), - nil ) ) ); + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-input" ) ), + nil ) ) ); env = c_bind( lisp_io_in, lisp_stdin, env ); @@ -183,10 +183,10 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lock_object( make_write_stream ( file_to_url_file( stdout ), make_cons( make_cons - ( c_string_to_lisp_keyword( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-output" ) ), - nil ) ) ); + ( c_string_to_lisp_keyword( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-output" ) ), + nil ) ) ); env = c_bind( lisp_io_out, lisp_stdout, env ); } @@ -196,10 +196,10 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { lock_object( make_write_stream ( file_to_url_file( stderr ), make_cons( make_cons - ( c_string_to_lisp_keyword( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-output" ) ), - nil ) ) ); + ( c_string_to_lisp_keyword( L"url" ), + c_string_to_lisp_string + ( L"::system:standard-output" ) ), + nil ) ) ); env = c_bind( lisp_io_log, lisp_stderr, env ); } @@ -420,29 +420,29 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, long int value ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. return make_cons( make_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, char32_t *key, char *value ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. value = trim( value ); char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); return make_cons( make_cons - ( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); + ( c_string_to_lisp_keyword( key ), + c_string_to_lisp_string( buffer ) ), meta ); } struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, time_t *value ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. char datestring[256]; strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), diff --git a/src/c/io/io.h b/src/c/io/io.h index a2b733c..f90e589 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -21,7 +21,7 @@ extern CURLSH *io_share; int initialise_io( ); struct pso_pointer initialise_default_streams( struct pso_pointer env ); -#define C_IO_IN L"*in*" +#define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" #define C_IO_LOG L"*log*" diff --git a/src/c/io/print.c b/src/c/io/print.c index fbe2845..d6bf63b 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -44,9 +44,9 @@ #include "ops/truth.h" -struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, - bool escape); - +struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, + bool escape ); + /** * @brief write this character `wc` to this `output` stream, escaping it if * 1. `escape` is true; and @@ -54,75 +54,77 @@ struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, * * TODO: this does not yet even nearly cope with all the possible special * cases. - */ -void write_char( char32_t wc, URL_FILE * output, bool escape) { - if (escape && !iswprint(wc)) { - url_fwprintf(output, L"\\%04x", wc); - // url_fputwc(L'\\', output); - } else { - url_fputwc(wc, output); - } + */ +void write_char( char32_t wc, URL_FILE *output, bool escape ) { + if ( escape && !iswprint( wc ) ) { + url_fwprintf( output, L"\\%04x", wc ); + // url_fputwc(L'\\', output); + } else { + url_fputwc( wc, output ); + } } -struct pso_pointer print_string_like_thing(struct pso_pointer p, - URL_FILE *output, bool escape) { - switch (get_tag_value(p)) { - case KEYTV: - url_fputwc(L':', output); - break; - case STRINGTV: - if (escape) - url_fputwc(L'"', output); - break; - } +struct pso_pointer print_string_like_thing( struct pso_pointer p, + URL_FILE *output, bool escape ) { + switch ( get_tag_value( p ) ) { + case KEYTV: + url_fputwc( L':', output ); + break; + case STRINGTV: + if ( escape ) + url_fputwc( L'"', output ); + break; + } - if (keywordp(p) || stringp(p) || symbolp(p)) { - for (struct pso_pointer cursor = p; !nilp(cursor); - cursor = pointer_to_object(cursor)->payload.string.cdr) { - char32_t wc = pointer_to_object(cursor)->payload.string.character; + if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { + for ( struct pso_pointer cursor = p; !nilp( cursor ); + cursor = pointer_to_object( cursor )->payload.string.cdr ) { + char32_t wc = + pointer_to_object( cursor )->payload.string.character; - write_char( wc, output, escape); - } - } + write_char( wc, output, escape ); + } + } - if (stringp(p)) { - if (escape) - url_fputwc(L'"', output); - } - - return p; + if ( stringp( p ) ) { + if ( escape ) + url_fputwc( L'"', output ); + } + + return p; } -struct pso_pointer write_list_content(struct pso_pointer p, URL_FILE *output, - bool escape) { - struct pso_pointer result = nil; +struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, + bool escape ) { + struct pso_pointer result = nil; - if (consp(p)) { - for (; consp(p); p = c_cdr(p)) { - struct pso2 *object = pointer_to_object(p); + if ( consp( p ) ) { + for ( ; consp( p ); p = c_cdr( p ) ) { + struct pso2 *object = pointer_to_object( p ); - result = in_write(object->payload.cons.car, output, escape); + result = in_write( object->payload.cons.car, output, escape ); - if (exceptionp(result)) - break; + 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_write(object->payload.cons.cdr, output, escape); - } - } - } else { - // TODO: return exception - } + 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_write( object->payload.cons.cdr, output, escape ); + } + } + } else { + // TODO: return exception + } - return result; + return result; } /** @@ -135,52 +137,53 @@ struct pso_pointer write_list_content(struct pso_pointer p, URL_FILE *output, * reader; otherwise, print it appropriately for human readers. * @return p on success, exception on failure. */ -struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, - bool escape) { - struct pso2 *object = pointer_to_object(p); - struct pso_pointer result = nil; +struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, + bool escape ) { + struct pso2 *object = pointer_to_object( p ); + struct pso_pointer result = nil; - if (object != NULL) { - uint32_t v = get_tag_value(p); - switch (v) { - case CHARACTERTV: - write_char(object->payload.character.character, output, escape); - break; - case CONSTV: - url_fputwc(L'(', output); - result = write_list_content(p, output, escape); - url_fputwc(L')', output); - break; - case INTEGERTV: - url_fwprintf(output, L"%d", - (int64_t)(object->payload.integer.value)); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - print_string_like_thing(p, output, escape); - break; - case NILTV: - url_fputws(L"nil", output); - break; - case READTV: - case WRITETV: - url_fwprintf(output, L"<%s stream: ", - v == READTV ? "read" : "write"); - in_write(object->payload.stream.meta, output, escape); - url_fputwc(L'>', output); - break; - case TRUETV: - url_fputwc(L't', output); - break; - default: - // TODO: return exception - } - } else { - // TODO: return exception - } + if ( object != NULL ) { + uint32_t v = get_tag_value( p ); + switch ( v ) { + case CHARACTERTV: + write_char( object->payload.character.character, output, + escape ); + break; + case CONSTV: + url_fputwc( L'(', output ); + result = write_list_content( p, output, escape ); + url_fputwc( L')', output ); + break; + case INTEGERTV: + url_fwprintf( output, L"%d", + ( int64_t ) ( object->payload.integer.value ) ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + print_string_like_thing( p, output, escape ); + break; + case NILTV: + url_fputws( L"nil", output ); + break; + case READTV: + case WRITETV: + url_fwprintf( output, L"<%s stream: ", + v == READTV ? "read" : "write" ); + in_write( object->payload.stream.meta, output, escape ); + url_fputwc( L'>', output ); + break; + case TRUETV: + url_fputwc( L't', output ); + break; + default: + // TODO: return exception + } + } else { + // TODO: return exception + } - return result; + return result; } /** @@ -195,31 +198,32 @@ struct pso_pointer in_write(struct pso_pointer p, URL_FILE *output, * @param nl_after if true, print a newline *after* printing `p`; else a space. * @return p on success, exception on failure. */ -struct pso_pointer write(struct pso_pointer p, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after) { - struct pso_pointer result = p; - URL_FILE *output = writep(stream) - ? pointer_to_object(stream)->payload.stream.stream - : file_to_url_file(stdout); +struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, + bool escape, bool nl_before, bool nl_after ) { + struct pso_pointer result = p; + 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 ); - if (nl_before) - url_fputwc(L'\n', output); + if ( nl_before ) + url_fputwc( L'\n', output ); - result = in_write(p, output, true); + result = in_write( p, output, true ); - url_fputwc(nl_after ? L'\n' : L' ', output); + url_fputwc( nl_after ? L'\n' : L' ', output ); - dec_ref(stream); - } else { - result = make_exception( - c_string_to_lisp_string(L"Bad write stream passed to write."), nil, - nil, nil); - } + dec_ref( stream ); + } else { + result = + make_exception( c_string_to_lisp_string + ( L"Bad write stream passed to write." ), nil, nil, + nil ); + } - return result; + return result; } /** @@ -229,13 +233,13 @@ struct pso_pointer write(struct pso_pointer p, struct pso_pointer 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 c_print(struct pso_pointer p, struct pso_pointer stream) { - return write(p, stream, true, true, false); +struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ) { + return write( p, stream, true, true, false ); } /** * @brief princ is pretty much like print except things are printed `unescaped` */ -struct pso_pointer c_princ(struct pso_pointer p, struct pso_pointer stream) { - return write(p, stream, false, true, false); +struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) { + return write( p, stream, false, true, false ); } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index b4b84cd..6e7e5af 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -77,60 +77,60 @@ struct pso_pointer initialise_memory( uint32_t node ) { /** * @brief Pop an object off the freelist for the specified `size_class`. */ -struct pso_pointer pop_freelist( uint8_t size_class) { - // `t`, because if `allocate_page` fails it will be set to `nil`. - struct pso_pointer result = t; - - if ( size_class <= MAX_SIZE_CLASS ) { - if ( nilp( freelists[size_class] ) ) { - result = allocate_page( size_class ); - } +struct pso_pointer pop_freelist( uint8_t size_class ) { + // `t`, because if `allocate_page` fails it will be set to `nil`. + struct pso_pointer result = t; - if ( nilp( result ) ) { - fputws( L"FATAL: Page space exhausted\n", stderr ); - exit( 1 ); // TODO: we don't want to do this! Somehow, we need to - // recover a workable environment, ideally by throwing a pre-made - // exception. - } + if ( size_class <= MAX_SIZE_CLASS ) { + if ( nilp( freelists[size_class] ) ) { + result = allocate_page( size_class ); + } - if ( !exceptionp( result ) && !nilp( result ) ) { - pthread_mutex_lock( &freelists_mutices[size_class]); - result = freelists[size_class]; - struct pso2 *object = pointer_to_object( result ); - freelists[size_class] = object->payload.free.next; - pthread_mutex_unlock(&freelists_mutices[size_class]); + if ( nilp( result ) ) { + fputws( L"FATAL: Page space exhausted\n", stderr ); + exit( 1 ); // TODO: we don't want to do this! Somehow, we need to + // recover a workable environment, ideally by throwing a pre-made + // exception. + } - /* 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 ) { - // 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 ) { - fwprintf( stderr, - L"WARNING: Request to allocate object of size class %d, which is not implemented", - size_class); - } - } - } // TODO: else throw exception - - return result; + if ( !exceptionp( result ) && !nilp( result ) ) { + pthread_mutex_lock( &freelists_mutices[size_class] ); + result = freelists[size_class]; + struct pso2 *object = pointer_to_object( result ); + freelists[size_class] = object->payload.free.next; + pthread_mutex_unlock( &freelists_mutices[size_class] ); + + /* 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 ) { + // 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 ) { + fwprintf( stderr, + L"WARNING: Request to allocate object of size class %d, which is not implemented", + size_class ); + } + } + } // TODO: else throw exception + + return result; } -void push_freelist( struct pso_pointer p) { - struct pso2 *obj = pointer_to_object( p ); - uint8_t size_class = ( obj->header.tag.bytes.size_class ); +void push_freelist( struct pso_pointer p ) { + struct pso2 *obj = pointer_to_object( p ); + uint8_t size_class = ( obj->header.tag.bytes.size_class ); - strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, - TAGLENGTH ); - - pthread_mutex_lock( &freelists_mutices[size_class]); + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); - if ( size_class <= MAX_SIZE_CLASS ) { - obj->payload.free.next = freelists[size_class]; - freelists[size_class] = p; - } - - pthread_mutex_unlock(&freelists_mutices[size_class]); + pthread_mutex_lock( &freelists_mutices[size_class] ); + + if ( size_class <= MAX_SIZE_CLASS ) { + obj->payload.free.next = freelists[size_class]; + freelists[size_class] = p; + } + + pthread_mutex_unlock( &freelists_mutices[size_class] ); } diff --git a/src/c/memory/memory.h b/src/c/memory/memory.h index 720bf1d..776e140 100644 --- a/src/c/memory/memory.h +++ b/src/c/memory/memory.h @@ -10,6 +10,7 @@ #ifndef __psse_memory_memory_h #define __psse_memory_memory_h #include +#include #include "memory/pointer.h" @@ -26,10 +27,11 @@ struct pso_pointer initialise_memory( ); -struct pso_pointer pop_freelist( uint8_t size_class); -void push_freelist( struct pso_pointer p); +struct pso_pointer pop_freelist( uint8_t size_class ); +void push_freelist( struct pso_pointer p ); extern struct pso_pointer out_of_memory_exception; extern struct pso_pointer freelists[]; extern pthread_mutex_t freelists_mutices[]; +extern bool memory_initialised; #endif diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 2cc12c7..9857a1d 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -319,11 +319,11 @@ struct pso_pointer allocate_page( uint8_t size_class ) { L"\nAllocated page %d for objects of size class %x.\n", npages_allocated, size_class ); - pthread_mutex_lock( &freelists_mutices[size_class]); + pthread_mutex_lock( &freelists_mutices[size_class] ); freelists[size_class] = initialise_page( ( union page * ) pg, npages_allocated, size_class, freelists[size_class] ); - pthread_mutex_unlock( &freelists_mutices[size_class]); + pthread_mutex_unlock( &freelists_mutices[size_class] ); debug_printf( DEBUG_ALLOC, 0, L"Initialised page %d; freelist for size class %x updated with head at page %d, offset %d.\n", diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 1a25c26..f6a241c 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -35,16 +35,20 @@ #include "ops/truth.h" /** - * @brief Allocate an object of this size_class with this tag. + * @brief Allocate an object of this `size_class` with this `tag`. * * All objects that are allocated (after completion of init)) should be linked - * onto the `locals` slot on a stack frame. This guarantees - * 1. that they get `inc_ref`ed; and that, + * onto the `locals` slot of a stack frame. This guarantees + * 1. that they do get `inc_ref`ed; and that, * 2. if nothing else hangs onto them they will be reclaimed when that stack * frame is reclaimed. * for some objects (e.g. those cons cells on the locals list) this isn't * possible due to infinite recursion, but those special cases need to be - * audited carefully + * audited carefully. + * + * The stack frame pointer is DELIBERATELY a C pointer, not a Lisp pointer, + * because you are definitely not supposed to be calling this function from + * Lisp. Please do not! * * @param stack_pointer C (NOT Lisp!) pointer to an active stack frame (or * NULL, but only during initialisation). @@ -52,8 +56,9 @@ * @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( /* struct pso4 * stack_pointer,*/ char *tag, uint8_t size_class ) { - // todo: issue #21: must have stack frame passed in. +struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag, + uint8_t size_class ) { + // todo: issue #21: must have stack frame passed in. #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -61,26 +66,29 @@ struct pso_pointer allocate( /* struct pso4 * stack_pointer,*/ char *tag, uint8_ size_class, tag ); #endif - struct pso_pointer result = pop_freelist(size_class); + struct pso_pointer result = pop_freelist( size_class ); - if (!nilp( result)) { - strncpy( ( char * ) ( pointer_to_object(result)->header.tag.bytes.mnemonic ), tag, - TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", - result.page, result.offset ); -// if ( stack_pointer != NULL && -// (stack_pointer->header.tag.value & 0xffffff) == STACKTV) { -// struct pso_pointer locals = make_cons(result, -// stack_pointer->payload.stack_frame.locals); -// stack_pointer->payload.stack_frame.locals = locals; -// -// } else { -// fputws( L"WARNING: No stack frame passed to `allocate`.\n", stderr); -// } - } else { - // TODO: throw exception - } + if ( !nilp( result ) ) { + strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes. + mnemonic ), tag, TAGLENGTH ); + + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", + result.page, result.offset ); + if ( stack_pointer != NULL && + ( stack_pointer->header.tag.value & 0xffffff ) == STACKTV ) { + struct pso_pointer locals = make_cons( result, + stack_pointer-> + payload.stack_frame. + locals ); + stack_pointer->payload.stack_frame.locals = locals; + + } else if ( memory_initialised ) { + fputws( L"WARNING: No stack frame passed to `allocate`.\n", + stderr ); + } + } else { + // TODO: throw exception + } #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, @@ -203,7 +211,7 @@ struct pso_pointer free_object( struct pso_pointer p ) { obj->payload.words[i] = 0; } - push_freelist(p); + push_freelist( p ); return result; } diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index c9894cf..38a18f6 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -14,9 +14,10 @@ #include "memory/header.h" #include "memory/pointer.h" +#include "memory/pso4.h" -// todo: issue #21: must have stack frame passed in. -struct pso_pointer allocate( char *tag, uint8_t size_class ); +struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag, + uint8_t size_class ); struct pso_pointer dec_ref( struct pso_pointer pointer ); diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index e34122c..32e1f4e 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -41,6 +41,6 @@ struct pso_pointer lisp_bind( struct pso_pointer c_bind( struct pso_pointer key, struct pso_pointer value, struct pso_pointer store ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. return make_cons( make_cons( key, value ), store ); } diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 819a2eb..7d39ca2 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -85,12 +85,18 @@ struct pso_pointer eval( default: result = make_exception( make_cons - ( c_string_to_lisp_string - ( L"Can't yet evaluate things of this type: " ), - result ), frame_pointer, - make_cons( make_cons - ( c_string_to_lisp_keyword( L"tag" ), - get_tag_string( result ) ), nil ), + ( frame, c_string_to_lisp_string + ( frame, + L"Can't yet evaluate things of this type: " ), + result ), frame_pointer, make_cons( frame, + make_cons + ( frame, + c_string_to_lisp_keyword + ( frame, + L"tag" ), + get_tag_string + ( result ) ), + nil ), nil ); } diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 4e58600..8036c47 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -44,7 +44,7 @@ struct pso_pointer cdr( #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif - return c_cdr( fetch_arg( frame, 0 ) ); + return c_cdr( frame, fetch_arg( frame, 0 ) ); } /** @@ -66,7 +66,7 @@ struct pso_pointer cons( struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif - return make_cons( fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); + return make_cons( frame, fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); } #endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index c3fa5a1..f470477 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -48,11 +48,13 @@ void int_handler( int dummy ) { * Very simple read/eval/print loop for bootstrapping. */ void c_repl( bool show_prompt ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); - struct pso_pointer env = consp( oblist ) ? oblist : make_cons( oblist, nil ); + // TODO: NULL is not OK here, but will do until we have a REPL in Lisp. + struct pso_pointer env = + consp( oblist ) ? oblist : make_cons( NULL, oblist, nil ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index aa8c416..0dc862f 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -13,7 +13,7 @@ #define SRC_C_OPS_REPL_H_ - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. void c_repl( ); diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 4e2704b..7bf3bc2 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -36,7 +36,7 @@ * the argument was not a sequence. */ struct pso_pointer c_reverse( struct pso_pointer sequence ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; for ( struct pso_pointer cursor = sequence; !nilp( sequence ); @@ -66,8 +66,8 @@ struct pso_pointer c_reverse( struct pso_pointer sequence ) { default: result = make_exception( make_cons( c_string_to_lisp_string - ( L"Invalid object in sequence" ), - cursor ), nil, nil, nil ); + ( L"Invalid object in sequence" ), + cursor ), nil, nil, nil ); goto exit; break; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index f84d327..bc199d1 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -69,12 +69,13 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * char32_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, +struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer, + wint_t c, struct pso_pointer tail, char *tag ) { struct pso_pointer pointer = tail; if ( check_type( tail, tag ) || nilp( tail ) ) { - pointer = allocate( tag, CONS_SIZE_CLASS ); + pointer = allocate( frame_pointer, tag, CONS_SIZE_CLASS ); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.string.character = c; @@ -106,8 +107,9 @@ struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, * @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 ); +struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, STRINGTAG ); } /** @@ -118,8 +120,9 @@ struct pso_pointer make_string( wint_t c, struct pso_pointer tail ) { * @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 ); +struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); } /** @@ -130,22 +133,26 @@ struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ) { * @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, SYMBOLTAG ); +struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); } /** * Return a lisp string representation of this wide character string. */ -struct pso_pointer c_string_to_lisp_string( char32_t *string ) { +struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer, + char32_t *string ) { struct pso_pointer result = nil; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { if ( string[i] != '"' ) { - result = make_string( string[i], result ); + result = make_string( frame_pointer, string[i], result ); } else { - result = make_string( L'\\', make_string( string[i], result ) ); + result = make_string( frame_pointer, L'\\', + make_string( frame_pointer, string[i], + result ) ); } } @@ -157,14 +164,15 @@ struct pso_pointer c_string_to_lisp_string( char32_t *string ) { * Return a lisp symbol representation of this wide character string. In * symbols, I am accepting only lower case characters. */ -struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ) { +struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer, + char32_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { char32_t c = towlower( symbol[i] ); if ( iswalpha( c ) || c == L'-' || c == L'*' ) { - result = make_symbol( c, result ); + result = make_symbol( frame_pointer, c, result ); } } @@ -175,14 +183,15 @@ struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ) { * 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( char32_t *symbol ) { +struct pso_pointer c_string_to_lisp_keyword( struct pso4 *frame_pointer, + char32_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { char32_t c = towlower( symbol[i] ); if ( iswalnum( c ) || c == L'-' ) { - result = make_keyword( c, result ); + result = make_keyword( frame_pointer, c, result ); } } diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index d17d9fc..aeaf243 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -17,19 +17,26 @@ #include #include -struct pso_pointer make_string_like_thing( wint_t c, struct pso_pointer tail, +struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer, + 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_string( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ); -struct pso_pointer make_keyword( wint_t c, struct pso_pointer tail ); +struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ); -struct pso_pointer make_symbol( wint_t c, struct pso_pointer tail ); +struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c, + struct pso_pointer tail ); -struct pso_pointer c_string_to_lisp_string( char32_t *string ); +struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer, + char32_t * string ); -struct pso_pointer c_string_to_lisp_keyword( char32_t *symbol ); +struct pso_pointer c_string_to_lisp_keyword( struct pso4 *frame_pointer, + char32_t * symbol ); -struct pso_pointer c_string_to_lisp_symbol( char32_t *symbol ); +struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer, + char32_t * symbol ); #endif diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c index cb807c1..962724c 100644 --- a/src/c/payloads/character.c +++ b/src/c/payloads/character.c @@ -24,8 +24,8 @@ #include "payloads/character.h" -struct pso_pointer make_character( wint_t c ) { - struct pso_pointer result = allocate( CHARACTERTAG, 2 ); +struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c ) { + struct pso_pointer result = allocate( frame_pointer, CHARACTERTAG, 2 ); if ( !nilp( result ) ) { pointer_to_object( result )->payload.character.character = diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 1f5e099..a901642 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -26,6 +26,7 @@ #include #include +#include "memory/pso4.h" #define CHARTAG "CHR" #define CHARTV 5392451 @@ -37,5 +38,5 @@ struct character_payload { char32_t character; }; -struct pso_pointer make_character( wint_t c ); +struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c ); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 8a05088..9af48b7 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -30,9 +30,11 @@ * @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 make_cons(struct pso_pointer car, struct pso_pointer cdr) { - // todo: issue #21: must have stack frame passed in. - struct pso_pointer result = allocate( CONSTAG, 2 ); +struct pso_pointer make_cons( struct pso4 *frame_pointer, + struct pso_pointer car, + struct pso_pointer cdr ) { + // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 ); struct pso2 *object = pointer_to_object( result ); object->payload.cons.car = inc_ref( car ); @@ -68,8 +70,8 @@ struct pso_pointer c_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 c_cdr(struct pso_pointer p) { - // todo: issue #21: must have stack frame passed in. +struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) { + // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( p ); @@ -85,8 +87,8 @@ struct pso_pointer c_cdr(struct pso_pointer p) { default: result = make_exception( make_cons - ( c_string_to_lisp_string - ( L"Invalid type for cdr" ), + ( stack_pointer, c_string_to_lisp_string + ( stack_pointer, L"Invalid type for cdr" ), get_tag_string( p ) ), nil, nil, nil ); break; } @@ -109,6 +111,6 @@ struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; dec_ref( c_car( p ) ); - dec_ref( c_cdr( p ) ); + dec_ref( c_cdr( frame, p ) ); } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 0192f4e..21b2334 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -12,6 +12,7 @@ #include #include "memory/pointer.h" +#include "memory/pso4.h" #define CONS_SIZE_CLASS 2 @@ -28,10 +29,12 @@ struct cons_payload { struct pso_pointer c_car( struct pso_pointer cons ); -struct pso_pointer c_cdr( struct pso_pointer cons ); +struct pso_pointer c_cdr( struct pso4 *stack_pointer, + struct pso_pointer cons ); // todo: issue #21: must have stack frame passed in. -struct pso_pointer make_cons( struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer make_cons( struct pso4 *stack_pointer, + struct pso_pointer car, struct pso_pointer cdr ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 8817894..28da143 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -38,7 +38,8 @@ struct pso_pointer make_exception( struct pso_pointer message, struct pso_pointer frame, struct pso_pointer meta, struct pso_pointer cause ) { - struct pso_pointer result = allocate( EXCEPTIONTAG, 3 ); + struct pso_pointer result = + allocate( pointer_to_pso4( frame ), EXCEPTIONTAG, 3 ); if ( !nilp( result ) && !exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 8437a8b..0c0e861 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -14,6 +14,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "debug.h" @@ -24,11 +25,11 @@ * @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 make_integer( struct pso4 *frame_pointer, int64_t value ) { struct pso_pointer result = nil; debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 ); - result = allocate( INTEGERTAG, 2 ); + result = allocate( frame_pointer, INTEGERTAG, 2 ); struct pso2 *cell = pointer_to_object( result ); cell->payload.integer.value = value; diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index 0a391aa..9205ebc 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -12,6 +12,8 @@ #include +#include "memory/pso4.h" + /** * @brief An integer . * @@ -23,6 +25,6 @@ struct integer_payload { __int128_t value; }; -struct pso_pointer make_integer( int64_t value ); +struct pso_pointer make_integer( struct pso4 *frame_pointer, int64_t value ); #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index 8a4bdbe..ad23d19 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -8,23 +8,19 @@ */ -#include /* * wide characters */ -#include -#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" -#include "ops/string_ops.h" -#include "ops/truth.h" +#include "payloads/cons.h" + /** * @brief When an string is freed, its cdr pointer must be decremented. @@ -38,7 +34,7 @@ struct pso_pointer destroy_string( struct pso_pointer fp, struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( c_cdr( p ) ); + dec_ref( c_cdr( frame, p ) ); } return nil; diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index a0b0876..1286335 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -15,6 +15,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" @@ -24,9 +25,10 @@ * @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 make_read_stream( struct pso4 *frame_pointer, + URL_FILE *input, struct pso_pointer metadata ) { - struct pso_pointer pointer = allocate( READTAG, 2 ); + struct pso_pointer pointer = allocate( frame_pointer, 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 1ea0adb..23a04a7 100644 --- a/src/c/payloads/read_stream.h +++ b/src/c/payloads/read_stream.h @@ -29,7 +29,8 @@ struct stream_payload { struct pso_pointer meta; }; -struct pso_pointer make_read_stream( URL_FILE * input, +struct pso_pointer make_read_stream( struct pso4 *frame_pointer, + URL_FILE * input, struct pso_pointer metadata ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 89fb617..0b025ca 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -33,12 +33,13 @@ */ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ) { - // todo: issue #21: must have stack frame passed in. + // todo: issue #21: must have stack frame passed in. va_list args; va_start( args, previous ); - struct pso_pointer frame_pointer = allocate( STACKTAG, 4 ); - struct pso4 *frame = ( struct pso4 * ) pointer_to_object( frame_pointer ); + struct pso4 *frame = pointer_to_pso4( previous ); + struct pso_pointer frame_pointer = + allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -72,7 +73,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( va_arg( args, struct pso_pointer ), more_args ); + make_cons( frame, va_arg( args, struct pso_pointer ), + more_args ); } frame->payload.stack_frame.more = c_reverse( more_args ); @@ -103,6 +105,8 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( frame->payload.stack_frame.previous ); dec_ref( frame->payload.stack_frame.function ); dec_ref( frame->payload.stack_frame.more ); + dec_ref( frame->payload.stack_frame.locals ); + dec_ref( frame->payload.stack_frame.env ); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->payload.stack_frame.arg[i] ); diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index ed02588..e9ab776 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -31,10 +31,10 @@ struct stack_frame_payload { struct pso_pointer more; /** the function to be called. */ struct pso_pointer function; - /** the execute-time environment */ - struct pso_pointer env; - /** a list of objects created in the context of this frame */ - struct pso_pointer locals; + /** the execute-time environment */ + struct pso_pointer env; + /** a list of objects created in the context of this frame */ + struct pso_pointer locals; /** the number of arguments provided. */ uint32_t args; /** the depth of the stack below this frame */ diff --git a/src/c/payloads/write_stream.c b/src/c/payloads/write_stream.c index 371f32c..1397e7a 100644 --- a/src/c/payloads/write_stream.c +++ b/src/c/payloads/write_stream.c @@ -15,6 +15,7 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" @@ -24,9 +25,10 @@ * @param metadata a pointer to an associaton containing metadata on the stream. * @return a pointer to the new read stream. */ -struct pso_pointer make_write_stream( URL_FILE *output, +struct pso_pointer make_write_stream( struct pso4 *frame_pointer, + URL_FILE *output, struct pso_pointer metadata ) { - struct pso_pointer pointer = allocate( WRITETAG, 2 ); + struct pso_pointer pointer = allocate( frame_pointer, WRITETAG, 2 ); struct pso2 *cell = pointer_to_object( pointer ); cell->payload.stream.stream = output; diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index 69de8a4..07e3b14 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -13,6 +13,7 @@ /* write stream shares a payload with /see read_streem.h */ #include "io/fopen.h" -struct pso_pointer make_write_stream( URL_FILE * output, +struct pso_pointer make_write_stream( struct pso4 *frame_pointer, + URL_FILE * output, struct pso_pointer metadata ); #endif From aa5b34368e9212845ebe518837d48f669e4eba09 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 20 Apr 2026 23:21:30 +0100 Subject: [PATCH 46/77] Modified `make_cons` and `make_frame` to illustrate the pattern I want to apply generally. This does not compile! --- docs/State-of-play.md | 41 +++++++++++++++++++ src/c/io/io.c | 4 +- src/c/memory/pso.c | 9 ++--- src/c/payloads/cons.c | 18 +++++---- src/c/payloads/stack.c | 90 +++++++++++++++++++++++++++++++++++++++--- src/c/payloads/stack.h | 4 +- 6 files changed, 145 insertions(+), 21 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 2faad50..c79bf17 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -21,6 +21,47 @@ I'm not ignoring the fact that a lot of stuff in `0.1.0` is still fundamentally I think this week is going to be mostly a thinking week — partly because the weather forecast is unusually benign, and it would be sensible get some outdoor work done. +### 21:30 + +Right, I have spent a lot of time hauling timber out of the wood today, but I've also done a substantial amount of coding, doing a sort of hybrid not-quite-standard-lisp calling convention; and I'm now convinced all this work is wrong and needs to be backed out, and I need to go for full on Lisp calling convention. + +So where I'm now calling `make_cons` as in this sample: + +```c +struct pso_pointer c_reverse( struct pso4* frame, struct pso_pointer sequence ) { + struct pso_pointer result = nil; + + for ( struct pso_pointer cursor = sequence; !nilp( sequence ); + cursor = c_cdr( cursor ) ) { + result = make_cons( frame, c_car( cursor ), result ); + } + + return result; +} +``` + +we would instead be doing this: + +```c +struct pso_pointer reverse( struct pso_pointer frame) { + struct pso_pointer sequence = fetch_arg( frame, 0); + struct pso_pointer result = nil; + + for ( struct pso_pointer cursor = sequence; !nilp( sequence ); + cursor = cdr( make_frame( 1, frame, cursor ) ) { + result = cons( make_frame( 2, frame, + car( make_frame( 1, frame, cursor )), + result); + } + + return result; +} +``` + +Note that instead of `c_reverse`, `c_cdr`, `c_car` this is using `reverse`, `cdr`, `car`. That's because these are actual Lisp functions, callable from Lisp, which don't have to be duplicated or wrapped in Lisp-compatible wrappers. + +This *has* to be the right way to go. + ## 20260415 OK, I have been diverted down a side-project on a side-project. I decided diff --git a/src/c/io/io.c b/src/c/io/io.c index db69b73..1b8be37 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -381,8 +381,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) - ( pointer_to_object( c )->payload. - character.character ), + ( pointer_to_object( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index f6a241c..e856023 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -69,17 +69,16 @@ struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag, struct pso_pointer result = pop_freelist( size_class ); if ( !nilp( result ) ) { - strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes. - mnemonic ), tag, TAGLENGTH ); + strncpy( ( char * ) ( pointer_to_object( result )->header.tag. + bytes.mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); if ( stack_pointer != NULL && ( stack_pointer->header.tag.value & 0xffffff ) == STACKTV ) { struct pso_pointer locals = make_cons( result, - stack_pointer-> - payload.stack_frame. - locals ); + stack_pointer->payload. + stack_frame.locals ); stack_pointer->payload.stack_frame.locals = locals; } else if ( memory_initialised ) { diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 9af48b7..730c14b 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -30,15 +30,17 @@ * @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 make_cons( struct pso4 *frame_pointer, - struct pso_pointer car, - struct pso_pointer cdr ) { - // todo: issue #21: must have stack frame passed in. - struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 ); +struct pso_pointer make_cons( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = allocate( frame, CONSTAG, 2 ); - struct pso2 *object = pointer_to_object( result ); - object->payload.cons.car = inc_ref( car ); - object->payload.cons.cdr = inc_ref( cdr ); + if ( stackp( frame ) ) { + struct pso2 *object = pointer_to_object( result ); + object->payload.cons.car = + inc_ref( frame->payload.stack_frame.args[0] ); + object->payload.cons.cdr = + inc_ref( frame->payload.stack_frame.args[0] ); + } return result; } diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 0b025ca..c2acfb2 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -28,14 +28,18 @@ * @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. + * + * @param arg_count the count of arguments to the Lisp function. + * @param previous the parent stack frame. + * @param ... the arguments to the Lisp function, all of which must be of type + * `struct pso_pointer`. + * @return struct pso_pointer a pointer to a populated stack frame which may be + * passed to the Lisp function. */ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, - ... ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer env, ... ) { va_list args; - va_start( args, previous ); + va_start( args, env ); struct pso4 *frame = pointer_to_pso4( previous ); struct pso_pointer frame_pointer = @@ -53,6 +57,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, if ( stackp( previous ) ) { struct pso4 *op = pointer_to_pso4( previous ); frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; + frame->payload.stack_frame.env = op->payload.stack_frame.env; } else { frame->payload.stack_frame.depth = 0; } @@ -91,6 +96,81 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, return frame_pointer; } +/** + * @brief variant of make_frame with an explicit replacement environment, to + * be called by functions like `binding` which add bindings to their upstack + * environment. + * + * @param arg_count the count of arguments to the Lisp function. + * @param previous the parent stack frame. + * @param env the modified environment + * @param ... the arguments to the Lisp function, all of which must be of type + * `struct pso_pointer`. + * @return struct pso_pointer a pointer to a populated stack frame which may be + * passed to the Lisp function. + */ +struct pso_pointer make_frame_with_env( int arg_count, + struct pso_pointer previous, + struct pso_pointer env, ... ) { + va_list args; + va_start( args, env ); + + struct pso4 *frame = pointer_to_pso4( previous ); + struct pso_pointer frame_pointer = + allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"\nAllocating stack frame with %d arguments at page %d, " + L"offset %d...\n", + arg_count, frame_pointer.page, frame_pointer.offset ); +#endif + + frame->payload.stack_frame.previous = previous; + + if ( stackp( previous ) ) { + struct pso4 *op = pointer_to_pso4( previous ); + frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; + frame->payload.stack_frame.env = env; + } else { + frame->payload.stack_frame.depth = 0; + } + + debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", + frame->payload.stack_frame.depth ); + + int cursor = 0; + frame->payload.stack_frame.args = arg_count; + + for ( ; cursor < arg_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 < arg_count ) { + struct pso_pointer more_args = nil; + + for ( ; cursor < arg_count; cursor++ ) { + more_args = + make_cons( frame, va_arg( args, struct pso_pointer ), + more_args ); + } + + frame->payload.stack_frame.more = c_reverse( more_args ); + } else { + for ( ; cursor < args_in_frame; cursor++ ) { + frame->payload.stack_frame.arg[cursor] = nil; + } + } + + debug_printf( DEBUG_ALLOC, 1, + L"Allocation of frame at page %d, offset %d completed.\n", + frame_pointer.page, frame_pointer.offset ); + + return frame_pointer; +} + + /** * @brief When a stack frame is freed, all its pointers must be decremented. * diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index e9ab776..dd2e8ae 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -43,7 +43,9 @@ struct stack_frame_payload { struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ); - +struct pso_pointer make_frame_with_env( int arg_count, + struct pso_pointer previous, + struct pso_pointer env, ... ) struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); From ef59563e258d4a00e4fc80b23e18cf21e30b432c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 21 Apr 2026 14:43:09 +0100 Subject: [PATCH 47/77] Still in progress. Nothing workds. --- src/c/ops/assoc.c | 21 +++--- src/c/ops/bind.c | 14 ++-- src/c/ops/eq.c | 6 +- src/c/ops/eq.h | 9 +-- src/c/ops/eval_apply.c | 8 +-- src/c/ops/list_ops.c | 69 ++++-------------- src/c/ops/list_ops.h | 22 +----- src/c/ops/stack_ops.c | 15 ++++ src/c/ops/stack_ops.h | 2 + src/c/payloads/cons.c | 48 ++++++++----- src/c/payloads/cons.h | 9 +-- src/c/payloads/exception.c | 13 ++-- src/c/payloads/function.h | 6 +- src/c/payloads/stack.c | 144 +++++++++++++++++++++++++++---------- 14 files changed, 206 insertions(+), 180 deletions(-) diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 100806d..625912b 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -17,6 +17,7 @@ #include "memory/tags.h" #include "payloads/cons.h" +#include "payloads/stack.h" #include "ops/eq.h" #include "ops/stack_ops.h" @@ -100,13 +101,13 @@ struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); - struct pso_pointer store = fetch_arg( frame, 1 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); return c_assoc( key, store ); } @@ -120,13 +121,13 @@ struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); - struct pso_pointer store = fetch_arg( frame, 1 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); return c_interned( key, store ); } @@ -140,13 +141,13 @@ struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); - struct pso_pointer store = fetch_arg( frame, 1 ); + struct pso_pointer store = or( make_frame( 2, frame_pointer, + fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); - return c_interned( key, store ); + return c_internedp( key, store ); } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 32e1f4e..4c552ed 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -22,25 +22,19 @@ #include "payloads/function.h" #include "payloads/stack.h" -struct pso_pointer lisp_bind( +struct pso_pointer bind( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif 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 binding = cons( make_frame( 2, frame_pointer, key, value)); - return make_cons( make_cons( key, value ), store ); + return cons( make_frame( 2, frame_pointer, binding, store)); } -struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store ) { - // todo: issue #21: must have stack frame passed in. - return make_cons( make_cons( key, value ), store ); -} diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 101ea51..5725ce4 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -99,8 +99,7 @@ struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); @@ -139,8 +138,7 @@ struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index a669a10..98e8ddc 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -20,24 +20,19 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ); -struct pso_pointer eq( struct pso_pointer frame_pointer, - struct pso_pointer env ); - bool c_equal( struct pso_pointer a, struct pso_pointer b ); struct pso_pointer eq( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer ); struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer); #endif diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 7d39ca2..3ff6ce8 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -35,8 +35,7 @@ struct pso_pointer apply( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -54,8 +53,7 @@ struct pso_pointer eval( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { + struct pso_pointer frame_pointer) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif @@ -71,7 +69,7 @@ struct pso_pointer eval( // self evaluating break; case SYMBOLTV: - result = c_assoc( result, env ); + result = c_assoc( result, fetch_env(frame_pointer) ); break; // case LAMBDATV: // result = eval_lambda( frame, frame_pointer, env); diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 8036c47..a4dc20a 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -1,5 +1,5 @@ /** - * ops/list_ops.h + * ops/list_ops.c * * Post Scarcity Software Environment: list_ops. * @@ -8,65 +8,22 @@ * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ - -#ifndef __psse_ops_list_ops_h -#define __psse_ops_list_ops_h - #include "memory/pointer.h" -#include "memory/pso.h" +#include "memory/pso2.h" #include "memory/pso4.h" -#include "memory/tags.h" -#include "ops/stack_ops.h" - -#include "payloads/cons.h" #include "payloads/stack.h" +#include "ops/truth.h" -struct pso_pointer car( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { -#ifdef MANAGED_POINTER_ONLY - struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif - return c_car( fetch_arg( frame, 0 ) ); +struct pso_pointer length( struct pso_pointer frame_pointer) { + struct pso_pointer list = fetch_arg( frame_pointer, 0); + int count = 0; + + for ( struct pso_pointer cursor = list; !nilp( cursor); + cursor = cdr( make_frame( 1, frame_pointer, list))) { + count++; + } + + return make_integer( pointer_to_pso4(frame_pointer), count); } - -struct pso_pointer cdr( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { -#ifdef MANAGED_POINTER_ONLY - struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif - return c_cdr( frame, fetch_arg( frame, 0 ) ); -} - -/** - * @brief allocate a cons cell from the first two args in this frame, and - * return a pointer to it. - * - * Lisp calling conventions. - * - * @return struct pso_pointer a pointer to the newly allocated cons cell. - */ - -struct pso_pointer cons( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { -#ifdef MANAGED_POINTER_ONLY - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - -#endif - return make_cons( frame, fetch_arg( frame, 0 ), fetch_arg( frame, 1 ) ); -} - -#endif diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index 0121b57..502577f 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -17,25 +17,5 @@ #include "payloads/function.h" -struct pso_pointer car( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); - -struct pso_pointer cdr( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); - -struct pso_pointer cons( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); - +struct pso_pointer length( struct pso_pointer frame_pointer); #endif diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index 0fd28c5..ccadf42 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -10,6 +10,7 @@ #include "memory/node.h" #include "memory/pso2.h" #include "memory/pso4.h" +#include "memory/tags.h" #include "payloads/stack.h" /** @@ -21,6 +22,8 @@ uint32_t stack_limit = 0; /** * Fetch a pointer to the value of the local variable at this index. + * + * TODO: I think the first argument would be better as a pso_pointer. */ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { struct pso_pointer result = nil; @@ -40,3 +43,15 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { return result; } + +/** + * @brief Return the environment from the stack frame identified by this + * `frame_pointer` + * + * @param frame_pointer a pointer to a stack frame. + */ +struct pso_pointer fetch_env( struct pso_pointer frame_pointer) { + return stackp(frame_pointer) ? + pointer_to_pso4(frame_pointer)->payload.stack_frame.env : + nil; +} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index 837d49a..3601724 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -27,4 +27,6 @@ extern uint32_t stack_limit; struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); +struct pso_pointer fetch_env( struct pso_pointer frame_pointer); + #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 730c14b..6963fbb 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -26,11 +26,12 @@ * @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. + * (cons object object) + * + * @param frame_pointer a pointer to a stack frame. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer make_cons( struct pso_pointer frame_pointer ) { +struct pso_pointer cons( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = allocate( frame, CONSTAG, 2 ); @@ -49,18 +50,28 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer ) { /** * @brief return the car of this cons cell. * - * @param cons a pointer to the cell. + * (car cell) + * + * @param frame_pointer a pointer to a stack frame. * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer c_car( struct pso_pointer cons ) { +struct pso_pointer car( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; + struct pso_pointer cons = fetch_arg( pointer_to_pso4( frame_pointer), 0); struct pso2 *object = pointer_to_object( cons ); if ( consp( cons ) ) { result = object->payload.cons.car; - } - // TODO: else throw an exception + } else { + result = + make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string( frame_pointer, L"Invalid type for car" ), + make_cons( + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, L"type" ), + get_tag_string( cons )), nil))); + } return result; } @@ -68,14 +79,17 @@ struct pso_pointer c_car( struct pso_pointer cons ) { /** * @brief return the cdr of this cons (or other sequence) cell. * - * @param cons a pointer to the cell. + * (cdr cell) + * + * @param frame_pointer a pointer to a stack frame. * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) { - // todo: issue #21: must have stack frame passed in. +struct pso_pointer cdr( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; - struct pso2 *object = pointer_to_object( p ); + struct pso4 *sp = pointer_to_pso4(frame_pointer); + struct pso_pointer cons = fetch_arg(sp, 0); + struct pso2 *object = pointer_to_object( cons ); switch ( get_tag_value( p ) ) { case CONSTV: @@ -88,15 +102,15 @@ struct pso_pointer c_cdr( struct pso4 *stack_pointer, struct pso_pointer p ) { break; default: result = - make_exception( make_cons - ( stack_pointer, c_string_to_lisp_string - ( stack_pointer, L"Invalid type for cdr" ), - get_tag_string( p ) ), nil, nil, nil ); + make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string( frame_pointer, L"Invalid type for cdr" ), + make_cons( + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, L"type" ), + get_tag_string( cons )), nil))); break; } - // TODO: else throw an exception - return result; } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 21b2334..62fd5ff 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -27,14 +27,11 @@ struct cons_payload { struct pso_pointer cdr; }; -struct pso_pointer c_car( struct pso_pointer cons ); +struct pso_pointer car( struct pso_pointer frame_pointer ); -struct pso_pointer c_cdr( struct pso4 *stack_pointer, - struct pso_pointer cons ); +struct pso_pointer cdr( struct pso_pointer frame_pointer ); -// todo: issue #21: must have stack frame passed in. -struct pso_pointer make_cons( struct pso4 *stack_pointer, - struct pso_pointer car, struct pso_pointer cdr ); +struct pso_pointer cons( struct pso_pointer frame_pointer ); struct pso_pointer destroy_cons( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 28da143..bf7a225 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -23,6 +23,8 @@ * @brief allocate an exception object, and, if successful, return a pointer * to it. * + * (exception message meta cause) + * * Throwing an exception while generating an exception is meaningless. If * allocation fails utterly (i.e. out of heap, out of page space) this will * have to return `nil`, which might give rise to hard to trace bugs. But @@ -34,10 +36,13 @@ * or `nil` * @param cause the exception that caused this exception to be `thrown`. */ -struct pso_pointer make_exception( struct pso_pointer message, - struct pso_pointer frame, - struct pso_pointer meta, - struct pso_pointer cause ) { +struct pso_pointer make_exception( struct pso_pointer frame_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer message = fetch_arg(frame, 0); + struct pso_pointer previous = frame->payload.stack_frame.previous; + struct pso_pointer meta = fetch_arg( frame, 1); + struct pso_pointer cause = fetch_arg( frame, 2); + struct pso_pointer result = allocate( pointer_to_pso4( frame ), EXCEPTIONTAG, 3 ); diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 94bbb61..2ab1a54 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -37,8 +37,7 @@ struct function_payload { * to the Lisp function are assumed to be loaded into the frame before * invocation. */ - struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); #else /** * pointer to a C function which takes an unmanaged pointer to a stack frame, @@ -47,8 +46,7 @@ struct function_payload { * loaded into the frame before invocation. */ struct pso_pointer ( *executable ) ( struct pso4 * frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ); + struct pso_pointer frame_pointer ); #endif }; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index c2acfb2..916c5c6 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -37,63 +37,63 @@ * passed to the Lisp function. */ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, - struct pso_pointer env, ... ) { + ... ) { va_list args; - va_start( args, env ); + va_start( args, previous ); - struct pso4 *frame = pointer_to_pso4( previous ); - struct pso_pointer frame_pointer = + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " L"offset %d...\n", - arg_count, frame_pointer.page, frame_pointer.offset ); + arg_count, new_pointer.page, new_pointer.offset ); #endif - frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - struct pso4 *op = pointer_to_pso4( previous ); - frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; - frame->payload.stack_frame.env = op->payload.stack_frame.env; + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = prev_frame->payload.stack_frame.env; } else { - frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; - frame->payload.stack_frame.args = arg_count; + new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_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 ); + new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); } if ( cursor < arg_count ) { struct pso_pointer more_args = nil; for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( frame, va_arg( args, struct pso_pointer ), + make_cons( prev_frame, va_arg( args, struct pso_pointer ), more_args ); } - frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } debug_printf( DEBUG_ALLOC, 1, - L"Allocation of frame at page %d, offset %d completed.\n", - frame_pointer.page, frame_pointer.offset ); + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); - return frame_pointer; + return new_pointer; } /** @@ -115,59 +115,131 @@ struct pso_pointer make_frame_with_env( int arg_count, va_list args; va_start( args, env ); - struct pso4 *frame = pointer_to_pso4( previous ); - struct pso_pointer frame_pointer = + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " L"offset %d...\n", - arg_count, frame_pointer.page, frame_pointer.offset ); + arg_count, new_pointer.page, new_pointer.offset ); #endif - frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - struct pso4 *op = pointer_to_pso4( previous ); - frame->payload.stack_frame.depth = op->payload.stack_frame.depth + 1; - frame->payload.stack_frame.env = env; + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = env; } else { - frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; - frame->payload.stack_frame.args = arg_count; + new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_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 ); + new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); } if ( cursor < arg_count ) { struct pso_pointer more_args = nil; for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( frame, va_arg( args, struct pso_pointer ), + make_cons( prev_frame, va_arg( args, struct pso_pointer ), more_args ); } - frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } debug_printf( DEBUG_ALLOC, 1, - L"Allocation of frame at page %d, offset %d completed.\n", - frame_pointer.page, frame_pointer.offset ); + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); - return frame_pointer; + return new_pointer; +} + +/** + * @brief variant make_frame where arg values are available as a Lisp list, + * and an explicit (because modified) environment is to be passed.. + * + * @param previous pointer to the previous stack frame. + * @param argvalues values for the arguments to be placed in the frame. + * @param end the environment to be linked in the new frame. + * + * @return pointer to the new frame. + */ +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer argvalues, + struct pso_pointer env) { + struct pso4 *prev_frame = pointer_to_pso4( previous ); + struct pso_pointer new_pointer = + allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + struct pso4* new_frame = pointer_to_pso4(new_pointer); + int arg_count = c_length(argvalues); + +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"\nAllocating stack frame with %d arguments at page %d, " + L"offset %d...\n", + arg_count, new_pointer.page, new_pointer.offset ); +#endif + + prev_frame->payload.stack_frame.previous = previous; + + if ( stackp( previous ) ) { + new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = inc_ref( prev_frame->payload.stack_frame.env); + } else { + new_frame->payload.stack_frame.depth = 0; + } + + debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", + new_frame->payload.stack_frame.depth ); + + int cursor = 0; + new_frame->payload.stack_frame.args = arg_count; + + for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { + + new_frame->payload.stack_frame.arg[cursor] = inc_ref( make_frame( 1, previous, car(argvalues))); + argvalues = cdr( make_frame( 1, previous, argvalues)); + } + if ( cursor < arg_count ) { + new_frame->payload.stack_frame.more = inc_ref( cursor); + } else { + for ( ; cursor < args_in_frame; cursor++ ) { + new_frame->payload.stack_frame.arg[cursor] = nil; + } + } + + debug_printf( DEBUG_ALLOC, 1, + L"Allocation of stack frame at page %d, offset %d completed.\n", + new_pointer.page, new_pointer.offset ); + + return new_pointer; +} + +/** + * @brief variant make_frame where arg values are available as a Lisp list. + * + * @param previous pointer to the previous stack frame. + * @param argvalues values for the arguments to be placed in the frame. + * + * @return pointer to the new frame. + */ +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues) { + return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4(previous)->payload.stack_frame.env); } From eed4711fee3d3ef0a924e1fe537b7cc4e92701d1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 22 Apr 2026 18:16:00 +0100 Subject: [PATCH 48/77] Another inconclusive session: still nothing works, still making progress. --- docs/State-of-play.md | 14 ++++ src/c/environment/environment.c | 23 +++--- src/c/io/io.c | 8 +- src/c/memory/node.c | 22 ++++-- src/c/memory/node.h | 6 +- src/c/memory/pso.c | 23 +++--- src/c/memory/pso.h | 2 +- src/c/memory/pso4.c | 5 +- src/c/memory/tags.h | 2 + src/c/ops/assoc.c | 4 +- src/c/ops/eq.c | 6 +- src/c/ops/eval_apply.c | 40 +++++----- src/c/ops/list_ops.c | 9 ++- src/c/ops/list_ops.h | 1 + src/c/ops/repl.c | 6 +- src/c/ops/reverse.c | 20 ++--- src/c/ops/string_ops.c | 18 ++--- src/c/ops/string_ops.h | 14 ++-- src/c/ops/truth.c | 75 +++++++++++------- src/c/ops/truth.h | 17 ++--- src/c/payloads/character.c | 7 +- src/c/payloads/character.h | 2 +- src/c/payloads/cons.c | 131 +++++++++++++++++--------------- src/c/payloads/cons.h | 21 ++++- src/c/payloads/exception.c | 21 +++-- src/c/payloads/exception.h | 5 +- src/c/payloads/integer.c | 2 +- src/c/payloads/integer.h | 2 +- src/c/payloads/psse_string.c | 5 +- src/c/payloads/read_stream.c | 2 +- src/c/payloads/read_stream.h | 2 +- src/c/payloads/stack.c | 19 ++--- src/c/payloads/stack.h | 11 ++- src/c/payloads/write_stream.c | 2 +- src/c/payloads/write_stream.h | 2 +- 35 files changed, 317 insertions(+), 232 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index c79bf17..6796248 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,19 @@ # State of Play +## 20260421 + +### To have `c_` functions or not to have `c_` functions? + +Up to now I've had a conscious design pattern of having C functions with names beginning with `c_` which were 'the simplest possible way of solving the problem in C', and C functions with names beginning `lisp_` which were (usually) wrappers around those functions designed to be callable from Lisp. The current current refactoring exercise — and the `0.1.0` design doctrine that I should only code in C things which are absolutely necessary to bootstrap the Lisp compiler — is calling into question the need for many of the `c_` functions. After all, the `lisp_` functions are callable from C, it's just a little more prolix. + +However, there is an overhead to calling a `lisp_` function: you have to generate a new stack frame, and there is a overhead, and consequently a time penalty. It may be in the long term it will be worth reviving `c_` functions for performance optimisation; but I think the priority for `0.1.X` is functionality, not performance. + +### Type checking stack frames + +Passing everything around as `pso_pointers` bypasses even C's rather lax type safety. Of course this doesn't matter for code written in Lisp, because it is the compiler's responsibility to mechanically make sure that **only** stack frames are passed into functions as stack frames. But if something else was passed in as a stack frame, the results probable wouldn't be pretty, and at least while I'm mostly running boostrap functions written in C, there is a risk. + +Type checking the stack frame every time a function is entered is an overhead that will grow big quickly. I'm inclined to not do it in production. But I think it's essential to do it during debugging. proposal [here](). + ## 20260420 Still on side projects, but those side-projects are giving me thinking time; diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index f80adc9..f15c382 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -41,10 +41,11 @@ bool environment_initialised = false; struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); + struct pso_pointer frame = make_frame(0, nil); - if ( truep( result ) ) { + if ( c_truep( result ) ) { debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( NILTAG, 2 ); + struct pso_pointer n = allocate( frame, NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { struct pso2 *object = pointer_to_object( n ); @@ -55,16 +56,13 @@ struct pso_pointer initialise_environment( uint32_t node ) { lock_object( nil ); debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { - result = - make_exception( c_string_to_lisp_string - ( L"Unexpected cell while allocating `nil`." ), - nil, nil, n ); + result = nil; debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } - if ( !exceptionp( result ) ) { + if ( !c_nilp( result ) ) { debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( TRUETAG, 2 ); + struct pso_pointer n = allocate( frame, TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words if ( ( n.page == 0 ) && ( n.offset == 4 ) ) { @@ -76,19 +74,16 @@ struct pso_pointer initialise_environment( uint32_t node ) { lock_object( t ); debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { - result = - make_exception( c_string_to_lisp_string - ( L"Unexpected cell while allocating `t`." ), - nil, nil, n ); + result = nil; debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !exceptionp( result ) ) { - result = c_bind( c_string_to_lisp_symbol( L"nil" ), nil, nil ); + result = c_bind( c_string_to_lisp_symbol( frame, L"nil" ), nil, nil ); debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); - result = c_bind( c_string_to_lisp_symbol( L"t" ), t, result ); + result = c_bind( c_string_to_lisp_symbol( frame, L"t" ), t, result ); environment_initialised = true; debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); diff --git a/src/c/io/io.c b/src/c/io/io.c index 1b8be37..f63264d 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -436,7 +436,7 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, return make_cons( make_cons - ( c_string_to_lisp_keyword( key ), + ( c_string_to_lisp_keyword( frame_pointer, key ), c_string_to_lisp_string( buffer ) ), meta ); } @@ -681,7 +681,7 @@ struct pso_pointer lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { result = - make_string( url_fgetwc( stream_get_url_file( stream_pointer ) ), + make_string( frame_pointer, url_fgetwc( stream_get_url_file( stream_pointer ) ), nil ); } @@ -709,7 +709,7 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, if ( readp( fetch_arg( frame, 0 ) ) ) { URL_FILE *stream = stream_get_url_file( fetch_arg( frame, 0 ) ); - struct pso_pointer cursor = make_string( url_fgetwc( stream ), nil ); + struct pso_pointer cursor = make_string( frame_pointer, url_fgetwc( stream ), nil ); result = cursor; for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; @@ -721,7 +721,7 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, debug_println( DEBUG_IO ); struct pso2 *cell = pointer_to_object( cursor ); - cursor = make_string( ( char32_t ) c, nil ); + cursor = make_string( frame_pointer, ( char32_t ) c, nil ); cell->payload.string.cdr = cursor; } } diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 42638a7..083536e 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -38,7 +38,6 @@ bool node_initialised = false; */ uint32_t node_index = 0; - /** * @brief The canonical `nil` pointer * @@ -52,6 +51,16 @@ struct pso_pointer nil = ( struct pso_pointer ) { 0, 0, 0 }; */ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 }; +/** + * @brief whether this node is in debugging mode or not. + */ +struct pso_pointer in_debugging_mode = +#ifdef DEBUG + ( struct pso_pointer ) { 0, 0, 4 }; +#else + ( struct pso_pointer ) { 0, 0, 0 }; +#endif + /** * @brief The root of the data space. */ @@ -62,23 +71,24 @@ struct pso_pointer oblist = ( struct pso_pointer ) { 0, 0, 0 }; * @brief Set up the basic informetion about this node. * * @param index - * @return struct pso_pointer + * @return struct pso_pointer the environment created during initialisation. */ struct pso_pointer initialise_node( uint32_t index ) { node_index = index; struct pso_pointer result = initialise_environment( index ); - if ( !nilp( result ) && !exceptionp( result ) ) { + if ( !c_nilp( result ) && !exceptionp( result ) ) { + node_initialised = true; if ( initialise_io( ) == 0 ) { result = initialise_default_streams( result ); } else { result = - make_exception( c_string_to_lisp_string - ( L"Failed to initialise default streams" ), - nil, nil, nil ); + make_exception( make_frame(1, nil, + c_string_to_lisp_string( nil, L"Failed to initialise default streams" ))); } } return result; } + diff --git a/src/c/memory/node.h b/src/c/memory/node.h index d8559f1..dc8f512 100644 --- a/src/c/memory/node.h +++ b/src/c/memory/node.h @@ -11,6 +11,7 @@ #ifndef __psse_memory_node_h #define __psse_memory_node_h +#include #include /** @@ -19,6 +20,8 @@ */ extern uint32_t node_index; +extern bool node_initialised; + /** * @brief The canonical `nil` pointer * @@ -27,10 +30,11 @@ extern struct pso_pointer nil; /** * @brief the canonical `t` (true) pointer. - * */ extern struct pso_pointer t; +extern struct pso_pointer in_debugging_mode; + extern struct pso_pointer oblist; struct pso_pointer initialise_node( int node_index ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index e856023..e0c4272 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -30,6 +30,7 @@ #include "memory/page.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/truth.h" @@ -45,18 +46,14 @@ * for some objects (e.g. those cons cells on the locals list) this isn't * possible due to infinite recursion, but those special cases need to be * audited carefully. - * - * The stack frame pointer is DELIBERATELY a C pointer, not a Lisp pointer, - * because you are definitely not supposed to be calling this function from - * Lisp. Please do not! * - * @param stack_pointer C (NOT Lisp!) pointer to an active stack frame (or - * NULL, but only during initialisation). + * @param frame_pointer pointer to an active stack frame (or + * nil, but only during initialisation). * @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( struct pso4 *stack_pointer, char *tag, +struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ) { // todo: issue #21: must have stack frame passed in. @@ -67,19 +64,19 @@ struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag, #endif struct pso_pointer result = pop_freelist( size_class ); + struct pso4* frame = pointer_to_pso4(frame_pointer); - if ( !nilp( result ) ) { + if ( !c_nilp( result ) ) { strncpy( ( char * ) ( pointer_to_object( result )->header.tag. bytes.mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); - if ( stack_pointer != NULL && - ( stack_pointer->header.tag.value & 0xffffff ) == STACKTV ) { + if ( stackp(frame_pointer)) { struct pso_pointer locals = make_cons( result, - stack_pointer->payload. + frame->payload. stack_frame.locals ); - stack_pointer->payload.stack_frame.locals = locals; + frame->payload.stack_frame.locals = locals; } else if ( memory_initialised ) { fputws( L"WARNING: No stack frame passed to `allocate`.\n", @@ -151,7 +148,7 @@ 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 ( !nilp( pointer ) && object->header.count > 0 + if ( !c_nilp( pointer ) && object->header.count > 0 && object->header.count != MAXREFERENCE ) { object->header.count--; #ifdef DEBUG diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 38a18f6..efb8075 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -16,7 +16,7 @@ #include "memory/pointer.h" #include "memory/pso4.h" -struct pso_pointer allocate( struct pso4 *stack_pointer, char *tag, +struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ); struct pso_pointer dec_ref( struct pso_pointer pointer ); diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c index cfe6722..d68e1e2 100644 --- a/src/c/memory/pso4.c +++ b/src/c/memory/pso4.c @@ -12,7 +12,4 @@ #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 ); diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 5516de1..afea5f5 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -34,6 +34,7 @@ #define NAMESPACETAG "NSP" #define NILTAG "NIL" #define NLAMBDATAG "NLM" +#define PACKSTRTAG "PST" #define RATIOTAG "RAT" #define READTAG "RED" #define REALTAG "REA" @@ -61,6 +62,7 @@ #define NAMESPACETV 5264206 #define NILTV 4999502 #define NLAMBDATV 5065806 +#define PACKSTRTV 5526352 #define RATIOTV 5521746 #define READTV 4474194 #define REALTV 4277586 diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 625912b..e9bc4cf 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -89,7 +89,7 @@ struct pso_pointer c_interned( struct pso_pointer key, * @return `true` if a pointer the key was found in the store.. */ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { - return !nilp( search( key, store, true ) ); + return !c_nilp( search( key, store, true ) ); } /** @@ -149,5 +149,5 @@ struct pso_pointer internedp( struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); - return c_internedp( key, store ); + return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 5725ce4..60c5316 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -66,7 +66,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { case KEYTV: case STRINGTV: case SYMBOLTV: - while ( result && !nilp( a ) && !nilp( b ) ) { + while ( result && !c_nilp( a ) && !c_nilp( b ) ) { if ( pointer_to_object( a )->payload.string.character == pointer_to_object( b )->payload.string.character ) { a = c_cdr( a ); @@ -75,7 +75,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { result = false; } } - result = result && nilp( a ) && nilp( b ); + result = result && c_nilp( a ) && c_nilp( b ); break; default: result = false; @@ -109,7 +109,7 @@ struct pso_pointer eq( if ( frame->payload.stack_frame.args > 1 ) { for ( int b = 1; - ( truep( result ) ) && ( b < frame->payload.stack_frame.args ); + ( c_truep( result ) ) && ( b < frame->payload.stack_frame.args ); b++ ) { result = c_eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil; diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 3ff6ce8..284a33b 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -57,9 +57,10 @@ struct pso_pointer eval( #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif - struct pso_pointer result = fetch_arg( frame, 0 ); + struct pso_pointer arg = fetch_arg( frame, 0 ); + struct pso_pointer result = nil; - switch ( get_tag_value( result ) ) { + switch ( get_tag_value( arg ) ) { // case CONSTV: // result = eval_cons( frame, frame_pointer, env); // break; @@ -67,9 +68,10 @@ struct pso_pointer eval( case KEYTV: case STRINGTV: // self evaluating + result = nil; break; case SYMBOLTV: - result = c_assoc( result, fetch_env(frame_pointer) ); + arg = c_assoc( arg, fetch_env(frame_pointer) ); break; // case LAMBDATV: // result = eval_lambda( frame, frame_pointer, env); @@ -81,34 +83,34 @@ struct pso_pointer eval( // result = eval_special( frame, frame_pointer, env); // break; default: - result = - make_exception( make_cons - ( frame, c_string_to_lisp_string - ( frame, + arg = + make_exception( + make_frame(1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string( frame_pointer, L"Can't yet evaluate things of this type: " ), - result ), frame_pointer, make_cons( frame, + arg ), + make_cons( frame_pointer, make_cons - ( frame, + ( frame_pointer, c_string_to_lisp_keyword - ( frame, + ( frame_pointer, L"tag" ), get_tag_string - ( result ) ), + ( arg ) ), nil ), - nil ); + nil )); } - if ( exceptionp( result ) ) { + if ( exceptionp( arg ) ) { struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( result, + ( struct pso3 * ) pointer_to_object_with_tag_value( arg, EXCEPTIONTV ); - if ( nilp( x->payload.exception.stack ) ) { - result = - make_exception( x->payload.exception.message, frame_pointer, - nil, result ); + if ( c_nilp( x->payload.exception.stack ) ) { + } } - return result; + return arg; } diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index a4dc20a..e253b44 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -12,18 +12,21 @@ #include "memory/pso2.h" #include "memory/pso4.h" +#include "ops/stack_ops.h" #include "payloads/stack.h" #include "ops/truth.h" struct pso_pointer length( struct pso_pointer frame_pointer) { - struct pso_pointer list = fetch_arg( frame_pointer, 0); + struct pso4* frame = pointer_to_pso4(frame_pointer); + + struct pso_pointer list = fetch_arg( frame, 0); int count = 0; - for ( struct pso_pointer cursor = list; !nilp( cursor); + for ( struct pso_pointer cursor = list; !c_nilp( cursor); cursor = cdr( make_frame( 1, frame_pointer, list))) { count++; } - return make_integer( pointer_to_pso4(frame_pointer), count); + return make_integer( frame_pointer, count); } diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index 502577f..3b1fcb1 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -18,4 +18,5 @@ #include "payloads/function.h" struct pso_pointer length( struct pso_pointer frame_pointer); + #endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index f470477..151b5b7 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -54,7 +54,7 @@ void c_repl( bool show_prompt ) { // TODO: NULL is not OK here, but will do until we have a REPL in Lisp. struct pso_pointer env = - consp( oblist ) ? oblist : make_cons( NULL, oblist, nil ); + consp( oblist ) ? oblist : make_cons( nil, oblist, nil ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); @@ -77,7 +77,7 @@ void c_repl( bool show_prompt ) { /* bottom of stack */ struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); - if ( nilp( frame_pointer ) ) + if ( c_nilp( frame_pointer ) ) break; struct pso_pointer input = read( #ifndef MANAGED_POINTER_ONLY @@ -86,7 +86,7 @@ void c_repl( bool show_prompt ) { frame_pointer, env ); frame_pointer = make_frame( 1, frame_pointer, input ); - if ( nilp( frame_pointer ) ) + if ( c_nilp( frame_pointer ) ) break; struct pso_pointer result = eval( diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 7bf3bc2..65be27a 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -35,39 +35,41 @@ * @return a sequence like the `sequence` passed, but reversed; or `nil` if * the argument was not a sequence. */ -struct pso_pointer c_reverse( struct pso_pointer sequence ) { +struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; - for ( struct pso_pointer cursor = sequence; !nilp( sequence ); + for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); cursor = c_cdr( cursor ) ) { struct pso2 *object = pointer_to_object( cursor ); switch ( get_tag_value( cursor ) ) { case CONSTV: - result = make_cons( c_car( cursor ), result ); + result = make_cons( frame_pointer, c_car( cursor ), result ); break; case KEYTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( object->payload.string.character, + make_string_like_thing( frame_pointer, object->payload.string.character, result, KEYTAG ); break; case STRINGTV: result = - make_string_like_thing( object->payload.string.character, + make_string_like_thing( frame_pointer, object->payload.string.character, result, STRINGTAG ); break; case SYMBOLTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( object->payload.string.character, + make_string_like_thing( frame_pointer, object->payload.string.character, result, SYMBOLTAG ); break; default: result = - make_exception( make_cons( c_string_to_lisp_string - ( L"Invalid object in sequence" ), - cursor ), nil, nil, nil ); + make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, L"Invalid object in sequence" ), + cursor ) )); goto exit; break; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index bc199d1..7bdc88a 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -46,7 +46,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { case KEYTV: case STRINGTV: case SYMBOLTV: - if ( nilp( cell->payload.string.cdr ) ) { + if ( c_nilp( cell->payload.string.cdr ) ) { result = ( uint32_t ) c; } else { result = @@ -69,12 +69,12 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * char32_t in larger pso classes, so this function may be only for strings * (and thus simpler). */ -struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer, +struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail, char *tag ) { struct pso_pointer pointer = tail; - if ( check_type( tail, tag ) || nilp( tail ) ) { + if ( check_type( tail, tag ) || c_nilp( tail ) ) { pointer = allocate( frame_pointer, tag, CONS_SIZE_CLASS ); struct pso2 *cell = pointer_to_object( pointer ); @@ -107,7 +107,7 @@ struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer, * @param c the character to add (prepend); * @param tail the string which is being built. */ -struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ) { return make_string_like_thing( frame_pointer, c, tail, STRINGTAG ); } @@ -120,7 +120,7 @@ struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c, * @param c the character to add (prepend); * @param tail the keyword which is being built. */ -struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ) { return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); } @@ -133,7 +133,7 @@ struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c, * @param c the character to add (prepend); * @param tail the symbol which is being built. */ -struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ) { return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); } @@ -142,7 +142,7 @@ struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c, /** * Return a lisp string representation of this wide character string. */ -struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, char32_t *string ) { struct pso_pointer result = nil; @@ -164,7 +164,7 @@ struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer, * Return a lisp symbol representation of this wide character string. In * symbols, I am accepting only lower case characters. */ -struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, char32_t *symbol ) { struct pso_pointer result = nil; @@ -183,7 +183,7 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer, * 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( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, char32_t *symbol ) { struct pso_pointer result = nil; diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index aeaf243..781901f 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -17,26 +17,26 @@ #include #include -struct pso_pointer make_string_like_thing( struct pso4 *frame_pointer, +struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail, char *tag ); -struct pso_pointer make_string( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); -struct pso_pointer make_keyword( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); -struct pso_pointer make_symbol( struct pso4 *frame_pointer, wint_t c, +struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); -struct pso_pointer c_string_to_lisp_string( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, char32_t * string ); -struct pso_pointer c_string_to_lisp_keyword( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, char32_t * symbol ); -struct pso_pointer c_string_to_lisp_symbol( struct pso4 *frame_pointer, +struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, char32_t * symbol ); #endif diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 7b0eb76..d9790e0 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -27,21 +27,10 @@ * @return true if `p` points to `nil`. * @return false otherwise. */ -bool nilp( struct pso_pointer p ) { +bool c_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`. * @@ -56,52 +45,82 @@ bool not( struct pso_pointer p ) { * @return true if `p` points to `t`. * @return false otherwise. */ -bool truep( struct pso_pointer p ) { +bool c_truep( struct pso_pointer p ) { return ( p.page == 0 && p.offset == 4 ); } /** * @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` */ -struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer nilp( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - return ( nilp( fetch_arg( frame, 0 ) ) ? t : nil ); + return ( c_nilp( fetch_arg( frame, 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`. */ -struct pso_pointer lisp_truep( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer truep( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - return ( truep( fetch_arg( frame, 0 ) ) ? t : nil ); + return ( c_truep( fetch_arg( frame, 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`. */ -struct pso_pointer lisp_not( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer not( struct pso_pointer frame_pointer) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - return ( not( fetch_arg( frame, 0 ) ) ? t : nil ); + return ( !c_nilp( fetch_arg( frame, 0 ) ) ? t : nil ); +} + +/** + * @brief (and args...) + * + * @return `nil` if any `arg` is `nil`, else `t`. + */ +struct pso_pointer and( struct pso_pointer frame_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer result = t; + + for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { + if (c_nilp(fetch_arg(frame, arg))) { + result = nil; + break; + } + } + + return result; +} + + +/** + * @brief (or args...) + * + * @return `t` if any `arg` is non-nil, else `nil`. + */ +struct pso_pointer or( struct pso_pointer frame_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer result = nil; + + for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { + if (!c_nilp(fetch_arg(frame, arg))) { + result = t; + break; + } + } + + return result; } diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index 0fa0574..38de633 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -14,21 +14,18 @@ #include #include "memory/pointer.h" -#include "memory/pso4.h" -bool nilp( struct pso_pointer p ); +struct pso_pointer nilp( struct pso_pointer frame_pointer ); -struct pso_pointer lisp_nilp( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer not( struct pso_pointer frame_pointer ); -bool not( struct pso_pointer p ); +struct pso_pointer truep( struct pso_pointer frame_pointer ); -struct pso_pointer lisp_not( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer and( struct pso_pointer frame_pointer ); -bool truep( struct pso_pointer p ); +struct pso_pointer or( struct pso_pointer frame_pointer ); -struct pso_pointer lisp_truep( struct pso_pointer frame_pointer, - struct pso_pointer env ); +bool c_nilp(struct pso_pointer p); +bool c_truep(struct pso_pointer p); #endif diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c index 962724c..88d5b0d 100644 --- a/src/c/payloads/character.c +++ b/src/c/payloads/character.c @@ -11,7 +11,6 @@ * wide characters */ #include -#include #include #include "memory/node.h" @@ -22,12 +21,12 @@ #include "ops/truth.h" -#include "payloads/character.h" +// #include "payloads/character.h" -struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c ) { +struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c ) { struct pso_pointer result = allocate( frame_pointer, CHARACTERTAG, 2 ); - if ( !nilp( result ) ) { + if ( !c_nilp( result ) ) { pointer_to_object( result )->payload.character.character = ( char32_t ) c; } diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index a901642..2862bfe 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -38,5 +38,5 @@ struct character_payload { char32_t character; }; -struct pso_pointer make_character( struct pso4 *frame_pointer, wint_t c ); +struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c ); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 6963fbb..39b10a4 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -25,93 +25,97 @@ /** * @brief allocate a cons cell with this car and this cdr, and return a pointer * to it. - * + * * (cons object object) * * @param frame_pointer a pointer to a stack frame. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer cons( struct pso_pointer frame_pointer ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = allocate( frame, CONSTAG, 2 ); +struct pso_pointer cons(struct pso_pointer frame_pointer) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = allocate(frame_pointer, CONSTAG, 2); - if ( stackp( frame ) ) { - struct pso2 *object = pointer_to_object( result ); - object->payload.cons.car = - inc_ref( frame->payload.stack_frame.args[0] ); - object->payload.cons.cdr = - inc_ref( frame->payload.stack_frame.args[0] ); - } + struct pso2 *object = pointer_to_object(result); + object->payload.cons.car = inc_ref(fetch_arg(frame, 0)); + object->payload.cons.cdr = inc_ref(fetch_arg(frame, 1)); - return result; + return result; } +struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr){ + return cons( make_frame(2, frame_pointer, car, cdr)); +} /** * @brief return the car of this cons cell. - * + * * (car cell) * * @param frame_pointer a pointer to a stack frame. * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer car( struct pso_pointer frame_pointer ) { - struct pso_pointer result = nil; - struct pso_pointer cons = fetch_arg( pointer_to_pso4( frame_pointer), 0); - struct pso2 *object = pointer_to_object( cons ); +struct pso_pointer car(struct pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer cons = fetch_arg(frame, 0); + struct pso2 *object = pointer_to_object(cons); - if ( consp( cons ) ) { - result = object->payload.cons.car; - } else { - result = - make_exception( make_frame( 2, frame_pointer, - c_string_to_lisp_string( frame_pointer, L"Invalid type for car" ), - make_cons( - make_cons( frame_pointer, - c_string_to_lisp_keyword( frame_pointer, L"type" ), - get_tag_string( cons )), nil))); + if (consp(cons)) { + result = object->payload.cons.car; + } else { + result = make_exception(make_frame( + 2, frame_pointer, + c_string_to_lisp_string(frame_pointer, L"Invalid type for car"), + make_cons(frame_pointer, make_cons( + frame_pointer, + c_string_to_lisp_keyword(frame_pointer, L"type"), + get_tag_string(cons)), + nil))); } - return result; + return result; } /** * @brief return the cdr of this cons (or other sequence) cell. - * + * * (cdr cell) * * @param frame_pointer a pointer to a stack frame. * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr( struct pso_pointer frame_pointer ) { - struct pso_pointer result = nil; - struct pso4 *sp = pointer_to_pso4(frame_pointer); - struct pso_pointer cons = fetch_arg(sp, 0); - struct pso2 *object = pointer_to_object( cons ); +struct pso_pointer cdr(struct pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer cons = fetch_arg(frame, 0); + struct pso2 *object = pointer_to_object(cons); - 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( make_frame( 2, frame_pointer, - c_string_to_lisp_string( frame_pointer, L"Invalid type for cdr" ), - make_cons( - make_cons( frame_pointer, - c_string_to_lisp_keyword( frame_pointer, L"type" ), - get_tag_string( cons )), nil))); - break; - } + switch (get_tag_value(cons)) { + case CONSTV: + result = object->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = object->payload.string.cdr; + break; + default: + struct pso_pointer type_binding = + make_cons(frame_pointer, + c_string_to_lisp_keyword(frame_pointer, L"type"), + get_tag_string(cons)); + result = make_exception(make_frame( + 2, frame_pointer, + c_string_to_lisp_string(frame_pointer, L"Invalid type for cdr"), + make_cons(frame_pointer, + type_binding, + nil))); + break; + } - return result; + return result; } /** @@ -121,12 +125,15 @@ struct pso_pointer cdr( struct pso_pointer frame_pointer ) { * 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( c_car( p ) ); - dec_ref( c_cdr( frame, p ) ); - } +struct pso_pointer destroy_cons(struct pso_pointer fp) { + if (stackp(fp)) { + struct pso4 *frame = pointer_to_pso4(fp); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; + + if (check_tag(p, CONSTV)) { + struct pso2 *cons = pointer_to_object(p); + dec_ref(cons->payload.cons.car); + dec_ref(cons->payload.cons.cdr); + } + } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 62fd5ff..540034c 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -33,7 +33,24 @@ struct pso_pointer cdr( struct pso_pointer frame_pointer ); struct pso_pointer cons( struct pso_pointer frame_pointer ); -struct pso_pointer destroy_cons( struct pso_pointer fp, - struct pso_pointer env ); +struct pso_pointer destroy_cons( struct pso_pointer frame_pointer); + +struct pso_pointer make_cons(struct pso_pointer frame_pointer, + struct pso_pointer car, + struct pso_pointer cdr); + +/** + * macro short-cuts for make_cons. + */ +// #define make_cons(frame_pointer,car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) + +/** + * Variant which assumes a convention that the frame pointer will always be + * called `frame_pointer` + */ +#define make_cons2(car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) + +#define c_car(p)(consp(p) ? pointer_to_object(p)->payload.cons.car : nil) +#define c_cdr(p)(consp(p) ? pointer_to_object(p)->payload.cons.cdr : nil) #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index bf7a225..e184354 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -6,6 +6,13 @@ * (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" @@ -17,7 +24,12 @@ #include "payloads/exception.h" +#include "ops/stack_ops.h" #include "ops/truth.h" +#include +#include +#include +#include /** * @brief allocate an exception object, and, if successful, return a pointer @@ -31,8 +43,7 @@ * otherwise it will return a pointer to a new exception. * * @param message expected to be a string, but anything printable is accepted. - * @param frame the stack frame in which the exception was `thrown`, if any. - * @param meta metadata for this exception. Must be an assoc list, hashtable, +b * @param meta metadata for this exception. Must be an assoc list, hashtable, * or `nil` * @param cause the exception that caused this exception to be `thrown`. */ @@ -44,13 +55,13 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer) { struct pso_pointer cause = fetch_arg( frame, 2); struct pso_pointer result = - allocate( pointer_to_pso4( frame ), EXCEPTIONTAG, 3 ); + allocate( frame_pointer, EXCEPTIONTAG, 3 ); - if ( !nilp( result ) && !exceptionp( result ) ) { + if ( !c_nilp( result ) && !exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); object->payload.exception.message = message; - object->payload.exception.stack = stackp( frame ) ? frame : nil; + object->payload.exception.stack = stackp( frame_pointer ) ? frame_pointer : nil; object->payload.exception.meta = ( consp( meta ) || hashtabp( meta ) ) ? meta : nil; object->payload.exception.cause = exceptionp( cause ) ? cause : nil; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 110252d..27e7e08 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -26,10 +26,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 meta, - struct pso_pointer cause ); +struct pso_pointer make_exception( struct pso_pointer frame_pointer ); struct pso_pointer destroy_exception( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 0c0e861..032005d 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -25,7 +25,7 @@ * @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( struct pso4 *frame_pointer, int64_t value ) { +struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ) { struct pso_pointer result = nil; debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 ); diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index 9205ebc..b537388 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -25,6 +25,6 @@ struct integer_payload { __int128_t value; }; -struct pso_pointer make_integer( struct pso4 *frame_pointer, int64_t value ); +struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ); #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index ad23d19..f1a1fb8 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -16,6 +16,7 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -34,8 +35,8 @@ struct pso_pointer destroy_string( struct pso_pointer fp, struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; - dec_ref( c_cdr( frame, p ) ); - } + dec_ref( c_cdr( p ) ); + } return nil; } diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index 1286335..9cdce09 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -25,7 +25,7 @@ * @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( struct pso4 *frame_pointer, +struct pso_pointer make_read_stream( struct pso_pointer frame_pointer, URL_FILE *input, struct pso_pointer metadata ) { struct pso_pointer pointer = allocate( frame_pointer, READTAG, 2 ); diff --git a/src/c/payloads/read_stream.h b/src/c/payloads/read_stream.h index 23a04a7..c8dc33f 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( struct pso4 *frame_pointer, +struct pso_pointer make_read_stream( struct pso_pointer frame_pointer, URL_FILE * input, struct pso_pointer metadata ); diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 916c5c6..86c68b1 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -1,5 +1,5 @@ /** - * payloads/stack.h + * payloads/stack.c * * a Lisp stack frame. * @@ -23,6 +23,7 @@ #include "payloads/cons.h" #include "ops/reverse.h" +#include "ops/list_ops.h" /** * @brief Construct a stack frame with this `previous` pointer, and arguments @@ -43,7 +44,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = - allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + allocate( previous, STACKTAG, 4 ); struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG @@ -78,7 +79,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( prev_frame, va_arg( args, struct pso_pointer ), + make_cons( previous, va_arg( args, struct pso_pointer ), more_args ); } @@ -117,7 +118,7 @@ struct pso_pointer make_frame_with_env( int arg_count, struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = - allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + allocate( previous, STACKTAG, 4 ); struct pso4* new_frame = pointer_to_pso4(new_pointer); #ifdef DEBUG @@ -152,7 +153,7 @@ struct pso_pointer make_frame_with_env( int arg_count, for ( ; cursor < arg_count; cursor++ ) { more_args = - make_cons( prev_frame, va_arg( args, struct pso_pointer ), + make_cons( previous, va_arg( args, struct pso_pointer ), more_args ); } @@ -184,10 +185,10 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer env) { struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = - allocate( pointer_to_pso4( previous ), STACKTAG, 4 ); + allocate( previous, STACKTAG, 4 ); struct pso4* new_frame = pointer_to_pso4(new_pointer); - int arg_count = c_length(argvalues); - + struct pso_pointer arg_length = length(make_frame(1, previous, argvalues)); + int arg_count = integerp(arg_length) ? pointer_to_object(arg_length)->payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -216,7 +217,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, argvalues = cdr( make_frame( 1, previous, argvalues)); } if ( cursor < arg_count ) { - new_frame->payload.stack_frame.more = inc_ref( cursor); + new_frame->payload.stack_frame.more = inc_ref( argvalues); } else { for ( ; cursor < args_in_frame; cursor++ ) { new_frame->payload.stack_frame.arg[cursor] = nil; diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index dd2e8ae..a9e1a0d 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -43,9 +43,18 @@ struct stack_frame_payload { struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ); + struct pso_pointer make_frame_with_env( int arg_count, struct pso_pointer previous, - struct pso_pointer env, ... ) + struct pso_pointer env, ... ); + +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, + struct pso_pointer argvalues, + struct pso_pointer env); + +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, + struct pso_pointer argvalues); + struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/payloads/write_stream.c b/src/c/payloads/write_stream.c index 1397e7a..85ce8eb 100644 --- a/src/c/payloads/write_stream.c +++ b/src/c/payloads/write_stream.c @@ -25,7 +25,7 @@ * @param metadata a pointer to an associaton containing metadata on the stream. * @return a pointer to the new read stream. */ -struct pso_pointer make_write_stream( struct pso4 *frame_pointer, +struct pso_pointer make_write_stream( struct pso_pointer frame_pointer, URL_FILE *output, struct pso_pointer metadata ) { struct pso_pointer pointer = allocate( frame_pointer, WRITETAG, 2 ); diff --git a/src/c/payloads/write_stream.h b/src/c/payloads/write_stream.h index 07e3b14..7dc7d36 100644 --- a/src/c/payloads/write_stream.h +++ b/src/c/payloads/write_stream.h @@ -13,7 +13,7 @@ /* write stream shares a payload with /see read_streem.h */ #include "io/fopen.h" -struct pso_pointer make_write_stream( struct pso4 *frame_pointer, +struct pso_pointer make_write_stream( struct pso_pointer frame_pointer, URL_FILE * output, struct pso_pointer metadata ); #endif From 8d2acbeb0f67ccafd3d31d130d5f406624f5ec62 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 22 Apr 2026 21:09:15 +0100 Subject: [PATCH 49/77] Still making progress. Dropped the archive because it was causing problems. --- archive/c/arith/integer.c | 508 -------- archive/c/arith/integer.h | 41 - archive/c/arith/peano.c | 825 ------------- archive/c/arith/peano.h | 95 -- archive/c/arith/ratio.c | 411 ------- archive/c/arith/ratio.h | 41 - archive/c/arith/real.c | 29 - archive/c/arith/real.h | 32 - archive/c/authorise.c | 24 - archive/c/authorise.h | 16 - archive/c/debug.c | 181 --- archive/c/debug.h | 101 -- archive/c/init.c | 564 --------- archive/c/io/fopen.c | 526 -------- archive/c/io/fopen.h | 83 -- archive/c/io/history.c | 14 - archive/c/io/history.h | 14 - archive/c/io/io.c | 557 --------- archive/c/io/io.h | 46 - archive/c/io/print.c | 356 ------ archive/c/io/print.h | 30 - archive/c/io/read.c | 570 --------- archive/c/io/read.h | 32 - archive/c/memory/conspage.c | 290 ----- archive/c/memory/conspage.h | 68 - archive/c/memory/consspaceobject.c | 561 --------- archive/c/memory/consspaceobject.h | 812 ------------ archive/c/memory/cursor.c | 9 - archive/c/memory/cursor.h | Bin 614 -> 0 bytes archive/c/memory/dump.c | 166 --- archive/c/memory/dump.h | 27 - archive/c/memory/hashmap.c | 152 --- archive/c/memory/hashmap.h | 38 - archive/c/memory/lookup3.c | 1281 ------------------- archive/c/memory/lookup3.h | 16 - archive/c/memory/stack.c | 380 ------ archive/c/memory/stack.h | 69 -- archive/c/memory/vectorspace.c | 158 --- archive/c/memory/vectorspace.h | 121 -- 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 - archive/c/repl.c | 50 - archive/c/repl.h | 29 - archive/c/time/psse_time.c | 109 -- archive/c/time/psse_time.h | 21 - archive/c/utils.c | 33 - archive/c/utils.h | 17 - archive/c/version.h | 11 - src/c/environment/environment.c | 20 +- src/c/io/io.c | 164 ++- src/c/io/io.h | 11 +- src/c/io/print.c | 43 +- src/c/io/print.h | 4 +- src/c/io/read.c | 52 +- src/c/io/read.h | 9 +- src/c/memory/destroy.c | 6 +- src/c/memory/memory.c | 12 +- src/c/memory/node.c | 23 +- src/c/memory/page.c | 3 +- src/c/memory/pso.c | 6 +- src/c/memory/tags.c | 6 +- src/c/memory/tags.h | 3 +- src/c/ops/assoc.c | 18 +- src/c/ops/bind.c | 17 +- src/c/ops/bind.h | 10 +- src/c/ops/eq.h | 2 +- src/c/ops/eval_apply.c | 58 +- src/c/ops/eval_apply.h | 14 +- src/c/ops/list_ops.c | 20 +- src/c/ops/list_ops.h | 2 +- src/c/ops/repl.c | 51 +- src/c/ops/repl.h | 3 +- src/c/ops/reverse.c | 23 +- src/c/ops/stack_ops.c | 7 +- src/c/ops/stack_ops.h | 2 +- src/c/ops/truth.c | 54 +- src/c/ops/truth.h | 4 +- src/c/payloads/character.h | 3 +- src/c/payloads/cons.c | 142 ++- src/c/payloads/cons.h | 7 +- src/c/payloads/exception.c | 21 +- src/c/payloads/exception.h | 3 +- src/c/payloads/integer.c | 3 +- src/c/payloads/integer.h | 3 +- src/c/payloads/psse_string.c | 14 +- src/c/payloads/psse_string.h | 3 +- src/c/payloads/stack.c | 77 +- src/c/payloads/stack.h | 18 +- src/c/psse.c | 20 +- 97 files changed, 490 insertions(+), 13322 deletions(-) delete mode 100644 archive/c/arith/integer.c delete mode 100644 archive/c/arith/integer.h delete mode 100644 archive/c/arith/peano.c delete mode 100644 archive/c/arith/peano.h delete mode 100644 archive/c/arith/ratio.c delete mode 100644 archive/c/arith/ratio.h delete mode 100644 archive/c/arith/real.c delete mode 100644 archive/c/arith/real.h delete mode 100644 archive/c/authorise.c delete mode 100644 archive/c/authorise.h delete mode 100644 archive/c/debug.c delete mode 100644 archive/c/debug.h delete mode 100644 archive/c/init.c delete mode 100644 archive/c/io/fopen.c delete mode 100644 archive/c/io/fopen.h delete mode 100644 archive/c/io/history.c delete mode 100644 archive/c/io/history.h delete mode 100644 archive/c/io/io.c delete mode 100644 archive/c/io/io.h delete mode 100644 archive/c/io/print.c delete mode 100644 archive/c/io/print.h delete mode 100644 archive/c/io/read.c delete mode 100644 archive/c/io/read.h delete mode 100644 archive/c/memory/conspage.c delete mode 100644 archive/c/memory/conspage.h delete mode 100644 archive/c/memory/consspaceobject.c delete mode 100644 archive/c/memory/consspaceobject.h delete mode 100644 archive/c/memory/cursor.c delete mode 100644 archive/c/memory/cursor.h delete mode 100644 archive/c/memory/dump.c delete mode 100644 archive/c/memory/dump.h delete mode 100644 archive/c/memory/hashmap.c delete mode 100644 archive/c/memory/hashmap.h delete mode 100644 archive/c/memory/lookup3.c delete mode 100644 archive/c/memory/lookup3.h delete mode 100644 archive/c/memory/stack.c delete mode 100644 archive/c/memory/stack.h delete mode 100644 archive/c/memory/vectorspace.c delete mode 100644 archive/c/memory/vectorspace.h 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 delete mode 100644 archive/c/repl.c delete mode 100644 archive/c/repl.h delete mode 100644 archive/c/time/psse_time.c delete mode 100644 archive/c/time/psse_time.h delete mode 100644 archive/c/utils.c delete mode 100644 archive/c/utils.h delete mode 100644 archive/c/version.h diff --git a/archive/c/arith/integer.c b/archive/c/arith/integer.c deleted file mode 100644 index 682efd0..0000000 --- a/archive/c/arith/integer.c +++ /dev/null @@ -1,508 +0,0 @@ -/* - * integer.c - * - * functions for integer cells. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define _GNU_SOURCE -#include -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "arith/integer.h" -#include "arith/peano.h" -#include "debug.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "ops/equal.h" -#include "ops/lispops.h" - -/** - * hexadecimal digits for printing numbers. - */ -const char *hex_digits = "0123456789ABCDEF"; - -/* - * Doctrine from here on in is that ALL integers are bignums, it's just - * that integers less than 61 bits are bignums of one cell only. - * that integers less than 61 bits are bignums of one cell only. - * TODO: why do I not have confidence to make this 64 bits? - */ - - /* - * A small_int_cache array of pointers to the integers 0...23, - * used only by functions `acquire_integer(int64) => cons_pointer` and - * `release_integer(cons_pointer) => NULL` which, if the value desired is - * in the cache, supplies it from the cache, and, otherwise, calls - * make_integer() and dec_ref() respectively. - */ - -#define SMALL_INT_LIMIT 24 -bool small_int_cache_initialised = false; -struct cons_pointer small_int_cache[SMALL_INT_LIMIT]; - - /** - * Low level integer arithmetic, do not use elsewhere. - * - * @param c a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expected to be either - * '+' or '*'; behaviour with other values is undefined. - * @param is_first_cell true if this is the first cell in a bignum - * chain, else false. - * \see multiply_integers - * \see add_integers - */ -__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { - long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; - - long int carry = is_first_cell ? 0 : ( INT_CELL_BASE ); - - __int128_t result = ( __int128_t ) integerp( c ) ? - ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; - debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ", - val, is_first_cell ? "true" : "false", - pointer2cell( c ).tag.bytes ); - debug_print_128bit( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; -} - - -/** - * Allocate an integer cell representing this `value` and return a cons_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 cons_pointer make_integer( int64_t value, struct cons_pointer more ) { - struct cons_pointer result = NIL; - debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); - - if ( integerp( more ) - && ( pointer2cell( more ).payload.integer.value < 0 ) ) { - printf( "WARNING: negative value %" PRId64 - " passed as `more` to `make_integer`\n", - pointer2cell( more ).payload.integer.value ); - } - - if ( integerp( more ) || nilp( more ) ) { - result = allocate_cell( INTEGERTV ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.integer.value = value; - cell->payload.integer.more = more; - } - - debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); - debug_dump_object( result, DEBUG_ALLOC ); - return result; -} - -/** - * @brief Supply small valued integers from the small integer cache, if available. - * - * The pattern here is intended to be that, at least within this file, instead of - * calling make_integer when an integer is required and dec_ref when it's no longer - * required, we call acquire_integer and release_integer respectively, in order to - * reduce allocation churn. - * - * In the initial implementation, acquire_integer supplies the integer from the - * small integer cache if available, else calls make_integer. Later, more - * sophisticated caching of integers which are currently in play may be enabled. - * - * @param value the value of the integer desired. - * @param more if this value is a bignum, the rest (less significant bits) of the - * value. - * @return struct cons_pointer a pointer to the integer acquired. - */ -struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) { - struct cons_pointer result; - - if ( !nilp( more ) || value < 0 || value >= SMALL_INT_LIMIT ) { - debug_print - ( L"acquire_integer passing to make_integer (outside small int range)\n", - DEBUG_ALLOC ); - result = make_integer( value, more ); - } else { - if ( !small_int_cache_initialised ) { - for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) { - small_int_cache[i] = make_integer( i, NIL ); - pointer2cell( small_int_cache[i] ).count = MAXREFERENCE; // lock it in so it can't be GC'd - } - small_int_cache_initialised = true; - debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC ); - } - - debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n", - value ); - result = small_int_cache[value]; - } - return result; -} - -/** - * @brief if the value of p is less than the size of the small integer cache - * (and thus it was presumably supplied from there), suppress dec_ref. - * - * **NOTE THAT** at this stage it's still safe to dec_ref an arbitrary integer, - * because those in the cache are locked and can't be dec_refed. - * - * @param p a pointer, expected to be to an integer. - */ -void release_integer( struct cons_pointer p ) { - struct cons_space_object o = pointer2cell( p ); - if ( !integerp( p ) || // what I've been passed isn't an integer; - !nilp( o.payload.integer.more ) || // or it's a bignum; - o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit; - !eq( p, small_int_cache[o.payload.integer.value] ) // or it's simply not the copy in the cache... - ) { - dec_ref( p ); - } else { - debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n", - o.payload.integer.value ); - } -} - - -/** - * @brief Overwrite the value field of the integer indicated by `new` with - * the least significant INTEGER_BITS bits of `val`, and return the - * more significant bits (if any) right-shifted by INTEGER_BITS places. - * - * Destructive, primitive, DO NOT USE in any context except primitive - * operations on integers. The value passed as `new` MUST be constructed - * with `make_integer`, NOT acquired with `acquire_integer`. - * - * @param val the value to represent; - * @param less_significant the less significant words of this bignum, if any, - * else NIL; - * @param new a newly created integer, which will be destructively changed. - * @return carry, if any, else 0. - */ -__int128_t int128_to_integer( __int128_t val, - struct cons_pointer less_significant, - struct cons_pointer new ) { - __int128_t carry = 0; - - if ( MAX_INTEGER >= val ) { - carry = 0; - } else { - carry = val % INT_CELL_BASE; - debug_printf( DEBUG_ARITH, - L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", - ( int64_t ) carry ); - val /= INT_CELL_BASE; - } - - struct cons_space_object *newc = &pointer2cell( new ); - newc->payload.integer.value = ( int64_t ) val; - - if ( integerp( less_significant ) ) { - struct cons_space_object *lsc = &pointer2cell( less_significant ); - // inc_ref( new ); - lsc->payload.integer.more = new; - } - - return carry; -} - -/** - * Return a pointer to an integer representing the sum of the integers - * pointed to by `a` and `b`. If either isn't an integer, will return nil. - */ -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = NIL; - struct cons_pointer cursor = NIL; - - __int128_t carry = 0; - bool is_first_cell = true; - - while ( integerp( a ) || integerp( b ) || carry != 0 ) { - __int128_t av = cell_value( a, '+', is_first_cell ); - __int128_t bv = cell_value( b, '+', is_first_cell ); - __int128_t rv = ( av + bv ) + carry; - - debug_print( L"add_integers: av = ", DEBUG_ARITH ); - debug_print_128bit( av, DEBUG_ARITH ); - debug_print( L"; bv = ", DEBUG_ARITH ); - debug_print_128bit( bv, DEBUG_ARITH ); - debug_print( L"; carry = ", DEBUG_ARITH ); - debug_print_128bit( carry, DEBUG_ARITH ); - debug_print( L"; rv = ", DEBUG_ARITH ); - debug_print_128bit( rv, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) { - result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL ); - break; - } else { - struct cons_pointer new = make_integer( 0, NIL ); - carry = int128_to_integer( rv, cursor, new ); - cursor = new; - - if ( nilp( result ) ) { - result = cursor; - } - - a = pointer2cell( a ).payload.integer.more; - b = pointer2cell( b ).payload.integer.more; - is_first_cell = false; - } - } - - debug_print( L"add_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; -} - -// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea. -struct cons_pointer base_partial( int depth ) { - struct cons_pointer result = NIL; - - debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth ); - - for ( int i = 0; i < depth; i++ ) { - result = acquire_integer( 0, result ); - } - - return result; -} - -/** - * @brief Return a copy of this `partial` with this `digit` appended. - * - * @param partial the more significant bits of a possible bignum. - * @param digit the less significant bits of that possible bignum. NOTE: the - * name `digit` is technically correct but possibly misleading, because the - * numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL - */ -struct cons_pointer append_cell( struct cons_pointer partial, - struct cons_pointer digit ) { - struct cons_space_object cell = pointer2cell( partial ); - // TODO: I should recursively copy the whole bignum chain, because - // we're still destructively modifying the end of it. - struct cons_pointer c = make_integer( cell.payload.integer.value, - cell.payload.integer.more ); - struct cons_pointer result = partial; - - if ( nilp( partial ) ) { - result = digit; - } else { - // find the last digit in the chain... - while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { - c = pointer2cell( c ).payload.integer.more; - } - - ( pointer2cell( c ) ).payload.integer.more = digit; - } - return result; -} - - - -/** - * Return a pointer to an integer representing the product of the integers - * pointed to by `a` and `b`. If either isn't an integer, will return nil. - * - * Yes, this is one of Muhammad ibn Musa al-Khwarizmi's original recipes, so - * you'd think it would be easy; the reason that each step is documented is - * because I did not find it so. - * - * @param a an integer; - * @param b an integer. - */ -struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = acquire_integer( 0, NIL ); - bool neg = is_negative( a ) != is_negative( b ); - bool is_first_b = true; - int i = 0; - - debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); - debug_print_object( a, DEBUG_ARITH ); - debug_print( L"; b = ", DEBUG_ARITH ); - debug_print_object( b, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - if ( integerp( a ) && integerp( b ) ) { - /* for each digit in a, starting with the least significant (ai) */ - - for ( struct cons_pointer ai = a; !nilp( ai ); - ai = pointer2cell( ai ).payload.integer.more ) { - /* set carry to 0 */ - __int128_t carry = 0; - - /* set least significant digits for result ri for this iteration - * to i zeros */ - struct cons_pointer ri = base_partial( i++ ); - - /* for each digit in b, starting with the least significant (bj) */ - for ( struct cons_pointer bj = b; !nilp( bj ); - bj = pointer2cell( bj ).payload.integer.more ) { - - debug_printf( DEBUG_ARITH, - L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", - pointer2cell( ai ).payload.integer.value, - pointer2cell( bj ).payload.integer.value, i ); - - /* multiply ai with bj and add the carry, resulting in a - * value xj which may exceed one digit */ - __int128_t xj = pointer2cell( ai ).payload.integer.value * - pointer2cell( bj ).payload.integer.value; - xj += carry; - - /* if xj exceeds one digit, break it into the digit dj and - * the carry */ - carry = xj >> INTEGER_BIT_SHIFT; - struct cons_pointer dj = - acquire_integer( xj & MAX_INTEGER, NIL ); - - replace_integer_p( ri, append_cell( ri, dj ) ); - // struct cons_pointer new_ri = append_cell( ri, dj ); - // release_integer( ri); - // ri = new_ri; - } /* end for bj */ - - /* if carry is not equal to zero, append it as a final cell - * to ri */ - if ( carry != 0 ) { - replace_integer_i( ri, carry ) - } - - /* add ri to result */ - result = add_integers( result, ri ); - - debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - } /* end for ai */ - } - - debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; -} - -/** - * don't use; private to integer_to_string, and somewhat dodgy. - */ -struct cons_pointer integer_to_string_add_digit( int digit, int digits, - struct cons_pointer tail ) { - wint_t character = btowc( hex_digits[digit] ); - debug_printf( DEBUG_IO, - L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ", - digit, digits ); - struct cons_pointer r = - ( digits % 3 == 0 ) ? make_string( L',', make_string( character, - tail ) ) : - make_string( character, tail ); - - debug_print_object( r, DEBUG_IO ); - debug_println( DEBUG_IO ); - - return r; -} - -/** - * @brief return a string representation of this integer, which may be a - * bignum. - * - * The general principle of printing a bignum is that you print the least - * significant digit in whatever base you're dealing with, divide through - * by the base, print the next, and carry on until you've none left. - * Obviously, that means you print from right to left. Given that we build - * strings from right to left, 'printing' an integer to a lisp string - * would seem reasonably easy. The problem is when you jump from one integer - * object to the next. 64 bit integers don't align with decimal numbers, so - * when we get to the last digit from one integer cell, we have potentially - * to be looking to the next. H'mmmm. - * - * @param int_pointer cons_pointer to the integer to print, - * @param base the base to print it in. - */ -struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ) { - struct cons_pointer result = NIL; - - if ( integerp( int_pointer ) ) { - struct cons_pointer next = - pointer2cell( int_pointer ).payload.integer.more; - __int128_t accumulator = - llabs( pointer2cell( int_pointer ).payload.integer.value ); - bool is_negative = - pointer2cell( int_pointer ).payload.integer.value < 0; - int digits = 0; - - if ( accumulator == 0 && nilp( next ) ) { - result = c_string_to_lisp_string( L"0" ); - } else { - while ( accumulator > 0 || !nilp( next ) ) { - if ( accumulator < MAX_INTEGER && !nilp( next ) ) { - accumulator += - ( pointer2cell( next ).payload.integer.value % - INT_CELL_BASE ); - next = pointer2cell( next ).payload.integer.more; - } - int offset = ( int ) ( accumulator % base ); - debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", - offset, hex_digits[offset] ); - debug_print_128bit( accumulator, DEBUG_IO ); - debug_print( L"; result is: ", DEBUG_IO ); - debug_print_object( result, DEBUG_IO ); - debug_println( DEBUG_IO ); - - result = - integer_to_string_add_digit( offset, ++digits, result ); - accumulator = accumulator / base; - } - - if ( stringp( result ) - && pointer2cell( result ).payload.string.character == L',' ) { - /* if the number of digits in the string is divisible by 3, there will be - * an unwanted comma on the front. */ - result = pointer2cell( result ).payload.string.cdr; - } - - - if ( is_negative ) { - result = make_string( L'-', result ); - } - } - } - - return result; -} - -/** - * true if a and be are both integers whose value is the same value. - */ -bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - if ( integerp( a ) && integerp( b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - result = - cell_a->payload.integer.value == cell_b->payload.integer.value; - } - - return result; -} diff --git a/archive/c/arith/integer.h b/archive/c/arith/integer.h deleted file mode 100644 index e08549f..0000000 --- a/archive/c/arith/integer.h +++ /dev/null @@ -1,41 +0,0 @@ -/* - * integer.h - * - * functions for integer cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __integer_h -#define __integer_h - -#include -#include -#include "memory/consspaceobject.h" - - -#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;} -#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;} - -struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); - -struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ); - -void release_integer( struct cons_pointer p ); - -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ); - -struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ); - -struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ); - -bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ); - -bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ); - -#endif diff --git a/archive/c/arith/peano.c b/archive/c/arith/peano.c deleted file mode 100644 index 9a1b478..0000000 --- a/archive/c/arith/peano.c +++ /dev/null @@ -1,825 +0,0 @@ -/* - * peano.c - * - * Basic peano arithmetic - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include - -#include "memory/consspaceobject.h" -#include "memory/conspage.h" -#include "debug.h" -#include "ops/equal.h" -#include "arith/integer.h" -#include "ops/intern.h" -#include "ops/lispops.h" -#include "arith/peano.h" -#include "io/print.h" -#include "arith/ratio.h" -#include "io/read.h" -#include "arith/real.h" -#include "memory/stack.h" - -long double to_long_double( struct cons_pointer arg ); -int64_t to_long_int( struct cons_pointer arg ); -struct cons_pointer add_2( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer arg1, - struct cons_pointer arg2 ); - -/** - * return true if this `arg` points to a number whose value is zero. - */ -bool zerop( struct cons_pointer arg ) { - bool result = false; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case INTEGERTV:{ - do { - debug_print( L"zerop: ", DEBUG_ARITH ); - debug_dump_object( arg, DEBUG_ARITH ); - result = - ( pointer2cell( arg ).payload.integer.value == 0 ); - arg = pointer2cell( arg ).payload.integer.more; - } while ( result && integerp( arg ) ); - } - break; - case RATIOTV: - result = zerop( cell.payload.ratio.dividend ); - break; - case REALTV: - result = ( cell.payload.real.value == 0 ); - break; - } - - return result; -} - -// TODO: think about -// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) { -// bool result = false; -// struct cons_space_object * cell_1 = & pointer2cell( arg_1 ); -// struct cons_space_object * cell_2 = & pointer2cell( arg_2 ); - -// if (cell_1->tag.value == cell_2->tag.value) { - -// switch ( cell_1->tag.value ) { -// case INTEGERTV:{ -// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) { -// result = cell_1->payload.integer.value > cell_2->payload.integer.value; -// } -// // else deal with comparing bignums... -// } -// break; -// case RATIOTV: -// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2); -// break; -// case REALTV: -// result = ( cell.payload.real.value == 0 ); -// break; -// } -// } - -// return result; - -// } - -/** - * does this `arg` point to a negative number? - */ -bool is_negative( struct cons_pointer arg ) { - bool result = false; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case INTEGERTV: - result = cell.payload.integer.value < 0; - break; - case RATIOTV: - result = is_negative( cell.payload.ratio.dividend ); - break; - case REALTV: - result = ( cell.payload.real.value < 0 ); - break; - } - - return result; -} - -/** - * @brief if `arg` is a number, return the absolute value of that number, else - * `NIL` - * - * @param arg a cons space object, probably a number. - * @return struct cons_pointer - */ -struct cons_pointer absolute( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); - - if ( numberp( arg ) ) { - if ( is_negative( arg ) ) { - switch ( cell.tag.value ) { - case INTEGERTV: - result = - make_integer( llabs( cell.payload.integer.value ), - cell.payload.integer.more ); - break; - case RATIOTV: - result = - make_ratio( absolute( cell.payload.ratio.dividend ), - cell.payload.ratio.divisor, false ); - break; - case REALTV: - result = make_real( 0 - cell.payload.real.value ); - break; - } - } else { - result = arg; - } - } - - return result; -} - -/** - * Return the closest possible `binary64` representation to the value of - * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` - * is not any of these. - * - * @arg a pointer to an integer, ratio or real. - * - * \todo cannot throw an exception out of here, which is a problem - * if a ratio may legally have zero as a divisor, or something which is - * not a number is passed in. - */ -long double to_long_double( struct cons_pointer arg ) { - long double result = 0; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case INTEGERTV: - // obviously, this doesn't work for bignums - result = ( long double ) cell.payload.integer.value; - // sadly, this doesn't work at all. -// result += 1.0; -// for (bool is_first = false; integerp(arg); is_first = true) { -// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result); -// debug_dump_object(arg, DEBUG_ARITH); -// if (!is_first) { -// result *= (long double)(MAX_INTEGER + 1); -// } -// result *= (long double)(cell.payload.integer.value); -// arg = cell.payload.integer.more; -// cell = pointer2cell( arg ); -// } - break; - case RATIOTV: - result = to_long_double( cell.payload.ratio.dividend ) / - to_long_double( cell.payload.ratio.divisor ); - break; - case REALTV: - result = cell.payload.real.value; - break; - default: - result = NAN; - break; - } - - debug_print( L"to_long_double( ", DEBUG_ARITH ); - debug_print_object( arg, DEBUG_ARITH ); - debug_printf( DEBUG_ARITH, L") => %lf\n", result ); - - return result; -} - - -/** - * Return the closest possible `int64_t` representation to the value of - * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` - * is not any of these. - * - * @arg a pointer to an integer, ratio or real. - * - * \todo cannot throw an exception out of here, which is a problem - * if a ratio may legally have zero as a divisor, or something which is - * not a number (or is a big number) is passed in. - */ -int64_t to_long_int( struct cons_pointer arg ) { - int64_t result = 0; - struct cons_space_object cell = pointer2cell( arg ); - switch ( cell.tag.value ) { - case INTEGERTV: - /* \todo if (integerp(cell.payload.integer.more)) { - * throw an exception! - * } */ - result = cell.payload.integer.value; - break; - case RATIOTV: - result = lroundl( to_long_double( arg ) ); - break; - case REALTV: - result = lroundl( cell.payload.real.value ); - break; - } - return result; -} - - -/** - * Function: calculate the absolute value of a number. - * - * (absolute arg) - * - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return the absolute value of the number represented by the first - * argument, or NIL if it was not a number. - */ -struct cons_pointer lisp_absolute( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - return absolute( frame->arg[0] ); -} - -/** - * return a cons_pointer indicating a number which is the sum of - * the numbers indicated by `arg1` and `arg2`. - */ -struct cons_pointer add_2( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer result; - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - - debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); - debug_dump_object( arg1, DEBUG_ARITH ); - debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_dump_object( arg2, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - if ( zerop( arg1 ) ) { - result = arg2; - } else if ( zerop( arg2 ) ) { - result = arg1; - } else { - - switch ( cell1.tag.value ) { - case EXCEPTIONTV: - result = arg1; - break; - case INTEGERTV: - switch ( cell2.tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV: - result = add_integers( arg1, arg2 ); - break; - case RATIOTV: - result = add_integer_ratio( arg1, arg2 ); - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) + - to_long_double( arg2 ) ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); - break; - } - break; - case RATIOTV: - switch ( cell2.tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV: - result = add_integer_ratio( arg2, arg1 ); - break; - case RATIOTV: - result = add_ratio_ratio( arg1, arg2 ); - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) + - to_long_double( arg2 ) ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); - break; - } - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) + - to_long_double( arg2 ) ); - break; - default: - result = exceptionp( arg2 ) ? arg2 : - throw_exception( c_string_to_lisp_symbol( L"+" ), - c_string_to_lisp_string - ( L"Cannot add: not a number" ), - frame_pointer ); - } - } - - debug_print( L"}; => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - -/** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer, ratio or real. - * @exception if any argument is not a number, returns an exception. - */ -struct cons_pointer lisp_add( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - struct cons_pointer result = make_integer( 0, NIL ); - struct cons_pointer tmp; - - for ( int i = 0; - i < args_in_frame && - !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { - tmp = result; - result = add_2( frame, frame_pointer, result, frame->arg[i] ); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - } - - struct cons_pointer more = frame->more; - while ( consp( more ) && !exceptionp( result ) ) { - tmp = result; - result = add_2( frame, frame_pointer, result, c_car( more ) ); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - - more = c_cdr( more ); - } - - return result; -} - - -/** - * return a cons_pointer indicating a number which is the product of - * the numbers indicated by `arg1` and `arg2`. - */ -struct cons_pointer multiply_2( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer result; - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - - debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")\n", DEBUG_ARITH ); - - if ( zerop( arg1 ) ) { - result = arg2; - } else if ( zerop( arg2 ) ) { - result = arg1; - } else { - switch ( cell1.tag.value ) { - case EXCEPTIONTV: - result = arg1; - break; - case INTEGERTV: - switch ( cell2.tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV: - result = multiply_integers( arg1, arg2 ); - break; - case RATIOTV: - result = multiply_integer_ratio( arg1, arg2 ); - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) * - to_long_double( arg2 ) ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons - ( c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number: " ), - c_type( arg2 ) ), - frame_pointer ); - break; - } - break; - case RATIOTV: - switch ( cell2.tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV: - result = multiply_integer_ratio( arg2, arg1 ); - break; - case RATIOTV: - result = multiply_ratio_ratio( arg1, arg2 ); - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) * - to_long_double( arg2 ) ); - break; - default: - result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons - ( c_string_to_lisp_string - ( L"Cannot multiply: argument 2 is not a number" ), - c_type( arg2 ) ), - frame_pointer ); - } - break; - case REALTV: - result = exceptionp( arg2 ) ? arg2 : - make_real( to_long_double( arg1 ) * - to_long_double( arg2 ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"*" ), - make_cons( c_string_to_lisp_string - ( L"Cannot multiply: argument 1 is not a number" ), - c_type( arg1 ) ), - frame_pointer ); - break; - } - } - - debug_print( L"multiply_2 returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - -#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}} - -/** - * Multiply an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer, ratio or real. - * @exception if any argument is not a number, returns an exception. - */ -struct cons_pointer lisp_multiply( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - struct cons_pointer result = make_integer( 1, NIL ); - struct cons_pointer tmp; - - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) - && !exceptionp( result ); i++ ) { - debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"; arg = ", DEBUG_ARITH ); - debug_print_object( frame->arg[i], DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - multiply_one_arg( frame->arg[i] ); - } - - struct cons_pointer more = frame->more; - while ( consp( more ) - && !exceptionp( result ) ) { - multiply_one_arg( c_car( more ) ); - more = c_cdr( more ); - } - - debug_print( L"lisp_multiply returning: ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_println( DEBUG_ARITH ); - - return result; -} - -/** - * return a cons_pointer indicating a number which is the - * 0 - the number indicated by `arg`. - */ -struct cons_pointer negative( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case EXCEPTIONTV: - result = arg; - break; - case INTEGERTV: - result = - make_integer( 0 - cell.payload.integer.value, - cell.payload.integer.more ); - break; - case NILTV: - result = TRUE; - break; - case RATIOTV: - result = make_ratio( negative( cell.payload.ratio.dividend ), - cell.payload.ratio.divisor, false ); - break; - case REALTV: - result = make_real( 0 - to_long_double( arg ) ); - break; - case TRUETV: - result = NIL; - break; - } - - return result; -} - - -/** - * Function: is this number negative? - * - * * (negative? arg) - * - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return T if the first argument was a negative number, or NIL if it - * was not. - */ -struct cons_pointer lisp_is_negative( struct stack_frame - *frame, - struct cons_pointer frame_pointer, struct - cons_pointer env ) { - return is_negative( frame->arg[0] ) ? TRUE : NIL; -} - - -/** - * return a cons_pointer indicating a number which is the result of - * subtracting the number indicated by `arg2` from that indicated by `arg1`, - * in the context of this `frame`. - */ -struct cons_pointer subtract_2( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer result = NIL; - - switch ( pointer2cell( arg1 ).tag.value ) { - case EXCEPTIONTV: - result = arg1; - break; - case INTEGERTV: - switch ( pointer2cell( arg2 ).tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV:{ - struct cons_pointer i = negative( arg2 ); - inc_ref( i ); - result = add_integers( arg1, i ); - dec_ref( i ); - } - break; - case RATIOTV:{ - struct cons_pointer tmp = make_ratio( arg1, - make_integer( 1, - NIL ), - false ); - inc_ref( tmp ); - result = subtract_ratio_ratio( tmp, arg2 ); - dec_ref( tmp ); - } - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) - - to_long_double( arg2 ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string - ( L"Cannot subtract: not a number" ), - frame_pointer ); - break; - } - break; - case RATIOTV: - switch ( pointer2cell( arg2 ).tag.value ) { - case EXCEPTIONTV: - result = arg2; - break; - case INTEGERTV:{ - struct cons_pointer tmp = make_ratio( arg2, - make_integer( 1, - NIL ), - false ); - inc_ref( tmp ); - result = subtract_ratio_ratio( arg1, tmp ); - dec_ref( tmp ); - } - break; - case RATIOTV: - result = subtract_ratio_ratio( arg1, arg2 ); - break; - case REALTV: - result = - make_real( to_long_double( arg1 ) - - to_long_double( arg2 ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string - ( L"Cannot subtract: not a number" ), - frame_pointer ); - break; - } - break; - case REALTV: - result = exceptionp( arg2 ) ? arg2 : - make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"-" ), - c_string_to_lisp_string - ( L"Cannot subtract: not a number" ), - frame_pointer ); - break; - } - - // and if not nilp[frame->arg[2]) we also have an error. - - return result; -} - -/** - * Subtract one number from another. If more than two arguments are passed - * in the frame, the additional arguments are ignored. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer, ratio or real. - * @exception if either argument is not a number, returns an exception. - */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] ); -} - -/** - * Divide one number by another. If more than two arguments are passed - * in the frame, the additional arguments are ignored. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - * @exception if either argument is not a number, returns an exception. - */ -struct cons_pointer lisp_divide( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); - struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - - switch ( arg0.tag.value ) { - case EXCEPTIONTV: - result = frame->arg[0]; - break; - case INTEGERTV: - switch ( arg1.tag.value ) { - case EXCEPTIONTV: - result = frame->arg[1]; - break; - case INTEGERTV:{ - result = - make_ratio( frame->arg[0], frame->arg[1], true ); - } - break; - case RATIOTV:{ - struct cons_pointer one = make_integer( 1, NIL ); - struct cons_pointer ratio = - make_ratio( frame->arg[0], one, false ); - inc_ref( ratio ); - result = divide_ratio_ratio( ratio, frame->arg[1] ); - dec_ref( ratio ); - } - break; - case REALTV: - result = - make_real( to_long_double( frame->arg[0] ) / - to_long_double( frame->arg[1] ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string - ( L"Cannot divide: not a number" ), - frame_pointer ); - break; - } - break; - case RATIOTV: - switch ( arg1.tag.value ) { - case EXCEPTIONTV: - result = frame->arg[1]; - break; - case INTEGERTV:{ - struct cons_pointer one = make_integer( 1, NIL ); - struct cons_pointer ratio = - make_ratio( frame->arg[1], one, false ); - result = divide_ratio_ratio( frame->arg[0], ratio ); - dec_ref( ratio ); - dec_ref( one ); - } - break; - case RATIOTV: - result = - divide_ratio_ratio( frame->arg[0], frame->arg[1] ); - break; - case REALTV: - result = - make_real( to_long_double( frame->arg[0] ) / - to_long_double( frame->arg[1] ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string - ( L"Cannot divide: not a number" ), - frame_pointer ); - break; - } - break; - case REALTV: - result = exceptionp( frame->arg[1] ) ? frame->arg[1] : - make_real( to_long_double( frame->arg[0] ) / - to_long_double( frame->arg[1] ) ); - break; - default: - result = throw_exception( c_string_to_lisp_symbol( L"/" ), - c_string_to_lisp_string - ( L"Cannot divide: not a number" ), - frame_pointer ); - break; - } - - return result; -} - -/** - * @brief Function: return a real (approcimately) equal in value to the ratio - * which is the first argument. - * - * @param frame - * @param frame_pointer - * @param env - * @return struct cons_pointer a pointer to a real - */ -// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, -// struct cons_pointer env ) -struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer rat = frame->arg[0]; - - debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH ); - debug_print_object( rat, DEBUG_ARITH ); - - if ( ratiop( rat ) ) { - result = make_real( c_ratio_to_ld( rat ) ); - } // TODO: else throw an exception? - - return result; -} diff --git a/archive/c/arith/peano.h b/archive/c/arith/peano.h deleted file mode 100644 index c85a9d8..0000000 --- a/archive/c/arith/peano.h +++ /dev/null @@ -1,95 +0,0 @@ -/* - * peano.h - * - * Basic peano arithmetic - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - - -#ifndef PEANO_H -#define PEANO_H - -#include "memory/consspaceobject.h" - -/** - * The maximum value we will allow in an integer cell: one less than 2^60: - * (let ((s (make-string-output-stream))) - * (format s "0x0~XL" (- (expt 2 60) 1)) - * (string-downcase (get-output-stream-string s))) - * "0x0fffffffffffffffl" - * - * So left shifting and right shifting by 60 bits is correct. - */ -#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) -#define INT_CELL_BASE ((__int128_t)MAX_INTEGER + 1) // ((__int128_t)0x1000000000000000L) - -/** - * @brief Number of value bits in an integer cell - * - */ -#define INTEGER_BIT_SHIFT (60) - -/** - * @brief return `true` if arg is `nil`, else `false`. - * - * Note that this doesn't really belong in `peano.h`, but after code cleanup it - * was the last thing remaining in either `boolean.c` or `boolean.h`, and it - * wasn't worth keeping two files around for one one-line macro. - * - * @param arg - * @return true if the sole argument is `nil`. - * @return false otherwise. - */ -#define truthy(arg)(!nilp(arg)) - -bool zerop( struct cons_pointer arg ); - -struct cons_pointer negative( struct cons_pointer arg ); - -bool is_negative( struct cons_pointer arg ); - -struct cons_pointer absolute( struct cons_pointer arg ); - -long double to_long_double( struct cons_pointer arg ); - -int64_t to_long_int( struct cons_pointer arg ); - -struct cons_pointer lisp_absolute( struct stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ); - -struct cons_pointer -lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_is_negative( struct stack_frame - *frame, - struct cons_pointer frame_pointer, struct - cons_pointer env ); - -struct cons_pointer -lisp_multiply( struct stack_frame *frame, - struct cons_pointer frame_pointer, struct cons_pointer env ); - -struct cons_pointer negative( struct cons_pointer arg ); - -struct cons_pointer subtract_2( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer arg1, - struct cons_pointer arg2 ); - -struct cons_pointer -lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, struct cons_pointer env ); - -struct cons_pointer -lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -#endif /* PEANO_H */ diff --git a/archive/c/arith/ratio.c b/archive/c/arith/ratio.c deleted file mode 100644 index 82f9138..0000000 --- a/archive/c/arith/ratio.c +++ /dev/null @@ -1,411 +0,0 @@ -/* - * ratio.c - * - * functions for rational number cells. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define _GNU_SOURCE -#include -#include - -#include "arith/integer.h" -#include "arith/peano.h" -#include "arith/ratio.h" -#include "arith/real.h" -#include "debug.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/stack.h" -#include "ops/equal.h" -#include "ops/lispops.h" - - -/** - * @brief return, as an int64_t, the greatest common divisor of `m` and `n`, - */ -int64_t greatest_common_divisor( int64_t m, int64_t n ) { - int o; - while ( m ) { - o = m; - m = n % m; - n = o; - } - - return o; -} - -/** - * @brief return, as an int64_t, the least common multiple of `m` and `n`, - */ -int64_t least_common_multiple( int64_t m, int64_t n ) { - return m / greatest_common_divisor( m, n ) * n; -} - -struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { - struct cons_pointer result = pointer; - - if ( ratiop( pointer ) ) { - struct cons_space_object cell = pointer2cell( pointer ); - struct cons_space_object dividend = - pointer2cell( cell.payload.ratio.dividend ); - struct cons_space_object divisor = - pointer2cell( cell.payload.ratio.divisor ); - - if ( divisor.payload.integer.value == 1 ) { - result = pointer2cell( pointer ).payload.ratio.dividend; - } else { - int64_t ddrv = dividend.payload.integer.value, - drrv = divisor.payload.integer.value, - gcd = greatest_common_divisor( ddrv, drrv ); - - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = - acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL ); - } else { - debug_printf( DEBUG_ARITH, - L"simplify_ratio: %ld/%ld => %ld/%ld\n", - ddrv, drrv, ddrv / gcd, drrv / gcd ); - result = - make_ratio( acquire_integer( ddrv / gcd, NIL ), - acquire_integer( drrv / gcd, NIL ), - false ); - } - } - } - } - // TODO: else throw exception? - - return result; - -} - - -/** - * return a cons_pointer indicating a number which is the sum of - * the ratios indicated by `arg1` and `arg2`. - * @exception will return an exception if either `arg1` or `arg2` is not a - * rational number. - */ -struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ) { - struct cons_pointer r; - - debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L" + ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - - if ( ratiop( arg1 ) && ratiop( arg2 ) ) { - struct cons_space_object *cell1 = &pointer2cell( arg1 ); - struct cons_space_object *cell2 = &pointer2cell( arg2 ); - - struct cons_pointer divisor = - multiply_integers( cell1->payload.ratio.divisor, - cell2->payload.ratio.divisor ); - struct cons_pointer dividend = - add_integers( multiply_integers( cell1->payload.ratio.dividend, - cell2->payload.ratio.divisor ), - multiply_integers( cell2->payload.ratio.dividend, - cell1->payload.ratio.divisor ) ); - r = make_ratio( dividend, divisor, true ); - } else { - r = throw_exception( c_string_to_lisp_symbol( L"+" ), - make_cons( c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), - make_cons( arg1, - make_cons( arg2, NIL ) ) ), - NIL ); - } - - debug_print( L"add_ratio_ratio => ", DEBUG_ARITH ); - debug_print_object( r, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return r; -} - - -/** - * return a cons_pointer indicating a number which is the sum of - * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. - * @exception if either `intarg` or `ratarg` is not of the expected type. - */ -struct cons_pointer add_integer_ratio( struct cons_pointer intarg, - struct cons_pointer ratarg ) { - struct cons_pointer result; - - debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH ); - debug_print_object( intarg, DEBUG_ARITH ); - debug_print( L" + ", DEBUG_ARITH ); - debug_print_object( ratarg, DEBUG_ARITH ); - - if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = acquire_integer( 1, NIL ), - ratio = make_ratio( intarg, one, false ); - - result = add_ratio_ratio( ratio, ratarg ); - - release_integer( one ); - dec_ref( ratio ); - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"+" ), - make_cons( c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to add_integer_ratio" ), - make_cons( intarg, - make_cons( ratarg, - NIL ) ) ), NIL ); - } - - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - -/** - * return a cons_pointer to a ratio which represents the value of the ratio - * indicated by `arg1` divided by the ratio indicated by `arg2`. - * @exception will return an exception if either `arg1` or `arg2` is not a - * rational number. - */ -struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ) { - debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L" / ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - // TODO: this now has to work if `arg1` is an integer - struct cons_pointer i = - make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, - pointer2cell( arg2 ).payload.ratio.dividend, false ), - result = multiply_ratio_ratio( arg1, i ); - - dec_ref( i ); - - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - -/** - * return a cons_pointer indicating a number which is the product of - * the ratios indicated by `arg1` and `arg2`. - * @exception will return an exception if either `arg1` or `arg2` is not a - * rational number. - */ -struct cons_pointer multiply_ratio_ratio( struct - cons_pointer arg1, struct - cons_pointer arg2 ) { - // TODO: this now has to work if arg1 is an integer - struct cons_pointer result; - - debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")\n", DEBUG_ARITH ); - - if ( ratiop( arg1 ) && ratiop( arg2 ) ) { - struct cons_space_object cell1 = pointer2cell( arg1 ); - struct cons_space_object cell2 = pointer2cell( arg2 ); - int64_t dd1v = - pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, - dd2v = - pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, - dr1v = - pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, - dr2v = - pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, - ddrv = dd1v * dd2v, drrv = dr1v * dr2v; - - struct cons_pointer dividend = acquire_integer( ddrv, NIL ); - struct cons_pointer divisor = acquire_integer( drrv, NIL ); - result = make_ratio( dividend, divisor, true ); - - release_integer( dividend ); - release_integer( divisor ); - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), - NIL ); - } - - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - -/** - * return a cons_pointer indicating a number which is the product of - * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. - * @exception if either `intarg` or `ratarg` is not of the expected type. - */ -struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, - struct cons_pointer ratarg ) { - struct cons_pointer result; - - debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH ); - debug_print_object( intarg, DEBUG_ARITH ); - debug_print( L" * ", DEBUG_ARITH ); - debug_print_object( ratarg, DEBUG_ARITH ); - - if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = acquire_integer( 1, NIL ), - ratio = make_ratio( intarg, one, false ); - result = multiply_ratio_ratio( ratio, ratarg ); - - release_integer( one ); - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"*" ), - c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), - NIL ); - } - - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( result, DEBUG_ARITH ); - debug_print( L"\n", DEBUG_ARITH ); - - return result; -} - - -/** - * return a cons_pointer indicating a number which is the difference of - * the ratios indicated by `arg1` and `arg2`. - * @exception will return an exception if either `arg1` or `arg2` is not a - * rational number. - */ -struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ) { - debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L" * ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - - struct cons_pointer i = negative( arg2 ), - result = add_ratio_ratio( arg1, i ); - - dec_ref( i ); - - return result; -} - - -/** - * Construct a ratio frame from this `dividend` and `divisor`, expected to - * be integers, in the context of the stack_frame indicated by this - * `frame_pointer`. - * @exception if either `dividend` or `divisor` is not an integer. - */ -struct cons_pointer make_ratio( struct cons_pointer dividend, - struct cons_pointer divisor, bool simplify ) { - debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC ); - debug_print_object( dividend, DEBUG_ALLOC ); - debug_print( L"; divisor = ", DEBUG_ALLOC ); - debug_print_object( divisor, DEBUG_ALLOC ); - debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify ); - - struct cons_pointer result; - if ( integerp( dividend ) && integerp( divisor ) ) { - inc_ref( dividend ); - inc_ref( divisor ); - struct cons_pointer unsimplified = allocate_cell( RATIOTV ); - struct cons_space_object *cell = &pointer2cell( unsimplified ); - cell->payload.ratio.dividend = dividend; - cell->payload.ratio.divisor = divisor; - - if ( simplify ) { - result = simplify_ratio( unsimplified ); - if ( !eq( result, unsimplified ) ) { - dec_ref( unsimplified ); - } - } else { - result = unsimplified; - } - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"make_ratio" ), - c_string_to_lisp_string - ( L"Dividend and divisor of a ratio must be integers" ), - NIL ); - } - debug_print( L" => ", DEBUG_ALLOC ); - debug_print_object( result, DEBUG_ALLOC ); - debug_println( DEBUG_ALLOC ); - - return result; -} - -/** - * True if a and be are identical rationals, else false. - * - * TODO: we need ways of checking whether rationals are equal - * to floats and to integers. - */ -bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - if ( ratiop( a ) && ratiop( b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - result = equal_integer_integer( cell_a->payload.ratio.dividend, - cell_b->payload.ratio.dividend ) && - equal_integer_integer( cell_a->payload.ratio.divisor, - cell_b->payload.ratio.divisor ); - } - - return result; -} - -/** - * @brief convert a ratio to an equivalent long double. - * - * @param rat a pointer to a ratio. - * @return long double - */ -long double c_ratio_to_ld( struct cons_pointer rat ) { - long double result = NAN; - - debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH ); - debug_print_object( rat, DEBUG_ARITH ); - - if ( ratiop( rat ) ) { - struct cons_space_object *cell_a = &pointer2cell( rat ); - struct cons_pointer dv = cell_a->payload.ratio.divisor; - struct cons_space_object *dv_cell = &pointer2cell( dv ); - struct cons_pointer dd = cell_a->payload.ratio.dividend; - struct cons_space_object *dd_cell = &pointer2cell( dd ); - - if ( nilp( dv_cell->payload.integer.more ) - && nilp( dd_cell->payload.integer.more ) ) { - result = - ( ( long double ) dd_cell->payload.integer.value ) / - ( ( long double ) dv_cell->payload.integer.value );; - } else { - fwprintf( stderr, - L"real conversion is not yet implemented for bignums rationals." ); - } - } - - debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result ); - - return result; -} diff --git a/archive/c/arith/ratio.h b/archive/c/arith/ratio.h deleted file mode 100644 index 2e39754..0000000 --- a/archive/c/arith/ratio.h +++ /dev/null @@ -1,41 +0,0 @@ -/** - * ratio.h - * - * functions for rational number cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __ratio_h -#define __ratio_h - -struct cons_pointer simplify_ratio( struct cons_pointer arg ); - -struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ); - -struct cons_pointer add_integer_ratio( struct cons_pointer intarg, - struct cons_pointer ratarg ); - -struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ); - -struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct - cons_pointer arg2 ); - -struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, - struct cons_pointer ratarg ); - -struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, - struct cons_pointer arg2 ); - -struct cons_pointer make_ratio( struct cons_pointer dividend, - struct cons_pointer divisor, bool simplify ); - -bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); - -long double c_ratio_to_ld( struct cons_pointer rat ); - -#endif diff --git a/archive/c/arith/real.c b/archive/c/arith/real.c deleted file mode 100644 index 34d29d0..0000000 --- a/archive/c/arith/real.c +++ /dev/null @@ -1,29 +0,0 @@ -/* - * real.c - * - * functions for real number cells. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "debug.h" -#include "io/read.h" - -/** - * Allocate a real number cell representing this value and return a cons - * pointer to it. - * @param value the value to wrap; - * @return a real number cell wrapping this value. - */ -struct cons_pointer make_real( long double value ) { - struct cons_pointer result = allocate_cell( REALTV ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.real.value = value; - - debug_dump_object( result, DEBUG_ARITH ); - - return result; -} diff --git a/archive/c/arith/real.h b/archive/c/arith/real.h deleted file mode 100644 index 6e4ed53..0000000 --- a/archive/c/arith/real.h +++ /dev/null @@ -1,32 +0,0 @@ -/* - * To change this license header, choose License Headers in Project Properties. - * To change this template file, choose Tools | Templates - * and open the template in the editor. - */ - -/* - * File: real.h - * Author: simon - * - * Created on 14 August 2017, 17:25 - */ - -#ifndef REAL_H -#define REAL_H - -#ifdef __cplusplus -extern "C" { -#endif - -/** - * Allocate a real number cell representing this value and return a cons - * pointer to it. - * @param value the value to wrap; - * @return a real number cell wrapping this value. - */ - struct cons_pointer make_real( long double value ); - -#ifdef __cplusplus -} -#endif -#endif /* REAL_H */ diff --git a/archive/c/authorise.c b/archive/c/authorise.c deleted file mode 100644 index afd730d..0000000 --- a/archive/c/authorise.c +++ /dev/null @@ -1,24 +0,0 @@ -/* - * authorised.c - * - * For now, a dummy authorising everything. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" - - -/** - * TODO: does nothing, yet. What it should do is access a magic value in the - * runtime environment and check that it is identical to something on this `acl` - */ -struct cons_pointer authorised( struct cons_pointer target, - struct cons_pointer acl ) { - if ( nilp( acl ) ) { - acl = pointer2cell( target ).access; - } - return TRUE; -} diff --git a/archive/c/authorise.h b/archive/c/authorise.h deleted file mode 100644 index 6c55b32..0000000 --- a/archive/c/authorise.h +++ /dev/null @@ -1,16 +0,0 @@ -/* - * authorise.h - * - * Basic implementation of a authorisation. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_authorise_h -#define __psse_authorise_h - -struct cons_pointer authorised( struct cons_pointer target, - struct cons_pointer acl ); - -#endif diff --git a/archive/c/debug.c b/archive/c/debug.c deleted file mode 100644 index 3df7dc1..0000000 --- a/archive/c/debug.c +++ /dev/null @@ -1,181 +0,0 @@ -/* - * debug.c - * - * Better debug log messages. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "memory/consspaceobject.h" -#include "debug.h" -#include "memory/dump.h" -#include "io/io.h" -#include "io/print.h" - -/** - * @brief the controlling flags for `debug_print`; set in `init.c`, q.v. - * - * Interpreted as a set o binary flags. The values are controlled by macros - * with names 'DEBUG_[A_Z]*' in `debug.h`, q.v. - */ -int verbosity = 0; - -/** - * When debugging, we want to see exceptions as they happen, because they may - * not make their way back down the stack to whatever is expected to handle - * them. - */ -void debug_print_exception( struct cons_pointer ex_ptr ) { -#ifdef DEBUG - if ( ( verbosity != 0 ) && exceptionp( ex_ptr ) ) { - fwide( stderr, 1 ); - fputws( L"EXCEPTION: ", stderr ); - - URL_FILE *ustderr = file_to_url_file( stderr ); - fwide( stderr, 1 ); - print( ustderr, ex_ptr ); - free( ustderr ); - } -#endif -} - -/** - * @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. - */ -void debug_print( char32_t *message, int level ) { -#ifdef DEBUG - if ( level & verbosity ) { - fwide( stderr, 1 ); - 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 - */ -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. - */ -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`. - */ -void debug_printf( int level, char32_t *format, ... ) { -#ifdef DEBUG - if ( level & verbosity ) { - fwide( stderr, 1 ); - va_list( args ); - va_start( args, format ); - vfwprintf( stderr, format, args ); - } -#endif -} - -/** - * @brief print the object indicated by this `pointer` 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. - */ -void debug_print_object( struct cons_pointer pointer, int level ) { -#ifdef DEBUG - if ( level & verbosity ) { - URL_FILE *ustderr = file_to_url_file( stderr ); - fwide( stderr, 1 ); - print( ustderr, pointer ); - free( ustderr ); - } -#endif -} - -/** - * @brief Like `dump_object`, q.v., but protected by the verbosity mechanism. - * - * `verbosity` is a set of flags, see debug_print.h; so you can - * turn debugging on for only one part of the system. - */ -void debug_dump_object( struct cons_pointer pointer, int level ) { -#ifdef DEBUG - if ( level & verbosity ) { - URL_FILE *ustderr = file_to_url_file( stderr ); - fwide( stderr, 1 ); - dump_object( ustderr, pointer ); - free( ustderr ); - } -#endif -} - -/** - * Standardise printing of binding trace messages. - */ -void debug_print_binding( struct cons_pointer key, struct cons_pointer val, - bool deep, int level ) { -#ifdef DEBUG - // char32_t * depth = (deep ? L"Deep" : L"Shallow"); - - debug_print( ( deep ? L"Deep" : L"Shallow" ), level ); - debug_print( L" binding `", level ); - debug_print_object( key, level ); - debug_print( L"` to `", level ); - debug_print_object( val, level ); - debug_print( L"`\n", level ); -#endif -} diff --git a/archive/c/debug.h b/archive/c/debug.h deleted file mode 100644 index cccf3ff..0000000 --- a/archive/c/debug.h +++ /dev/null @@ -1,101 +0,0 @@ -/* - * debug.h - * - * Better debug log messages. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include - -#include "memory/consspaceobject.h" - -#ifndef __debug_print_h -#define __debug_print_h - -/** - * @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 - -extern int verbosity; - -void debug_print_exception( struct cons_pointer ex_ptr ); -void debug_print( char32_t *message, int level ); -void debug_print_128bit( __int128_t n, int level ); -void debug_println( int level ); -void debug_printf( int level, char32_t *format, ... ); -void debug_print_object( struct cons_pointer pointer, int level ); -void debug_dump_object( struct cons_pointer pointer, int level ); -void debug_print_binding( struct cons_pointer key, struct cons_pointer val, - bool deep, int level ); - -#endif diff --git a/archive/c/init.c b/archive/c/init.c deleted file mode 100644 index fbfdb2f..0000000 --- a/archive/c/init.c +++ /dev/null @@ -1,564 +0,0 @@ -/* - * init.c - * - * Start up and initialise the environement - just enough to get working - * and (ultimately) hand off to the executive. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include -#include - -/* libcurl, used for io */ -#include - -#include "arith/peano.h" -#include "arith/ratio.h" -#include "debug.h" -#include "io/fopen.h" -#include "io/io.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/hashmap.h" -#include "memory/stack.h" -#include "ops/intern.h" -#include "ops/lispops.h" -#include "ops/meta.h" -#include "repl.h" -#include "time/psse_time.h" -#include "version.h" - -/** - * @brief If `pointer` is an exception, display that exception to stderr, - * decrement that exception, and return NIL; else return the pointer. - * - * @param pointer a cons pointer. - * @param location_descriptor a description of where the pointer was caught. - * @return struct cons_pointer - */ -struct cons_pointer check_exception( struct cons_pointer pointer, - char *location_descriptor ) { - struct cons_pointer result = pointer; - - if ( exceptionp( pointer ) ) { - struct cons_space_object *object = &pointer2cell( pointer ); - result = NIL; - - fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor ); - URL_FILE *ustderr = file_to_url_file( stderr ); - fwide( stderr, 1 ); - c_print( ustderr, object->payload.exception.payload ); - free( ustderr ); - - dec_ref( pointer ); - } - - return result; -} - -void maybe_bind_init_symbols( ) { - if ( nilp( privileged_keyword_documentation ) ) { - privileged_keyword_documentation = - c_string_to_lisp_keyword( L"documentation" ); - } - if ( nilp( privileged_keyword_name ) ) { - privileged_keyword_name = c_string_to_lisp_keyword( L"name" ); - } - if ( nilp( privileged_keyword_primitive ) ) { - privileged_keyword_primitive = - c_string_to_lisp_keyword( L"primitive" ); - } - if ( nilp( privileged_symbol_nil ) ) { - privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" ); - } - // we can't make this string when we need it, because memory is then - // exhausted! - if ( nilp( privileged_string_memory_exhausted ) ) { - privileged_string_memory_exhausted = - c_string_to_lisp_string( L"Memory exhausted." ); - } - if ( nilp( privileged_keyword_location ) ) { - privileged_keyword_location = c_string_to_lisp_keyword( L"location" ); - } - if ( nilp( privileged_keyword_payload ) ) { - privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" ); - } - if ( nilp( privileged_keyword_cause ) ) { - privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" ); - } -} - -void free_init_symbols( ) { - dec_ref( privileged_keyword_documentation ); - dec_ref( privileged_keyword_name ); - dec_ref( privileged_keyword_primitive ); -} - -/** - * Bind this compiled `executable` function, as a Lisp function, to - * this name in the `oblist`. - * \todo where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. - */ -struct cons_pointer bind_function( char32_t *name, - char32_t *doc, - struct cons_pointer ( *executable ) - ( struct stack_frame *, - struct cons_pointer, - struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - struct cons_pointer d = c_string_to_lisp_string( doc ); - - struct cons_pointer meta = - make_cons( make_cons( privileged_keyword_primitive, TRUE ), - make_cons( make_cons( privileged_keyword_name, n ), - make_cons( make_cons - ( privileged_keyword_documentation, - d ), - NIL ) ) ); - - struct cons_pointer r = - check_exception( deep_bind( n, make_function( meta, executable ) ), - "bind_function" ); - - dec_ref( n ); - dec_ref( d ); - - return r; -} - -/** - * Bind this compiled `executable` function, as a Lisp special form, to - * this `name` in the `oblist`. - */ -struct cons_pointer bind_special( char32_t *name, - char32_t *doc, - struct cons_pointer ( *executable ) - ( struct stack_frame *, struct cons_pointer, - struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - struct cons_pointer d = c_string_to_lisp_string( doc ); - - struct cons_pointer meta = - make_cons( make_cons( privileged_keyword_primitive, TRUE ), - make_cons( make_cons( privileged_keyword_name, n ), - make_cons( make_cons - ( privileged_keyword_documentation, - d ), - NIL ) ) ); - - struct cons_pointer r = - check_exception( deep_bind( n, make_special( meta, executable ) ), - "bind_special" ); - - dec_ref( n ); - dec_ref( d ); - - return r; -} - -/** - * Bind this `value` to this `symbol` in the `oblist`. - */ -struct cons_pointer -bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value, - bool lock ) { - struct cons_pointer r = check_exception( deep_bind( symbol, value ), - "bind_symbol_value" ); - - if ( lock && !exceptionp( r ) ) { - struct cons_space_object *cell = &pointer2cell( r ); - - cell->count = UINT32_MAX; - } - - return r; -} - -/** - * Bind this `value` to this `name` in the `oblist`. - */ -struct cons_pointer bind_value( char32_t *name, struct cons_pointer value, - bool lock ) { - struct cons_pointer p = c_string_to_lisp_symbol( name ); - - struct cons_pointer r = bind_symbol_value( p, value, lock ); - - dec_ref( p ); - - return r; -} - -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_cons_pages( ); - - maybe_bind_init_symbols( ); - - - if ( show_prompt ) { - print_banner( ); - } - - debug_print( L"About to initialise oblist\n", DEBUG_BOOTSTRAP ); - - oblist = make_hashmap( 32, NIL, TRUE ); - - debug_print( L"About to bind\n", DEBUG_BOOTSTRAP ); - - /* - * privileged variables (keywords) - */ - bind_symbol_value( privileged_symbol_nil, NIL, true ); - bind_value( L"t", TRUE, true ); - bind_symbol_value( privileged_keyword_location, TRUE, true ); - bind_symbol_value( privileged_keyword_payload, TRUE, true ); - - /* - * standard input, output, error and sink streams - * attempt to set wide character acceptance on all streams - */ - URL_FILE *sink = url_fopen( "/dev/null", "w" ); - fwide( stdin, 1 ); - fwide( stdout, 1 ); - fwide( stderr, 1 ); - fwide( sink->handle.file, 1 ); - - FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r" ); - - - lisp_io_in = - bind_value( C_IO_IN, - make_read_stream( file_to_url_file( infile ), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - NIL ) ), false ); - lisp_io_out = - bind_value( C_IO_OUT, - make_write_stream( file_to_url_file( stdout ), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard output" ) ), - NIL ) ), false ); - bind_value( L"*log*", - make_write_stream( file_to_url_file( stderr ), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard log" ) ), - NIL ) ), false ); - bind_value( L"*sink*", - make_write_stream( sink, - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard sink" ) ), - NIL ) ), false ); - /* - * the default prompt - */ - prompt_name = bind_value( L"*prompt*", - show_prompt ? c_string_to_lisp_symbol( L":: " ) : - NIL, false ); - /* - * primitive function operations - */ - /* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system. - * HTTP from an address at journeyman? */ - bind_function( L"absolute", - L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.", - &lisp_absolute ); - bind_function( L"add", - L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.", - &lisp_add ); - bind_function( L"and", - L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.", - &lisp_and ); - bind_function( L"append", - L"`(append args...)`: If args are all collections, return the concatenation of those collections.", - &lisp_append ); - bind_function( L"apply", - L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.", - &lisp_apply ); - bind_function( L"assoc", - L"`(assoc key store)`: Return the value associated with this `key` in this `store`.", - &lisp_assoc ); - bind_function( L"car", - L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.", - &lisp_car ); - bind_function( L"cdr", - L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.", - &lisp_cdr ); - bind_function( L"close", - L"`(close stream)`: If `stream` is a stream, close that stream.", - &lisp_close ); - bind_function( L"cons", - L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.", - &lisp_cons ); - bind_function( L"count", - L"`(count s)`: Return the number of items in the sequence `s`.", - &lisp_count ); - bind_function( L"divide", - L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.", - &lisp_divide ); - bind_function( L"eq?", - L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.", - &lisp_eq ); - bind_function( L"equal?", - L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", - &lisp_equal ); - bind_function( L"eval", L"", &lisp_eval ); - bind_function( L"exception", - L"`(exception message)`: Return (throw) an exception with this `message`.", - &lisp_exception ); - bind_function( L"get-hash", - L"`(get-hash arg)`: returns the natural number hash value of `arg`.", - &lisp_get_hash ); - bind_function( L"hashmap", - L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.", - lisp_make_hashmap ); - bind_function( L"inspect", - L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.", - &lisp_inspect ); - bind_function( L"interned?", - L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.", - &lisp_internedp ); - bind_function( L"keys", - L"`(keys store)`: Return a list of all keys in this `store`.", - &lisp_keys ); - bind_function( L"list", - L"`(list args...)`: Return a list of these `args`.", - &lisp_list ); - bind_function( L"mapcar", - L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", - &lisp_mapcar ); - bind_function( L"meta", - L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", - &lisp_metadata ); - bind_function( L"metadata", - L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", - &lisp_metadata ); - bind_function( L"multiply", - L"`(* args...)` Multiply these `args`, all of which should be numbers.", - &lisp_multiply ); - bind_function( L"negative?", - L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.", - &lisp_is_negative ); - bind_function( L"not", - L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.", - &lisp_not ); - bind_function( L"oblist", - L"`(oblist)`: Return the current symbol bindings, as a map.", - &lisp_oblist ); - bind_function( L"open", - L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.", - &lisp_open ); - bind_function( L"or", - L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.", - &lisp_or ); - bind_function( L"print", - L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.", - &lisp_print ); - bind_function( L"println", - L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.", - &lisp_println ); - bind_function( L"put!", L"", lisp_hashmap_put ); - bind_function( L"put-all!", - L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.", - &lisp_hashmap_put_all ); - bind_function( L"ratio->real", - L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.", - &lisp_ratio_to_real ); - bind_function( L"read", - L"`(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.", - &lisp_read ); - bind_function( L"read-char", - L"`(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.", - &lisp_read_char ); - bind_function( L"repl", - L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.", - &lisp_repl ); - bind_function( L"reverse", - L"`(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.", - &lisp_reverse ); - bind_function( L"set", L"", &lisp_set ); - bind_function( L"slurp", - L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.", - &lisp_slurp ); - bind_function( L"source", - L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.", - &lisp_source ); - bind_function( L"subtract", - L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.", - &lisp_subtract ); - bind_function( L"throw", - L"`(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).", - &lisp_exception ); - bind_function( L"time", - L"`(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.", - &lisp_time ); - bind_function( L"type", - L"`(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.", - &lisp_type ); - bind_function( L"+", - L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.", - &lisp_add ); - bind_function( L"*", - L"`(* args...)` Multiply these `args`, all of which should be numbers.", - &lisp_multiply ); - bind_function( L"-", - L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.", - &lisp_subtract ); - bind_function( L"/", - L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.", - &lisp_divide ); - bind_function( L"=", - L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", - &lisp_equal ); - /* - * primitive special forms - */ - bind_special( L"cond", - L"`(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.", - &lisp_cond ); - bind_special( L"lambda", - L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.", - &lisp_lambda ); - bind_special( L"\u03bb", L"", &lisp_lambda ); // λ - bind_special( L"let", - L"`(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.", - &lisp_let ); - bind_special( L"nlambda", - L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", - &lisp_nlambda ); - bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ - bind_special( L"progn", - L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.", - &lisp_progn ); - bind_special( L"quote", - L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.", - &lisp_quote ); - 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 ); - debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); - debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - - repl( show_prompt ); - - debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - - debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); - while ( ( pointer2cell( oblist ) ).count > 0 ) { - fprintf( stderr, "Dangling refs on oblist: %d\n", - ( pointer2cell( oblist ) ).count ); - dec_ref( oblist ); - } - - free_init_symbols( ); - - if ( dump_at_end ) { - dump_pages( file_to_url_file( stdout ) ); - } - - summarise_allocation( ); - curl_global_cleanup( ); - return ( 0 ); -} diff --git a/archive/c/io/fopen.c b/archive/c/io/fopen.c deleted file mode 100644 index bf918ec..0000000 --- a/archive/c/io/fopen.c +++ /dev/null @@ -1,526 +0,0 @@ -/* - * 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/consspaceobject.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/archive/c/io/fopen.h b/archive/c/io/fopen.h deleted file mode 100644 index 5f87bd2..0000000 --- a/archive/c/io/fopen.h +++ /dev/null @@ -1,83 +0,0 @@ -/* - * 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/archive/c/io/history.c b/archive/c/io/history.c deleted file mode 100644 index 417a6b1..0000000 --- a/archive/c/io/history.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * history.c - * - * Maintain, and recall, a history of things which have been read from standard - * input. Necessarily the history must be stored on the user session, and not be - * global. - * - * I *think* history will be maintained as a list of forms, not of strings, so - * only forms which have successfully been read can be recalled, and forms which - * have not been completed when the history function is invoked will be lost. - * - * (c) 2025 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/io/history.h b/archive/c/io/history.h deleted file mode 100644 index ffdd262..0000000 --- a/archive/c/io/history.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * history.h - * - * Maintain, and recall, a history of things which have been read from standard - * input. Necessarily the history must be stored on the user session, and not be - * global. - * - * I *think* history will be maintained as a list of forms, not of strings, so - * only forms which have successfully been read can be recalled, and forms which - * have not been completed when the history function is invoked will be lost. - * - * (c) 2025 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/archive/c/io/io.c b/archive/c/io/io.c deleted file mode 100644 index f8a400c..0000000 --- a/archive/c/io/io.c +++ /dev/null @@ -1,557 +0,0 @@ -/* - * 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/conspage.h" -#include "memory/consspaceobject.h" -#include "ops/intern.h" -#include "ops/lispops.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 cons_pointer lisp_io_in = NIL; -/** - * @brief bound to the Lisp string representing C_IO_OUT in initialisation. - */ -struct cons_pointer lisp_io_out = NIL; - - -/** - * 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 cons_pointer s ) { - char *result = NULL; - - if ( stringp( s ) || symbolp( s ) ) { - int len = 0; - - for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { - len++; - } - - char32_t *buffer = calloc( len + 1, sizeof( char32_t ) ); - /* worst case, one wide char = four utf bytes */ - result = calloc( ( len * 4 ) + 1, sizeof( char ) ); - - int i = 0; - for ( struct cons_pointer c = s; !nilp( c ); - c = pointer2cell( c ).payload.string.cdr ) { - buffer[i++] = pointer2cell( c ).payload.string.character; - } - - wcstombs( result, buffer, len ); - free( buffer ); - } - - debug_print( L"lisp_string_to_c_string( ", DEBUG_IO ); - debug_print_object( s, DEBUG_IO ); - debug_printf( DEBUG_IO, 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( char32_t ) + 2, sizeof( char ) ); - char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); - - size_t count = 0; - - debug_print( L"url_fgetwc: about to call url_fgets\n", - DEBUG_IO ); - url_fgets( cbuff, 2, input ); - debug_print( L"url_fgetwc: back from url_fgets\n", - DEBUG_IO ); - int c = ( int ) cbuff[0]; - // TODO: risk of reading off cbuff? - debug_printf( DEBUG_IO, - 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, 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 cons_pointer -lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) { - if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream ) - == 0 ) { - result = TRUE; - } - } - - return result; -} - -struct cons_pointer add_meta_integer( struct cons_pointer meta, char32_t *key, - long int value ) { - return - make_cons( make_cons - ( c_string_to_lisp_keyword( key ), - make_integer( value, NIL ) ), meta ); -} - -struct cons_pointer add_meta_string( struct cons_pointer meta, char32_t *key, - char *value ) { - value = trim( value ); - char32_t buffer[strlen( value ) + 1]; - mbstowcs( buffer, value, strlen( value ) + 1 ); - - return make_cons( make_cons( c_string_to_lisp_keyword( key ), - c_string_to_lisp_string( buffer ) ), meta ); -} - -struct cons_pointer add_meta_time( struct cons_pointer meta, char32_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 cons_pointer stream ) { - struct cons_space_object *cell = &pointer2cell( stream ); - - /* make a copy of the string that we can destructively change */ - char *s = calloc( strlen( string ), sizeof( char ) ); - - strcpy( s, string ); - - if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) || - strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) { - int offset = index_of( ':', s ); - - if ( offset != -1 ) { - s[offset] = ( char ) 0; - char *name = trim( s ); - char *value = trim( &s[++offset] ); - char32_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 strlen( string ); -} - -void collect_meta( struct cons_pointer stream, char *url ) { - struct cons_space_object *cell = &pointer2cell( stream ); - URL_FILE *s = pointer2cell( stream ).payload.stream.stream; - struct cons_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 cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_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 cons_pointer -lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - if ( stringp( frame->arg[0] ) ) { - char *url = lisp_string_to_c_string( frame->arg[0] ); - - if ( nilp( frame->arg[1] ) ) { - URL_FILE *stream = url_fopen( url, "r" ); - - debug_printf( DEBUG_IO, - 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 ); - break; - case CFTYPE_FILE: - if ( stream->handle.file == NULL ) { - return - make_exception( c_string_to_lisp_string - ( L"Could not open file" ), - frame_pointer ); - } - 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 ( pointer2cell( 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 cons_pointer -lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - if ( readp( frame->arg[0] ) ) { - result = - make_string( url_fgetwc - ( pointer2cell( frame->arg[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 cons_pointer -lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - - if ( readp( frame->arg[0] ) ) { - URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; - struct cons_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 ); - debug_dump_object( cursor, DEBUG_IO ); - debug_print( L"; result is: ", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - debug_println( DEBUG_IO ); - - struct cons_space_object *cell = &pointer2cell( cursor ); - cursor = make_string( ( char32_t ) c, NIL ); - cell->payload.string.cdr = cursor; - } - } - - return result; -} diff --git a/archive/c/io/io.h b/archive/c/io/io.h deleted file mode 100644 index 0f971a3..0000000 --- a/archive/c/io/io.h +++ /dev/null @@ -1,46 +0,0 @@ - -/* - * 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/consspaceobject.h" - -extern CURLSH *io_share; - -int io_init( ); - -#define C_IO_IN L"*in*" -#define C_IO_OUT L"*out*" - -extern struct cons_pointer lisp_io_in; -extern struct cons_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 cons_pointer get_default_stream( bool inputp, struct cons_pointer env ); - -struct cons_pointer -lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer -lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer -lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer -lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - -char *lisp_string_to_c_string( struct cons_pointer s ); -#endif diff --git a/archive/c/io/print.c b/archive/c/io/print.c deleted file mode 100644 index c945943..0000000 --- a/archive/c/io/print.c +++ /dev/null @@ -1,356 +0,0 @@ -/* - * print.c - * - * First pass at a printer, for bootstrapping. - * - * (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 "arith/integer.h" -#include "debug.h" -#include "io/io.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/hashmap.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "ops/intern.h" -#include "time/psse_time.h" - -/** - * print all the characters in the symbol or string indicated by `pointer` - * onto this `output`; if `pointer` does not indicate a string or symbol, - * don't print anything but just return. - */ -void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) { - while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - char32_t c = cell->payload.string.character; - - if ( c != '\0' ) { - url_fputwc( c, output ); - } - pointer = cell->payload.string.cdr; - } -} - -/** - * print all the characters in the string indicated by `pointer` onto - * the stream at this `output`, prepending and appending double quote - * characters. - */ -void print_string( URL_FILE *output, struct cons_pointer pointer ) { - url_fputwc( btowc( '"' ), output ); - print_string_contents( output, pointer ); - url_fputwc( btowc( '"' ), output ); -} - -/** - * Print a single list cell (cons cell) indicated by `pointer` to the - * stream indicated by `output`. if `initial_space` is `true`, prepend - * a space character. - */ -void -print_list_contents( URL_FILE *output, struct cons_pointer pointer, - bool initial_space ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - switch ( cell->tag.value ) { - case CONSTV: - if ( initial_space ) { - url_fputwc( btowc( ' ' ), output ); - } - c_print( output, cell->payload.cons.car ); - - print_list_contents( output, cell->payload.cons.cdr, true ); - break; - case NILTV: - break; - default: - url_fwprintf( output, L" . " ); - c_print( output, pointer ); - } -} - -void print_list( URL_FILE *output, struct cons_pointer pointer ) { - url_fputws( L"(", output ); - print_list_contents( output, pointer, false ); - url_fputws( L")", output ); -} - -void print_map( URL_FILE *output, struct cons_pointer map ) { - if ( hashmapp( map ) ) { - struct vector_space_object *vso = pointer_to_vso( map ); - - url_fputwc( btowc( '{' ), output ); - - for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); - ks = c_cdr( ks ) ) { - struct cons_pointer key = c_car( ks ); - c_print( output, key ); - url_fputwc( btowc( ' ' ), output ); - c_print( output, hashmap_get( map, key, false ) ); - - if ( !nilp( c_cdr( ks ) ) ) { - url_fputws( L", ", output ); - } - } - - url_fputwc( btowc( '}' ), output ); - } -} - -void print_vso( URL_FILE *output, struct cons_pointer pointer ) { - struct vector_space_object *vso = pointer_to_vso( pointer ); - switch ( vso->header.tag.value ) { - case HASHTV: - print_map( output, pointer ); - break; - case STACKFRAMETV: - dump_stack_trace( output, pointer ); - break; - // \todo: others. - default: - fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", - vso->header.tag.value ); - } -} - -/** - * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc - */ -void print_128bit( URL_FILE *output, __int128_t n ) { - 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 - } - url_fwprintf( output, L"%s", s ); - } -} - - -/** - * Print the cons-space object indicated by `pointer` to the stream indicated - * by `output`. - */ -struct cons_pointer c_print( URL_FILE *output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - char *buffer; - - /* - * Because tags have values as well as bytes, this if ... else if - * statement can ultimately be replaced by a switch, which will be neater. - */ - switch ( cell.tag.value ) { - case CONSTV: - print_list( output, pointer ); - break; - case EXCEPTIONTV: - url_fputws( L"\nException: ", output ); - dump_stack_trace( output, pointer ); - break; - case FUNCTIONTV: - url_fputws( L"', output ); - break; - case INTEGERTV: - struct cons_pointer s = integer_to_string( pointer, 10 ); - print_string_contents( output, s ); - dec_ref( s ); - break; - case KEYTV: - url_fputws( L":", output ); - print_string_contents( output, pointer ); - break; - case LAMBDATV:{ - url_fputws( L"', output ); - } - break; - case NILTV: - url_fwprintf( output, L"nil" ); - break; - case NLAMBDATV:{ - url_fputws( L"', output ); - } - break; - case RATIOTV: - c_print( output, cell.payload.ratio.dividend ); - url_fputws( L"/", output ); - c_print( output, cell.payload.ratio.divisor ); - break; - case READTV: - url_fwprintf( output, L"', output ); - break; - case REALTV: - /* \todo using the C heap is a bad plan because it will fragment. - * As soon as I have working vector space I'll use a special purpose - * vector space object */ - buffer = ( char * ) malloc( 24 ); - memset( buffer, 0, 24 ); - /* format it really long, then clear the trailing zeros */ - sprintf( buffer, "%-.23Lg", cell.payload.real.value ); - if ( strchr( buffer, '.' ) != NULL ) { - for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) { - buffer[i] = '\0'; - } - } - url_fwprintf( output, L"%s", buffer ); - free( buffer ); - break; - case STRINGTV: - print_string( output, pointer ); - break; - case SYMBOLTV: - print_string_contents( output, pointer ); - break; - case SPECIALTV: - url_fwprintf( output, L"', output ); - break; - case TIMETV: - url_fwprintf( output, L"', output ); - break; - case TRUETV: - url_fwprintf( output, L"t" ); - break; - case VECTORPOINTTV: - print_vso( output, pointer ); - break; - case WRITETV: - url_fwprintf( output, L"', output ); - break; - default: - fwprintf( stderr, - L"Error: Unrecognised tag value %d (%4.4s)\n", - cell.tag.value, &cell.tag.bytes[0] ); - // dump_object( stderr, pointer); - break; - } - - return pointer; -} - -/** - * Function; print 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. - * - * * (print expr) - * * (print 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_print( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering print\n", DEBUG_IO ); - struct cons_pointer result = NIL; - URL_FILE *output; - struct cons_pointer out_stream = writep( frame->arg[1] ) ? - frame->arg[1] : get_default_stream( false, env ); - - if ( writep( out_stream ) ) { - debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - inc_ref( out_stream ); - } else { - output = file_to_url_file( stderr ); - } - - debug_print( L"lisp_print: about to print\n", DEBUG_IO ); - debug_dump_object( frame->arg[0], DEBUG_IO ); - - result = c_print( output, frame->arg[0] ); - - debug_print( L"lisp_print returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - if ( writep( out_stream ) ) { - dec_ref( out_stream ); - } else { - free( output ); - } - - return result; -} - -void println( URL_FILE *output ) { - url_fputws( L"\n", output ); -} - -/** - * @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if - * it is specified and is an output stream, else to `*out*`. - * - * @param frame - * @param frame_pointer - * @param env - * @return `nil` - */ -struct cons_pointer -lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - URL_FILE *output; - struct cons_pointer out_stream = writep( frame->arg[1] ) ? - frame->arg[1] : get_default_stream( false, env ); - - if ( writep( out_stream ) ) { - output = pointer2cell( out_stream ).payload.stream.stream; - - println( output ); - } - - return NIL; -} diff --git a/archive/c/io/print.h b/archive/c/io/print.h deleted file mode 100644 index 0d9aae8..0000000 --- a/archive/c/io/print.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * print.h - * - * First pass at a printer, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include - -#include "io/fopen.h" - -#ifndef __print_h -#define __print_h - -struct cons_pointer c_print( URL_FILE * output, struct cons_pointer pointer ); -void println( URL_FILE * output ); - -struct cons_pointer lisp_print( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer lisp_println( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - - -#endif diff --git a/archive/c/io/read.c b/archive/c/io/read.c deleted file mode 100644 index fee80b3..0000000 --- a/archive/c/io/read.c +++ /dev/null @@ -1,570 +0,0 @@ -/* - * read.c - * - * First pass at a reader, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "memory/consspaceobject.h" -#include "debug.h" -#include "memory/dump.h" -#include "memory/hashmap.h" -#include "arith/integer.h" -#include "ops/intern.h" -#include "io/io.h" -#include "ops/lispops.h" -#include "arith/peano.h" -#include "io/print.h" -#include "arith/ratio.h" -#include "io/read.h" -#include "arith/real.h" -#include "memory/vectorspace.h" - -// We can't, I think, use libreadline, because we read character by character, -// not line by line, and because we use wide characters. So we're going to have -// to reimplement it. So we're going to have to maintain history of the forms -// (or strings, but I currently think forms). So we're going to have to be able -// to detact special keys, particularly, at this stage, the uparrow and down- -// arrow keys -// #include -// #include - - -/* - * for the time being things which may be read are: - * * strings - * * numbers - either integer, ratio or real - * * lists - * * maps - * * keywords - * * atoms - */ - -struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial, - bool seen_period ); -struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE * input, wint_t initial ); -struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE * input, wint_t initial ); -struct cons_pointer read_string( URL_FILE * input, wint_t initial ); -struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, - wint_t initial ); - -/** - * quote reader macro in C (!) - */ -struct cons_pointer c_quote( struct cons_pointer arg ) { - return make_cons( c_string_to_lisp_symbol( L"quote" ), - make_cons( arg, NIL ) ); -} - -/** - * Read a path macro from the stream. A path macro is expected to be - * 1. optionally a leading character such as '/' or '$', followed by - * 2. one or more keywords with leading colons (':') but no intervening spaces; or - * 3. one or more symbols separated by slashes; or - * 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes). - */ -struct cons_pointer read_path( URL_FILE *input, wint_t initial, - struct cons_pointer q ) { - bool done = false; - struct cons_pointer prefix = NIL; - - switch ( initial ) { - case '/': - prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL ); - break; - case '$': - case LSESSION: - prefix = c_string_to_lisp_symbol( L"session" ); - break; - } - - while ( !done ) { - wint_t c = url_fgetwc( input ); - if ( iswblank( c ) || iswcntrl( c ) ) { - done = true; - } else if ( url_feof( input ) ) { - done = true; - } else { - switch ( c ) { - case ':': - q = make_cons( read_symbol_or_key - ( input, KEYTV, url_fgetwc( input ) ), q ); - break; - case '/': - q = make_cons( make_cons - ( c_string_to_lisp_symbol( L"quote" ), - make_cons( read_symbol_or_key - ( input, SYMBOLTV, - url_fgetwc( input ) ), - NIL ) ), q ); - break; - default: - if ( iswalpha( c ) ) { - q = make_cons( read_symbol_or_key - ( input, SYMBOLTV, c ), q ); - } else { - // TODO: it's really an error. Exception? - url_ungetwc( c, input ); - done = true; - } - } - } - } - - // right, we now have the path we want (reversed) in q. - struct cons_pointer r = NIL; - - for ( struct cons_pointer p = q; !nilp( p ); p = c_cdr( p ) ) { - r = make_cons( c_car( p ), r ); - } - - dec_ref( q ); - - if ( !nilp( prefix ) ) { - r = make_cons( prefix, r ); - } - - return make_cons( c_string_to_lisp_symbol( L"->" ), r ); -} - -/** - * Read the next object on this input stream and return a cons_pointer to it, - * treating this initial character as the first character of the object - * representation. - */ -struct cons_pointer read_continuation( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE *input, wint_t initial ) { - debug_print( L"entering read_continuation\n", DEBUG_IO ); - struct cons_pointer result = NIL; - - wint_t c; - - for ( c = initial; - c == '\0' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ); - - if ( url_feof( input ) ) { - result = - throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string - ( L"End of file while reading" ), frame_pointer ); - } else { - 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; - case '\'': - result = - c_quote( read_continuation - ( frame, frame_pointer, env, input, - url_fgetwc( input ) ) ); - break; - case '(': - result = - read_list( frame, frame_pointer, env, input, - url_fgetwc( input ) ); - break; - case '{': - result = read_map( frame, frame_pointer, env, input, - url_fgetwc( input ) ); - break; - case '"': - result = read_string( input, url_fgetwc( input ) ); - break; - case '-':{ - wint_t next = url_fgetwc( input ); - url_ungetwc( next, input ); - if ( iswdigit( next ) ) { - result = - read_number( frame, frame_pointer, input, c, - false ); - } else { - result = read_symbol_or_key( input, SYMBOLTV, c ); - } - } - break; - case '.': - { - wint_t next = url_fgetwc( input ); - if ( iswdigit( next ) ) { - url_ungetwc( next, input ); - result = - read_number( frame, frame_pointer, input, c, - true ); - } else if ( iswblank( next ) ) { - /* dotted pair. \todo this isn't right, we - * really need to backtrack up a level. */ - result = - read_continuation( frame, frame_pointer, env, - input, url_fgetwc( input ) ); - debug_print - ( L"read_continuation: dotted pair; read cdr ", - DEBUG_IO ); - } else { - read_symbol_or_key( input, SYMBOLTV, c ); - } - } - break; - case ':': - result = - read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); - break; - case '/': - { - /* slash followed by whitespace is legit provided it's not - * preceded by anything - it's the division operator. Otherwise, - * it's terminal, probably part of a path, and needs pushed back. - */ - wint_t cn = url_fgetwc( input ); - if ( nilp( result ) - && ( iswblank( cn ) || iswcntrl( cn ) ) ) { - url_ungetwc( cn, input ); - result = make_symbol_or_key( c, NIL, SYMBOLTV ); - } else { - url_ungetwc( cn, input ); - result = read_path( input, c, NIL ); - } - } - break; - case '$': - case LSESSION: - result = read_path( input, c, NIL ); - break; - default: - if ( iswdigit( c ) ) { - result = - read_number( frame, frame_pointer, input, c, false ); - } else if ( iswprint( c ) ) { - result = read_symbol_or_key( input, SYMBOLTV, c ); - } 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; - } - } - debug_print( L"read_continuation returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * read a number from this input stream, given this initial character. - * \todo Need to do a lot of inc_ref and dec_ref, to make sure the - * garbage is collected. - */ -struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE *input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); - - struct cons_pointer result = acquire_integer( 0, NIL ); - /* \todo we really need to be getting `base` from a privileged Lisp name - - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = acquire_integer( 10, NIL ); - struct cons_pointer dividend = NIL; - int places_of_decimals = 0; - wint_t c; - bool neg = initial == btowc( '-' ); - - if ( neg ) { - initial = url_fgetwc( input ); - } - - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, - initial ); - - for ( c = initial; iswdigit( c ) - || c == LPERIOD || c == LSLASH || c == LCOMMA; - c = url_fgetwc( input ) ) { - switch ( c ) { - case LPERIOD: - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); - } else { - debug_print( L"read_number: decimal point seen\n", - DEBUG_IO ); - seen_period = true; - } - break; - case LSLASH: - if ( seen_period || !nilp( dividend ) ) { - return throw_exception( c_string_to_lisp_symbol( L"read" ), - c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - debug_print( L"read_number: ratio slash seen\n", - DEBUG_IO ); - dividend = result; - - result = acquire_integer( 0, NIL ); - // If I do replace_integer_p here instead of acquire_integer, - // and thus reclaim the garbage, I get a regression. Dom't yet - // know why. - } - break; - case LCOMMA: - // silently ignore comma. - break; - default: - result = add_integers( multiply_integers( result, base ), - acquire_integer( ( int ) c - - ( int ) '0', NIL ) ); - - debug_printf( DEBUG_IO, - L"read_number: added character %c, result now ", - c ); - debug_print_object( result, DEBUG_IO ); - debug_print( L"\n", DEBUG_IO ); - - if ( seen_period ) { - places_of_decimals++; - } - } - } - - /* - * push back the character read which was not a digit - */ - url_ungetwc( c, input ); - - if ( seen_period ) { - debug_print( L"read_number: converting result to real\n", DEBUG_IO ); - struct cons_pointer div = make_ratio( result, - acquire_integer( powl - ( to_long_double - ( base ), - places_of_decimals ), - NIL ), true ); - inc_ref( div ); - - result = make_real( to_long_double( div ) ); - - dec_ref( div ); - } else if ( integerp( dividend ) ) { - debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); - result = make_ratio( dividend, result, true ); - } - - if ( neg ) { - debug_print( L"read_number: converting result to negative\n", - DEBUG_IO ); - - result = negative( result ); - } - - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * Read a list from this input stream, which no longer contains the opening - * left parenthesis. - */ -struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE *input, wint_t initial ) { - struct cons_pointer result = NIL; - wint_t c; - - if ( initial != ')' ) { - debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); - struct cons_pointer car = - read_continuation( frame, frame_pointer, env, input, - initial ); - - /* skip whitespace */ - for ( c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); - - if ( c == LPERIOD ) { - /* might be a dotted pair; indeed, if we rule out numbers with - * initial periods, it must be a dotted pair. \todo Ought to check, - * howerver, that there's only one form after the period. */ - result = - make_cons( car, - c_car( read_list( frame, - frame_pointer, - env, - input, url_fgetwc( input ) ) ) ); - } else { - result = - make_cons( car, - read_list( frame, frame_pointer, env, input, c ) ); - } - } else { - debug_print( L"End of list detected\n", DEBUG_IO ); - } - - return result; -} - -struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE *input, wint_t initial ) { - // set write ACL to true whilst creating to prevent GC churn - struct cons_pointer result = - make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); - wint_t c = initial; - - while ( c != LCBRACE ) { - struct cons_pointer key = - read_continuation( frame, frame_pointer, env, input, c ); - - /* skip whitespace */ - for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ); - - struct cons_pointer value = - read_continuation( frame, frame_pointer, env, input, c ); - - /* skip commaa and whitespace at this point. */ - for ( c = url_fgetwc( input ); - c == LCOMMA || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ); - - result = - hashmap_put( result, key, - eval_form( frame, frame_pointer, value, env ) ); - } - - // default write ACL for maps should be NIL. - pointer_to_vso( result )->payload.hashmap.write_acl = NIL; - - return result; -} - -/** - * Read a string. This means either a string delimited by double quotes - * (is_quoted == true), in which case it may contain whitespace but may - * not contain a double quote character (unless escaped), or one not - * so delimited in which case it may not contain whitespace (unless escaped) - * but may contain a double quote character (probably not a good idea!) - */ -struct cons_pointer read_string( URL_FILE *input, wint_t initial ) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; - switch ( initial ) { - case '\0': - result = NIL; - break; - case '"': - /* making a string of the null character means we can have an empty - * string. Just returning NIL here would make an empty string - * impossible. */ - result = make_string( '\0', NIL ); - break; - default: - result = - make_string( initial, - read_string( input, url_fgetwc( input ) ) ); - break; - } - - return result; -} - -struct cons_pointer read_symbol_or_key( URL_FILE *input, uint32_t tag, - wint_t initial ) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; - switch ( initial ) { - case '\0': - result = make_symbol_or_key( initial, NIL, tag ); - break; - case '"': - case '\'': - /* unwise to allow embedded quotation marks in symbols */ - case ')': - case ':': - case '/': - /* - * symbols and keywords may not include right-parenthesis, - * slashes or colons. - */ - result = NIL; - /* - * push back the character read - */ - url_ungetwc( initial, input ); - break; - default: - if ( iswprint( initial ) - && !iswblank( initial ) ) { - result = - make_symbol_or_key( initial, - read_symbol_or_key( input, - tag, - url_fgetwc - ( input ) ), tag ); - } else { - result = NIL; - /* - * push back the character read - */ - url_ungetwc( initial, input ); - } - break; - } - - debug_print( L"read_symbol_or_key returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * Read the next object on this input stream and return a cons_pointer to it. - */ -struct cons_pointer read( struct - stack_frame - *frame, struct cons_pointer frame_pointer, - struct cons_pointer env, URL_FILE *input ) { - return read_continuation( frame, frame_pointer, env, input, - url_fgetwc( input ) ); -} diff --git a/archive/c/io/read.h b/archive/c/io/read.h deleted file mode 100644 index 7f58d0c..0000000 --- a/archive/c/io/read.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * read.c - * - * First pass at a reader, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __read_h -#define __read_h - -#include "memory/consspaceobject.h" - -/* characters (other than arabic numberals) used in number representations */ -#define LCOMMA L',' -#define LPERIOD L'.' -#define LSLASH L'/' -/* ... used in map representations */ -#define LCBRACE L'}' -/* ... used in path representations */ -#define LSESSION L'§' - -/** - * read the next object on this input stream and return a cons_pointer to it. - */ -struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, URL_FILE * input ); - -#endif diff --git a/archive/c/memory/conspage.c b/archive/c/memory/conspage.c deleted file mode 100644 index 31ab050..0000000 --- a/archive/c/memory/conspage.c +++ /dev/null @@ -1,290 +0,0 @@ -/* - * conspage.c - * - * Setup and tear down cons pages, and (FOR NOW) do primitive - * allocation/deallocation of cells. - * NOTE THAT before we go multi-threaded, these functions must be - * aggressively - * thread safe. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include - -#include "memory/consspaceobject.h" -#include "memory/conspage.h" -#include "debug.h" -#include "memory/dump.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" - -/** - * Flag indicating whether conspage initialisation has been done. - */ -bool conspageinitihasbeencalled = false; - -/** - * keep track of total cells allocated and freed to check for leakage. - */ -uint64_t total_cells_allocated = 0; -uint64_t total_cells_freed = 0; - -/** - * the number of cons pages which have thus far been initialised. - */ -int initialised_cons_pages = 0; - -/** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately - * belongs in this file. - */ -struct cons_pointer freelist = NIL; - -/** - * The exception message printed when the world blows up, initialised in - * `maybe_bind_init_symbols()` in `init.c`, q.v. - */ -struct cons_pointer privileged_string_memory_exhausted; - -/** - * An array of pointers to cons pages. - */ -struct cons_page *conspages[NCONSPAGES]; - -/** - * Make a cons page. Initialise all cells and prepend each to the freelist; - * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the - * freelist but initialise them as NIL and T respectively. - * \todo we ought to handle cons space exhaustion more gracefully than just - * crashing; should probably return an exception instead, although obviously - * that exception would have to have been pre-built. - */ -void make_cons_page( ) { - struct cons_page *result = NULL; - - if ( initialised_cons_pages < NCONSPAGES ) { - result = malloc( sizeof( struct cons_page ) ); - } - - if ( result != NULL ) { - conspages[initialised_cons_pages] = result; - - for ( int i = 0; i < CONSPAGESIZE; i++ ) { - struct cons_space_object *cell = - &conspages[initialised_cons_pages]->cell[i]; - if ( initialised_cons_pages == 0 && i < 2 ) { - switch ( i ) { - case 0: - /* - * initialise cell as NIL - */ - strncpy( &cell->tag.bytes[0], NILTAG, TAGLENGTH ); - cell->count = MAXREFERENCE; - cell->payload.free.car = NIL; - cell->payload.free.cdr = NIL; - debug_printf( DEBUG_ALLOC, - L"Allocated special cell NIL\n" ); - break; - case 1: - /* - * initialise cell as T - */ - strncpy( &cell->tag.bytes[0], TRUETAG, TAGLENGTH ); - cell->count = MAXREFERENCE; - cell->payload.free.car = ( struct cons_pointer ) { - 0, 1 - }; - cell->payload.free.cdr = ( struct cons_pointer ) { - 0, 1 - }; - debug_printf( DEBUG_ALLOC, - L"Allocated special cell T\n" ); - break; - } - } else { - /* - * otherwise, standard initialisation - */ - strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); - cell->payload.free.car = NIL; - cell->payload.free.cdr = freelist; - freelist.page = initialised_cons_pages; - freelist.offset = i; - } - } - - initialised_cons_pages++; - } else { - fwide( stderr, 1 ); - fwprintf( stderr, - L"FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages ); - exit( 1 ); - } -} - -/** - * dump the allocated pages to this `output` stream. - */ -void dump_pages( URL_FILE *output ) { - for ( int i = 0; i < initialised_cons_pages; i++ ) { - url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); - - for ( int j = 0; j < CONSPAGESIZE; j++ ) { - struct cons_pointer pointer = ( struct cons_pointer ) { i, j }; - if ( !freep( pointer ) ) { - dump_object( output, ( struct cons_pointer ) { - i, j - } ); - } - } - } -} - -/** - * Frees the cell at the specified `pointer`; for all the types of cons-space - * object which point to other cons-space objects, cascade the decrement. - * Dangerous, primitive, low level. - * - * @pointer the cell to free - */ -void free_cell( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - debug_printf( DEBUG_ALLOC, L"Freeing cell " ); - debug_dump_object( pointer, DEBUG_ALLOC ); - - if ( !check_tag( pointer, FREETV ) ) { - if ( cell->count == 0 ) { - switch ( cell->tag.value ) { - case CONSTV: - dec_ref( cell->payload.cons.car ); - dec_ref( cell->payload.cons.cdr ); - break; - case EXCEPTIONTV: - dec_ref( cell->payload.exception.payload ); - dec_ref( cell->payload.exception.frame ); - break; - case FUNCTIONTV: - dec_ref( cell->payload.function.meta ); - break; - case INTEGERTV: - dec_ref( cell->payload.integer.more ); - break; - case LAMBDATV: - case NLAMBDATV: - dec_ref( cell->payload.lambda.args ); - dec_ref( cell->payload.lambda.body ); - break; - case RATIOTV: - dec_ref( cell->payload.ratio.dividend ); - dec_ref( cell->payload.ratio.divisor ); - break; - case READTV: - case WRITETV: - dec_ref( cell->payload.stream.meta ); - url_fclose( cell->payload.stream.stream ); - break; - case SPECIALTV: - dec_ref( cell->payload.special.meta ); - break; - case STRINGTV: - case SYMBOLTV: - dec_ref( cell->payload.string.cdr ); - break; - case VECTORPOINTTV: - free_vso( pointer ); - break; - default: - fprintf( stderr, "WARNING: Freeing object of type %s!", - ( char * ) &( cell->tag.bytes ) ); - } - - strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); - cell->payload.free.car = NIL; - cell->payload.free.cdr = freelist; - freelist = pointer; - total_cells_freed++; - } else { - debug_printf( DEBUG_ALLOC, - L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", - cell->count, pointer.page, pointer.offset ); - } - } else { - debug_printf( DEBUG_ALLOC, - L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset ); - } -} - -/** - * Allocates a cell with the specified `tag`. Dangerous, primitive, low - * level. - * - * @param tag the tag of the cell to allocate - must be a valid cons space tag. - * @return the cons pointer which refers to the cell allocated. - * \todo handle the case where another cons_page cannot be allocated; - * return an exception. Which, as we cannot create such an exception when - * cons space is exhausted, means we must construct it at init time. - */ -struct cons_pointer allocate_cell( uint32_t tag ) { - struct cons_pointer result = freelist; - - - if ( result.page == NIL.page && result.offset == NIL.offset ) { - make_cons_page( ); - result = allocate_cell( tag ); - } else { - struct cons_space_object *cell = &pointer2cell( result ); - - if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { - freelist = cell->payload.free.cdr; - - cell->tag.value = tag; - - cell->count = 1; - cell->payload.cons.car = NIL; - cell->payload.cons.cdr = NIL; - - total_cells_allocated++; - - debug_printf( DEBUG_ALLOC, - L"Allocated cell of type %4.4s at %u, %u \n", - ( ( char * ) cell->tag.bytes ), result.page, - result.offset ); - } else { - debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); - } - } - - return result; -} - -/** - * initialise the cons page system; to be called exactly once during startup. - */ -void initialise_cons_pages( ) { - if ( conspageinitihasbeencalled == false ) { - for ( int i = 0; i < NCONSPAGES; i++ ) { - conspages[i] = ( struct cons_page * ) NULL; - } - - make_cons_page( ); - conspageinitihasbeencalled = true; - } else { - debug_printf( DEBUG_ALLOC, - L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); - } -} - -void summarise_allocation( ) { - fwprintf( stderr, - L"Allocation summary: allocated %lld; deallocated %lld; not deallocated %lld.\n", - total_cells_allocated, total_cells_freed, - total_cells_allocated - total_cells_freed ); -} diff --git a/archive/c/memory/conspage.h b/archive/c/memory/conspage.h deleted file mode 100644 index 3bad3ae..0000000 --- a/archive/c/memory/conspage.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * conspage.h - * - * Setup and tear down cons pages, and (FOR NOW) do primitive - * allocation/deallocation of cells. - * NOTE THAT before we go multi-threaded, these functions must be - * aggressively - * thread safe. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ -#ifndef __psse_conspage_h -#define __psse_conspage_h - -#include "memory/consspaceobject.h" - -/** - * the number of cons cells on a cons page. The maximum value this can - * be (and consequently, the size which, by version 1, it will default - * to) is the maximum value of an unsigned 32 bit integer, which is to - * say 4294967296. However, we'll start small. - */ -#define CONSPAGESIZE 1024 - -/** - * the number of cons pages we will initially allow for. For - * convenience we'll set up an array of cons pages this big; however, - * later we will want a mechanism for this to be able to grow - * dynamically to the maximum we can currently allow, which is - * 4294967296. - * - * Note that this means the total number of addressable cons cells is - * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are - * up to a maximum of 4e9 of heap space objects, each of potentially - * 4e9 bytes. So we're talking about a potential total of 8e100 bytes - * of addressable memory, which is only slightly more than the - * number of atoms in the universe. - */ -#define NCONSPAGES 64 - -/** - * a cons page is essentially just an array of cons space objects. It - * might later have a local free list (i.e. list of free cells on this - * page) and a pointer to the next cons page, but my current view is - * that that's probably unneccessary. - */ -struct cons_page { - struct cons_space_object cell[CONSPAGESIZE]; -}; - -extern struct cons_pointer privileged_string_memory_exhausted; - -extern struct cons_pointer freelist; - -extern struct cons_page *conspages[NCONSPAGES]; - -void free_cell( struct cons_pointer pointer ); - -struct cons_pointer allocate_cell( uint32_t tag ); - -void initialise_cons_pages( ); - -void dump_pages( URL_FILE * output ); - -void summarise_allocation( ); - -#endif diff --git a/archive/c/memory/consspaceobject.c b/archive/c/memory/consspaceobject.c deleted file mode 100644 index 4220618..0000000 --- a/archive/c/memory/consspaceobject.c +++ /dev/null @@ -1,561 +0,0 @@ -/* - * consspaceobject.c - * - * Structures common to all cons space objects. - * - * - * (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 "authorise.h" -#include "debug.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "ops/intern.h" - -/** - * Keywords used when constructing exceptions: `:location`. Instantiated in - * `init.c`q.v. - */ -struct cons_pointer privileged_keyword_location = NIL; - -/** - * Keywords used when constructing exceptions: `:payload`. Instantiated in - * `init.c`, q.v. - */ -struct cons_pointer privileged_keyword_payload = NIL; - -/** - * Keywords used when constructing exceptions: `:payload`. Instantiated in - * `init.c`, q.v. - */ -struct cons_pointer privileged_keyword_cause = NIL; - -/** - * @brief keywords used in documentation: `:documentation`. Instantiated in - * `init.c`, q. v. - * - */ -struct cons_pointer privileged_keyword_documentation = NIL; - -/** - * @brief keywords used in documentation: `:name`. Instantiated in - * `init.c`, q. v. - */ -struct cons_pointer privileged_keyword_name = NIL; - -/** - * @brief keywords used in documentation: `:primitive`. Instantiated in - * `init.c`, q. v. - */ -struct cons_pointer privileged_keyword_primitive = NIL; - - -/** - * True if the value of the tag on the cell at this `pointer` is this `value`, - * or, if the tag of the cell is `VECP`, if the value of the tag of the - * vectorspace object indicated by the cell is this `value`, else false. - */ -bool check_tag( struct cons_pointer pointer, uint32_t value ) { - bool result = false; - - struct cons_space_object *cell = &pointer2cell( pointer ); - result = cell->tag.value == value; - - if ( result == false ) { - if ( cell->tag.value == VECTORPOINTTV ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); - - if ( vec != NULL ) { - result = vec->header.tag.value == value; - } - } - } - - return 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 cons_pointer inc_ref( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - if ( cell->count < MAXREFERENCE ) { - cell->count++; -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, - L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u", - ( ( char * ) cell->tag.bytes ), pointer.page, - pointer.offset, cell->count ); - if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { - debug_printf( DEBUG_ALLOC, - L"; pointer to vector object of type %4.4s.\n", - ( ( char * ) ( cell->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 cell should be freed. - * - * Returns the `pointer`, or, if the cell has been freed, NIL. - */ -struct cons_pointer dec_ref( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - if ( cell->count > 0 && cell->count != UINT32_MAX ) { - cell->count--; -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, - L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d", - ( ( char * ) cell->tag.bytes ), pointer.page, - pointer.offset, cell->count ); - if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) - == 0 ) { - debug_printf( DEBUG_ALLOC, - L"; pointer to vector object of type %4.4s.\n", - ( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } -#endif - - if ( cell->count == 0 ) { - free_cell( pointer ); - pointer = NIL; - } - } - - return pointer; -} - -/** - * given a cons_pointer as argument, return the tag. - */ -uint32_t get_tag_value( struct cons_pointer pointer ) { - uint32_t result = pointer2cell( pointer ).tag.value; - - if ( result == VECTORPOINTTV ) { - result = pointer_to_vso( pointer )->header.tag.value; - } - - return result; -} - -/** - * Get the Lisp type of the single argument. - * @param pointer a pointer to the object whose type is requested. - * @return As a Lisp string, the tag of the object which is at that pointer. - */ -struct cons_pointer c_type( struct cons_pointer pointer ) { - /* Strings read by `read` have the null character termination. This means - * that for the same printable string, the hashcode is different from - * strings made with NIL termination. The question is which should be - * fixed, and actually that's probably strings read by `read`. However, - * for now, it was easier to add a null character here. */ - struct cons_pointer result = make_string( ( char32_t ) 0, NIL ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - if ( cell->tag.value == VECTORPOINTTV ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); - - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = - make_string( ( char32_t ) vec->header.tag.bytes[i], result ); - } - } else { - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( char32_t ) cell->tag.bytes[i], result ); - } - } - - return result; -} - -/** - * Implementation of car in C. If arg is not a cons, or the current user is not - * authorised to read it, does not error but returns nil. - */ -struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } - - return result; -} - -/** - * Implementation of cdr in C. If arg is not a sequence, or the current user is - * not authorised to read it, does not error but returns nil. - */ -struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( truep( authorised( arg, NIL ) ) ) { - struct cons_space_object *cell = &pointer2cell( arg ); - - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.cdr; - break; - } - } - - return result; -} - -/** - * Implementation of `length` in C. If arg is not a cons, does not error but - * returns 0. - */ -int c_length( struct cons_pointer arg ) { - int result = 0; - - for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) { - result++; - } - - return result; -} - -/** - * Construct a cons cell from this pair of pointers. - */ -struct cons_pointer make_cons( struct cons_pointer car, - struct cons_pointer cdr ) { - struct cons_pointer pointer = NIL; - - pointer = allocate_cell( CONSTV ); - - struct cons_space_object *cell = &pointer2cell( pointer ); - - inc_ref( car ); - inc_ref( cdr ); - cell->payload.cons.car = car; - cell->payload.cons.cdr = cdr; - - return pointer; -} - -/** - * Construct an exception cell. - * @param message should be a lisp string describing the problem, but actually - * any cons pointer will do; - * @param frame_pointer should be the pointer to the frame in which the - * exception occurred. - */ -struct cons_pointer make_exception( struct cons_pointer message, - struct cons_pointer frame_pointer ) { - struct cons_pointer result = NIL; - struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - inc_ref( frame_pointer ); - cell->payload.exception.payload = message; - cell->payload.exception.frame = frame_pointer; - - result = pointer; - - return result; -} - -/** - * Construct a cell which points to an executable Lisp function. - */ -struct cons_pointer make_function( struct cons_pointer meta, - struct cons_pointer ( *executable ) ( struct - stack_frame - *, - struct - cons_pointer, - struct - cons_pointer ) ) -{ - struct cons_pointer pointer = allocate_cell( FUNCTIONTV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( meta ); - - cell->payload.function.meta = meta; - cell->payload.function.executable = executable; - - return pointer; -} - -/** - * Construct a lambda (interpretable source) cell - */ -struct cons_pointer make_lambda( struct cons_pointer args, - struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( LAMBDATV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - inc_ref( args ); - inc_ref( body ); - cell->payload.lambda.args = args; - cell->payload.lambda.body = body; - - return pointer; -} - -/** - * Construct an nlambda (interpretable source) cell; to a - * lambda as a special form is to a function. - */ -struct cons_pointer make_nlambda( struct cons_pointer args, - struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( NLAMBDATV ); - - struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( args ); - inc_ref( body ); - cell->payload.lambda.args = args; - cell->payload.lambda.body = body; - - return pointer; -} - -/** - * 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 cons_pointer ptr ) { - struct cons_space_object *cell = &pointer2cell( ptr ); - uint32_t result = 0; - - switch ( cell->tag.value ) { - 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. - */ -struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, - uint32_t tag ) { - struct cons_pointer pointer = NIL; - - if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) { - pointer = allocate_cell( tag ); - struct cons_space_object *cell = &pointer2cell( 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 ); - debug_println( DEBUG_ALLOC ); - } else { - // \todo should throw an exception! - debug_printf( DEBUG_ALLOC, - 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 cons_pointer make_string( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, STRINGTV ); -} - -/** - * Construct a symbol or keyword from the character `c` and this `tail`. - * Each is internally identical to a string except for having a different tag. - * - * @param c the character to add (prepend); - * @param tail the symbol which is being built. - * @param tag the tag to use: expected to be "SYMB" or "KEYW" - */ -struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - uint32_t tag ) { - struct cons_pointer result; - - if ( tag == SYMBOLTV || tag == KEYTV ) { - result = make_string_like_thing( c, tail, tag ); - - // if ( tag == KEYTV ) { - // struct cons_pointer r = interned( result, oblist ); - - // if ( nilp( r ) ) { - // intern( result, oblist ); - // } else { - // result = r; - // } - // } - } else { - result = - make_exception( c_string_to_lisp_string - ( L"Unexpected tag when making symbol or key." ), - NIL ); - } - - return result; -} - -/** - * Construct a cell which points to an executable Lisp special form. - */ -struct cons_pointer make_special( struct cons_pointer meta, - struct cons_pointer ( *executable ) ( struct - stack_frame - *frame, - struct - cons_pointer, - struct - cons_pointer - env ) ) -{ - struct cons_pointer pointer = allocate_cell( SPECIALTV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( meta ); - - cell->payload.special.meta = meta; - cell->payload.special.executable = executable; - - return pointer; -} - -/** - * 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 cons_pointer make_read_stream( URL_FILE *input, - struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( READTV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - cell->payload.stream.stream = input; - cell->payload.stream.meta = metadata; - - return pointer; -} - -/** - * Construct a cell which points to a stream open for writing. - * @param output 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 cons_pointer make_write_stream( URL_FILE *output, - struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( WRITETV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - cell->payload.stream.stream = output; - cell->payload.stream.meta = metadata; - - return pointer; -} - -/** - * Return a lisp keyword representation of this wide character string. In - * keywords, I am accepting only lower case characters and numbers. - */ -struct cons_pointer c_string_to_lisp_keyword( char32_t *symbol ) { - struct cons_pointer result = NIL; - - for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_t c = towlower( symbol[i] ); - - if ( iswalnum( c ) || c == L'-' ) { - result = make_keyword( c, result ); - } - } - - return result; -} - -/** - * Return a lisp string representation of this wide character string. - */ -struct cons_pointer c_string_to_lisp_string( char32_t *string ) { - struct cons_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 symbol representation of this wide character string. - */ -struct cons_pointer c_string_to_lisp_symbol( char32_t *symbol ) { - struct cons_pointer result = NIL; - - for ( int i = wcslen( symbol ); i > 0; i-- ) { - result = make_symbol( symbol[i - 1], result ); - } - - return result; -} diff --git a/archive/c/memory/consspaceobject.h b/archive/c/memory/consspaceobject.h deleted file mode 100644 index 62713bb..0000000 --- a/archive/c/memory/consspaceobject.h +++ /dev/null @@ -1,812 +0,0 @@ -/* - * consspaceobject.h - * - * Declarations common to all cons space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_consspaceobject_h -#define __psse_consspaceobject_h - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "io/fopen.h" -// #include "memory/conspage.h" - - -/** - * The length of a tag, in bytes. - */ -#define TAGLENGTH 4 - -/* - * tag values, all of which must be 4 bytes. Must not collide with vector space - * tag values - */ - -/** - * An ordinary cons cell: - */ -#define CONSTAG "CONS" - -/** - * The string `CONS`, considered as an `unsigned int`. - * @todo tag values should be collected into an enum. - */ -#define CONSTV 1397641027 - -/** - * An exception. TODO: we need a means of dealing with different classes of - * exception, and we don't have one yet. - */ -#define EXCEPTIONTAG "EXEP" - -/** - * The string `EXEP`, considered as an `unsigned int`. - */ -#define EXCEPTIONTV 1346721861 - -/** - * Keywords used when constructing exceptions: `:location`. Instantiated in - * `init.c`. - */ -extern struct cons_pointer privileged_keyword_location; - -/** - * Keywords used when constructing exceptions: `:payload`. Instantiated in - * `init.c`. - */ -extern struct cons_pointer privileged_keyword_payload; - -/** - * Keywords used when constructing exceptions: `:cause`. Instantiated in - * `init.c`. - */ -extern struct cons_pointer privileged_keyword_cause; - -/** - * @brief keywords used in documentation: `:documentation`. Instantiated in - * `init.c`, q. v. - */ -extern struct cons_pointer privileged_keyword_documentation; - -/** - * @brief keywords used in documentation: `:name`. Instantiated in - * `init.c`, q. v. - */ -extern struct cons_pointer privileged_keyword_name; - -/** - * @brief keywords used in documentation: `:primitive`. Instantiated in - * `init.c`, q. v. - */ -extern struct cons_pointer privileged_keyword_primitive; - -/** - * An unallocated cell on the free list - should never be encountered by a Lisp - * function. - */ -#define FREETAG "FREE" - -/** - * The string `FREE`, considered as an `unsigned int`. - */ -#define FREETV 1162170950 - -/** - * 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 "FUNC" - -/** - * The string `FUNC`, considered as an `unsigned int`. - */ -#define FUNCTIONTV 1129207110 - -/** - * An integer number (bignums are integers). - */ -#define INTEGERTAG "INTR" - -/** - * The string `INTR`, considered as an `unsigned int`. - */ -#define INTEGERTV 1381256777 - -/** - * A keyword - an interned, self-evaluating string. - */ -#define KEYTAG "KEYW" - -/** - * The string `KEYW`, considered as an `unsigned int`. - */ -#define KEYTV 1465468235 - -/** - * A lambda cell. Lambdas are the interpretable (source) versions of functions. - * \see FUNCTIONTAG. - */ -#define LAMBDATAG "LMDA" - -/** - * The string `LMDA`, considered as an `unsigned int`. - */ -#define LAMBDATV 1094995276 - -/** - * A loop exit is a special kind of exception which has exactly the same - * payload as an exception. - */ -#define LOOPTAG "LOOP" - -/** - * The string `LOOX`, considered as an `unsigned int`. - */ -#define LOOPTV 1347374924 - -/** - * @brief Tag for a lazy cons cell. - * - * A lazy cons cell is like a cons cell, but lazy. - * - */ -#define LAZYCONSTAG "LZYC" - -/** - * @brief Tag for a lazy string cell. - * - * A lazy string cell is like a string cell, but lazy. - * - */ -#define LAZYSTRTAG "LZYS" - -/** - * @brief Tag for a lazy worker cell. - * - * A lazy - * - */ -#define LAZYWRKRTAG "WRKR" - -/** - * The special cons cell at address {0,0} whose car and cdr both point to - * itself. - */ -#define NILTAG "NIL " - -/** - * The string `NIL `, considered as an `unsigned int`. - */ -#define NILTV 541870414 - -/** - * An nlambda cell. NLambdas are the interpretable (source) versions of special - * forms. \see SPECIALTAG. - */ -#define NLAMBDATAG "NLMD" - -/** - * The string `NLMD`, considered as an `unsigned int`. - */ -#define NLAMBDATV 1145916494 - -/** - * A rational number, stored as pointers two integers representing dividend - * and divisor respectively. - */ -#define RATIOTAG "RTIO" - -/** - * The string `RTIO`, considered as an `unsigned int`. - */ -#define RATIOTV 1330205778 - -/** - * An open read stream. - */ -#define READTAG "READ" - -/** - * The string `READ`, considered as an `unsigned int`. - */ -#define READTV 1145128274 - -/** - * A real number, represented internally as an IEEE 754-2008 `binary128`. - */ -#define REALTAG "REAL" - -/** - * The string `REAL`, considered as an `unsigned int`. - */ -#define REALTV 1279346002 - -/** - * A special form - one whose arguments are not pre-evaluated but passed as - * provided. - * \see NLAMBDATAG. - */ -#define SPECIALTAG "SPFM" - -/** - * The string `SPFM`, considered as an `unsigned int`. - */ -#define SPECIALTV 1296453715 - -/** - * A string of characters, organised as a linked list. - */ -#define STRINGTAG "STRG" - -/** - * The string `STRG`, considered as an `unsigned int`. - */ -#define STRINGTV 1196577875 - -/** - * A symbol is just like a keyword except not self-evaluating. - */ -#define SYMBOLTAG "SYMB" - -/** - * The string `SYMB`, considered as an `unsigned int`. - */ -#define SYMBOLTV 1112365395 - -/** - * A time stamp. - */ -#define TIMETAG "TIME" - -/** - * The string `TIME`, considered as an `unsigned int`. - */ -#define TIMETV 1162692948 - -/** - * The special cons cell at address {0,1} which is canonically different - * from NIL. - */ -#define TRUETAG "TRUE" - -/** - * The string `TRUE`, considered as an `unsigned int`. - */ -#define TRUETV 1163219540 - -/** - * A pointer to an object in vector space. - */ -#define VECTORPOINTTAG "VECP" - -/** - * The string `VECP`, considered as an `unsigned int`. - */ -#define VECTORPOINTTV 1346585942 - -/** - * An open write stream. - */ -#define WRITETAG "WRIT" - -/** - * The string `WRIT`, considered as an `unsigned int`. - */ -#define WRITETV 1414091351 - -/** - * a cons pointer which points to the special NIL cell - */ -#define NIL (struct cons_pointer){ 0, 0} - -/** - * a cons pointer which points to the special T cell - */ -#define TRUE (struct cons_pointer){ 0, 1} - -/** - * the maximum possible value of a reference count - */ -#define MAXREFERENCE 4294967295 - -/** - * a macro to convert a tag into a number - */ -#define tag2uint(tag) ((uint32_t)*tag) - -/** - * given a cons_pointer as argument, return the cell. - */ -#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) - -/** - * true if `conspoint` points to the special cell NIL, else false - * (there should only be one of these so it's slightly redundant). - */ -#define nilp(conspoint) (check_tag(conspoint,NILTV)) - -/** - * true if `conspoint` points to a cons cell, else false - */ -#define consp(conspoint) (check_tag(conspoint,CONSTV)) - -/** - * true if `conspoint` points to an exception, else false - */ -#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) - -/** - * true if `conspoint` points to an unassigned cell, else false - */ -#define freep(conspoint) (check_tag(conspoint,FREETV)) - -/** - * true if `conspoint` points to a function cell, else false - */ -#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV)) - -/** - * true if `conspoint` points to a keyword, else false - */ -#define keywordp(conspoint) (check_tag(conspoint,KEYTV)) - -/** - * true if `conspoint` points to a Lambda binding cell, else false - */ -#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) - -/** - * true if `conspoint` points to a loop recursion, else false. - */ -#define loopp(conspoint) (check_tag(conspoint,LOOPTV)) - -/** - * true if `conspoint` points to a special form cell, else false - */ -#define specialp(conspoint) (check_tag(conspoint,SPECIALTV)) - -/** - * true if `conspoint` points to a string cell, else false - */ -#define stringp(conspoint) (check_tag(conspoint,STRINGTV)) - -/** - * true if `conspoint` points to a symbol cell, else false - */ -#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV)) - -/** - * true if `conspoint` points to an integer cell, else false - */ -#define integerp(conspoint) (check_tag(conspoint,INTEGERTV)) - -/** - * true if `conspoint` points to a rational number cell, else false - */ -#define ratiop(conspoint) (check_tag(conspoint,RATIOTV)) - -/** - * true if `conspoint` points to a read stream cell, else false - */ -#define readp(conspoint) (check_tag(conspoint,READTV)) - -/** - * true if `conspoint` points to a real number cell, else false - */ -#define realp(conspoint) (check_tag(conspoint,REALTV)) - -/** - * true if `conspoint` points to some sort of a number cell, - * else false - */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV)) - -/** - * true if `conspoint` points to a sequence (list, string or, later, vector), - * else false. - */ -#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV)) - -/** - * true if `conspoint` points to a vector pointer, else false. - */ -#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV)) - -/** - * true if `conspoint` points to a write stream cell, else false. - */ -#define writep(conspoint) (check_tag(conspoint,WRITETV)) - -#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV)) - -/** - * true if `conspoint` points to a true cell, else false - * (there should only be one of these so it's slightly redundant). - * Also note that anything that is not NIL is truthy. - */ -#define tp(conspoint) (check_tag(conspoint,TRUETV)) - -/** - * true if `conspoint` points to a time cell, else false. - */ -#define timep(conspoint) (check_tag(conspoint,TIMETV)) - -/** - * true if `conspoint` points to something that is truthy, i.e. - * anything but NIL. - */ -#define truep(conspoint) (!check_tag(conspoint,NILTV)) - -/** - * An indirect pointer to a cons cell - */ -struct cons_pointer { - /** the index of the page on which this cell resides */ - uint32_t page; - /** the index of the cell within the page */ - uint32_t offset; -}; - -/* - * number of arguments stored in a stack frame - */ -#define args_in_frame 8 - -/** - * A stack frame. Yes, I know it isn't a cons-space object, but it's defined - * here to avoid circularity. \todo refactor. - */ -struct stack_frame { - /** 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; -}; - -/** - * payload of a cons cell. - */ -struct cons_payload { - /** Contents of the Address Register, naturally. */ - struct cons_pointer car; - /** Contents of the Decrement Register, naturally. */ - struct cons_pointer cdr; -}; - -/** - * Payload of an exception. - * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. - */ -struct exception_payload { - /** The payload: usually a Lisp string but in practice anything printable will do. */ - struct cons_pointer payload; - /** pointer to the (unfreed) stack frame in which the exception was thrown. */ - struct cons_pointer frame; -}; - -/** - * 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 ); -}; - -/** - * payload of a free cell. For the time being identical to a cons cell, - * but it may not be so in future. - */ -struct free_payload { - struct cons_pointer car; - struct cons_pointer cdr; -}; - -/** - * payload of an integer cell. An integer is in principle a sequence of cells; - * only 60 bits (+ sign bit) are actually used in each cell. If the value - * exceeds 60 bits, the least significant 60 bits are stored in the first cell - * in the chain, the next 60 in the next cell, and so on. Only the value of the - * first cell in any chain should be negative. - * - * \todo Why is this 60, and not 64 bits? - */ -struct integer_payload { - /** the value of the payload (i.e. 60 bits) of this cell. */ - int64_t value; - /** the next (more significant) cell in the chain, or `NIL` if there are no - * more. */ - struct cons_pointer more; -}; - -/** - * payload for lambda and nlambda cells. - */ -struct lambda_payload { - /** the arument list */ - struct cons_pointer args; - /** the body of the function to be applied to the arguments. */ - struct cons_pointer body; -}; - -/** - * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells. - */ -struct ratio_payload { - /** a pointer to an integer representing the dividend */ - struct cons_pointer dividend; - /** a pointer to an integer representing the divisor. */ - struct cons_pointer divisor; -}; - -/** - * payload for a real number cell. Internals of this liable to change to give 128 bits - * precision, but I'm not sure of the detail. - */ -struct real_payload { - /** the value of the number */ - long double value; -}; - -/** - * 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 ); -}; - -/** - * 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; -}; - -/** - * payload of a string cell. At least at first, only one UTF character will - * be stored in each cell. The doctrine that 'a symbol is just a string' - * didn't work; however, the payload of a symbol or keyword cell is identical - * to the payload of a string cell, except that a keyword may store a hash - * of its own value in the padding. - */ -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; -}; - -/** - * 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; -}; - -/** - * 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 (\todo will change when I actually - * implement vector space) */ - void *address; -}; - -/** - * an object in cons space. - */ -struct cons_space_object { - union { - /** the tag (type) of this cell, - * considered as bytes */ - char bytes[TAGLENGTH]; - /** 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; - union { - /** - * if tag == CONSTAG - */ - struct cons_payload cons; - /** - * if tag == EXCEPTIONTAG || tag == LOOPTAG - */ - struct exception_payload exception; - /** - * if tag == FREETAG - */ - struct free_payload free; - /** - * if tag == FUNCTIONTAG - */ - struct function_payload function; - /** - * if tag == INTEGERTAG - */ - struct integer_payload integer; - /** - * if tag == LAMBDATAG or NLAMBDATAG - */ - struct lambda_payload lambda; - /** - * if tag == NILTAG; we'll treat the special cell NIL as just a cons - */ - struct cons_payload nil; - /** - * if tag == RATIOTAG - */ - struct ratio_payload ratio; - /** - * if tag == READTAG || tag == WRITETAG - */ - struct stream_payload stream; - /** - * if tag == REALTAG - */ - struct real_payload real; - /** - * if tag == SPECIALTAG - */ - struct special_payload special; - /** - * if tag == STRINGTAG || tag == SYMBOLTAG - */ - struct string_payload string; - /** - * if tag == TIMETAG - */ - struct time_payload time; - /** - * if tag == TRUETAG; we'll treat the special cell T as just a cons - */ - struct cons_payload t; - /** - * if tag == VECTORPTAG - */ - struct vectorp_payload vectorp; - } payload; -}; - -bool check_tag( struct cons_pointer pointer, uint32_t value ); - -struct cons_pointer inc_ref( struct cons_pointer pointer ); - -struct cons_pointer dec_ref( struct cons_pointer pointer ); - -/** - * given a cons_pointer as argument, return the tag. - */ -uint32_t get_tag_value( struct cons_pointer pointer ); - -struct cons_pointer c_type( struct cons_pointer pointer ); - -struct cons_pointer c_car( struct cons_pointer arg ); - -struct cons_pointer c_cdr( struct cons_pointer arg ); - -int c_length( struct cons_pointer arg ); - -struct cons_pointer make_cons( struct cons_pointer car, - struct cons_pointer cdr ); - -struct cons_pointer make_exception( struct cons_pointer message, - struct cons_pointer frame_pointer ); - -struct cons_pointer make_function( struct cons_pointer src, - struct cons_pointer ( *executable ) - ( struct stack_frame *, - struct cons_pointer, - struct cons_pointer ) ); - -struct cons_pointer c_string_to_lisp_keyword( char32_t *symbol ); - -struct cons_pointer make_lambda( struct cons_pointer args, - struct cons_pointer body ); - -struct cons_pointer make_nlambda( struct cons_pointer args, - struct cons_pointer body ); - -struct cons_pointer make_special( struct cons_pointer src, - struct cons_pointer ( *executable ) - ( struct stack_frame *, - struct cons_pointer, - struct cons_pointer ) ); - -struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, - uint32_t tag ); - -struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); - -struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - uint32_t tag ); - -#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV)) - -#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV)) - -struct cons_pointer make_read_stream( URL_FILE * input, - struct cons_pointer metadata ); - -struct cons_pointer make_write_stream( URL_FILE * output, - struct cons_pointer metadata ); - -struct cons_pointer c_string_to_lisp_string( char32_t *string ); - -struct cons_pointer c_string_to_lisp_symbol( char32_t *symbol ); - -#endif diff --git a/archive/c/memory/cursor.c b/archive/c/memory/cursor.c deleted file mode 100644 index 31a38b2..0000000 --- a/archive/c/memory/cursor.c +++ /dev/null @@ -1,9 +0,0 @@ -/* - * a cursor is a cons-space object which holds: - * 1. a pointer to a vector (i.e. a vector-space object which holds an - * array of `cons_pointer`); - * 2. an integer offset into that array. - * - * this provides a mechanism for iterating through vectors (actually, in - * either direction) - */ diff --git a/archive/c/memory/cursor.h b/archive/c/memory/cursor.h deleted file mode 100644 index a50aff600d3015faae07bdd40e47973ce43ee241..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 614 zcmZWm!A=4(6!g4b@d6hmWLeOJpvH)3xR5|Vx$c&3$rei=X}gg9dtX~H7&qC&wDac8 zbb6gm0v!Ne8;d5b2n75txMGGmiP{3k{T?+q1f~=rIj~UxU*@T3WK-&4hC6& z2rKDl-VEZmfM@H`>kez9MYCr*<@_b^XOatTMG3Vog@Nf}21j8m?S(;_bpcHmn1hBU z0T12}VcmdYj_7BqH_%Ixw%n4)7Vfyfx^&xaAx5-WN1CG$cHvj+t diff --git a/archive/c/memory/dump.c b/archive/c/memory/dump.c deleted file mode 100644 index edaf269..0000000 --- a/archive/c/memory/dump.c +++ /dev/null @@ -1,166 +0,0 @@ -/* - * dump.c - * - * Dump representations of both cons space and vector space objects. - * - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "debug.h" -#include "memory/hashmap.h" -#include "ops/intern.h" -#include "io/io.h" -#include "io/print.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" - - -void dump_string_cell( URL_FILE *output, char32_t *prefix, - struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - if ( cell.payload.string.character == 0 ) { - url_fwprintf( output, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - } else { - url_fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell.payload.string.character, - cell.payload.string.character, - cell.payload.string.hash, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - url_fwprintf( output, L"\t\t value: " ); - c_print( output, pointer ); - url_fwprintf( output, L"\n" ); - } -} - -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( URL_FILE *output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", - cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, - cell.count ); - - switch ( cell.tag.value ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d " - L"offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - c_print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, - L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - if ( !nilp( cell.payload.integer.more ) ) { - url_fputws( L"\t\tBIGNUM! More at:\n", output ); - dump_object( output, cell.payload.integer.more ); - } - break; - case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); - break; - case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - c_print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - c_print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - c_print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - c_print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); - break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - c_print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case VECTORPOINTTV:{ - url_fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); - struct vector_space_object *vso = cell.payload.vectorp.address; - url_fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size " - L"%d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - dump_frame( output, pointer ); - break; - case HASHTV: - dump_map( output, pointer ); - break; - } - } - break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - c_print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } -} diff --git a/archive/c/memory/dump.h b/archive/c/memory/dump.h deleted file mode 100644 index e3a4fc2..0000000 --- a/archive/c/memory/dump.h +++ /dev/null @@ -1,27 +0,0 @@ -/* - * dump.h - * - * Dump representations of both cons space and vector space objects. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#ifndef __dump_h -#define __dump_h - -void dump_string_cell( URL_FILE * output, char32_t *prefix, - struct cons_pointer pointer ); - -void dump_object( URL_FILE * output, struct cons_pointer pointer ); - -#endif diff --git a/archive/c/memory/hashmap.c b/archive/c/memory/hashmap.c deleted file mode 100644 index 96baf39..0000000 --- a/archive/c/memory/hashmap.c +++ /dev/null @@ -1,152 +0,0 @@ -/* - * hashmap.c - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "arith/integer.h" -#include "arith/peano.h" -#include "authorise.h" -#include "debug.h" -#include "ops/intern.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/hashmap.h" -#include "memory/vectorspace.h" - - -/** - * A lisp function signature conforming wrapper around get_hash, q.v.. - */ -struct cons_pointer lisp_get_hash( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( get_hash( frame->arg[0] ), NIL ); -} - -/** - * Lisp funtion of up to four args (all optional), where - * - * first is expected to be an integer, the number of buckets, or nil; - * second is expected to be a hashing function, or nil; - * third is expected to be an assocable, or nil; - * fourth is a list of user tokens, to be used as a write ACL, or nil. - */ -struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - uint32_t n = DFLT_HASHMAP_BUCKETS; - struct cons_pointer hash_fn = NIL; - struct cons_pointer result = NIL; - - if ( frame->args > 0 ) { - if ( integerp( frame->arg[0] ) ) { - n = to_long_int( frame->arg[0] ) % UINT32_MAX; - } else if ( !nilp( frame->arg[0] ) ) { - result = - make_exception( c_string_to_lisp_string - ( L"First arg to `hashmap`, if passed, must " - L"be an integer or `nil`.`" ), NIL ); - } - } - if ( frame->args > 1 ) { - if ( functionp( frame->arg[1] ) ) { - hash_fn = frame->arg[1]; - } else if ( nilp( frame->arg[1] ) ) { - /* that's allowed */ - } else { - result = - make_exception( c_string_to_lisp_string - ( L"Second arg to `hashmap`, if passed, must " - L"be a function or `nil`.`" ), NIL ); - } - } - - if ( nilp( result ) ) { - /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which - * is fine */ - result = make_hashmap( n, hash_fn, frame->arg[3] ); - struct vector_space_object *map = pointer_to_vso( result ); - - if ( frame->args > 2 && - truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { - // then arg[2] ought to be an assoc list which we should iterate down - // populating the hashmap. - for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); - cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer key = c_car( pair ); - struct cons_pointer val = c_cdr( pair ); - - uint32_t bucket_no = - get_hash( key ) % ( ( struct hashmap_payload * ) - &( map->payload ) )->n_buckets; - - map->payload.hashmap.buckets[bucket_no] = - make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] ); - } - } - } - - return result; -} - -/** - * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be - * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be - * any value. 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 lisp_hashmap_put( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - // TODO: if current user has write access to this hashmap - - struct cons_pointer mapp = frame->arg[0]; - struct cons_pointer key = frame->arg[1]; - struct cons_pointer val = frame->arg[2]; - - struct cons_pointer result = hashmap_put( mapp, key, val ); - struct cons_space_object *cell = &pointer2cell( result ); - return result; - - // TODO: else clone and return clone. -} - -/** - * Lisp function expecting two arguments, a hashmap and an assoc list. Copies all - * key/value pairs from the assoc list into the map. - */ -struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return hashmap_put_all( frame->arg[0], frame->arg[1] ); -} - -struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return hashmap_keys( frame->arg[0] ); -} - -void dump_map( URL_FILE *output, struct cons_pointer pointer ) { - struct hashmap_payload *payload = - &pointer_to_vso( pointer )->payload.hashmap; - url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); - url_fwprintf( output, L"\tHash function: " ); - c_print( output, payload->hash_fn ); - url_fwprintf( output, L"\n\tWrite ACL: " ); - c_print( output, payload->write_acl ); - url_fwprintf( output, L"\n\tBuckets:" ); - for ( int i = 0; i < payload->n_buckets; i++ ) { - url_fwprintf( output, L"\n\t\t[%d]: ", i ); - c_print( output, payload->buckets[i] ); - } - url_fwprintf( output, L"\n" ); -} diff --git a/archive/c/memory/hashmap.h b/archive/c/memory/hashmap.h deleted file mode 100644 index 05823bb..0000000 --- a/archive/c/memory/hashmap.h +++ /dev/null @@ -1,38 +0,0 @@ -/* - * hashmap.h - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_hashmap_h -#define __psse_hashmap_h - -#include "arith/integer.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/vectorspace.h" - -#define DFLT_HASHMAP_BUCKETS 32 - - -struct cons_pointer lisp_get_hash( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - - -#endif diff --git a/archive/c/memory/lookup3.c b/archive/c/memory/lookup3.c deleted file mode 100644 index 043d703..0000000 --- a/archive/c/memory/lookup3.c +++ /dev/null @@ -1,1281 +0,0 @@ -/* -------------------------------------------------------------------------------- -lookup3.c, by Bob Jenkins, May 2006, Public Domain. - -These are functions for producing 32-bit hashes for hash table lookup. -hashword(), hashlittle(), hashlittle2(), hashbig(), mix(), and final() -are externally useful functions. Routines to test the hash are included -if SELF_TEST is defined. You can use this free for any purpose. It's in -the public domain. It has no warranty. - -You probably want to use hashlittle(). hashlittle() and hashbig() -hash byte arrays. hashlittle() is is faster than hashbig() on -little-endian machines. Intel and AMD are little-endian machines. -On second thought, you probably want hashlittle2(), which is identical to -hashlittle() except it returns two 32-bit hashes for the price of one. -You could implement hashbig2() if you wanted but I haven't bothered here. - -If you want to find a hash of, say, exactly 7 integers, do - a = i1; b = i2; c = i3; - mix(a,b,c); - a += i4; b += i5; c += i6; - mix(a,b,c); - a += i7; - final(a,b,c); -then use c as the hash value. If you have a variable length array of -4-byte integers to hash, use hashword(). If you have a byte array (like -a character string), use hashlittle(). If you have several byte arrays, or -a mix of things, see the comments above hashlittle(). - -Why is this so big? I read 12 bytes at a time into 3 4-byte integers, -then mix those integers. This is fast (you can do a lot more thorough -mixing with 12*3 instructions on 3 integers than you can with 3 instructions -on 1 byte), but shoehorning those bytes into integers efficiently is messy. -------------------------------------------------------------------------------- -*/ -// #define SELF_TEST 1 - -#include /* defines printf for tests */ -#include /* defines time_t for timings in the test */ -#include /* defines uint32_t etc */ -#include /* attempt to define endianness */ -#ifdef linux -#include /* attempt to define endianness */ -#endif - -/* - * My best guess at if you are big-endian or little-endian. This may - * need adjustment. - */ -#if (defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && \ - __BYTE_ORDER == __LITTLE_ENDIAN) || \ - (defined(i386) || defined(__i386__) || defined(__i486__) || \ - defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) -#define HASH_LITTLE_ENDIAN 1 -#define HASH_BIG_ENDIAN 0 -#elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ - __BYTE_ORDER == __BIG_ENDIAN) || \ - (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 1 -#else -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 0 -#endif - -#define hashsize(n) ((uint32_t)1<<(n)) -#define hashmask(n) (hashsize(n)-1) -#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k)))) - -/* -------------------------------------------------------------------------------- -mix -- mix 3 32-bit values reversibly. - -This is reversible, so any information in (a,b,c) before mix() is -still in (a,b,c) after mix(). - -If four pairs of (a,b,c) inputs are run through mix(), or through -mix() in reverse, there are at least 32 bits of the output that -are sometimes the same for one pair and different for another pair. -This was tested for: -* pairs that differed by one bit, by two bits, in any combination - of top bits of (a,b,c), or in any combination of bottom bits of - (a,b,c). -* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed - the output delta to a Gray code (a^(a>>1)) so a string of 1's (as - is commonly produced by subtraction) look like a single 1-bit - difference. -* the base values were pseudorandom, all zero but one bit set, or - all zero plus a counter that starts at zero. - -Some k values for my "a-=c; a^=rot(c,k); c+=b;" arrangement that -satisfy this are - 4 6 8 16 19 4 - 9 15 3 18 27 15 - 14 9 3 7 17 3 -Well, "9 15 3 18 27 15" didn't quite get 32 bits diffing -for "differ" defined as + with a one-bit base and a two-bit delta. I -used http://burtleburtle.net/bob/hash/avalanche.html to choose -the operations, constants, and arrangements of the variables. - -This does not achieve avalanche. There are input bits of (a,b,c) -that fail to affect some output bits of (a,b,c), especially of a. The -most thoroughly mixed value is c, but it doesn't really even achieve -avalanche in c. - -This allows some parallelism. Read-after-writes are good at doubling -the number of bits affected, so the goal of mixing pulls in the opposite -direction as the goal of parallelism. I did what I could. Rotates -seem to cost as much as shifts on every machine I could lay my hands -on, and rotates are much kinder to the top and bottom bits, so I used -rotates. -------------------------------------------------------------------------------- -*/ -#define mix(a,b,c) \ -{ \ - a -= c; a ^= rot(c, 4); c += b; \ - b -= a; b ^= rot(a, 6); a += c; \ - c -= b; c ^= rot(b, 8); b += a; \ - a -= c; a ^= rot(c,16); c += b; \ - b -= a; b ^= rot(a,19); a += c; \ - c -= b; c ^= rot(b, 4); b += a; \ -} - -/* -------------------------------------------------------------------------------- -final -- final mixing of 3 32-bit values (a,b,c) into c - -Pairs of (a,b,c) values differing in only a few bits will usually -produce values of c that look totally different. This was tested for -* pairs that differed by one bit, by two bits, in any combination - of top bits of (a,b,c), or in any combination of bottom bits of - (a,b,c). -* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed - the output delta to a Gray code (a^(a>>1)) so a string of 1's (as - is commonly produced by subtraction) look like a single 1-bit - difference. -* the base values were pseudorandom, all zero but one bit set, or - all zero plus a counter that starts at zero. - -These constants passed: - 14 11 25 16 4 14 24 - 12 14 25 16 4 14 24 -and these came close: - 4 8 15 26 3 22 24 - 10 8 15 26 3 22 24 - 11 8 15 26 3 22 24 -------------------------------------------------------------------------------- -*/ -#define final(a,b,c) \ -{ \ - c ^= b; c -= rot(b,14); \ - a ^= c; a -= rot(c,11); \ - b ^= a; b -= rot(a,25); \ - c ^= b; c -= rot(b,16); \ - a ^= c; a -= rot(c,4); \ - b ^= a; b -= rot(a,14); \ - c ^= b; c -= rot(b,24); \ -} - -/* --------------------------------------------------------------------- - This works on all machines. To be useful, it requires - -- that the key be an array of uint32_t's, and - -- that the length be the number of uint32_t's in the key - - The function hashword() is identical to hashlittle() on little-endian - machines, and identical to hashbig() on big-endian machines, - except that the length has to be measured in uint32_ts rather than in - bytes. hashlittle() is more complicated than hashword() only because - hashlittle() has to dance around fitting the key bytes into registers. --------------------------------------------------------------------- -*/ -uint32_t hashword( const uint32_t *k, /* the key, an array of uint32_t values */ - size_t length, /* the length of the key, in uint32_ts */ - uint32_t initval ) { /* the previous hash, or an arbitrary value */ - uint32_t a, b, c; - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( ( uint32_t ) length ) << 2 ) + initval; - - /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } - - /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } - /*------------------------------------------------------ report the result */ - return c; -} - - -/* --------------------------------------------------------------------- -hashword2() -- same as hashword(), but take two seeds and return two -32-bit values. pc and pb must both be nonnull, and *pc and *pb must -both be initialized with seeds. If you pass in (*pb)==0, the output -(*pc) will be the same as the return value from hashword(). --------------------------------------------------------------------- -*/ -void hashword2( const uint32_t *k, /* the key, an array of uint32_t values */ - size_t length, /* the length of the key, in uint32_ts */ - uint32_t *pc, /* IN: seed OUT: primary hash value */ - uint32_t *pb ) { /* IN: more seed OUT: secondary hash value */ - uint32_t a, b, c; - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) ( length << 2 ) ) + *pc; - c += *pb; - - /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } - - /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } - /*------------------------------------------------------ report the result */ - *pc = c; - *pb = b; -} - - -/* -------------------------------------------------------------------------------- -hashlittle() -- hash a variable-length key into a 32-bit value - k : the key (the unaligned variable-length array of bytes) - length : the length of the key, counting by bytes - initval : can be any 4-byte value -Returns a 32-bit value. Every bit of the key affects every bit of -the return value. Two keys differing by one or two bits will have -totally different hash values. - -The best hash table sizes are powers of 2. There is no need to do -mod a prime (mod is sooo slow!). If you need less than 32 bits, -use a bitmask. For example, if you need only 10 bits, do - h = (h & hashmask(10)); -In which case, the hash table should have hashsize(10) elements. - -If you are hashing n strings (uint8_t **)k, do it like this: - for (i=0, h=0; i 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - return c; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - return c; - } - -#endif /* !valgrind */ - - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; - - /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - return c; /* zero length requires no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - return c; - } - } - - final( a, b, c ); - return c; -} - - -/* - * hashlittle2: return 2 32-bit hash values - * - * This is identical to hashlittle(), except it returns two 32-bit hash - * values instead of just one. This is good enough for hash table - * lookup with 2^^64 buckets, or if you want a second hash if you're not - * happy with the first, or if you want a probably-unique 64-bit ID for - * the key. *pc is better mixed than *pb, so use *pc first. If you want - * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". - */ -void hashlittle2( const void *key, /* the key to hash */ - size_t length, /* length of the key */ - uint32_t *pc, /* IN: primary initval, OUT: primary hash */ - uint32_t *pb ) { /* IN: secondary initval, OUT: secondary hash */ - uint32_t a, b, c; /* internal state */ - union { - const void *ptr; - size_t i; - } u; /* needed for Mac Powerbook G4 */ - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + *pc; - c += *pb; - - u.ptr = key; - if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; - - /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - -#endif /* !valgrind */ - - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; - - /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - } - - final( a, b, c ); - *pc = c; - *pb = b; -} - - - -/* - * hashbig(): - * This is the same as hashword() on big-endian machines. It is different - * from hashlittle() on all machines. hashbig() takes advantage of - * big-endian byte ordering. - */ -uint32_t hashbig( const void *key, size_t length, uint32_t initval ) { - uint32_t a, b, c; - union { - const void *ptr; - size_t i; - } u; /* to cast key to (size_t) happily */ - - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - - u.ptr = key; - if ( HASH_BIG_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; - - /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } - - /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]<<8" actually reads beyond the end of the string, but - * then shifts out the part it's not allowed to read. Because the - * string is aligned, the illegal read is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ -#ifndef VALGRIND - - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff00; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff0000; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff000000; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff00; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff0000; - a += k[0]; - break; - case 5: - b += k[1] & 0xff000000; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff00; - break; - case 2: - a += k[0] & 0xffff0000; - break; - case 1: - a += k[0] & 0xff000000; - break; - case 0: - return c; /* zero length strings require no mixing */ - } - -#else /* make valgrind happy */ - - k8 = ( const uint8_t * ) k; - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 8; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 16; /* fall through */ - case 9: - c += ( ( uint32_t ) k8[8] ) << 24; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 8; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 16; /* fall through */ - case 5: - b += ( ( uint32_t ) k8[4] ) << 24; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 8; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 16; /* fall through */ - case 1: - a += ( ( uint32_t ) k8[0] ) << 24; - break; - case 0: - return c; - } - -#endif /* !VALGRIND */ - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += ( ( uint32_t ) k[0] ) << 24; - a += ( ( uint32_t ) k[1] ) << 16; - a += ( ( uint32_t ) k[2] ) << 8; - a += ( ( uint32_t ) k[3] ); - b += ( ( uint32_t ) k[4] ) << 24; - b += ( ( uint32_t ) k[5] ) << 16; - b += ( ( uint32_t ) k[6] ) << 8; - b += ( ( uint32_t ) k[7] ); - c += ( ( uint32_t ) k[8] ) << 24; - c += ( ( uint32_t ) k[9] ) << 16; - c += ( ( uint32_t ) k[10] ) << 8; - c += ( ( uint32_t ) k[11] ); - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[11]; - case 11: - c += ( ( uint32_t ) k[10] ) << 8; - case 10: - c += ( ( uint32_t ) k[9] ) << 16; - case 9: - c += ( ( uint32_t ) k[8] ) << 24; - case 8: - b += k[7]; - case 7: - b += ( ( uint32_t ) k[6] ) << 8; - case 6: - b += ( ( uint32_t ) k[5] ) << 16; - case 5: - b += ( ( uint32_t ) k[4] ) << 24; - case 4: - a += k[3]; - case 3: - a += ( ( uint32_t ) k[2] ) << 8; - case 2: - a += ( ( uint32_t ) k[1] ) << 16; - case 1: - a += ( ( uint32_t ) k[0] ) << 24; - break; - case 0: - return c; - } - } - - final( a, b, c ); - return c; -} - - -#ifdef SELF_TEST - -/* used for timings */ -void driver1( ) { - uint8_t buf[256]; - uint32_t i; - uint32_t h = 0; - time_t a, z; - - time( &a ); - for ( i = 0; i < 256; ++i ) - buf[i] = 'x'; - for ( i = 0; i < 1; ++i ) { - h = hashlittle( &buf[0], 1, h ); - } - time( &z ); - if ( z - a > 0 ) - printf( "time %d %.8x\n", z - a, h ); -} - -/* check that every input bit changes every output bit half the time */ -#define HASHSTATE 1 -#define HASHLEN 1 -#define MAXPAIR 60 -#define MAXLEN 70 -void driver2( ) { - uint8_t qa[MAXLEN + 1], qb[MAXLEN + 2], *a = &qa[0], *b = &qb[1]; - uint32_t c[HASHSTATE], d[HASHSTATE], i = 0, j = 0, k, l, m = 0, z; - uint32_t e[HASHSTATE], f[HASHSTATE], g[HASHSTATE], h[HASHSTATE]; - uint32_t x[HASHSTATE], y[HASHSTATE]; - uint32_t hlen; - - printf( "No more than %d trials should ever be needed \n", MAXPAIR / 2 ); - for ( hlen = 0; hlen < MAXLEN; ++hlen ) { - z = 0; - for ( i = 0; i < hlen; ++i ) { -/*----------------------- for each input byte, */ - for ( j = 0; j < 8; ++j ) { -/*------------------------ for each input bit, */ - for ( m = 1; m < 8; ++m ) { -/*------------ for serveral possible initvals, */ - for ( l = 0; l < HASHSTATE; ++l ) - e[l] = f[l] = g[l] = h[l] = x[l] = y[l] = - ~( ( uint32_t ) 0 ); - - /*---- check that every output bit is affected by that input bit */ - for ( k = 0; k < MAXPAIR; k += 2 ) { - uint32_t finished = 1; - /* keys have one bit different */ - for ( l = 0; l < hlen + 1; ++l ) { - a[l] = b[l] = ( uint8_t ) 0; - } - /* have a and b be two keys differing in only one bit */ - a[i] ^= ( k << j ); - a[i] ^= ( k >> ( 8 - j ) ); - c[0] = hashlittle( a, hlen, m ); - b[i] ^= ( ( k + 1 ) << j ); - b[i] ^= ( ( k + 1 ) >> ( 8 - j ) ); - d[0] = hashlittle( b, hlen, m ); - /* check every bit is 1, 0, set, and not set at least once */ - for ( l = 0; l < HASHSTATE; ++l ) { - e[l] &= ( c[l] ^ d[l] ); - f[l] &= ~( c[l] ^ d[l] ); - g[l] &= c[l]; - h[l] &= ~c[l]; - x[l] &= d[l]; - y[l] &= ~d[l]; - if ( e[l] | f[l] | g[l] | h[l] | x[l] | y[l] ) - finished = 0; - } - if ( finished ) - break; - } - if ( k > z ) - z = k; - if ( k == MAXPAIR ) { - printf( "Some bit didn't change: " ); - printf( "%.8x %.8x %.8x %.8x %.8x %.8x ", - e[0], f[0], g[0], h[0], x[0], y[0] ); - printf( "i %d j %d m %d len %d\n", i, j, m, hlen ); - } - if ( z == MAXPAIR ) - goto done; - } - } - } - done: - if ( z < MAXPAIR ) { - printf( "Mix success %2d bytes %2d initvals ", i, m ); - printf( "required %d trials\n", z / 2 ); - } - } - printf( "\n" ); -} - -/* Check for reading beyond the end of the buffer and alignment problems */ -void driver3( ) { - uint8_t buf[MAXLEN + 20], *b; - uint32_t len; - uint8_t q[] = - "This is the time for all good men to come to the aid of their country..."; - uint32_t h; - uint8_t qq[] = - "xThis is the time for all good men to come to the aid of their country..."; - uint32_t i; - uint8_t qqq[] = - "xxThis is the time for all good men to come to the aid of their country..."; - uint32_t j; - uint8_t qqqq[] = - "xxxThis is the time for all good men to come to the aid of their country..."; - uint32_t ref, x, y; - uint8_t *p; - - printf - ( "Endianness. These lines should all be the same (for values filled in):\n" ); - printf - ( "%.8x %.8x %.8x\n", - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 1 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 5 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 9 ) / 4, 13 ) ); - p = q; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qq[1]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqq[2]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqqq[3]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - printf( "\n" ); - - /* check that hashlittle2 and hashlittle produce the same results */ - i = 47; - j = 0; - hashlittle2( q, sizeof( q ), &i, &j ); - if ( hashlittle( q, sizeof( q ), 47 ) != i ) - printf( "hashlittle2 and hashlittle mismatch\n" ); - - /* check that hashword2 and hashword produce the same results */ - len = 0xdeadbeef; - i = 47, j = 0; - hashword2( &len, 1, &i, &j ); - if ( hashword( &len, 1, 47 ) != i ) - printf( "hashword2 and hashword mismatch %x %x\n", - i, hashword( &len, 1, 47 ) ); - - /* check hashlittle doesn't read before or after the ends of the string */ - for ( h = 0, b = buf + 1; h < 8; ++h, ++b ) { - for ( i = 0; i < MAXLEN; ++i ) { - len = i; - for ( j = 0; j < i; ++j ) - *( b + j ) = 0; - - /* these should all be equal */ - ref = hashlittle( b, len, ( uint32_t ) 1 ); - *( b + i ) = ( uint8_t ) ~ 0; - *( b - 1 ) = ( uint8_t ) ~ 0; - x = hashlittle( b, len, ( uint32_t ) 1 ); - y = hashlittle( b, len, ( uint32_t ) 1 ); - if ( ( ref != x ) || ( ref != y ) ) { - printf( "alignment error: %.8x %.8x %.8x %d %d\n", ref, x, y, - h, i ); - } - } - } -} - -/* check for problems with nulls */ -void driver4( ) { - uint8_t buf[1]; - uint32_t h, i, state[HASHSTATE]; - - - buf[0] = ~0; - for ( i = 0; i < HASHSTATE; ++i ) - state[i] = 1; - printf( "These should all be different\n" ); - for ( i = 0, h = 0; i < 8; ++i ) { - h = hashlittle( buf, 0, h ); - printf( "%2ld 0-byte strings, hash is %.8x\n", i, h ); - } -} - -void driver5( ) { - uint32_t b, c; - b = 0, c = 0, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* deadbeef deadbeef */ - b = 0xdeadbeef, c = 0, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* bd5b7dde deadbeef */ - b = 0xdeadbeef, c = 0xdeadbeef, hashlittle2( "", 0, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* 9c093ccd bd5b7dde */ - b = 0, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* 17770551 ce7226e6 */ - b = 1, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* e3607cae bd371de4 */ - b = 0, c = 1, hashlittle2( "Four score and seven years ago", 30, &c, &b ); - printf( "hash is %.8lx %.8lx\n", c, b ); /* cd628161 6cbea4b3 */ - c = hashlittle( "Four score and seven years ago", 30, 0 ); - printf( "hash is %.8lx\n", c ); /* 17770551 */ - c = hashlittle( "Four score and seven years ago", 30, 1 ); - printf( "hash is %.8lx\n", c ); /* cd628161 */ -} - - -int main( ) { - driver1( ); /* test that the key is hashed: used for timings */ - driver2( ); /* test that whole key is hashed thoroughly */ - driver3( ); /* test that nothing but the key is hashed */ - driver4( ); /* test hashing multiple buffers (all buffers are null) */ - driver5( ); /* test the hash against known vectors */ - return 1; -} - -#endif /* SELF_TEST */ diff --git a/archive/c/memory/lookup3.h b/archive/c/memory/lookup3.h deleted file mode 100644 index 6df9447..0000000 --- a/archive/c/memory/lookup3.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * lookup3.h - * - * Minimal header file wrapping Bob Jenkins' lookup3.c - * - * - * (c) 2019 Simon Brooke - * Public domain. - */ - -#ifndef __lookup3_h -#define __lookup3_h - -uint32_t hashword( const uint32_t * k, size_t length, uint32_t initval ); - -#endif diff --git a/archive/c/memory/stack.c b/archive/c/memory/stack.c deleted file mode 100644 index 9b8df3e..0000000 --- a/archive/c/memory/stack.c +++ /dev/null @@ -1,380 +0,0 @@ -/* - * stack.c - * - * The Lisp evaluation stack. - * - * Stack frames could be implemented in cons space; indeed, the stack - * could simply be an assoc list consed onto the front of the environment. - * But such a stack would be costly to search. The design sketched here, - * with stack frames as special objects, SHOULD be substantially more - * efficient, but does imply we need to generalise the idea of cons pages - * with freelists to a more general 'equal sized object pages', so that - * allocating/freeing stack frames can be more efficient. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#include "debug.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/dump.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "ops/lispops.h" - -/** - * @brief If non-zero, maximum depth of stack. - * - */ -uint32_t stack_limit = 0; - -/** - * set a register in a stack frame. Alwaye use this to do so, - * because that way we can be sure the inc_ref happens! - */ -void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { - debug_printf( DEBUG_STACK, L"\tSetting register %d to ", reg ); - debug_print_object( value, DEBUG_STACK ); - debug_println( DEBUG_STACK ); - dec_ref( frame->arg[reg] ); /* if there was anything in that slot - * previously other than NIL, we need to decrement it; - * NIL won't be decremented as it is locked. */ - frame->arg[reg] = value; - inc_ref( value ); - - if ( reg == frame->args ) { - frame->args++; - } -} - - -/** - * get the actual stackframe object from this `pointer`, or NULL if - * `pointer` is not a stackframe pointer. - */ -struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { - struct stack_frame *result = NULL; - struct vector_space_object *vso = - pointer2cell( pointer ).payload.vectorp.address; - - if ( vectorpointp( pointer ) && stackframep( vso ) ) { - result = ( struct stack_frame * ) &( vso->payload ); - // debug_printf( DEBUG_STACK, - // L"\nget_stack_frame: all good, returning %p\n", result ); - } else { - debug_print( L"\nget_stack_frame: fail, returning NULL\n", - DEBUG_STACK ); - } - - return result; -} - -/** - * Make an empty stack frame, and return it. - * - * This function does the actual meat of making the frame. - * - * @param previous the current top-of-stack; - * @param depth the depth of the new frame. - * @return the new frame, or NULL if memory is exhausted. - */ -struct cons_pointer in_make_empty_frame( struct cons_pointer previous, - uint32_t depth ) { - debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); - struct cons_pointer result = - make_vso( STACKFRAMETV, sizeof( struct stack_frame ) ); - - if ( !nilp( result ) ) { - struct stack_frame *frame = get_stack_frame( result ); - /* - * \todo later, pop a frame off a free-list of stack frames - */ - - frame->previous = previous; - frame->depth = depth; - - /* - * The frame has already been cleared with memset in make_vso, but our - * NIL is not the same as C's NULL. - */ - frame->more = NIL; - frame->function = NIL; - frame->args = 0; - - for ( int i = 0; i < args_in_frame; i++ ) { - frame->arg[i] = NIL; - } - - debug_dump_object( result, DEBUG_ALLOC ); - } - debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); - debug_dump_object( result, DEBUG_ALLOC ); - - return result; -} - -/** - * @brief Make an empty stack frame, and return it. - * - * This function does the error checking around actual construction. - * - * @param previous the current top-of-stack; - * @param env the environment in which evaluation happens. - * @return the new frame, or NULL if memory is exhausted. - */ -struct cons_pointer make_empty_frame( struct cons_pointer previous ) { - struct cons_pointer result = NIL; - uint32_t depth = - ( nilp( previous ) ) ? 0 : ( get_stack_frame( previous ) )->depth + 1; - - if ( stack_limit == 0 || stack_limit > depth ) { - result = in_make_empty_frame( previous, depth ); - } else { - debug_printf( DEBUG_STACK, - L"WARNING: Exceeded stack limit of %d\n", stack_limit ); - result = - make_exception( c_string_to_lisp_string - ( L"Stack limit exceeded." ), previous ); - } - - if ( nilp( result ) ) { - /* i.e. out of memory */ - result = - make_exception( privileged_string_memory_exhausted, previous ); - } - - return result; -} - -/** - * Allocate a new stack frame with its previous pointer set to this value, - * its arguments set up from these args, evaluated in this env. - * @param previous the current top-of-stack; - * @args the arguments to load into this frame; - * @param env the environment in which evaluation happens. - * @return the new frame, or an exception if one occurred while building it. - */ -struct cons_pointer make_stack_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ) { - debug_print( L"Entering make_stack_frame\n", DEBUG_STACK ); - struct cons_pointer result = make_empty_frame( previous ); - - if ( !exceptionp( result ) ) { - struct stack_frame *frame = get_stack_frame( result ); - - while ( frame->args < args_in_frame && consp( args ) ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ - struct cons_space_object cell = pointer2cell( args ); - - /* - * \todo if we were running on real massively parallel hardware, - * each arg except the first should be handed off to another - * processor to be evaled in parallel; but see notes here: - * https://github.com/simon-brooke/post-scarcity/wiki/parallelism - */ - struct cons_pointer val = - eval_form( frame, result, cell.payload.cons.car, env ); - if ( exceptionp( val ) ) { - result = val; - break; - } else { - debug_printf( DEBUG_STACK, L"\tSetting argument %d to ", - frame->args ); - debug_print_object( cell.payload.cons.car, DEBUG_STACK ); - debug_print( L"\n", DEBUG_STACK ); - set_reg( frame, frame->args, val ); - } - - args = cell.payload.cons.cdr; - } - - if ( !exceptionp( result ) ) { - if ( consp( args ) ) { - /* if we still have args, eval them and stick the values on `more` */ - struct cons_pointer more = - eval_forms( get_stack_frame( previous ), previous, args, - env ); - frame->more = more; - inc_ref( more ); - - for ( ; !nilp( args ); args = c_cdr( args ) ) { - frame->args++; - } - } - } - debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); - debug_dump_object( result, DEBUG_STACK ); - } - - return result; -} - -/** - * A 'special' frame is exactly like a normal stack frame except that the - * arguments are unevaluated. - * @param previous the previous stack frame; - * @param args a list of the arguments to be stored in this stack frame; - * @param env the execution environment; - * @return a new special frame. - */ -struct cons_pointer make_special_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ) { - debug_print( L"Entering make_special_frame\n", DEBUG_STACK ); - - struct cons_pointer result = make_empty_frame( previous ); - - if ( !exceptionp( result ) ) { - struct stack_frame *frame = get_stack_frame( result ); - - while ( frame->args < args_in_frame && !nilp( args ) ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ - struct cons_space_object cell = pointer2cell( args ); - - set_reg( frame, frame->args, cell.payload.cons.car ); - - args = cell.payload.cons.cdr; - } - if ( !exceptionp( result ) ) { - if ( consp( args ) ) { - frame->more = args; - inc_ref( args ); - } - } - } - debug_print( L"make_special_frame: returning\n", DEBUG_STACK ); - debug_dump_object( result, DEBUG_STACK ); - - return result; -} - -/** - * Free this stack frame. - */ -void free_stack_frame( struct stack_frame *frame ) { - /* - * \todo later, push it back on the stack-frame freelist - */ - debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); - for ( int i = 0; i < args_in_frame; i++ ) { - dec_ref( frame->arg[i] ); - } - if ( !nilp( frame->more ) ) { - dec_ref( frame->more ); - } - debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); -} - -struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) { - struct stack_frame *frame = get_stack_frame( frame_pointer ); - struct cons_pointer result = NIL; - - if ( frame != NULL ) { - result = frame->previous; - } - - return result; -} - -void dump_frame_context_fragment( URL_FILE *output, - struct cons_pointer frame_pointer ) { - struct stack_frame *frame = get_stack_frame( frame_pointer ); - - if ( frame != NULL ) { - url_fwprintf( output, L" <= " ); - c_print( output, frame->arg[0] ); - } -} - -void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer, - int depth ) { - struct stack_frame *frame = get_stack_frame( frame_pointer ); - - if ( frame != NULL ) { - url_fwprintf( output, L"\tContext: " ); - - int i = 0; - for ( struct cons_pointer cursor = frame_pointer; - i++ < depth && !nilp( cursor ); - cursor = frame_get_previous( cursor ) ) { - dump_frame_context_fragment( output, cursor ); - } - - url_fwprintf( output, L"\n" ); - } -} - -/** - * Dump a stackframe to this stream for debugging - * @param output the stream - * @param frame_pointer the pointer to the frame - */ -void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) { - struct stack_frame *frame = get_stack_frame( frame_pointer ); - - if ( frame != NULL ) { - url_fwprintf( output, L"Stack frame %d with %d arguments:\n", - frame->depth, frame->args ); - dump_frame_context( output, frame_pointer, 4 ); - - for ( int arg = 0; arg < frame->args; arg++ ) { - struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - - url_fwprintf( output, L"\tArg %d:\t%4.4s\tcount: %10u\tvalue: ", - arg, cell.tag.bytes, cell.count ); - - c_print( output, frame->arg[arg] ); - url_fputws( L"\n", output ); - } - if ( !nilp( frame->more ) ) { - url_fputws( L"More: \t", output ); - c_print( output, frame->more ); - url_fputws( L"\n", output ); - } - } -} - -void dump_stack_trace( URL_FILE *output, struct cons_pointer pointer ) { - if ( exceptionp( pointer ) ) { - c_print( output, pointer2cell( pointer ).payload.exception.payload ); - url_fputws( L"\n", output ); - dump_stack_trace( output, - pointer2cell( pointer ).payload.exception.frame ); - } else { - while ( vectorpointp( pointer ) - && stackframep( pointer_to_vso( pointer ) ) ) { - dump_frame( output, pointer ); - pointer = get_stack_frame( pointer )->previous; - } - } -} - -/** - * 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/archive/c/memory/stack.h b/archive/c/memory/stack.h deleted file mode 100644 index 111df48..0000000 --- a/archive/c/memory/stack.h +++ /dev/null @@ -1,69 +0,0 @@ -/** - * stack.h - * - * The Lisp evaluation stack. - * - * Stack frames could be implemented in cons space; indeed, the stack - * could simply be an assoc list consed onto the front of the environment. - * But such a stack would be costly to search. The design sketched here, - * with stack frames as special objects, SHOULD be substantially more - * efficient, but does imply we need to generalise the idea of cons pages - * with freelists to a more general 'equal sized object pages', so that - * allocating/freeing stack frames can be more efficient. - * - * Stack frames are not yet a first class object; they have no VECP pointer - * in cons space. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_stack_h -#define __psse_stack_h - -#include - -#include "consspaceobject.h" -#include "conspage.h" - -/** - * macros for the tag of a stack frame. - */ -#define STACKFRAMETAG "STAK" -#define STACKFRAMETV 1262572627 - -/** - * is this vector-space object a stack frame? - */ -#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) - -extern uint32_t stack_limit; - -void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); - -struct stack_frame *get_stack_frame( struct cons_pointer pointer ); - -struct cons_pointer make_empty_frame( struct cons_pointer previous ); - -struct cons_pointer make_stack_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ); - -void free_stack_frame( struct stack_frame *frame ); - -void dump_frame( URL_FILE * output, struct cons_pointer pointer ); - -void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer ); - -struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); - -struct cons_pointer make_special_frame( struct cons_pointer previous, - struct cons_pointer args, - struct cons_pointer env ); - -/* - * struct stack_frame is defined in consspaceobject.h to break circularity - * \todo refactor. - */ - -#endif diff --git a/archive/c/memory/vectorspace.c b/archive/c/memory/vectorspace.c deleted file mode 100644 index 26a23d9..0000000 --- a/archive/c/memory/vectorspace.c +++ /dev/null @@ -1,158 +0,0 @@ -/* - * vectorspace.c - * - * Structures common to all vector space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - - -/* - * wide characters - */ -#include -#include - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "debug.h" -#include "io/io.h" -#include "memory/hashmap.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" -#include "ops/intern.h" - - -/** - * Make a cons_space_object which points to the vector_space_object - * with this `tag` at this `address`. - * - * @address the address of the vector_space_object to point to. - * @tag the vector-space tag of the particular type of vector-space object, - * NOT `VECTORPOINTTV`. - * - * @return a cons_pointer to the object, or NIL if the object could not be - * allocated due to memory exhaustion. - */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address, - uint32_t tag ) { - debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); - struct cons_pointer pointer = allocate_cell( VECTORPOINTTV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - debug_printf( DEBUG_ALLOC, - L"make_vec_pointer: tag written, about to set pointer address to %p\n", - address ); - - cell->payload.vectorp.address = address; - cell->payload.vectorp.tag.value = tag; - - debug_printf( DEBUG_ALLOC, - L"make_vec_pointer: all good, returning pointer to %p\n", - cell->payload.vectorp.address ); - - debug_dump_object( pointer, DEBUG_ALLOC ); - - return pointer; -} - -/** - * Allocate a vector space object with this `payload_size` and `tag`, - * and return a `cons_pointer` which points to an object whigh points to it. - * - * @tag the vector-space tag of the particular type of vector-space object, - * NOT `VECTORPOINTTAG`. - * @payload_size the size of the payload required, in bytes. - * - * @return a cons_pointer to the object, or NIL if the object could not be - * allocated due to memory exhaustion. - */ -struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { - debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); - struct cons_pointer result = NIL; - int64_t total_size = sizeof( struct vector_space_header ) + payload_size; - - /* Pad size to 64 bit words. This is intended to promote access efficiancy - * on 64 bit machines but may just be voodoo coding */ - uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); - debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC ); - struct vector_space_object *vso = malloc( padded ); - - if ( vso != NULL ) { - memset( vso, 0, padded ); - vso->header.tag.value = tag; - - debug_printf( DEBUG_ALLOC, - L"make_vso: written tag '%4.4s' into vso at %p\n", - vso->header.tag.bytes, vso ); - result = make_vec_pointer( vso, tag ); - debug_dump_object( result, DEBUG_ALLOC ); - vso->header.vecp = result; - // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); - - vso->header.size = payload_size; - -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, - L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", - &vso->header.tag.bytes, total_size, vso->header.size, - vso, &vso->payload ); - if ( padded != total_size ) { - debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", - total_size, padded ); - } -#endif - } -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, - L"make_vso: all good, returning pointer to %p\n", - pointer2cell( result ).payload.vectorp.address ); -#endif - - return result; -} - -/** for vector space pointers, free the actual vector-space - * object. Dangerous! */ - -void free_vso( struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - - debug_printf( DEBUG_ALLOC, - L"About to free vector-space object of type %s at 0x%lx\n", - ( char * ) cell.payload.vectorp.tag.bytes, - cell.payload.vectorp.address ); - struct vector_space_object *vso = cell.payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case HASHTV: - free_hashmap( pointer ); - break; - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - -// free( (void *)cell.payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell.payload.vectorp.address ); -} - -// bool check_vso_tag( struct cons_pointer pointer, char * tag) { -// bool result = false; - -// if (check_tag(pointer, VECTORPOINTTAG)) { -// struct vector_space_object * vso = pointer_to_vso(pointer); -// result = strncmp( vso->header.tag.bytes[0], tag, TAGLENGTH); -// } - -// return result; -// } diff --git a/archive/c/memory/vectorspace.h b/archive/c/memory/vectorspace.h deleted file mode 100644 index 3265225..0000000 --- a/archive/c/memory/vectorspace.h +++ /dev/null @@ -1,121 +0,0 @@ -/** - * vectorspace.h - * - * Declarations common to all vector space objects. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "consspaceobject.h" -#include "hashmap.h" - -#ifndef __vectorspace_h -#define __vectorspace_h - -/* - * part of the implementation structure of a namespace. - */ -#define HASHTAG "HASH" -#define HASHTV 1213415752 - -#define hashmapp(conspoint)((check_tag(conspoint,HASHTV))) - -/* - * a namespace (i.e. a binding of names to values, implemented as a hashmap) - * TODO: but note that a namespace is now essentially a hashmap with a write ACL - * whose name is interned. - */ -#define NAMESPACETAG "NMSP" -#define NAMESPACETV 1347636558 - -#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV)) - -/* - * a vector of cons pointers. - */ -#define VECTORTAG "VECT" -#define VECTORTV 1413694806 - -#define vectorp(conspoint)(check_tag(conspoint,VECTORTV)) - -/** - * given a pointer to a vector space object, return the object. - */ -#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL)) - -/** - * given a vector space object, return its canonical pointer. - */ -#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) - -struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); - -void free_vso( struct cons_pointer pointer ); - -/** - * the header which forms the start of every vector space object. - */ -struct vector_space_header { - /** the tag (type) of this vector-space object. */ - union { - /** the tag considered as bytes. */ - char bytes[TAGLENGTH]; - /** the tag considered as a number */ - uint32_t value; - } tag; - /** back pointer to the vector pointer which uniquely points to this vso */ - struct cons_pointer vecp; - /** the size of my payload, in bytes */ - uint64_t size; -}; - -/** - * The payload of a hashmap. 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 hashmap. - */ -struct hashmap_payload { - struct cons_pointer hash_fn; /* function for hashing values in this hashmap, 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 hashmap and a - * namespace is that a hashmap 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 hashmaps. */ -}; - - -/** a vector_space_object is just a vector_space_header followed by a - * lump of bytes; what we deem to be in there is a function of the tag, - * and at this stage we don't have a good picture of what these may be. - * - * \see stack_frame for an example payload; - * \see make_empty_frame for an example of how to initialise and use one. - */ -struct vector_space_object { - /** the header of this object */ - struct vector_space_header header; - /** we'll malloc `size` bytes for payload, `payload` is just the first of these. - * \todo this is almost certainly not idiomatic C. */ - union { - /** the payload considered as bytes */ - char bytes; - struct hashmap_payload hashmap; - } payload; -}; - -#endif diff --git a/archive/c/ops/equal.c b/archive/c/ops/equal.c deleted file mode 100644 index 77e07c4..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 ( !c_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 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 ); - 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 = - 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: - 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 ) { - char32_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 ) - && c_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 a3ae93a..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 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 deleted file mode 100644 index f16733d..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 ( c_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 ( 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. - 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 3b0d5c1..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( char32_t ) * 1024; - char32_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 = - c_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 ) ) { - c_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 ); - - c_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/archive/c/repl.c b/archive/c/repl.c deleted file mode 100644 index 8ae0b43..0000000 --- a/archive/c/repl.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * repl.c - * - * the read/eval/print loop - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include - -#include "memory/consspaceobject.h" -#include "debug.h" -#include "ops/intern.h" -#include "ops/lispops.h" -#include "memory/stack.h" - -/** - * @brief Handle an interrupt signal. - * - * @param dummy - */ -void int_handler( int dummy ) { - wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); -} - -/** - * The read/eval/print loop. - */ -void repl( ) { - signal( SIGINT, int_handler ); - debug_print( L"Entered repl\n", DEBUG_REPL ); - - struct cons_pointer env = - consp( oblist ) ? oblist : make_cons( oblist, NIL ); - - /* bottom of stack */ - struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); - - if ( !nilp( frame_pointer ) ) { - lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); - - dec_ref( frame_pointer ); - } - - debug_print( L"Leaving repl\n", DEBUG_REPL ); -} diff --git a/archive/c/repl.h b/archive/c/repl.h deleted file mode 100644 index 8ff8b19..0000000 --- a/archive/c/repl.h +++ /dev/null @@ -1,29 +0,0 @@ -/* - * To change this license header, choose License Headers in Project Properties. - * To change this template file, choose Tools | Templates - * and open the template in the editor. - */ - -/* - * File: repl.h - * Author: simon - * - * Created on 14 August 2017, 14:40 - */ - -#ifndef REPL_H -#define REPL_H - -#ifdef __cplusplus -extern "C" { -#endif - -/** - * The read/eval/print loop - */ - void repl( ); - -#ifdef __cplusplus -} -#endif -#endif /* REPL_H */ diff --git a/archive/c/time/psse_time.c b/archive/c/time/psse_time.c deleted file mode 100644 index a2deb86..0000000 --- a/archive/c/time/psse_time.c +++ /dev/null @@ -1,109 +0,0 @@ -/* - * psse_time.c - * - * Bare bones of PSSE time. See issue #16. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "arith/integer.h" -#include "time/psse_time.h" -#define _GNU_SOURCE - -#define seconds_per_year 31557600L - -/** - * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before - * the UNIX epoch; the value in microseconds will break the C reader. - */ -unsigned __int128 epoch_offset = - ( ( __int128 ) ( seconds_per_year * 1000000000L ) * - ( __int128 ) ( 14L * 1000000000L ) ); - -/** - * Return the UNIX time value which represents this time, if it falls within - * the period representable in UNIX time, or zero otherwise. - */ -long int lisp_time_to_unix_time( struct cons_pointer t ) { - long int result = 0; - - if ( timep( t ) ) { - unsigned __int128 value = pointer2cell( t ).payload.time.value; - - if ( value > epoch_offset ) { // \todo && value < UNIX time rollover - result = ( ( value - epoch_offset ) / 1000000000 ); - } - } - - return result; -} - -unsigned __int128 unix_time_to_lisp_time( time_t t ) { - unsigned __int128 result = epoch_offset + ( t * 1000000000 ); - - return result; -} - -struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { - struct cons_pointer pointer = allocate_cell( TIMETV ); - struct cons_space_object *cell = &pointer2cell( pointer ); - - if ( integerp( integer_or_nil ) ) { - cell->payload.time.value = - pointer2cell( integer_or_nil ).payload.integer.value; - } else { - cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); - } - - return pointer; -} - -/** - * Function; return a time representation of the first argument in the frame; - * further arguments are ignored. - * - * * (time integer_or_nil) - * - * @param frame my stack_frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env my environment. - * @return a lisp time; if `integer_or_nil` is an integer, return a time which - * is that number of microseconds after the notional big bang; else the current - * time. - */ -struct cons_pointer lisp_time( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_time( frame->arg[0] ); -} - -/** - * This is temporary, for bootstrapping. - */ -struct cons_pointer time_to_string( struct cons_pointer pointer ) { - struct cons_pointer result = NIL; - long int t = lisp_time_to_unix_time( pointer ); - - if ( t != 0 ) { - char *bytes = ctime( &t ); - int l = strlen( bytes ) + 1; - char32_t buffer[l]; - - mbstowcs( buffer, bytes, l ); - result = c_string_to_lisp_string( buffer ); - } - - return result; -} diff --git a/archive/c/time/psse_time.h b/archive/c/time/psse_time.h deleted file mode 100644 index f2afdd2..0000000 --- a/archive/c/time/psse_time.h +++ /dev/null @@ -1,21 +0,0 @@ -/* - * psse_time.h - * - * Bare bones of PSSE time. See issue #16. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_time_h -#define __psse_time_h - -#define _GNU_SOURCE -#include "consspaceobject.h" - -struct cons_pointer lisp_time( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer time_to_string( struct cons_pointer pointer ); - -#endif diff --git a/archive/c/utils.c b/archive/c/utils.c deleted file mode 100644 index 9919dbe..0000000 --- a/archive/c/utils.c +++ /dev/null @@ -1,33 +0,0 @@ -/* - * 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/archive/c/utils.h b/archive/c/utils.h deleted file mode 100644 index 456e4d0..0000000 --- a/archive/c/utils.h +++ /dev/null @@ -1,17 +0,0 @@ -/* - * 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/archive/c/version.h b/archive/c/version.h deleted file mode 100644 index 6548d30..0000000 --- a/archive/c/version.h +++ /dev/null @@ -1,11 +0,0 @@ -/** - * version.h - * - * Just the version number. There's DEFINITELY a better way to do this! - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#define VERSION "0.0.7-SNAPSHOT" diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index f15c382..3bbb021 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -41,11 +41,11 @@ bool environment_initialised = false; struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); - struct pso_pointer frame = make_frame(0, nil); + struct pso_pointer frame_pointer = make_frame( 0, nil ); if ( c_truep( result ) ) { debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( frame, NILTAG, 2 ); + struct pso_pointer n = allocate( frame_pointer, NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { struct pso2 *object = pointer_to_object( n ); @@ -62,7 +62,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { } if ( !c_nilp( result ) ) { debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); - struct pso_pointer n = allocate( frame, TRUETAG, 2 ); + struct pso_pointer n = allocate( frame_pointer, TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words if ( ( n.page == 0 ) && ( n.offset == 4 ) ) { @@ -79,11 +79,19 @@ struct pso_pointer initialise_environment( uint32_t node ) { } } if ( !exceptionp( result ) ) { - result = c_bind( c_string_to_lisp_symbol( frame, L"nil" ), nil, nil ); + result = + lisp_bind( make_frame + ( 3, frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"nil" ), nil, + nil ) ); debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); - result = c_bind( c_string_to_lisp_symbol( frame, L"t" ), t, result ); + result = + lisp_bind( make_frame + ( 3, frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"t" ), t, + result ) ); environment_initialised = true; debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); @@ -93,5 +101,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { DEBUG_BOOTSTRAP, 0 ); } + dec_ref( frame_pointer ); + return result; } diff --git a/src/c/io/io.c b/src/c/io/io.c index f63264d..20e01e1 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -26,6 +26,7 @@ */ #include #include +#include #include @@ -149,65 +150,79 @@ int initialise_io( ) { return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer env ) { +struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, + struct pso_pointer env ) { // todo: issue #21: should this have stack frame passed in? // It's called in initialisation before everything else is set // up, so **possibly** not? - lisp_io_in = c_string_to_lisp_symbol( C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( C_IO_OUT ); - lisp_io_log = c_string_to_lisp_symbol( C_IO_LOG ); - lisp_io_prompt = c_string_to_lisp_symbol( C_IO_PROMPT ); + lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT ); + lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG ); + lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); env = - c_bind( lisp_io_prompt, c_string_to_lisp_string( INITIAL_PROMPT ), - env ); - - lisp_stdin = lock_object( make_read_stream( file_to_url_file( stdin ), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-input" ) ), - nil ) ) ); - - env = c_bind( lisp_io_in, lisp_stdin, env ); + lisp_bind( make_frame + ( 3, stack_frame, lisp_io_prompt, + c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ), + env ) ); + lisp_stdin = + lock_object( make_read_stream + ( stack_frame, file_to_url_file( stdin ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-input" ) ), + stack_frame ) ) ); + env = + lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) ); debug_print_object( env, DEBUG_IO, 0 ); - if ( !nilp( env ) && !exceptionp( env ) ) { + if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stdout = - lock_object( make_write_stream - ( file_to_url_file( stdout ), - make_cons( make_cons - ( c_string_to_lisp_keyword( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-output" ) ), - nil ) ) ); - - env = c_bind( lisp_io_out, lisp_stdout, env ); + lock_object( make_write_stream( stack_frame, + file_to_url_file( stdout ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, + L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-output" ) ), + nil ) ) ); + env = + lisp_bind( make_frame + ( 3, stack_frame, lisp_io_out, lisp_stdout, env ) ); } - if ( !nilp( env ) && !exceptionp( env ) ) { + if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stderr = lock_object( make_write_stream - ( file_to_url_file( stderr ), - make_cons( make_cons - ( c_string_to_lisp_keyword( L"url" ), - c_string_to_lisp_string - ( L"::system:standard-output" ) ), + ( stack_frame, file_to_url_file( stderr ), + make_cons( stack_frame, + make_cons( stack_frame, + c_string_to_lisp_keyword + ( stack_frame, L"url" ), + c_string_to_lisp_string + ( stack_frame, + L"::system:standard-output" ) ), nil ) ) ); - - env = c_bind( lisp_io_log, lisp_stderr, env ); + env = + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) ); } debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); - return env; } @@ -222,20 +237,17 @@ struct pso_pointer initialise_default_streams( struct pso_pointer env ) { */ 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 = c_cdr( c ) ) { + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { len++; } char32_t *buffer = calloc( len + 1, sizeof( char32_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 = c_cdr( c ) ) { + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = pointer_to_object( c )->payload.string.character; } @@ -246,7 +258,6 @@ 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_printf( DEBUG_IO, 0, L") => '%s'\n", result ); - return result; } @@ -258,7 +269,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { */ wint_t url_fgetwc( URL_FILE *input ) { wint_t result = -1; - if ( ungotten != 0 ) { /* TODO: not thread safe */ result = ungotten; @@ -269,14 +279,11 @@ wint_t url_fgetwc( URL_FILE *input ) { fwide( input->handle.file, 1 ); /* wide characters */ result = fgetwc( input->handle.file ); /* passthrough */ break; - case CFTYPE_CURL:{ char *cbuff = calloc( sizeof( char32_t ) + 2, sizeof( char ) ); char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); - size_t count = 0; - debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO, 0 ); url_fgets( cbuff, 2, input ); @@ -312,10 +319,10 @@ wint_t url_fgetwc( URL_FILE *input ) { } mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); result = wbuff[0]; - free( wbuff ); free( cbuff ); - } break; + } + break; case CFTYPE_NONE: break; } @@ -328,13 +335,11 @@ wint_t url_fgetwc( URL_FILE *input ) { 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; @@ -356,12 +361,11 @@ wint_t url_ungetwc( wint_t wc, URL_FILE *input ) { */ 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 ) ); + ( pointer_to_object_of_size_class + ( read_stream, 2 )->payload.stream.stream ) ); } return result; @@ -378,7 +382,6 @@ 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 result = nil; - if ( characterp( c ) && readp( r ) ) { if ( url_ungetwc( ( wint_t ) ( pointer_to_object( c )->payload.character. @@ -407,10 +410,11 @@ struct pso_pointer 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 ) == 0 ) { + if ( url_fclose + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) + == 0 ) { result = t; } } @@ -433,7 +437,6 @@ struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, value = trim( value ); char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return make_cons( make_cons ( c_string_to_lisp_keyword( frame_pointer, key ), @@ -444,10 +447,8 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, time_t *value ) { // todo: issue #21: must have stack frame passed in. char datestring[256]; - strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), localtime( value ) ); - return add_meta_string( meta, key, datestring ); } @@ -458,43 +459,33 @@ struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, 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] ); // char32_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 ); @@ -510,7 +501,6 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, // DEBUG_IO ); // debug_dump_object( stream, DEBUG_IO ); // } - // free( s ); return 0; // strlen( string ); } @@ -519,12 +509,12 @@ 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 ); + 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; @@ -545,7 +535,6 @@ void collect_meta( struct pso_pointer stream, char *url ) { meta = add_meta_integer( meta, L"size", ( intmax_t ) statbuf.st_size ); - meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); } break; @@ -569,9 +558,7 @@ void collect_meta( struct pso_pointer stream, char *url ) { 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; } @@ -581,10 +568,8 @@ struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env ) { */ URL_FILE *stream_get_url_file( struct pso_pointer s ) { URL_FILE *result = NULL; - if ( readp( s ) || writep( s ) ) { struct pso2 *obj = pointer_to_object( s ); - result = obj->payload.stream.stream; } @@ -610,18 +595,14 @@ struct pso_pointer 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) ) ) { // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); - - // if ( nilp( fetch_arg( frame, 1) ) ) { + // if ( c_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 @@ -641,23 +622,19 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer, // /* 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; } @@ -677,12 +654,11 @@ struct pso_pointer 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; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { - result = - make_string( frame_pointer, url_fgetwc( stream_get_url_file( stream_pointer ) ), - nil ); + result = make_string( frame_pointer, + url_fgetwc( stream_get_url_file + ( stream_pointer ) ), nil ); } return result; @@ -706,12 +682,11 @@ struct pso_pointer 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 = stream_get_url_file( fetch_arg( frame, 0 ) ); - struct pso_pointer cursor = make_string( frame_pointer, url_fgetwc( stream ), nil ); + struct pso_pointer cursor = make_string( frame_pointer, + 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 ); @@ -719,7 +694,6 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, 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( frame_pointer, ( char32_t ) c, nil ); cell->payload.string.cdr = cursor; diff --git a/src/c/io/io.h b/src/c/io/io.h index f90e589..cc660d1 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -12,6 +12,13 @@ #define __psse_io_io_h #include +/* + * wide characters + */ +#include +#include +#include + #include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" @@ -19,7 +26,9 @@ extern CURLSH *io_share; int initialise_io( ); -struct pso_pointer initialise_default_streams( struct pso_pointer env ); +struct pso_pointer initialise_default_streams( struct pso_pointer + frame_pointer, + struct pso_pointer env ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" diff --git a/src/c/io/print.c b/src/c/io/print.c index d6bf63b..b1ce56e 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -42,6 +42,7 @@ #include "payloads/exception.h" #include "payloads/integer.h" +#include "ops/stack_ops.h" #include "ops/truth.h" struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, @@ -78,7 +79,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, } if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { - for ( struct pso_pointer cursor = p; !nilp( cursor ); + for ( struct pso_pointer cursor = p; !c_nilp( cursor ); cursor = pointer_to_object( cursor )->payload.string.cdr ) { char32_t wc = pointer_to_object( cursor )->payload.string.character; @@ -190,7 +191,9 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, * This is kind of modelled after the implementation of PRIN* variants on page * 383 of the aluminium book. It is the inner workings of all PRIN* functions. * - * @param p pointer to the object to print. + * (write object stream escape? nl_before? nl_after?) + * + * @param object pointer to the object to print. * @param output stream to print to. * @param escape if true, print everything so that it can be read by the Lisp * reader; otherwise, print it appropriately for human readers. @@ -198,9 +201,14 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, * @param nl_after if true, print a newline *after* printing `p`; else a space. * @return p on success, exception on failure. */ -struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after ) { - struct pso_pointer result = p; +struct pso_pointer write( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer object = fetch_arg( frame, 0 ); + struct pso_pointer stream = fetch_arg( frame, 1 ); + bool escape = c_truep( fetch_arg( frame, 2 ) ); + bool nl_before = c_truep( fetch_arg( frame, 3 ) ); + bool nl_after = c_truep( fetch_arg( frame, 4 ) ); + struct pso_pointer result = object; URL_FILE *output = writep( stream ) ? pointer_to_object( stream )->payload.stream.stream : file_to_url_file( stdout ); @@ -211,16 +219,17 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer stream, if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( p, output, true ); + result = in_write( object, output, true ); url_fputwc( nl_after ? L'\n' : L' ', output ); dec_ref( stream ); } else { result = - make_exception( c_string_to_lisp_string - ( L"Bad write stream passed to write." ), nil, nil, - nil ); + make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Bad write stream passed to write." ) ) ); } return result; @@ -233,13 +242,21 @@ struct pso_pointer write( struct pso_pointer p, struct pso_pointer 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 c_print( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, true, true, false ); +struct pso_pointer print( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return write( make_frame( 5, frame_pointer, + fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, + t, nil ) ); } /** * @brief princ is pretty much like print except things are printed `unescaped` */ -struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ) { - return write( p, stream, false, true, false ); +struct pso_pointer princ( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + return write( make_frame( 5, frame_pointer, + fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), + nil, t, nil ) ); } diff --git a/src/c/io/print.h b/src/c/io/print.h index d239913..c6716e4 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -16,8 +16,8 @@ #include #include "io/fopen.h" -struct pso_pointer c_print( struct pso_pointer p, struct pso_pointer stream ); -struct pso_pointer c_princ( struct pso_pointer p, struct pso_pointer stream ); +struct pso_pointer print( struct pso_pointer frame_pointer ); +struct pso_pointer princ( struct pso_pointer frame_pointer ); #define PRINT_VARIANT_PRINT 0 #define PRINT_VARIANT_PRIN1 1 diff --git a/src/c/io/read.c b/src/c/io/read.c index c2d0335..8525836 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -98,12 +98,7 @@ struct pso_pointer read_example( * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_number( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_number( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -115,10 +110,10 @@ struct pso_pointer read_number( int64_t value = 0; if ( readp( stream ) ) { - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } - char32_t c = nilp( character ) + char32_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -127,18 +122,13 @@ struct pso_pointer read_number( } url_ungetwc( c, input ); - result = make_integer( value ); + result = make_integer( frame_pointer, value ); } // else exception? return result; } -struct pso_pointer read_symbol( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -146,16 +136,17 @@ struct pso_pointer read_symbol( struct pso_pointer result = nil; if ( readp( stream ) ) { - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } - char32_t c = nilp( character ) + char32_t c = 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 ); + result = + make_string_like_thing( frame_pointer, c, result, SYMBOLTAG ); } url_ungetwc( c, input ); @@ -176,12 +167,7 @@ struct pso_pointer read_symbol( * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -189,22 +175,23 @@ struct pso_pointer read( struct pso_pointer result = nil; - if ( nilp( stream ) ) { - stream = make_read_stream( file_to_url_file( stdin ), nil ); + if ( c_nilp( stream ) ) { + stream = + make_read_stream( frame_pointer, file_to_url_file( stdin ), nil ); } - if ( nilp( readtable ) ) { + if ( c_nilp( readtable ) ) { // TODO: check for the value of `*read-table*` in the environment and // use that. } - if ( nilp( character ) ) { + if ( c_nilp( character ) ) { character = get_character( stream ); } struct pso_pointer readmacro = c_assoc( character, readtable ); - if ( !nilp( readmacro ) ) { + if ( !c_nilp( readmacro ) ) { // invoke the read macro on the stream } else if ( readp( stream ) && characterp( character ) ) { char32_t c = @@ -228,12 +215,13 @@ struct pso_pointer read( default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, readtable, - make_character( c ) ); + make_character + ( frame_pointer, c ) ); inc_ref( next ); if ( iswdigit( c ) ) { - result = read_number( next, env ); + result = read_number( next ); } else if ( iswalpha( c ) ) { - result = read_symbol( next, env ); + result = read_symbol( next ); } else { // result = // throw_exception( diff --git a/src/c/io/read.h b/src/c/io/read.h index a3e0ffc..7bb4687 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -13,13 +13,10 @@ #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_number( struct pso_pointer frame_pointer ); -struct pso_pointer read_symbol( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer read_symbol( struct pso_pointer frame_pointer ); -struct pso_pointer read( struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer read( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/memory/destroy.c b/src/c/memory/destroy.c index 41adcb6..9879f6b 100644 --- a/src/c/memory/destroy.c +++ b/src/c/memory/destroy.c @@ -44,15 +44,15 @@ struct pso_pointer destroy( struct pso_pointer p ) { switch ( get_tag_value( p ) ) { case CONSTV: - destroy_cons( f, nil ); + destroy_cons( f ); break; case EXCEPTIONTV: - destroy_exception( f, nil ); + destroy_exception( f ); break; case KEYTV: case STRINGTV: case SYMBOLTV: - destroy_string( f, nil ); + destroy_string( f ); break; case STACKTV: // destroy_stack_frame( f, nil ); diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 6e7e5af..adbf827 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -58,9 +58,9 @@ struct pso_pointer initialise_memory( uint32_t node ) { struct pso_pointer result = nil; if ( memory_initialised ) { result = - make_exception( c_string_to_lisp_string - ( L"Attenpt to reinitialise memory." ), nil, nil, - nil ); + make_exception( make_frame( 1, nil, c_string_to_lisp_string + ( nil, + L"Attenpt to reinitialise memory." ) ) ); } else { for ( uint8_t i = 0; i <= MAX_SIZE_CLASS; i++ ) { freelists[i] = nil; @@ -82,18 +82,18 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { struct pso_pointer result = t; if ( size_class <= MAX_SIZE_CLASS ) { - if ( nilp( freelists[size_class] ) ) { + if ( c_nilp( freelists[size_class] ) ) { result = allocate_page( size_class ); } - if ( nilp( result ) ) { + if ( c_nilp( result ) ) { fputws( L"FATAL: Page space exhausted\n", stderr ); exit( 1 ); // TODO: we don't want to do this! Somehow, we need to // recover a workable environment, ideally by throwing a pre-made // exception. } - if ( !exceptionp( result ) && !nilp( result ) ) { + if ( !exceptionp( result ) && !c_nilp( result ) ) { pthread_mutex_lock( &freelists_mutices[size_class] ); result = freelists[size_class]; struct pso2 *object = pointer_to_object( result ); diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 083536e..42ff995 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -16,12 +16,15 @@ #include "memory/memory.h" #include "memory/pointer.h" +#include "memory/pso.h" #include "memory/tags.h" +#include "payloads/exception.h" + #include "ops/eq.h" +#include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" -#include "payloads/exception.h" /** * @brief Flag to prevent the node being initialised more than once. @@ -56,9 +59,9 @@ struct pso_pointer t = ( struct pso_pointer ) { 0, 0, 4 }; */ struct pso_pointer in_debugging_mode = #ifdef DEBUG - ( struct pso_pointer ) { 0, 0, 4 }; +( struct pso_pointer ) { 0, 0, 4 }; #else - ( struct pso_pointer ) { 0, 0, 0 }; +( struct pso_pointer ) { 0, 0, 0 }; #endif /** @@ -77,18 +80,22 @@ struct pso_pointer initialise_node( uint32_t index ) { node_index = index; struct pso_pointer result = initialise_environment( index ); + struct pso_pointer base_of_stack = make_frame( 0, nil ); if ( !c_nilp( result ) && !exceptionp( result ) ) { - node_initialised = true; + node_initialised = true; if ( initialise_io( ) == 0 ) { - result = initialise_default_streams( result ); + result = initialise_default_streams( base_of_stack, result ); } else { result = - make_exception( make_frame(1, nil, - c_string_to_lisp_string( nil, L"Failed to initialise default streams" ))); + make_exception( make_frame( 1, base_of_stack, + c_string_to_lisp_string + ( base_of_stack, + L"Failed to initialise default streams" ) ) ); } } + dec_ref( base_of_stack ); + return result; } - diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 9857a1d..580f100 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,7 +286,8 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0 ); + debug_print( c_nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, + 0 ); return result; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index e0c4272..16e60f9 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -64,7 +64,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, #endif struct pso_pointer result = pop_freelist( size_class ); - struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); if ( !c_nilp( result ) ) { strncpy( ( char * ) ( pointer_to_object( result )->header.tag. @@ -72,8 +72,8 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); - if ( stackp(frame_pointer)) { - struct pso_pointer locals = make_cons( result, + if ( stackp( frame_pointer ) ) { + struct pso_pointer locals = make_cons( frame_pointer, result, frame->payload. stack_frame.locals ); frame->payload.stack_frame.locals = locals; diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 721ba1e..635f19c 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -31,13 +31,15 @@ uint32_t get_tag_value( struct pso_pointer p ) { * * @param p must be a struct pso_pointer, indicating the appropriate object. */ -struct pso_pointer get_tag_string( struct pso_pointer p ) { +struct pso_pointer get_tag_string( struct pso_pointer frame_pointer, + struct pso_pointer p ) { struct pso_pointer result = nil; struct pso2 *object = pointer_to_object( p ); for ( int i = 2 - 1; i >= 0; i-- ) { result = - make_string( ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), + make_string( frame_pointer, + ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), result ); } diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index afea5f5..422c1dd 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -87,7 +87,8 @@ // #define get_tag_value(p)((pointer_to_object(p)->header.tag.value) & 0xffffff) uint32_t get_tag_value( struct pso_pointer p ); -struct pso_pointer get_tag_string( struct pso_pointer p ); +struct pso_pointer get_tag_string( struct pso_pointer frame_pointer, + struct pso_pointer p ); /** * @brief check that the tag of the object indicated by this poiner has this diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index e9bc4cf..f77cbb8 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -101,13 +101,15 @@ struct pso_pointer assoc( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_assoc( key, store ); } @@ -121,13 +123,15 @@ struct pso_pointer interned( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_interned( key, store ); } @@ -141,13 +145,15 @@ struct pso_pointer internedp( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer) { + struct pso_pointer frame_pointer ) { #ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); #endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, - fetch_arg( frame, 1 ), frame->payload.stack_frame.env)); + fetch_arg( frame, 1 ), + frame->payload. + stack_frame.env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 4c552ed..2b6f447 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -22,19 +22,16 @@ #include "payloads/function.h" #include "payloads/stack.h" -struct pso_pointer bind( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY +/** + * (bind key value store) + */ +struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif 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 binding = cons( make_frame( 2, frame_pointer, key, value)); + struct pso_pointer binding = + cons( make_frame( 2, frame_pointer, key, value ) ); - return cons( make_frame( 2, frame_pointer, binding, store)); + return cons( make_frame( 2, frame_pointer, binding, store ) ); } - diff --git a/src/c/ops/bind.h b/src/c/ops/bind.h index 2682fe8..79cb753 100644 --- a/src/c/ops/bind.h +++ b/src/c/ops/bind.h @@ -16,15 +16,7 @@ #include "memory/pointer.h" #include "memory/pso4.h" -struct pso_pointer c_bind( struct pso_pointer key, - struct pso_pointer value, - struct pso_pointer store ); -struct pso_pointer lisp_bind( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/eq.h b/src/c/ops/eq.h index 98e8ddc..0f3e10a 100644 --- a/src/c/ops/eq.h +++ b/src/c/ops/eq.h @@ -32,7 +32,7 @@ struct pso_pointer equal( #ifndef MANAGED_POINTER_ONLY struct pso4 *frame, #endif - struct pso_pointer frame_pointer); + struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 284a33b..c95513c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -31,14 +31,7 @@ * * * (apply fn args) */ -struct pso_pointer apply( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY - struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif +struct pso_pointer apply( struct pso_pointer frame_pointer ) { // TODO. @@ -49,16 +42,11 @@ struct pso_pointer apply( * * * (eval form) */ -struct pso_pointer eval( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer) { -#ifdef MANAGED_POINTER_ONLY +struct pso_pointer eval( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif + struct pso_pointer arg = fetch_arg( frame, 0 ); - struct pso_pointer result = nil; + struct pso_pointer result = nil; switch ( get_tag_value( arg ) ) { // case CONSTV: @@ -68,10 +56,10 @@ struct pso_pointer eval( case KEYTV: case STRINGTV: // self evaluating - result = nil; + result = nil; break; case SYMBOLTV: - arg = c_assoc( arg, fetch_env(frame_pointer) ); + arg = c_assoc( arg, fetch_env( frame_pointer ) ); break; // case LAMBDATV: // result = eval_lambda( frame, frame_pointer, env); @@ -84,22 +72,22 @@ struct pso_pointer eval( // break; default: arg = - make_exception( - make_frame(1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( arg ) ), - nil ), - nil )); + make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Can't yet evaluate things of this type: " ), + arg ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"tag" ), + get_tag_string + ( frame_pointer, + arg ) ), nil ), + nil ) ); } if ( exceptionp( arg ) ) { @@ -108,7 +96,7 @@ struct pso_pointer eval( EXCEPTIONTV ); if ( c_nilp( x->payload.exception.stack ) ) { - + } } diff --git a/src/c/ops/eval_apply.h b/src/c/ops/eval_apply.h index 18b0f01..2f326fa 100644 --- a/src/c/ops/eval_apply.h +++ b/src/c/ops/eval_apply.h @@ -17,20 +17,10 @@ #include "memory/pso4.h" #include "payloads/function.h" -struct pso_pointer apply( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer apply( struct pso_pointer frame_pointer ); -struct pso_pointer eval( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ); +struct pso_pointer eval( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index e253b44..3baeabf 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -17,16 +17,16 @@ #include "ops/truth.h" -struct pso_pointer length( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4(frame_pointer); - - struct pso_pointer list = fetch_arg( frame, 0); - int count = 0; +struct pso_pointer length( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); - for ( struct pso_pointer cursor = list; !c_nilp( cursor); - cursor = cdr( make_frame( 1, frame_pointer, list))) { - count++; - } + struct pso_pointer list = fetch_arg( frame, 0 ); + int count = 0; - return make_integer( frame_pointer, count); + for ( struct pso_pointer cursor = list; !c_nilp( cursor ); + cursor = cdr( make_frame( 1, frame_pointer, list ) ) ) { + count++; + } + + return make_integer( frame_pointer, count ); } diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index 3b1fcb1..0dd74d1 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -17,6 +17,6 @@ #include "payloads/function.h" -struct pso_pointer length( struct pso_pointer frame_pointer); +struct pso_pointer length( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 151b5b7..e2f46fe 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -33,6 +33,7 @@ #include "ops/assoc.h" #include "ops/eval_apply.h" +#include "ops/stack_ops.h" #include "ops/truth.h" /** @@ -47,14 +48,14 @@ void int_handler( int dummy ) { /** * Very simple read/eval/print loop for bootstrapping. */ -void c_repl( bool show_prompt ) { +void repl( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); // todo: issue #21: must have stack frame passed in. signal( SIGINT, int_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); - // TODO: NULL is not OK here, but will do until we have a REPL in Lisp. - struct pso_pointer env = - consp( oblist ) ? oblist : make_cons( nil, oblist, nil ); + struct pso_pointer env = fetch_env( frame_pointer ); struct pso_pointer input_stream = c_assoc( lisp_io_in, env ); struct pso_pointer output_stream = c_assoc( lisp_io_out, env ); @@ -72,32 +73,28 @@ void c_repl( bool show_prompt ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { if ( show_prompt ) - c_princ( c_assoc( lisp_io_prompt, env ), output_stream ); + princ( make_frame( 2, frame_pointer, + c_assoc( lisp_io_prompt, env ), + output_stream ) ); - /* bottom of stack */ - struct pso_pointer frame_pointer = make_frame( 1, nil, input_stream ); + /* the reason for initialising a new stack for each REPL input is to + * be sure the old stack is fully torn down and reclaimed. Once I'm + * confident of that, TODO: do not start a new stack base each time! + */ + struct pso_pointer base_of_stack = + inc_ref( make_frame_with_env( 0, nil, + consp( oblist ) ? oblist : + make_cons( nil, oblist, nil ) ) ); - if ( c_nilp( frame_pointer ) ) - break; - struct pso_pointer input = read( -#ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( frame_pointer ), -#endif - frame_pointer, env ); + print( make_frame + ( 2, base_of_stack, + eval( make_frame + ( 1, base_of_stack, + read( make_frame + ( 1, base_of_stack, input_stream ) ) ) ), + output_stream ) ); - frame_pointer = make_frame( 1, frame_pointer, input ); - if ( c_nilp( frame_pointer ) ) - break; - - struct pso_pointer result = eval( -#ifndef MANAGED_POINTER_ONLY - pointer_to_pso4( frame_pointer ), -#endif - frame_pointer, oblist ); - - c_print( result, output_stream ); - - dec_ref( frame_pointer ); + dec_ref( base_of_stack ); } debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index 0dc862f..b7ab6de 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -13,8 +13,7 @@ #define SRC_C_OPS_REPL_H_ - // todo: issue #21: must have stack frame passed in. -void c_repl( ); +void repl( struct pso_pointer frame_pointer ); #endif /* SRC_C_OPS_REPL_H_ */ diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 65be27a..9bfe934 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -35,7 +35,8 @@ * @return a sequence like the `sequence` passed, but reversed; or `nil` if * the argument was not a sequence. */ -struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { +struct pso_pointer c_reverse( struct pso_pointer frame_pointer, + struct pso_pointer sequence ) { // todo: issue #21: must have stack frame passed in. struct pso_pointer result = nil; @@ -49,27 +50,31 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_point case KEYTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, KEYTAG ); break; case STRINGTV: result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, STRINGTAG ); break; case SYMBOLTV: // TODO: should you be able to reverse keywords and symbols? result = - make_string_like_thing( frame_pointer, object->payload.string.character, + make_string_like_thing( frame_pointer, + object->payload.string.character, result, SYMBOLTAG ); break; default: result = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, L"Invalid object in sequence" ), - cursor ) )); + make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid object in sequence" ), + cursor ) ) ); goto exit; break; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index ccadf42..bdf5e15 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -50,8 +50,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) { * * @param frame_pointer a pointer to a stack frame. */ -struct pso_pointer fetch_env( struct pso_pointer frame_pointer) { - return stackp(frame_pointer) ? - pointer_to_pso4(frame_pointer)->payload.stack_frame.env : - nil; +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { + return stackp( frame_pointer ) ? + pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; } diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index 3601724..fb1c4cc 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -27,6 +27,6 @@ extern uint32_t stack_limit; struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); -struct pso_pointer fetch_env( struct pso_pointer frame_pointer); +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index d9790e0..4b7b9d8 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -27,7 +27,7 @@ * @return true if `p` points to `nil`. * @return false otherwise. */ -bool c_nilp(struct pso_pointer p) { +bool c_nilp( struct pso_pointer p ) { return ( p.page == 0 && p.offset == 0 ); } @@ -80,7 +80,7 @@ struct pso_pointer truep( struct pso_pointer frame_pointer ) { * @param frame_pointer A pointer to the current stack frame; * @return `t` if the first argument in this frame is not `nil`, else `t`. */ -struct pso_pointer not( struct pso_pointer frame_pointer) { +struct pso_pointer not( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); return ( !c_nilp( fetch_arg( frame, 0 ) ) ? t : nil ); @@ -91,18 +91,19 @@ struct pso_pointer not( struct pso_pointer frame_pointer) { * * @return `nil` if any `arg` is `nil`, else `t`. */ -struct pso_pointer and( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer result = t; - - for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { - if (c_nilp(fetch_arg(frame, arg))) { - result = nil; - break; - } - } - - return result; +struct pso_pointer and( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = t; + + for ( int arg = 0; + c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) { + if ( c_nilp( fetch_arg( frame, arg ) ) ) { + result = nil; + break; + } + } + + return result; } @@ -111,16 +112,17 @@ struct pso_pointer and( struct pso_pointer frame_pointer) { * * @return `t` if any `arg` is non-nil, else `nil`. */ -struct pso_pointer or( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer result = nil; - - for (int arg = 0; c_truep(result) && arg < frame->payload.stack_frame.args; arg++) { - if (!c_nilp(fetch_arg(frame, arg))) { - result = t; - break; - } - } - - return result; +struct pso_pointer or( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = nil; + + for ( int arg = 0; + c_truep( result ) && arg < frame->payload.stack_frame.args; arg++ ) { + if ( !c_nilp( fetch_arg( frame, arg ) ) ) { + result = t; + break; + } + } + + return result; } diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index 38de633..e775ff2 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -25,7 +25,7 @@ struct pso_pointer and( struct pso_pointer frame_pointer ); struct pso_pointer or( struct pso_pointer frame_pointer ); -bool c_nilp(struct pso_pointer p); -bool c_truep(struct pso_pointer p); +bool c_nilp( struct pso_pointer p ); +bool c_truep( struct pso_pointer p ); #endif diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 2862bfe..6995631 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -38,5 +38,6 @@ struct character_payload { char32_t character; }; -struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c ); +struct pso_pointer make_character( struct pso_pointer frame_pointer, + wint_t c ); #endif diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index 39b10a4..dccdf13 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -31,19 +31,21 @@ * @param frame_pointer a pointer to a stack frame. * @return struct pso_pointer a pointer to the newly allocated cons cell. */ -struct pso_pointer cons(struct pso_pointer frame_pointer) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer result = allocate(frame_pointer, CONSTAG, 2); +struct pso_pointer cons( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = allocate( frame_pointer, CONSTAG, 2 ); - struct pso2 *object = pointer_to_object(result); - object->payload.cons.car = inc_ref(fetch_arg(frame, 0)); - object->payload.cons.cdr = inc_ref(fetch_arg(frame, 1)); + struct pso2 *object = pointer_to_object( result ); + object->payload.cons.car = inc_ref( fetch_arg( frame, 0 ) ); + object->payload.cons.cdr = inc_ref( fetch_arg( frame, 1 ) ); - return result; + return result; } -struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr){ - return cons( make_frame(2, frame_pointer, car, cdr)); +struct pso_pointer make_cons( struct pso_pointer frame_pointer, + struct pso_pointer car, + struct pso_pointer cdr ) { + return cons( make_frame( 2, frame_pointer, car, cdr ) ); } /** @@ -55,26 +57,32 @@ struct pso_pointer make_cons(struct pso_pointer frame_pointer, struct pso_pointe * @return the car of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer car(struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer cons = fetch_arg(frame, 0); - struct pso2 *object = pointer_to_object(cons); +struct pso_pointer car( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer cons = fetch_arg( frame, 0 ); + struct pso2 *object = pointer_to_object( cons ); - if (consp(cons)) { - result = object->payload.cons.car; - } else { - result = make_exception(make_frame( - 2, frame_pointer, - c_string_to_lisp_string(frame_pointer, L"Invalid type for car"), - make_cons(frame_pointer, make_cons( - frame_pointer, - c_string_to_lisp_keyword(frame_pointer, L"type"), - get_tag_string(cons)), - nil))); - } + if ( consp( cons ) ) { + result = object->payload.cons.car; + } else { + result = make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid type for car" ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"type" ), + get_tag_string + ( frame_pointer, + cons ) ), + nil ) ) ); + } - return result; + return result; } /** @@ -86,36 +94,40 @@ struct pso_pointer car(struct pso_pointer frame_pointer) { * @return the cdr of the indicated cell. * @exception if the pointer does not indicate a cons cell. */ -struct pso_pointer cdr(struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer cons = fetch_arg(frame, 0); - struct pso2 *object = pointer_to_object(cons); +struct pso_pointer cdr( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer cons = fetch_arg( frame, 0 ); + struct pso2 *object = pointer_to_object( cons ); - switch (get_tag_value(cons)) { - case CONSTV: - result = object->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = object->payload.string.cdr; - break; - default: - struct pso_pointer type_binding = - make_cons(frame_pointer, - c_string_to_lisp_keyword(frame_pointer, L"type"), - get_tag_string(cons)); - result = make_exception(make_frame( - 2, frame_pointer, - c_string_to_lisp_string(frame_pointer, L"Invalid type for cdr"), - make_cons(frame_pointer, - type_binding, - nil))); - break; - } + switch ( get_tag_value( cons ) ) { + case CONSTV: + result = object->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = object->payload.string.cdr; + break; + default: + result = make_exception( make_frame( 2, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid type for cdr" ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"type" ), + get_tag_string + ( frame_pointer, + cons ) ), + nil ) ) ); + break; + } - return result; + return result; } /** @@ -125,15 +137,15 @@ struct pso_pointer cdr(struct pso_pointer frame_pointer) { * Lisp calling conventions; one expected arg, the pointer to the cell to * be destroyed. */ -struct pso_pointer destroy_cons(struct pso_pointer fp) { - if (stackp(fp)) { - struct pso4 *frame = pointer_to_pso4(fp); - struct pso_pointer p = frame->payload.stack_frame.arg[0]; +struct pso_pointer destroy_cons( struct pso_pointer fp ) { + if ( stackp( fp ) ) { + struct pso4 *frame = pointer_to_pso4( fp ); + struct pso_pointer p = frame->payload.stack_frame.arg[0]; - if (check_tag(p, CONSTV)) { - struct pso2 *cons = pointer_to_object(p); - dec_ref(cons->payload.cons.car); - dec_ref(cons->payload.cons.cdr); - } - } + if ( check_tag( p, CONSTV ) ) { + struct pso2 *cons = pointer_to_object( p ); + dec_ref( cons->payload.cons.car ); + dec_ref( cons->payload.cons.cdr ); + } + } } diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 540034c..fdbfc8f 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -33,11 +33,10 @@ struct pso_pointer cdr( struct pso_pointer frame_pointer ); struct pso_pointer cons( struct pso_pointer frame_pointer ); -struct pso_pointer destroy_cons( struct pso_pointer frame_pointer); +struct pso_pointer destroy_cons( struct pso_pointer frame_pointer ); -struct pso_pointer make_cons(struct pso_pointer frame_pointer, - struct pso_pointer car, - struct pso_pointer cdr); +struct pso_pointer make_cons( struct pso_pointer frame_pointer, + struct pso_pointer car, struct pso_pointer cdr ); /** * macro short-cuts for make_cons. diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index e184354..aa9f33c 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -47,21 +47,21 @@ b * @param meta metadata for this exception. Must be an assoc list, hashtable, * or `nil` * @param cause the exception that caused this exception to be `thrown`. */ -struct pso_pointer make_exception( struct pso_pointer frame_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer message = fetch_arg(frame, 0); - struct pso_pointer previous = frame->payload.stack_frame.previous; - struct pso_pointer meta = fetch_arg( frame, 1); - struct pso_pointer cause = fetch_arg( frame, 2); +struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer message = fetch_arg( frame, 0 ); + struct pso_pointer previous = frame->payload.stack_frame.previous; + struct pso_pointer meta = fetch_arg( frame, 1 ); + struct pso_pointer cause = fetch_arg( frame, 2 ); - struct pso_pointer result = - allocate( frame_pointer, EXCEPTIONTAG, 3 ); + struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); if ( !c_nilp( result ) && !exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); object->payload.exception.message = message; - object->payload.exception.stack = stackp( frame_pointer ) ? frame_pointer : nil; + object->payload.exception.stack = + stackp( frame_pointer ) ? frame_pointer : nil; object->payload.exception.meta = ( consp( meta ) || hashtabp( meta ) ) ? meta : nil; object->payload.exception.cause = exceptionp( cause ) ? cause : nil; @@ -76,8 +76,7 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer) { * 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 ) { +struct pso_pointer destroy_exception( struct pso_pointer fp ) { if ( stackp( fp ) ) { struct pso4 *frame = pointer_to_pso4( fp ); struct pso_pointer p = frame->payload.stack_frame.arg[0]; diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 27e7e08..4bb088e 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -28,7 +28,6 @@ struct exception_payload { struct pso_pointer make_exception( struct pso_pointer frame_pointer ); -struct pso_pointer destroy_exception( struct pso_pointer fp, - struct pso_pointer env ); +struct pso_pointer destroy_exception( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 032005d..8fe53d7 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -25,7 +25,8 @@ * @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( struct pso_pointer frame_pointer, int64_t value ) { +struct pso_pointer make_integer( struct pso_pointer frame_pointer, + int64_t value ) { struct pso_pointer result = nil; debug_print( L"Entering make_integer\n", DEBUG_ALLOC, 0 ); diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index b537388..ea8464a 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -25,6 +25,7 @@ struct integer_payload { __int128_t value; }; -struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ); +struct pso_pointer make_integer( struct pso_pointer frame_pointer, + int64_t value ); #endif diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index f1a1fb8..2206138 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -22,6 +22,8 @@ #include "payloads/cons.h" +#include "ops/stack_ops.h" + /** * @brief When an string is freed, its cdr pointer must be decremented. @@ -29,14 +31,10 @@ * 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( c_cdr( p ) ); - } +struct pso_pointer destroy_string( struct pso_pointer frame_pointer ) { + if ( stackp( frame_pointer ) ) { + dec_ref( c_cdr( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ) ); + } return nil; } diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 9b83d99..8c71039 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -33,7 +33,6 @@ struct string_payload { struct pso_pointer cdr; }; -struct pso_pointer destroy_string( struct pso_pointer fp, - struct pso_pointer env ); +struct pso_pointer destroy_string( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 86c68b1..3a3fa70 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -43,9 +43,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_start( args, previous ); struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -57,14 +56,16 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = prev_frame->payload.stack_frame.env; + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = + prev_frame->payload.stack_frame.env; } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; @@ -86,7 +87,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -117,9 +118,8 @@ struct pso_pointer make_frame_with_env( int arg_count, va_start( args, env ); struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, @@ -131,14 +131,15 @@ struct pso_pointer make_frame_with_env( int arg_count, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; new_frame->payload.stack_frame.env = env; } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; @@ -160,7 +161,7 @@ struct pso_pointer make_frame_with_env( int arg_count, new_frame->payload.stack_frame.more = c_reverse( more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -181,14 +182,19 @@ struct pso_pointer make_frame_with_env( int arg_count, * * @return pointer to the new frame. */ -struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, struct pso_pointer argvalues, - struct pso_pointer env) { +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer + previous, + struct pso_pointer + argvalues, + struct pso_pointer env ) { struct pso4 *prev_frame = pointer_to_pso4( previous ); - struct pso_pointer new_pointer = - allocate( previous, STACKTAG, 4 ); - struct pso4* new_frame = pointer_to_pso4(new_pointer); - struct pso_pointer arg_length = length(make_frame(1, previous, argvalues)); - int arg_count = integerp(arg_length) ? pointer_to_object(arg_length)->payload.integer.value : 0; + struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + struct pso_pointer arg_length = + length( make_frame( 1, previous, argvalues ) ); + int arg_count = + integerp( arg_length ) ? pointer_to_object( arg_length )-> + payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -199,28 +205,31 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = inc_ref( prev_frame->payload.stack_frame.env); + new_frame->payload.stack_frame.depth = + prev_frame->payload.stack_frame.depth + 1; + new_frame->payload.stack_frame.env = + inc_ref( prev_frame->payload.stack_frame.env ); } else { - new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.depth = 0; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); + new_frame->payload.stack_frame.depth ); int cursor = 0; new_frame->payload.stack_frame.args = arg_count; for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = inc_ref( make_frame( 1, previous, car(argvalues))); - argvalues = cdr( make_frame( 1, previous, argvalues)); + new_frame->payload.stack_frame.arg[cursor] = + inc_ref( make_frame( 1, previous, car( argvalues ) ) ); + argvalues = cdr( make_frame( 1, previous, argvalues ) ); } if ( cursor < arg_count ) { - new_frame->payload.stack_frame.more = inc_ref( argvalues); + new_frame->payload.stack_frame.more = inc_ref( argvalues ); } else { for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; + new_frame->payload.stack_frame.arg[cursor] = nil; } } @@ -239,8 +248,12 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, * * @return pointer to the new frame. */ -struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues) { - return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4(previous)->payload.stack_frame.env); +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, + struct pso_pointer argvalues ) { + return make_frame_with_arglist_and_env( previous, argvalues, + pointer_to_pso4 + ( previous )->payload.stack_frame. + env ); } diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index a9e1a0d..5fb9267 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -43,17 +43,19 @@ struct stack_frame_payload { struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ); - + struct pso_pointer make_frame_with_env( int arg_count, struct pso_pointer previous, struct pso_pointer env, ... ); - -struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer previous, - struct pso_pointer argvalues, - struct pso_pointer env); - -struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, - struct pso_pointer argvalues); + +struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer + previous, + struct pso_pointer + argvalues, + struct pso_pointer env ); + +struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, + struct pso_pointer argvalues ); struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); diff --git a/src/c/psse.c b/src/c/psse.c index f1f4e13..65e9196 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -1,4 +1,3 @@ - /** * psse.c * @@ -120,7 +119,7 @@ int main( int argc, char *argv[] ) { debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); debug_println( DEBUG_BOOTSTRAP ); - if ( nilp( oblist ) ) { + if ( c_nilp( oblist ) ) { fputs( "Failed to initialise node\n", stderr ); exit( 1 ); } @@ -134,7 +133,22 @@ int main( int argc, char *argv[] ) { stdout ); } - c_repl( show_prompt ); + struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, + consp + ( oblist ) + ? oblist + : + make_cons + ( nil, + oblist, + nil ), + show_prompt + ? t : + nil ) ); + + repl( bootstrap_stack ); + + dec_ref( bootstrap_stack ); exit( 0 ); } From aa0d60bbed0112eaffa6a963916b4bff8255b3c8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 23 Apr 2026 11:50:30 +0100 Subject: [PATCH 50/77] It compiles. It runs. Nothing works, but it also doesn't crash. Victory! --- src/c/debug.c | 18 +- src/c/environment/environment.c | 2 +- src/c/io/io.c | 338 +++++++++++++++----------------- src/c/io/io.h | 10 +- src/c/io/read.c | 51 +++-- src/c/io/read.h | 2 + src/c/memory/pso.c | 33 +++- src/c/memory/pso2.h | 2 +- src/c/memory/pso4.c | 4 +- src/c/memory/pso4.h | 4 +- src/c/ops/assoc.c | 12 +- src/c/ops/repl.c | 4 +- src/c/ops/string_ops.c | 52 ++++- src/c/ops/string_ops.h | 4 +- src/c/payloads/integer.c | 5 + src/c/payloads/integer.h | 2 + src/c/payloads/stack.c | 11 +- src/c/payloads/time.c | 57 ++++++ src/c/payloads/time.h | 11 +- src/c/psse.c | 12 +- 20 files changed, 390 insertions(+), 244 deletions(-) create mode 100644 src/c/payloads/time.c diff --git a/src/c/debug.c b/src/c/debug.c index a551b19..e293e89 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -118,15 +118,15 @@ void debug_println( int level ) { */ void debug_printf( int level, int indent, char32_t *format, ... ) { #ifdef DEBUG - if ( level & verbosity ) { - fwide( stderr, 1 ); - for ( int i = 0; i < indent; i++ ) { - fputws( L" ", stderr ); - } - va_list( args ); - va_start( args, format ); - vfwprintf( stderr, format, args ); - } +// if ( level & verbosity ) { +// fwide( stderr, 1 ); +// for ( int i = 0; i < indent; i++ ) { +// fputws( L" ", stderr ); +// } +// va_list( args ); +// va_start( args, format ); +// vfwprintf( stderr, format, args ); +// } #endif } diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 3bbb021..4c83bc7 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -41,7 +41,7 @@ bool environment_initialised = false; struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer result = initialise_memory( node ); - struct pso_pointer frame_pointer = make_frame( 0, nil ); + struct pso_pointer frame_pointer = nil; // can't have a frame pointer before we've initialised nil and t if ( c_truep( result ) ) { debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); diff --git a/src/c/io/io.c b/src/c/io/io.c index 20e01e1..c2e9c3c 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -106,6 +106,16 @@ struct pso_pointer lisp_stderr; */ struct pso_pointer lisp_io_prompt; +/** + * @brief bound to the Lisp symbol representing C_IO_READBASE in initialisation + */ +struct pso_pointer lisp_io_readbase; + +/** + * @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation + */ +struct pso_pointer lisp_io_readtable; + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. @@ -134,6 +144,10 @@ URL_FILE *file_to_url_file( FILE *f ) { * @return 0 on success; any other value means failure. */ int initialise_io( ) { + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); @@ -150,75 +164,100 @@ int initialise_io( ) { return result; } -struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, +struct pso_pointer initialise_default_streams( struct pso_pointer + frame_pointer, struct pso_pointer env ) { // todo: issue #21: should this have stack frame passed in? // It's called in initialisation before everything else is set // up, so **possibly** not? - lisp_io_in = c_string_to_lisp_symbol( stack_frame, C_IO_IN ); - lisp_io_out = c_string_to_lisp_symbol( stack_frame, C_IO_OUT ); - lisp_io_log = c_string_to_lisp_symbol( stack_frame, C_IO_LOG ); - lisp_io_prompt = c_string_to_lisp_symbol( stack_frame, C_IO_PROMPT ); + lisp_io_in = c_string_to_lisp_symbol( frame_pointer, C_IO_IN ); + lisp_io_out = c_string_to_lisp_symbol( frame_pointer, C_IO_OUT ); + lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG ); + lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT ); + lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE ); + lisp_io_readtable = + c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, 0 ); debug_print_object( env, DEBUG_IO, 0 ); env = - lisp_bind( make_frame - ( 3, stack_frame, lisp_io_prompt, - c_string_to_lisp_string( stack_frame, INITIAL_PROMPT ), - env ) ); + lisp_bind( make_frame( 3, frame_pointer, lisp_io_prompt, + c_string_to_lisp_string( frame_pointer, + INITIAL_PROMPT ), + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_readbase, + acquire_integer( frame_pointer, + 10 ), + lisp_bind( make_frame + ( 3, frame_pointer, + lisp_io_readtable, + nil, env ) ) ) ) ) ); lisp_stdin = lock_object( make_read_stream - ( stack_frame, file_to_url_file( stdin ), - make_cons( stack_frame, - make_cons( stack_frame, + ( frame_pointer, file_to_url_file( stdin ), + make_cons( frame_pointer, + make_cons( frame_pointer, c_string_to_lisp_keyword - ( stack_frame, L"url" ), + ( frame_pointer, L"url" ), c_string_to_lisp_string - ( stack_frame, + ( frame_pointer, L"::system:standard-input" ) ), - stack_frame ) ) ); + frame_pointer ) ) ); env = - lisp_bind( make_frame( 3, stack_frame, lisp_io_in, lisp_stdin, env ) ); + lisp_bind( make_frame + ( 3, frame_pointer, lisp_io_in, lisp_stdin, env ) ); debug_print_object( env, DEBUG_IO, 0 ); if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stdout = - lock_object( make_write_stream( stack_frame, + lock_object( make_write_stream( frame_pointer, file_to_url_file( stdout ), - make_cons( stack_frame, - make_cons( stack_frame, - c_string_to_lisp_keyword - ( stack_frame, - L"url" ), - c_string_to_lisp_string - ( stack_frame, - L"::system:standard-output" ) ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"url" ), + c_string_to_lisp_string + ( frame_pointer, + L"::system:standard-output" ) ), nil ) ) ); env = lisp_bind( make_frame - ( 3, stack_frame, lisp_io_out, lisp_stdout, env ) ); + ( 3, frame_pointer, lisp_io_out, lisp_stdout, env ) ); } if ( !c_nilp( env ) && !exceptionp( env ) ) { lisp_stderr = lock_object( make_write_stream - ( stack_frame, file_to_url_file( stderr ), - make_cons( stack_frame, - make_cons( stack_frame, + ( frame_pointer, file_to_url_file( stderr ), + make_cons( frame_pointer, + make_cons( frame_pointer, c_string_to_lisp_keyword - ( stack_frame, L"url" ), + ( frame_pointer, L"url" ), c_string_to_lisp_string - ( stack_frame, + ( frame_pointer, L"::system:standard-output" ) ), nil ) ) ); env = lisp_bind( make_frame ( 3, frame_pointer, lisp_io_log, lisp_stderr, env ) ); } + // TODO: create the sink stream. Something like: + // URL_FILE *sink = url_fopen( "/dev/null", "w" ); + // fwide( sink->handle.file, 1 ); +// bind_value( L"*sink*", +// make_write_stream( sink, +// make_cons( make_cons +// ( c_string_to_lisp_keyword +// ( L"url" ), +// c_string_to_lisp_string +// ( L"system:standard sink" ) ), +// NIL ) ), false ); + debug_print( L"Leaving initialise_default_streams; environment is: ", DEBUG_IO, 0 ); @@ -226,40 +265,6 @@ struct pso_pointer initialise_default_streams( struct pso_pointer stack_frame, return env; } -/** - * 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; !c_nilp( c ); c = c_cdr( c ) ) { - len++; - } - - char32_t *buffer = calloc( len + 1, sizeof( char32_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; !c_nilp( c ); 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; -} /** * get one wide character from the buffer. @@ -351,25 +356,6 @@ 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`. @@ -384,8 +370,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, 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( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -412,8 +398,8 @@ struct pso_pointer lisp_close( struct pso_pointer 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 ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ) == 0 ) { result = t; } @@ -422,34 +408,43 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer, return result; } -struct pso_pointer add_meta_integer( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, long int value ) { - // todo: issue #21: must have stack frame passed in. - return - make_cons( make_cons - ( c_string_to_lisp_keyword( key ), make_integer( value ) ), - meta ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + make_integer( frame_pointer, value ) ), + meta ); } -struct pso_pointer add_meta_string( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_string( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, char *value ) { - // todo: issue #21: must have stack frame passed in. value = trim( value ); char32_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); - return - make_cons( make_cons - ( c_string_to_lisp_keyword( frame_pointer, key ), - c_string_to_lisp_string( buffer ) ), meta ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + c_string_to_lisp_string( frame_pointer, + buffer ) ), meta ); } -struct pso_pointer add_meta_time( struct pso_pointer meta, char32_t *key, +struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, + struct pso_pointer meta, char32_t *key, time_t *value ) { - // todo: issue #21: must have stack frame passed in. - char datestring[256]; - strftime( datestring, sizeof( datestring ), nl_langinfo( D_T_FMT ), - localtime( value ) ); - return add_meta_string( meta, key, datestring ); + return make_cons( frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_keyword( frame_pointer, + key ), + make_time( frame_pointer, + ( value == + NULL ) ? nil : + make_integer( frame_pointer, + *value ) ) ), meta ); } /** @@ -505,11 +500,12 @@ static size_t write_meta_callback( char *string, size_t size, size_t nmemb, return 0; // strlen( string ); } -void collect_meta( struct pso_pointer stream, char *url ) { +void collect_meta( struct pso_pointer frame_pointer, 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", + add_meta_string( frame_pointer, cell->payload.stream.meta, L"url", url ); struct stat statbuf; int result = stat( url, &statbuf ); @@ -521,21 +517,31 @@ void collect_meta( struct pso_pointer stream, char *url ) { case CFTYPE_FILE: if ( result == 0 ) { if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { - meta = add_meta_string( meta, L"owner", pwd->pw_name ); + meta = + add_meta_string( frame_pointer, meta, L"owner", + pwd->pw_name ); } else { - meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); + meta = + add_meta_integer( frame_pointer, meta, L"owner", + statbuf.st_uid ); } if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { - meta = add_meta_string( meta, L"group", grp->gr_name ); + meta = + add_meta_string( frame_pointer, meta, L"group", + grp->gr_name ); } else { - meta = add_meta_integer( meta, L"group", statbuf.st_gid ); + meta = + add_meta_integer( frame_pointer, meta, L"group", + statbuf.st_gid ); } meta = - add_meta_integer( meta, L"size", + add_meta_integer( frame_pointer, meta, L"size", ( intmax_t ) statbuf.st_size ); - meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); + meta = + add_meta_time( frame_pointer, meta, L"modified", + &statbuf.st_mtime ); } break; case CFTYPE_CURL: @@ -595,75 +601,51 @@ struct pso_pointer 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) ) ) { - // char *url = lisp_string_to_c_string( fetch_arg( frame, 0) ); - // if ( c_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 pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); - if ( readp( stream_pointer ) ) { - result = make_string( frame_pointer, - url_fgetwc( stream_get_url_file - ( stream_pointer ) ), nil ); + if ( stringp( fetch_arg( frame, 0 ) ) ) { + char *url = lisp_string_to_c_string( fetch_arg( frame, 0 ) ); + if ( c_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( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Could not open stream" ) ) ); + break; + case CFTYPE_FILE: + if ( stream->handle.file == NULL ) { + return make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Could not open file" ) ) ); + } + break; + case CFTYPE_CURL: + /* can't tell whether a URL is bad without reading it */ + break; + } + result = make_read_stream( frame_pointer, stream, nil ); + } else { + // TODO: anything more complex is a problem for another day. + URL_FILE *stream = url_fopen( url, "w" ); + result = make_write_stream( frame_pointer, stream, nil ); + } + if ( pointer_to_object( result )->payload.stream.stream == NULL ) { + result = nil; + } else { + collect_meta( frame_pointer, result, url ); + } + free( url ); } return result; } + /** * Function: return a string representing all characters from the stream * indicated by arg 0; further arguments are ignored. diff --git a/src/c/io/io.h b/src/c/io/io.h index cc660d1..10552b4 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -33,10 +33,14 @@ struct pso_pointer initialise_default_streams( struct pso_pointer #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" #define C_IO_LOG L"*log*" +#define C_IO_READBASE L"*read_base*" +#define C_IO_READTABLE L"*read_table*" extern struct pso_pointer lisp_io_in; extern struct pso_pointer lisp_io_out; extern struct pso_pointer lisp_io_log; +extern struct pso_pointer lisp_io_readbase; +extern struct pso_pointer lisp_io_read_table; extern struct pso_pointer lisp_stdin; extern struct pso_pointer lisp_stdout; @@ -47,11 +51,12 @@ extern struct pso_pointer lisp_stderr; extern struct pso_pointer lisp_io_prompt; + + 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 ); @@ -65,9 +70,6 @@ lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ); struct pso_pointer -lisp_read_char( struct pso_pointer frame_pointer, struct pso_pointer env ); -struct pso_pointer 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/read.c b/src/c/io/read.c index 8525836..2b44d55 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" #include "payloads/read_stream.h" @@ -73,12 +74,7 @@ * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer read_example( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer stream = fetch_arg( frame, 0 ); struct pso_pointer readtable = fetch_arg( frame, 1 ); @@ -88,6 +84,31 @@ struct pso_pointer read_example( 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 read_character( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer result = nil; + struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); + if ( readp( stream_pointer ) ) { + result = make_string( frame_pointer, + url_fgetwc( stream_get_url_file + ( stream_pointer ) ), nil ); + } + + return result; +} + /** * @brief Read one integer from the stream and return it. * @@ -111,7 +132,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { if ( readp( stream ) ) { if ( c_nilp( character ) ) { - character = get_character( stream ); + character = + read_character( make_frame( 1, frame_pointer, stream ) ); } char32_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; @@ -137,7 +159,8 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { if ( readp( stream ) ) { if ( c_nilp( character ) ) { - character = get_character( stream ); + character = + read_character( make_frame( 1, frame_pointer, stream ) ); } char32_t c = c_nilp( character ) @@ -186,7 +209,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( character ) ) { - character = get_character( stream ); + character = read_character( make_frame( 1, frame_pointer, stream ) ); } struct pso_pointer readmacro = c_assoc( character, readtable ); @@ -205,12 +228,10 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { /* 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 ); + result = make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Read: end of input while reading" ) ) ); break; default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, diff --git a/src/c/io/read.h b/src/c/io/read.h index 7bb4687..5508510 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -13,6 +13,8 @@ #ifndef __psse_io_read_h #define __psse_io_read_h +struct pso_pointer read_character( struct pso_pointer frame_pointer ); + struct pso_pointer read_number( struct pso_pointer frame_pointer ); struct pso_pointer read_symbol( struct pso_pointer frame_pointer ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 16e60f9..b827f50 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -35,6 +35,26 @@ #include "ops/truth.h" +/** + * @brief a means of creating a cons cell without using a stack frame, to + * prevent runaway recursion. + * + * @param car + * @param cdr + * + * return cons + */ +struct pso_pointer cheaty_make_cons( struct pso_pointer car, + struct pso_pointer cdr ) { + struct pso_pointer result = allocate( nil, CONSTAG, 2 ); + struct pso2 *obj = pointer_to_object( result ); + + obj->payload.cons.car = car; + obj->payload.cons.cdr = cdr; + + return result; +} + /** * @brief Allocate an object of this `size_class` with this `tag`. * @@ -67,15 +87,18 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, struct pso4 *frame = pointer_to_pso4( frame_pointer ); if ( !c_nilp( result ) ) { - strncpy( ( char * ) ( pointer_to_object( result )->header.tag. - bytes.mnemonic ), tag, TAGLENGTH ); + strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes. + mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); if ( stackp( frame_pointer ) ) { - struct pso_pointer locals = make_cons( frame_pointer, result, - frame->payload. - stack_frame.locals ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = cheaty_make_cons( result, + frame-> + payload.stack_frame. + locals ); frame->payload.stack_frame.locals = locals; } else if ( memory_initialised ) { diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 812d582..2d93a50 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -48,7 +48,7 @@ struct pso2 { 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 time_payload time; struct vectorp_payload vectorp; } payload; }; diff --git a/src/c/memory/pso4.c b/src/c/memory/pso4.c index d68e1e2..745af24 100644 --- a/src/c/memory/pso4.c +++ b/src/c/memory/pso4.c @@ -1,5 +1,5 @@ /** - * memory/pso4.h + * memory/pso4.c * * Paged space object of size class 4, 16 words total, 14 words payload. * @@ -11,5 +11,3 @@ #include "memory/pso.h" #include "memory/pso2.h" #include "memory/pso4.h" - -struct pso4 *pointer_to_pso4( struct pso_pointer p ); diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index bafda3f..59996f7 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -13,6 +13,7 @@ #include #include "memory/header.h" + #include "payloads/free.h" #include "payloads/stack.h" @@ -31,6 +32,7 @@ struct pso4 { } payload; }; -struct pso4 *pointer_to_pso4( struct pso_pointer p ); +// struct pso4 *pointer_to_pso4( struct pso_pointer p ); +#define pointer_to_pso4(p)((struct pso4*)pointer_to_object(p)) #endif diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index f77cbb8..d61f6e8 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -108,8 +108,8 @@ struct pso_pointer assoc( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_assoc( key, store ); } @@ -130,8 +130,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_interned( key, store ); } @@ -152,8 +152,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index e2f46fe..a427a2b 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -41,7 +41,7 @@ * * @param dummy */ -void int_handler( int dummy ) { +void interrupt_handler( int dummy ) { wprintf( L"TODO: handle ctrl-C in a more interesting way\n" ); } @@ -52,7 +52,7 @@ void repl( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); // todo: issue #21: must have stack frame passed in. - signal( SIGINT, int_handler ); + signal( SIGINT, interrupt_handler ); debug_print( L"Entered repl\n", DEBUG_REPL, 0 ); struct pso_pointer env = fetch_env( frame_pointer ); diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 7bdc88a..74d0f47 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -8,7 +8,8 @@ */ #include - +#include +#include /* * wide characters */ @@ -143,7 +144,7 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, * Return a lisp string representation of this wide character string. */ struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, - char32_t *string ) { + wchar_t *string ) { struct pso_pointer result = nil; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { @@ -159,6 +160,53 @@ struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, 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 = 1; + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { + len++; + } + + wchar_t *buffer = calloc( len, sizeof( char32_t ) ); + int i = 0; + for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { + buffer[i++] = + ( wchar_t ) ( pointer_to_object( c )->payload.string. + character ); + } + + mbstate_t ps; + const wchar_t *src = buffer; + memset( &ps, 0, sizeof( ps ) ); + result = + calloc( wcsrtombs( NULL, &src, len, &ps ) + 1, sizeof( char ) ); + src = buffer; + memset( &ps, 0, sizeof( ps ) ); + wcsrtombs( result, &src, len, &ps ); + free( buffer ); +// mbstate_t ps = mbstate_t(); +// +// result = calloc( wcsrtombs( NULL, &buffer, len, &ps) + 1 ); +// wcsrtombs( result, &buffer, len, &ps); +// 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; +} + /** * Return a lisp symbol representation of this wide character string. In diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 781901f..463aab7 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -31,7 +31,9 @@ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, - char32_t * string ); + wchar_t *string ); +char *lisp_string_to_c_string( struct pso_pointer s ); + struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, char32_t * symbol ); diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 8fe53d7..9b85b5a 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -39,3 +39,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer, return result; } + +struct pso_pointer acquire_integer( struct pso_pointer frame_pointer, + int64_t value ) { + return make_integer( frame_pointer, value ); +} diff --git a/src/c/payloads/integer.h b/src/c/payloads/integer.h index ea8464a..b60cabe 100644 --- a/src/c/payloads/integer.h +++ b/src/c/payloads/integer.h @@ -27,5 +27,7 @@ struct integer_payload { struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ); +struct pso_pointer acquire_integer( struct pso_pointer frame_pointer, + int64_t value ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 3a3fa70..34682ed 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -42,7 +42,6 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_list args; va_start( args, previous ); - struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -53,9 +52,9 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = previous; if ( stackp( previous ) ) { + struct pso4 *prev_frame = pointer_to_pso4( previous ); new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; new_frame->payload.stack_frame.env = @@ -193,8 +192,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = length( make_frame( 1, previous, argvalues ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )-> - payload.integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )->payload. + integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -252,8 +251,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload.stack_frame. - env ); + ( previous )->payload. + stack_frame.env ); } diff --git a/src/c/payloads/time.c b/src/c/payloads/time.c new file mode 100644 index 0000000..6dad3c2 --- /dev/null +++ b/src/c/payloads/time.c @@ -0,0 +1,57 @@ +/** + * payloads/time.c + * + * A time record. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + + +#include "memory/tags.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "payloads/integer.h" +#include "payloads/stack.h" +#include "payloads/time.h" + +#define _GNU_SOURCE + +#define seconds_per_year 31557600L + +/** + * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before + * the UNIX epoch; the value in microseconds will break the C reader. + */ +unsigned __int128 epoch_offset = + ( ( __int128 ) ( seconds_per_year * 1000000000L ) * + ( __int128 ) ( 14L * 1000000000L ) ); + + +unsigned __int128 unix_time_to_lisp_time( time_t t ) { + unsigned __int128 result = epoch_offset + ( t * 1000000000 ); + + return result; +} + + +struct pso_pointer make_time( struct pso_pointer frame_pointer, + struct pso_pointer specification ) { + struct pso_pointer result = allocate( frame_pointer, TIMETAG, 2 ); + struct pso2 *cell = pointer_to_object( result ); + + if ( integerp( specification ) ) { + cell->payload.time.value = + pointer_to_object( specification )->payload.integer.value; + } else { + cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); + } + + return result; +} diff --git a/src/c/payloads/time.h b/src/c/payloads/time.h index d808c0e..0890e8a 100644 --- a/src/c/payloads/time.h +++ b/src/c/payloads/time.h @@ -1,14 +1,14 @@ /** - * payloads/cons.h + * payloads/time.h * - * A cons cell. + * A timee record. * * (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 +#ifndef __psse_payloads_time_h +#define __psse_payloads_time_h #include #include @@ -31,4 +31,7 @@ struct time_payload { unsigned __int128 value; }; +struct pso_pointer make_time( struct pso_pointer stack_frame, + struct pso_pointer time ); + #endif diff --git a/src/c/psse.c b/src/c/psse.c index 65e9196..a31b59e 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -78,12 +78,6 @@ int main( int argc, char *argv[] ) { bool show_prompt = false; char *infilename = NULL; - setlocale( LC_ALL, "" ); - 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 ) { case 'd': @@ -114,6 +108,12 @@ int main( int argc, char *argv[] ) { } } + setlocale( LC_ALL, "" ); + if ( initialise_io( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); From dd4176e20b5a66a84880aa935cda8f578e0e8892 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 23 Apr 2026 12:29:10 +0100 Subject: [PATCH 51/77] Not much progess. Priority has to be in fixing debug_printf. --- src/c/memory/memory.c | 7 +++++-- src/c/memory/pso.c | 12 +++++++----- src/c/ops/stack_ops.c | 2 +- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index adbf827..658f649 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -109,8 +109,11 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { * on the freelist, but again we should sanity check. */ if ( object->header.count != 0 ) { fwprintf( stderr, - L"WARNING: Request to allocate object of size class %d, which is not implemented", - size_class ); + L"WARNING: Count of %d in newly allocated object at %d, %d, should be 0\n", + result.page, + result.offset, + object->header.count ); + object->header.count = 0; } } } // TODO: else throw exception diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index b827f50..c37549a 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -86,8 +86,14 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, struct pso_pointer result = pop_freelist( size_class ); struct pso4 *frame = pointer_to_pso4( frame_pointer ); + if ( memory_initialised && c_nilp(frame_pointer)) { + fputws( L"WARNING: No stack frame passed to `allocate`.\n", + stderr ); + } + if ( !c_nilp( result ) ) { - strncpy( ( char * ) ( pointer_to_object( result )->header.tag.bytes. + struct pso2 *obj = pointer_to_object(result); + strncpy((char*) (obj->header.tag.bytes. mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", @@ -100,10 +106,6 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, payload.stack_frame. locals ); frame->payload.stack_frame.locals = locals; - - } else if ( memory_initialised ) { - fputws( L"WARNING: No stack frame passed to `allocate`.\n", - stderr ); } } else { // TODO: throw exception diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index bdf5e15..4d566cf 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -29,7 +29,7 @@ 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 ) { + if ( index < frame->payload.stack_frame.args ) { result = frame->payload.stack_frame.arg[index]; } else { struct pso_pointer p = frame->payload.stack_frame.more; From 235d455b80bf1aab4f5151c62ec213ad22fcba23 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 23 Apr 2026 14:45:51 +0100 Subject: [PATCH 52/77] More memory debugging, but what it shows is that deallocation is not happening. --- src/c/debug.c | 18 +++++++------- src/c/io/io.h | 7 +++--- src/c/memory/page.c | 2 +- src/c/memory/pso.c | 59 ++++++++++++++++++++++++++++++++++++--------- src/c/memory/pso.h | 3 +++ src/c/psse.c | 5 ++++ 6 files changed, 69 insertions(+), 25 deletions(-) diff --git a/src/c/debug.c b/src/c/debug.c index e293e89..a551b19 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -118,15 +118,15 @@ void debug_println( int level ) { */ void debug_printf( int level, int indent, char32_t *format, ... ) { #ifdef DEBUG -// if ( level & verbosity ) { -// fwide( stderr, 1 ); -// for ( int i = 0; i < indent; i++ ) { -// fputws( L" ", stderr ); -// } -// va_list( args ); -// va_start( args, format ); -// vfwprintf( stderr, format, args ); -// } + if ( level & verbosity ) { + fwide( stderr, 1 ); + for ( int i = 0; i < indent; i++ ) { + fputws( L" ", stderr ); + } + va_list( args ); + va_start( args, format ); + vfwprintf( stderr, format, args ); + } #endif } diff --git a/src/c/io/io.h b/src/c/io/io.h index 10552b4..baf9e52 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -10,18 +10,17 @@ #ifndef __psse_io_io_h #define __psse_io_io_h + +#include #include /* * wide characters */ -#include -#include #include +#include "io/fopen.h" #include "memory/pointer.h" -#include "memory/pso2.h" -#include "memory/pso4.h" extern CURLSH *io_share; diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 580f100..1d9eebd 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,7 +286,7 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( c_nilp( result ) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, + debug_print( (c_nilp( result ) && (page_index != 0)) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, 0 ); return result; diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index c37549a..f4f130b 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -19,7 +19,9 @@ #include #include #include +#include #include +#include #include "debug.h" @@ -35,6 +37,26 @@ #include "ops/truth.h" +#ifdef DEBUG +int allocation_table_allocated = 0; +int allocation_table_freed = 1; + +long int allocation_table[MAX_SIZE_CLASS +1][2]; + +void print_allocation_table() { + fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", stderr); + fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); + + for ( int s = 2; s<= MAX_SIZE_CLASS; s++) { + long int a = allocation_table[s][allocation_table_allocated]; + long int d = allocation_table[s][allocation_table_freed]; + long int r = a - d; + fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r); + } + fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); +} +#endif + /** * @brief a means of creating a cons cell without using a stack frame, to * prevent runaway recursion. @@ -107,6 +129,9 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, locals ); frame->payload.stack_frame.locals = locals; } +#ifdef DEBUG + allocation_table[size_class][allocation_table_allocated]++; +#endif } else { // TODO: throw exception } @@ -145,8 +170,9 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { object->header.count++; #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] ), + L"\nIncremented object of type %3.3s, size class %d, at page %u, offset %u to count %u", + ( ( char * ) &(object->header.tag.bytes.mnemonic[0] )), + (int)object->header.tag.bytes.size_class, pointer.page, pointer.offset, object->header.count ); if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, @@ -178,9 +204,10 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { object->header.count--; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, - L"\nDecremented object of type %3.3s at page %d, offset %d to count %d", + L"\nDecremented object of type %3.3s, size class %d, at page %d, offset %d to count %d", ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - pointer.page, pointer.offset, object->header.count ); + (int)object->header.tag.bytes.size_class, + 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", @@ -219,20 +246,30 @@ struct pso_pointer lock_object( struct pso_pointer 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 free_object( struct pso_pointer pointer ) { struct pso_pointer result = nil; - struct pso2 *obj = pointer_to_object( p ); - uint32_t array_size = ( uint32_t ) payload_size( obj ); - uint8_t size_class = ( obj->header.tag.bytes.size_class ); + struct pso2 *object = pointer_to_object( pointer ); + uint32_t array_size = ( uint32_t ) payload_size( object ); + uint8_t size_class = ( object->header.tag.bytes.size_class ); - result = destroy( p ); + result = destroy( pointer ); /* 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; + object->payload.words[i] = 0; } - push_freelist( p ); + push_freelist( pointer ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + (int)object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count + ); + + allocation_table[size_class][allocation_table_freed]++; +#endif return result; } diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index efb8075..45bfdce 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -27,4 +27,7 @@ struct pso_pointer lock_object( struct pso_pointer pointer ); struct pso_pointer free_object( struct pso_pointer p ); +#ifdef DEBUG +void print_allocation_table(); +#endif #endif diff --git a/src/c/psse.c b/src/c/psse.c index a31b59e..79c1a5b 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -149,6 +149,11 @@ int main( int argc, char *argv[] ) { repl( bootstrap_stack ); dec_ref( bootstrap_stack ); + dec_ref( oblist); +#ifdef DEBUG + print_allocation_table(); +#endif + exit( 0 ); } From 9425506e2a48ca6f1e1b2d39c131e59ddb51675c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 23 Apr 2026 17:34:07 +0100 Subject: [PATCH 53/77] OK, garbage collection is now working a little bit. --- src/c/io/print.c | 6 +++--- src/c/memory/pso.c | 38 ++++++++++++++++++++++---------------- src/c/payloads/exception.c | 8 ++++---- src/c/payloads/stack.c | 12 ++++++++++-- src/c/psse.c | 11 ++++++----- 5 files changed, 45 insertions(+), 30 deletions(-) diff --git a/src/c/io/print.c b/src/c/io/print.c index b1ce56e..e56f542 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -209,13 +209,13 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { bool nl_before = c_truep( fetch_arg( frame, 3 ) ); bool nl_after = c_truep( fetch_arg( frame, 4 ) ); struct pso_pointer result = object; - URL_FILE *output = writep( stream ) - ? pointer_to_object( stream )->payload.stream.stream - : file_to_url_file( stdout ); + struct pso2* stream_obj = pointer_to_object( stream ); if ( writep( stream ) ) { inc_ref( stream ); + URL_FILE *output = stream_obj->payload.stream.stream; + if ( nl_before ) url_fputwc( L'\n', output ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index f4f130b..93696d7 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -198,6 +198,10 @@ 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 (freep(pointer)) { + fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr); + } if ( !c_nilp( pointer ) && object->header.count > 0 && object->header.count != MAXREFERENCE ) { @@ -217,12 +221,11 @@ struct pso_pointer dec_ref( struct pso_pointer pointer ) { debug_println( DEBUG_ALLOC ); } #endif - - if ( object->header.count == 0 ) { - free_object( pointer ); - pointer = nil; - } } + if ( object->header.count == 0 ) { + free_object( pointer ); + pointer = nil; + } return pointer; } @@ -259,17 +262,20 @@ struct pso_pointer free_object( struct pso_pointer pointer ) { object->payload.words[i] = 0; } - push_freelist( pointer ); - -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count - ); + #ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + (int)object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count + ); + + allocation_table[size_class][allocation_table_freed]++; + #endif - allocation_table[size_class][allocation_table_freed]++; -#endif + strncpy((char*) (object->header.tag.bytes. + mnemonic ), FREETAG, TAGLENGTH ); + + push_freelist( pointer ); return result; } diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index aa9f33c..33a0e4b 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -59,12 +59,12 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { if ( !c_nilp( result ) && !exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); - object->payload.exception.message = message; + object->payload.exception.message = inc_ref(message); object->payload.exception.stack = - stackp( frame_pointer ) ? frame_pointer : nil; + stackp( frame_pointer ) ? inc_ref(frame_pointer) : nil; object->payload.exception.meta = ( consp( meta ) - || hashtabp( meta ) ) ? meta : nil; - object->payload.exception.cause = exceptionp( cause ) ? cause : nil; + || hashtabp( meta ) ) ? inc_ref(meta) : nil; + object->payload.exception.cause = exceptionp( cause ) ? inc_ref(cause) : nil; } return result; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 34682ed..927ac90 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -62,6 +62,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, } else { new_frame->payload.stack_frame.depth = 0; } + + new_frame->payload.stack_frame.previous = inc_ref( previous); debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", new_frame->payload.stack_frame.depth ); @@ -127,7 +129,7 @@ struct pso_pointer make_frame_with_env( int arg_count, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = inc_ref(previous); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -201,7 +203,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = previous; + prev_frame->payload.stack_frame.previous = inc_ref( previous); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -277,6 +279,12 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( frame->payload.stack_frame.arg[i] ); } + frame->payload.stack_frame.previous = nil; + frame->payload.stack_frame.function = nil; + frame->payload.stack_frame.more = nil; + frame->payload.stack_frame.locals = nil; + frame->payload.stack_frame.env = nil; + frame->payload.stack_frame.args = 0; frame->payload.stack_frame.depth = 0; } diff --git a/src/c/psse.c b/src/c/psse.c index 79c1a5b..c7e740c 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -77,6 +77,11 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; char *infilename = NULL; + + 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 ) { @@ -109,11 +114,7 @@ int main( int argc, char *argv[] ) { } setlocale( LC_ALL, "" ); - if ( initialise_io( ) != 0 ) { - fputs( "Failed to initialise I/O subsystem\n", stderr ); - exit( 1 ); - } - + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); From 22b0160a266999c939c9a21df150542f8b2f0b25 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 24 Apr 2026 09:22:06 +0100 Subject: [PATCH 54/77] Builds and runs, but print is badly broken. Need some rethink. --- src/c/debug.c | 18 +++++---- src/c/io/io.c | 88 ++++++++++++++++++++---------------------- src/c/io/print.c | 79 ++++++++++++++++++++++++++----------- src/c/io/print.h | 2 +- src/c/memory/pso3.h | 3 ++ src/c/payloads/stack.c | 2 +- src/c/psse.c | 17 +++----- 7 files changed, 118 insertions(+), 91 deletions(-) diff --git a/src/c/debug.c b/src/c/debug.c index a551b19..a494358 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -19,6 +19,8 @@ #include "io/io.h" #include "io/print.h" +#include "memory/dump.h" + int verbosity = 0; @@ -143,7 +145,7 @@ void debug_print_object( struct pso_pointer pointer, int level, int indent ) { if ( level & verbosity ) { URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - in_write( pointer, ustderr, PRINT_VARIANT_PRINT ); + in_write( pointer, ustderr, PRINT_VARIANT_PRINT, indent ); free( ustderr ); } #endif @@ -156,14 +158,14 @@ void debug_print_object( struct pso_pointer pointer, int level, int indent ) { * turn debugging on for only one part of the system. */ void debug_dump_object( struct pso_pointer pointer, int level, int indent ) { -//#ifdef DEBUG -// if ( level & verbosity ) { -// URL_FILE *ustderr = file_to_url_file( stderr ); -// fwide( stderr, 1 ); +#ifdef DEBUG + if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); + fwide( stderr, 1 ); // dump_object( ustderr, pointer ); -// free( ustderr ); -// } -//#endif + free( ustderr ); + } +#endif } ///** diff --git a/src/c/io/io.c b/src/c/io/io.c index c2e9c3c..7a8aacd 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -451,61 +451,57 @@ struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, * 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, +static size_t write_meta_callback( struct pso_pointer frame_pointer, char *string, size_t size, size_t nmemb, struct pso_pointer stream ) { - struct pso2 *cell = pointer_to_object( stream ); + struct pso2 *object = 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] ); - // char32_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 ); + char *s = calloc( strlen( string ), sizeof( char ) ); + strcpy( s, string ); + if ( readp(stream) || + writep(stream) ) { + int offset = index_of( ':', s ); + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = trim( s ); + char *value = trim( &s[++offset] ); + char32_t wname[strlen( name )]; + mbstowcs( wname, name, strlen( name ) + 1 ); + object->payload.stream.meta = + add_meta_string( frame_pointer, object->payload.stream.meta, wname, value ); + debug_printf( DEBUG_IO, 0, + 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] ); + object->payload.stream.meta = + add_meta_integer( frame_pointer, add_meta_string + (frame_pointer, object->payload.stream.meta, L"status", + value ), L"status-code", strtol( value, + NULL, + 10 ) ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header 'status': value '%s'\n", value ); + } else { + debug_printf( DEBUG_IO, 0, + 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, 0 ); + debug_dump_object( stream, DEBUG_IO, 0 ); + } + free( s ); return 0; // strlen( string ); } void collect_meta( struct pso_pointer frame_pointer, struct pso_pointer stream, char *url ) { - struct pso2 *cell = pointer_to_object( stream ); + struct pso2 *object = pointer_to_object( stream ); URL_FILE *s = pointer_to_object( stream )->payload.stream.stream; struct pso_pointer meta = - add_meta_string( frame_pointer, cell->payload.stream.meta, L"url", + add_meta_string( frame_pointer, object->payload.stream.meta, L"url", url ); struct stat statbuf; int result = stat( url, &statbuf ); @@ -554,7 +550,7 @@ void collect_meta( struct pso_pointer frame_pointer, struct pso_pointer stream, /* this is destructive change before the cell is released into the * wild, and consequently permissible, just. */ - cell->payload.stream.meta = meta; + object->payload.stream.meta = meta; } /** diff --git a/src/c/io/print.c b/src/c/io/print.c index e56f542..7a158d1 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -34,6 +34,8 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso3.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/string_ops.h" @@ -46,7 +48,7 @@ #include "ops/truth.h" struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, - bool escape ); + bool escape, int indent ); /** * @brief write this character `wc` to this `output` stream, escaping it if @@ -70,11 +72,11 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, URL_FILE *output, bool escape ) { switch ( get_tag_value( p ) ) { case KEYTV: - url_fputwc( L':', output ); + write_char( L':', output, escape ); break; case STRINGTV: if ( escape ) - url_fputwc( L'"', output ); + write_char( L'"', output, escape ); break; } @@ -90,7 +92,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, if ( stringp( p ) ) { if ( escape ) - url_fputwc( L'"', output ); + write_char( L'"', output, escape ); } return p; @@ -104,7 +106,7 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, for ( ; consp( p ); p = c_cdr( p ) ) { struct pso2 *object = pointer_to_object( p ); - result = in_write( object->payload.cons.car, output, escape ); + result = in_write( object->payload.cons.car, output, escape, 0 ); if ( exceptionp( result ) ) break; @@ -113,12 +115,12 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, case NILTV: break; case CONSTV: - url_fputwc( L' ', output ); + write_char( L' ', output, escape ); break; default: url_fputws( L" . ", output ); result = - in_write( object->payload.cons.cdr, output, escape ); + in_write( object->payload.cons.cdr, output, escape, 0 ); } } } else { @@ -128,6 +130,13 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, return result; } +void in_write_nl (URL_FILE *output, int indent) { + write_char( L'\n', output, false); + for (int i = 0; i < indent; i++) { + write_char( L'\t', output, false); + } +} + /** * This is kind of modelled after the implementation of PRIN* variants on page * 383 of the aluminium book. It is the inner workings of all PRIN* functions. @@ -139,7 +148,7 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, * @return p on success, exception on failure. */ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, - bool escape ) { + bool escape, int indent ) { struct pso2 *object = pointer_to_object( p ); struct pso_pointer result = nil; @@ -151,10 +160,26 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, escape ); break; case CONSTV: - url_fputwc( L'(', output ); + write_char( L'(', output, escape); result = write_list_content( p, output, escape ); - url_fputwc( L')', output ); + write_char( L')', output, escape); break; + case EXCEPTIONTV : + struct pso3* exception = pointer_to_pso3(p); + url_fputws( L"payload.exception.message, output, escape, indent); + if (!c_nilp( exception->payload.exception.meta)) { + in_write_nl( output, indent+1); + url_fputws( L"metadata: ", output); + in_write( exception->payload.exception.meta, output, escape, indent); + } + if (!c_nilp( exception->payload.exception.cause)) { + in_write_nl( output, indent+1); + url_fputws( L"cause: ", output); + in_write( exception->payload.exception.cause, output, escape, indent); + } + write_char( L'>', output, escape); + break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -171,11 +196,11 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, case WRITETV: url_fwprintf( output, L"<%s stream: ", v == READTV ? "read" : "write" ); - in_write( object->payload.stream.meta, output, escape ); - url_fputwc( L'>', output ); + in_write( object->payload.stream.meta, output, escape, indent ); + write_char( L'>', output, escape ); break; case TRUETV: - url_fputwc( L't', output ); + write_char( L't', output, escape ); break; default: // TODO: return exception @@ -212,18 +237,14 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { struct pso2* stream_obj = pointer_to_object( stream ); if ( writep( stream ) ) { - inc_ref( stream ); - URL_FILE *output = stream_obj->payload.stream.stream; if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( object, output, true ); + result = in_write( object, output, true, 0); url_fputwc( nl_after ? L'\n' : L' ', output ); - - dec_ref( stream ); } else { result = make_exception( make_frame( 1, frame_pointer, @@ -245,9 +266,15 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { struct pso_pointer print( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - return write( make_frame( 5, frame_pointer, + struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, - t, nil ) ); + t, nil )); + + struct pso_pointer result = write( next ); + + dec_ref( next); + + return result; } /** @@ -256,7 +283,13 @@ struct pso_pointer print( struct pso_pointer frame_pointer ) { struct pso_pointer princ( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - return write( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), - nil, t, nil ) ); + struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, + fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), + nil, t, nil )); + + struct pso_pointer result = write( next ); + + dec_ref( next); + + return result; } diff --git a/src/c/io/print.h b/src/c/io/print.h index c6716e4..8c5fdf5 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -24,6 +24,6 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ); #define PRINT_VARIANT_PRINC 2 struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, - bool variant ); + bool escape, int indent ); #endif diff --git a/src/c/memory/pso3.h b/src/c/memory/pso3.h index c4975b1..ee48806 100644 --- a/src/c/memory/pso3.h +++ b/src/c/memory/pso3.h @@ -34,4 +34,7 @@ struct pso3 { } payload; }; +#define pointer_to_pso3(p)((struct pso3*)pointer_to_object_of_size_class(p,3)) + + #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 927ac90..ed65024 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -134,7 +134,6 @@ struct pso_pointer make_frame_with_env( int arg_count, if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = env; } else { new_frame->payload.stack_frame.depth = 0; } @@ -144,6 +143,7 @@ struct pso_pointer make_frame_with_env( int arg_count, int cursor = 0; new_frame->payload.stack_frame.args = arg_count; + new_frame->payload.stack_frame.env = env; for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { struct pso_pointer argument = va_arg( args, struct pso_pointer ); diff --git a/src/c/psse.c b/src/c/psse.c index c7e740c..38f7d96 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -134,18 +134,11 @@ int main( int argc, char *argv[] ) { stdout ); } - struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, - consp - ( oblist ) - ? oblist - : - make_cons - ( nil, - oblist, - nil ), - show_prompt - ? t : - nil ) ); + struct pso_pointer bootstrap_stack = inc_ref( + make_frame_with_env(1, nil, + consp + ( oblist ) ? oblist : make_cons(nil, oblist, nil), + show_prompt ? t : nil)); repl( bootstrap_stack ); From 63906fe817d509adb6171a72d16c045c2793ebed Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 24 Apr 2026 21:20:23 +0100 Subject: [PATCH 55/77] Print is less badly broken. Read is less badly broken. GC is too aggressive. --- docs/State-of-play.md | 63 ++++++++++ src/c/debug.c | 2 +- src/c/io/io.c | 86 +++++++------ src/c/io/print.c | 84 +++++++------ src/c/io/read.c | 24 ++-- src/c/memory/memory.c | 17 ++- src/c/memory/page.c | 7 +- src/c/memory/pso.c | 250 ++++++++++++++++++++----------------- src/c/memory/pso.h | 2 +- src/c/ops/assoc.c | 17 +++ src/c/ops/eq.c | 3 +- src/c/ops/eval_apply.c | 112 +++++++++-------- src/c/ops/repl.c | 25 ++-- src/c/ops/stack_ops.c | 25 ++++ src/c/ops/stack_ops.h | 3 + src/c/payloads/exception.c | 12 +- src/c/payloads/integer.c | 6 +- src/c/payloads/stack.c | 20 +-- src/c/psse.c | 34 +++-- 19 files changed, 489 insertions(+), 303 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 6796248..eba1311 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,68 @@ # State of Play +## 20260424 + +### To have `c_` functions or not to have `c_` functions, revisited + +Right, I was hugely pleased with my 'make everything a Lisp, function, and then call it from C' idea. I wrote things like: + +```c + print( make_frame( 2, base_of_stack, + eval( make_frame( 1, base_of_stack, + read( make_frame( 1, base_of_stack, input_stream ) ) ) ), + output_stream ) ); +``` + +Isn't it beautiful? Isn't it elegant? Isn't it clear? Yes, it is. Does it work? Yes, actually, it does. Is it a total crock? Unfortunately, dear reader, it is. In this pattern, we don't have a handle on any of the stack frames made with make_frame, so we can't `dec_ref` them, so they don't get garbage collected. And while during bootstrap it's inevitable that there's a little crud left over because it was created before we have enough infrastructure set up, what I'm seeing at present from a 'start up and shut down run' is + +| Size class | Allocated | Deallocated | Remaining | +| ------------ | ------------ | ------------ | ------------ | +| 2 | 453 | 1 | 452 | +| 3 | 1 | 0 | 1 | +| 4 | 49 | 4 | 45 | +| 5 | 0 | 0 | 0 | +| 6 | 0 | 0 | 0 | + +The 452 unfreed objects in size class two are cons cells and string fragments, and they mostly represent the metadata on the streams `*in*`, `*out*`, `*log*` and `*sink*`, all of which are deliberately protected from garbage collection because, frankly, you don't want those things going away under you; so that's kind of OK. The one in size class three is an exception, and I'm quite pleased I'm only throwing one exception during bootstrap (although it would be nice it it got cleaned up). + +But the 45 unfreed objects in size class four are stackframes, and the reason they're unfreed is the coding pattern you see above. + +So, how to get around this? + +The code snippet above could be rewritten: + +```c + struct pso_pointer next = inc_ref( make_frame(1, base_of_stack, input_stream)); + struct pso_pointer read_value = inc_ref(read(next)); + dec_ref( next); + + next = inc_ref( make_frame(1, base_of_stack, read_value)); + struct pso_pointer eval_value = inc_ref( eval( next)); + dec_ref( next); + dec_ref( read_value); + + next = inc_ref( make_frame(2, base_of_stack, eval_value, output_stream)); + print( next); + dec_ref( next); + dec_ref( eval_value); +``` +This is much more prolix and, to me, less elegant; but it does get the garbage collected. In each stanza we're first setting up a frame with the arguments for the function we're about to call, then calling that function with the frame we've set up, and then `dec_ref`ing the frame. We shouldn't need to `dec_ref` the value returned by `print`, since we don't use it and the only thing holding a reference to it is the frame in which it was created, which we do `dec_ref`. + +I could `dec_ref` `read_value`, for instance, as soon as I've put it into the frame for `eval` rather than after `eval` has actually been invoked, since the frame is now protecting it from garbage collection; but I've delayed doing so until afterwards out of caution. + +Once we have `eval`/`apply` working, we won't need to do all this bureaucratic incrementing and decrementing of reference counts explicitly, since `eval`/`apply` *should* take care of it automatically. + +I'm still not 100% confident I can make the reference counting garbage collector work reliably, irrespective of whether it's actually efficient. + +### To recode or not to recode? + +There are 55 calls to `make_frame` in existing C code, and they're almost all written in the 'elegant but insanitary' pattern. Could they be rewritten more cleanly? Yes, they could. But my hope is most of this code will be replaced with code written in Lisp, once we have Lisp sufficiently bootstrapped to make that possible. + +So I think I'm going to put up with the uncollected garbage until we get to that point, at which point I'll audit the C code to see what is actually still in use, sanitise that, and delete the rest. + +However, any new C code (and there is going to have to be some) *must* be written in the sanitary but bureaucratic pattern. + + ## 20260421 ### To have `c_` functions or not to have `c_` functions? diff --git a/src/c/debug.c b/src/c/debug.c index a494358..6c4796d 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -19,7 +19,7 @@ #include "io/io.h" #include "io/print.h" -#include "memory/dump.h" +// #include "memory/dump.h" int verbosity = 0; diff --git a/src/c/io/io.c b/src/c/io/io.c index 7a8aacd..8865a0d 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,7 +114,8 @@ struct pso_pointer lisp_io_readbase; /** * @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation */ -struct pso_pointer lisp_io_readtable; +struct pso_pointer lisp_io_read_table; + /** * Allow a one-character unget facility. This may not be enough - we may need @@ -175,7 +176,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG ); lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT ); lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE ); - lisp_io_readtable = + lisp_io_read_table = c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, @@ -192,7 +193,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer 10 ), lisp_bind( make_frame ( 3, frame_pointer, - lisp_io_readtable, + lisp_io_read_table, nil, env ) ) ) ) ) ); lisp_stdin = @@ -451,48 +452,51 @@ struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, * 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( struct pso_pointer frame_pointer, char *string, size_t size, size_t nmemb, +static size_t write_meta_callback( struct pso_pointer frame_pointer, + char *string, size_t size, size_t nmemb, struct pso_pointer stream ) { struct pso2 *object = 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 ( readp(stream) || - writep(stream) ) { - int offset = index_of( ':', s ); - if ( offset != -1 ) { - s[offset] = ( char ) 0; - char *name = trim( s ); - char *value = trim( &s[++offset] ); - char32_t wname[strlen( name )]; - mbstowcs( wname, name, strlen( name ) + 1 ); - object->payload.stream.meta = - add_meta_string( frame_pointer, object->payload.stream.meta, wname, value ); - debug_printf( DEBUG_IO, 0, - 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] ); - object->payload.stream.meta = - add_meta_integer( frame_pointer, add_meta_string - (frame_pointer, object->payload.stream.meta, L"status", - value ), L"status-code", strtol( value, - NULL, - 10 ) ); - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: added header 'status': value '%s'\n", value ); - } else { - debug_printf( DEBUG_IO, 0, - 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, 0 ); - debug_dump_object( stream, DEBUG_IO, 0 ); - } - free( s ); + char *s = calloc( strlen( string ), sizeof( char ) ); + strcpy( s, string ); + if ( readp( stream ) || writep( stream ) ) { + int offset = index_of( ':', s ); + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = trim( s ); + char *value = trim( &s[++offset] ); + char32_t wname[strlen( name )]; + mbstowcs( wname, name, strlen( name ) + 1 ); + object->payload.stream.meta = + add_meta_string( frame_pointer, object->payload.stream.meta, + wname, value ); + debug_printf( DEBUG_IO, 0, + 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] ); + object->payload.stream.meta = + add_meta_integer( frame_pointer, add_meta_string + ( frame_pointer, object->payload.stream.meta, + L"status", value ), L"status-code", + strtol( value, NULL, 10 ) ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header 'status': value '%s'\n", + value ); + } else { + debug_printf( DEBUG_IO, 0, + 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, 0 ); + debug_dump_object( stream, DEBUG_IO, 0 ); + } + free( s ); return 0; // strlen( string ); } diff --git a/src/c/io/print.c b/src/c/io/print.c index 7a158d1..1ca8a35 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -120,7 +120,8 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, default: url_fputws( L" . ", output ); result = - in_write( object->payload.cons.cdr, output, escape, 0 ); + in_write( object->payload.cons.cdr, output, escape, + 0 ); } } } else { @@ -130,11 +131,11 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, return result; } -void in_write_nl (URL_FILE *output, int indent) { - write_char( L'\n', output, false); - for (int i = 0; i < indent; i++) { - write_char( L'\t', output, false); - } +void in_write_nl( URL_FILE *output, int indent ) { + write_char( L'\n', output, false ); + for ( int i = 0; i < indent; i++ ) { + write_char( L'\t', output, false ); + } } /** @@ -160,26 +161,36 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, escape ); break; case CONSTV: - write_char( L'(', output, escape); + write_char( L'(', output, escape ); result = write_list_content( p, output, escape ); - write_char( L')', output, escape); + write_char( L')', output, escape ); + break; + case EXCEPTIONTV:{ + struct pso3 *exception = pointer_to_pso3( p ); + + if ( exception != NULL ) { + url_fputws( L"payload.exception.message, output, + escape, indent ); + if ( !c_nilp( exception->payload.exception.meta ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"metadata: ", output ); + in_write( exception->payload.exception.meta, + output, escape, indent ); + } + + if ( !c_nilp( exception->payload.exception.cause ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"cause: ", output ); + in_write( exception->payload.exception.cause, + output, escape, indent ); + } + write_char( L'>', output, escape ); + } else { + url_fputws( L"", output ); + } + } break; - case EXCEPTIONTV : - struct pso3* exception = pointer_to_pso3(p); - url_fputws( L"payload.exception.message, output, escape, indent); - if (!c_nilp( exception->payload.exception.meta)) { - in_write_nl( output, indent+1); - url_fputws( L"metadata: ", output); - in_write( exception->payload.exception.meta, output, escape, indent); - } - if (!c_nilp( exception->payload.exception.cause)) { - in_write_nl( output, indent+1); - url_fputws( L"cause: ", output); - in_write( exception->payload.exception.cause, output, escape, indent); - } - write_char( L'>', output, escape); - break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -196,7 +207,8 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, case WRITETV: url_fwprintf( output, L"<%s stream: ", v == READTV ? "read" : "write" ); - in_write( object->payload.stream.meta, output, escape, indent ); + in_write( object->payload.stream.meta, output, escape, + indent ); write_char( L'>', output, escape ); break; case TRUETV: @@ -234,15 +246,15 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { bool nl_before = c_truep( fetch_arg( frame, 3 ) ); bool nl_after = c_truep( fetch_arg( frame, 4 ) ); struct pso_pointer result = object; - struct pso2* stream_obj = pointer_to_object( stream ); + struct pso2 *stream_obj = pointer_to_object( stream ); if ( writep( stream ) ) { - URL_FILE *output = stream_obj->payload.stream.stream; + URL_FILE *output = stream_obj->payload.stream.stream; if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( object, output, true, 0); + result = in_write( object, output, escape, 0 ); url_fputwc( nl_after ? L'\n' : L' ', output ); } else { @@ -267,12 +279,13 @@ struct pso_pointer print( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, - t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), t, + t, nil ) ); struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } @@ -284,12 +297,13 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), - nil, t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), + nil, t, nil ) ); - struct pso_pointer result = write( next ); + struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } diff --git a/src/c/io/read.c b/src/c/io/read.c index 2b44d55..336311f 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/character.h" #include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" @@ -101,9 +102,12 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { - result = make_string( frame_pointer, - url_fgetwc( stream_get_url_file - ( stream_pointer ) ), nil ); + wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) ); + result = make_character( frame_pointer, chr ); + +#ifdef DEBUG + debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr ); +#endif } return result; @@ -204,8 +208,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( readtable ) ) { - // TODO: check for the value of `*read-table*` in the environment and - // use that. + readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) ); } if ( c_nilp( character ) ) { @@ -240,9 +243,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { ( frame_pointer, c ) ); inc_ref( next ); if ( iswdigit( c ) ) { - result = read_number( next ); + result = push_local( frame_pointer, read_number( next ) ); } else if ( iswalpha( c ) ) { - result = read_symbol( next ); + result = push_local( frame_pointer, read_symbol( next ) ); } else { // result = // throw_exception( @@ -260,10 +263,15 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { // ), // frame_pointer ); } - dec_ref( next ); +// dec_ref( next ); break; } } +#ifdef DEBUG + debug_print( L"Read object: ", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0 ); + debug_println( DEBUG_IO ); +#endif return result; } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 658f649..bc1e722 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -76,9 +76,14 @@ struct pso_pointer initialise_memory( uint32_t node ) { /** * @brief Pop an object off the freelist for the specified `size_class`. + * + * There is no conventional way this function can signal an error. Any pointer + * it returns is potentially valid. However, every valid object must have an + * even numbered offset, so possibly {:node 0, :page 0, :offset 1} could be + * used as a magic marker to indicate total exhaustion of store for this size + * class. TODO: think about this. */ struct pso_pointer pop_freelist( uint8_t size_class ) { - // `t`, because if `allocate_page` fails it will be set to `nil`. struct pso_pointer result = t; if ( size_class <= MAX_SIZE_CLASS ) { @@ -103,16 +108,16 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { /* 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 ) { - // TODO: return an exception instead? Or warn, set it, and continue? + fwprintf( stderr, + L"WARNING: Unexpected size class %x. on free list for class %x while allocating.\n", + object->header.tag.bytes.size_class, 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 ) { fwprintf( stderr, - L"WARNING: Count of %d in newly allocated object at %d, %d, should be 0\n", - result.page, - result.offset, - object->header.count ); + L"\nWARNING: Count of %u in newly allocated object at %u, %u, should be 0\n", + object->header.count, result.page, result.offset ); object->header.count = 0; } } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 1d9eebd..b22846a 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,8 +286,9 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( (c_nilp( result ) && (page_index != 0)) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, - 0 ); + debug_print( ( c_nilp( result ) + && ( page_index != 0 ) ) ? L"fail.\n" : L"success.\n", + DEBUG_ALLOC, 0 ); return result; } @@ -311,7 +312,7 @@ struct pso_pointer allocate_page( uint8_t size_class ) { if ( npages_allocated < NPAGES ) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { - void *pg = malloc( sizeof( union page ) ); + void *pg = calloc( sizeof( union page ), 1 ); if ( pg != NULL ) { memset( pg, 0, sizeof( union page ) ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 93696d7..c5fa2b8 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -4,9 +4,9 @@ * 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 + * 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. * @@ -41,19 +41,22 @@ int allocation_table_allocated = 0; int allocation_table_freed = 1; -long int allocation_table[MAX_SIZE_CLASS +1][2]; +long int allocation_table[MAX_SIZE_CLASS + 1][2]; -void print_allocation_table() { - fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", stderr); - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); - - for ( int s = 2; s<= MAX_SIZE_CLASS; s++) { - long int a = allocation_table[s][allocation_table_allocated]; - long int d = allocation_table[s][allocation_table_freed]; - long int r = a - d; - fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r); - } - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); +void print_allocation_table( ) { + fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", + stderr ); + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); + + for ( int s = 2; s <= MAX_SIZE_CLASS; s++ ) { + long int a = allocation_table[s][allocation_table_allocated]; + long int d = allocation_table[s][allocation_table_freed]; + long int r = a - d; + fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r ); + } + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); } #endif @@ -77,64 +80,53 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, return result; } - /** - * @brief Allocate an object of this `size_class` with this `tag`. - * - * All objects that are allocated (after completion of init)) should be linked - * onto the `locals` slot of a stack frame. This guarantees - * 1. that they do get `inc_ref`ed; and that, - * 2. if nothing else hangs onto them they will be reclaimed when that stack - * frame is reclaimed. - * for some objects (e.g. those cons cells on the locals list) this isn't - * possible due to infinite recursion, but those special cases need to be - * audited carefully. - * - * @param frame_pointer pointer to an active stack frame (or - * nil, but only during initialisation). - * @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 - */ +/** + * @brief Allocate an object of this `size_class` with this `tag`. + * + * All objects that are allocated (after completion of init)) should be linked + * onto the `locals` slot of a stack frame. This guarantees + * 1. that they do get `inc_ref`ed; and that, + * 2. if nothing else hangs onto them they will be reclaimed when that stack + * frame is reclaimed. + * for some objects (e.g. those cons cells on the locals list) this isn't + * possible due to infinite recursion, but those special cases need to be + * audited carefully. + * + * @param frame_pointer pointer to an active stack frame (or + * nil, but only during initialisation). + * @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( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = pop_freelist( size_class ); + if ( memory_initialised && c_nilp( frame_pointer ) ) { + fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); + } #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, - L"Allocating object of size class %d with tag `%s`... ", + L"\nAllocating object of size class %d with tag `%s`... ", size_class, tag ); #endif - struct pso_pointer result = pop_freelist( size_class ); - struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso2 *obj = pointer_to_object( result ); + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); - if ( memory_initialised && c_nilp(frame_pointer)) { - fputws( L"WARNING: No stack frame passed to `allocate`.\n", - stderr ); - } - - if ( !c_nilp( result ) ) { - struct pso2 *obj = pointer_to_object(result); - strncpy((char*) (obj->header.tag.bytes. - mnemonic ), tag, TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", - result.page, result.offset ); - if ( stackp( frame_pointer ) ) { - // You can't make a stack frame in the middle of making a stack - // frame. Infinite recursion. So we have to cheat. - struct pso_pointer locals = cheaty_make_cons( result, - frame-> - payload.stack_frame. - locals ); - frame->payload.stack_frame.locals = locals; - } -#ifdef DEBUG - allocation_table[size_class][allocation_table_allocated]++; -#endif - } else { - // TODO: throw exception + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, + result.offset ); + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = + cheaty_make_cons( result, frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = locals; } +#ifdef DEBUG + allocation_table[size_class][allocation_table_allocated]++; +#endif #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, @@ -164,25 +156,40 @@ int payload_size( struct pso2 *object ) { * Returns the `pointer`. */ struct pso_pointer inc_ref( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to inc_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( object->header.count < MAXREFERENCE ) { - object->header.count++; + if ( object->header.count < MAXREFERENCE ) { + object->header.count++; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nIncremented object of type %3.3s, size class %d, at page %u, offset %u to count %u", - ( ( char * ) &(object->header.tag.bytes.mnemonic[0] )), - (int)object->header.tag.bytes.size_class, - 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] ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } + L"\nIncremented object of type %3.3s, size class %d, " + L"at page %u, offset %u to count %u", ( ( char * ) + &( object-> + header. + tag.bytes. + mnemonic + [0] ) ), + ( int ) object->header.tag.bytes.size_class, + 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] ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } #endif + } } return pointer; @@ -197,42 +204,48 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { * 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 (freep(pointer)) { - fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr); - } + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to dec_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( !c_nilp( pointer ) && object->header.count > 0 - && object->header.count != MAXREFERENCE ) { - object->header.count--; + if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) { + object->header.count--; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nDecremented object of type %3.3s, size class %d, at page %d, offset %d to count %d", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - 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 ); - } + L"\nDecremented object of type %3.3s, size class %d, " + L"at page %d, offset %d to count %d", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, + 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 ); + } #endif + } + if ( object->header.count == 0 ) { + free_object( pointer ); + pointer = nil; + } } - if ( object->header.count == 0 ) { - free_object( pointer ); - pointer = nil; - } return pointer; } /** * @brief Prevent an object ever being dereferenced. - * + * * @param pointer pointer to an object to lock. * * @return the `pointer` @@ -257,24 +270,27 @@ struct pso_pointer free_object( struct pso_pointer pointer ) { result = destroy( pointer ); - /* will C just let me cheerfully walk off the end of the array I've declared? */ + /* will C just let me cheerfully walk off the end of the array I've + * declared? */ for ( int i = 0; i < array_size; i++ ) { object->payload.words[i] = 0; } - #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count - ); - - allocation_table[size_class][allocation_table_freed]++; - #endif - - strncpy((char*) (object->header.tag.bytes. - mnemonic ), FREETAG, TAGLENGTH ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of type %3.3s, size class %d, at page %d, " + L"offset %d.\n", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, pointer.page, + pointer.offset, object->header.count ); + + allocation_table[size_class][allocation_table_freed]++; +#endif + + strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); + object->header.count = ( uint8_t ) 0; + object->header.access = nil; push_freelist( pointer ); return result; diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 45bfdce..8643163 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -28,6 +28,6 @@ struct pso_pointer lock_object( struct pso_pointer pointer ); struct pso_pointer free_object( struct pso_pointer p ); #ifdef DEBUG -void print_allocation_table(); +void print_allocation_table( ); #endif #endif diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index d61f6e8..aa425ea 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -11,6 +11,7 @@ #include +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" @@ -40,15 +41,31 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer result = nil; bool found = false; +#ifdef DEBUG + debug_print( L"In search; key is: ", DEBUG_BIND, 0 ); + debug_print_object( key, DEBUG_BIND, 0 ); + debug_println( DEBUG_BIND ); +#endif + if ( consp( store ) ) { for ( struct pso_pointer cursor = store; consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); +#ifdef DEBUG + debug_print( L"Checking ", DEBUG_BIND, 2 ); + debug_print_object( pair, DEBUG_BIND, 0 ); +#endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; result = return_key ? c_car( pair ) : c_cdr( pair ); +#ifdef DEBUG + debug_print( L" ...found!", DEBUG_BIND, 0 ); +#endif } +#ifdef DEBUG + debug_println( DEBUG_BIND ); +#endif } } diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 60c5316..f350d5a 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -41,7 +41,7 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ) { } bool c_equal( struct pso_pointer a, struct pso_pointer b ) { - bool result = true; + bool result = false; if ( c_eq( a, b ) ) { result = true; @@ -73,6 +73,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { b = c_cdr( b ); } else { result = false; + break; } } result = result && c_nilp( a ) && c_nilp( b ); diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index c95513c..0c8d2a7 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -10,9 +10,11 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -48,57 +50,67 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) { struct pso_pointer arg = fetch_arg( frame, 0 ); struct pso_pointer result = nil; - switch ( get_tag_value( arg ) ) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - case INTEGERTV: - case KEYTV: - case STRINGTV: - // self evaluating - result = nil; - break; - case SYMBOLTV: - arg = c_assoc( arg, fetch_env( frame_pointer ) ); - 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; - default: - arg = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( frame_pointer, - arg ) ), nil ), - nil ) ); - } - - if ( exceptionp( arg ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( arg, - EXCEPTIONTV ); - - if ( c_nilp( x->payload.exception.stack ) ) { - + if ( !c_nilp( arg ) ) { + switch ( get_tag_value( arg ) ) { + // case CONSTV: + // result = eval_cons( frame, frame_pointer, env); + // break; + case INTEGERTV: + case KEYTV: + case NILTV: + case STRINGTV: + // self evaluating + result = nil; + break; + case SYMBOLTV: + result = c_assoc( arg, fetch_env( frame_pointer ) ); + 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; + default: +#ifdef DEBUG + struct pso2 *object = pointer_to_object( arg ); + debug_printf( DEBUG_EVAL, 0, + L"Can't yet evaluate objects of type %3.3s\n", + object->header.tag.bytes.mnemonic[0] ); + debug_print_object( arg, DEBUG_EVAL, 2 ); + debug_println( DEBUG_EVAL ); +#endif + result = make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Can't yet evaluate things of this type: " ), + arg ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"tag" ), + get_tag_string + ( frame_pointer, + arg ) ), + nil ), nil ) ); } } - return arg; + if ( exceptionp( result ) ) { + struct pso3 *x = + ( struct pso3 * ) pointer_to_object_with_tag_value( result, + EXCEPTIONTV ); + + if ( c_nilp( x->payload.exception.stack ) ) { + x->payload.exception.stack = frame_pointer; + } + } + + return result; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index a427a2b..4e8e5f1 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -72,10 +72,11 @@ void repl( struct pso_pointer frame_pointer ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { - if ( show_prompt ) + if ( show_prompt ) { princ( make_frame( 2, frame_pointer, c_assoc( lisp_io_prompt, env ), output_stream ) ); + } /* the reason for initialising a new stack for each REPL input is to * be sure the old stack is fully torn down and reclaimed. Once I'm @@ -86,13 +87,21 @@ void repl( struct pso_pointer frame_pointer ) { consp( oblist ) ? oblist : make_cons( nil, oblist, nil ) ) ); - print( make_frame - ( 2, base_of_stack, - eval( make_frame - ( 1, base_of_stack, - read( make_frame - ( 1, base_of_stack, input_stream ) ) ) ), - output_stream ) ); + struct pso_pointer next = + inc_ref( make_frame( 1, base_of_stack, input_stream ) ); + struct pso_pointer read_value = inc_ref( read( next ) ); + dec_ref( next ); + + next = inc_ref( make_frame( 1, base_of_stack, read_value ) ); + struct pso_pointer eval_value = inc_ref( eval( next ) ); + dec_ref( next ); + dec_ref( read_value ); + + next = + inc_ref( make_frame + ( 2, base_of_stack, eval_value, output_stream ) ); + print( next ); + dec_ref( next ); dec_ref( base_of_stack ); } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index 4d566cf..cd7fac1 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -8,9 +8,12 @@ */ #include "memory/node.h" +#include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" + +#include "payloads/cons.h" #include "payloads/stack.h" /** @@ -54,3 +57,25 @@ struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { return stackp( frame_pointer ) ? pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; } + +/** + * Push a binding (and therefore a reference) for this `local` onto the + * stack_frame indicated by this `frame_pointer`, thereby protecting the + * `local` from garbage collection until the frame itself is disposed of. + * + * This is a hack. For Lisp functions, where the stack frames are set up + * and torn down by eval/apply, it shouldn't be necessary. + */ +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ) { + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer l = + make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = l; + } + + return local; +} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index fb1c4cc..059f61e 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -29,4 +29,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ); + #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 33a0e4b..729e1f9 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -56,15 +56,17 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); - if ( !c_nilp( result ) && !exceptionp( result ) ) { + if ( exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); - object->payload.exception.message = inc_ref(message); + object->payload.exception.message = inc_ref( message ); object->payload.exception.stack = - stackp( frame_pointer ) ? inc_ref(frame_pointer) : nil; + stackp( frame_pointer ) ? inc_ref( frame_pointer ) : nil; object->payload.exception.meta = ( consp( meta ) - || hashtabp( meta ) ) ? inc_ref(meta) : nil; - object->payload.exception.cause = exceptionp( cause ) ? inc_ref(cause) : nil; + || hashtabp( meta ) ) ? + inc_ref( meta ) : nil; + object->payload.exception.cause = + exceptionp( cause ) ? inc_ref( cause ) : nil; } return result; diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 9b85b5a..71ed2c1 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -22,8 +22,6 @@ /** * 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( struct pso_pointer frame_pointer, int64_t value ) { @@ -34,8 +32,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer, 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 ); + debug_printf( DEBUG_ALLOC, 0, L"\nmake_integer returning %ld\n", + cell->payload.integer.value ); return result; } diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index ed65024..c4b11c5 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -62,8 +62,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, } else { new_frame->payload.stack_frame.depth = 0; } - - new_frame->payload.stack_frame.previous = inc_ref( previous); + + new_frame->payload.stack_frame.previous = inc_ref( previous ); debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", new_frame->payload.stack_frame.depth ); @@ -129,7 +129,7 @@ struct pso_pointer make_frame_with_env( int arg_count, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref(previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -203,7 +203,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref( previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -279,12 +279,12 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( frame->payload.stack_frame.arg[i] ); } - frame->payload.stack_frame.previous = nil; - frame->payload.stack_frame.function = nil; - frame->payload.stack_frame.more = nil; - frame->payload.stack_frame.locals = nil; - frame->payload.stack_frame.env = nil; - + frame->payload.stack_frame.previous = nil; + frame->payload.stack_frame.function = nil; + frame->payload.stack_frame.more = nil; + frame->payload.stack_frame.locals = nil; + frame->payload.stack_frame.env = nil; + frame->payload.stack_frame.args = 0; frame->payload.stack_frame.depth = 0; } diff --git a/src/c/psse.c b/src/c/psse.c index 38f7d96..bf7c745 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -21,6 +21,7 @@ #include "psse.h" #include "io/print.h" + #include "memory/node.h" #include "memory/pso.h" #include "memory/tags.h" @@ -77,11 +78,11 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; char *infilename = NULL; - - if ( initialise_io( ) != 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 ) { @@ -114,7 +115,7 @@ int main( int argc, char *argv[] ) { } setlocale( LC_ALL, "" ); - + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); @@ -134,18 +135,25 @@ int main( int argc, char *argv[] ) { stdout ); } - struct pso_pointer bootstrap_stack = inc_ref( - make_frame_with_env(1, nil, - consp - ( oblist ) ? oblist : make_cons(nil, oblist, nil), - show_prompt ? t : nil)); + struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, + consp + ( oblist ) + ? oblist + : + make_cons + ( nil, + oblist, + nil ), + show_prompt + ? t : + nil ) ); repl( bootstrap_stack ); dec_ref( bootstrap_stack ); - dec_ref( oblist); + dec_ref( oblist ); #ifdef DEBUG - print_allocation_table(); + print_allocation_table( ); #endif From f7eabb9b62b4a84dd6355fa4ba807aa71f725e3a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 25 Apr 2026 21:52:05 +0100 Subject: [PATCH 56/77] Working on eval/apply. Unfinished, does not build. More significantly, as the focus ot this prototype is supposed to be building things in Lisp, I've started deliberately copying stuff that mostly works directly from the 0.0.6 branch into this branch. After all, if it's going to be replaced in Lisp, it doesn't have to be the most elegant C. --- docs/State-of-play.md | 20 + src/c/io/io.c | 8 +- src/c/memory/pso.c | 9 +- src/c/ops/assoc.c | 12 +- src/c/ops/eval_apply.c | 1688 ++++++++++++++++++++++++++++++++++++++-- src/c/ops/reverse.c | 103 ++- src/c/ops/stack_ops.c | 5 +- src/c/ops/string_ops.c | 4 +- src/c/payloads/stack.c | 8 +- src/sed/convert.sed | 7 +- 10 files changed, 1730 insertions(+), 134 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index eba1311..155aaab 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -62,6 +62,26 @@ So I think I'm going to put up with the uncollected garbage until we get to that However, any new C code (and there is going to have to be some) *must* be written in the sanitary but bureaucratic pattern. +#### 21:24 + +Well, at the end of the day I think the git log says it all: + +``` +commit 63906fe817d509adb6171a72d16c045c2793ebed (HEAD -> feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 21:20:23 2026 +0100 + + Print is less badly broken. Read is less badly broken. GC is too aggressive. + +commit 22b0160a266999c939c9a21df150542f8b2f0b25 (origin/feature/reengineering-17-21) +Author: Simon Brooke +Date: Fri Apr 24 09:22:06 2026 +0100 + + Builds and runs, but print is badly broken. Need some rethink. +``` + +I could just disable the garbage collector until I've got `eval`/`apply` working. I *believe* that with `eval`/`apply` I'll be able to automate all the garbage collection bookkeeping work. I hope so. Mark and sweep, or even my preferred mark but don't sweep, on a massively parallel machine, just doesn't bear thinking on. + ## 20260421 diff --git a/src/c/io/io.c b/src/c/io/io.c index 8865a0d..9a95c2f 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -371,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, 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( c )->payload.character. + character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -399,8 +399,8 @@ struct pso_pointer lisp_close( struct pso_pointer 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 ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream. + stream ) == 0 ) { result = t; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index c5fa2b8..aff210b 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -173,11 +173,10 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { debug_printf( DEBUG_ALLOC, 0, L"\nIncremented object of type %3.3s, size class %d, " L"at page %u, offset %u to count %u", ( ( char * ) - &( object-> - header. - tag.bytes. - mnemonic - [0] ) ), + & + ( object->header.tag. + bytes.mnemonic + [0] ) ), ( int ) object->header.tag.bytes.size_class, pointer.page, pointer.offset, object->header.count ); if ( vectorpointp( pointer ) ) { diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index aa425ea..9e5672d 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -125,8 +125,8 @@ struct pso_pointer assoc( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_assoc( key, store ); } @@ -147,8 +147,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_interned( key, store ); } @@ -169,8 +169,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload.stack_frame. - env ) ); + frame->payload. + stack_frame.env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 0c8d2a7..e26fc1c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -10,6 +10,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include +#include +#include +#include +#include + + #include "debug.h" #include "memory/node.h" #include "memory/pointer.h" @@ -20,6 +27,8 @@ #include "memory/tags.h" #include "ops/assoc.h" +#include "ops/bind.h" +#include "ops/reverse.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -28,89 +37,1638 @@ #include "payloads/function.h" #include "payloads/stack.h" -/** - * @brief Apply a function to arguments in an environment. +///** +// * @brief Apply a function to arguments in an environment. +// * +// * * (apply fn args) +// */ +//struct pso_pointer apply( struct pso_pointer frame_pointer ) { +// +//// TODO. +// +//} +// +///** +// * @brief Evaluate a form, in an environment +// * +// * * (eval form) +// */ +//struct pso_pointer eval( struct pso_pointer frame_pointer ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// struct pso_pointer arg = fetch_arg( frame, 0 ); +// struct pso_pointer result = nil; +// +// if ( !c_c_nilp( arg ) ) { +// switch ( get_tag_value( arg ) ) { +// // case CONSTV: +// // result = eval_cons( frame, frame_pointer, env); +// // break; +// case INTEGERTV: +// case KEYTV: +// case NILTV: +// case STRINGTV: +// // self evaluating +// result = nil; +// break; +// case SYMBOLTV: +// result = c_assoc( arg, fetch_env( frame_pointer ) ); +// 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; +// default: +//#ifdef DEBUG +// struct pso2 *object = pointer_to_object( arg ); +// debug_printf( DEBUG_EVAL, 0, +// L"Can't yet evaluate objects of type %3.3s\n", +// object->header.tag.bytes.mnemonic[0] ); +// debug_print_object( arg, DEBUG_EVAL, 2 ); +// debug_println( DEBUG_EVAL, 0 ); +//#endif +// result = make_exception( make_frame( 1, frame_pointer, +// make_cons( frame_pointer, +// c_string_to_lisp_string +// ( frame_pointer, +// L"Can't yet evaluate things of this type: " ), +// arg ), +// make_cons( frame_pointer, +// make_cons +// ( frame_pointer, +// c_string_to_lisp_keyword +// ( frame_pointer, +// L"tag" ), +// get_tag_string +// ( frame_pointer, +// arg ) ), +// nil ), nil ) ); +// } +// } +// +// if ( exceptionp( result ) ) { +// struct pso3 *x = +// ( struct pso3 * ) pointer_to_object_with_tag_value( result, +// EXCEPTIONTV ); +// +// if ( c_c_nilp( x->payload.exception.stack ) ) { +// x->payload.exception.stack = frame_pointer; +// } +// } +// +// return result; +//} +/* + * lispops.c * - * * (apply fn args) + * List processing operations. + * + * The general idea here is that a list processing operation is a + * function which takes two arguments, both pso_pointers: + * + * 1. args, the argument list to this function; + * 2. env, the environment in which this function should be evaluated; + * + * and returns a pso_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. */ -struct pso_pointer apply( struct pso_pointer frame_pointer ) { -// TODO. +/** + * 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 pso_pointer eval_form( struct pso_pointer frame_pointer ) { + struct pso_pointer form = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; +#ifdef DEBUG + debug_print( L"eval_form: ", DEBUG_EVAL, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + struct pso_pointer result = form; + switch ( pointer_to_object( form )->header.tag.value & 0xfffff ) { + /* 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 pso_pointer next_pointer = + make_frame( 0, frame_pointer ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + next->payload.stack_frame.arg[0] = form; + next->payload.stack_frame.args = 1; + + result = + push_local( frame_pointer, lisp_eval( next_pointer ) ); + + 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, 0 ); + debug_print_object( form, DEBUG_EVAL, 0 ); + debug_print( L" returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; } /** - * @brief Evaluate a form, in an environment - * - * * (eval form) + * 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 pso_pointer eval( struct pso_pointer frame_pointer ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - - struct pso_pointer arg = fetch_arg( frame, 0 ); +struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { + struct pso_pointer list = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; struct pso_pointer result = nil; - if ( !c_nilp( arg ) ) { - switch ( get_tag_value( arg ) ) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - case INTEGERTV: - case KEYTV: - case NILTV: - case STRINGTV: - // self evaluating - result = nil; - break; - case SYMBOLTV: - result = c_assoc( arg, fetch_env( frame_pointer ) ); - 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; - default: -#ifdef DEBUG - struct pso2 *object = pointer_to_object( arg ); - debug_printf( DEBUG_EVAL, 0, - L"Can't yet evaluate objects of type %3.3s\n", - object->header.tag.bytes.mnemonic[0] ); - debug_print_object( arg, DEBUG_EVAL, 2 ); - debug_println( DEBUG_EVAL ); -#endif - result = make_exception( make_frame( 1, frame_pointer, + while ( consp( list ) ) { + struct pso_pointer next_pointer = + inc_ref( make_frame( 1, frame_pointer, c_car( list ) ) ); + result = push_local( frame_pointer, + make_cons( frame_pointer, + eval_form( next_pointer ), result ) ); + list = c_cdr( list ); + + dec_ref( next_pointer ); + } + + 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 pso_pointer lisp_try( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body_frame = + inc_ref( make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + + result = push_local( frame_pointer, progn( body_frame ) ); + + dec_ref( body_frame ); + + if ( exceptionp( result ) ) { + // TODO: need to put the exception into the environment! + struct pso_pointer catch_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, + make_cons( frame_pointer, make_cons( frame_pointer, - c_string_to_lisp_string + c_string_to_lisp_symbol ( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( frame_pointer, - arg ) ), - nil ), nil ) ); + L"*exception*" ), + result ), + fetch_env + ( frame_pointer ) ), + frame->payload.stack_frame. + arg[1] ) ); + result = push_local( progn( catch_frame ) ); + + dec_ref( catch_frame ); + } + + 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 pso4. + * @param env my environment (ignored). + * @return the root namespace. + */ +struct pso_pointer +lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return oblist; +} + +/** + * Used to construct the body for `lambda` and `nlambda` expressions. + */ +struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer body = frame->payload.stack_frame.more; + + for ( int i = args_in_frame - 1; i > 0; i-- ) { + if ( !c_nilp( body ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); + } else if ( !c_nilp( frame->payload.stack_frame.arg[i] ) ) { + body = + make_cons( frame_pointer, frame->payload.stack_frame.arg[i], + body ); } } - if ( exceptionp( result ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( result, - EXCEPTIONTV ); + debug_print( L"compose_body returning ", DEBUG_LAMBDA, 0 ); + debug_dump_object( body, DEBUG_LAMBDA, 0 ); - if ( c_nilp( x->payload.exception.stack ) ) { - x->payload.exception.stack = frame_pointer; + 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 pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_lambda( struct pso_pointer frame_pointer ) { +// return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + +/** + * 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 pso4. + * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. + */ +//struct pso_pointer +//lisp_nlambda( struct pso_pointer frame_pointer, +// struct pso_pointer env ) { +// return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +//} + + +/** + * Evaluate a lambda or nlambda expression. + */ +struct pso_pointer +eval_lambda( struct pso4 *frame, + struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 *cell = + pointer_to_object( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ); + struct pso_pointer new_env = fetch_env( frame_pointer ); + struct pso_pointer names = cell->payload.lambda.args; + struct pso_pointer body = cell->payload.lambda.body; +#ifdef DEBUG + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA, 0 ); + debug_println( DEBUG_LAMBDA ); +#endif + + if ( consp( names ) ) { + /* if `names` is a list, bind successive items from that list + * to values of arguments */ + for ( int i = 0; i < frame->payload.stack_frame.args && consp( names ); + i++ ) { + struct pso_pointer name = c_car( names ); + struct pso_pointer val = frame->payload.stack_frame.arg[i]; + + new_env = + make_cons( frame_pointer, + make_cons( frame_pointer, 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->payload.stack_frame.more */ +// struct pso_pointer vals = +// eval_forms( frame, frame_pointer, frame->payload.stack_frame.more, env ); + + for ( int i = args_in_frame - 1; i >= 0; i-- ) { + struct pso_pointer next = + make_frame( 1, frame_pointer, fetch_arg( frame, i ) ); + struct pso_pointer val = + push_local( frame_pointer, eval_form( next ) ); + + if ( c_nilp( val ) && c_nilp( vals ) ) { /* nothing */ + } else { + vals = make_cons( frame_pointer, val, vals ); + } + } + + new_env = + make_cons( frame_pointer, make_cons( frame_pointer, names, vals ), + new_env ); + } + + while ( !c_nilp( body ) ) { + struct pso_pointer sexpr = c_car( body ); + body = c_cdr( body ); + + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA, 0 ); + debug_print_object( sexpr, DEBUG_LAMBDA, 0 ); + // debug_print( L"\t env is: ", DEBUG_LAMBDA , 0); + // debug_print_object( new_env, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + struct pso_pointer lambda_frame = + inc_ref( make_frame_with_env( 1, frame_pointer, new_env, sexpr ) ); + + result = push_local( frame_pointer, eval_form( lambda_frame ) ); + + dec_ref( lambda_frame ); + + if ( exceptionp( result ) ) { + break; + } + } + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA, 0 ); + debug_print_object( result, DEBUG_LAMBDA, 0 ); + 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 pso_pointer maybe_fixup_exception_location( struct pso_pointer r, + struct pso_pointer + fn_pointer ) { + struct pso_pointer result = r; + + if ( exceptionp( result ) + && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + + struct pso_pointer payload = + pointer_to_object( result ).payload.exception.payload; + + switch ( get_header.tag.bytes.value & 0xfffff( payload ) ) { + case nilTV: + case CONSTV: + case HASHTV: + { + if ( c_nilp( c_assoc( privileged_keyword_location, + payload ) ) ) { + pointer_to_object( result ).payload.exception.payload = + set( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ), + payload ); + } + } + break; + default: + pointer_to_object( result ).payload.exception.payload = + cons( cons( privileged_keyword_location, + c_assoc( privileged_keyword_name, + fn_cell->payload.function.meta ) ), + cons( 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 pso_pointer +c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Entering c_apply\n", DEBUG_EVAL, 0 ); + struct pso_pointer result = nil; + + struct pso_pointer fn_pointer = + eval_form( frame, frame_pointer, + c_car( frame->payload.stack_frame.arg[0] ), env ); + + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { + struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + struct pso_pointer args = c_cdr( frame->payload.stack_frame.arg[0] ); + + switch ( get_header.tag.bytes.value & 0xfffff( fn_pointer ) ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; + + case FUNCTIONTV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( 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->payload. + stack_frame.arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct pso_pointer exep = nil; + struct pso_pointer next_pointer = + make_pso4( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( 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->payload. + stack_frame.arg[0] ) ), + env ), fn_pointer ); + break; + + case NLAMBDATV: + { + struct pso_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct pso4 *next = pointer_to_pso4( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } + } + break; + + case SPECIALTV: + { + struct pso_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 ) ) + ( pointer_to_pso4( next_pointer ), next_pointer, env ), fn_pointer ); + debug_print( L"Special form returning: ", DEBUG_EVAL, + 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + 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->header.tag.bytes.value & 0xfffff, + &( fn_cell->tag.bytes[0] ) ); + struct pso_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, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + return result; +} + +/** + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. + * + * * (eval expression) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @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 pso_pointer +lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + struct pso_pointer result = frame->payload.stack_frame.arg[0]; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + + switch ( cell->header.tag.bytes.value & 0xfffff ) { + case CONSTV: + result = c_apply( frame, frame_pointer, env ); + break; + + case SYMBOLTV: + { + struct pso_pointer canonical = + interned( frame->payload.stack_frame.arg[0], env ); + if ( c_nilp( canonical ) ) { + struct pso_pointer message = + cons( c_string_to_lisp_string + ( L"Attempt to take value of unbound symbol." ), + frame->payload.stack_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->payload.stack_frame.arg[0]; + break; + } + + debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + 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 pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment. + * @return the result of applying `fn` to `args`. + */ +struct pso_pointer +lisp_apply( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + debug_print( L"Apply: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + + set_reg( frame, 0, + cons( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ) ); + set_reg( frame, 1, nil ); + + struct pso_pointer result = c_apply( frame, frame_pointer, env ); + + debug_print( L"Apply returning ", DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); + + 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 pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `a`, unevaluated, + */ +struct pso_pointer +lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return frame->payload.stack_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 pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = + c_nilp( frame->payload.stack_frame.arg[2] ) ? oblist : frame->payload. + stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + deep_bind( frame->payload.stack_frame.arg[0], + frame->payload.stack_frame.arg[1] ); + result = frame->payload.stack_frame.arg[1]; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + cons( frame->payload.stack_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 pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return `value` + */ +struct pso_pointer +lisp_set_shriek( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer namespace = frame->payload.stack_frame.arg[2]; + + if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[1], + env ); + deep_bind( frame->payload.stack_frame.arg[0], val ); + result = val; + } else { + result = + throw_exception( c_string_to_lisp_symbol( L"set!" ), + cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + cons( frame->payload.stack_frame.arg[0], + nil ) ), frame_pointer ); + } + + return result; +} + +/** + * @return t if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct pso_pointer arg ) { + return c_nilp( arg ) || + ( stringp( arg ) && + pointer_to_object( arg ).payload.string.character == + ( wint_t ) '\0' ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. + */ +struct pso_pointer +lisp_assoc( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_assoc( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame->payload.stack_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 pso_pointer + */ +struct pso_pointer +lisp_internedp( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = internedp( frame->payload.stack_frame.arg[0], + c_nilp( frame->payload.stack_frame. + arg[1] ) ? oblist : frame-> + payload.stack_frame.arg[1] ); + + if ( exceptionp( result ) ) { + struct pso_pointer old = result; + struct pso2 **cell = &( pointer_to_object( result ) ); + result = + throw_exception( c_string_to_lisp_symbol( L"interned?" ), + cell->payload.exception.payload, frame_pointer ); + dec_ref( old ); + } + + return result; +} + +struct pso_pointer c_keys( struct pso_pointer store ) { + struct pso_pointer result = nil; + + if ( consp( store ) ) { + for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = 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 pso_pointer lisp_keys( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_keys( frame->payload.stack_frame.arg[0] ); +} + +/** + * 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 pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return the number of top level forms in a list, or characters in a + * string, else 0. + */ +struct pso_pointer +lisp_count( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return acquire_integer( c_count( frame->payload.stack_frame.arg[0] ), + nil ); +} + + + + +/** + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. + */ +struct pso_pointer lisp_reverse( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_reverse( frame->payload.stack_frame.arg[0] ); +} + + + +/** + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. + */ +struct pso_pointer +lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_type( frame->payload.stack_frame.arg[0] ); +} + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct pso_pointer +c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, struct pso_pointer env ) { + struct pso_pointer result = nil; + + while ( consp( expressions ) ) { + struct pso_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 pso4. + * @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 pso_pointer +lisp_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + + for ( int i = 0; + i < args_in_frame && !c_nilp( frame->payload.stack_frame.arg[i] ); + i++ ) { + struct pso_pointer r = result; + + result = + eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[i], + env ); + + dec_ref( r ); + } + + if ( consp( frame->payload.stack_frame.more ) ) { + result = + c_progn( frame, frame_pointer, frame->payload.stack_frame.more, + env ); + } + + return result; +} + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is t and whose cdr is the value of the action part + */ +struct pso_pointer eval_cond_clause( struct pso_pointer clause, + struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#endif + + if ( consp( clause ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !c_nilp( val ) ) { + result = + cons( t, + c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" failed.\n", DEBUG_EVAL, 0 ); +#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 pso4. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. + */ +struct pso_pointer +lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + bool done = false; + + for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { + struct pso_pointer clause_pointer = fetch_arg( frame, i ); + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !c_nilp( result ) && tp( c_car( result ) ) ) { + result = c_cdr( result ); + done = t; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); +#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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer throw_exception_with_cause( struct pso_pointer location, + struct pso_pointer message, + struct pso_pointer cause, + struct pso_pointer + frame_pointer ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\nERROR: `", 511, 0 ); + debug_print_object( message, 511 ); + debug_print( L"` at `", 511, 0 ); + debug_print_object( location, 511 ); + debug_print( L"`\n", 511, 0 ); + if ( !c_nilp( cause ) ) { + debug_print( L"\tCaused by: ", 511, 0 ); + debug_print_object( cause, 511 ); + debug_print( L"`\n", 511, 0 ); + } +#endif + struct pso2 **cell = pointer_to_object( message ); + + if ( cell->header.tag.bytes.value & 0xfffff == EXCEPTIONTV ) { + result = message; + } else { + result = + make_exception( cons + ( cons( privileged_keyword_location, + location ), + cons( cons + ( privileged_keyword_payload, + message ), + ( c_nilp( cause ) ? nil : + cons( 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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer +throw_exception( struct pso_pointer location, + struct pso_pointer payload, + struct pso_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 pso4. + * @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 pso_pointer +lisp_exception( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer message = frame->payload.stack_frame.arg[0]; + + return exceptionp( message ) ? message : + throw_exception_with_cause( message, frame->payload.stack_frame.arg[1], + frame->payload.stack_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 pso4. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct pso_pointer lisp_repl( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer expr = nil; + +#ifdef DEBUG + debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL, 0 ); + debug_print_object( env, DEBUG_REPL ); + debug_print( L"`\n", DEBUG_REPL, 0 ); +#endif + + struct pso_pointer input = get_default_stream( t, env ); + struct pso_pointer output = get_default_stream( false, env ); + struct pso_pointer old_oblist = oblist; + struct pso_pointer new_env = env; + + if ( tp( frame->payload.stack_frame.arg[0] ) ) { + new_env = + set( prompt_name, frame->payload.stack_frame.arg[0], new_env ); + } + if ( readp( frame->payload.stack_frame.arg[1] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*in*" ), + frame->payload.stack_frame.arg[1], new_env ); + input = frame->payload.stack_frame.arg[1]; + } + if ( writep( frame->payload.stack_frame.arg[2] ) ) { + new_env = + set( c_string_to_lisp_symbol( L"*out*" ), + frame->payload.stack_frame.arg[2], new_env ); + output = frame->payload.stack_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 ) : + pointer_to_object( 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( pointer_to_object( 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 pso_pointer cursor = oblist; + + while ( !c_nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct pso_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 = 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 pso_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !c_nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( pointer_to_pso4( frame_pointer ), frame_pointer, + new_env ); + + if ( exceptionp( expr ) + && url_feof( pointer_to_object( 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 ( c_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 pso4. + * @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 pso_pointer lisp_source( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso2 **cell = + pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell->header.tag.bytes.value & 0xfffff ) { + 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 = cons( c_string_to_lisp_symbol( L"lambda" ), + cons( cell->payload.lambda.args, + cell->payload.lambda.body ) ); + break; + case NLAMBDATV: + result = cons( c_string_to_lisp_symbol( L"nlambda" ), + 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 pso_pointer c_append( struct pso_pointer l1, struct pso_pointer l2 ) { + switch ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ) { + case CONSTV: + if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return cons( c_car( l1 ), l2 ); + } else { + return 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 ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == + pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { + if ( c_nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), l2, + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } else { + return + make_string_like_thing( ( pointer_to_object + ( l1 ).payload.string. + character ), + c_append( c_cdr( l1 ), l2 ), + pointer_to_object( l1 ).header. + tag.bytes.value & 0xfffff ); + } + } 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 pso_pointer lisp_append( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = + fetch_arg( frame, ( frame->payload.stack_frame.args - 1 ) ); + + for ( int a = frame->payload.stack_frame.args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +struct pso_pointer lisp_mapcar( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + int i = 0; + + for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; tp( c ); + c = c_cdr( c ) ) { + struct pso_pointer expr = + cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + struct pso_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 = cons( r, result ); + } + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + 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 pso_pointer a pointer to the result + */ +struct pso_pointer lisp_list( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = + c_nilp( result ) ? frame->payload.stack_frame.args - + 1 : args_in_frame - 1; a >= 0; a-- ) { + result = 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 pso_pointer lisp_let( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer bindings = env; + struct pso_pointer result = nil; + + for ( struct pso_pointer cursor = frame->payload.stack_frame.arg[0]; + tp( cursor ); cursor = c_cdr( cursor ) ) { + struct pso_pointer pair = c_car( cursor ); + struct pso_pointer symbol = c_car( pair ); + + if ( symbolp( symbol ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ); + + debug_print_binding( symbol, val, false, DEBUG_BIND ); + + bindings = cons( 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, 0 ); + + /* i.e., no exception yet */ + for ( int form = 1; + !exceptionp( result ) && form < frame->payload.stack_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 pso_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 pso_pointer a pointer to the result + */ +struct pso_pointer lisp_and( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = t; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; + a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } +# + return accumulator ? t : 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 pso_pointer a pointer to the result + */ +struct pso_pointer lisp_or( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + bool accumulator = false; + struct pso_pointer result = frame->payload.stack_frame.more; + + for ( int a = 0; + accumulator == false && a < frame->payload.stack_frame.args; a++ ) { + accumulator = truthy( fetch_arg( frame, a ) ); + } + + return accumulator ? t : 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 pso_pointer `t` if the first argument is `nil`, else `nil`. + */ +struct pso_pointer lisp_not( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + return c_nilp( frame->payload.stack_frame.arg[0] ) ? t : nil; +} diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 9bfe934..720d348 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -16,8 +16,10 @@ #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" +#include "ops/stack_ops.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/psse_string.h" @@ -25,6 +27,63 @@ #include "ops/string_ops.h" #include "ops/truth.h" + +struct pso_pointer reverse( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer sequence = + fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); + for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); + cursor = c_cdr( cursor ) ) { + struct pso2 *object = pointer_to_object( cursor ); + switch ( get_tag_value( cursor ) ) { + case CONSTV: + result = push_local( frame_pointer, + make_cons( frame_pointer, c_car( cursor ), + result ) ); + break; + case KEYTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + KEYTAG ) ); + break; + case STRINGTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + STRINGTAG ) ); + break; + case SYMBOLTV: + result = push_local( frame_pointer, + make_string_like_thing( frame_pointer, + object->payload. + string.character, + result, + SYMBOLTAG ) ); + break; + default: + result = push_local( frame_pointer, + make_exception( make_frame + ( 1, frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Invalid object in sequence" ), + cursor ) ) ) ); + goto exit; + break; + } + } + exit: + + return result; +} + /** * @brief reverse a sequence. * @@ -37,49 +96,11 @@ */ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer sequence ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = nil; - for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); - cursor = c_cdr( cursor ) ) { - struct pso2 *object = pointer_to_object( cursor ); - switch ( get_tag_value( cursor ) ) { - case CONSTV: - result = make_cons( frame_pointer, c_car( cursor ), result ); - break; - case KEYTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, KEYTAG ); - break; - case STRINGTV: - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, STRINGTAG ); - break; - case SYMBOLTV: - // TODO: should you be able to reverse keywords and symbols? - result = - make_string_like_thing( frame_pointer, - object->payload.string.character, - result, SYMBOLTAG ); - break; - default: - result = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Invalid object in sequence" ), - cursor ) ) ); - goto exit; - break; - } + if ( stackp( frame_pointer ) ) { + result = reverse( frame_pointer ); } - exit: - return result; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index cd7fac1..f1d14ea 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -71,9 +71,8 @@ struct pso_pointer push_local( struct pso_pointer frame_pointer, if ( stackp( frame_pointer ) ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer l = - make_cons( frame_pointer, local, - frame->payload.stack_frame.locals ); + struct pso_pointer l = make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); frame->payload.stack_frame.locals = l; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 74d0f47..8d5c345 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -181,8 +181,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { int i = 0; for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = - ( wchar_t ) ( pointer_to_object( c )->payload.string. - character ); + ( wchar_t ) ( pointer_to_object( c )->payload. + string.character ); } mbstate_t ps; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index c4b11c5..b0b2730 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -194,8 +194,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = length( make_frame( 1, previous, argvalues ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )->payload. - integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )-> + payload.integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -253,8 +253,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload. - stack_frame.env ); + ( previous )->payload.stack_frame. + env ); } diff --git a/src/sed/convert.sed b/src/sed/convert.sed index d7d681a..1ab02c8 100644 --- a/src/sed/convert.sed +++ b/src/sed/convert.sed @@ -1,17 +1,16 @@ # 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?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?\&pointer2cell?pointer_to_object?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 aff1430762c941661669fed74c8acb40b1fddee8 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 26 Apr 2026 09:44:09 +0100 Subject: [PATCH 57/77] Brought dump in from 0.0.6. This may be a mistake and I may reverse it. --- src/c/memory/dump.c | 269 ++++++++++++++++++++++++++++++++++++++++++++ src/c/memory/dump.h | 17 +++ 2 files changed, 286 insertions(+) create mode 100644 src/c/memory/dump.c create mode 100644 src/c/memory/dump.h diff --git a/src/c/memory/dump.c b/src/c/memory/dump.c new file mode 100644 index 0000000..46d5c81 --- /dev/null +++ b/src/c/memory/dump.c @@ -0,0 +1,269 @@ +/** + * memory/dump.c + * + * Dump objects to the error stream for.debugging purposes. + * H'mmm... I think it is probably a mistake to do this in C. I need + * to get primitive print working, and primitive eval/applu, and then + * switch to Lisp. + * + * (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 "io/print.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/pso3.h" +#include "memory/pso4.h" +#include "memory/tags.h" + +#include "payloads/character.h" +#include "payloads/cons.h" +#include "payloads/exception.h" +#include "payloads/free.h" +#include "payloads/integer.h" +#include "payloads/read_stream.h" +#include "payloads/stack.h" +#include "payloads/symbol.h" +#include "payloads/time.h" + +//void dump_string_cell( URL_FILE *output, wchar_t *prefix, +// struct pso_pointer pointer ) { +// struct pso2* object = pointer_to_object( pointer ); +// if ( object->payload.string.character == 0 ) { +// url_fwprintf( output, +// L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", +// prefix, +// object->payload.string.cdr.page, +// object->payload.string.cdr.offset, object->header.count ); +// } else { +// url_fwprintf( output, +// L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", +// prefix, +// ( wint_t ) object->payload.string.character, +// object->payload.string.character, +// object->payload.string.hash, +// object->payload.string.cdr.page, +// object->payload.string.cdr.offset, object->header.count ); +//// url_fwprintf( output, L"\t\t value: " ); +//// print( output, pointer ); +// url_fwprintf( output, L"\n" ); +// } +//} +// +// +//void dump_frame_context_fragment( URL_FILE *output, +// struct pso_pointer frame_pointer, +// uint arg) { +// if ( stackp(frame_pointer ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// url_fwprintf( output, L" <= " ); +//// print( frame->payload.stack_frame.arg[arg], output ); +// } +//} +// +//void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, +// int depth ) { +// if ( framep(frame_pointer) ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// url_fwprintf( output, L"\tContext: " ); +// +// int i = 0; +// for ( struct pso_pointer cursor = frame_pointer; +// i++ < depth && !nilp( cursor ); +// cursor = frame_get_previous( cursor ) ) { +// dump_frame_context_fragment( output, cursor, 0 ); +// } +// +// url_fwprintf( output, L"\n" ); +// } +//} +// +///** +// * Dump a stackframe to this stream for debugging +// * @param output the stream +// * @param frame_pointer the pointer to the frame +// */ +//void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { +// if ( framep(frame_pointer) ) { +// struct pso4 *frame = pointer_to_pso4( frame_pointer ); +// +// url_fwprintf( output, L"Stack frame %d with %d arguments:\n", +// frame->payload.stack_frame.depth, frame->payload.stack_frame.args ); +// dump_frame_context( output, frame_pointer, 4 ); +// +// for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) { +// struct pso2* object = fetch_arg(frame, arg); +// +// url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ", +// arg, object->header.tag.bytes.mnemonic[0], object->header.count ); +// +// print( output, frame->payload.stack_frame.arg[arg] ); +// url_fputws( L"\n", output ); +// } +// if ( !nilp( frame->more ) ) { +// url_fputws( L"More: \t", output ); +// print( output, frame->more ); +// url_fputws( L"\n", output ); +// } +// } +//} +// +// +//void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { +// if ( exceptionp( pointer ) ) { +// struct pso3* exep = pointer_to_pso3( pointer); +// print( output, exep->payload.exception. ); +// url_fputws( L"\n", output ); +// dump_stack_trace( output, +// exep->payload.exception.stack ); +// } else { +// while ( stackp( pointer) ) { +// dump_frame( output, pointer ); +// pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous; +// } +// } +//} +// +// +///** +// * dump the object at this pso_pointer to this output stream. +// * TODO: convert this into a proper Lisp function and move to ops +// */ +//struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { +// struct pso_pointer result = nil; +// +// if (stackp(frame_pointer)) { +// struct pso4* frame = pointer_to_pso4( frame_pointer); +// +// struct pso_pointer pointer = fetch_arg( frame, 0); +// struct pso_pointer stream = fetch_arg( frame, 1); +// +// if (!writep(stream)) { +// stream = lisp_stdout; +// } +// +// struct pso2* object = pointer_to_object( pointer ); +// url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", +// object->header.tag.bytes.mnemonic[0], +// get_tag_value(pointer), +// object->header.tag.bytes.size_class, +// pointer.page, pointer.offset, +// object->header.count ); +// +// switch ( get_tag_value( pointer) ) { +// case CONSTV: +// url_fwprintf( output, +// L"\t\tCons object: car at page %d offset %d, cdr at page %d " +// L"offset %d :", +// object->payload.cons.car.page, +// object->payload.cons.car.offset, +// object->payload.cons.cdr.page, +// object->payload.cons.cdr.offset); +// print( output, pointer ); +// url_fputws( L"\n", output ); +// break; +// case EXCEPTIONTV: +// url_fwprintf( output, L"\t\tException object: " ); +// dump_stack_trace( output, pointer ); +// break; +// case FREETV: +// url_fwprintf( output, +// L"\t\tFree object: next at page %d offset %d\n", +// object->payload.free.next.page, +// object->payload.free.next.offset); +// break; +// case INTEGERTV: +// url_fwprintf( output, L"\t\tInteger object: value %ld\n", +// object->payload.integer.value ); +// break; +// case KEYTV: +// dump_string_cell( output, L"Keyword", pointer ); +// break; +//// case LAMBDATV: +//// url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " ); +//// print( output, object->payload.lambda.args ); +//// url_fwprintf( output, L";\n\t\t\tbody: " ); +//// print( output, object->payload.lambda.body ); +//// url_fputws( L"\n", output ); +//// break; +//// case NILTV: +//// break; +//// case NLAMBDATV: +//// url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " ); +//// print( output, object->payload.lambda.args ); +//// url_fwprintf( output, L";\n\t\t\tbody: " ); +//// print( output, object->payload.lambda.body ); +//// url_fputws( L"\n", output ); +//// break; +//// case RATIOTV: +//// url_fwprintf( output, +//// L"\t\tRational object: value %ld/%ld, count %u\n", +//// pointer_to_object( object->payload.ratio.dividend ). +//// payload.integer.value, +//// pointer_to_object( object->payload.ratio.divisor ). +//// payload.integer.value, object->count ); +//// break; +// case READTV: +// url_fputws( L"\t\tInput stream; metadata: ", output ); +//// print( output, object->payload.stream.meta ); +// url_fputws( L"\n", output ); +// break; +//// case REALTV: +//// url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n", +//// object->payload.real.value, object->count ); +//// break; +// case STRINGTV: +// dump_string_cell( output, L"String", pointer ); +// break; +// case SYMBOLTV: +// dump_string_cell( output, L"Symbol", pointer ); +// break; +//// case TRUETV: +//// break; +//// case VECTORPOINTTV:{ +//// url_fwprintf( output, +//// L"\t\tPointer to vector-space object at %p\n", +//// object->payload.vectorp.address ); +//// struct vector_space_object *vso = object->payload.vectorp.address; +//// url_fwprintf( output, +//// L"\t\tVector space object of type %4.4s (%d), payload size " +//// L"%d bytes\n", +//// &vso->header.tag.bytes, vso->header.tag.value, +//// vso->header.size ); +//// +//// switch ( vso->header.tag.value ) { +//// case STACKFRAMETV: +//// dump_frame( output, pointer ); +//// break; +//// case HASHTV: +//// dump_map( output, pointer ); +//// break; +//// } +//// } +//// break; +// case WRITETV: +// url_fputws( L"\t\tOutput stream; metadata: ", output ); +//// print( output, object->payload.stream.meta ); +//// url_fputws( L"\n", output ); +// break; +// } +// } // TODO: else exception +// +// return result; +//} diff --git a/src/c/memory/dump.h b/src/c/memory/dump.h new file mode 100644 index 0000000..98583a6 --- /dev/null +++ b/src/c/memory/dump.h @@ -0,0 +1,17 @@ +/** + * memory/dump.h + * + * Dump objects to the error stream for.debuging purposes + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef SRC_C_MEMORY_DUMP_H_ +#define SRC_C_MEMORY_DUMP_H_ + + +void dump_object( URL_FILE *output, struct pso_pointer pointer ); + + +#endif /* SRC_C_MEMORY_DUMP_H_ */ From aac4669a3d01fd63eef07afa0891f32f71ff1e4f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 28 Apr 2026 11:54:15 +0100 Subject: [PATCH 58/77] Still doesn't compile, but I think excellent progress. --- docs/State-of-play.md | 8 + src/c/debug.h | 5 + src/c/environment/privileged_keywords.c | 43 ++ src/c/environment/privileged_keywords.h | 23 + src/c/memory/tags.h | 7 +- src/c/ops/bind.c | 1 + src/c/ops/cond.c | 114 ++++ src/c/ops/dump.c | 140 ++++ src/c/ops/eval_apply.c | 824 +++++++----------------- src/c/ops/eval_apply.h | 4 +- src/c/ops/inspect.c | 64 ++ src/c/ops/inspect.h | 16 + src/c/ops/keys.c | 49 ++ src/c/ops/keys.h | 19 + src/c/ops/list_ops.c | 14 +- src/c/ops/mapcar.c | 62 ++ src/c/ops/mapcar.h | 0 src/c/ops/progn.c | 84 +++ src/c/ops/progn.h | 23 + src/c/ops/string_ops.c | 52 +- src/c/ops/string_ops.h | 13 +- src/c/payloads/cons.h | 4 +- src/c/payloads/exception.c | 71 ++ src/c/payloads/function.h | 11 - src/c/payloads/keyword.c | 27 + src/c/payloads/keyword.h | 4 + src/c/payloads/lambda.c | 24 + src/c/payloads/lambda.h | 7 +- src/c/payloads/nlambda.h | 4 + src/c/payloads/packed_string.h | 33 + src/c/payloads/psse_string.c | 14 + src/c/payloads/psse_string.h | 3 + src/c/payloads/symbol.c | 29 + src/c/payloads/symbol.h | 5 + 34 files changed, 1128 insertions(+), 673 deletions(-) create mode 100644 src/c/environment/privileged_keywords.c create mode 100644 src/c/environment/privileged_keywords.h create mode 100644 src/c/ops/cond.c create mode 100644 src/c/ops/dump.c create mode 100644 src/c/ops/inspect.c create mode 100644 src/c/ops/inspect.h create mode 100644 src/c/ops/keys.c create mode 100644 src/c/ops/keys.h create mode 100644 src/c/ops/mapcar.c create mode 100644 src/c/ops/mapcar.h create mode 100644 src/c/ops/progn.c create mode 100644 src/c/ops/progn.h create mode 100644 src/c/payloads/keyword.c create mode 100644 src/c/payloads/lambda.c create mode 100644 src/c/payloads/packed_string.h create mode 100644 src/c/payloads/symbol.c diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 155aaab..86bff0f 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,13 @@ # State of Play +## 20260427 + +### eval/apply, yet again + +OK, OK. So the version of `eval`/`apply` written in C is the `:bootstrap` version — which is to say, sufficient to get Lisp bootstrapped, and to run the compiler. One or both can then be replaced by new implementations written in Lisp, to provide the `:system` versions. And any user should in principle be able to override the system versions with their own versions (although troubling worries about security come into that). + +So yesterday, I decided to copy the versions of `eval` and `apply` from `0.0.6` (which, after all, do work — there are lots of problems with the `0.0.6` prototype, but the interpreter is not one of them) into `0.1.0`. But then last night I read the chapter in Cees de Groot's [The Genius of Lisp](https://cdegroot.com/programming/lisp/2026/02/17/why-i-wrote-the-genius-of-lisp.html) and I'm back to wanting to reimplement them *yet again*. I'm not sure that this is wise. + ## 20260424 ### To have `c_` functions or not to have `c_` functions, revisited diff --git a/src/c/debug.h b/src/c/debug.h index 4c3a8b3..317f62d 100644 --- a/src/c/debug.h +++ b/src/c/debug.h @@ -97,6 +97,11 @@ */ #define DEBUG_EQUAL 512 +/** + * @brief sum of all previous DEBUG_ values. + */ +#define DEBUG_ANY 1023 + /** * @brief Verbosity (and content) of debugging output * diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c new file mode 100644 index 0000000..411e6a0 --- /dev/null +++ b/src/c/environment/privileged_keywords.c @@ -0,0 +1,43 @@ +/** + * privileged_keywords.c + * + * Post Scarcity Soctware Environment + * + * Keywords essential to the operation of the system. I'm not certain that + * there's any necessity to have privileged keywords, but as these are + * keywords that will be used exceedingly frequently, we might as well + * make them cheap to access. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "environment/privileged_keywords.h" + +#include "memory/node.h" +#include "memory/pointer.h" + +#include "memory/pso.h" +#include "payloads/cons.h" + +#include "ops/string_ops.h" + + +/** + * location metadata for exceptions (and possibly location in other contexts). + */ +struct pso_pointer privileged_keyword_location; + +/** + * name metadata for compiled functions. + */ +struct pso_pointer privileged_keyword_name; + + +#define load_and_lock(var,val)var = lock_object(c_string_to_lisp_keyword(nil, val)) + + +struct pso_pointer initialise_privileged_keywords( struct pso_pointer env){ + load_and_lock(privileged_keyword_location, PK_LOCATION); + load_and_lock( privileged_keyword_name, PK_NAME); +} \ No newline at end of file diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h new file mode 100644 index 0000000..74a9723 --- /dev/null +++ b/src/c/environment/privileged_keywords.h @@ -0,0 +1,23 @@ +/** + * privileged_keywords.h + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ +#define SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ + +#define PK_LOCATION U"location" +#define PK_NAME = U"name" + +#include "memory/pointer.h" +extern struct pso_pointer privileged_keyword_location; +extern struct pso_pointer privileged_keyword_name; + +struct pso_pointer initialise_privileged_keywords( struct pso_pointer env); +#endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 422c1dd..faad41f 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -135,6 +135,11 @@ bool check_type( struct pso_pointer p, char *s ); // #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)) +#define writep(p) (check_tag(p, WRITETV)) + +/** a sequence is an object having a list structure with the pointer to the + * remainder in the fourth word of each cell. I.e., cons, string, symbol, + * keyword, possibly some others */ +#define sequencep(p)(consp(p) || keywordp(p) || stringp(p) || symbolp(p)) #endif diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 2b6f447..743de6b 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -35,3 +35,4 @@ struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) { return cons( make_frame( 2, frame_pointer, binding, store ) ); } + diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c new file mode 100644 index 0000000..f764661 --- /dev/null +++ b/src/c/ops/cond.c @@ -0,0 +1,114 @@ + +/** + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is t and whose cdr is the value of the action part + */ +#include "debug.h" + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +#include "ops/progn.h" +#include "ops/stack_ops.h" +#include "ops/truth.h" + +#include "payloads/cons.h" +#include "payloads/exception.h" + +/** + * if the car of a consp evaluates to non-nil, the clause succeeded and the + * cond expression must conclude, even if the result of the clause is nil. + * + * Therefore this funtion will + * @return nil if the test failed; + * @return a pair `(t . )` if the test succeeded. + */ +struct pso_pointer eval_cond_clause( struct pso_pointer clause, + struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); +#endif + + if ( consp( clause ) ) { + struct pso_pointer val = + eval_form( frame, frame_pointer, c_car( clause ), + env ); + + if ( !c_nilp( val ) ) { + result = + cons( t, + c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); + +#ifdef DEBUG + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); + } else { + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print_object( clause, DEBUG_EVAL, 0 ); + debug_print( L" failed.\n", DEBUG_EVAL, 0 ); +#endif + } + } else { + result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), + c_string_to_lisp_string + (frame_pointer, 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 pso4. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. + */ +struct pso_pointer +lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + bool done = false; + + for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { + struct pso_pointer clause_pointer = fetch_arg( frame, i ); + + // TODO: WHOOPS! This isn't right. If the test of a cond clause + // evaluates to non-nil, but the last form of the clause evaluates + // to nil, the form still succeeded and we should still exit `cond`. + // + + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + + if ( !c_nilp( result ) && c_truep( c_car( result ) ) ) { + result = c_cdr( result ); + done = true; + break; + } + } +#ifdef DEBUG + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); +#endif + + return result; +} diff --git a/src/c/ops/dump.c b/src/c/ops/dump.c new file mode 100644 index 0000000..0e3ed86 --- /dev/null +++ b/src/c/ops/dump.c @@ -0,0 +1,140 @@ +/* + * dump.c + * + * Dump representations of both cons space and vector space objects. + * + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* + * wide characters + */ +#include +#include + +#include "memory/pso2.h" +#include "memory/tags.h" +#include "io/print.h" + +#include "payloads/lambda.h" + + +void dump_string_cell( URL_FILE *output, wchar_t *prefix, + struct pso_pointer pointer ) { + struct pso2 *cell = pointer_to_object( pointer ); + if ( cell->payload.string.character == 0 ) { + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell->payload.string.cdr.page, + cell->payload.string.cdr.offset, cell->header.count ); + } else { + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell->payload.string.character, + cell->payload.string.character, + cell->payload.string.hash, + cell->payload.string.cdr.page, + cell->payload.string.cdr.offset, cell->header.count ); + url_fwprintf( output, L"\t\t value: " ); + print( output, pointer ); + url_fwprintf( output, L"\n" ); + } +} + +/** + * dump the object at this pso_pointer to this output stream. + */ +void dump_object( URL_FILE *output, struct pso_pointer pointer ) { + struct pso2 *cell = pointer_to_object( pointer ); + url_fwprintf( output, L"\t%3.3s (%d) at page %d, offset %d count %u\n", + cell->header.tag.bytes.mnemonic[0], get_tag_value( pointer ), + pointer.page, pointer.offset, cell->header.count ); + + switch ( get_tag_value( pointer ) ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell->payload.cons.car.page, + cell->payload.cons.car.offset, + cell->payload.cons.cdr.page, + cell->payload.cons.cdr.offset ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell->payload.cons.cdr.page, + cell->payload.cons.cdr.offset ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell->payload.integer.value, cell->header.count ); + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell->payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell->payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell->payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell->payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer_to_object( cell->payload.ratio. + dividend ).payload.integer.value, + pointer_to_object( cell->payload.ratio. + divisor ).payload.integer.value, + cell->header.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell->payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell->payload.real.value, cell->header.count ); + break; + case STACKTV: + dump_frame( output, pointer ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell->payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } +} diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index e26fc1c..e6bff33 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -1,10 +1,10 @@ /** - * ops/apply.c + * ops/eval_apply.c * - * Post Scarcity Software Environment: apply. + * Post Scarcity Software Environment: eval and apply. * - * Add a applying for a key/value pair to a store -- at this stage, just an - * association list. + * apply: Apply a function to arguments in an environment. + * eval: Evaluate a form in an environment. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -18,6 +18,9 @@ #include "debug.h" + +#include "environment/privileged_keywords.h" + #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -28,13 +31,17 @@ #include "ops/assoc.h" #include "ops/bind.h" +#include "ops/eval_apply.h" #include "ops/reverse.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/function.h" +#include "payloads/lambda.h" +#include "payloads/nlambda.h" #include "payloads/stack.h" ///** @@ -338,10 +345,11 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { * @param env the environment in which it is to be intepreted. * @return an interpretable function with these `args` and this `body`. */ -//struct pso_pointer -//lisp_lambda( struct pso_pointer frame_pointer ) { -// return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); -//} +struct pso_pointer +lisp_lambda( struct pso_pointer frame_pointer ) { + struct pso4* frame = pointer_to_pso4(frame_pointer); + return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +} /** * Construct an interpretable special form. *NOTE* that if `args` is a single symbol @@ -354,25 +362,27 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { * @param env the environment in which it is to be intepreted. * @return an interpretable special form with these `args` and this `body`. */ -//struct pso_pointer -//lisp_nlambda( struct pso_pointer frame_pointer, -// struct pso_pointer env ) { -// return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); -//} +struct pso_pointer +lisp_nlambda( struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso4* frame = pointer_to_pso4(frame_pointer); + return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); +} /** * Evaluate a lambda or nlambda expression. */ struct pso_pointer -eval_lambda( struct pso4 *frame, - struct pso_pointer frame_pointer, struct pso_pointer env ) { - struct pso_pointer result = nil; - struct pso2 *cell = - pointer_to_object( fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ); +eval_lambda( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso2 *lambda = pointer_to_object(fetch_arg(frame, 0)); + struct pso_pointer args = fetch_arg( frame, 1); + struct pso_pointer new_env = fetch_env( frame_pointer ); - struct pso_pointer names = cell->payload.lambda.args; - struct pso_pointer body = cell->payload.lambda.body; + struct pso_pointer names = lambda->payload.lambda.args; + struct pso_pointer body = lambda->payload.lambda.body; #ifdef DEBUG debug_print( L"eval_lambda called\n", DEBUG_LAMBDA, 0 ); debug_println( DEBUG_LAMBDA ); @@ -399,8 +409,12 @@ eval_lambda( struct pso4 *frame, /* 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->payload.stack_frame.more */ -// struct pso_pointer vals = -// eval_forms( frame, frame_pointer, frame->payload.stack_frame.more, env ); + struct pso_pointer more_frame = inc_ref( + make_frame(1, frame_pointer, + frame->payload.stack_frame.more)); + + struct pso_pointer vals = + eval_forms( more_frame ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct pso_pointer next = @@ -410,7 +424,7 @@ eval_lambda( struct pso4 *frame, if ( c_nilp( val ) && c_nilp( vals ) ) { /* nothing */ } else { - vals = make_cons( frame_pointer, val, vals ); + new_env = make_cons( frame_pointer, val, vals ); } } @@ -457,42 +471,129 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, fn_pointer ) { struct pso_pointer result = r; - if ( exceptionp( result ) - && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { - struct pso2 **fn_cell = pointer_to_object( fn_pointer ); - - struct pso_pointer payload = - pointer_to_object( result ).payload.exception.payload; - - switch ( get_header.tag.bytes.value & 0xfffff( payload ) ) { - case nilTV: - case CONSTV: - case HASHTV: - { - if ( c_nilp( c_assoc( privileged_keyword_location, - payload ) ) ) { - pointer_to_object( result ).payload.exception.payload = - set( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function.meta ), - payload ); - } - } - break; - default: - pointer_to_object( result ).payload.exception.payload = - cons( cons( privileged_keyword_location, - c_assoc( privileged_keyword_name, - fn_cell->payload.function.meta ) ), - cons( cons - ( privileged_keyword_payload, - payload ), nil ) ); - } - } +// if ( exceptionp( result ) +// && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) { +// struct pso2 **fn_cell = pointer_to_object( fn_pointer ); +// +// struct pso_pointer payload = +// pointer_to_pso3( result )->payload.exception.meta; +// +// switch ( get_tag_value(payload)) { +// case NILTV: +// case CONSTV: +// case HASHTV: +// { +// if ( c_nilp( c_assoc( privileged_keyword_location, +// payload ) ) ) { +// pointer_to_pso3( result )->payload.exception.meta = +// make_cons(frame_pointer, privileged_keyword_location, +// c_assoc( privileged_keyword_name, +// fn_cell->payload.function.meta ), +// payload ); +// } +// } +// break; +// default: +// pointer_to_pso3( result )->payload.exception.meta = +// cons( cons( privileged_keyword_location, +// c_assoc( privileged_keyword_name, +// fn_cell->payload.function.meta ) ), +// cons( cons +// ( privileged_keyword_payload, +// payload ), nil ) ); +// } +// } return result; } +/** + * @brief Create a new stack frame in which to evaluate the function indicated + * by this `fn_pointer`, with evaluated args from this `arg_list`. + * + * @param previous the parent stack frame; + * @param fn_pointer a pointer to the function object or lambda to evaluate; + * @param arg_list a Lisp list of args to be passed; + * + * @return a pointer to the new frame. + */ +struct pso_pointer make_fn_frame(struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list) { + + struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + struct pso_pointer next_pointer = + push_local(previous, make_frame(1, previous, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + new_frame->payload.stack_frame.function = fn_pointer; + + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car(cursor); + new_frame->payload.stack_frame.arg[args++] = inc_ref( lisp_eval( next_pointer) ); + } + if (consp(cursor)) { + struct pso_pointer more = nil; + + for (; consp(cursor); cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save + // allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car(cursor); + more = make_cons(previous, lisp_eval(next_pointer), more); + + args++; + } + + new_frame->payload.stack_frame.more = inc_ref( c_reverse( more)); + } + + new_frame->payload.stack_frame.args = args; + dec_ref(next_pointer); + + return new_pointer; +} + + +/** + * @brief Create a new stack frame in which to evaluate the special form + * indicated by this `fn_pointer`, with unevaluated args from this `arg_list`. + * + * @param previous the parent stack frame; + * @param fn_pointer a pointer to the special form object or nlambda to + * evaluate; + * @param arg_list a Lisp list of args to be passed; + * + * @return a pointer to the new frame. + */ +struct pso_pointer make_special_frame(struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list) { + + struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + + new_frame->payload.stack_frame.function = fn_pointer; + + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) ); + } + if (consp(cursor)) { + + new_frame->payload.stack_frame.more = inc_ref( cursor); + } + + new_frame->payload.stack_frame.args = args; + + return new_pointer; +} + /** * Internal guts of apply. @@ -501,23 +602,23 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, * @param env The evaluation environment. * @return the result of evaluating the function with its arguments. */ -struct pso_pointer -c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - debug_print( L"Entering c_apply\n", DEBUG_EVAL, 0 ); +struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { + debug_print( L"Entering apply\n", DEBUG_EVAL, 0 ); struct pso_pointer result = nil; + struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso_pointer fn_frame = inc_ref( make_frame(1, frame_pointer, c_car( frame->payload.stack_frame.arg[0] ))); struct pso_pointer fn_pointer = - eval_form( frame, frame_pointer, - c_car( frame->payload.stack_frame.arg[0] ), env ); - + push_local(frame_pointer, eval_form( fn_frame)); + dec_ref( fn_frame); + if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { - struct pso2 **fn_cell = pointer_to_object( fn_pointer ); + struct pso2 *fn_cell = pointer_to_object( fn_pointer ); struct pso_pointer args = c_cdr( frame->payload.stack_frame.arg[0] ); - switch ( get_header.tag.bytes.value & 0xfffff( fn_pointer ) ) { + switch ( get_tag_value( fn_pointer ) ) { case EXCEPTIONTV: /* just pass exceptions straight back */ result = fn_pointer; @@ -525,51 +626,46 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, case FUNCTIONTV: { - struct pso_pointer exep = nil; struct pso_pointer next_pointer = - make_pso4( frame_pointer, args, env ); + inc_ref( make_fn_frame( frame_pointer, fn_pointer, args )); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - struct pso4 *next = pointer_to_pso4( next_pointer ); - - result = maybe_fixup_exception_location( ( * + result = push_local( frame_pointer, + maybe_fixup_exception_location( ( * ( fn_cell-> payload. function. executable ) ) - ( next, - next_pointer, - env ), - fn_pointer ); + (next_pointer ), + fn_pointer )); dec_ref( next_pointer ); } } break; - case KEYTV: - result = c_assoc( fn_pointer, - eval_form( frame, - frame_pointer, - c_car( c_cdr - ( frame->payload. - stack_frame.arg[0] ) ), - env ) ); - break; + case KEYTV: { + struct pso_pointer map_frame = + inc_ref(make_frame(1, frame_pointer, c_car(args))); + result = push_local( + frame_pointer, + c_assoc(fn_pointer, + maybe_fixup_exception_location( + eval_form(map_frame), fn_pointer))); + } break; - case LAMBDATV: + case LAMBDATV: { - struct pso_pointer exep = nil; struct pso_pointer next_pointer = - make_pso4( frame_pointer, args, env ); + make_fn_frame( frame_pointer, fn_pointer, args ); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { struct pso4 *next = pointer_to_pso4( next_pointer ); result = - eval_lambda( fn_cell, next, next_pointer, env ); + eval_lambda( next_pointer ); if ( !exceptionp( result ) ) { dec_ref( next_pointer ); } @@ -578,26 +674,27 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_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->payload. - stack_frame.arg[0] ) ), - env ), fn_pointer ); + /* \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->payload. + // stack_frame.arg[0] ) ), + // env ), fn_pointer ); break; case NLAMBDATV: { struct pso_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); + make_special_frame( frame_pointer, fn_pointer, args ); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { struct pso4 *next = pointer_to_pso4( next_pointer ); result = - eval_lambda( fn_cell, next, next_pointer, env ); + eval_lambda( next_pointer ); dec_ref( next_pointer ); } } @@ -606,7 +703,7 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, case SPECIALTV: { struct pso_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); + make_special_frame( frame_pointer, fn_pointer, args ); if ( exceptionp( next_pointer ) ) { result = next_pointer; @@ -616,11 +713,11 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, payload. special. executable ) ) - ( pointer_to_pso4( next_pointer ), next_pointer, env ), fn_pointer ); - debug_print( L"Special form returning: ", DEBUG_EVAL, + ( next_pointer ), fn_pointer ); + debug_print( U"Special form returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); dec_ref( next_pointer ); } } @@ -632,23 +729,23 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, 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->header.tag.bytes.value & 0xfffff, - &( fn_cell->tag.bytes[0] ) ); + L"Unexpected cell with tag %u (%3.3s) in function position", + get_tag_value(fn_pointer), + &( fn_cell->header.tag.bytes.mnemonic[0] ) ); struct pso_pointer message = - c_string_to_lisp_string( buffer ); + c_string_to_lisp_string( frame_pointer, buffer ); free( buffer ); result = - throw_exception( c_string_to_lisp_symbol( L"apply" ), + make_exception( frame_pointer, c_string_to_lisp_symbol( frame_pointer, U"apply" ), message, frame_pointer ); } } } - debug_print( L"c_apply: returning: ", DEBUG_EVAL, 0 ); + debug_print( L"apply: returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); return result; } @@ -674,31 +771,34 @@ c_apply( struct pso4 *frame, struct pso_pointer frame_pointer, * @exception if `expression` is a symbol which is not bound in `env`. */ struct pso_pointer -lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_eval( struct pso_pointer frame_pointer ) { debug_print( L"Eval: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + struct pso4* frame = pointer_to_pso4(frame_pointer); struct pso_pointer result = frame->payload.stack_frame.arg[0]; - struct pso2 **cell = - pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso2 *cell = pointer_to_object(frame->payload.stack_frame.arg[0]); + struct pso_pointer env = fetch_env(frame_pointer); - switch ( cell->header.tag.bytes.value & 0xfffff ) { - case CONSTV: - result = c_apply( frame, frame_pointer, env ); - break; + switch (get_tag_value(result)) { + case CONSTV: { + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(2, frame_pointer, + c_car(result), c_cdr(result))); + result = push_local(frame_pointer, lisp_apply(next_pointer)); + } break; - case SYMBOLTV: + case SYMBOLTV: { struct pso_pointer canonical = - interned( frame->payload.stack_frame.arg[0], env ); + c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); if ( c_nilp( canonical ) ) { struct pso_pointer message = - cons( c_string_to_lisp_string - ( L"Attempt to take value of unbound symbol." ), + make_cons( frame_pointer, c_string_to_lisp_string + ( frame_pointer, L"Attempt to take value of unbound symbol." ), frame->payload.stack_frame.arg[0] ); result = - throw_exception( c_string_to_lisp_symbol( L"eval" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"eval" ), message, frame_pointer ); } else { result = c_assoc( canonical, env ); @@ -713,47 +813,18 @@ lisp_eval( struct pso4 *frame, struct pso_pointer frame_pointer, * H'mmm... this is working, but it isn't here. Where is it? */ default: - result = frame->payload.stack_frame.arg[0]; + // we've already done this... break; - } + } - debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); debug_dump_object( result, DEBUG_EVAL, 0 ); 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 pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment. - * @return the result of applying `fn` to `args`. - */ -struct pso_pointer -lisp_apply( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - debug_print( L"Apply: ", DEBUG_EVAL, 0 ); - debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); - set_reg( frame, 0, - cons( frame->payload.stack_frame.arg[0], - frame->payload.stack_frame.arg[1] ) ); - set_reg( frame, 1, nil ); - - struct pso_pointer result = c_apply( frame, frame_pointer, env ); - - debug_print( L"Apply returning ", DEBUG_EVAL, 0 ); - debug_dump_object( result, DEBUG_EVAL, 0 ); - - return result; -} /** @@ -775,212 +846,6 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, } -/** - * 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 pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return `value` - */ -struct pso_pointer -lisp_set( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - struct pso_pointer namespace = - c_nilp( frame->payload.stack_frame.arg[2] ) ? oblist : frame->payload. - stack_frame.arg[2]; - - if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { - deep_bind( frame->payload.stack_frame.arg[0], - frame->payload.stack_frame.arg[1] ); - result = frame->payload.stack_frame.arg[1]; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set" ), - cons - ( c_string_to_lisp_string - ( L"The first argument to `set` is not a symbol: " ), - cons( frame->payload.stack_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 pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return `value` - */ -struct pso_pointer -lisp_set_shriek( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - struct pso_pointer namespace = frame->payload.stack_frame.arg[2]; - - if ( symbolp( frame->payload.stack_frame.arg[0] ) ) { - struct pso_pointer val = - eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[1], - env ); - deep_bind( frame->payload.stack_frame.arg[0], val ); - result = val; - } else { - result = - throw_exception( c_string_to_lisp_symbol( L"set!" ), - cons - ( c_string_to_lisp_string - ( L"The first argument to `set!` is not a symbol: " ), - cons( frame->payload.stack_frame.arg[0], - nil ) ), frame_pointer ); - } - - return result; -} - -/** - * @return t if `arg` represents an end of string, else false. - * \todo candidate for moving to a memory/string.c file - */ -bool end_of_stringp( struct pso_pointer arg ) { - return c_nilp( arg ) || - ( stringp( arg ) && - pointer_to_object( arg ).payload.string.character == - ( wint_t ) '\0' ); -} - -/** - * Function; look up the value of a `key` in a `store`. - * - * * (assoc key store) - * - * @param frame my pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return the value associated with `key` in `store`, or `nil` if not found. - */ -struct pso_pointer -lisp_assoc( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return c_assoc( frame->payload.stack_frame.arg[0], - c_nilp( frame->payload.stack_frame. - arg[1] ) ? oblist : frame->payload.stack_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 pso_pointer - */ -struct pso_pointer -lisp_internedp( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = internedp( frame->payload.stack_frame.arg[0], - c_nilp( frame->payload.stack_frame. - arg[1] ) ? oblist : frame-> - payload.stack_frame.arg[1] ); - - if ( exceptionp( result ) ) { - struct pso_pointer old = result; - struct pso2 **cell = &( pointer_to_object( result ) ); - result = - throw_exception( c_string_to_lisp_symbol( L"interned?" ), - cell->payload.exception.payload, frame_pointer ); - dec_ref( old ); - } - - return result; -} - -struct pso_pointer c_keys( struct pso_pointer store ) { - struct pso_pointer result = nil; - - if ( consp( store ) ) { - for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); - pair = c_car( store ) ) { - if ( consp( pair ) ) { - result = 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 pso_pointer lisp_keys( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return c_keys( frame->payload.stack_frame.arg[0] ); -} - -/** - * 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 pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return the number of top level forms in a list, or characters in a - * string, else 0. - */ -struct pso_pointer -lisp_count( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return acquire_integer( c_count( frame->payload.stack_frame.arg[0] ), - nil ); -} - - - - -/** - * Function; reverse the order of members in s sequence. - * - * * (reverse sequence) - * - * @param frame my pso4. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return a sequence like this `sequence` but with the members in the reverse order. - */ -struct pso_pointer lisp_reverse( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return c_reverse( frame->payload.stack_frame.arg[0] ); -} @@ -1000,251 +865,6 @@ lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, return c_type( frame->payload.stack_frame.arg[0] ); } -/** - * Evaluate each of these expressions in this `env`ironment over this `frame`, - * returning only the value of the last. - */ -struct pso_pointer -c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer expressions, struct pso_pointer env ) { - struct pso_pointer result = nil; - - while ( consp( expressions ) ) { - struct pso_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 pso4. - * @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 pso_pointer -lisp_progn( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - - for ( int i = 0; - i < args_in_frame && !c_nilp( frame->payload.stack_frame.arg[i] ); - i++ ) { - struct pso_pointer r = result; - - result = - eval_form( frame, frame_pointer, frame->payload.stack_frame.arg[i], - env ); - - dec_ref( r ); - } - - if ( consp( frame->payload.stack_frame.more ) ) { - result = - c_progn( frame, frame_pointer, frame->payload.stack_frame.more, - env ); - } - - return result; -} - -/** - * @brief evaluate a single cond clause; if the test part succeeds return a - * pair whose car is t and whose cdr is the value of the action part - */ -struct pso_pointer eval_cond_clause( struct pso_pointer clause, - struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - -#ifdef DEBUG - debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); - debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); -#endif - - if ( consp( clause ) ) { - struct pso_pointer val = - eval_form( frame, frame_pointer, c_car( clause ), - env ); - - if ( !c_nilp( val ) ) { - result = - cons( t, - c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); - -#ifdef DEBUG - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); - debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); - debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); - } else { - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); - debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( L" failed.\n", DEBUG_EVAL, 0 ); -#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 pso4. - * @param env the environment in which arguments will be evaluated. - * @return the value of the last expression of the first successful `clause`. - */ -struct pso_pointer -lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - bool done = false; - - for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { - struct pso_pointer clause_pointer = fetch_arg( frame, i ); - - result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); - - if ( !c_nilp( result ) && tp( c_car( result ) ) ) { - result = c_cdr( result ); - done = t; - break; - } - } -#ifdef DEBUG - debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); - debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); -#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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct pso_pointer throw_exception_with_cause( struct pso_pointer location, - struct pso_pointer message, - struct pso_pointer cause, - struct pso_pointer - frame_pointer ) { - struct pso_pointer result = nil; - -#ifdef DEBUG - debug_print( L"\nERROR: `", 511, 0 ); - debug_print_object( message, 511 ); - debug_print( L"` at `", 511, 0 ); - debug_print_object( location, 511 ); - debug_print( L"`\n", 511, 0 ); - if ( !c_nilp( cause ) ) { - debug_print( L"\tCaused by: ", 511, 0 ); - debug_print_object( cause, 511 ); - debug_print( L"`\n", 511, 0 ); - } -#endif - struct pso2 **cell = pointer_to_object( message ); - - if ( cell->header.tag.bytes.value & 0xfffff == EXCEPTIONTV ) { - result = message; - } else { - result = - make_exception( cons - ( cons( privileged_keyword_location, - location ), - cons( cons - ( privileged_keyword_payload, - message ), - ( c_nilp( cause ) ? nil : - cons( 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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space - * pointer to the frame in which the exception occurred. - */ -struct pso_pointer -throw_exception( struct pso_pointer location, - struct pso_pointer payload, - struct pso_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 pso4. - * @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 pso_pointer -lisp_exception( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer message = frame->payload.stack_frame.arg[0]; - - return exceptionp( message ) ? message : - throw_exception_with_cause( message, frame->payload.stack_frame.arg[1], - frame->payload.stack_frame.arg[2], - frame->previous ); -} /** * Function: the read/eval/print loop. diff --git a/src/c/ops/eval_apply.h b/src/c/ops/eval_apply.h index 2f326fa..4126657 100644 --- a/src/c/ops/eval_apply.h +++ b/src/c/ops/eval_apply.h @@ -17,10 +17,10 @@ #include "memory/pso4.h" #include "payloads/function.h" -struct pso_pointer apply( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_apply( struct pso_pointer frame_pointer ); -struct pso_pointer eval( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_eval( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c new file mode 100644 index 0000000..6f9b856 --- /dev/null +++ b/src/c/ops/inspect.c @@ -0,0 +1,64 @@ +/** + * inspect.c + * + * Post Scarcity Soctware Environment + * + * Display the contents of an object; later, in explorable form. + * + * Copyright (c): 25 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#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/stack_ops.h" + +/** + * 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) + * + * TODO: IT OCCURS TO ME that if `inspect` returns a Markdown formatted string + * then it will be readable right away, but wrappable in a browser later to + * allow interactive exploration. + * + * @param frame my pso4. + * @param frame_pointer a pointer to my pso4. + * @param env my environment (from which the stream may be extracted). + * @return nil. + */ +struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 ); + struct pso_pointer result = nil; + + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer out_stream = writep( frame->payload.stack_frame.arg[1] ) + ? frame->payload.stack_frame.arg[1] + : get_default_stream( false, fetch_env( frame_pointer ) ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO, 0 ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer_to_object( out_stream )->payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->payload.stack_frame.arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 ); + + return result; +} diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h new file mode 100644 index 0000000..7e15d15 --- /dev/null +++ b/src/c/ops/inspect.h @@ -0,0 +1,16 @@ +/** + * inspect.h + * + * Post Scarcity Soctware Environment + * + * Display the contents of an object; later, in explorable form. + * + * Copyright (c): 25 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef psse_ops_inspect +#define psse_ops_inspect + +struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ); +#endif \ No newline at end of file diff --git a/src/c/ops/keys.c b/src/c/ops/keys.c new file mode 100644 index 0000000..2ec8ac9 --- /dev/null +++ b/src/c/ops/keys.c @@ -0,0 +1,49 @@ +/** + * ops/keys.c + * + * Post Scarcity Software Environment: eval and apply. + * + * keys: return an unsorted list of the keys bound in a store. + * + * (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/tags.h" +#include "ops/truth.h" +#include "payloads/cons.h" + +/** + * @brief an implementation of `keys` convenient for calling from C + * + * @param */ +struct pso_pointer c_keys( struct pso_pointer store ) { + struct pso_pointer result = nil; + + if ( consp( store ) ) { + for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); + pair = c_car( store ) ) { + if ( consp( pair ) ) { + result = cons( c_car( pair ), result ); + // } else if ( hashtabp( pair ) ) { + // result = c_append( hashmap_keys( pair ), result ); + } + + store = c_cdr( store ); + } + // } else if ( hashtabp( store ) ) { + // result = hashmap_keys( store ); + } + + return result; +} + + + +struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) { + return c_keys( pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); +} + diff --git a/src/c/ops/keys.h b/src/c/ops/keys.h new file mode 100644 index 0000000..3b48261 --- /dev/null +++ b/src/c/ops/keys.h @@ -0,0 +1,19 @@ +/** + * ops/keys.h + * + * Post Scarcity Software Environment: keys. + * + * keys: return an unsorted list of the keys bound in a store. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef psse_ops_keys +#define psse_ops_keys + +struct pso_pointer c_keys( struct pso_pointer store ); + +struct pso_pointer lisp_keys(struct pso_pointer frame_pointer); + +#endif \ No newline at end of file diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 3baeabf..6ef05b9 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -13,20 +13,24 @@ #include "memory/pso4.h" #include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/integer.h" #include "payloads/stack.h" #include "ops/truth.h" -struct pso_pointer length( struct pso_pointer frame_pointer ) { +struct pso_pointer count( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer list = fetch_arg( frame, 0 ); - int count = 0; + int c = 0; for ( struct pso_pointer cursor = list; !c_nilp( cursor ); - cursor = cdr( make_frame( 1, frame_pointer, list ) ) ) { - count++; + cursor = c_cdr( cursor ) ) { + c++; } - return make_integer( frame_pointer, count ); + return acquire_integer( frame_pointer, c ); } + diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c new file mode 100644 index 0000000..444cfc8 --- /dev/null +++ b/src/c/ops/mapcar.c @@ -0,0 +1,62 @@ +/** + * ops/mapcar.c + * + * Post Scarcity Software Environment: mapcar. + * + * map a function across a sequence of forms. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + + +#include "debug.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/tags.h" +#include "ops/reverse.h" +#include "ops/truth.h" +#include "payloads/cons.h" + +struct pso_pointer lisp_mapcar( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer env ) { + struct pso_pointer result = nil; + debug_print( U"Mapcar: ", DEBUG_EVAL, 0 ); + debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); + int i = 0; + + for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); + c = c_cdr( c ) ) { + struct pso_pointer expr = + cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + + debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL, 0 ); + + struct pso_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 = cons( r, result ); + } + debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); + + dec_ref( expr ); + } + + result = consp( result ) ? c_reverse( result ) : result; + + debug_print( U"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print_object( result, DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); + + return result; +} diff --git a/src/c/ops/mapcar.h b/src/c/ops/mapcar.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/ops/progn.c b/src/c/ops/progn.c new file mode 100644 index 0000000..f5ac897 --- /dev/null +++ b/src/c/ops/progn.c @@ -0,0 +1,84 @@ +/** + * ops/progn.c + * + * Post Scarcity Software Environment: progn. + * + * Evaluate a sequence of expressions and return the value of the last. + * + * (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/pso4.h" +#include "memory/tags.h" + +#include "ops/eval_apply.h" +#include "ops/stack_ops.h" + +#include "payloads/cons.h" +#include "payloads/stack.h" + + +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct pso_pointer +c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, struct pso_pointer env ) { + struct pso_pointer result = nil; + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(1, frame_pointer, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + while ( consp( expressions ) ) { + next_frame->payload.stack_frame.arg[0] = c_car(expressions); + + result = lisp_eval( next_pointer); + + 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 pso4. + * @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 pso_pointer +lisp_progn( struct pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(1, frame_pointer, nil)); + struct pso4 *next_frame = pointer_to_pso4(next_pointer); + + for (int i = 0; i < args_in_frame; i++) { + next_frame->payload.stack_frame.arg[0] = + frame->payload.stack_frame.arg[i]; + + result = push_local(frame_pointer, lisp_eval(next_pointer)); + } + + if (consp(frame->payload.stack_frame.more)) { + result = + c_progn(frame, frame_pointer, frame->payload.stack_frame.more, env); + } + + return result; +} diff --git a/src/c/ops/progn.h b/src/c/ops/progn.h new file mode 100644 index 0000000..4651485 --- /dev/null +++ b/src/c/ops/progn.h @@ -0,0 +1,23 @@ +/** + * ops/progn.c + * + * Post Scarcity Software Environment: progn. + * + * Evaluate a sequence of expressions and return the value of the last. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_progn_h +#define __psse_ops_progn_h + +#include "memory/pointer.h" +#include "memory/pso4.h" + +struct pso_pointer c_progn(struct pso4 *frame, struct pso_pointer frame_pointer, + struct pso_pointer expressions, + struct pso_pointer env); + +struct pso_pointer lisp_progn(struct pso_pointer frame_pointer); +#endif \ No newline at end of file diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 8d5c345..47e30a3 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -26,6 +26,7 @@ #include "ops/truth.h" #include "payloads/exception.h" +#include "payloads/symbol.h" /** @@ -100,45 +101,6 @@ struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, 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( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, 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( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, 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( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); -} - /** * Return a lisp string representation of this wide character string. @@ -245,3 +207,15 @@ struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, return result; } + + +/** + * @return t if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct pso_pointer arg ) { + return c_nilp( arg ) || + ( stringp( arg ) && + pointer_to_object( arg )->payload.string.character == + ( wint_t ) '\0' ); +} diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 463aab7..4e94ae9 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -9,7 +9,7 @@ #ifndef __psse_ops_string_ops_h #define __psse_ops_string_ops_h - +#include /* * wide characters */ @@ -21,15 +21,6 @@ struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail, char *tag ); -struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - -struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - -struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); - struct pso_pointer c_string_to_lisp_string( struct pso_pointer frame_pointer, wchar_t *string ); char *lisp_string_to_c_string( struct pso_pointer s ); @@ -41,4 +32,6 @@ struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, char32_t * symbol ); +bool end_of_stringp(struct pso_pointer arg); + #endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index fdbfc8f..bb10292 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -49,7 +49,7 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer, */ #define make_cons2(car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) -#define c_car(p)(consp(p) ? pointer_to_object(p)->payload.cons.car : nil) -#define c_cdr(p)(consp(p) ? pointer_to_object(p)->payload.cons.cdr : nil) +#define c_car(p)(sequencep(p) ? pointer_to_object(p)->payload.cons.car : nil) +#define c_cdr(p)(sequencep(p) ? pointer_to_object(p)->payload.cons.cdr : nil) #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 729e1f9..2bcb802 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -15,6 +15,8 @@ #include +#include "debug.h" +#include "environment/privileged_keywords.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -26,6 +28,7 @@ #include "ops/stack_ops.h" #include "ops/truth.h" +#include "payloads/cons.h" #include #include #include @@ -92,3 +95,71 @@ struct pso_pointer destroy_exception( struct pso_pointer fp ) { return nil; } + +/** + * 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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer throw_exception_with_cause( struct pso_pointer location, + struct pso_pointer message, + struct pso_pointer cause, + struct pso_pointer + frame_pointer ) { + struct pso_pointer result = nil; + +#ifdef DEBUG + debug_print( U"\nERROR: `", DEBUG_ANY, 0 ); + debug_print_object( message, DEBUG_ANY, 0 ); + debug_print( U"` at `", DEBUG_ANY, 0 ); + debug_print_object( location, DEBUG_ANY, 0 ); + debug_print( U"`\n", DEBUG_ANY, 0 ); + if ( !c_nilp( cause ) ) { + debug_print( U"\tCaused by: ", DEBUG_ANY, 0 ); + debug_print_object( cause, DEBUG_ANY, 0); + debug_print( U"`\n", DEBUG_ANY, 0 ); + } +#endif + struct pso2 *cell = pointer_to_object( message ); + + if (get_tag_value( message)) { + result = message; + } else { + struct pso_pointer x_frame = inc_ref(make_frame( + 2, frame_pointer, message, + (nilp(location) + ? nil + : make_cons(frame_pointer, + make_cons(frame_pointer, + privileged_keyword_location, location), + nil)), + cause)); + + result = push_local(frame_pointer, make_exception(x_frame)); + } + + 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->payload.stack_frame.arg[0] is the payload, frame->payload.stack_frame.arg[1] is the cause, and frame->payload.stack_frame.arg[2] is the cons-space + * pointer to the frame in which the exception occurred. + */ +struct pso_pointer +throw_exception( struct pso_pointer location, + struct pso_pointer payload, + struct pso_pointer frame_pointer ) { + return throw_exception_with_cause( location, payload, nil, frame_pointer ); +} + diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 2ab1a54..419ffa7 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -30,7 +30,6 @@ struct function_payload { */ struct pso_pointer meta; -#ifdef MANAGED_POINTER_ONLY /** * pointer to a C function which takes a managed pointer to the same stack * frame and a managed pointer to the environment as arguments. Arguments @@ -38,16 +37,6 @@ struct function_payload { * invocation. */ struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); -#else - /** - * pointer to a C function which takes an unmanaged pointer to a stack frame, - * a managed pointer to the same stack frame, and a managed pointer to the - * environment as arguments. Arguments to the Lisp function are assumed to be - * loaded into the frame before invocation. - */ - struct pso_pointer ( *executable ) ( struct pso4 * frame, - struct pso_pointer frame_pointer ); -#endif }; #endif diff --git a/src/c/payloads/keyword.c b/src/c/payloads/keyword.c new file mode 100644 index 0000000..325f4e3 --- /dev/null +++ b/src/c/payloads/keyword.c @@ -0,0 +1,27 @@ +/** + * keyword.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/tags.h" +#include "ops/string_ops.h" + + /** + * 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( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); + } diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h index 4728066..35bbbe7 100644 --- a/src/c/payloads/keyword.h +++ b/src/c/payloads/keyword.h @@ -11,9 +11,13 @@ #define __psse_payloads_keyword_h #include "memory/pointer.h" +#include /* 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. */ + + struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif diff --git a/src/c/payloads/lambda.c b/src/c/payloads/lambda.c new file mode 100644 index 0000000..b38ad9d --- /dev/null +++ b/src/c/payloads/lambda.c @@ -0,0 +1,24 @@ +/** + * lambda.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 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" + +struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, char *tag) { + + struct pso_pointer result = allocate(frame_pointer, tag, 2); + struct pso2 *object = pointer_to_object(result); + object->payload.lambda.args = args; + object->payload.lambda.body = body; +} diff --git a/src/c/payloads/lambda.h b/src/c/payloads/lambda.h index cfa9bde..0873719 100644 --- a/src/c/payloads/lambda.h +++ b/src/c/payloads/lambda.h @@ -11,6 +11,7 @@ #define __psse_payloads_lambda_h #include "memory/pointer.h" +#include "memory/tags.h" /** * @brief Tag for lambda cell. Lambdas are the interpretable (source) versions of functions. @@ -29,5 +30,9 @@ struct lambda_payload { struct pso_pointer body; }; - +struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, char *tag); + +#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG)) #endif diff --git a/src/c/payloads/nlambda.h b/src/c/payloads/nlambda.h index d82d2e3..874bc87 100644 --- a/src/c/payloads/nlambda.h +++ b/src/c/payloads/nlambda.h @@ -11,7 +11,11 @@ #define __psse_payloads_nlambda_h #include "memory/pointer.h" +#include "memory/tags.h" +#include "payloads/lambda.h" /* nlambda shares a payload with lambda */ +#define make_nlambda(f,a,b)(make_lambda_like_thing(f, a, b, NLAMBDATAG)) + #endif diff --git a/src/c/payloads/packed_string.h b/src/c/payloads/packed_string.h new file mode 100644 index 0000000..e09d078 --- /dev/null +++ b/src/c/payloads/packed_string.h @@ -0,0 +1,33 @@ +/** + * packed_string.h + * + * Post Scarcity Soctware Environment + * + * The idea of a packed string is that it is an array of wide characters, + * packed into a paged space object. Any size of paged space object may be + * used. + * + * The initial inspiration is I wanted to use swprintf to produce formatted + * strings. Eventually, we will have a `format` function in Lisp similar to + * Common Lisp's or Clojure's, so this issue will go away. But it may still + * be useful to have an array of character as an explicit type. + * + * Copyright (c): 22 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef SRC_C_PAYLOADS_PACKED_STRING_H_ +#define SRC_C_PAYLOADS_PACKED_STRING_H_ +#include +/* + * wide characters + */ +#include + +struct packed_string_payload { + uint32_t length; /* number of characters */ + wchar_t chars[]; /* actual characters. */ +}; + + +#endif /* SRC_C_PAYLOADS_PACKED_STRING_H_ */ diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index 2206138..cc5eaef 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -20,11 +20,25 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "ops/string_ops.h" #include "payloads/cons.h" #include "ops/stack_ops.h" +/** + * 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( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, STRINGTAG ); +} + /** * @brief When an string is freed, its cdr pointer must be decremented. * diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 8c71039..7e1c75e 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -33,6 +33,9 @@ struct string_payload { struct pso_pointer cdr; }; +struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); + struct pso_pointer destroy_string( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/symbol.c b/src/c/payloads/symbol.c new file mode 100644 index 0000000..4030831 --- /dev/null +++ b/src/c/payloads/symbol.c @@ -0,0 +1,29 @@ +/** + * symbol.c + * + * Post Scarcity Soctware Environment + * + * TODO: Edit purpose. + * + * Copyright (c): 27 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "memory/pointer.h" +#include "memory/tags.h" +#include "ops/string_ops.h" + + /** + * 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( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); + } diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index cddd293..3460983 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -10,10 +10,15 @@ #ifndef __psse_payloads_symbol_h #define __psse_payloads_symbol_h +#include + #include "memory/pointer.h" /* 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. */ + + struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif From ab0ea09bd4421d95b98f51730fbf1be22cd89fa7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 3 May 2026 14:17:31 +0100 Subject: [PATCH 59/77] Still still doesn't compile. Progress is being made, but it's fair awfy slow. --- docs/State-of-play.md | 8 + src/c/io/print.c | 12 ++ src/c/io/print.h | 7 + src/c/memory/pso2.h | 23 ++- src/c/memory/tags.h | 7 +- src/c/ops/cond.c | 17 +- src/c/ops/dump.c | 124 +++++++----- src/c/ops/eval_apply.c | 404 ++++++++----------------------------- src/c/ops/inspect.c | 11 +- src/c/ops/inspect.h | 9 + src/c/ops/keys.c | 7 +- src/c/ops/mapcar.c | 10 +- src/c/ops/mapcar.h | 17 ++ src/c/ops/progn.c | 4 +- src/c/ops/repl.c | 2 +- src/c/payloads/cons.h | 13 +- src/c/payloads/exception.c | 2 +- src/c/payloads/exception.h | 4 + 18 files changed, 255 insertions(+), 426 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 86bff0f..ea48db0 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,13 @@ # State of Play +## 20260503 + +Right, so, it's a week since my last entry. The version of eval/apply copied from `0.0.6` still doesn't compile, let alone work. There are reasons. I've been ill — my brain really is fucked — and I've had outdoor work it's felt urgent to do. + +There is progress. I am cleaning up bits of old cruft as I go. But I don't think copying the old code was a good decision. Probably, if I had started a clean room implementation a week ago, I would now have a working evaluator. Certainly, I'd have a better one. + +Probably, the first thing I should do when I get the old one working is write a new, clean, one. + ## 20260427 ### eval/apply, yet again diff --git a/src/c/io/print.c b/src/c/io/print.c index 1ca8a35..c627e8d 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -268,6 +268,17 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { return result; } +struct pso_pointer c_write(struct pso_pointer frame_pointer, + struct pso_pointer object, struct pso_pointer stream, + bool escape, bool nl_before, bool nl_after) { + struct pso_pointer next_pointer = + push_local(frame_pointer, make_frame(5, frame_pointer, object, stream, escape ? t : nil, + nl_before ? t : nil, nl_after ? t : nil)); + struct pso_pointer result = push_local(frame_pointer, write(next_pointer)); + + return result; +} + /** * @brief Simple print for bootstrap layer. * @@ -307,3 +318,4 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) { return result; } + diff --git a/src/c/io/print.h b/src/c/io/print.h index 8c5fdf5..44f2bfa 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -26,4 +26,11 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ); struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, bool escape, int indent ); +struct pso_pointer c_write(struct pso_pointer frame_pointer, + struct pso_pointer object, struct pso_pointer stream, + bool escape, bool nl_before, bool nl_after); + +#define c_print(f,o,s)(c_write(f,o,s,true,true,false)) +#define c_princ(f,o,s)(c_write(f,o,s,false,true,false)) + #endif diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 2d93a50..5c459de 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -12,21 +12,29 @@ #include -#include "../payloads/psse_string.h" +#include "payloads/psse_string.h" #include "memory/header.h" #include "payloads/character.h" -#include "payloads/cons.h" +#include "payloads/float.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/symbol.h" #include "payloads/time.h" #include "payloads/vector_pointer.h" -#include "payloads/write_stream.h" + +/** + * @brief A cons cell. + * + * included here to avoid circularity. + */ +struct cons_payload { + /** Contents of the Address Register, naturally. */ + struct pso_pointer car; + /** Contents of the Decrement Register, naturally. */ + struct pso_pointer cdr; +}; /** * @brief A paged space object of size class 2, four words total, two words @@ -43,7 +51,8 @@ struct pso2 { struct free_payload free; struct function_payload function; struct integer_payload integer; - struct lambda_payload lambda; + struct lambda_payload lambda; + struct float_payload real; struct function_payload special; struct stream_payload stream; struct string_payload string; diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index faad41f..268272e 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -122,6 +122,9 @@ bool check_type( struct pso_pointer p, char *s ); #define ratiop(p) (check_tag(p,RATIOTV)) #define readp(p) (check_tag(p,READTV)) #define realp(p) (check_tag(p,REALTV)) +/** a sequence is an object having a list structure with the pointer to the + * remainder in the fourth word of each cell. I.e., cons, string, symbol, + * keyword, possibly some others */ #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)) @@ -137,9 +140,5 @@ bool check_type( struct pso_pointer p, char *s ); #define vectorp(p) (check_tag(p,VECTORTV)) #define writep(p) (check_tag(p, WRITETV)) -/** a sequence is an object having a list structure with the pointer to the - * remainder in the fourth word of each cell. I.e., cons, string, symbol, - * keyword, possibly some others */ -#define sequencep(p)(consp(p) || keywordp(p) || stringp(p) || symbolp(p)) #endif diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index f764661..c600d98 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -1,7 +1,7 @@ /** - * @brief evaluate a single cond clause; if the test part succeeds return a - * pair whose car is t and whose cdr is the value of the action part + * @brief evaluate a single cond clause; if the test part succeeds return a + * pair whose car is t and whose cdr is the value of the action part */ #include "debug.h" @@ -10,8 +10,10 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "ops/eval_apply.h" #include "ops/progn.h" #include "ops/stack_ops.h" +#include "ops/string_ops.h" #include "ops/truth.h" #include "payloads/cons.h" @@ -38,13 +40,12 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, #endif if ( consp( clause ) ) { - struct pso_pointer val = - eval_form( frame, frame_pointer, c_car( clause ), - env ); + struct pso_pointer test_frame = push_local( frame_pointer, make_frame(1, frame_pointer, c_car(clause))); + struct pso_pointer val = lisp_eval(test_frame); if ( !c_nilp( val ) ) { result = - cons( t, + make_cons( frame_pointer, t, c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); #ifdef DEBUG @@ -94,8 +95,8 @@ lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, // TODO: WHOOPS! This isn't right. If the test of a cond clause // evaluates to non-nil, but the last form of the clause evaluates // to nil, the form still succeeded and we should still exit `cond`. - // - + // + result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); if ( !c_nilp( result ) && c_truep( c_car( result ) ) ) { diff --git a/src/c/ops/dump.c b/src/c/ops/dump.c index 0e3ed86..f50cc14 100644 --- a/src/c/ops/dump.c +++ b/src/c/ops/dump.c @@ -3,6 +3,9 @@ * * Dump representations of both cons space and vector space objects. * + * TODO: This is going to be entirely rewritten and merged with `inspect.c`, + * q.v., which will be the main entrypoint to this code. What exists is + * technical debt but will work for now. * * (c) 2018 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -14,24 +17,29 @@ #include #include +#include "memory/pointer.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "io/print.h" +#include "ops/stack_ops.h" #include "payloads/lambda.h" -void dump_string_cell( URL_FILE *output, wchar_t *prefix, +void dump_string_cell( struct pso_pointer frame_pointer, struct pso_pointer output, wchar_t *prefix, struct pso_pointer pointer ) { + URL_FILE* os = pointer_to_object(output)->payload.stream.stream; struct pso2 *cell = pointer_to_object( pointer ); - if ( cell->payload.string.character == 0 ) { - url_fwprintf( output, + + if ( cell->payload.string.character == 0 ) { + url_fwprintf( os, L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", prefix, cell->payload.string.cdr.page, cell->payload.string.cdr.offset, cell->header.count ); } else { - url_fwprintf( output, + url_fwprintf( os, L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", prefix, ( wint_t ) cell->payload.string.character, @@ -39,102 +47,108 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix, cell->payload.string.hash, cell->payload.string.cdr.page, cell->payload.string.cdr.offset, cell->header.count ); - url_fwprintf( output, L"\t\t value: " ); - print( output, pointer ); - url_fwprintf( output, L"\n" ); + url_fwprintf( os, L"\t\t value: " ); + c_print( frame_pointer, pointer, output ); + url_fwprintf( os, L"\n" ); } } /** * dump the object at this pso_pointer to this output stream. */ -void dump_object( URL_FILE *output, struct pso_pointer pointer ) { - struct pso2 *cell = pointer_to_object( pointer ); - url_fwprintf( output, L"\t%3.3s (%d) at page %d, offset %d count %u\n", +void dump_object( struct pso_pointer frame_pointer, struct pso_pointer output, struct pso_pointer pointer ) { + URL_FILE* os = pointer_to_object(output)->payload.stream.stream; + + struct pso2 *cell = pointer_to_object( pointer ); + url_fwprintf( os, L"\t%3.3s (%d) at page %d, offset %d count %u\n", cell->header.tag.bytes.mnemonic[0], get_tag_value( pointer ), pointer.page, pointer.offset, cell->header.count ); switch ( get_tag_value( pointer ) ) { case CONSTV: - url_fwprintf( output, + url_fwprintf( os, L"\t\tCons cell: car at page %d offset %d, cdr at page %d " L"offset %d, count %u :", cell->payload.cons.car.page, cell->payload.cons.car.offset, cell->payload.cons.cdr.page, cell->payload.cons.cdr.offset ); - print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); + c_print( frame_pointer, pointer, output ); + url_fputws( L"\n", os ); break; + // case EXCEPTIONTV: + // url_fwprintf( os, L"\t\tException cell: " ); + // dump_stack_trace( output, pointer ); + // break; case FREETV: - url_fwprintf( output, + url_fwprintf( os, L"\t\tFree cell: next at page %d offset %d\n", cell->payload.cons.cdr.page, cell->payload.cons.cdr.offset ); break; - case HASHTV: - dump_map( output, pointer ); - break; + // case HASHTV: + // dump_map( output, pointer ); + // break; case INTEGERTV: - url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + url_fwprintf( os, L"\t\tInteger cell: value %ld, count %u\n", cell->payload.integer.value, cell->header.count ); break; case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); + dump_string_cell( frame_pointer, output, L"Keyword", pointer ); break; case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell->payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell->payload.lambda.body ); - url_fputws( L"\n", output ); + url_fwprintf( os, L"\t\t\u03bb cell;\n\t\t args: " ); + c_print( frame_pointer, cell->payload.lambda.args, output ); + url_fwprintf( os, L";\n\t\t\tbody: " ); + c_print( frame_pointer, cell->payload.lambda.body, output ); + url_fputws( L"\n", os ); break; case NILTV: break; case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell->payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell->payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer_to_object( cell->payload.ratio. - dividend ).payload.integer.value, - pointer_to_object( cell->payload.ratio. - divisor ).payload.integer.value, - cell->header.count ); + url_fwprintf( os, L"\t\tn\u03bb cell; \n\t\targs: " ); + c_print( frame_pointer, cell->payload.lambda.args, output ); + url_fwprintf( os, L";\n\t\t\tbody: " ); + c_print( frame_pointer, cell->payload.lambda.body, output ); + url_fputws( L"\n", os ); break; + // case RATIOTV: + // url_fwprintf( os, + // L"\t\tRational cell: value %ld/%ld, count %u\n", + // pointer_to_object( cell->payload.ratio. + // dividend ).payload.integer.value, + // pointer_to_object( cell->payload.ratio. + // divisor ).payload.integer.value, + // cell->header.count ); + // break; case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell->payload.stream.meta ); - url_fputws( L"\n", output ); + url_fputws( L"\t\tInput stream; metadata: ", os ); + c_print( frame_pointer, cell->payload.stream.meta, output ); + url_fputws( L"\n", os ); break; case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + url_fwprintf( os, L"\t\tReal cell: value %Lf, count %u\n", cell->payload.real.value, cell->header.count ); break; - case STACKTV: - dump_frame( output, pointer ); - break; + // case STACKTV: + // dump_frame( frame_pointer, output, pointer ); + // break; case STRINGTV: - dump_string_cell( output, L"String", pointer ); + dump_string_cell( frame_pointer, output, L"String", pointer ); break; case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); + dump_string_cell( frame_pointer, output, L"Symbol", pointer ); break; case TRUETV: break; case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell->payload.stream.meta ); - url_fputws( L"\n", output ); - break; + url_fputws( L"\t\tOutput stream; metadata: ", os ); + c_print( frame_pointer, cell->payload.stream.meta, output ); + url_fputws( L"\n", os ); + break; + default: + url_fwprintf(os, L"TODO: Cannot yet dump object of type %3.3s\n", + cell->header.tag.bytes.mnemonic[0]); + break; } } diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index e6bff33..4b18e8c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -32,6 +32,7 @@ #include "ops/assoc.h" #include "ops/bind.h" #include "ops/eval_apply.h" +#include "ops/progn.h" #include "ops/reverse.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" @@ -43,11 +44,12 @@ #include "payloads/lambda.h" #include "payloads/nlambda.h" #include "payloads/stack.h" +#include "payloads/symbol.h" ///** // * @brief Apply a function to arguments in an environment. // * -// * * (apply fn args) +// * * (apply fn args) // */ //struct pso_pointer apply( struct pso_pointer frame_pointer ) { // @@ -58,7 +60,7 @@ ///** // * @brief Evaluate a form, in an environment // * -// * * (eval form) +// * * (eval form) // */ //struct pso_pointer eval( struct pso_pointer frame_pointer ) { // struct pso4 *frame = pointer_to_pso4( frame_pointer ); @@ -164,7 +166,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) { #ifdef DEBUG debug_print( L"eval_form: ", DEBUG_EVAL, 0 ); debug_print_object( form, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); #endif struct pso_pointer result = form; @@ -214,7 +216,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) { debug_print_object( form, DEBUG_EVAL, 0 ); debug_print( L" returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL ); return result; } @@ -264,16 +266,14 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer, struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer body_frame = - inc_ref( make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + push_local( frame_pointer, make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); - result = push_local( frame_pointer, progn( body_frame ) ); - - dec_ref( body_frame ); + result = push_local( frame_pointer, lisp_progn( body_frame ) ); if ( exceptionp( result ) ) { // TODO: need to put the exception into the environment! struct pso_pointer catch_frame = - inc_ref( make_frame_with_env( 1, frame_pointer, + push_local( frame_pointer, make_frame_with_env( 1, frame_pointer, make_cons( frame_pointer, make_cons( frame_pointer, c_string_to_lisp_symbol @@ -284,9 +284,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer, ( frame_pointer ) ), frame->payload.stack_frame. arg[1] ) ); - result = push_local( progn( catch_frame ) ); - - dec_ref( catch_frame ); + result = push_local( frame_pointer, lisp_progn( catch_frame ) ); } return result; @@ -348,7 +346,7 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_lambda( struct pso_pointer frame_pointer ) { struct pso4* frame = pointer_to_pso4(frame_pointer); - return make_lambda( frame_pointer, frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); + return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); } /** @@ -366,7 +364,7 @@ struct pso_pointer lisp_nlambda( struct pso_pointer frame_pointer, struct pso_pointer env ) { struct pso4* frame = pointer_to_pso4(frame_pointer); - return make_nlambda( frame->payload.stack_frame.arg[0], compose_body( frame_pointer ) ); + return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); } @@ -379,7 +377,7 @@ eval_lambda( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4(frame_pointer); struct pso2 *lambda = pointer_to_object(fetch_arg(frame, 0)); struct pso_pointer args = fetch_arg( frame, 1); - + struct pso_pointer new_env = fetch_env( frame_pointer ); struct pso_pointer names = lambda->payload.lambda.args; struct pso_pointer body = lambda->payload.lambda.body; @@ -410,9 +408,9 @@ eval_lambda( struct pso_pointer frame_pointer ) { * then bind a list of the values of args to that symbol. */ /* \todo eval all the things in frame->payload.stack_frame.more */ struct pso_pointer more_frame = inc_ref( - make_frame(1, frame_pointer, + make_frame(1, frame_pointer, frame->payload.stack_frame.more)); - + struct pso_pointer vals = eval_forms( more_frame ); @@ -464,7 +462,7 @@ eval_lambda( struct pso_pointer frame_pointer ) { /** * 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. + * the name associated with this fn_pointer, if any. */ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, struct pso_pointer @@ -520,7 +518,7 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, struct pso_pointer make_fn_frame(struct pso_pointer previous, struct pso_pointer fn_pointer, struct pso_pointer arg_list) { - + struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso_pointer next_pointer = @@ -528,7 +526,7 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, struct pso4 *next_frame = pointer_to_pso4(next_pointer); new_frame->payload.stack_frame.function = fn_pointer; - + int args = 0; struct pso_pointer cursor; for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { @@ -557,7 +555,6 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, return new_pointer; } - /** * @brief Create a new stack frame in which to evaluate the special form * indicated by this `fn_pointer`, with unevaluated args from this `arg_list`. @@ -572,12 +569,12 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, struct pso_pointer make_special_frame(struct pso_pointer previous, struct pso_pointer fn_pointer, struct pso_pointer arg_list) { - + struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); new_frame->payload.stack_frame.function = fn_pointer; - + int args = 0; struct pso_pointer cursor; for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { @@ -585,7 +582,7 @@ struct pso_pointer make_special_frame(struct pso_pointer previous, new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) ); } if (consp(cursor)) { - + new_frame->payload.stack_frame.more = inc_ref( cursor); } @@ -594,7 +591,6 @@ struct pso_pointer make_special_frame(struct pso_pointer previous, return new_pointer; } - /** * Internal guts of apply. * @param frame the stack frame, expected to have only one argument, a list @@ -611,7 +607,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { struct pso_pointer fn_pointer = push_local(frame_pointer, eval_form( fn_frame)); dec_ref( fn_frame); - + if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { @@ -675,7 +671,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { 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 @@ -736,7 +732,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { c_string_to_lisp_string( frame_pointer, buffer ); free( buffer ); result = - make_exception( frame_pointer, c_string_to_lisp_symbol( frame_pointer, U"apply" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, U"apply" ), message, frame_pointer ); } } @@ -809,7 +805,7 @@ lisp_eval( struct pso_pointer frame_pointer ) { /* * \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; + * 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: @@ -823,10 +819,6 @@ lisp_eval( struct pso_pointer frame_pointer ) { return result; } - - - - /** * Special form; * returns its argument (strictly first argument - only one is expected but @@ -845,8 +837,26 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, return frame->payload.stack_frame.arg[0]; } +/** + * Get the Lisp type of the single argument. + * @param pointer a pointer to the object whose type is requested. + * @return As a Lisp string, the tag of the object which is at that pointer. + */ +struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer pointer ) { + /* Strings read by `read` have the null character termination. This means + * that for the same printable string, the hashcode is different from + * strings made with NIL termination. The question is which should be + * fixed, and actually that's probably strings read by `read`. However, + * for now, it was easier to add a null character here. */ + struct pso_pointer result = make_symbol( frame_pointer, ( wchar_t ) 0, nil ); + struct pso2 *cell = pointer_to_object( pointer ); + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_symbol( frame_pointer, ( wchar_t ) cell->header.tag.bytes.mnemonic[i], result ); + } + return result; +} /** @@ -854,153 +864,14 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, * * * (type expression) * - * @param frame my stack frame. - * @param frame_pointer a pointer to my pso4. - * @param env my environment (ignored). - * @return As a Lisp string, the tag of `expression`. + * @return As a Lisp symbol, the tag of `expression`. */ struct pso_pointer -lisp_type( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { - return c_type( frame->payload.stack_frame.arg[0] ); +lisp_type( struct pso_pointer frame_pointer ) { + return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) ); } -/** - * 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 pso4. - * @param env the environment in which epressions will be evaluated. - * @return the value of the last expression read. - */ -struct pso_pointer lisp_repl( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer expr = nil; - -#ifdef DEBUG - debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL, 0 ); - debug_print_object( env, DEBUG_REPL ); - debug_print( L"`\n", DEBUG_REPL, 0 ); -#endif - - struct pso_pointer input = get_default_stream( t, env ); - struct pso_pointer output = get_default_stream( false, env ); - struct pso_pointer old_oblist = oblist; - struct pso_pointer new_env = env; - - if ( tp( frame->payload.stack_frame.arg[0] ) ) { - new_env = - set( prompt_name, frame->payload.stack_frame.arg[0], new_env ); - } - if ( readp( frame->payload.stack_frame.arg[1] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*in*" ), - frame->payload.stack_frame.arg[1], new_env ); - input = frame->payload.stack_frame.arg[1]; - } - if ( writep( frame->payload.stack_frame.arg[2] ) ) { - new_env = - set( c_string_to_lisp_symbol( L"*out*" ), - frame->payload.stack_frame.arg[2], new_env ); - output = frame->payload.stack_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 ) : - pointer_to_object( 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( pointer_to_object( 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 pso_pointer cursor = oblist; - - while ( !c_nilp( cursor ) && !eq( cursor, old_oblist ) ) { - struct pso_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 = 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 pso_pointer prompt = c_assoc( prompt_name, new_env ); - if ( !c_nilp( prompt ) ) { - print( os, prompt ); - } - - expr = lisp_read( pointer_to_pso4( frame_pointer ), frame_pointer, - new_env ); - - if ( exceptionp( expr ) - && url_feof( pointer_to_object( 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 ( c_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. @@ -1013,14 +884,13 @@ struct pso_pointer lisp_repl( struct pso4 *frame, * @return the source of the `object` indicated, if it is a function, a lambda, * an nlambda, or a spcial form; else `nil`. */ -struct pso_pointer lisp_source( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { struct pso_pointer result = nil; - struct pso2 **cell = - pointer_to_object( frame->payload.stack_frame.arg[0] ); - struct pso_pointer source_key = c_string_to_lisp_keyword( L"source" ); - switch ( cell->header.tag.bytes.value & 0xfffff ) { + struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso2 *cell = + pointer_to_object( fetch_arg( frame, 0) ); + struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" ); + switch ( get_tag_value(fetch_arg( frame, 0)) ) { case FUNCTIONTV: result = c_assoc( source_key, cell->payload.function.meta ); break; @@ -1028,151 +898,38 @@ struct pso_pointer lisp_source( struct pso4 *frame, result = c_assoc( source_key, cell->payload.special.meta ); break; case LAMBDATV: - result = cons( c_string_to_lisp_symbol( L"lambda" ), - cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); + result = make_cons( frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"λ" ), + make_cons( frame_pointer, + cell->payload.lambda.args, + cell->payload.lambda.body ) ); break; case NLAMBDATV: - result = cons( c_string_to_lisp_symbol( L"nlambda" ), - cons( cell->payload.lambda.args, - cell->payload.lambda.body ) ); + result = make_cons( frame_pointer, c_string_to_lisp_symbol( frame_pointer, L"nλ" ), + make_cons( frame_pointer, 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 pso_pointer c_append( struct pso_pointer l1, struct pso_pointer l2 ) { - switch ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff ) { - case CONSTV: - if ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == - pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { - if ( c_nilp( c_cdr( l1 ) ) ) { - return cons( c_car( l1 ), l2 ); - } else { - return 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 ( pointer_to_object( l1 ).header.tag.bytes.value & 0xfffff == - pointer_to_object( l2 ).header.tag.bytes.value & 0xfffff ) { - if ( c_nilp( c_cdr( l1 ) ) ) { - return - make_string_like_thing( ( pointer_to_object - ( l1 ).payload.string. - character ), l2, - pointer_to_object( l1 ).header. - tag.bytes.value & 0xfffff ); - } else { - return - make_string_like_thing( ( pointer_to_object - ( l1 ).payload.string. - character ), - c_append( c_cdr( l1 ), l2 ), - pointer_to_object( l1 ).header. - tag.bytes.value & 0xfffff ); - } - } 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 pso_pointer lisp_append( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = - fetch_arg( frame, ( frame->payload.stack_frame.args - 1 ) ); - - for ( int a = frame->payload.stack_frame.args - 2; a >= 0; a-- ) { - result = c_append( fetch_arg( frame, a ), result ); - } - - return result; -} - -struct pso_pointer lisp_mapcar( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; - debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); - debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); - int i = 0; - - for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; tp( c ); - c = c_cdr( c ) ) { - struct pso_pointer expr = - cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); - - debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); - debug_print_object( expr, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); - - struct pso_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 = cons( r, result ); - } - debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); - debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); - - dec_ref( expr ); - } - - result = consp( result ) ? c_reverse( result ) : result; - - debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 ); - debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + push_local( frame_pointer, result ); 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. + * + * (list args...) + * * @return struct pso_pointer a pointer to the result */ -struct pso_pointer lisp_list( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { + struct pso4* frame = pointer_to_pso4( frame_pointer); struct pso_pointer result = frame->payload.stack_frame.more; for ( int a = c_nilp( result ) ? frame->payload.stack_frame.args - 1 : args_in_frame - 1; a >= 0; a-- ) { - result = cons( fetch_arg( frame, a ), result ); + result = make_cons( frame_pointer, fetch_arg( frame, a ), result ); } return result; @@ -1191,7 +948,7 @@ struct pso_pointer lisp_let( struct pso4 *frame, struct pso_pointer bindings = env; struct pso_pointer result = nil; - for ( struct pso_pointer cursor = frame->payload.stack_frame.arg[0]; + for ( struct pso_pointer cursor = fetch_arg( frame, 0); tp( cursor ); cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); struct pso_pointer symbol = c_car( pair ); @@ -1216,6 +973,17 @@ struct pso_pointer lisp_let( struct pso4 *frame, debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); + struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, env); + progn_frame = pointer_to_pso4(progn_pointer); + int a = 1; + for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + progn_frame->payload.stack_frame.args ++; + } + if ( a < frame->payload.stack_frame.args) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + } + /* i.e., no exception yet */ for ( int form = 1; !exceptionp( result ) && form < frame->payload.stack_frame.args; @@ -1225,19 +993,13 @@ struct pso_pointer lisp_let( struct pso4 *frame, bindings ); } - /* release the local bindings as they go out of scope! **BUT** - * bindings were consed onto the front of env, so caution... */ - // for (struct pso_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. @@ -1246,7 +1008,7 @@ struct pso_pointer lisp_let( struct pso4 *frame, struct pso_pointer lisp_and( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer env ) { - bool accumulator = t; + bool accumulator = true; struct pso_pointer result = frame->payload.stack_frame.more; for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; @@ -1259,7 +1021,7 @@ struct pso_pointer lisp_and( struct pso4 *frame, /** * @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. @@ -1281,7 +1043,7 @@ struct pso_pointer lisp_or( struct pso4 *frame, /** * @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. diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c index 6f9b856..ee64388 100644 --- a/src/c/ops/inspect.c +++ b/src/c/ops/inspect.c @@ -17,6 +17,7 @@ #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" +#include "ops/inspect.h" #include "ops/stack_ops.h" /** @@ -48,15 +49,7 @@ struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { : get_default_stream( false, fetch_env( frame_pointer ) ); URL_FILE *output; - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO, 0 ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer_to_object( out_stream )->payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } - - dump_object( output, frame->payload.stack_frame.arg[0] ); + dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) ); debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 ); diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h index 7e15d15..6803e09 100644 --- a/src/c/ops/inspect.h +++ b/src/c/ops/inspect.h @@ -12,5 +12,14 @@ #ifndef psse_ops_inspect #define psse_ops_inspect +#include "memory/pointer.h" + +/** + * Legacy technical debt to be entirely rewritten + */ +void dump_object(struct pso_pointer frame_pointer, + struct pso_pointer output, struct pso_pointer pointer ); + + struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ); #endif \ No newline at end of file diff --git a/src/c/ops/keys.c b/src/c/ops/keys.c index 2ec8ac9..5eaffdd 100644 --- a/src/c/ops/keys.c +++ b/src/c/ops/keys.c @@ -20,14 +20,15 @@ * @brief an implementation of `keys` convenient for calling from C * * @param */ -struct pso_pointer c_keys( struct pso_pointer store ) { +struct pso_pointer c_keys(struct pso_pointer frame_pointer, + struct pso_pointer store ) { struct pso_pointer result = nil; if ( consp( store ) ) { for ( struct pso_pointer pair = c_car( store ); !c_nilp( pair ); pair = c_car( store ) ) { if ( consp( pair ) ) { - result = cons( c_car( pair ), result ); + result = make_cons( frame_pointer, c_car( pair ), result ); // } else if ( hashtabp( pair ) ) { // result = c_append( hashmap_keys( pair ), result ); } @@ -44,6 +45,6 @@ struct pso_pointer c_keys( struct pso_pointer store ) { struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) { - return c_keys( pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); + return c_keys( frame_pointer, pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); } diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index 444cfc8..a929d01 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -14,15 +14,15 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/reverse.h" #include "ops/truth.h" #include "payloads/cons.h" -struct pso_pointer lisp_mapcar( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; +struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4* frame = pointer_to_pso4(frame_pointer); debug_print( U"Mapcar: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); int i = 0; @@ -34,7 +34,7 @@ struct pso_pointer lisp_mapcar( struct pso4 *frame, debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL, 0 ); + debug_println( DEBUG_EVAL); struct pso_pointer r = eval_form( frame, frame_pointer, expr, env ); diff --git a/src/c/ops/mapcar.h b/src/c/ops/mapcar.h index e69de29..db0a5dd 100644 --- a/src/c/ops/mapcar.h +++ b/src/c/ops/mapcar.h @@ -0,0 +1,17 @@ +/** + * ops/mapcar.h + * + * Post Scarcity Software Environment: mapcar. + * + * map a function across a sequence of forms. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef psse_ops_mapcar +#define psse_ops_mapcar + + + +#endif \ No newline at end of file diff --git a/src/c/ops/progn.c b/src/c/ops/progn.c index f5ac897..ac3f722 100644 --- a/src/c/ops/progn.c +++ b/src/c/ops/progn.c @@ -76,8 +76,8 @@ lisp_progn( struct pso_pointer frame_pointer) { } if (consp(frame->payload.stack_frame.more)) { - result = - c_progn(frame, frame_pointer, frame->payload.stack_frame.more, env); + result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more, + fetch_env(frame_pointer)); } return result; diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 4e8e5f1..cc150bd 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -93,7 +93,7 @@ void repl( struct pso_pointer frame_pointer ) { dec_ref( next ); next = inc_ref( make_frame( 1, base_of_stack, read_value ) ); - struct pso_pointer eval_value = inc_ref( eval( next ) ); + struct pso_pointer eval_value = inc_ref( lisp_eval( next ) ); dec_ref( next ); dec_ref( read_value ); diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index bb10292..131eb88 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -12,20 +12,13 @@ #include #include "memory/pointer.h" +#include "memory/pso2.h" #include "memory/pso4.h" #define CONS_SIZE_CLASS 2 -/** - * @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; -}; +/* NOTE THAT the definition of a cons payload has to be in memory/pso2.h to + * avoid circularity. */ struct pso_pointer car( struct pso_pointer frame_pointer ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 2bcb802..7f40fc5 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -132,7 +132,7 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location, } else { struct pso_pointer x_frame = inc_ref(make_frame( 2, frame_pointer, message, - (nilp(location) + (c_nilp(location) ? nil : make_cons(frame_pointer, make_cons(frame_pointer, diff --git a/src/c/payloads/exception.h b/src/c/payloads/exception.h index 4bb088e..60f0b31 100644 --- a/src/c/payloads/exception.h +++ b/src/c/payloads/exception.h @@ -30,4 +30,8 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ); struct pso_pointer destroy_exception( struct pso_pointer fp ); +struct pso_pointer +throw_exception( struct pso_pointer location, + struct pso_pointer payload, + struct pso_pointer frame_pointer ); #endif From 92490ebd5fb5f9bffd7f1634eb34ce54f67c528c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 3 May 2026 17:26:53 +0100 Subject: [PATCH 60/77] Still grinding incrementally forward, through barbed wire entanglements. Morale fading. --- src/c/ops/eval_apply.c | 73 ++++++++++++++++++++---------------------- src/c/ops/mapcar.c | 2 +- src/c/ops/reverse.c | 6 +++- src/c/ops/reverse.h | 4 ++- src/c/ops/string_ops.c | 4 ++- src/c/ops/truth.h | 2 ++ src/c/payloads/cons.h | 3 +- src/c/payloads/stack.c | 54 ++++++++++++++++++++++++++++--- src/c/payloads/stack.h | 4 ++- 9 files changed, 104 insertions(+), 48 deletions(-) diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 4b18e8c..ad8f3e6 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -246,7 +246,7 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { dec_ref( next_pointer ); } - return c_reverse( result ); + return c_reverse( frame_pointer, result ); } /** @@ -546,11 +546,10 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, args++; } - new_frame->payload.stack_frame.more = inc_ref( c_reverse( more)); + new_frame->payload.stack_frame.more = push_local( previous, c_reverse( previous, more)); } new_frame->payload.stack_frame.args = args; - dec_ref(next_pointer); return new_pointer; } @@ -905,9 +904,11 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { cell->payload.lambda.body ) ); break; case NLAMBDATV: - result = make_cons( frame_pointer, c_string_to_lisp_symbol( frame_pointer, L"nλ" ), - make_cons( frame_pointer, cell->payload.lambda.args, - cell->payload.lambda.body ) ) ); + result = make_cons( frame_pointer, + c_string_to_lisp_symbol( frame_pointer, L"nλ" ), + make_cons( frame_pointer, + cell->payload.lambda.args, + cell->payload.lambda.body ) ); break; } push_local( frame_pointer, result ); @@ -942,57 +943,53 @@ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { * these bindings are bound. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ -struct pso_pointer lisp_let( struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer bindings = env; +struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer bindings = fetch_env(frame_pointer); struct pso_pointer result = nil; for ( struct pso_pointer cursor = fetch_arg( frame, 0); - tp( cursor ); cursor = c_cdr( cursor ) ) { + c_truep( cursor ); cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); struct pso_pointer symbol = c_car( pair ); + struct pso_pointer next_pointer = push_local( frame_pointer, make_frame_with_env( 0, frame_pointer, bindings)); + if ( symbolp( symbol ) ) { + add_arg(next_pointer, c_cdr(pair)); struct pso_pointer val = - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ); + eval_form( next_pointer ); - debug_print_binding( symbol, val, false, DEBUG_BIND ); + // debug_print_binding( symbol, val, false, DEBUG_BIND ); - bindings = cons( cons( symbol, val ), bindings ); + bindings = make_cons( frame_pointer, make_cons( frame_pointer, 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" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"let" ), + c_string_to_lisp_string( frame_pointer, L"Let: cannot bind, not a symbol" ), frame_pointer ); break; } } - debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); + if (!exceptionp(result)) { + debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); - struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, env); - progn_frame = pointer_to_pso4(progn_pointer); - int a = 1; - for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - progn_frame->payload.stack_frame.args ++; - } - if ( a < frame->payload.stack_frame.args) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - } + struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, bindings); + struct pso4* progn_frame = pointer_to_pso4(progn_pointer); - /* i.e., no exception yet */ - for ( int form = 1; - !exceptionp( result ) && form < frame->payload.stack_frame.args; - form++ ) { - result = - eval_form( frame, frame_pointer, fetch_arg( frame, form ), - bindings ); - } + int a = 1; + for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + progn_frame->payload.stack_frame.args ++; + } + if ( a < frame->payload.stack_frame.args) { + progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); + progn_frame->payload.stack_frame.more = c_cdr( frame->payload.stack_frame.more); + } + result = lisp_progn(progn_pointer); + } return result; } @@ -1011,7 +1008,7 @@ struct pso_pointer lisp_and( struct pso4 *frame, bool accumulator = true; struct pso_pointer result = frame->payload.stack_frame.more; - for ( int a = 0; accumulator == t && a < frame->payload.stack_frame.args; + for ( int a = 0; accumulator == true && a < frame->payload.stack_frame.args; a++ ) { accumulator = truthy( fetch_arg( frame, a ) ); } diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index a929d01..57571a0 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -30,7 +30,7 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); c = c_cdr( c ) ) { struct pso_pointer expr = - cons( frame->payload.stack_frame.arg[0], cons( c_car( c ), nil ) ); + cons( frame->payload.stack_frame.arg[0], make_cons( frame_pointer, c_car( c ), nil ) ); debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 720d348..296aaf3 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -27,7 +27,11 @@ #include "ops/string_ops.h" #include "ops/truth.h" - +/** + * @brief reverse a sequence + * + * (reverse sequence) + */ struct pso_pointer reverse( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer sequence = diff --git a/src/c/ops/reverse.h b/src/c/ops/reverse.h index 5519523..01b5776 100644 --- a/src/c/ops/reverse.h +++ b/src/c/ops/reverse.h @@ -16,6 +16,8 @@ #include "memory/pointer.h" -struct pso_pointer c_reverse( struct pso_pointer sequence ); +struct pso_pointer reverse( struct pso_pointer frame_pointer ); +struct pso_pointer c_reverse( struct pso_pointer frame_pointer, + struct pso_pointer sequence ); #endif diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 47e30a3..54dbc15 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -25,7 +25,9 @@ #include "ops/truth.h" +#include "payloads/cons.h" #include "payloads/exception.h" +#include "payloads/keyword.h" #include "payloads/symbol.h" @@ -67,7 +69,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * 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 + * NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of * char32_t in larger pso classes, so this function may be only for strings * (and thus simpler). */ diff --git a/src/c/ops/truth.h b/src/c/ops/truth.h index e775ff2..fb73682 100644 --- a/src/c/ops/truth.h +++ b/src/c/ops/truth.h @@ -28,4 +28,6 @@ struct pso_pointer or( struct pso_pointer frame_pointer ); bool c_nilp( struct pso_pointer p ); bool c_truep( struct pso_pointer p ); +#define truthy(p)(!c_nilp(p)) + #endif diff --git a/src/c/payloads/cons.h b/src/c/payloads/cons.h index 131eb88..7f56384 100644 --- a/src/c/payloads/cons.h +++ b/src/c/payloads/cons.h @@ -11,6 +11,7 @@ #define __psse_payloads_cons_h #include +#include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" @@ -32,7 +33,7 @@ struct pso_pointer make_cons( struct pso_pointer frame_pointer, struct pso_pointer car, struct pso_pointer cdr ); /** - * macro short-cuts for make_cons. + * macro short-cuts for make_cons. */ // #define make_cons(frame_pointer,car,cdr) (cons(make_frame(2, frame_pointer, car, cdr))) diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index b0b2730..066642d 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -24,12 +24,46 @@ #include "ops/reverse.h" #include "ops/list_ops.h" +#include "ops/stack_ops.h" + +/** + * @brief Add an argument to this (already initialised) stack frame, updating + * the args count. + * + * TODO: unit test this to death and back! + * + * @param frame_pointer a pointer to the frame to be modified. + * @param arg_pointer the pointer to the arg to be added. + * + * @return `nil` on success; potentially an exception on failure. + */ +struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer result = nil; + + if (frame->payload.stack_frame.args < args_in_frame) { + frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = push_local(frame_pointer, arg_pointer); + } else { + struct pso_pointer new_more = c_reverse( frame_pointer, + make_cons( frame_pointer, + arg_pointer, + c_reverse( frame_pointer, frame->payload.stack_frame.more))); + if (exceptionp(new_more)) { + result = new_more; + } else { + frame->payload.stack_frame.more = + push_local( frame_pointer, new_more); + } + } + + return result; +} /** * @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. - * + * * @param arg_count the count of arguments to the Lisp function. * @param previous the parent stack frame. * @param ... the arguments to the Lisp function, all of which must be of type @@ -42,6 +76,9 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_list args; va_start( args, previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -85,7 +122,7 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, more_args ); } - new_frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( previous, more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { new_frame->payload.stack_frame.arg[cursor] = nil; @@ -103,7 +140,10 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, * @brief variant of make_frame with an explicit replacement environment, to * be called by functions like `binding` which add bindings to their upstack * environment. - * + * + * TODO: someone who really understood how C varargs functions work could save + * a lot of potentially error prone code by having this call `make_frame`, q.v. + * * @param arg_count the count of arguments to the Lisp function. * @param previous the parent stack frame. * @param env the modified environment @@ -119,6 +159,9 @@ struct pso_pointer make_frame_with_env( int arg_count, va_start( args, env ); struct pso4 *prev_frame = pointer_to_pso4( previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); @@ -159,7 +202,7 @@ struct pso_pointer make_frame_with_env( int arg_count, more_args ); } - new_frame->payload.stack_frame.more = c_reverse( more_args ); + new_frame->payload.stack_frame.more = c_reverse( previous, more_args ); } else { for ( ; cursor < args_in_frame; cursor++ ) { new_frame->payload.stack_frame.arg[cursor] = nil; @@ -189,6 +232,9 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer argvalues, struct pso_pointer env ) { struct pso4 *prev_frame = pointer_to_pso4( previous ); + /* NOTE! It is really important not to `push_local` the new_pointer here, + * since that would stop stack frames and all the temporary objects they + * curate ever being garbage collected! */ struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso_pointer arg_length = diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 5fb9267..d89d705 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -20,7 +20,7 @@ #define args_in_frame 8 /** - * A stack frame. + * A stack frame. */ struct stack_frame_payload { /** the previous frame. */ @@ -60,4 +60,6 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); +struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer); + #endif From 8c5dccb5c8ccc6372f1b29675a8ce80d91b7914b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 10:34:07 +0100 Subject: [PATCH 61/77] My monster, she builds! --- ...st of spacecraft in the Culture series.csv | 267 ++++++++++++++++++ src/c/environment/privileged_keywords.h | 4 +- src/c/io/read.c | 2 +- src/c/ops/list_ops.h | 2 +- src/c/ops/mapcar.c | 19 +- src/c/payloads/stack.c | 2 +- 6 files changed, 283 insertions(+), 13 deletions(-) create mode 100644 docs/List of spacecraft in the Culture series.csv diff --git a/docs/List of spacecraft in the Culture series.csv b/docs/List of spacecraft in the Culture series.csv new file mode 100644 index 0000000..792345b --- /dev/null +++ b/docs/List of spacecraft in the Culture series.csv @@ -0,0 +1,267 @@ +Culture,GSV,Bora Horza Gobuchul,"Ocean, later Range","The name chosen by the Mind at the centre of the events of the book, after its rescue and emplacement in a GSV." +Culture,GSV,Determinist,System,"The largest GSV class built by the Culture, composed of multiple separate hulls. Population 6 billion." +Culture,GSV,Eschatologist (temporary name),Ocean,"A comparatively small GSV class, designed for combat and military manufacturing." +Culture,GSV,Irregular Apocalypse,, +Culture,GSV,No More Mr Nice Guy,, +Culture,LSV,Profit Margin,, +Culture,GCU,Nervous Energy,Mountain, +Culture,GCU,Prosthetic Conscience,, +Culture,ROU,Revisionist,Killer, +Culture,ROU,Trade Surplus,Killer, +Culture Ulterior,GSV,The Ends Of Invention,,"Officially discharged from Culture service, with its Mind/s removed, and employed as a neutral vessel to evacuate Vavatch Orbital. " +Idiran,Light Cruiser,The Hand of God 137,, +Non-aligned (Ex-Hronish),Armoured assault,"Clear Air Turbulence or ""CAT"" for short",,"A pirate ship, and one of the main settings of the book. Named by the author after the rock album Clear Air Turbulence by the Ian Gillan Band, the cover of which shows a yellow-striped spacecraft painted by the sci-fi artist Chris Foss.[3] The Clear Air Turbulence in the book is also described as having yellow stripes on its hull. " +Non-aligned,,Control Surface,,"Third ship of Ghalssel's Raiders, commanded by Jandraligeli, a former member of Kraiklyn's Free Company. This ship is mentioned only in the book's appendices." +Culture,GSV,Cargo Cult,, +Culture,GSV,Little Rascal,Plate,"Focused on 'throughput' (ship construction and crewing), rather than accommodation. Population 250 million. Plate class hull dimensions 53 km × 22 km × 4 km (32.9 mi × 13.7 mi × 2.5 mi)." +,,,, +,,,,"The Deep Submersible Support Vessel (DSSV) Pressure Drop, the expedition support ship of the Five Deeps Expedition led by Victor Vescovo, has a utility boat on it called the Little Rascal. Similar to its namesake, the small vessel is designed to provide frequent crew-support missions and provisioning runs for the main ship. " +Culture,GSV,So Much For Subtlety,Range, +Culture,GSV,Unfortunate Conflict Of Evidence,, +Culture,GSV,Youthful Indiscretion,, +Culture,GCU,Flexible Demeanour,, +Culture,GCU,Just Read The Instructions,,Elon Musk named three SpaceX autonomous spaceport drone ships after these ships. +Culture,GCU,Of Course I Still Love You,, +Culture,(D)ROU,Zealot,, +Culture,(D)GOU,Limiting Factor,Murderer,"Jernau Morat Gurgeh's ship to Empire of Azad. Nominally demilitarised, but actually retains part of its main armament. Victor Vescovo, an American deep-sea explorer, named the deep diving submersible DSV Limiting Factor after this ship.[5] " +Culture,LOU,Gunboat Diplomat,,An allusion to the concept of gunboat diplomacy. +Culture,Superlifter,Kiss My Ass,River, +Culture,Superlifter,Prime Mover,,"An allusion to the Aristotelian philosophical concept of the prime mover, in humorous reference to the function of a Superlifter. " +Culture,Clipper,Screw Loose,, +Azadian,Battlecruiser,Invincible,,Flagship of the Empire of Azad. +Culture,GSV,Bad For Business,, +Culture,GCU,Ablation*,, +Culture,GCU,Arbitrary,Escarpment,"The only ship actually appearing in the book, and one of its main settings." +,,,(middle series), +Culture,GCU,Arrested Development*,, +Culture,GCU,A Series Of Unlikely Explanations,, +Culture,GCU,A Ship With A View*,, +Culture,GCU,Big Sexy Beast,, +Culture,GCU,Boo!,, +Culture,GCU,Cantankerous,, +Culture,GCU,Credibility Problem*,, +Culture,GCU,Dramatic Exit*,, +Culture,GCU,Excuses And Accusations*,, +Culture,GCU,"Funny, It Worked Last Time...",, +Culture,GCU,God Told Me To Do It*,, +Culture,GCU,Halation Effect*,, +Culture,GCU,Happy Idiot Talk*,, +Culture,GCU,Helpless In The Face Of Your Beauty*,, +Culture,GCU,Heresiarch*,, +Culture,GCU,I Thought He Was With You,, +Culture,GCU,It'll Be Over By Christmas,, +Culture,GCU,Just Another Victim Of The Ambient Morality*,, +Culture,GCU,Minority Report*,, +Culture,GCU,Never Talk To Strangers,, +Culture,GCU,Not Wanted On Voyage*,, +Culture,GCU,Only Slightly Bent,, +Culture,GCU,Perfidy*,, +Culture,GCU,Sacrificial Victim*,, +Culture,GCU,Space Monster,, +Culture,GCU,Stranger Here Myself*,, +Culture,GCU,Synchronize Your Dogmas*,, +Culture,GCU,Thank You And Goodnight*,, +Culture,GCU,The Precise Nature Of The Catastrophe*,, +Culture,GCU,Ultimate Ship The Second,, +Culture,GCU,Undesirable Alien*,, +Culture,GCU,Unwitting Accomplice*,, +Culture,GCU,Well I Was In The Neighbourhood*,, +Culture,GCU,You'll Thank Me Later*,, +Culture,GCU,You Would If You Really Loved Me*,, +Culture,GSV,Congenital Optimist,, +Culture,GSV,Size Isn't Everything,,Length of over 80 kilometers. Parent ship of the Sweet and Full of Grace. +Culture,GSV,What Are The Civilian Applications?,Continent,Limited edition Prompt subclass. Can outrun a Very Fast Picket. +Culture,GCU,Just Testing,, +Culture,GCU,Sweet and Full of Grace,,Child ship of the Size Isn't Everything. Unusual insofar as being the only Culture ship mentioned in the series to not have its name in start case. +Culture,GCU,Very Little Gravitas Indeed,,"Part of the ""... Gravitas ..."" running gag.[7] " +Culture,VFP/(D)ROU,Xenophobe,Torturer, +Culture,GSV,"Anticipation Of A New Lover's Arrival, The",Plate, +Culture,GSV,Death And Gravity,,"Its name is a play on the adage that only death and taxes are inevitable; ""taxes"" are replaced with gravity, since the Culture doesn't have taxes (or money). " +Culture,GSV,Ethics Gradient,Range,"Parent ship of the Fate Amenable To Change. References ethical relativism, where no moral position is absolute." +Culture,GSV,Honest Mistake,,Parent ship of the Grey Area. +Culture,GSV,Limivorous,Ocean,"""of or relating to animals, usually worms or bivalves, that ingest earth or mud to extract the organic matter from it."" Unflattering view of non-Mind entities if this is how it sees its relationship with the ship's organic complement." +Culture,GSV,Uninvited Guest,, +Culture,GSV,Use Psychology,, +Culture,GSV,What Is The Answer And Why?,, +Culture,GSV,Wisdom Like Silence,Continent,Controlled by three Minds. +Culture,GSV,Yawning Angel,Range,"Top speed, 146,000 × light-speed." +Culture,GSV,Zero Gravitas,,"Part of the ""... Gravitas ..."" running gag.[7] " +Culture,MSV,Not Invented Here,Desert,"The Desert class was originally a GSV class that was demoted to MSV as Culture ship sizes grew. The Not Invented Here is usually termed an MSV, but is also referred to as an actual GSV twice (Genar-Hofoen is told that the NIH was a GSV by Tishlin, and he subsequently refers to it as a GSV even after knowing that it is now an MSV), while towards the end of the book it is referred to as an LSV by the Sleeper Service and in authorial narration. Accounts of its history are also contradictory: at one point, characters indicate that the NIH is generally believed (even within Special Circumstances) to have been destroyed five centuries earlier; at another, the narration states that it has always remained an apparently normal part of the Culture, with a very well-documented past." +Culture,LSV,Misophist,,"A Sophist is ""a person who reasons with clever but false arguments.""[citation needed] A Misophist is presumably someone who dislikes sophists. " +Culture,LSV,Serious Callers Only,Tundra, +Culture,GCV,Steely Glint,Plains,Parent ship of the Attitude Adjuster. +Culture,GCU,Different Tan,Mountain, +Culture,GCU,Fate Amenable To Change,Escarpment,Child ship of the Ethics Gradient. +Culture,GCU,Grey Area (aka Meatfucker),,"Ostracised for non-consensual mindreading of biological individuals, earning it the condemnation of other ships, who then ignored its chosen name in favor of Meatfucker. Child ship of the Honest Mistake. Also mentioned in Look to Windward. " +Culture,GCU,It's Character Forming,, +Culture,GCU,Jaundiced Outlook,Ridge,Child ship of the Sleeper Service. +Culture,GCU,Problem Child,Troubadour,"Early (vs Excession-contemporary) GCU, historical mention. Nominally captained by Zreyn Tramow." +Culture,GCU,Reasonable Excuse,, +Culture,GCU,Recent Convert,, +Culture,GCU,Tactical Grace,Escarpment, +Culture,GCU,Unacceptable Behaviour,,Child ship of the Quietly Confident (Sleeper Service). +Culture,LOU,Attitude Adjuster,Killer,"Nominally demilitarised, but in fact a fully armed warship. Child ship of the Steely Glint. Class possibly downgraded from ROU (designated as such in Consider Phlebas, set five centuries earlier). " +Culture,ROU,Heavy Messing,Gangster,"An allusion to a term from Glaswegian, or from Ned-ese. Generally if one is said to be ""heavy messing"" they are considered by an aggrieved party to be interfering or aggravating a situation in which they have little to no stake in. " +Culture,ROU,Killing Time,Torturer,"A pun on a saying that 99% of war is just killing time, while the rest is the killing time." +Culture,ROU,Frank Exchange Of Views,Psychopath,"Nominally demilitarised, but in fact a fully armed warship. References the diplomatic language commonly used to describe a blazing argument." +Culture,OU,T3OU 4,Type Three,"Non-standard design, based on Inquisitor-class prototype. Child ships of the Sleeper Service. Controlled by semi-slaved AIs rather than independent Minds." +Culture,OU,T3OU 118,Type Three, +Culture,OU,T3OU 736,Type Three, +Culture,Superlifter,Charitable View,Cliff,"Top sprint speed, 221,000 × light-speed (faster than contemporary ROUs)." +Culture,Cruise Ship,Just Passing Through,, +Culture,,I Blame My Mother,, +Culture,,I Blame Your Mother,, +Culture Convertcraft,Main Battle Unit,Full Refund (formerly MBU 604),Empire,"Former Homomdan MBU, now Culture Convertcraft " +Culture Eccentric,GSV,"Quietly Confident,",Plate,"Acts as a storage ship for biological persons in stasis. The name Sleeper Service is a pun on sleeping car (transport) and sleeper agent (espionage). It also secretly converts itself to be ""mostly engine"" so it can move unexpectedly quickly - a parallel to sleeper cars (racing). Standard Plate class top cruising speed is 104,000 × light-speed, increased by these modifications to 233,500. Originally controlled by three Minds, two of which were removed when the other became Eccentric. Parent ship of the Unacceptable Behaviour, Jaundiced Outlook, T3OU 4, T3OU 118 and T3OU 736. " +,,later Sleeper Service,, +Culture Sabbaticaler,GSV,No Fixed Abode,Ex-Equator,"No fixed abode is a legal term for someone without a fixed address, such as a homeless person. Its name is an observation on itself as a moving starship inherently has no fixed abode. " +Culture Ulterior,,Highpoint,,"Possibly not a ship (described only as an ""Ulterior Entity"")." +"Culture Ulterior (AhForgetIt Tendency), Eccentric",,Shoot Them Later,, +Culture Ulterior (Zetetic Elench),Explorer Ship,Appeal To Reason,,Part of the Stargazer Clan. +Culture Ulterior (Zetetic Elench),Explorer Ship,Break Even,, +Culture Ulterior (Zetetic Elench),Explorer Ship,Long View,, +Culture Ulterior (Zetetic Elench),Explorer Ship,Peace Makes Plenty,, +Culture Ulterior (Zetetic Elench),Explorer Ship,Sober Counsel,, +Culture Ulterior (Zetetic Elench),Explorer Ship,Within Reason,, +Affront,,Frightspear,, +Affront,Light Cruiser,Furious Purpose,Meteorite, +Affront,,Kiss The Blade,, +Affront,,Riptalon,, +Affront,,SacSlicer II,, +Affront,,Wingclipper,, +Affront,Battleship,Xenoclast,, +Culture,GSV,Experiencing A Significant Gravitas Shortfall,Equator,"Part of the ""... Gravitas ..."" running gag.[7] A GCU of the same name is mentioned in Matter. SpaceX's fourth drone ship is named A Shortfall of Gravitas, in reference to this ship. " +Culture,GSV,Lasting Damage,,"A GSV built for combat on the eve of the Idiran-Culture War. After it was destroyed in battle, a recorded copy of its mind-state was embodied in a new Mind and incorporated into another GSV of the same class. Its original Mind was later found to have survived the ship's destruction, and was also incorporated into a new combat GSV." +Culture,GSV,Lasting Damage I,,"The second ship incorporating the original Lasting Damage Mind, which had been assumed destroyed but eventually returned. This second ship was later itself destroyed, but its Mind again survived, and merged with the recorded mind-state of the Lasting Damage II, which was also destroyed, including its Mind, in the same battle. It became the Hub Mind of Masaq' Orbital. " +Culture,GSV,Lasting Damage II,,The ship incorporating the backup copy Mind of the Lasting Damage. +Culture,GSV,Sanctioned Parts List,, +Culture,GCU,Grey Area (aka Meatfucker),,"Featured in Excession; mentioned here only as an illustration of the Culture's disapproval of machines reading the minds of biological individuals, an activity which led other Minds to disregard its chosen name in favour of the name Meatfucker. " +Culture,ROU,Nuisance Value,Torturer, +Culture,VFP/(D)ROU,Resistance Is Character-Forming,Gangster, +Culture,Superlifter,Vulgarian,, +Culture,,Someone Else's Problem†,,"Possible reference to the ""SEP field"", a type of cloaking device featured in the Hitch Hiker's Guide to the Galaxy (Tertiary phase) which caused people to simply ignore what it was protecting, rather than actually making it invisible. " +Culture,,Lacking That Small Match Temperament†,, +Culture,GCU,Poke It With A Stick†,, +Culture,OU,"I Said, I've Got A Big Stick†",,"The small print (spoken softly) is an allusion to the saying ""Speak softly and carry a big stick."" " +Culture,,Hand Me The Gun And Ask Me Again†,, +Culture,,But Who's Counting?†,,"LOU Me, I'm Counting provides the answer." +Culture,,Germane Riposte†,, +Culture,,We Haven't Met But You're A Great Fan Of Mine†,, +Culture,,"All The Same, I Saw It First†",, +Culture,,Ravished By The Sheer Implausibility Of That Last Statement†,, +Culture,,Zero Credibility†,, +Culture,,Charming But Irrational†,, +Culture,,Demented But Determined†,, +Culture,,You May Not Be The Coolest Person Here†,, +Culture,,Lucid Nonsense†,, +Culture,,Awkward Customer†,, +Culture,,Thorough But... Unreliable†,, +Culture,,Advanced Case Of Chronic Patheticism†,, +Culture,,Another Fine Product From The Nonsense Factory†,, +Culture,,Conventional Wisdom†,, +Culture,,In One Ear†,,"Part of the expression ""in one ear and out the other""." +Culture,,Fine Till You Came Along†,, +Culture,,I Blame The Parents†,, +Culture,,Inappropriate Response†,, +Culture,,A Momentary Lapse Of Sanity†,, +Culture,,Lapsed Pacifist†,, +Culture,,Reformed Nice Guy†,, +Culture,,Pride Comes Before A Fall†,, +Culture,,Injury Time†,,"A play on the sporting term ""injury time"" (i.e. time added on at the end of a match to make up for stoppages required to deal with injuries to players) and a notional appropriate time to inflict an injury (see also Killing Time)." +Culture,,Now Look What You've Made Me Do†,, +Culture,,Kiss This Then†,, +Chelgrian,Privateer,Winter Storm,, +Chelgrian,Temple ship,Piety,, +Chelgrian,Temple ship,Soulhaven,, +Culture,GSV,Seed Drill,Ocean, +Culture,MSV,Don't Try This At Home,Steppe, +Culture,LSV,Xenoglossicist,Air, +Culture,GCV,Subtle Shift In Emphasis,Plains, +Culture,GCU,Experiencing A Significant Gravitas Shortfall,,"Part of the ""... Gravitas ..."" running gag.[7] A GSV of the same name is mentioned in Look to Windward. SpaceX's fourth drone ship is named A Shortfall of Gravitas, in reference to this ship. " +Culture,GCU,It's My Party And I'll Sing If I Want To,Escarpment,"Allusion to the song It's my party, and I'll cry if I want to. " +Culture,GCU,Lightly Seared On The Reality Grill,, +Culture,GCU,Pure Big Mad Boat Man,,"An inside joke based upon the language of Ned (Scottish) culture. It would be read/heard as ""a pure big, mad boat, man"" roughly meaning ""a very large and deadly serious boat my good man"". " +Culture,GCU,Qualifier,Trench, +Culture,GCU,Transient Atmospheric Phenomenon,,Transient Atmospheric Phenomenon has been suggested as an alternative name for a UFO +Culture,GCU,You Naughty Monsters,, +Culture,FP/(D)GOU,Eight Rounds Rapid,Delinquent, +Culture,VFP/(D)ROU,You'll Clean That Up Before You Leave,Gangster, +Culture,,Now We Try It My Way,Erratic,"An ancient ship, originally an Interstellar-class ship of the now-obsolete General Transport Craft type." +Culture Ulterior,"Superlifter (ex‑GCU), militarised",Liveware Problem,Stream (modified Delta-class GCU),"Militarised during the Idiran War and nominally absconded after the conflict, probably for the purpose of acting as a deniable Special Circumstances operative. The phrase is a joke among computer engineers, suggesting that the problem lies with the user.[9] " +,,,, +,,,,"The Deep Submersible Support Vessel (DSSV) Pressure Drop, the expedition support ship of the Five Deeps Expedition led by Victor Vescovo, has a rescue boat on it called the ""Liveware Problem."" The inside joke according to the crew is that if the ship was ever sinking and the ship had to use the boat, it would probably be because of a ""liveware problem."" " +Morthanveld,Cat.3 SlimHull,"“Now, Turning to Reason, & its Just Sweetness”",,"The book's appendix capitalises the first letter of 'its', contrary to the two times the ship is named in the text." +Morthanveld,Cat.4 CleaveHull,“On First Seeing Jhiriit”,,"This ship is not mentioned in the story itself, only in the book's appendix." +Morthanveld,Cat.5 SwellHull,"“Fasilyce, Upon Waking”",, +Morthanveld,Great Ship,"Inspiral, Coalescence, Ringdown",,Comparable to a GSV; the name refers to stages in the merger of two black holes. +Nariscene,Star Cruiser,Hence the Fortress,Comet, +Nariscene,,"Hundredth Idiot, The",White Dwarf,Name derived from a Nariscene proverb. +Culture,GSV,Dressed Up To Party,, +Culture,GSV,Pelagian,Equator, +Culture,GSV,"Sense Amid Madness, Wit Amidst Folly",Plate, +Culture,GSV,Total Internal Reflection,,"One of the ""Forgotten""/""Oubliettionaries"": Systems Vehicles remaining indefinitely in secretive isolation, tasked with recreating the Culture in the event of its destruction." +Culture,GCU,Armchair Traveller,Mountain, +Culture,GCU,"Bodhisattva, OAQS",Escarpment,Part of Contact's Quietudinal Service (Quietus). Quietus ships added letters OAQS - On Active Quietudinal Service - to their names while they were so employed. +Culture,GOU/PS,Falling Outside The Normal Moral Constraints,Abominator,"Class publicly categorised as Picket Ship, to give the impression that they are equivalent in function to FPs and VFPs; in fact these are state-of-the-art warships, the most powerful to appear in the series." +Culture,FP/(D)GOU,No One Knows What The Dead Think,,Formerly known as the GOU Obliterating Angel. +Culture,FP/(D)LOU,Hylozoist,Killer,"Class possibly downgraded from ROU (designated as such in Consider Phlebas, set fifteen centuries earlier). Name alludes to Hylozoism. " +Culture,FP/(D)ROU,The Usual But Etymologically Unsatisfactory,Psychopath,"Class possibly downgraded from VFP (designated as such in Excession, set ten centuries earlier, and in The Hydrogen Sonata, set five centuries earlier). " +Culture,,Beastly To The Animals,, +Culture,,Fixed Grin,, +Culture,,Hidden Income,,"Type not mentioned in novel, but possibly General Transport Craft (see Matter).[why?] " +Culture,,Scar Glamour,, +Culture Eccentric,,Labtebricolephile,,"This name appears to be derived from a misspelling of 'latebricole' (the misspelling in question likely originating from Stephen Chrisomalis's website ""The Phrontistery""), which is an adjective meaning ""living concealed in a hole"". " +"Culture Ulterior, Eccentric",FP/(D)LOU,"Me, I'm Counting",Hooligan,Another ship in the Culture is called But Who's Counting?. +GFCF,Contact Craft,Messenger Of Truth,Succour, +GFCF,Minor Destructor Vessel,Fractious Person,, +GFCF,Minor Destructor Vessel,Rubric Of Ruin,, +GFCF,,Abundance Of Onslaught,Deepest Regrets,Deepest Regrets-class ships are capital ships and the pride of the GFCF fleet. +GFCF,,Vision Of Hope Surpassed,Deepest Regrets, +GFCF,GOU,Joiler Veppers (provisional name),Murderer (modified),"Based on the Culture's obsolete Murderer-class GOU, with upgraded speed and modified weaponry, built by the GFCF as a bribe for the Sichultian plutocrat Joiler Veppers." +Jhlupian,Heavy Cruiser,Ucalegon,,"Ucalegon means ""a neighbor whose house is on fire"". Ucalegon is also the name of a non-sentient Culture barge on Masaq' Orbital in Look to Windward. " +Nauptre Reliquaria,Bismuth Category,8401.00 Partial Photic Boundary,, +Culture,GSV,A Fine Disregard For Awkward Facts,, +Culture,GSV,Contents May Differ,Atmosphere, +Culture,GSV,Empiricist,System,"A big ship, even by the standards of System-class vessels, which are the largest built by the Culture (being composed of multiple separate hulls, ships of this class are easily expanded, leading to great variations in size). Controlled by seven Minds. Population over 13 billion." +Culture,GSV,Just The Washing Instruction Chip In Life's Rich Tapestry,, +Culture,GSV,Kakistocrat,,"Home GSV of Mistake Not… ""Kakistocrat"" is Ancient Greek, meaning ""worst ruler"", a humorous inversion of ""aristocrat"". " +Culture,GSV,Teething Problems,, +Culture,GSV,Unreliable Witness,,Parent ship of the Smile Tolerantly. +Culture,MSV,Passing By And Thought I'd Drop In,Desert, +Culture,MSV,Pressure Drop,Shelf,"Victor Vescovo, an American deep-sea explorer, named the expedition/mother ship of the deep diving submersible DSV Limiting Factor after this ship. The current DSSV (Deep Submersible Support Vessel) Pressure Drop was formerly the USNS Indomitable.[5] " +Culture,LSV,You Call This Clean?,Blue, +Culture,GCU,Displacement Activity,River,Class name previously used for a Superlifter class in The Player of Games. +Culture,GCU,"Warm, Considering",Delta, +Culture,LCU,Anything Legal Considered,Ridge,"Class possibly downgraded from GCU (designated as such in Excession, set five centuries earlier). " +Culture,LCU,Beats Working,Scree,"The smallest class of Contact Unit: 80m long, with a human crew of five." +Culture,GOU,Headcrash,Delinquent, +Culture,GOU,Questionable Ethics,, +Culture,GOU,Xenocrat,Delinquent, +Culture,LOU,Caconym,Troublemaker,"Although categorised as LOUs, the Troublemaker class are referred to as ""nominatively camouflaged"", outclassing earlier GOUs. ""Caconym"" is Ancient Greek, meaning ""bad name"", probably in reference to the English idiom meaning ""bad reputation"". " +Culture,LOU,New Toy,, +Culture,VFP/(D)LOU,Rapid Random Response Unit,Troublemaker, +Culture,ROU,Learned Response,,"The Deep Submersible Support Vessel (DSSV) Pressure Drop, the expedition support ship of the Five Deeps Expedition led by Victor Vescovo, has a small, dual-outboard sea-control/support vessel called the ""Learned Response."" " +Culture,VFP/(D)ROU,Outstanding Contribution To The Historical Process,Psychopath,Twice referred to as “Ex-Psychopath-class”[10] +Culture,FP/(D)ROU,Refreshingly Unconcerned With The Vulgar Exigencies Of Veracity,Thug,"Some confusion as to type: described as a demilitarised ROU, but also as an FP, a designation otherwise applied to demilitarised GOUs and LOUs, whereas demilitarised ROUs are VFPs. Also referred to as an ROU class in Excession, but in that book the Thug-class-based Type Five OUs are lower in the fleet hierarchy than the Type Four, based on the Killer class, which is described in the same book as an LOU, implying that the Thug class should also be LOUs. " +Culture,FP/(D)ROU,Value Judgement,Thug,See above. +Culture,Superlifter,Zoologist,Boulder, +Culture Eccentric,OU/e,Mistake Not…,,"A one-off design of indeterminate classification, whose capabilities remain secret but which is a highly capable warship. It identifies itself as Ue, for Unit (eccentric/erratic); less coyly designated in the book's appendix as OU/e. Its full name, which is a private joke amongst other Culture Minds and almost never used, is the Mistake Not My Current State Of Joshing Gentle Peevishness For The Awesome And Terrible Majesty Of The Towering Seas Of Ire That Are Themselves The Mere Milquetoast Shallows Fringing My Vast Oceans Of Wrath." +Culture-Zihdren-Remnanter hybrid,(ex-)GCU,Smile Tolerantly,,"Formerly an ancient GCU, has hybridised its Mind with the technology of another civilisation, the Zihdren-Remnanter, and describes itself as having ""enhanced loyalties"" (i.e. divided loyalties). Child ship of the Unreliable Witness." +Gzilt,IR-HAS cruiser,5*Gelish-Oplule,,"Indefinite Range, High Acceleration/Speed" +Gzilt,IR-HVW battlecruiser,7*Uagren,,"Indefinite Range, High Velocity/Weapon-load" +Gzilt,IR-FWS battleship,8*Churkun,,"Indefinite Range, Full Weapon Spectrum" +Iwenick,Space-Capable Inter-Element Transportation Component,Iberre,,"Private yacht, named after the owner's father-mother." +Iwenick,Strategic Outreach Element,CH2OH.(CHOH)4.CHO,,The chemical whose formulation is given in this name is galactose (here used as a pun on galaxy/galactic). +Liseiden,Collective Purposes Vessel,Abalule-Sheliz,, +Liseiden,Collective Purposes Vessel,Gellemtyan-Asool-Anafawaya,(First Class),Flagship +Liseiden,Collective Purposes Vessel,Laskuil-Hliz,, +Liseiden,Collective Purposes Vessel,Quiatrea-Anang,, +Liseiden,,Fulanya-Guang,, +Ronte,,Melancholia Enshrines All Triumph,Interstitial/Exploratory, +Zihdren-Remnanter,Adjunct Entity,Oceanic Dissonance,, +Zihdren-Remnanter,Ceremonial Representative Carrying Ship,Exaltation-Parsimony III,, + ,,,, +,,,, + ,,,, +,,,, + ,,,, diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h index 74a9723..190c6e4 100644 --- a/src/c/environment/privileged_keywords.h +++ b/src/c/environment/privileged_keywords.h @@ -4,7 +4,7 @@ * Post Scarcity Soctware Environment * * TODO: Edit purpose. - * + * * Copyright (c): 27 Apr 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ @@ -13,7 +13,7 @@ #define SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ #define PK_LOCATION U"location" -#define PK_NAME = U"name" +#define PK_NAME U"name" #include "memory/pointer.h" extern struct pso_pointer privileged_keyword_location; diff --git a/src/c/io/read.c b/src/c/io/read.c index 336311f..5e64005 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -177,7 +177,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { } url_ungetwc( c, input ); - result = c_reverse( result ); + result = c_reverse( frame_pointer, result ); } return result; diff --git a/src/c/ops/list_ops.h b/src/c/ops/list_ops.h index 0dd74d1..4ae47dc 100644 --- a/src/c/ops/list_ops.h +++ b/src/c/ops/list_ops.h @@ -17,6 +17,6 @@ #include "payloads/function.h" -struct pso_pointer length( struct pso_pointer frame_pointer ); +struct pso_pointer count( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index 57571a0..5f74aae 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -9,15 +9,19 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ - #include "debug.h" + #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" #include "memory/pso4.h" #include "memory/tags.h" + +#include "ops/eval_apply.h" #include "ops/reverse.h" +#include "ops/stack_ops.h" #include "ops/truth.h" + #include "payloads/cons.h" struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { @@ -30,29 +34,28 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); c = c_cdr( c ) ) { struct pso_pointer expr = - cons( frame->payload.stack_frame.arg[0], make_cons( frame_pointer, c_car( c ), nil ) ); + push_local( frame_pointer, + make_cons( frame_pointer, frame->payload.stack_frame.arg[0], + make_cons( frame_pointer, c_car( c ), nil ) ) ); debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); - struct pso_pointer r = eval_form( frame, frame_pointer, expr, env ); + struct pso_pointer r = lisp_eval( push_local( frame_pointer, make_frame(1, frame_pointer, expr))); if ( exceptionp( r ) ) { result = r; - inc_ref( expr ); // to protect exception from the later dec_ref break; } else { - result = cons( r, result ); + result = push_local( frame_pointer, make_cons( frame_pointer, r, result )); } debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, result is ", i++ ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); - - dec_ref( expr ); } - result = consp( result ) ? c_reverse( result ) : result; + result = consp( result ) ? c_reverse( frame_pointer, result ) : result; debug_print( U"Mapcar returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 066642d..75472f5 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -238,7 +238,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); struct pso_pointer arg_length = - length( make_frame( 1, previous, argvalues ) ); + count( push_local( previous, make_frame( 1, previous, argvalues ) ) ); int arg_count = integerp( arg_length ) ? pointer_to_object( arg_length )-> payload.integer.value : 0; From f4303247b90c493f35ab017ba80a68a7e047c2df Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 13:15:30 +0100 Subject: [PATCH 62/77] Added files which were missed by the last commit. --- docs/State-of-play.md | 26 ++++++++++++++++++++++++++ src/c/ops/dump.h | 0 src/c/ops/eval_apply.c | 1 - src/c/payloads/float.h | 22 ++++++++++++++++++++++ 4 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 src/c/ops/dump.h create mode 100644 src/c/payloads/float.h diff --git a/docs/State-of-play.md b/docs/State-of-play.md index ea48db0..c7c9832 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,31 @@ # State of Play +## 20260504 + +My monster, she builds! + +Admittedly, she doesn't yet do much, but... + +### Evaluating editors + +My favourite Clojure editor, [LightTable](http://lighttable.com/), went dark — or at least, ceased to be actively developed — about five years ago; and as it depends on libraries which are not available in Debian Trixie, the published executable will no longer run. At about the time it died I did have a look at whether it would be feasible for me to take over maintenance of it, and I came to the conclusion that it would be too much work. + +#### VS Codium + +So I switched to [VSCodium](https://vscodium.com/), which is a fork of Microsoft's supposedly open source VS Code editor with all the proprietary Microsoft shit taken out, some years ago. VS Codium, like VS Code, is built on [Electron](https://www.electronjs.org/), which means it's built, fundamentally, on a JavaScript library stack, with all the instability and insecurity that implies. I have been getting increasingly nervous about my use of VSCodium in the light of [increasingly frequent attacks](https://krebsonsecurity.com/2025/09/18-popular-code-packages-hacked-rigged-to-steal-crypto/) on the JavaScript ecosystem. + +This is not to say I dislike VSCodium; I don't. It's been, mainly, a pleasure to use. It's stable, it doesn't get in my way, it's highly configurable and extensible. I just don't have the bandwidth to monitor and audit the libraries it is using. + +#### Emacs + +In April had one of my periodic attempts to switch back to [Emacs](https://www.gnu.org/software/emacs/) — that ancient editor which is Generally Not Used Except by Middle Aged Computer Scientists. Back in the day I didn't use Emacs for editing Lisp, of course, because back in the day I was using real Lisps like Portable Standard Lisp and InterLisp which had built in structure editors. But I used to use Emacs for almost everything else, including reading my mail, browsing [Usenet](https://en.wikipedia.org/wiki/Usenet), and editing shell scripts and programs in the languages of [οἱ](https://en.wiktionary.org/wiki/οἱ#Ancient_Greek) [πολλοί](https://en.wiktionary.org/wiki/πολλοί#Ancient_Greek). And given that the substrate of Post Scarcity is (still) being written in C, just as KnacqTools was back in the day, why not Emacs? After all, it is extremely stable, and extraordinarily configurable and extensible. + +The answer, dear reader, is that Emacs is determined to get in my way in every possible way. It is obnoxious to use. Every key binding, every mouse action, which works in every other software package on a modern windowed user interface does something completely different in Emacs (and vice versa). Your muscle memory no longer works. Every keystroke, every command action, has to be carefully thought about. You have two choices: you can switch entirely to living only in Emacs and relearning the Emacs keybindings, or to live in a permanent hell of confusion, overthinking and self-doubt. And, in this day and age, there are many things which Emacs does not do nearly so well as more modern packages do. You **can** browse the web in Emacs — of course you can! — but, dear reader, you really wouldn't want to. + +#### Eclipse + +When I finally switched away from using Emacs for everything + ## 20260503 Right, so, it's a week since my last entry. The version of eval/apply copied from `0.0.6` still doesn't compile, let alone work. There are reasons. I've been ill — my brain really is fucked — and I've had outdoor work it's felt urgent to do. diff --git a/src/c/ops/dump.h b/src/c/ops/dump.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index ad8f3e6..0473523 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -16,7 +16,6 @@ #include #include - #include "debug.h" #include "environment/privileged_keywords.h" diff --git a/src/c/payloads/float.h b/src/c/payloads/float.h new file mode 100644 index 0000000..9cfc018 --- /dev/null +++ b/src/c/payloads/float.h @@ -0,0 +1,22 @@ +/** + * payloads/float.h + * + * A floating point number. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_payloads_float_h +#define __psse_payloads_float_h + + +/** + * @brief a floating point number. At this stage it's only 64 bits wide, but + * we could/should use the full 128 bits. + */ +struct float_payload { + long double value; +}; + +#endif \ No newline at end of file From efa6a3246d75abeca7af719b4bf2162cb11b577f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 16:15:57 +0100 Subject: [PATCH 63/77] Started work on binding functions. Not yet complete. --- docs/State-of-play.md | 30 +++- src/c/environment/function_bindings.c | 175 ++++++++++++++++++++++++ src/c/environment/function_bindings.h | 0 src/c/environment/privileged_keywords.c | 11 +- src/c/environment/privileged_keywords.h | 8 +- src/c/ops/assoc.c | 5 - src/c/ops/assoc.h | 2 + src/c/ops/cond.c | 31 ++--- src/c/ops/cond.h | 20 +++ src/c/ops/eq.c | 2 +- src/c/ops/eval_apply.c | 9 +- src/c/ops/inspect.c | 5 +- src/c/ops/inspect.h | 4 +- src/c/payloads/function.c | 25 ++++ src/c/payloads/function.h | 4 + src/c/payloads/special.c | 25 ++++ src/c/payloads/special.h | 6 +- 17 files changed, 321 insertions(+), 41 deletions(-) create mode 100644 src/c/environment/function_bindings.c create mode 100644 src/c/environment/function_bindings.h create mode 100644 src/c/ops/cond.h create mode 100644 src/c/payloads/function.c create mode 100644 src/c/payloads/special.c diff --git a/docs/State-of-play.md b/docs/State-of-play.md index c7c9832..39f44ff 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -24,7 +24,35 @@ The answer, dear reader, is that Emacs is determined to get in my way in every p #### Eclipse -When I finally switched away from using Emacs for everything +When I finally switched away from using Emacs for everything, sometime around 2000, I tried a number of things and ended up with [Eclipse](https://eclipseide.org/), which was at the time a fairly simple but fairly solid Java oriented integrated development environment (IDE). I stayed with Eclipse then for about a decade; but when I moved to mainly developing in Clojure, Eclipse just didn't do Clojure very well, I switched back to Emacs for a while, was driven mad by it again, and found LightTable as a blissful release; which takes us back to the beginning of this section. + +Last month, when I was searching for something to replace VSCodium and had realised once again how much I hate using Emacs for serious development, I tried Eclipse. + +It's... not awful? It's become a very polished, very configurable IDE; it has excellent facilities for C development. But I found it intrusively over-helpful: its continual 'helpful' suggestions got in my way. I used it for about ten days. I wasn't enjoying it. But what made me give up on it was because it won't follow your configured desktop colour theme, and I wasn't able to find a dark-mode theme for it that worked for me: there are plenty of themes , but they are only applied to the editing panels, not to the chrome or to any of the other panels. I find white backgrounds really unpleasant on my eyes. + +#### KDevelop and Gnome Builder + +I know I tried [KDevelop](https://kdevelop.org/) at some stage in this process. I can't remember why I rejected it. There's probably a reason. I also tried [Gnome Builder](https://apps.gnome.org/en-GB/Builder/) and rejected it very quickly, again I can't remember why; having a wee play with it just now it feels quite nice, and I may have another try. However, the Debian package of Gnome Builder [does not include the help files](https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1111418), and, without them, I haven't found out how to invoke the debugger. + +#### Basic text editors + +I obviously have a basic text editor, [gedit](https://gedit-text-editor.org/), on my system. It does C syntax highlighting very well, but doesn't do code completion, and doesn't have any integration with a build system or debugger. I have various debugger user interfaces — I like [seergdb](https://github.com/epasveer/seer) — but I do have it convenient to have a debugger integrated into my editor, rather than having to switch between two separate applications. Similarly, it's convenient to have a terminal integrated with the development environment, although it doesn't need to be. GEdit, plus seergdb, plus a terminal, plus some sort of a git browser, would work for me. + +#### New editors + +People online have suggested I try two new editors: [Zed](https://zed.dev/) and Gram: these are essentially the same editor, in fact. Zed proudly announces itself as + +> a minimal code editor crafted for speed and collaboration with humans and AI + +The Zed project seems to want to monetise their work by selling you AI tokens. Which LLM is behind their AI I don't know. Open Source development needs to be funded somehow; funding it through a tax on people who use AI is as good a way as any. + +Dear reader, I do **not want** to collaborate with AI; I don't want any of that shit in my working environment. So that immediately got my back up. It also doesn't have a Debian installer. But I was able to build it from source, and have been using it consistently over the last couple of days, and it's very pleasant. There's a built in debugger, but I cannot get it to work. Beyond that, my build crashes occasionally — maybe once every two or three hours; but it doesn't seem to lose anything when it crashes, so this is not obnoxious. If I ignore the 'AI' features, the lack of a working debugger is the only mark against it. + +[Gram](https://gram.liten.app/) is said to be a fork of Zed with the AI features removed. It has a proper Debian installation repository, which is a significant step up over Zed. Unfortunately, it won't run on my desktop machine, due to [a problem with the video card](https://codeberg.org/GramEditor/gram/issues/256). On my laptop, it runs fine, and seems generally usable — although, again, I can't get the debugger to work. + +#### Conclusion for now + +The conclusion for now is that I don't have a conclusion for now. Any of Gnome Builder, Zed and Gram are sort of good enough. Zed crashes, which is not desirable; Gram only launches on my laptop, but I mostly do serious development on my desktop; I can't yet work out how to launch the debugger on any of them. But none are annoying, none get in my way. I'll keep on evaluating. ## 20260503 diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c new file mode 100644 index 0000000..00d026c --- /dev/null +++ b/src/c/environment/function_bindings.c @@ -0,0 +1,175 @@ +/** + * environment/function_bindings.c + * + * Post Scarcity Software Environment: + * + * Provide bindings for substrate functions. At least in theory, these + * bindings only need to be initialised on node zero. + * todo: they really ought to be in a namespace ::system:bootstrap, once I + * have namespaces and paths working. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#include "environment/privileged_keywords.h" +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/tags.h" + +#include "ops/assoc.h" +#include "ops/bind.h" +#include "ops/cond.h" +#include "ops/eval_apply.h" +#include "ops/eq.h" +#include "ops/inspect.h" +#include "ops/stack_ops.h" +#include "ops/string_ops.h" + +#include "payloads/cons.h" +#include "payloads/function.h" +#include "payloads/special.h" + +/** + * Bind this compiled `executable` function, as a Lisp function, to + * this name in the `oblist`. + * \todo where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. + */ + +struct pso_pointer +bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, + struct pso_pointer (*executable)(struct pso_pointer)) { + struct pso_pointer result = fetch_env(frame_pointer); + struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); + struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); + + struct pso_pointer meta = + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_bootstrap, nil), + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_name, n), + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_documentation, d), nil))); + + struct pso_pointer r = make_function(frame_pointer, meta, executable); + + if (!exceptionp(r)) { + result = make_cons( frame_pointer, make_cons( frame_pointer, n, r), result); + } + + return result; +} + +/** + * Bind this compiled `executable` function, as a Lisp special form, to + * this `name` in the `oblist`. + */ +struct pso_pointer +bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, + struct pso_pointer (*executable)(struct pso_pointer)) { + struct pso_pointer result = fetch_env(frame_pointer); + struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); + struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); + + struct pso_pointer meta = + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_bootstrap, nil), + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_name, n), + make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_documentation, d), nil))); + + struct pso_pointer r = make_special(frame_pointer, meta, executable); + + if (!exceptionp(r)) { + result = make_cons( frame_pointer, make_cons( frame_pointer, n, r), result); + } + + return result; +} + +struct function_data { + char32_t *name; + char32_t *documentation; + void* executable; +}; + +/* right, the problem with all those pretty '#ifdefs' which might allow us to + * simply switch functions on and off just by including or not including .h + * files is that the C compiler is too primitive to know how many items there + * are in an array. So this number must be edited manually, and must be right. + */ +#define N_FUNCTION_INITIALISERS 4 + +/** initialisers for functions */ +struct function_data function_initialisers[] = { +#ifdef __psse_ops_assoc_h + {U"assoc", + U"(assoc key store): search `store` for the value associated with " + U"`key`.", + &assoc}, +#endif +#ifdef __psse_ops_bind_h + {U"bind!", + U"(bind! key value store): bind `key` to `value` in this store, modifying " + U"the store if it is writable to the user, otherwise returning a new " + U"store", + &bind}, +#endif +#ifdef __psse_ops_eq_h + {U"eq", + U"(eq args...): shallow, cheap equality; returns `t` if all `args...` " + U"are the same object, else `nil`.", + &eq}, + {U"equal", + U"(equal a b): expensive, deep equality: returns `t` if objects `a` " + U"and `b` have recursively equal value.", + &equal}, +#endif +#ifdef __psse_ops_eval_apply_h + // TODO: there's a lot of other stuff in eval_apply.c, which ought to be in + // other files but at present isn't. + {U"apply", + U"(apply fn args...): apply this `fn` to these `args...` and return " + U"their value.", + &lisp_apply}, + {U"eval", + U"(eval expression): evaluate this `expression` and return its value", + &lisp_eval}, +#endif +#ifdef __psse_ops_inspect_h + { + U"inspect", + U"(inspect expr), (inspect expr write-stream): inspect one complete " + U"lisp expression and return `nil`. If `write-stream` is specified and " + U"is a write stream, then print to that stream, else to the stream " + U"which is the value of `*out*` in the environment.", + &lisp_inspect + }, +#endif +}; + +/* right, the problem with all those pretty '#ifdefs' which might allow us to + * simply switch functions on and off just by including or not including .h + * files is that the C compiler is too primitive to know how many items there + * are in an array */ +#define N_SPECIAL_INITIALISERS 1 + +/** initialisers for special forms */ +struct function_data special_initialisers[] = { +#ifdef __psse_ops_cond_h + {U"cond", + U"(cond clauses...): conditional. Each `clause` is expected to be a " + U"list; if the first item in such a list evaluates to non-nil, the " + U"remaining items in that list are evaluated in turn and the value of " + U"the last returned. If no arg `clause` has a first element which " + U"evaluates to non nil, then nil is returned", + &lisp_cond}, +#endif +}; + +struct pso_pointer +initialise_function_bindings(struct pso_pointer frame_pointer) { + struct pso_pointer result = fetch_env(frame_pointer); + + return result; +} \ No newline at end of file diff --git a/src/c/environment/function_bindings.h b/src/c/environment/function_bindings.h new file mode 100644 index 0000000..e69de29 diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c index 411e6a0..394fe09 100644 --- a/src/c/environment/privileged_keywords.c +++ b/src/c/environment/privileged_keywords.c @@ -23,6 +23,13 @@ #include "ops/string_ops.h" +/** + * layer metadata for functions written in C + */ +struct pso_pointer privileged_keyword_bootstrap; + +struct pso_pointer privileged_keyword_documentation; + /** * location metadata for exceptions (and possibly location in other contexts). */ @@ -37,7 +44,9 @@ struct pso_pointer privileged_keyword_name; #define load_and_lock(var,val)var = lock_object(c_string_to_lisp_keyword(nil, val)) -struct pso_pointer initialise_privileged_keywords( struct pso_pointer env){ +struct pso_pointer initialise_privileged_keywords(struct pso_pointer env) { + load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP); + load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION); load_and_lock(privileged_keyword_location, PK_LOCATION); load_and_lock( privileged_keyword_name, PK_NAME); } \ No newline at end of file diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h index 190c6e4..5726fb7 100644 --- a/src/c/environment/privileged_keywords.h +++ b/src/c/environment/privileged_keywords.h @@ -3,7 +3,7 @@ * * Post Scarcity Soctware Environment * - * TODO: Edit purpose. + * Keywords guaranteed to be present in the environment on each node. * * Copyright (c): 27 Apr 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. @@ -11,11 +11,15 @@ #ifndef SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ #define SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ +#include "memory/pointer.h" +#define PK_BOOTSTRAP U"bootstrap" +#define PK_DOCUMENTATION U"documentation" #define PK_LOCATION U"location" #define PK_NAME U"name" -#include "memory/pointer.h" +extern struct pso_pointer privileged_keyword_bootstrap; +extern struct pso_pointer privileged_keyword_documentation; extern struct pso_pointer privileged_keyword_location; extern struct pso_pointer privileged_keyword_name; diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 9e5672d..647b7bf 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -115,13 +115,8 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { * @return a pointer to the value of the key in the store, or nil if not found */ struct pso_pointer assoc( -#ifndef MANAGED_POINTER_ONLY - struct pso4 *frame, -#endif struct pso_pointer frame_pointer ) { -#ifdef MANAGED_POINTER_ONLY struct pso4 *frame = pointer_to_pso4( frame_pointer ); -#endif struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index 746a6ea..1fcf981 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -16,6 +16,8 @@ #include "memory/pointer.h" +struct pso_pointer assoc(struct pso_pointer frame_pointer); + struct pso_pointer search( struct pso_pointer key, struct pso_pointer store, bool return_key ); diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index c600d98..f2949d4 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -8,6 +8,7 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" +#include "memory/pso4.h" #include "memory/tags.h" #include "ops/eval_apply.h" @@ -29,12 +30,12 @@ */ struct pso_pointer eval_cond_clause( struct pso_pointer clause, struct pso4 *frame, - struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso_pointer result = nil; + struct pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso_pointer env = fetch_env(frame_pointer); #ifdef DEBUG - debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print( U"\n\tCond clause: ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); #endif @@ -49,19 +50,19 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); #ifdef DEBUG - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print( U"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print( U" succeeded; returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); } else { - debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print( U"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( L" failed.\n", DEBUG_EVAL, 0 ); + debug_print( U" failed.\n", DEBUG_EVAL, 0 ); #endif } } else { - result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), + result = throw_exception( c_string_to_lisp_symbol( frame_pointer, U"cond" ), c_string_to_lisp_string (frame_pointer, L"Arguments to `cond` must be lists" ), frame_pointer ); @@ -78,14 +79,10 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, * * * (cond clauses...) * - * @param frame my stack frame. - * @param frame_pointer a pointer to my pso4. - * @param env the environment in which arguments will be evaluated. * @return the value of the last expression of the first successful `clause`. */ -struct pso_pointer -lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); struct pso_pointer result = nil; bool done = false; @@ -97,7 +94,7 @@ lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, // to nil, the form still succeeded and we should still exit `cond`. // - result = eval_cond_clause( clause_pointer, frame, frame_pointer, env ); + result = eval_cond_clause( clause_pointer, frame, frame_pointer ); if ( !c_nilp( result ) && c_truep( c_car( result ) ) ) { result = c_cdr( result ); @@ -106,7 +103,7 @@ lisp_cond( struct pso4 *frame, struct pso_pointer frame_pointer, } } #ifdef DEBUG - debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print( U"\tCond returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); #endif diff --git a/src/c/ops/cond.h b/src/c/ops/cond.h new file mode 100644 index 0000000..a2f7136 --- /dev/null +++ b/src/c/ops/cond.h @@ -0,0 +1,20 @@ +/** + * ops/cond.h + * + * Post Scarcity Software Environment: cond. + * + * cond a name to a value in a store. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_cond_h +#define __psse_ops_cond_h + +#include "memory/pointer.h" + + +struct pso_pointer lisp_cond( struct pso_pointer frame_pointer ); + +#endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index f350d5a..d7b4f38 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -131,7 +131,7 @@ struct pso_pointer eq( * * symbols * * strings * - * * (equal? arg1 qrg2) + * * (equal? arg1 arg2) * * @return `t` if all args are pointers to the same object, else `nil`; */ diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 0473523..361c911 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -260,8 +260,7 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { * * This is experimental. It almost certainly WILL change. */ -struct pso_pointer lisp_try( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_try( struct pso_pointer frame_pointer) { struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer body_frame = @@ -301,8 +300,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer, * @return the root namespace. */ struct pso_pointer -lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer env ) { +lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer) { return oblist; } @@ -750,9 +748,6 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { * * * (eval expression) * - * @param frame my pso4. - * @param frame_pointer a pointer to my pso4. - * @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 diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c index ee64388..9d3ce60 100644 --- a/src/c/ops/inspect.c +++ b/src/c/ops/inspect.c @@ -21,10 +21,7 @@ #include "ops/stack_ops.h" /** - * 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. + * Function: dump/ * * * (inspect expr) * * (inspect expr write-stream) diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h index 6803e09..800d643 100644 --- a/src/c/ops/inspect.h +++ b/src/c/ops/inspect.h @@ -9,8 +9,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef psse_ops_inspect -#define psse_ops_inspect +#ifndef psse_ops_inspect_h +#define psse_ops_inspect_h #include "memory/pointer.h" diff --git a/src/c/payloads/function.c b/src/c/payloads/function.c new file mode 100644 index 0000000..14015ab --- /dev/null +++ b/src/c/payloads/function.c @@ -0,0 +1,25 @@ +/** + * payloads/function.c + * + * 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. + */ + +#include "memory/pointer.h" +#include "memory/pso.h" +#include "memory/pso2.h" +#include "memory/tags.h" + +struct pso_pointer make_function( + struct pso_pointer frame_pointer, struct pso_pointer meta, + struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { + struct pso_pointer result = allocate(frame_pointer, FUNCTIONTAG, 2); + struct pso2 *object = pointer_to_object(result); + + object->payload.function.meta = meta; + object->payload.function.executable = executable; + + return result; +} diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 419ffa7..8c7da98 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -39,4 +39,8 @@ struct function_payload { struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); }; +struct pso_pointer make_function( + struct pso_pointer frame_pointer, struct pso_pointer meta, + struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); + #endif diff --git a/src/c/payloads/special.c b/src/c/payloads/special.c new file mode 100644 index 0000000..abf8d97 --- /dev/null +++ b/src/c/payloads/special.c @@ -0,0 +1,25 @@ +/** + * payloads/special.c + * + * a special Lisp function - one whose arguments are **not** pre-evaluated. + * + * (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/tags.h" + +struct pso_pointer make_special( + struct pso_pointer frame_pointer, struct pso_pointer meta, + struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { + struct pso_pointer result = allocate(frame_pointer, SPECIALTAG, 2); + struct pso2 *object = pointer_to_object(result); + + object->payload.special.meta = meta; + object->payload.special.executable = executable; + + return result; +} diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index 5ccdb1f..ef913e9 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -18,8 +18,12 @@ /** * A special form - one whose arguments are not pre-evaluated but passed as - * provided. + * provided. Shares payload with function, q.v. * \see NLAMBDATAG. */ +struct pso_pointer make_special( + struct pso_pointer frame_pointer, struct pso_pointer meta, + struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); + #endif From fcfdb43b05b0ed66ef1f35b976284a892de3c6e2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 18:23:46 +0100 Subject: [PATCH 64/77] I *think* that's all the bootstrap functions being bound in the environment. --- src/c/environment/environment.c | 34 +++--- src/c/environment/function_bindings.c | 157 +++++++++++++++++++++----- src/c/environment/function_bindings.h | 17 +++ src/c/ops/inspect.h | 4 +- src/c/ops/keys.h | 4 +- src/c/ops/mapcar.h | 6 +- src/c/ops/repl.c | 6 +- src/c/ops/repl.h | 10 +- 8 files changed, 184 insertions(+), 54 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 4c83bc7..b575fb9 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -11,6 +11,7 @@ #include "debug.h" +#include "environment/function_bindings.h" #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -21,11 +22,11 @@ #include "ops/bind.h" #include "ops/string_ops.h" -#include "payloads/cons.h" -#include "payloads/exception.h" #include "payloads/psse_string.h" +#include "ops/stack_ops.h" #include "ops/truth.h" +#include "payloads/stack.h" /** * @brief Flag to prevent re-initialisation. @@ -44,7 +45,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer frame_pointer = nil; // can't have a frame pointer before we've initialised nil and t if ( c_truep( result ) ) { - debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( frame_pointer, NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { @@ -54,14 +55,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { nil = n; lock_object( nil ); - debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = nil; - debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !c_nilp( result ) ) { - debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( frame_pointer, TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words @@ -72,36 +73,39 @@ struct pso_pointer initialise_environment( uint32_t node ) { t = n; lock_object( t ); - debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = nil; - debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !exceptionp( result ) ) { result = lisp_bind( make_frame ( 3, frame_pointer, - c_string_to_lisp_symbol( frame_pointer, L"nil" ), nil, + c_string_to_lisp_symbol( frame_pointer, U"niU" ), nil, nil ) ); - debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, + debug_print( U"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); result = lisp_bind( make_frame ( 3, frame_pointer, - c_string_to_lisp_symbol( frame_pointer, L"t" ), t, + c_string_to_lisp_symbol( frame_pointer, U"t" ), t, result ) ); environment_initialised = true; - debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); + debug_print( U"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); - debug_print( L"\nEnvironment initialised successfully.\n", + debug_print( U"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); } - dec_ref( frame_pointer ); + result = initialise_function_bindings(push_local( + frame_pointer, make_frame_with_env(0, frame_pointer, result))); - return result; + dec_ref(frame_pointer); + + return result; } diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 00d026c..07a19c7 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -6,15 +6,17 @@ * Provide bindings for substrate functions. At least in theory, these * bindings only need to be initialised on node zero. * todo: they really ought to be in a namespace ::system:bootstrap, once I - * have namespaces and paths working. + * have namespaces and paths working. * * (c) 2026 Simon Brooke * Licensed under GPL version 2.0, or, at your option, any later version. */ #include +#include #include +#include "debug.h" #include "environment/privileged_keywords.h" #include "memory/node.h" #include "memory/pointer.h" @@ -23,15 +25,24 @@ #include "ops/assoc.h" #include "ops/bind.h" #include "ops/cond.h" -#include "ops/eval_apply.h" #include "ops/eq.h" +#include "ops/eval_apply.h" #include "ops/inspect.h" +#include "ops/keys.h" +#include "ops/list_ops.h" +#include "ops/mapcar.h" +#include "ops/progn.h" +#include "ops/quote.h" +#include "ops/repl.h" +#include "ops/reverse.h" #include "ops/stack_ops.h" #include "ops/string_ops.h" +#include "ops/truth.h" #include "payloads/cons.h" #include "payloads/function.h" #include "payloads/special.h" +#include "payloads/stack.h" /** * Bind this compiled `executable` function, as a Lisp function, to @@ -42,21 +53,31 @@ */ struct pso_pointer -bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, +bind_function(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); - struct pso_pointer meta = - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_bootstrap, nil), - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_name, n), - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_documentation, d), nil))); + struct pso_pointer meta = make_cons( + frame_pointer, + make_cons(frame_pointer, privileged_keyword_bootstrap, nil), + make_cons(frame_pointer, + make_cons(frame_pointer, privileged_keyword_name, n), + make_cons(frame_pointer, + make_cons(frame_pointer, + privileged_keyword_documentation, d), + nil))); struct pso_pointer r = make_function(frame_pointer, meta, executable); + debug_print(doc, DEBUG_BOOTSTRAP, 0); if (!exceptionp(r)) { - result = make_cons( frame_pointer, make_cons( frame_pointer, n, r), result); + debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0); + result = + make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); + } else { + debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0); } return result; @@ -67,21 +88,31 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, * this `name` in the `oblist`. */ struct pso_pointer -bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, +bind_special(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); - struct pso_pointer meta = - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_bootstrap, nil), - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_name, n), - make_cons( frame_pointer, make_cons( frame_pointer, privileged_keyword_documentation, d), nil))); + struct pso_pointer meta = make_cons( + frame_pointer, + make_cons(frame_pointer, privileged_keyword_bootstrap, nil), + make_cons(frame_pointer, + make_cons(frame_pointer, privileged_keyword_name, n), + make_cons(frame_pointer, + make_cons(frame_pointer, + privileged_keyword_documentation, d), + nil))); struct pso_pointer r = make_special(frame_pointer, meta, executable); + debug_print(doc, DEBUG_BOOTSTRAP, 0); if (!exceptionp(r)) { - result = make_cons( frame_pointer, make_cons( frame_pointer, n, r), result); + debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0); + result = + make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); + } else { + debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0); } return result; @@ -90,7 +121,7 @@ bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, struct function_data { char32_t *name; char32_t *documentation; - void* executable; + void *executable; }; /* right, the problem with all those pretty '#ifdefs' which might allow us to @@ -137,16 +168,70 @@ struct function_data function_initialisers[] = { &lisp_eval}, #endif #ifdef __psse_ops_inspect_h - { - U"inspect", - U"(inspect expr), (inspect expr write-stream): inspect one complete " - U"lisp expression and return `nil`. If `write-stream` is specified and " - U"is a write stream, then print to that stream, else to the stream " - U"which is the value of `*out*` in the environment.", - &lisp_inspect - }, + {U"inspect", + U"(inspect expr), (inspect expr write-stream): inspect one complete " + U"lisp expression and return `nil`. If `write-stream` is specified and " + U"is a write stream, then print to that stream, else to the stream " + U"which is the value of `*out*` in the environment.", + &lisp_inspect}, #endif -}; +#ifdef __psse_ops_keys_h + {U"keys", U"(keys store): returns a list of the keys in this `store`.", + &lisp_keys}, +#endif +#ifdef __psse_ops_list_ops_h + {U"count", + U"(count sequence): returns the number of top level elements in " + U"`sequence`.", + &count}, +#endif +#ifdef __psse_ops_mapcar_h + {U"mapcar", + U"(mapcar fn list): map this `fn` over this `list`, and return a list " + U"of the results.", + &lisp_mapcar}, +#endif +#ifdef __psse_ops_progn_h + {U"progn", + U"(progn expressions...): Evaluate each expression in " + U"`expressions` in turn and return the value of the last.", + &lisp_progn}, +#endif +#ifdef __psse_ops_repl_h + {U"repl", U"(repl show_prompt?): Start a new read, eval, print loop.", + &repl}, +#endif +#ifdef __psse_ops_reverse_h + {U"reverse", + U"(reverse sequence): return a sequence like this `sequence`, but with " + U"the order of top level elements reversed.", + &reverse}, +#endif +#ifdef __psse_ops_truth_h + {U"and", + U"(and expressions...): returns `t` if none of these `expressions...` " + U"evaluates to `nil`, else `nil`.", + &and}, + {U"nil?", + U"(nil? expression): returns `t` if `expression` evaluates to `nil`, else " + U"`nil`.", + &nilp}, + {U"not", + U"(not expression): returns `t` unless `expression` evaluates to `nil`, " + U"else " + U"`nil`.", + ¬}, + {U"or", + U"(or expressions...): returns `nil` if all of these `expressions...` " + U"evaluates to `nil`, else `t`.", + &or}, + {U"true?", + U"(true? expression): returns `t` if `expression` evaluates to `t`, else " + U"`nil`.", + &truep}, +#endif + + {U"END MARKER", U"END MARKER", NULL}}; /* right, the problem with all those pretty '#ifdefs' which might allow us to * simply switch functions on and off just by including or not including .h @@ -158,18 +243,38 @@ struct function_data function_initialisers[] = { struct function_data special_initialisers[] = { #ifdef __psse_ops_cond_h {U"cond", - U"(cond clauses...): conditional. Each `clause` is expected to be a " + U"(cond clauses...): special form; conditional. Each `clause` is expected " + U"to be a " U"list; if the first item in such a list evaluates to non-nil, the " U"remaining items in that list are evaluated in turn and the value of " U"the last returned. If no arg `clause` has a first element which " U"evaluates to non nil, then nil is returned", &lisp_cond}, #endif -}; +#ifdef __psse_ops_quote_h + {U"quote", + U"(quote expression): special form; protect `expression` from " + U"evaluation.", + "e}, +#endif + {U"END MARKER", U"END MARKER", NULL}}; struct pso_pointer initialise_function_bindings(struct pso_pointer frame_pointer) { struct pso_pointer result = fetch_env(frame_pointer); + for (int i = 0; function_initialisers[i].executable != NULL; i++) { + result = bind_function(push_local(frame_pointer, make_frame_with_env(0, frame_pointer, result)), + function_initialisers[i].name, + function_initialisers[i].documentation, + function_initialisers[i].executable); + } + for (int i = 0; special_initialisers[i].executable != NULL; i++) { + result = bind_function(push_local( frame_pointer, make_frame_with_env(0, frame_pointer, result)), + special_initialisers[i].name, + special_initialisers[i].documentation, + special_initialisers[i].executable); + } + return result; } \ No newline at end of file diff --git a/src/c/environment/function_bindings.h b/src/c/environment/function_bindings.h index e69de29..0a061f4 100644 --- a/src/c/environment/function_bindings.h +++ b/src/c/environment/function_bindings.h @@ -0,0 +1,17 @@ +/** + * environment/function_bindings.h + * + * Post Scarcity Software Environment: bootstrap function bindings. + * + * Bindings for functions written in C and available during bootstrap. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_environment_function_bindings_h +#define __psse_environment_function_bindings_h + +struct pso_pointer +initialise_function_bindings(struct pso_pointer frame_pointer); +#endif \ No newline at end of file diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h index 800d643..a383dfa 100644 --- a/src/c/ops/inspect.h +++ b/src/c/ops/inspect.h @@ -9,8 +9,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef psse_ops_inspect_h -#define psse_ops_inspect_h +#ifndef __psse_ops_inspect_h +#define __psse_ops_inspect_h #include "memory/pointer.h" diff --git a/src/c/ops/keys.h b/src/c/ops/keys.h index 3b48261..a912936 100644 --- a/src/c/ops/keys.h +++ b/src/c/ops/keys.h @@ -9,8 +9,8 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef psse_ops_keys -#define psse_ops_keys +#ifndef __psse_ops_keys_h +#define __psse_ops_keys_h struct pso_pointer c_keys( struct pso_pointer store ); diff --git a/src/c/ops/mapcar.h b/src/c/ops/mapcar.h index db0a5dd..50408a9 100644 --- a/src/c/ops/mapcar.h +++ b/src/c/ops/mapcar.h @@ -9,9 +9,9 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef psse_ops_mapcar -#define psse_ops_mapcar - +#ifndef __psse_ops_mapcar_h +#define __psse_ops_mapcar_h +struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ); #endif \ No newline at end of file diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index cc150bd..a949b25 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -48,7 +48,7 @@ void interrupt_handler( int dummy ) { /** * Very simple read/eval/print loop for bootstrapping. */ -void repl( struct pso_pointer frame_pointer ) { +struct pso_pointer repl( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); bool show_prompt = c_truep( fetch_arg( frame, 0 ) ); // todo: issue #21: must have stack frame passed in. @@ -106,5 +106,7 @@ void repl( struct pso_pointer frame_pointer ) { dec_ref( base_of_stack ); } - debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); + debug_print(L"Leaving repl\n", DEBUG_REPL, 0); + + return nil; } diff --git a/src/c/ops/repl.h b/src/c/ops/repl.h index b7ab6de..7603433 100644 --- a/src/c/ops/repl.h +++ b/src/c/ops/repl.h @@ -9,11 +9,13 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#ifndef SRC_C_OPS_REPL_H_ -#define SRC_C_OPS_REPL_H_ +#ifndef __psse_ops_repl_h +#define __psse_ops_repl_h -void repl( struct pso_pointer frame_pointer ); +#include "memory/pointer.h" + +struct pso_pointer repl( struct pso_pointer frame_pointer ); -#endif /* SRC_C_OPS_REPL_H_ */ +#endif /* __psse_ops_repl_h */ From 5ec1c926b0189bbf61d171591a92337c2a60b568 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 18:24:38 +0100 Subject: [PATCH 65/77] And, of course, I'd forgotten to add the files for `quote`. --- src/c/ops/quote.c | 26 ++++++++++++++++++++++++++ src/c/ops/quote.h | 18 ++++++++++++++++++ 2 files changed, 44 insertions(+) create mode 100644 src/c/ops/quote.c create mode 100644 src/c/ops/quote.h diff --git a/src/c/ops/quote.c b/src/c/ops/quote.c new file mode 100644 index 0000000..88ec694 --- /dev/null +++ b/src/c/ops/quote.c @@ -0,0 +1,26 @@ +/** + * ops/quote.c + * + * Post Scarcity Soctware Environment + * + * Special form: protect an expression from evaluation. + * + * Copyright (c): 25 Apr 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/pointer.h" +#include "memory/pso4.h" + +#include "ops/stack_ops.h" + +/** + * @brief Special form: protect an expression from evaluation. + * + * (quote expression) + * + * @return the expression. + */ +struct pso_pointer quote(struct pso_pointer frame_pointer){ + return fetch_arg(pointer_to_pso4(frame_pointer), 0); +} \ No newline at end of file diff --git a/src/c/ops/quote.h b/src/c/ops/quote.h new file mode 100644 index 0000000..6c6af0b --- /dev/null +++ b/src/c/ops/quote.h @@ -0,0 +1,18 @@ +/** + * ops/quote.c + * + * Post Scarcity Software Environment: quote. + * + * Special form: protect an expression from evaluation. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_ops_quote_h +#define __psse_ops_quote_h + +#include "memory/pointer.h" + +struct pso_pointer quote(struct pso_pointer frame_pointer); +#endif \ No newline at end of file From d2efc8ba78bee3401118d88a3e3f1ed7ba5b85f6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 19:26:09 +0100 Subject: [PATCH 66/77] Now happy with what's appearing in the oblist. Reader is very broken. --- src/c/environment/environment.c | 5 ++++- src/c/environment/function_bindings.c | 2 +- src/c/environment/privileged_keywords.c | 4 ++-- src/c/io/alphabets.h | 19 +++++++++++++++++++ src/c/io/print.c | 17 +++++++++++++++-- src/c/ops/string_ops.c | 5 +++-- 6 files changed, 44 insertions(+), 8 deletions(-) create mode 100644 src/c/io/alphabets.h diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index b575fb9..8ca6b42 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -12,6 +12,7 @@ #include "debug.h" #include "environment/function_bindings.h" +#include "environment/privileged_keywords.h" #include "memory/memory.h" #include "memory/node.h" #include "memory/pointer.h" @@ -100,7 +101,9 @@ struct pso_pointer initialise_environment( uint32_t node ) { debug_print( U"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); - } + } + + initialise_privileged_keywords(frame_pointer); result = initialise_function_bindings(push_local( frame_pointer, make_frame_with_env(0, frame_pointer, result))); diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 07a19c7..8b039d1 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -222,7 +222,7 @@ struct function_data function_initialisers[] = { U"`nil`.", ¬}, {U"or", - U"(or expressions...): returns `nil` if all of these `expressions...` " + U"(or expressions...): returns `nil` if every one of these `expressions...` " U"evaluates to `nil`, else `t`.", &or}, {U"true?", diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c index 394fe09..56fbd62 100644 --- a/src/c/environment/privileged_keywords.c +++ b/src/c/environment/privileged_keywords.c @@ -41,10 +41,10 @@ struct pso_pointer privileged_keyword_location; struct pso_pointer privileged_keyword_name; -#define load_and_lock(var,val)var = lock_object(c_string_to_lisp_keyword(nil, val)) +#define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val))) -struct pso_pointer initialise_privileged_keywords(struct pso_pointer env) { +struct pso_pointer initialise_privileged_keywords(struct pso_pointer frame_pointer) { load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP); load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION); load_and_lock(privileged_keyword_location, PK_LOCATION); diff --git a/src/c/io/alphabets.h b/src/c/io/alphabets.h new file mode 100644 index 0000000..60e5ff3 --- /dev/null +++ b/src/c/io/alphabets.h @@ -0,0 +1,19 @@ +/* + * io/alphabets.h + * + * Post Scarcity Software Environment: alphabets + * + * I probably don't need these at this stage and may never in fact need them, + * but... + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_io_h +#define __psse_io_io_h + +#define GREEK L"ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσςΤτΥυΦφΧχΨψΩω" +#define ELDERFUTHARK L"ᚠᚢᚦᚨᚱᚲᚷᚹᚺᚾᛁᛃᛈᛇᛉᛊᛏᛒᛖᛗᛚᛜᛞᛟ" + +#endif \ No newline at end of file diff --git a/src/c/io/print.c b/src/c/io/print.c index c627e8d..d1dfcb4 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -189,8 +189,14 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, } else { url_fputws( L"", output ); } - } - break; + } break; + case FUNCTIONTV: { + struct pso2 *function = pointer_to_object(p); + url_fputws(L"payload.function.meta, output, escape, + indent); + write_char( L'>', output, escape ); + } break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -211,6 +217,13 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, indent ); write_char( L'>', output, escape ); break; + case SPECIALTV: { + struct pso2 *function = pointer_to_object(p); + url_fputws(L"payload.function.meta, output, escape, + indent); + write_char( L'>', output, escape ); + } break; case TRUETV: write_char( L't', output, escape ); break; diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 54dbc15..95c6fc5 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -23,6 +23,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "ops/string_ops.h" #include "ops/truth.h" #include "payloads/cons.h" @@ -174,7 +175,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { /** * Return a lisp symbol representation of this wide character string. In - * symbols, I am accepting only lower case characters. + * symbols, I am accepting only lower case characters and certain punctuation. */ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, char32_t *symbol ) { @@ -183,7 +184,7 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { char32_t c = towlower( symbol[i] ); - if ( iswalpha( c ) || c == L'-' || c == L'*' ) { + if ( iswalpha( c ) || wcschr(L"-*|!?", c)) { result = make_symbol( frame_pointer, c, result ); } } From f895a8e3594c4b903aca4a221cd63d1da621b38c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 4 May 2026 21:26:36 +0100 Subject: [PATCH 67/77] Added an end of the day not to state of play --- docs/State-of-play.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 39f44ff..a7600fc 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -54,6 +54,10 @@ Dear reader, I do **not want** to collaborate with AI; I don't want any of that The conclusion for now is that I don't have a conclusion for now. Any of Gnome Builder, Zed and Gram are sort of good enough. Zed crashes, which is not desirable; Gram only launches on my laptop, but I mostly do serious development on my desktop; I can't yet work out how to launch the debugger on any of them. But none are annoying, none get in my way. I'll keep on evaluating. +### End of the day (21:22) + +`read_symbol` is breaking horribly, and a cursory glance at the code shows multiple things wrong. But the first thing wrong is that I'm not sanity-checking the arguments; and that's key because it seems that somehow the stream is getting spliced into what should be a stream of characters. That's the first place to start looking for trouble in the morning. + ## 20260503 Right, so, it's a week since my last entry. The version of eval/apply copied from `0.0.6` still doesn't compile, let alone work. There are reasons. I've been ill — my brain really is fucked — and I've had outdoor work it's felt urgent to do. From 4d480798e89c6b2f4c698c0e119be849b4da4273 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 May 2026 17:21:16 +0100 Subject: [PATCH 68/77] Tactical commit: things in 'stack_ops' really didn't belong in ops; moving. --- Makefile | 8 +- docs/State-of-play.md | 142 ++++++++++++++++++++++++++ src/c/environment/environment.c | 15 +-- src/c/io/read.c | 4 +- src/c/memory/pso.c | 81 +++++++++------ src/c/ops/reverse.c | 6 +- src/c/ops/stack_ops.c | 80 --------------- src/c/ops/stack_ops.h | 35 ------- src/c/payloads/stack.c | 173 +++++++++++++++++++------------- src/c/payloads/stack.h | 20 ++++ 10 files changed, 333 insertions(+), 231 deletions(-) delete mode 100644 src/c/ops/stack_ops.c delete mode 100644 src/c/ops/stack_ops.h diff --git a/Makefile b/Makefile index b6853b9..8609dfc 100644 --- a/Makefile +++ b/Makefile @@ -51,8 +51,14 @@ clean: coredumps: ulimit -c unlimited -repl: +repl: Makefile $(TARGET) $(TARGET) -ps1000 2> tmp/psse.log +run: Makefile $(TARGET) + $(TARGET) -ps1000v1023 2> tmp/psse.log + +install: Makefile $(TARGET) + cp $(TARGET) ~/bin + -include $(DEPS) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 39f44ff..60b6e10 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,147 @@ # State of Play +## 20260505 + +### The stack frame corruption(?) bug + +I have a weird bug in `read_symbol`, which at present I'm not understanding. + +Stack frames in `0.1.0` are [paged space objects](https://www.journeyman.cc/blog/posts-output/2026-03-23-Paged-space-objects/), like all other objects; specifically they are objects of size class 4, which is to say they have a payload size of fourteen words. The first eight arguments to the function being called (which in most cases will be all the arguments) are held directly in the frame. + +`read_symbol` expects its arguments to be as follows (I'm numbering from zero here, although I consider that perverse and confusing, because the substrate language is C which uses numbering from zero:) + +| Argument | Expected value | Expected type | +| -------- | --------------- | ------------------------------------ | +| 0 | input stream | input stream | +| 1 | read table | store (cons, hashtable or namespace) | +| 2 | first character | character object | + +`read_symbol` then reads characters sequentially from the stream until it encounters a white-space character; for each character it reads, it creates a symbol object representing that character, and conses that object onto the list of the characters it has read so far. So if the user has typed + +> xyz + +the internal representation is now a sequence + +```lisp +(z y x) +``` + +Obviously, this now has to be reversed. So `read_symbol` then calls `reverse`. But wait! Because we're still in the bootstrap layer, the version of `read_symbol` I'm talking about is written in C. So *at the time of writing* it actually calls a wrapper function called `c_reverse` which builds the Lisp stack frame for `reverse` and then calls `reverse` with that stack frame. There was an earlier version of `c_reverse` which failed to create a new stack frame, and which would account for the bug I'm seeing; but that version has been replaced and the current version does certainly create the new stack frame: + +```c +/** + * @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 c_reverse( struct pso_pointer frame_pointer, + struct pso_pointer sequence ) { + + struct pso_pointer result = nil; + + if ( stackp( frame_pointer ) ) { + result = reverse( make_frame(1, frame_pointer, sequence) ); + } + + return result; +} +``` + +So, I can see in the debugger that the sequence created in `read_symbol` is passed to `c_reverse` as the sequence argument; I can see it is put into the new frame as the first (index 0) argument; the new frame is directly passed into reverse. Reverse expects the argument in its stack frame to look like this: + +| Argument | Expected value | Expected type | +| -------- | -------------- | ------------------------------------------ | +| 0 | sequence | sequence (cons, keyword, string or symbol) | + + Reverse throws an exception: + +```lisp + +``` + +D'oh! And, of course, in trying to explain the bug, I've found the bug. It wasn't what I thought it was, so I was looking in the wrong place. It was this: + +```diff + struct pso_pointer sequence = + fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); +- for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); ++ for ( struct pso_pointer cursor = sequence; !c_nilp( cursor ); + cursor = c_cdr( cursor ) ) { + struct pso2 *object = pointer_to_object( cursor ); + switch ( get_tag_value( cursor ) ) { + +``` + +I was checking for `nil` on the sequence, which obviously didn't change, not on the cursor, which did. D'oh! + +### About debuggers + +I switched to Eclipse for this session, because Eclipse has really good, really easy to use, debugger integration. But I don't, as I said yesterday, much like Eclipse. It is too helpful; it gets in the way too much. + +Zed, Gram, Gnome Builder and VS Codium (discussed yesterday) all claim to have debugger integration, and I'm pretty sure the debugger used in all cases is the [GNU debugger, `gdb`](https://sourceware.org/gdb/) (edited: I'm wrong. Zed, and so presumably also Gram, use [`lldb`](https://lldb.llvm.org/)). `Gdb` is an excellent debugger with a truly atrocious user interface, but fortunately there's a large range of tools which wrap more or less good user interfaces around `gdb`, of which I use (and like) ['seer'](https://github.com/epasveer/seer). However it's *much* more productive to have your debugger integrated with your editor. + +I've tried this morning to get each of these to enter a useful debugging session. It has taken some work. Gnome Builder fails (for me) because although selecting `Run with Debugger` from the `run` menu does start both a `psse` session and a `gdb` session, and although terminating the `psse` session does show `[Inferior 1 (process 248474) exited normally]` on the GDB console, when I attempt to set a breakpoint (you don't seem to be able to set on in the GUI), I get the following: + +``` +> break src/c/ops/eval_apply.c:784 +Make breakpoint pending on future shared library load? (y or [n]) [answered N; input not from terminal] +> n +Cannot execute this command without a live selected thread. +``` + +So there is something alive there, and probably with a bit of struggle I could make it work. + +Zed and Gram are much the same, because Gram is a fork of Zed. Zed appears(?) to copy VS Codium's (and thus VS Code's) approach to interacting with `gdb`. VS Codium *appears*(?) to need some sort of JSON configuration in `launch.json`. I've tried this: + +```json +{ + // Use IntelliSense to learn about possible attributes. + // Hover to view descriptions of existing attributes. + // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 + "version": "0.2.0", + "configurations": [ + { + "name": "PSSE Debug (gdb Attach)", + "type": "cppdbg", + "request": "attach", + "program": "target/psse", + // "args": ["-p", "-s1000", "-v1023"], + "processId": "${command:pickProcess}", + "MIMode": "gdb", + "setupCommands": [ + { + "description": "Enable pretty-printing for gdb", + "text": "-enable-pretty-printing", + "ignoreFailures": true + } + ] + } + ] +} +``` + +It does not work, at least not in VS Codium. + +Zed's debugger [configuration documentation](https://zed.dev/docs/debugger) is better. Using it, I was able to compose this stanza: + +```json + { + "label": "PSSE Start debugger config", + "adapter": "CodeLLDB", + "request": "launch", + "program": "target/psse", + "cwd": "$ZED_WORKTREE_ROOT", + }, + +``` + +which successfully launches a debugger session. It's easy to set breakpoints in the editor windows; it's probably as easy to find your way around variables and stack frames as it is in Eclipse or Seer, once you get used to it (I haven't yet). I haven't yet worked out how to get it to automatically rebuild before running if it needs to do so, but I expect I shall. This is usable; but I shall need to get used to it. + ## 20260504 My monster, she builds! diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 8ca6b42..69a88d6 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -36,7 +36,7 @@ bool environment_initialised = false; /** * @brief Initialise a minimal environment, so that Lisp can be bootstrapped. - * + * * @param node the index of the node we are initialising. * @return a proto-environment on success, else an exception. */ @@ -81,10 +81,11 @@ struct pso_pointer initialise_environment( uint32_t node ) { } } if ( !exceptionp( result ) ) { + frame_pointer = inc_ref( make_frame(0, nil)); result = lisp_bind( make_frame ( 3, frame_pointer, - c_string_to_lisp_symbol( frame_pointer, U"niU" ), nil, + c_string_to_lisp_symbol( frame_pointer, U"nil" ), nil, nil ) ); debug_print( U"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); @@ -101,14 +102,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { debug_print( U"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); - } - initialise_privileged_keywords(frame_pointer); + initialise_privileged_keywords(frame_pointer); - result = initialise_function_bindings(push_local( - frame_pointer, make_frame_with_env(0, frame_pointer, result))); + result = inc_ref( initialise_function_bindings(push_local( + frame_pointer, make_frame_with_env(0, frame_pointer, result)))); - dec_ref(frame_pointer); + dec_ref(frame_pointer); + } return result; } diff --git a/src/c/io/read.c b/src/c/io/read.c index 5e64005..ff0f516 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -143,8 +143,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { ? 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' ); + for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) { + if ( iswdigit( c ) ){value = ( value * base ) + ( ( int ) c - ( int ) L'0' );} } url_ungetwc( c, input ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index aff210b..e16fafb 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -60,6 +60,9 @@ void print_allocation_table( ) { } #endif +struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, + uint8_t size_class); + /** * @brief a means of creating a cons cell without using a stack frame, to * prevent runaway recursion. @@ -71,7 +74,7 @@ void print_allocation_table( ) { */ struct pso_pointer cheaty_make_cons( struct pso_pointer car, struct pso_pointer cdr ) { - struct pso_pointer result = allocate( nil, CONSTAG, 2 ); + struct pso_pointer result = cheaty_allocate( nil, CONSTAG, 2 ); struct pso2 *obj = pointer_to_object( result ); obj->payload.cons.car = car; @@ -80,6 +83,46 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, return result; } +/** + * Special variant of allocate especially for cheaty_make_cons, so we don't + * get excessive spurius missing stack frame warnings. Not to be called + * outside this file! + */ +struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, + uint8_t size_class) { + struct pso_pointer result = pop_freelist( size_class ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"\nAllocating object of size class %d with tag `%s`... ", + size_class, tag ); +#endif + + struct pso2 *obj = pointer_to_object( result ); + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); + + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, + result.offset ); + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = + cheaty_make_cons( result, frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = locals; + } +#ifdef DEBUG + allocation_table[size_class][allocation_table_allocated]++; +#endif + +#ifdef DEBUG + debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, + 0 ); +#endif + + return result; +} + + /** * @brief Allocate an object of this `size_class` with this `tag`. * @@ -100,42 +143,14 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, */ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ) { - struct pso_pointer result = pop_freelist( size_class ); - if ( memory_initialised && c_nilp( frame_pointer ) ) { fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); } -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nAllocating object of size class %d with tag `%s`... ", - size_class, tag ); -#endif - struct pso2 *obj = pointer_to_object( result ); - strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, - result.offset ); - if ( stackp( frame_pointer ) ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - // You can't make a stack frame in the middle of making a stack - // frame. Infinite recursion. So we have to cheat. - struct pso_pointer locals = - cheaty_make_cons( result, frame->payload.stack_frame.locals ); - frame->payload.stack_frame.locals = locals; - } -#ifdef DEBUG - allocation_table[size_class][allocation_table_allocated]++; -#endif - -#ifdef DEBUG - debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, - 0 ); -#endif - - return result; + return cheaty_allocate(frame_pointer, tag, size_class); } + int payload_size( struct pso2 *object ) { // TODO: Unit tests DEFINITELY needed! int sc = object->header.tag.bytes.size_class; @@ -157,7 +172,7 @@ int payload_size( struct pso2 *object ) { */ struct pso_pointer inc_ref( struct pso_pointer pointer ) { if ( c_nilp( pointer ) || c_truep( pointer ) ) { - /* You can't do this and there's no point trying or cluttering the + /* You can't do this and there's no point trying or cluttering the logs. */ return pointer; } else if ( freep( pointer ) ) { @@ -204,7 +219,7 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { */ struct pso_pointer dec_ref( struct pso_pointer pointer ) { if ( c_nilp( pointer ) || c_truep( pointer ) ) { - /* You can't do this and there's no point trying or cluttering the + /* You can't do this and there's no point trying or cluttering the logs. */ return pointer; } else if ( freep( pointer ) ) { diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index 296aaf3..c25a5b0 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -26,6 +26,7 @@ #include "ops/string_ops.h" #include "ops/truth.h" +#include "payloads/stack.h" /** * @brief reverse a sequence @@ -36,7 +37,7 @@ struct pso_pointer reverse( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer sequence = fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); - for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); + for ( struct pso_pointer cursor = sequence; !c_nilp( cursor ); cursor = c_cdr( cursor ) ) { struct pso2 *object = pointer_to_object( cursor ); switch ( get_tag_value( cursor ) ) { @@ -104,7 +105,8 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer result = nil; if ( stackp( frame_pointer ) ) { - result = reverse( frame_pointer ); + result = reverse( make_frame(1, frame_pointer, sequence) ); } + return result; } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c deleted file mode 100644 index f1d14ea..0000000 --- a/src/c/ops/stack_ops.c +++ /dev/null @@ -1,80 +0,0 @@ -/** - * payloads/stack.c - * - * The execution stack. - * - * (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/pso2.h" -#include "memory/pso4.h" -#include "memory/tags.h" - -#include "payloads/cons.h" -#include "payloads/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. - * - * TODO: I think the first argument would be better as a pso_pointer. - */ -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 < frame->payload.stack_frame.args ) { - result = frame->payload.stack_frame.arg[index]; - } else { - 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; - } - - result = pointer_to_object( p )->payload.cons.car; - } - - return result; -} - -/** - * @brief Return the environment from the stack frame identified by this - * `frame_pointer` - * - * @param frame_pointer a pointer to a stack frame. - */ -struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { - return stackp( frame_pointer ) ? - pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; -} - -/** - * Push a binding (and therefore a reference) for this `local` onto the - * stack_frame indicated by this `frame_pointer`, thereby protecting the - * `local` from garbage collection until the frame itself is disposed of. - * - * This is a hack. For Lisp functions, where the stack frames are set up - * and torn down by eval/apply, it shouldn't be necessary. - */ -struct pso_pointer push_local( struct pso_pointer frame_pointer, - struct pso_pointer local ) { - if ( stackp( frame_pointer ) ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - - struct pso_pointer l = make_cons( frame_pointer, local, - frame->payload.stack_frame.locals ); - frame->payload.stack_frame.locals = l; - } - - return local; -} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h deleted file mode 100644 index 059f61e..0000000 --- a/src/c/ops/stack_ops.h +++ /dev/null @@ -1,35 +0,0 @@ -/** - * 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 ); - -struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); - -struct pso_pointer push_local( struct pso_pointer frame_pointer, - struct pso_pointer local ); - -#endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 75472f5..978f356 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -26,6 +26,69 @@ #include "ops/list_ops.h" #include "ops/stack_ops.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. + * + * TODO: I think the first argument would be better as a pso_pointer. + */ +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 < frame->payload.stack_frame.args ) { + result = frame->payload.stack_frame.arg[index]; + } else { + 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; + } + + result = pointer_to_object( p )->payload.cons.car; + } + + return result; +} + +/** + * @brief Return the environment from the stack frame identified by this + * `frame_pointer` + * + * @param frame_pointer a pointer to a stack frame. + */ +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { + return stackp( frame_pointer ) ? + pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; +} + +/** + * Push a binding (and therefore a reference) for this `local` onto the + * stack_frame indicated by this `frame_pointer`, thereby protecting the + * `local` from garbage collection until the frame itself is disposed of. + * + * This is a hack. For Lisp functions, where the stack frames are set up + * and torn down by eval/apply, it shouldn't be necessary. + */ +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ) { + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer l = make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = l; + } + + return local; +} + /** * @brief Add an argument to this (already initialised) stack frame, updating * the args count. @@ -60,22 +123,11 @@ struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer } /** - * @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. - * - * @param arg_count the count of arguments to the Lisp function. - * @param previous the parent stack frame. - * @param ... the arguments to the Lisp function, all of which must be of type - * `struct pso_pointer`. - * @return struct pso_pointer a pointer to a populated stack frame which may be - * passed to the Lisp function. + * @brief internal shared guts of make_frame variants. **Does not** set up the + * `env` pointer of the new frame -- callers are responsible for doing so. */ -struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, - ... ) { - va_list args; - va_start( args, previous ); - +struct pso_pointer in_make_frame( int arg_count, struct pso_pointer previous, + va_list args ) { /* NOTE! It is really important not to `push_local` the new_pointer here, * since that would stop stack frames and all the temporary objects they * curate ever being garbage collected! */ @@ -94,13 +146,13 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, struct pso4 *prev_frame = pointer_to_pso4( previous ); new_frame->payload.stack_frame.depth = prev_frame->payload.stack_frame.depth + 1; - new_frame->payload.stack_frame.env = - prev_frame->payload.stack_frame.env; + new_frame->payload.stack_frame.previous = inc_ref( previous ); } else { new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.previous = nil; } - new_frame->payload.stack_frame.previous = inc_ref( previous ); + new_frame->payload.stack_frame.env = nil; debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", new_frame->payload.stack_frame.depth ); @@ -136,6 +188,34 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, return new_pointer; } +/** + * @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. + * + * @param arg_count the count of arguments to the Lisp function. + * @param previous the parent stack frame. + * @param ... the arguments to the Lisp function, all of which must be of type + * `struct pso_pointer`. + * @return struct pso_pointer a pointer to a populated stack frame which may be + * passed to the Lisp function. + */ +struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, + ... ) { + va_list args; + va_start( args, previous ); + + struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); + struct pso4* new_frame = pointer_to_pso4(new_pointer); + + new_frame->payload.stack_frame.env = stackp(previous) ? + inc_ref(pointer_to_pso4(previous)->payload.stack_frame.env) : nil; + + va_end(args); + + return new_pointer; +} + /** * @brief variant of make_frame with an explicit replacement environment, to * be called by functions like `binding` which add bindings to their upstack @@ -158,60 +238,10 @@ struct pso_pointer make_frame_with_env( int arg_count, va_list args; va_start( args, env ); - struct pso4 *prev_frame = pointer_to_pso4( previous ); - /* NOTE! It is really important not to `push_local` the new_pointer here, - * since that would stop stack frames and all the temporary objects they - * curate ever being garbage collected! */ - struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 ); - struct pso4 *new_frame = pointer_to_pso4( new_pointer ); + struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); + pointer_to_pso4(new_pointer)->payload.stack_frame.env = inc_ref( env); -#ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nAllocating stack frame with %d arguments at page %d, " - L"offset %d...\n", - arg_count, new_pointer.page, new_pointer.offset ); -#endif - - prev_frame->payload.stack_frame.previous = inc_ref( previous ); - - if ( stackp( previous ) ) { - new_frame->payload.stack_frame.depth = - prev_frame->payload.stack_frame.depth + 1; - } else { - new_frame->payload.stack_frame.depth = 0; - } - - debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", - new_frame->payload.stack_frame.depth ); - - int cursor = 0; - new_frame->payload.stack_frame.args = arg_count; - new_frame->payload.stack_frame.env = env; - - for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) { - struct pso_pointer argument = va_arg( args, struct pso_pointer ); - - new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument ); - } - if ( cursor < arg_count ) { - struct pso_pointer more_args = nil; - - for ( ; cursor < arg_count; cursor++ ) { - more_args = - make_cons( previous, va_arg( args, struct pso_pointer ), - more_args ); - } - - new_frame->payload.stack_frame.more = c_reverse( previous, more_args ); - } else { - for ( ; cursor < args_in_frame; cursor++ ) { - new_frame->payload.stack_frame.arg[cursor] = nil; - } - } - - debug_printf( DEBUG_ALLOC, 1, - L"Allocation of stack frame at page %d, offset %d completed.\n", - new_pointer.page, new_pointer.offset ); + va_end(args); return new_pointer; } @@ -258,6 +288,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer inc_ref( prev_frame->payload.stack_frame.env ); } else { new_frame->payload.stack_frame.depth = 0; + new_frame->payload.stack_frame.env = nil; } debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index d89d705..62f9a7b 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -41,6 +41,26 @@ struct stack_frame_payload { uint32_t depth; }; +/* + * 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 ); + +struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); + +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ); + + struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, ... ); From 818293d4f146446ec89c8e29e9aee86189296c83 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 May 2026 19:16:44 +0100 Subject: [PATCH 69/77] Moved everything from ops/stack_ops (which were not ops) to payloads/stack. Added io functions to function_bindings. --- Makefile | 4 +- src/c/environment/environment.c | 2 +- src/c/environment/function_bindings.c | 56 ++++++++++++++++++++++++++- src/c/io/io.c | 24 ++++-------- src/c/io/io.h | 37 +++++++----------- src/c/io/peek.c | 42 ++++++++++++++++++++ src/c/io/peek.h | 20 ++++++++++ src/c/io/print.c | 4 +- src/c/io/read.c | 2 +- src/c/memory/memory.c | 3 +- src/c/memory/node.c | 2 +- src/c/memory/pso4.h | 2 +- src/c/ops/assoc.c | 2 +- src/c/ops/bind.c | 2 +- src/c/ops/cond.c | 2 +- src/c/ops/dump.c | 2 +- src/c/ops/eq.c | 2 +- src/c/ops/eval_apply.c | 2 +- src/c/ops/inspect.c | 2 +- src/c/ops/list_ops.c | 2 +- src/c/ops/mapcar.c | 2 +- src/c/ops/progn.c | 2 +- src/c/ops/quote.c | 2 +- src/c/ops/repl.c | 2 +- src/c/ops/reverse.c | 2 +- src/c/ops/truth.c | 2 +- src/c/payloads/cons.c | 2 +- src/c/payloads/exception.c | 2 +- src/c/payloads/psse_string.c | 2 +- src/c/payloads/read_stream.c | 3 ++ src/c/payloads/stack.c | 2 +- src/c/payloads/stack.h | 28 +------------- src/c/payloads/stack_payload.h | 45 +++++++++++++++++++++ src/c/psse.c | 1 - 34 files changed, 217 insertions(+), 94 deletions(-) create mode 100644 src/c/io/peek.c create mode 100644 src/c/io/peek.h create mode 100644 src/c/payloads/stack_payload.h diff --git a/Makefile b/Makefile index 8609dfc..97bbf76 100644 --- a/Makefile +++ b/Makefile @@ -52,10 +52,10 @@ coredumps: ulimit -c unlimited repl: Makefile $(TARGET) - $(TARGET) -ps1000 2> tmp/psse.log + $(TARGET) -p -s1000 -v1023 2> tmp/psse.log run: Makefile $(TARGET) - $(TARGET) -ps1000v1023 2> tmp/psse.log + $(TARGET) -p -s1000 -v1023 2> tmp/psse.log install: Makefile $(TARGET) cp $(TARGET) ~/bin diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 69a88d6..27c9fa5 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -25,7 +25,7 @@ #include "payloads/psse_string.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" #include "payloads/stack.h" diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 8b039d1..50225a9 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -18,6 +18,12 @@ #include "debug.h" #include "environment/privileged_keywords.h" + +#include "io/io.h" +#include "io/peek.h" +#include "io/print.h" +#include "io/read.h" + #include "memory/node.h" #include "memory/pointer.h" #include "memory/tags.h" @@ -35,7 +41,7 @@ #include "ops/quote.h" #include "ops/repl.h" #include "ops/reverse.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -133,6 +139,54 @@ struct function_data { /** initialisers for functions */ struct function_data function_initialisers[] = { +#ifdef _psse_io_io_h + {U"close", U"(close stream): close `stream`.", &lisp_close}, + {U"open", + U"(open stream), (open stream write?): open `stream`; if `write?` is " + U"present and is non-nil, open for writing, else for reading.", + &lisp_open}, + {U"slurp", + U"(slurp stream): read the whole contents of this `stream`, " + U"which may " + U"be an open stream open for reading or a URL, into a string, and return " + U"the " + U"string.", + &lisp_slurp}, +#endif +#ifdef __psse_io_peek_h + {U"peek", + U"(peek stream): return the next character which may be read from " + U"`stream`, without removing it.", + &peek}, +#endif +#ifdef __psse_io_print_h + {U"print", + U"(print object), (print object stream) print this `object` in a format " + U"suitable to be read by `read`, q.v.; if `stream` is specified and is a " + U"stream open for writing, to that stream.", + &print}, + {U"princ", + U"(princ object), (princ object stream) print this `object` in a format " + U"more suited to human readers; if `stream` is specified and is a stream " + U"open for writing, to that stream.", + &print}, +#endif +#ifdef __psse_io_read_h + {U"read", + U"(read stream) read one complete Lisp expression from `stream`, and " + U"return that expression unevaluated.", + &read}, + {U"read-character", + U"(read_character stream): read a single character from `stream` and " + U"return it.", + &read_character}, + {U"read_number", + U"(read-number stream): read a number from `stream` and return it.", + &read_number}, + {U"read_symbol", + U"(read-symbol stream): read a symbol from `stream` and return it.", + &read_symbol}, +#endif #ifdef __psse_ops_assoc_h {U"assoc", U"(assoc key store): search `store` for the value associated with " diff --git a/src/c/io/io.c b/src/c/io/io.c index 9a95c2f..4636bc3 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -47,7 +47,7 @@ #include "ops/assoc.h" #include "ops/bind.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" @@ -393,8 +393,7 @@ struct pso_pointer push_back_character( struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer lisp_close( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_close( struct pso_pointer frame_pointer) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) { @@ -591,14 +590,10 @@ URL_FILE *stream_get_url_file( struct pso_pointer s ) { * * * (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. + * @return a stream open on the URL indicated by the first argument. */ -struct pso_pointer lisp_open( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_open( struct pso_pointer frame_pointer) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; if ( stringp( fetch_arg( frame, 0 ) ) ) { @@ -650,18 +645,13 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer, * 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. + * @return return a string representing all characters from the stream + * indicated by arg 0 */ -struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer, - struct pso_pointer env ) { +struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; if ( readp( fetch_arg( frame, 0 ) ) ) { diff --git a/src/c/io/io.h b/src/c/io/io.h index baf9e52..cd37d5d 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -11,8 +11,8 @@ #ifndef __psse_io_io_h #define __psse_io_io_h -#include #include +#include /* * wide characters @@ -24,12 +24,11 @@ extern CURLSH *io_share; -int initialise_io( ); -struct pso_pointer initialise_default_streams( struct pso_pointer - frame_pointer, - struct pso_pointer env ); +int initialise_io(); +struct pso_pointer initialise_default_streams(struct pso_pointer frame_pointer, + struct pso_pointer env); -#define C_IO_IN L"*in*" +#define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" #define C_IO_LOG L"*log*" #define C_IO_READBASE L"*read_base*" @@ -50,25 +49,19 @@ extern struct pso_pointer lisp_stderr; extern struct pso_pointer lisp_io_prompt; +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 push_back_character(struct pso_pointer c, + struct pso_pointer r); -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); +URL_FILE *stream_get_url_file(struct pso_pointer s); -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 ); - -URL_FILE *stream_get_url_file( struct pso_pointer s ); - -struct pso_pointer -lisp_close( struct pso_pointer frame_pointer, struct pso_pointer env ); -struct pso_pointer -lisp_open( struct pso_pointer frame_pointer, struct pso_pointer env ); -struct pso_pointer -lisp_slurp( struct pso_pointer frame_pointer, struct pso_pointer env ); +struct pso_pointer lisp_close(struct pso_pointer frame_pointer); +struct pso_pointer lisp_open(struct pso_pointer frame_pointer); +struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer); #endif diff --git a/src/c/io/peek.c b/src/c/io/peek.c new file mode 100644 index 0000000..b926456 --- /dev/null +++ b/src/c/io/peek.c @@ -0,0 +1,42 @@ +/** + * io/peek.c + * + * Post Scarcity Software Environment: peek. + * + * look at the next character on the input stream, without consuming it. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "io/fopen.h" +#include "io/io.h" + +#include "memory/node.h" +#include "memory/pointer.h" +#include "memory/pso2.h" + +#include "payloads/character.h" + +/** + * @brief look at the next character on the input stream, without consuming it. + * + * (peek stream) + */ +struct pso_pointer peek(struct pso_pointer frame_pointer) { + struct pso_pointer result = nil; + struct pso_pointer input = + pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0]; + + if (readp(input)) { + URL_FILE *stream = pointer_to_object(input)->payload.stream.stream; + wint_t c = url_fgetwc(stream); + url_ungetwc(c, stream); + + result = make_character(frame_pointer, c); + } + return result; +} + diff --git a/src/c/io/peek.h b/src/c/io/peek.h new file mode 100644 index 0000000..06b6b3f --- /dev/null +++ b/src/c/io/peek.h @@ -0,0 +1,20 @@ +/** + * io/peek.c + * + * Post Scarcity Software Environment: peek. + * + * peek basic Lisp objects..This is :bootstrap layer peek; it needs to be + * able to peek characters, symbols, integers, lists and dotted pairs. I + * don't think it needs to be able to peek anything else. + * + * (c) 2026 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_peek_h +#define __psse_io_peek_h +#include + +struct pso_pointer peek( struct pso_pointer frame_pointer ); + +#endif diff --git a/src/c/io/print.c b/src/c/io/print.c index d1dfcb4..a850e72 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -44,7 +44,7 @@ #include "payloads/exception.h" #include "payloads/integer.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, @@ -295,6 +295,8 @@ struct pso_pointer c_write(struct pso_pointer frame_pointer, /** * @brief Simple print for bootstrap layer. * + * (print object stream) + * * @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. diff --git a/src/c/io/read.c b/src/c/io/read.c index ff0f516..5c09457 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -40,7 +40,7 @@ #include "ops/assoc.h" #include "ops/reverse.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index bc1e722..efb9f81 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -23,11 +23,12 @@ #include "memory/pso2.h" #include "memory/tags.h" -#include "ops/truth.h" #include "payloads/exception.h" +#include "payloads/stack.h" #include "ops/bind.h" #include "ops/string_ops.h" +#include "ops/truth.h" /** * @brief Freelists for each size class. diff --git a/src/c/memory/node.c b/src/c/memory/node.c index 42ff995..015164d 100644 --- a/src/c/memory/node.c +++ b/src/c/memory/node.c @@ -22,7 +22,7 @@ #include "payloads/exception.h" #include "ops/eq.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" diff --git a/src/c/memory/pso4.h b/src/c/memory/pso4.h index 59996f7..cae50b2 100644 --- a/src/c/memory/pso4.h +++ b/src/c/memory/pso4.h @@ -15,7 +15,7 @@ #include "memory/header.h" #include "payloads/free.h" -#include "payloads/stack.h" +#include "payloads/stack_payload.h" /** * @brief A paged space object of size class 4, 16 words total, 14 words diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 647b7bf..401aeb1 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -21,7 +21,7 @@ #include "payloads/stack.h" #include "ops/eq.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" /** diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index 743de6b..fbcbfe5 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -16,7 +16,7 @@ #include "memory/pso4.h" #include "memory/tags.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "payloads/cons.h" #include "payloads/function.h" diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index f2949d4..f22a20f 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -13,7 +13,7 @@ #include "ops/eval_apply.h" #include "ops/progn.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" diff --git a/src/c/ops/dump.c b/src/c/ops/dump.c index f50cc14..c39b871 100644 --- a/src/c/ops/dump.c +++ b/src/c/ops/dump.c @@ -23,7 +23,7 @@ #include "memory/tags.h" #include "io/print.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "payloads/lambda.h" diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index d7b4f38..17e0f11 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -19,7 +19,7 @@ #include "payloads/function.h" #include "payloads/integer.h" #include "payloads/stack.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" /** diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 361c911..03c1411 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -33,7 +33,7 @@ #include "ops/eval_apply.h" #include "ops/progn.h" #include "ops/reverse.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c index 9d3ce60..67c883d 100644 --- a/src/c/ops/inspect.c +++ b/src/c/ops/inspect.c @@ -18,7 +18,7 @@ #include "memory/pso4.h" #include "memory/tags.h" #include "ops/inspect.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" /** * Function: dump/ diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 6ef05b9..5cb3151 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -12,7 +12,7 @@ #include "memory/pso2.h" #include "memory/pso4.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "payloads/cons.h" #include "payloads/integer.h" diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index 5f74aae..e09379d 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -19,7 +19,7 @@ #include "ops/eval_apply.h" #include "ops/reverse.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" #include "payloads/cons.h" diff --git a/src/c/ops/progn.c b/src/c/ops/progn.c index ac3f722..3fdef99 100644 --- a/src/c/ops/progn.c +++ b/src/c/ops/progn.c @@ -17,7 +17,7 @@ #include "memory/tags.h" #include "ops/eval_apply.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "payloads/cons.h" #include "payloads/stack.h" diff --git a/src/c/ops/quote.c b/src/c/ops/quote.c index 88ec694..f1d3595 100644 --- a/src/c/ops/quote.c +++ b/src/c/ops/quote.c @@ -12,7 +12,7 @@ #include "memory/pointer.h" #include "memory/pso4.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" /** * @brief Special form: protect an expression from evaluation. diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index a949b25..8d04f09 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -33,7 +33,7 @@ #include "ops/assoc.h" #include "ops/eval_apply.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" /** diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index c25a5b0..a9be24f 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -19,7 +19,7 @@ #include "memory/pso4.h" #include "memory/tags.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/psse_string.h" diff --git a/src/c/ops/truth.c b/src/c/ops/truth.c index 4b7b9d8..9ac4ef0 100644 --- a/src/c/ops/truth.c +++ b/src/c/ops/truth.c @@ -14,7 +14,7 @@ #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso4.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" /** * @brief true if `p` points to `nil`, else false. diff --git a/src/c/payloads/cons.c b/src/c/payloads/cons.c index dccdf13..cfca981 100644 --- a/src/c/payloads/cons.c +++ b/src/c/payloads/cons.c @@ -19,7 +19,7 @@ #include "payloads/cons.h" #include "payloads/exception.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/string_ops.h" /** diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 7f40fc5..08dbfef 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -26,7 +26,7 @@ #include "payloads/exception.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" #include "ops/truth.h" #include "payloads/cons.h" #include diff --git a/src/c/payloads/psse_string.c b/src/c/payloads/psse_string.c index cc5eaef..a7d8dbe 100644 --- a/src/c/payloads/psse_string.c +++ b/src/c/payloads/psse_string.c @@ -23,7 +23,7 @@ #include "ops/string_ops.h" #include "payloads/cons.h" -#include "ops/stack_ops.h" +#include "payloads/stack.h" /** diff --git a/src/c/payloads/read_stream.c b/src/c/payloads/read_stream.c index 9cdce09..2058473 100644 --- a/src/c/payloads/read_stream.c +++ b/src/c/payloads/read_stream.c @@ -12,6 +12,9 @@ #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" diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 978f356..2e299a4 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -21,10 +21,10 @@ #include "memory/tags.h" #include "payloads/cons.h" +#include "payloads/stack.h" #include "ops/reverse.h" #include "ops/list_ops.h" -#include "ops/stack_ops.h" /** * @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 62f9a7b..7c20409 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -13,33 +13,7 @@ #define __psse_payloads_stack_h #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 pso_pointer previous; - /** first 8 arument bindings. */ - struct pso_pointer arg[args_in_frame]; - /** list of any further argument bindings. */ - struct pso_pointer more; - /** the function to be called. */ - struct pso_pointer function; - /** the execute-time environment */ - struct pso_pointer env; - /** a list of objects created in the context of this frame */ - struct pso_pointer locals; - /** the number of arguments provided. */ - uint32_t args; - /** the depth of the stack below this frame */ - uint32_t depth; -}; +#include "payloads/stack_payload.h" /* * number of arguments stored in a stack frame diff --git a/src/c/payloads/stack_payload.h b/src/c/payloads/stack_payload.h new file mode 100644 index 0000000..95a9c2a --- /dev/null +++ b/src/c/payloads/stack_payload.h @@ -0,0 +1,45 @@ +/** + * payloads/stack_payload.h + * + * payload struct itself separated out from functions which interrogate it + * to avoid circularity with pso4. + * + * 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_payload_h +#define __psse_payloads_stack_payload_h + +#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 pso_pointer previous; + /** first 8 arument bindings. */ + struct pso_pointer arg[args_in_frame]; + /** list of any further argument bindings. */ + struct pso_pointer more; + /** the function to be called. */ + struct pso_pointer function; + /** the execute-time environment */ + struct pso_pointer env; + /** a list of objects created in the context of this frame */ + struct pso_pointer locals; + /** the number of arguments provided. */ + uint32_t args; + /** the depth of the stack below this frame */ + uint32_t depth; +}; + +#endif \ No newline at end of file diff --git a/src/c/psse.c b/src/c/psse.c index bf7c745..0208c23 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -27,7 +27,6 @@ #include "memory/tags.h" #include "ops/repl.h" -#include "ops/stack_ops.h" #include "ops/string_ops.h" #include "ops/truth.h" From cf655e8020abc9785588d1e22db8880a9a07f1d9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 09:16:46 +0100 Subject: [PATCH 70/77] Investigating why symbols created by `read` are not equal to those created in C. --- src/c/environment/function_bindings.c | 16 ++-- src/c/io/read.c | 24 +++++- src/c/ops/assoc.c | 23 +++++- src/c/ops/eval_apply.c | 112 ++------------------------ src/c/ops/string_ops.c | 5 +- src/c/payloads/symbol.h | 10 +++ 6 files changed, 67 insertions(+), 123 deletions(-) diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 50225a9..cae295e 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -177,13 +177,13 @@ struct function_data function_initialisers[] = { U"return that expression unevaluated.", &read}, {U"read-character", - U"(read_character stream): read a single character from `stream` and " + U"(read-character stream): read a single character from `stream` and " U"return it.", &read_character}, - {U"read_number", + {U"read-number", U"(read-number stream): read a number from `stream` and return it.", &read_number}, - {U"read_symbol", + {U"read-symbol", U"(read-symbol stream): read a symbol from `stream` and return it.", &read_symbol}, #endif @@ -318,16 +318,18 @@ initialise_function_bindings(struct pso_pointer frame_pointer) { struct pso_pointer result = fetch_env(frame_pointer); for (int i = 0; function_initialisers[i].executable != NULL; i++) { - result = bind_function(push_local(frame_pointer, make_frame_with_env(0, frame_pointer, result)), + struct pso_pointer b = c_car( bind_function( frame_pointer, function_initialisers[i].name, function_initialisers[i].documentation, - function_initialisers[i].executable); + function_initialisers[i].executable)); + result = make_cons( frame_pointer, b, result); } for (int i = 0; special_initialisers[i].executable != NULL; i++) { - result = bind_function(push_local( frame_pointer, make_frame_with_env(0, frame_pointer, result)), + struct pso_pointer b = c_car( bind_special( frame_pointer, special_initialisers[i].name, special_initialisers[i].documentation, - special_initialisers[i].executable); + special_initialisers[i].executable)); + result = make_cons( frame_pointer, b, result); } return result; diff --git a/src/c/io/read.c b/src/c/io/read.c index 5c09457..fa244c8 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -33,10 +33,12 @@ #include "memory/tags.h" #include "payloads/character.h" +#include "payloads/cons.h" #include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" #include "payloads/read_stream.h" +#include "payloads/symbol.h" #include "ops/assoc.h" #include "ops/reverse.h" @@ -150,6 +152,9 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { url_ungetwc( c, input ); result = make_integer( frame_pointer, value ); } // else exception? +#ifdef DEBUG + debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); +#endif return result; } @@ -171,7 +176,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { ? 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 ) ) { + for ( ; symbol_char_p( c ); c = url_fgetwc( input ) ) { result = make_string_like_thing( frame_pointer, c, result, SYMBOLTAG ); } @@ -180,6 +185,17 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { result = c_reverse( frame_pointer, result ); } +#ifdef DEBUG + debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0); + debug_print( L"`\n\t", DEBUG_IO, 0); + for ( struct pso_pointer cursor = result; !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_IO, 0, L"[Character %lc (%d)]", c, c); + } + debug_println(DEBUG_IO); +#endif + return result; } @@ -244,7 +260,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { inc_ref( next ); if ( iswdigit( c ) ) { result = push_local( frame_pointer, read_number( next ) ); - } else if ( iswalpha( c ) ) { + } else if ( symbol_char_p( c ) ) { result = push_local( frame_pointer, read_symbol( next ) ); } else { // result = @@ -268,9 +284,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } } #ifdef DEBUG - debug_print( L"Read object: ", DEBUG_IO, 0 ); + debug_print( L"Read expression: `", DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 ); - debug_println( DEBUG_IO ); + debug_print( L"`\n", DEBUG_IO, 0 ); #endif return result; diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 401aeb1..6b68a19 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -42,9 +42,16 @@ struct pso_pointer search( struct pso_pointer key, bool found = false; #ifdef DEBUG - debug_print( L"In search; key is: ", DEBUG_BIND, 0 ); + debug_print( L"In search; key is: `", DEBUG_BIND, 0 ); debug_print_object( key, DEBUG_BIND, 0 ); - debug_println( DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND, 0 ); + debug_print(L"", DEBUG_BIND, 2); + if (symbolp(key)) { + for ( struct pso_pointer cursor = key; !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); + } + } #endif if ( consp( store ) ) { @@ -53,7 +60,17 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer pair = c_car( cursor ); #ifdef DEBUG debug_print( L"Checking ", DEBUG_BIND, 2 ); - debug_print_object( pair, DEBUG_BIND, 0 ); + debug_print_object( c_car( pair), DEBUG_BIND, 0 ); + debug_println( DEBUG_BIND); + debug_print(L"", DEBUG_BIND, 4); + if (symbolp(c_car( pair))) { + for ( struct pso_pointer cursor = c_car(pair); !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); + } + } + debug_println(DEBUG_BIND); + #endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 03c1411..5ced0e2 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -45,112 +45,6 @@ #include "payloads/stack.h" #include "payloads/symbol.h" -///** -// * @brief Apply a function to arguments in an environment. -// * -// * * (apply fn args) -// */ -//struct pso_pointer apply( struct pso_pointer frame_pointer ) { -// -//// TODO. -// -//} -// -///** -// * @brief Evaluate a form, in an environment -// * -// * * (eval form) -// */ -//struct pso_pointer eval( struct pso_pointer frame_pointer ) { -// struct pso4 *frame = pointer_to_pso4( frame_pointer ); -// -// struct pso_pointer arg = fetch_arg( frame, 0 ); -// struct pso_pointer result = nil; -// -// if ( !c_c_nilp( arg ) ) { -// switch ( get_tag_value( arg ) ) { -// // case CONSTV: -// // result = eval_cons( frame, frame_pointer, env); -// // break; -// case INTEGERTV: -// case KEYTV: -// case NILTV: -// case STRINGTV: -// // self evaluating -// result = nil; -// break; -// case SYMBOLTV: -// result = c_assoc( arg, fetch_env( frame_pointer ) ); -// 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; -// default: -//#ifdef DEBUG -// struct pso2 *object = pointer_to_object( arg ); -// debug_printf( DEBUG_EVAL, 0, -// L"Can't yet evaluate objects of type %3.3s\n", -// object->header.tag.bytes.mnemonic[0] ); -// debug_print_object( arg, DEBUG_EVAL, 2 ); -// debug_println( DEBUG_EVAL, 0 ); -//#endif -// result = make_exception( make_frame( 1, frame_pointer, -// make_cons( frame_pointer, -// c_string_to_lisp_string -// ( frame_pointer, -// L"Can't yet evaluate things of this type: " ), -// arg ), -// make_cons( frame_pointer, -// make_cons -// ( frame_pointer, -// c_string_to_lisp_keyword -// ( frame_pointer, -// L"tag" ), -// get_tag_string -// ( frame_pointer, -// arg ) ), -// nil ), nil ) ); -// } -// } -// -// if ( exceptionp( result ) ) { -// struct pso3 *x = -// ( struct pso3 * ) pointer_to_object_with_tag_value( result, -// EXCEPTIONTV ); -// -// if ( c_c_nilp( x->payload.exception.stack ) ) { -// x->payload.exception.stack = frame_pointer; -// } -// } -// -// return result; -//} -/* - * lispops.c - * - * List processing operations. - * - * The general idea here is that a list processing operation is a - * function which takes two arguments, both pso_pointers: - * - * 1. args, the argument list to this function; - * 2. env, the environment in which this function should be evaluated; - * - * and returns a pso_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. - */ - /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. @@ -779,6 +673,12 @@ lisp_eval( struct pso_pointer frame_pointer ) { case SYMBOLTV: { +#ifdef DEBUG + debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0); + debug_print_object( fetch_arg( frame, 0), DEBUG_EVAL, 0); + debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0); + debug_dump_object( fetch_env(frame_pointer), DEBUG_EVAL, 0); +#endif struct pso_pointer canonical = c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); if ( c_nilp( canonical ) ) { diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 95c6fc5..c9ff224 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -172,7 +172,6 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { return result; } - /** * Return a lisp symbol representation of this wide character string. In * symbols, I am accepting only lower case characters and certain punctuation. @@ -182,9 +181,9 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_t c = towlower( symbol[i] ); + char32_t c = symbol[i]; - if ( iswalpha( c ) || wcschr(L"-*|!?", c)) { + if ( symbol_char_p(c)) { result = make_symbol( frame_pointer, c, result ); } } diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index 3460983..2b0dd48 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -14,6 +14,16 @@ #include "memory/pointer.h" +/** + * @brief true if the argument `wc`, a wide character, is suitable for + * inclusion in a symbol. + * + * Note that Common Lisp is *much* less restrictive + * than this currently is, so rethinking may be necessary. + */ +#define symbol_char_p(wc)(iswalpha( wc ) || wcschr(L"-*|!?", wc)) + + /* 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. */ From c29a95b00d5111a43b6516d1210d94945856cee0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 12:23:46 +0100 Subject: [PATCH 71/77] Got `dump` working, to try to investigate the `assoc` bug. Much better dump output, but `assoc` still doesn't work for read symbols, and we now have a segfault on exit. --- src/c/debug.c | 4 +- src/c/io/io.c | 2 +- src/c/io/read.c | 12 +- src/c/memory/dump.c | 494 ++++++++++++++++++++++------------------- src/c/memory/dump.h | 2 +- src/c/memory/tags.h | 1 + src/c/ops/assoc.c | 24 +- src/c/ops/dump.c | 154 ------------- src/c/ops/dump.h | 0 src/c/ops/eval_apply.c | 2 + 10 files changed, 284 insertions(+), 411 deletions(-) delete mode 100644 src/c/ops/dump.c delete mode 100644 src/c/ops/dump.h diff --git a/src/c/debug.c b/src/c/debug.c index 6c4796d..a375dee 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -19,7 +19,7 @@ #include "io/io.h" #include "io/print.h" -// #include "memory/dump.h" +#include "memory/dump.h" int verbosity = 0; @@ -162,7 +162,7 @@ void debug_dump_object( struct pso_pointer pointer, int level, int indent ) { if ( level & verbosity ) { URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); -// dump_object( ustderr, pointer ); + dump_object( pointer ); free( ustderr ); } #endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 4636bc3..ffe5ae9 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -241,7 +241,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer ( frame_pointer, L"url" ), c_string_to_lisp_string ( frame_pointer, - L"::system:standard-output" ) ), + L"::system:standard-log" ) ), nil ) ) ); env = lisp_bind( make_frame diff --git a/src/c/io/read.c b/src/c/io/read.c index fa244c8..3331511 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -154,6 +154,7 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { } // else exception? #ifdef DEBUG debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); + debug_dump_object(result, DEBUG_IO, 1); #endif return result; @@ -189,12 +190,8 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0); debug_print( L"`\n\t", DEBUG_IO, 0); - for ( struct pso_pointer cursor = result; !c_nilp(cursor); cursor = c_cdr(cursor)) { - wint_t c = pointer_to_object(cursor)->payload.string.character; - debug_printf( DEBUG_IO, 0, L"[Character %lc (%d)]", c, c); - } - debug_println(DEBUG_IO); -#endif + debug_dump_object(result, DEBUG_IO, 1); + #endif return result; } @@ -286,7 +283,8 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { #ifdef DEBUG debug_print( L"Read expression: `", DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 ); - debug_print( L"`\n", DEBUG_IO, 0 ); + debug_print( L"`\n", DEBUG_IO, 0 ); + debug_dump_object(result, DEBUG_IO, 1); #endif return result; diff --git a/src/c/memory/dump.c b/src/c/memory/dump.c index 46d5c81..36a9755 100644 --- a/src/c/memory/dump.c +++ b/src/c/memory/dump.c @@ -22,6 +22,7 @@ #include #include "io/fopen.h" +#include "io/io.h" #include "io/print.h" #include "memory/pointer.h" #include "memory/pso.h" @@ -30,6 +31,8 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "ops/truth.h" +#include "ops/truth.h" #include "payloads/character.h" #include "payloads/cons.h" #include "payloads/exception.h" @@ -40,230 +43,267 @@ #include "payloads/symbol.h" #include "payloads/time.h" -//void dump_string_cell( URL_FILE *output, wchar_t *prefix, -// struct pso_pointer pointer ) { -// struct pso2* object = pointer_to_object( pointer ); -// if ( object->payload.string.character == 0 ) { -// url_fwprintf( output, -// L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", -// prefix, -// object->payload.string.cdr.page, -// object->payload.string.cdr.offset, object->header.count ); -// } else { -// url_fwprintf( output, -// L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", -// prefix, -// ( wint_t ) object->payload.string.character, -// object->payload.string.character, -// object->payload.string.hash, -// object->payload.string.cdr.page, -// object->payload.string.cdr.offset, object->header.count ); -//// url_fwprintf( output, L"\t\t value: " ); -//// print( output, pointer ); -// url_fwprintf( output, L"\n" ); -// } -//} -// -// -//void dump_frame_context_fragment( URL_FILE *output, -// struct pso_pointer frame_pointer, -// uint arg) { -// if ( stackp(frame_pointer ) { -// struct pso4 *frame = pointer_to_pso4( frame_pointer ); -// -// url_fwprintf( output, L" <= " ); -//// print( frame->payload.stack_frame.arg[arg], output ); -// } -//} -// -//void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, -// int depth ) { -// if ( framep(frame_pointer) ) { -// struct pso4 *frame = pointer_to_pso4( frame_pointer ); -// -// url_fwprintf( output, L"\tContext: " ); -// -// int i = 0; -// for ( struct pso_pointer cursor = frame_pointer; -// i++ < depth && !nilp( cursor ); -// cursor = frame_get_previous( cursor ) ) { -// dump_frame_context_fragment( output, cursor, 0 ); -// } -// -// url_fwprintf( output, L"\n" ); -// } -//} -// -///** -// * Dump a stackframe to this stream for debugging -// * @param output the stream -// * @param frame_pointer the pointer to the frame -// */ -//void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { -// if ( framep(frame_pointer) ) { -// struct pso4 *frame = pointer_to_pso4( frame_pointer ); -// -// url_fwprintf( output, L"Stack frame %d with %d arguments:\n", -// frame->payload.stack_frame.depth, frame->payload.stack_frame.args ); -// dump_frame_context( output, frame_pointer, 4 ); -// -// for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) { -// struct pso2* object = fetch_arg(frame, arg); -// -// url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ", -// arg, object->header.tag.bytes.mnemonic[0], object->header.count ); -// -// print( output, frame->payload.stack_frame.arg[arg] ); -// url_fputws( L"\n", output ); -// } -// if ( !nilp( frame->more ) ) { -// url_fputws( L"More: \t", output ); -// print( output, frame->more ); -// url_fputws( L"\n", output ); -// } -// } -//} -// -// -//void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { -// if ( exceptionp( pointer ) ) { -// struct pso3* exep = pointer_to_pso3( pointer); -// print( output, exep->payload.exception. ); -// url_fputws( L"\n", output ); -// dump_stack_trace( output, -// exep->payload.exception.stack ); -// } else { -// while ( stackp( pointer) ) { -// dump_frame( output, pointer ); -// pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous; -// } -// } -//} -// -// -///** -// * dump the object at this pso_pointer to this output stream. -// * TODO: convert this into a proper Lisp function and move to ops -// */ -//struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { -// struct pso_pointer result = nil; -// -// if (stackp(frame_pointer)) { -// struct pso4* frame = pointer_to_pso4( frame_pointer); -// -// struct pso_pointer pointer = fetch_arg( frame, 0); -// struct pso_pointer stream = fetch_arg( frame, 1); -// -// if (!writep(stream)) { -// stream = lisp_stdout; -// } -// -// struct pso2* object = pointer_to_object( pointer ); -// url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", -// object->header.tag.bytes.mnemonic[0], -// get_tag_value(pointer), -// object->header.tag.bytes.size_class, -// pointer.page, pointer.offset, -// object->header.count ); -// -// switch ( get_tag_value( pointer) ) { -// case CONSTV: -// url_fwprintf( output, -// L"\t\tCons object: car at page %d offset %d, cdr at page %d " -// L"offset %d :", -// object->payload.cons.car.page, -// object->payload.cons.car.offset, -// object->payload.cons.cdr.page, -// object->payload.cons.cdr.offset); -// print( output, pointer ); -// url_fputws( L"\n", output ); -// break; -// case EXCEPTIONTV: -// url_fwprintf( output, L"\t\tException object: " ); -// dump_stack_trace( output, pointer ); -// break; -// case FREETV: -// url_fwprintf( output, -// L"\t\tFree object: next at page %d offset %d\n", -// object->payload.free.next.page, -// object->payload.free.next.offset); -// break; -// case INTEGERTV: -// url_fwprintf( output, L"\t\tInteger object: value %ld\n", -// object->payload.integer.value ); -// break; -// case KEYTV: -// dump_string_cell( output, L"Keyword", pointer ); -// break; -//// case LAMBDATV: -//// url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " ); -//// print( output, object->payload.lambda.args ); -//// url_fwprintf( output, L";\n\t\t\tbody: " ); -//// print( output, object->payload.lambda.body ); -//// url_fputws( L"\n", output ); -//// break; -//// case NILTV: -//// break; -//// case NLAMBDATV: -//// url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " ); -//// print( output, object->payload.lambda.args ); -//// url_fwprintf( output, L";\n\t\t\tbody: " ); -//// print( output, object->payload.lambda.body ); -//// url_fputws( L"\n", output ); -//// break; -//// case RATIOTV: -//// url_fwprintf( output, -//// L"\t\tRational object: value %ld/%ld, count %u\n", -//// pointer_to_object( object->payload.ratio.dividend ). -//// payload.integer.value, -//// pointer_to_object( object->payload.ratio.divisor ). -//// payload.integer.value, object->count ); -//// break; -// case READTV: -// url_fputws( L"\t\tInput stream; metadata: ", output ); -//// print( output, object->payload.stream.meta ); -// url_fputws( L"\n", output ); -// break; -//// case REALTV: -//// url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n", -//// object->payload.real.value, object->count ); -//// break; -// case STRINGTV: -// dump_string_cell( output, L"String", pointer ); -// break; -// case SYMBOLTV: -// dump_string_cell( output, L"Symbol", pointer ); -// break; -//// case TRUETV: -//// break; -//// case VECTORPOINTTV:{ -//// url_fwprintf( output, -//// L"\t\tPointer to vector-space object at %p\n", -//// object->payload.vectorp.address ); -//// struct vector_space_object *vso = object->payload.vectorp.address; -//// url_fwprintf( output, -//// L"\t\tVector space object of type %4.4s (%d), payload size " -//// L"%d bytes\n", -//// &vso->header.tag.bytes, vso->header.tag.value, -//// vso->header.size ); -//// -//// switch ( vso->header.tag.value ) { -//// case STACKFRAMETV: -//// dump_frame( output, pointer ); -//// break; -//// case HASHTV: -//// dump_map( output, pointer ); -//// break; -//// } -//// } -//// break; -// case WRITETV: -// url_fputws( L"\t\tOutput stream; metadata: ", output ); -//// print( output, object->payload.stream.meta ); -//// url_fputws( L"\n", output ); -// break; -// } -// } // TODO: else exception -// -// return result; -//} +void dump_string_cell( URL_FILE *output, wchar_t *prefix, + struct pso_pointer pointer ) { + struct pso2* object = pointer_to_object( pointer ); + if ( object->payload.string.character == 0 ) { + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + object->payload.string.cdr.page, + object->payload.string.cdr.offset, object->header.count ); + } else { + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) object->payload.string.character, + object->payload.string.character, + object->payload.string.hash, + object->payload.string.cdr.page, + object->payload.string.cdr.offset, object->header.count ); + url_fwprintf( output, L"\t\t value: " ); + in_write( pointer, output, false, 0); + if (stringlikep(pointer)) { + url_fwprintf( output, L"\n\t\t structure: " ); + for ( struct pso_pointer cursor = pointer; !c_nilp(cursor); cursor = c_cdr(cursor)) { + wint_t c = pointer_to_object(cursor)->payload.string.character; + char* tag = (pointer_to_object(cursor)->header.tag.bytes.mnemonic); + url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c); + } + } + + url_fwprintf( output, L"\n" ); + } +} + + +void dump_frame_context_fragment( URL_FILE *output, + struct pso_pointer frame_pointer, + uint arg) { + if ( stackp(frame_pointer )) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + url_fwprintf( output, L" <= " ); + in_write( frame->payload.stack_frame.arg[arg], output, false, 0 ); + } +} + +void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, + int depth ) { + if ( stackp(frame_pointer) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + url_fwprintf( output, L"\tContext: " ); + + int i = 0; + for ( struct pso_pointer cursor = frame_pointer; + i++ < depth && !c_nilp( cursor ); + cursor = pointer_to_pso4(cursor)->payload.stack_frame.previous ) { + dump_frame_context_fragment( output, cursor, 0 ); + } + + url_fwprintf( output, L"\n" ); + } +} + +/** + * Dump a stackframe to this stream for debugging + * @param output the stream + * @param frame_pointer the pointer to the frame + */ +void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { + if ( stackp(frame_pointer) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + url_fwprintf( output, L"Stack frame %d with %d arguments:\n", + frame->payload.stack_frame.depth, frame->payload.stack_frame.args ); + dump_frame_context( output, frame_pointer, 4 ); + + for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) { + struct pso2* object = pointer_to_object( fetch_arg(frame, arg)); + + url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ", + arg, object->header.tag.bytes.mnemonic[0], object->header.count ); + + in_write( frame->payload.stack_frame.arg[arg], output, false, 0 ); + url_fputws( L"\n", output ); + } + if ( !c_nilp( frame->payload.stack_frame.more ) ) { + url_fputws( L"More: \t", output ); + in_write( frame->payload.stack_frame.more, output, false, 0 ); + url_fputws( L"\n", output ); + } + } +} + + +void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { + if ( exceptionp( pointer ) ) { + struct pso3* exep = pointer_to_pso3( pointer); + in_write( exep->payload.exception.message, output, false, 0 ); + url_fputws( L"\n", output ); + dump_stack_trace( output, + exep->payload.exception.stack ); + } else { + while ( stackp( pointer) ) { + dump_frame( output, pointer ); + pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous; + } + } +} + + +/** + * @brief dump an object to a stream. + * + * (dump object stream) + * + * dual role: can be invoked from Lisp with a frame pointer as + * a normal Lisp function, in which case args should be + * + * @param object a pointer to the object to be dumped; + * @param stream (optional) the stream to dump to (defaults to `*log*`) + * + * If invoked from C, the single argument should be a pointer to the object + * to be dumped. + */ +struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer stream = nil; + struct pso_pointer pointer = nil; + + if (stackp(frame_pointer)) { + struct pso4* frame = pointer_to_pso4( frame_pointer); + + pointer = fetch_arg( frame, 0); + stream = fetch_arg( frame, 1); + } else { + pointer = frame_pointer; + } + + if (!writep(stream)) { + stream = lisp_stderr; + } + +// URL_FILE* output = file_to_url_file(stderr); +// url_fputws( L"\ndump_object printing to output stream; metadata: ", output ); +// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 ); +// url_fputws( L"\n", output ); +// fflush(stderr); + + URL_FILE* output = pointer_to_object(stream)->payload.stream.stream; + + if (c_nilp(pointer)) { + // the object at (node, 0, 0) ought to have been initialised, but may not + // have been... + url_fputws(L"nil of size class 2 at page 0, offset 0, count xxxx\n", output ); + } else { + struct pso2* object = pointer_to_object( pointer ); + url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", + object->header.tag.bytes.mnemonic, + get_tag_value(pointer), + object->header.tag.bytes.size_class, + pointer.page, pointer.offset, + object->header.count ); + + switch ( get_tag_value( pointer) ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons object: car at page %d offset %d, cdr at page %d " + L"offset %d :", + object->payload.cons.car.page, + object->payload.cons.car.offset, + object->payload.cons.cdr.page, + object->payload.cons.cdr.offset); + in_write( pointer, output, false, 0 ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException object: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree object: next at page %d offset %d\n", + object->payload.free.next.page, + object->payload.free.next.offset); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger object: value %ld\n", + object->payload.integer.value ); + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + // case LAMBDATV: + // url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " ); + // in_write( output, object->payload.lambda.args ); + // url_fwprintf( output, L";\n\t\t\tbody: " ); + // in_write( output, object->payload.lambda.body ); + // url_fputws( L"\n", output ); + // break; + // case NILTV: + // break; + // case NLAMBDATV: + // url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " ); + // in_write( output, object->payload.lambda.args ); + // url_fwprintf( output, L";\n\t\t\tbody: " ); + // in_write( output, object->payload.lambda.body ); + // url_fputws( L"\n", output ); + // break; + // case RATIOTV: + // url_fwprintf( output, + // L"\t\tRational object: value %ld/%ld, count %u\n", + // pointer_to_object( object->payload.ratio.dividend ). + // payload.integer.value, + // pointer_to_object( object->payload.ratio.divisor ). + // payload.integer.value, object->count ); + // break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + in_write( object->payload.stream.meta, output, false, 0 ); + url_fputws( L"\n", output ); + break; + // case REALTV: + // url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n", + // object->payload.real.value, object->count ); + // break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + // case TRUETV: + // break; + // case VECTORPOINTTV:{ + // url_fwprintf( output, + // L"\t\tPointer to vector-space object at %p\n", + // object->payload.vectorp.address ); + // struct vector_space_object *vso = object->payload.vectorp.address; + // url_fwprintf( output, + // L"\t\tVector space object of type %4.4s (%d), payload size " + // L"%d bytes\n", + // &vso->header.tag.bytes, vso->header.tag.value, + // vso->header.size ); + // + // switch ( vso->header.tag.value ) { + // case STACKFRAMETV: + // dump_frame( output, pointer ); + // break; + // case HASHTV: + // dump_map( output, pointer ); + // break; + // } + // } + // break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + in_write( object->payload.stream.meta, output, false, 0 ); + url_fputws( L"\n", output ); + break; + } + } + + return result; +} diff --git a/src/c/memory/dump.h b/src/c/memory/dump.h index 98583a6..d467c8d 100644 --- a/src/c/memory/dump.h +++ b/src/c/memory/dump.h @@ -11,7 +11,7 @@ #define SRC_C_MEMORY_DUMP_H_ -void dump_object( URL_FILE *output, struct pso_pointer pointer ); +void dump_object( struct pso_pointer pointer ); #endif /* SRC_C_MEMORY_DUMP_H_ */ diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 268272e..63bf30b 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -130,6 +130,7 @@ bool check_type( struct pso_pointer p, char *s ); #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 stringlikep(p) (check_tag(p,KEYTV)||check_tag(p,STRINGTV)||check_tag(p,SYMBOLTV)) #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 diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 6b68a19..5dfdd63 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -45,13 +45,7 @@ struct pso_pointer search( struct pso_pointer key, debug_print( L"In search; key is: `", DEBUG_BIND, 0 ); debug_print_object( key, DEBUG_BIND, 0 ); debug_print( L"`\n", DEBUG_BIND, 0 ); - debug_print(L"", DEBUG_BIND, 2); - if (symbolp(key)) { - for ( struct pso_pointer cursor = key; !c_nilp(cursor); cursor = c_cdr(cursor)) { - wint_t c = pointer_to_object(cursor)->payload.string.character; - debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); - } - } + debug_dump_object(key, DEBUG_BIND, 1); #endif if ( consp( store ) ) { @@ -59,25 +53,17 @@ struct pso_pointer search( struct pso_pointer key, consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); #ifdef DEBUG - debug_print( L"Checking ", DEBUG_BIND, 2 ); + debug_print( L"Checking `", DEBUG_BIND, 1 ); debug_print_object( c_car( pair), DEBUG_BIND, 0 ); - debug_println( DEBUG_BIND); - debug_print(L"", DEBUG_BIND, 4); - if (symbolp(c_car( pair))) { - for ( struct pso_pointer cursor = c_car(pair); !c_nilp(cursor); cursor = c_cdr(cursor)) { - wint_t c = pointer_to_object(cursor)->payload.string.character; - debug_printf( DEBUG_BIND, 0, L"[Character %lc (%d)]", c, c); - } - } - debug_println(DEBUG_BIND); - + debug_print(L"`\n", DEBUG_BIND, 2); + debug_dump_object(c_car(pair), DEBUG_BIND, 2); #endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; result = return_key ? c_car( pair ) : c_cdr( pair ); #ifdef DEBUG - debug_print( L" ...found!", DEBUG_BIND, 0 ); + debug_print( L" ...found!", DEBUG_BIND, 2 ); #endif } #ifdef DEBUG diff --git a/src/c/ops/dump.c b/src/c/ops/dump.c deleted file mode 100644 index c39b871..0000000 --- a/src/c/ops/dump.c +++ /dev/null @@ -1,154 +0,0 @@ -/* - * dump.c - * - * Dump representations of both cons space and vector space objects. - * - * TODO: This is going to be entirely rewritten and merged with `inspect.c`, - * q.v., which will be the main entrypoint to this code. What exists is - * technical debt but will work for now. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -/* - * wide characters - */ -#include -#include - -#include "memory/pointer.h" -#include "memory/pso2.h" -#include "memory/pso4.h" -#include "memory/tags.h" -#include "io/print.h" - -#include "payloads/stack.h" -#include "payloads/lambda.h" - - -void dump_string_cell( struct pso_pointer frame_pointer, struct pso_pointer output, wchar_t *prefix, - struct pso_pointer pointer ) { - URL_FILE* os = pointer_to_object(output)->payload.stream.stream; - struct pso2 *cell = pointer_to_object( pointer ); - - if ( cell->payload.string.character == 0 ) { - url_fwprintf( os, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell->payload.string.cdr.page, - cell->payload.string.cdr.offset, cell->header.count ); - } else { - url_fwprintf( os, - L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell->payload.string.character, - cell->payload.string.character, - cell->payload.string.hash, - cell->payload.string.cdr.page, - cell->payload.string.cdr.offset, cell->header.count ); - url_fwprintf( os, L"\t\t value: " ); - c_print( frame_pointer, pointer, output ); - url_fwprintf( os, L"\n" ); - } -} - -/** - * dump the object at this pso_pointer to this output stream. - */ -void dump_object( struct pso_pointer frame_pointer, struct pso_pointer output, struct pso_pointer pointer ) { - URL_FILE* os = pointer_to_object(output)->payload.stream.stream; - - struct pso2 *cell = pointer_to_object( pointer ); - url_fwprintf( os, L"\t%3.3s (%d) at page %d, offset %d count %u\n", - cell->header.tag.bytes.mnemonic[0], get_tag_value( pointer ), - pointer.page, pointer.offset, cell->header.count ); - - switch ( get_tag_value( pointer ) ) { - case CONSTV: - url_fwprintf( os, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d " - L"offset %d, count %u :", - cell->payload.cons.car.page, - cell->payload.cons.car.offset, - cell->payload.cons.cdr.page, - cell->payload.cons.cdr.offset ); - c_print( frame_pointer, pointer, output ); - url_fputws( L"\n", os ); - break; - // case EXCEPTIONTV: - // url_fwprintf( os, L"\t\tException cell: " ); - // dump_stack_trace( output, pointer ); - // break; - case FREETV: - url_fwprintf( os, - L"\t\tFree cell: next at page %d offset %d\n", - cell->payload.cons.cdr.page, - cell->payload.cons.cdr.offset ); - break; - // case HASHTV: - // dump_map( output, pointer ); - // break; - case INTEGERTV: - url_fwprintf( os, L"\t\tInteger cell: value %ld, count %u\n", - cell->payload.integer.value, cell->header.count ); - break; - case KEYTV: - dump_string_cell( frame_pointer, output, L"Keyword", pointer ); - break; - case LAMBDATV: - url_fwprintf( os, L"\t\t\u03bb cell;\n\t\t args: " ); - c_print( frame_pointer, cell->payload.lambda.args, output ); - url_fwprintf( os, L";\n\t\t\tbody: " ); - c_print( frame_pointer, cell->payload.lambda.body, output ); - url_fputws( L"\n", os ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( os, L"\t\tn\u03bb cell; \n\t\targs: " ); - c_print( frame_pointer, cell->payload.lambda.args, output ); - url_fwprintf( os, L";\n\t\t\tbody: " ); - c_print( frame_pointer, cell->payload.lambda.body, output ); - url_fputws( L"\n", os ); - break; - // case RATIOTV: - // url_fwprintf( os, - // L"\t\tRational cell: value %ld/%ld, count %u\n", - // pointer_to_object( cell->payload.ratio. - // dividend ).payload.integer.value, - // pointer_to_object( cell->payload.ratio. - // divisor ).payload.integer.value, - // cell->header.count ); - // break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", os ); - c_print( frame_pointer, cell->payload.stream.meta, output ); - url_fputws( L"\n", os ); - break; - case REALTV: - url_fwprintf( os, L"\t\tReal cell: value %Lf, count %u\n", - cell->payload.real.value, cell->header.count ); - break; - // case STACKTV: - // dump_frame( frame_pointer, output, pointer ); - // break; - case STRINGTV: - dump_string_cell( frame_pointer, output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( frame_pointer, output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", os ); - c_print( frame_pointer, cell->payload.stream.meta, output ); - url_fputws( L"\n", os ); - break; - default: - url_fwprintf(os, L"TODO: Cannot yet dump object of type %3.3s\n", - cell->header.tag.bytes.mnemonic[0]); - break; - } -} diff --git a/src/c/ops/dump.h b/src/c/ops/dump.h deleted file mode 100644 index e69de29..0000000 diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 5ced0e2..0c5b19c 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -110,6 +110,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) { debug_print( L" returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); + debug_dump_object(result, DEBUG_EVAL, 1); return result; } @@ -632,6 +633,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { debug_print( L"apply: returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL, 0 ); return result; } From 271b7da46a7a02b9d4ea659cbff1ac71855db4d0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 15:32:35 +0100 Subject: [PATCH 72/77] Right, I have finally undone the issue #18 change. It was a nice idea, but I have not made it work. --- src/c/environment/function_bindings.c | 8 ++++---- src/c/io/io.c | 16 ++++++++-------- src/c/io/print.c | 4 ++-- src/c/io/read.c | 6 +++--- src/c/memory/tags.c | 2 +- src/c/ops/string_ops.c | 12 ++++++------ src/c/ops/string_ops.h | 4 ++-- src/c/payloads/character.c | 2 +- src/c/payloads/character.h | 2 +- src/sh/wchar_t_everywhere.sh | 8 ++++++++ 10 files changed, 36 insertions(+), 28 deletions(-) create mode 100644 src/sh/wchar_t_everywhere.sh diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index cae295e..65b1e2a 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -59,7 +59,7 @@ */ struct pso_pointer -bind_function(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, +bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); @@ -94,7 +94,7 @@ bind_function(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, * this `name` in the `oblist`. */ struct pso_pointer -bind_special(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, +bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, struct pso_pointer (*executable)(struct pso_pointer)) { struct pso_pointer result = fetch_env(frame_pointer); struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); @@ -125,8 +125,8 @@ bind_special(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc, } struct function_data { - char32_t *name; - char32_t *documentation; + wchar_t *name; + wchar_t *documentation; void *executable; }; diff --git a/src/c/io/io.c b/src/c/io/io.c index ffe5ae9..31f64c4 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -287,8 +287,8 @@ wint_t url_fgetwc( URL_FILE *input ) { break; case CFTYPE_CURL:{ char *cbuff = - calloc( sizeof( char32_t ) + 2, sizeof( char ) ); - char32_t *wbuff = calloc( 2, sizeof( char32_t ) ); + 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 ); @@ -409,7 +409,7 @@ struct pso_pointer lisp_close( struct pso_pointer frame_pointer) { } struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer, - struct pso_pointer meta, char32_t *key, + struct pso_pointer meta, wchar_t *key, long int value ) { return make_cons( frame_pointer, make_cons( frame_pointer, @@ -420,10 +420,10 @@ struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer, } struct pso_pointer add_meta_string( struct pso_pointer frame_pointer, - struct pso_pointer meta, char32_t *key, + struct pso_pointer meta, wchar_t *key, char *value ) { value = trim( value ); - char32_t buffer[strlen( value ) + 1]; + wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); return make_cons( frame_pointer, make_cons( frame_pointer, @@ -434,7 +434,7 @@ struct pso_pointer add_meta_string( struct pso_pointer frame_pointer, } struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, - struct pso_pointer meta, char32_t *key, + struct pso_pointer meta, wchar_t *key, time_t *value ) { return make_cons( frame_pointer, make_cons( frame_pointer, @@ -465,7 +465,7 @@ static size_t write_meta_callback( struct pso_pointer frame_pointer, s[offset] = ( char ) 0; char *name = trim( s ); char *value = trim( &s[++offset] ); - char32_t wname[strlen( name )]; + wchar_t wname[strlen( name )]; mbstowcs( wname, name, strlen( name ) + 1 ); object->payload.stream.meta = add_meta_string( frame_pointer, object->payload.stream.meta, @@ -667,7 +667,7 @@ struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer) { debug_dump_object( result, DEBUG_IO, 0 ); debug_println( DEBUG_IO ); struct pso2 *cell = pointer_to_object( cursor ); - cursor = make_string( frame_pointer, ( char32_t ) c, nil ); + cursor = make_string( frame_pointer, ( wchar_t ) c, nil ); cell->payload.string.cdr = cursor; } } diff --git a/src/c/io/print.c b/src/c/io/print.c index a850e72..c9b0f7d 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -58,7 +58,7 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, * TODO: this does not yet even nearly cope with all the possible special * cases. */ -void write_char( char32_t wc, URL_FILE *output, bool escape ) { +void write_char( wchar_t wc, URL_FILE *output, bool escape ) { if ( escape && !iswprint( wc ) ) { url_fwprintf( output, L"\\%04x", wc ); // url_fputwc(L'\\', output); @@ -83,7 +83,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { for ( struct pso_pointer cursor = p; !c_nilp( cursor ); cursor = pointer_to_object( cursor )->payload.string.cdr ) { - char32_t wc = + wchar_t wc = pointer_to_object( cursor )->payload.string.character; write_char( wc, output, escape ); diff --git a/src/c/io/read.c b/src/c/io/read.c index 3331511..4813c70 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -141,7 +141,7 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { character = read_character( make_frame( 1, frame_pointer, stream ) ); } - char32_t c = c_nilp( character ) + wchar_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -173,7 +173,7 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { read_character( make_frame( 1, frame_pointer, stream ) ); } - char32_t c = c_nilp( character ) + wchar_t c = c_nilp( character ) ? 0 : pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; @@ -233,7 +233,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { if ( !c_nilp( readmacro ) ) { // invoke the read macro on the stream } else if ( readp( stream ) && characterp( character ) ) { - char32_t c = + wchar_t c = pointer_to_object( character )->payload.character.character; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index 635f19c..a77519c 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -39,7 +39,7 @@ struct pso_pointer get_tag_string( struct pso_pointer frame_pointer, for ( int i = 2 - 1; i >= 0; i-- ) { result = make_string( frame_pointer, - ( char32_t ) ( object->header.tag.bytes.mnemonic[i] ), + ( wchar_t ) ( object->header.tag.bytes.mnemonic[i] ), result ); } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index c9ff224..7111762 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -71,7 +71,7 @@ uint32_t calculate_hash( wint_t c, struct pso_pointer ptr ) { * pointer to next is nil. * * NOTE THAT: in 0.1.X, we may allocate symbols and keywords as arrays of - * char32_t in larger pso classes, so this function may be only for strings + * wchar_t in larger pso classes, so this function may be only for strings * (and thus simpler). */ struct pso_pointer make_string_like_thing( struct pso_pointer frame_pointer, @@ -142,7 +142,7 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { len++; } - wchar_t *buffer = calloc( len, sizeof( char32_t ) ); + wchar_t *buffer = calloc( len, sizeof( wchar_t ) ); int i = 0; for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = @@ -177,11 +177,11 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { * symbols, I am accepting only lower case characters and certain punctuation. */ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, - char32_t *symbol ) { + wchar_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_t c = symbol[i]; + wchar_t c = symbol[i]; if ( symbol_char_p(c)) { result = make_symbol( frame_pointer, c, result ); @@ -196,11 +196,11 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, * keywords, I am accepting only lower case characters and numbers. */ struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, - char32_t *symbol ) { + wchar_t *symbol ) { struct pso_pointer result = nil; for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - char32_t c = towlower( symbol[i] ); + wchar_t c = towlower( symbol[i] ); if ( iswalnum( c ) || c == L'-' ) { result = make_keyword( frame_pointer, c, result ); diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index 4e94ae9..b265dc7 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -27,10 +27,10 @@ char *lisp_string_to_c_string( struct pso_pointer s ); struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, - char32_t * symbol ); + wchar_t * symbol ); struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, - char32_t * symbol ); + wchar_t * symbol ); bool end_of_stringp(struct pso_pointer arg); diff --git a/src/c/payloads/character.c b/src/c/payloads/character.c index 88d5b0d..4c379a7 100644 --- a/src/c/payloads/character.c +++ b/src/c/payloads/character.c @@ -28,7 +28,7 @@ struct pso_pointer make_character( struct pso_pointer frame_pointer, wint_t c ) if ( !c_nilp( result ) ) { pointer_to_object( result )->payload.character.character = - ( char32_t ) c; + ( wchar_t ) c; } return result; diff --git a/src/c/payloads/character.h b/src/c/payloads/character.h index 6995631..d1307d1 100644 --- a/src/c/payloads/character.h +++ b/src/c/payloads/character.h @@ -35,7 +35,7 @@ * @brief a single character, as returned by the reader. */ struct character_payload { - char32_t character; + wchar_t character; }; struct pso_pointer make_character( struct pso_pointer frame_pointer, diff --git a/src/sh/wchar_t_everywhere.sh b/src/sh/wchar_t_everywhere.sh new file mode 100644 index 0000000..a193083 --- /dev/null +++ b/src/sh/wchar_t_everywhere.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +for file in src/c/*/*.[ch] +do + echo $file + cp $file $file.bak + sed 's/char32_t/wchar_t/g' $file.bak > $file +done From 5e64a33965f48a5b7983975cdba27c5d3bf7193f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 16:42:18 +0100 Subject: [PATCH 73/77] Major step forward: `equal` is now working, and consequently so is `assoc`. --- src/c/environment/environment.c | 22 +-- src/c/environment/function_bindings.c | 202 ++++++++++++------------ src/c/environment/privileged_keywords.c | 22 +++ src/c/environment/privileged_keywords.h | 14 +- src/c/memory/tags.h | 2 +- src/c/ops/cond.c | 14 +- src/c/ops/eq.c | 4 +- src/c/ops/eval_apply.c | 4 +- src/c/ops/mapcar.c | 8 +- src/c/payloads/exception.c | 10 +- src/sh/wchar_t_everywhere.sh | 3 +- 11 files changed, 168 insertions(+), 137 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index 27c9fa5..dbc5f84 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -46,7 +46,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { struct pso_pointer frame_pointer = nil; // can't have a frame pointer before we've initialised nil and t if ( c_truep( result ) ) { - debug_print( U"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"Initialising `nil`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( frame_pointer, NILTAG, 2 ); if ( ( n.page == 0 ) && ( n.offset == 0 ) ) { @@ -56,14 +56,14 @@ struct pso_pointer initialise_environment( uint32_t node ) { nil = n; lock_object( nil ); - debug_print( U"success\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = nil; - debug_print( U"fail\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !c_nilp( result ) ) { - debug_print( U"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"Initialising `t`... ", DEBUG_BOOTSTRAP, 0 ); struct pso_pointer n = allocate( frame_pointer, TRUETAG, 2 ); // offset is in words, and size of a pso2 is four words @@ -74,10 +74,10 @@ struct pso_pointer initialise_environment( uint32_t node ) { t = n; lock_object( t ); - debug_print( U"success\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 ); } else { result = nil; - debug_print( U"fail\n", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 ); } } if ( !exceptionp( result ) ) { @@ -85,22 +85,22 @@ struct pso_pointer initialise_environment( uint32_t node ) { result = lisp_bind( make_frame ( 3, frame_pointer, - c_string_to_lisp_symbol( frame_pointer, U"nil" ), nil, + c_string_to_lisp_symbol( frame_pointer, L"nil" ), nil, nil ) ); - debug_print( U"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, + debug_print( L"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); result = lisp_bind( make_frame ( 3, frame_pointer, - c_string_to_lisp_symbol( frame_pointer, U"t" ), t, + c_string_to_lisp_symbol( frame_pointer, L"t" ), t, result ) ); environment_initialised = true; - debug_print( U"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); + debug_print( L"Environment after binding `t`: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( result, DEBUG_BOOTSTRAP, 0 ); - debug_print( U"\nEnvironment initialised successfully.\n", + debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); initialise_privileged_keywords(frame_pointer); diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 65b1e2a..80b6a5d 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -67,7 +67,7 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, struct pso_pointer meta = make_cons( frame_pointer, - make_cons(frame_pointer, privileged_keyword_bootstrap, nil), + make_cons(frame_pointer, privileged_keyword_layer, privileged_keyword_bootstrap), make_cons(frame_pointer, make_cons(frame_pointer, privileged_keyword_name, n), make_cons(frame_pointer, @@ -79,11 +79,11 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, debug_print(doc, DEBUG_BOOTSTRAP, 0); if (!exceptionp(r)) { - debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0); + debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0); result = make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); } else { - debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0); + debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0); } return result; @@ -114,11 +114,11 @@ bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, debug_print(doc, DEBUG_BOOTSTRAP, 0); if (!exceptionp(r)) { - debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0); + debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0); result = make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); } else { - debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0); + debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0); } return result; @@ -140,152 +140,152 @@ struct function_data { /** initialisers for functions */ struct function_data function_initialisers[] = { #ifdef _psse_io_io_h - {U"close", U"(close stream): close `stream`.", &lisp_close}, - {U"open", - U"(open stream), (open stream write?): open `stream`; if `write?` is " - U"present and is non-nil, open for writing, else for reading.", + {L"close", L"(close stream): close `stream`.", &lisp_close}, + {L"open", + L"(open stream), (open stream write?): open `stream`; if `write?` is " + L"present and is non-nil, open for writing, else for reading.", &lisp_open}, - {U"slurp", - U"(slurp stream): read the whole contents of this `stream`, " - U"which may " - U"be an open stream open for reading or a URL, into a string, and return " - U"the " - U"string.", + {L"slurp", + L"(slurp stream): read the whole contents of this `stream`, " + L"which may " + L"be an open stream open for reading or a URL, into a string, and return " + L"the " + L"string.", &lisp_slurp}, #endif #ifdef __psse_io_peek_h - {U"peek", - U"(peek stream): return the next character which may be read from " - U"`stream`, without removing it.", + {L"peek", + L"(peek stream): return the next character which may be read from " + L"`stream`, without removing it.", &peek}, #endif #ifdef __psse_io_print_h - {U"print", - U"(print object), (print object stream) print this `object` in a format " - U"suitable to be read by `read`, q.v.; if `stream` is specified and is a " - U"stream open for writing, to that stream.", + {L"print", + L"(print object), (print object stream) print this `object` in a format " + L"suitable to be read by `read`, q.v.; if `stream` is specified and is a " + L"stream open for writing, to that stream.", &print}, - {U"princ", - U"(princ object), (princ object stream) print this `object` in a format " - U"more suited to human readers; if `stream` is specified and is a stream " - U"open for writing, to that stream.", + {L"princ", + L"(princ object), (princ object stream) print this `object` in a format " + L"more suited to human readers; if `stream` is specified and is a stream " + L"open for writing, to that stream.", &print}, #endif #ifdef __psse_io_read_h - {U"read", - U"(read stream) read one complete Lisp expression from `stream`, and " - U"return that expression unevaluated.", + {L"read", + L"(read stream) read one complete Lisp expression from `stream`, and " + L"return that expression unevaluated.", &read}, - {U"read-character", - U"(read-character stream): read a single character from `stream` and " - U"return it.", + {L"read-character", + L"(read-character stream): read a single character from `stream` and " + L"return it.", &read_character}, - {U"read-number", - U"(read-number stream): read a number from `stream` and return it.", + {L"read-number", + L"(read-number stream): read a number from `stream` and return it.", &read_number}, - {U"read-symbol", - U"(read-symbol stream): read a symbol from `stream` and return it.", + {L"read-symbol", + L"(read-symbol stream): read a symbol from `stream` and return it.", &read_symbol}, #endif #ifdef __psse_ops_assoc_h - {U"assoc", - U"(assoc key store): search `store` for the value associated with " - U"`key`.", + {L"assoc", + L"(assoc key store): search `store` for the value associated with " + L"`key`.", &assoc}, #endif #ifdef __psse_ops_bind_h - {U"bind!", - U"(bind! key value store): bind `key` to `value` in this store, modifying " - U"the store if it is writable to the user, otherwise returning a new " - U"store", + {L"bind!", + L"(bind! key value store): bind `key` to `value` in this store, modifying " + L"the store if it is writable to the user, otherwise returning a new " + L"store", &bind}, #endif #ifdef __psse_ops_eq_h - {U"eq", - U"(eq args...): shallow, cheap equality; returns `t` if all `args...` " - U"are the same object, else `nil`.", + {L"eq", + L"(eq args...): shallow, cheap equality; returns `t` if all `args...` " + L"are the same object, else `nil`.", &eq}, - {U"equal", - U"(equal a b): expensive, deep equality: returns `t` if objects `a` " - U"and `b` have recursively equal value.", + {L"equal", + L"(equal a b): expensive, deep equality: returns `t` if objects `a` " + L"and `b` have recursively equal value.", &equal}, #endif #ifdef __psse_ops_eval_apply_h // TODO: there's a lot of other stuff in eval_apply.c, which ought to be in // other files but at present isn't. - {U"apply", - U"(apply fn args...): apply this `fn` to these `args...` and return " - U"their value.", + {L"apply", + L"(apply fn args...): apply this `fn` to these `args...` and return " + L"their value.", &lisp_apply}, - {U"eval", - U"(eval expression): evaluate this `expression` and return its value", + {L"eval", + L"(eval expression): evaluate this `expression` and return its value", &lisp_eval}, #endif #ifdef __psse_ops_inspect_h - {U"inspect", - U"(inspect expr), (inspect expr write-stream): inspect one complete " - U"lisp expression and return `nil`. If `write-stream` is specified and " - U"is a write stream, then print to that stream, else to the stream " - U"which is the value of `*out*` in the environment.", + {L"inspect", + L"(inspect expr), (inspect expr write-stream): inspect one complete " + L"lisp expression and return `nil`. If `write-stream` is specified and " + L"is a write stream, then print to that stream, else to the stream " + L"which is the value of `*out*` in the environment.", &lisp_inspect}, #endif #ifdef __psse_ops_keys_h - {U"keys", U"(keys store): returns a list of the keys in this `store`.", + {L"keys", L"(keys store): returns a list of the keys in this `store`.", &lisp_keys}, #endif #ifdef __psse_ops_list_ops_h - {U"count", - U"(count sequence): returns the number of top level elements in " - U"`sequence`.", + {L"count", + L"(count sequence): returns the number of top level elements in " + L"`sequence`.", &count}, #endif #ifdef __psse_ops_mapcar_h - {U"mapcar", - U"(mapcar fn list): map this `fn` over this `list`, and return a list " - U"of the results.", + {L"mapcar", + L"(mapcar fn list): map this `fn` over this `list`, and return a list " + L"of the results.", &lisp_mapcar}, #endif #ifdef __psse_ops_progn_h - {U"progn", - U"(progn expressions...): Evaluate each expression in " - U"`expressions` in turn and return the value of the last.", + {L"progn", + L"(progn expressions...): Evaluate each expression in " + L"`expressions` in turn and return the value of the last.", &lisp_progn}, #endif #ifdef __psse_ops_repl_h - {U"repl", U"(repl show_prompt?): Start a new read, eval, print loop.", + {L"repl", L"(repl show_prompt?): Start a new read, eval, print loop.", &repl}, #endif #ifdef __psse_ops_reverse_h - {U"reverse", - U"(reverse sequence): return a sequence like this `sequence`, but with " - U"the order of top level elements reversed.", + {L"reverse", + L"(reverse sequence): return a sequence like this `sequence`, but with " + L"the order of top level elements reversed.", &reverse}, #endif #ifdef __psse_ops_truth_h - {U"and", - U"(and expressions...): returns `t` if none of these `expressions...` " - U"evaluates to `nil`, else `nil`.", + {L"and", + L"(and expressions...): returns `t` if none of these `expressions...` " + L"evaluates to `nil`, else `nil`.", &and}, - {U"nil?", - U"(nil? expression): returns `t` if `expression` evaluates to `nil`, else " - U"`nil`.", + {L"nil?", + L"(nil? expression): returns `t` if `expression` evaluates to `nil`, else " + L"`nil`.", &nilp}, - {U"not", - U"(not expression): returns `t` unless `expression` evaluates to `nil`, " - U"else " - U"`nil`.", + {L"not", + L"(not expression): returns `t` unless `expression` evaluates to `nil`, " + L"else " + L"`nil`.", ¬}, - {U"or", - U"(or expressions...): returns `nil` if every one of these `expressions...` " - U"evaluates to `nil`, else `t`.", + {L"or", + L"(or expressions...): returns `nil` if every one of these `expressions...` " + L"evaluates to `nil`, else `t`.", &or}, - {U"true?", - U"(true? expression): returns `t` if `expression` evaluates to `t`, else " - U"`nil`.", + {L"true?", + L"(true? expression): returns `t` if `expression` evaluates to `t`, else " + L"`nil`.", &truep}, #endif - {U"END MARKER", U"END MARKER", NULL}}; + {L"END MARKER", L"END MARKER", NULL}}; /* right, the problem with all those pretty '#ifdefs' which might allow us to * simply switch functions on and off just by including or not including .h @@ -296,22 +296,22 @@ struct function_data function_initialisers[] = { /** initialisers for special forms */ struct function_data special_initialisers[] = { #ifdef __psse_ops_cond_h - {U"cond", - U"(cond clauses...): special form; conditional. Each `clause` is expected " - U"to be a " - U"list; if the first item in such a list evaluates to non-nil, the " - U"remaining items in that list are evaluated in turn and the value of " - U"the last returned. If no arg `clause` has a first element which " - U"evaluates to non nil, then nil is returned", + {L"cond", + L"(cond clauses...): special form; conditional. Each `clause` is expected " + L"to be a " + L"list; if the first item in such a list evaluates to non-nil, the " + L"remaining items in that list are evaluated in turn and the value of " + L"the last returned. If no arg `clause` has a first element which " + L"evaluates to non nil, then nil is returned", &lisp_cond}, #endif #ifdef __psse_ops_quote_h - {U"quote", - U"(quote expression): special form; protect `expression` from " - U"evaluation.", + {L"quote", + L"(quote expression): special form; protect `expression` from " + L"evaluation.", "e}, #endif - {U"END MARKER", U"END MARKER", NULL}}; + {L"END MARKER", L"END MARKER", NULL}}; struct pso_pointer initialise_function_bindings(struct pso_pointer frame_pointer) { diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c index 56fbd62..1a807bb 100644 --- a/src/c/environment/privileged_keywords.c +++ b/src/c/environment/privileged_keywords.c @@ -28,8 +28,17 @@ */ struct pso_pointer privileged_keyword_bootstrap; +/** + * documentation metadate for functions and special forms (and possibly other + * things) + */ struct pso_pointer privileged_keyword_documentation; +/** + * key for layer metadata for functions and special forms + */ +struct pso_pointer privileged_keyword_layer; + /** * location metadata for exceptions (and possibly location in other contexts). */ @@ -40,6 +49,16 @@ struct pso_pointer privileged_keyword_location; */ struct pso_pointer privileged_keyword_name; +/** + * layer metadata for functions that users shouldn't be able to override. + */ +struct pso_pointer privileged_keyword_system; + +/** + * layer metadata for functions written by users. + */ +struct pso_pointer privileged_keyword_user; + #define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val))) @@ -47,6 +66,9 @@ struct pso_pointer privileged_keyword_name; struct pso_pointer initialise_privileged_keywords(struct pso_pointer frame_pointer) { load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP); load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION); + load_and_lock(privileged_keyword_layer, PK_LAYER); load_and_lock(privileged_keyword_location, PK_LOCATION); load_and_lock( privileged_keyword_name, PK_NAME); + load_and_lock(privileged_keyword_system, PK_SYSTEM); + load_and_lock(privileged_keyword_user, PK_USER); } \ No newline at end of file diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h index 5726fb7..0bee337 100644 --- a/src/c/environment/privileged_keywords.h +++ b/src/c/environment/privileged_keywords.h @@ -13,15 +13,21 @@ #define SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ #include "memory/pointer.h" -#define PK_BOOTSTRAP U"bootstrap" -#define PK_DOCUMENTATION U"documentation" -#define PK_LOCATION U"location" -#define PK_NAME U"name" +#define PK_BOOTSTRAP L"bootstrap" +#define PK_DOCUMENTATION L"documentation" +#define PK_LAYER L"layer" +#define PK_LOCATION L"location" +#define PK_NAME L"name" +#define PK_SYSTEM L"system" +#define PK_USER L"user" extern struct pso_pointer privileged_keyword_bootstrap; extern struct pso_pointer privileged_keyword_documentation; +extern struct pso_pointer privileged_keyword_layer; extern struct pso_pointer privileged_keyword_location; extern struct pso_pointer privileged_keyword_name; +extern struct pso_pointer privileged_keyword_system; +extern struct pso_pointer privileged_keyword_user; struct pso_pointer initialise_privileged_keywords( struct pso_pointer env); #endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ diff --git a/src/c/memory/tags.h b/src/c/memory/tags.h index 63bf30b..8306583 100644 --- a/src/c/memory/tags.h +++ b/src/c/memory/tags.h @@ -43,7 +43,7 @@ #define STRINGTAG "STR" #define SYMBOLTAG "SYM" #define TIMETAG "TIM" -#define TRUETAG "TRU" +#define TRUETAG "TRL" #define VECTORTAG "VEC" #define VECTORPOINTTAG "VSP" #define WRITETAG "WRT" diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index f22a20f..c78e0e7 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -35,7 +35,7 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, struct pso_pointer env = fetch_env(frame_pointer); #ifdef DEBUG - debug_print( U"\n\tCond clause: ", DEBUG_EVAL, 0 ); + debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); #endif @@ -50,19 +50,19 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); #ifdef DEBUG - debug_print( U"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( U" succeeded; returning: ", DEBUG_EVAL, 0 ); + debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); } else { - debug_print( U"\n\t\tCond clause ", DEBUG_EVAL, 0 ); + debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_print( U" failed.\n", DEBUG_EVAL, 0 ); + debug_print( L" failed.\n", DEBUG_EVAL, 0 ); #endif } } else { - result = throw_exception( c_string_to_lisp_symbol( frame_pointer, U"cond" ), + result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), c_string_to_lisp_string (frame_pointer, L"Arguments to `cond` must be lists" ), frame_pointer ); @@ -103,7 +103,7 @@ struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) { } } #ifdef DEBUG - debug_print( U"\tCond returning: ", DEBUG_EVAL, 0 ); + debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); #endif diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 17e0f11..f2ef638 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -46,6 +46,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { if ( c_eq( a, b ) ) { result = true; } else if ( get_tag_value( a ) == get_tag_value( b ) ) { + /* assume true and try to falsify */ + result = true; struct pso2 *oa = pointer_to_object( a ); struct pso2 *ob = pointer_to_object( b ); @@ -88,7 +90,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { /** - * Function; do all arguments to this finction point to the same object? + * Function; do all arguments to this function point to the same object? * * Shallow, cheap equality. * diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 0c5b19c..b35e947 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -601,7 +601,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { special. executable ) ) ( next_pointer ), fn_pointer ); - debug_print( U"Special form returning: ", DEBUG_EVAL, + debug_print( L"Special form returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); @@ -623,7 +623,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { c_string_to_lisp_string( frame_pointer, buffer ); free( buffer ); result = - throw_exception( c_string_to_lisp_symbol( frame_pointer, U"apply" ), + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"apply" ), message, frame_pointer ); } } diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index e09379d..44921b1 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -27,7 +27,7 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso4* frame = pointer_to_pso4(frame_pointer); - debug_print( U"Mapcar: ", DEBUG_EVAL, 0 ); + debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); int i = 0; @@ -38,7 +38,7 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { make_cons( frame_pointer, frame->payload.stack_frame.arg[0], make_cons( frame_pointer, c_car( c ), nil ) ) ); - debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, evaluating ", i ); + debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); @@ -50,14 +50,14 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { } else { result = push_local( frame_pointer, make_cons( frame_pointer, r, result )); } - debug_printf( DEBUG_EVAL, 0, U"Mapcar %d, result is ", i++ ); + debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, result is ", i++ ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL); } result = consp( result ) ? c_reverse( frame_pointer, result ) : result; - debug_print( U"Mapcar returning: ", DEBUG_EVAL, 0 ); + debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 08dbfef..1bdd236 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -114,15 +114,15 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location, struct pso_pointer result = nil; #ifdef DEBUG - debug_print( U"\nERROR: `", DEBUG_ANY, 0 ); + debug_print( L"\nERROR: `", DEBUG_ANY, 0 ); debug_print_object( message, DEBUG_ANY, 0 ); - debug_print( U"` at `", DEBUG_ANY, 0 ); + debug_print( L"` at `", DEBUG_ANY, 0 ); debug_print_object( location, DEBUG_ANY, 0 ); - debug_print( U"`\n", DEBUG_ANY, 0 ); + debug_print( L"`\n", DEBUG_ANY, 0 ); if ( !c_nilp( cause ) ) { - debug_print( U"\tCaused by: ", DEBUG_ANY, 0 ); + debug_print( L"\tCaused by: ", DEBUG_ANY, 0 ); debug_print_object( cause, DEBUG_ANY, 0); - debug_print( U"`\n", DEBUG_ANY, 0 ); + debug_print( L"`\n", DEBUG_ANY, 0 ); } #endif struct pso2 *cell = pointer_to_object( message ); diff --git a/src/sh/wchar_t_everywhere.sh b/src/sh/wchar_t_everywhere.sh index a193083..5bb30aa 100644 --- a/src/sh/wchar_t_everywhere.sh +++ b/src/sh/wchar_t_everywhere.sh @@ -4,5 +4,6 @@ for file in src/c/*/*.[ch] do echo $file cp $file $file.bak - sed 's/char32_t/wchar_t/g' $file.bak > $file + sed 's/char32_t/wchar_t/g' $file.bak |\ + sed 's/U"/L"/g' > $file done From 80049f2272564e26eef122c37858911fe9ad8e42 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 16:45:56 +0100 Subject: [PATCH 74/77] Ran a 'make format', because !'m close to being able to merge this feature. --- src/c/environment/environment.c | 15 +- src/c/environment/function_bindings.c | 410 +++++++++++++----------- src/c/environment/function_bindings.h | 4 +- src/c/environment/privileged_keywords.c | 19 +- src/c/environment/privileged_keywords.h | 2 +- src/c/io/alphabets.h | 2 +- src/c/io/io.c | 14 +- src/c/io/io.h | 27 +- src/c/io/peek.c | 23 +- src/c/io/print.c | 55 ++-- src/c/io/print.h | 7 +- src/c/io/read.c | 23 +- src/c/memory/dump.c | 327 ++++++++++--------- src/c/memory/pso.c | 24 +- src/c/memory/pso2.h | 4 +- src/c/ops/assoc.c | 23 +- src/c/ops/assoc.h | 2 +- src/c/ops/bind.c | 1 - src/c/ops/cond.c | 42 +-- src/c/ops/eq.c | 4 +- src/c/ops/eval_apply.c | 375 ++++++++++++---------- src/c/ops/inspect.c | 6 +- src/c/ops/inspect.h | 6 +- src/c/ops/keys.c | 19 +- src/c/ops/keys.h | 4 +- src/c/ops/list_ops.c | 1 - src/c/ops/mapcar.c | 33 +- src/c/ops/mapcar.h | 2 +- src/c/ops/progn.c | 44 +-- src/c/ops/progn.h | 11 +- src/c/ops/quote.c | 6 +- src/c/ops/quote.h | 4 +- src/c/ops/repl.c | 4 +- src/c/ops/reverse.c | 22 +- src/c/ops/string_ops.c | 6 +- src/c/ops/string_ops.h | 6 +- src/c/payloads/exception.c | 33 +- src/c/payloads/float.h | 4 +- src/c/payloads/function.c | 19 +- src/c/payloads/function.h | 8 +- src/c/payloads/keyword.c | 8 +- src/c/payloads/keyword.h | 6 +- src/c/payloads/lambda.c | 15 +- src/c/payloads/lambda.h | 11 +- src/c/payloads/psse_string.h | 2 +- src/c/payloads/special.c | 19 +- src/c/payloads/special.h | 8 +- src/c/payloads/stack.c | 52 +-- src/c/payloads/stack.h | 3 +- src/c/payloads/stack_payload.h | 2 +- src/c/payloads/symbol.c | 6 +- src/c/payloads/symbol.h | 6 +- 52 files changed, 936 insertions(+), 843 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index dbc5f84..c167eb1 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -81,7 +81,7 @@ struct pso_pointer initialise_environment( uint32_t node ) { } } if ( !exceptionp( result ) ) { - frame_pointer = inc_ref( make_frame(0, nil)); + frame_pointer = inc_ref( make_frame( 0, nil ) ); result = lisp_bind( make_frame ( 3, frame_pointer, @@ -103,13 +103,16 @@ struct pso_pointer initialise_environment( uint32_t node ) { debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); - initialise_privileged_keywords(frame_pointer); + initialise_privileged_keywords( frame_pointer ); - result = inc_ref( initialise_function_bindings(push_local( - frame_pointer, make_frame_with_env(0, frame_pointer, result)))); + result = + inc_ref( initialise_function_bindings + ( push_local + ( frame_pointer, + make_frame_with_env( 0, frame_pointer, result ) ) ) ); - dec_ref(frame_pointer); + dec_ref( frame_pointer ); } - return result; + return result; } diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index 80b6a5d..b393c3c 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -59,34 +59,40 @@ */ struct pso_pointer -bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, - struct pso_pointer (*executable)(struct pso_pointer)) { - struct pso_pointer result = fetch_env(frame_pointer); - struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); - struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); +bind_function( struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, + struct pso_pointer ( *executable ) ( struct pso_pointer ) ) { + struct pso_pointer result = fetch_env( frame_pointer ); + struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name ); + struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc ); - struct pso_pointer meta = make_cons( - frame_pointer, - make_cons(frame_pointer, privileged_keyword_layer, privileged_keyword_bootstrap), - make_cons(frame_pointer, - make_cons(frame_pointer, privileged_keyword_name, n), - make_cons(frame_pointer, - make_cons(frame_pointer, - privileged_keyword_documentation, d), - nil))); + struct pso_pointer meta = make_cons( frame_pointer, + make_cons( frame_pointer, + privileged_keyword_layer, + privileged_keyword_bootstrap ), + make_cons( frame_pointer, + make_cons( frame_pointer, + privileged_keyword_name, + n ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + privileged_keyword_documentation, + d ), + nil ) ) ); - struct pso_pointer r = make_function(frame_pointer, meta, executable); + struct pso_pointer r = make_function( frame_pointer, meta, executable ); - debug_print(doc, DEBUG_BOOTSTRAP, 0); - if (!exceptionp(r)) { - debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0); - result = - make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); - } else { - debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0); - } + debug_print( doc, DEBUG_BOOTSTRAP, 0 ); + if ( !exceptionp( r ) ) { + debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 ); + result = + make_cons( frame_pointer, make_cons( frame_pointer, n, r ), + result ); + } else { + debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 ); + } - return result; + return result; } /** @@ -94,40 +100,46 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, * this `name` in the `oblist`. */ struct pso_pointer -bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, - struct pso_pointer (*executable)(struct pso_pointer)) { - struct pso_pointer result = fetch_env(frame_pointer); - struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name); - struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc); +bind_special( struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc, + struct pso_pointer ( *executable ) ( struct pso_pointer ) ) { + struct pso_pointer result = fetch_env( frame_pointer ); + struct pso_pointer n = c_string_to_lisp_symbol( frame_pointer, name ); + struct pso_pointer d = c_string_to_lisp_string( frame_pointer, doc ); - struct pso_pointer meta = make_cons( - frame_pointer, - make_cons(frame_pointer, privileged_keyword_bootstrap, nil), - make_cons(frame_pointer, - make_cons(frame_pointer, privileged_keyword_name, n), - make_cons(frame_pointer, - make_cons(frame_pointer, - privileged_keyword_documentation, d), - nil))); + struct pso_pointer meta = make_cons( frame_pointer, + make_cons( frame_pointer, + privileged_keyword_bootstrap, + nil ), + make_cons( frame_pointer, + make_cons( frame_pointer, + privileged_keyword_name, + n ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + privileged_keyword_documentation, + d ), + nil ) ) ); - struct pso_pointer r = make_special(frame_pointer, meta, executable); + struct pso_pointer r = make_special( frame_pointer, meta, executable ); - debug_print(doc, DEBUG_BOOTSTRAP, 0); - if (!exceptionp(r)) { - debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0); - result = - make_cons(frame_pointer, make_cons(frame_pointer, n, r), result); - } else { - debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0); - } + debug_print( doc, DEBUG_BOOTSTRAP, 0 ); + if ( !exceptionp( r ) ) { + debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 ); + result = + make_cons( frame_pointer, make_cons( frame_pointer, n, r ), + result ); + } else { + debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 ); + } - return result; + return result; } struct function_data { - wchar_t *name; - wchar_t *documentation; - void *executable; + wchar_t *name; + wchar_t *documentation; + void *executable; }; /* right, the problem with all those pretty '#ifdefs' which might allow us to @@ -140,152 +152,151 @@ struct function_data { /** initialisers for functions */ struct function_data function_initialisers[] = { #ifdef _psse_io_io_h - {L"close", L"(close stream): close `stream`.", &lisp_close}, - {L"open", - L"(open stream), (open stream write?): open `stream`; if `write?` is " - L"present and is non-nil, open for writing, else for reading.", - &lisp_open}, - {L"slurp", - L"(slurp stream): read the whole contents of this `stream`, " - L"which may " - L"be an open stream open for reading or a URL, into a string, and return " - L"the " - L"string.", - &lisp_slurp}, + {L"close", L"(close stream): close `stream`.", &lisp_close}, + {L"open", + L"(open stream), (open stream write?): open `stream`; if `write?` is " + L"present and is non-nil, open for writing, else for reading.", + &lisp_open}, + {L"slurp", + L"(slurp stream): read the whole contents of this `stream`, " + L"which may " + L"be an open stream open for reading or a URL, into a string, and return " + L"the " L"string.", + &lisp_slurp}, #endif #ifdef __psse_io_peek_h - {L"peek", - L"(peek stream): return the next character which may be read from " - L"`stream`, without removing it.", - &peek}, + {L"peek", + L"(peek stream): return the next character which may be read from " + L"`stream`, without removing it.", + &peek}, #endif #ifdef __psse_io_print_h - {L"print", - L"(print object), (print object stream) print this `object` in a format " - L"suitable to be read by `read`, q.v.; if `stream` is specified and is a " - L"stream open for writing, to that stream.", - &print}, - {L"princ", - L"(princ object), (princ object stream) print this `object` in a format " - L"more suited to human readers; if `stream` is specified and is a stream " - L"open for writing, to that stream.", - &print}, + {L"print", + L"(print object), (print object stream) print this `object` in a format " + L"suitable to be read by `read`, q.v.; if `stream` is specified and is a " + L"stream open for writing, to that stream.", + &print}, + {L"princ", + L"(princ object), (princ object stream) print this `object` in a format " + L"more suited to human readers; if `stream` is specified and is a stream " + L"open for writing, to that stream.", + &print}, #endif #ifdef __psse_io_read_h - {L"read", - L"(read stream) read one complete Lisp expression from `stream`, and " - L"return that expression unevaluated.", - &read}, - {L"read-character", - L"(read-character stream): read a single character from `stream` and " - L"return it.", - &read_character}, - {L"read-number", - L"(read-number stream): read a number from `stream` and return it.", - &read_number}, - {L"read-symbol", - L"(read-symbol stream): read a symbol from `stream` and return it.", - &read_symbol}, + {L"read", + L"(read stream) read one complete Lisp expression from `stream`, and " + L"return that expression unevaluated.", + &read}, + {L"read-character", + L"(read-character stream): read a single character from `stream` and " + L"return it.", + &read_character}, + {L"read-number", + L"(read-number stream): read a number from `stream` and return it.", + &read_number}, + {L"read-symbol", + L"(read-symbol stream): read a symbol from `stream` and return it.", + &read_symbol}, #endif #ifdef __psse_ops_assoc_h - {L"assoc", - L"(assoc key store): search `store` for the value associated with " - L"`key`.", - &assoc}, + {L"assoc", + L"(assoc key store): search `store` for the value associated with " + L"`key`.", + &assoc}, #endif #ifdef __psse_ops_bind_h - {L"bind!", - L"(bind! key value store): bind `key` to `value` in this store, modifying " - L"the store if it is writable to the user, otherwise returning a new " - L"store", - &bind}, + {L"bind!", + L"(bind! key value store): bind `key` to `value` in this store, modifying " + L"the store if it is writable to the user, otherwise returning a new " + L"store", + &bind}, #endif #ifdef __psse_ops_eq_h - {L"eq", - L"(eq args...): shallow, cheap equality; returns `t` if all `args...` " - L"are the same object, else `nil`.", - &eq}, - {L"equal", - L"(equal a b): expensive, deep equality: returns `t` if objects `a` " - L"and `b` have recursively equal value.", - &equal}, + {L"eq", + L"(eq args...): shallow, cheap equality; returns `t` if all `args...` " + L"are the same object, else `nil`.", + &eq}, + {L"equal", + L"(equal a b): expensive, deep equality: returns `t` if objects `a` " + L"and `b` have recursively equal value.", + &equal}, #endif #ifdef __psse_ops_eval_apply_h - // TODO: there's a lot of other stuff in eval_apply.c, which ought to be in - // other files but at present isn't. - {L"apply", - L"(apply fn args...): apply this `fn` to these `args...` and return " - L"their value.", - &lisp_apply}, - {L"eval", - L"(eval expression): evaluate this `expression` and return its value", - &lisp_eval}, + // TODO: there's a lot of other stuff in eval_apply.c, which ought to be in + // other files but at present isn't. + {L"apply", + L"(apply fn args...): apply this `fn` to these `args...` and return " + L"their value.", + &lisp_apply}, + {L"eval", + L"(eval expression): evaluate this `expression` and return its value", + &lisp_eval}, #endif #ifdef __psse_ops_inspect_h - {L"inspect", - L"(inspect expr), (inspect expr write-stream): inspect one complete " - L"lisp expression and return `nil`. If `write-stream` is specified and " - L"is a write stream, then print to that stream, else to the stream " - L"which is the value of `*out*` in the environment.", - &lisp_inspect}, + {L"inspect", + L"(inspect expr), (inspect expr write-stream): inspect one complete " + L"lisp expression and return `nil`. If `write-stream` is specified and " + L"is a write stream, then print to that stream, else to the stream " + L"which is the value of `*out*` in the environment.", + &lisp_inspect}, #endif #ifdef __psse_ops_keys_h - {L"keys", L"(keys store): returns a list of the keys in this `store`.", - &lisp_keys}, + {L"keys", L"(keys store): returns a list of the keys in this `store`.", + &lisp_keys}, #endif #ifdef __psse_ops_list_ops_h - {L"count", - L"(count sequence): returns the number of top level elements in " - L"`sequence`.", - &count}, + {L"count", + L"(count sequence): returns the number of top level elements in " + L"`sequence`.", + &count}, #endif #ifdef __psse_ops_mapcar_h - {L"mapcar", - L"(mapcar fn list): map this `fn` over this `list`, and return a list " - L"of the results.", - &lisp_mapcar}, + {L"mapcar", + L"(mapcar fn list): map this `fn` over this `list`, and return a list " + L"of the results.", + &lisp_mapcar}, #endif #ifdef __psse_ops_progn_h - {L"progn", - L"(progn expressions...): Evaluate each expression in " - L"`expressions` in turn and return the value of the last.", - &lisp_progn}, + {L"progn", + L"(progn expressions...): Evaluate each expression in " + L"`expressions` in turn and return the value of the last.", + &lisp_progn}, #endif #ifdef __psse_ops_repl_h - {L"repl", L"(repl show_prompt?): Start a new read, eval, print loop.", - &repl}, + {L"repl", L"(repl show_prompt?): Start a new read, eval, print loop.", + &repl}, #endif #ifdef __psse_ops_reverse_h - {L"reverse", - L"(reverse sequence): return a sequence like this `sequence`, but with " - L"the order of top level elements reversed.", - &reverse}, + {L"reverse", + L"(reverse sequence): return a sequence like this `sequence`, but with " + L"the order of top level elements reversed.", + &reverse}, #endif #ifdef __psse_ops_truth_h - {L"and", - L"(and expressions...): returns `t` if none of these `expressions...` " - L"evaluates to `nil`, else `nil`.", - &and}, - {L"nil?", - L"(nil? expression): returns `t` if `expression` evaluates to `nil`, else " - L"`nil`.", - &nilp}, - {L"not", - L"(not expression): returns `t` unless `expression` evaluates to `nil`, " - L"else " - L"`nil`.", - ¬}, - {L"or", - L"(or expressions...): returns `nil` if every one of these `expressions...` " - L"evaluates to `nil`, else `t`.", - &or}, - {L"true?", - L"(true? expression): returns `t` if `expression` evaluates to `t`, else " - L"`nil`.", - &truep}, + {L"and", + L"(and expressions...): returns `t` if none of these `expressions...` " + L"evaluates to `nil`, else `nil`.", + &and}, + {L"nil?", + L"(nil? expression): returns `t` if `expression` evaluates to `nil`, else " + L"`nil`.", + &nilp}, + {L"not", + L"(not expression): returns `t` unless `expression` evaluates to `nil`, " + L"else " L"`nil`.", + ¬}, + {L"or", + L"(or expressions...): returns `nil` if every one of these `expressions...` " + L"evaluates to `nil`, else `t`.", + &or}, + {L"true?", + L"(true? expression): returns `t` if `expression` evaluates to `t`, else " + L"`nil`.", + &truep}, #endif - {L"END MARKER", L"END MARKER", NULL}}; + {L"END MARKER", L"END MARKER", NULL} +}; /* right, the problem with all those pretty '#ifdefs' which might allow us to * simply switch functions on and off just by including or not including .h @@ -296,41 +307,48 @@ struct function_data function_initialisers[] = { /** initialisers for special forms */ struct function_data special_initialisers[] = { #ifdef __psse_ops_cond_h - {L"cond", - L"(cond clauses...): special form; conditional. Each `clause` is expected " - L"to be a " - L"list; if the first item in such a list evaluates to non-nil, the " - L"remaining items in that list are evaluated in turn and the value of " - L"the last returned. If no arg `clause` has a first element which " - L"evaluates to non nil, then nil is returned", - &lisp_cond}, + {L"cond", + L"(cond clauses...): special form; conditional. Each `clause` is expected " + L"to be a " + L"list; if the first item in such a list evaluates to non-nil, the " + L"remaining items in that list are evaluated in turn and the value of " + L"the last returned. If no arg `clause` has a first element which " + L"evaluates to non nil, then nil is returned", + &lisp_cond}, #endif #ifdef __psse_ops_quote_h - {L"quote", - L"(quote expression): special form; protect `expression` from " - L"evaluation.", - "e}, + {L"quote", + L"(quote expression): special form; protect `expression` from " + L"evaluation.", + "e}, #endif - {L"END MARKER", L"END MARKER", NULL}}; + {L"END MARKER", L"END MARKER", NULL} +}; struct pso_pointer -initialise_function_bindings(struct pso_pointer frame_pointer) { - struct pso_pointer result = fetch_env(frame_pointer); +initialise_function_bindings( struct pso_pointer frame_pointer ) { + struct pso_pointer result = fetch_env( frame_pointer ); - for (int i = 0; function_initialisers[i].executable != NULL; i++) { - struct pso_pointer b = c_car( bind_function( frame_pointer, - function_initialisers[i].name, - function_initialisers[i].documentation, - function_initialisers[i].executable)); - result = make_cons( frame_pointer, b, result); - } - for (int i = 0; special_initialisers[i].executable != NULL; i++) { - struct pso_pointer b = c_car( bind_special( frame_pointer, - special_initialisers[i].name, - special_initialisers[i].documentation, - special_initialisers[i].executable)); - result = make_cons( frame_pointer, b, result); - } + for ( int i = 0; function_initialisers[i].executable != NULL; i++ ) { + struct pso_pointer b = c_car( bind_function( frame_pointer, + function_initialisers[i]. + name, + function_initialisers[i]. + documentation, + function_initialisers[i]. + executable ) ); + result = make_cons( frame_pointer, b, result ); + } + for ( int i = 0; special_initialisers[i].executable != NULL; i++ ) { + struct pso_pointer b = c_car( bind_special( frame_pointer, + special_initialisers[i]. + name, + special_initialisers[i]. + documentation, + special_initialisers[i]. + executable ) ); + result = make_cons( frame_pointer, b, result ); + } - return result; -} \ No newline at end of file + return result; +} diff --git a/src/c/environment/function_bindings.h b/src/c/environment/function_bindings.h index 0a061f4..48a83c7 100644 --- a/src/c/environment/function_bindings.h +++ b/src/c/environment/function_bindings.h @@ -13,5 +13,5 @@ #define __psse_environment_function_bindings_h struct pso_pointer -initialise_function_bindings(struct pso_pointer frame_pointer); -#endif \ No newline at end of file +initialise_function_bindings( struct pso_pointer frame_pointer ); +#endif diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c index 1a807bb..26f785e 100644 --- a/src/c/environment/privileged_keywords.c +++ b/src/c/environment/privileged_keywords.c @@ -63,12 +63,13 @@ struct pso_pointer privileged_keyword_user; #define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val))) -struct pso_pointer initialise_privileged_keywords(struct pso_pointer frame_pointer) { - load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP); - load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION); - load_and_lock(privileged_keyword_layer, PK_LAYER); - load_and_lock(privileged_keyword_location, PK_LOCATION); - load_and_lock( privileged_keyword_name, PK_NAME); - load_and_lock(privileged_keyword_system, PK_SYSTEM); - load_and_lock(privileged_keyword_user, PK_USER); -} \ No newline at end of file +struct pso_pointer initialise_privileged_keywords( struct pso_pointer + frame_pointer ) { + load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP ); + load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION ); + load_and_lock( privileged_keyword_layer, PK_LAYER ); + load_and_lock( privileged_keyword_location, PK_LOCATION ); + load_and_lock( privileged_keyword_name, PK_NAME ); + load_and_lock( privileged_keyword_system, PK_SYSTEM ); + load_and_lock( privileged_keyword_user, PK_USER ); +} diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h index 0bee337..fe08e4c 100644 --- a/src/c/environment/privileged_keywords.h +++ b/src/c/environment/privileged_keywords.h @@ -29,5 +29,5 @@ extern struct pso_pointer privileged_keyword_name; extern struct pso_pointer privileged_keyword_system; extern struct pso_pointer privileged_keyword_user; -struct pso_pointer initialise_privileged_keywords( struct pso_pointer env); +struct pso_pointer initialise_privileged_keywords( struct pso_pointer env ); #endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ diff --git a/src/c/io/alphabets.h b/src/c/io/alphabets.h index 60e5ff3..8970fc0 100644 --- a/src/c/io/alphabets.h +++ b/src/c/io/alphabets.h @@ -16,4 +16,4 @@ #define GREEK L"ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσςΤτΥυΦφΧχΨψΩω" #define ELDERFUTHARK L"ᚠᚢᚦᚨᚱᚲᚷᚹᚺᚾᛁᛃᛈᛇᛉᛊᛏᛒᛖᛗᛚᛜᛞᛟ" -#endif \ No newline at end of file +#endif diff --git a/src/c/io/io.c b/src/c/io/io.c index 31f64c4..38ff1d3 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -371,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c, 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( c )->payload. + character.character ), pointer_to_object( r )->payload.stream.stream ) >= 0 ) { result = t; @@ -393,13 +393,13 @@ struct pso_pointer push_back_character( struct pso_pointer c, * @param env my environment. * @return T if the stream was successfully closed, else nil. */ -struct pso_pointer lisp_close( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_close( struct pso_pointer frame_pointer ) { 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 ) + ( pointer_to_object( fetch_arg( frame, 0 ) )->payload. + stream.stream ) == 0 ) { result = t; } @@ -593,7 +593,7 @@ URL_FILE *stream_get_url_file( struct pso_pointer s ) { * @param frame_pointer a pointer to my stack frame. * @return a stream open on the URL indicated by the first argument. */ -struct pso_pointer lisp_open( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_open( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; if ( stringp( fetch_arg( frame, 0 ) ) ) { @@ -651,7 +651,7 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer) { * @return return a string representing all characters from the stream * indicated by arg 0 */ -struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; if ( readp( fetch_arg( frame, 0 ) ) ) { diff --git a/src/c/io/io.h b/src/c/io/io.h index cd37d5d..d6acd86 100644 --- a/src/c/io/io.h +++ b/src/c/io/io.h @@ -24,9 +24,10 @@ extern CURLSH *io_share; -int initialise_io(); -struct pso_pointer initialise_default_streams(struct pso_pointer frame_pointer, - struct pso_pointer env); +int initialise_io( ); +struct pso_pointer initialise_default_streams( struct pso_pointer + frame_pointer, + struct pso_pointer env ); #define C_IO_IN L"*in*" #define C_IO_OUT L"*out*" @@ -49,19 +50,19 @@ extern struct pso_pointer lisp_stderr; extern struct pso_pointer lisp_io_prompt; -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); +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 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 get_default_stream( bool inputp, struct pso_pointer env ); -URL_FILE *stream_get_url_file(struct pso_pointer s); +URL_FILE *stream_get_url_file( struct pso_pointer s ); -struct pso_pointer lisp_close(struct pso_pointer frame_pointer); -struct pso_pointer lisp_open(struct pso_pointer frame_pointer); -struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer); +struct pso_pointer lisp_close( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_open( struct pso_pointer frame_pointer ); +struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer ); #endif diff --git a/src/c/io/peek.c b/src/c/io/peek.c index b926456..ad64c47 100644 --- a/src/c/io/peek.c +++ b/src/c/io/peek.c @@ -25,18 +25,17 @@ * * (peek stream) */ -struct pso_pointer peek(struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso_pointer input = - pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0]; +struct pso_pointer peek( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer input = + pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0]; - if (readp(input)) { - URL_FILE *stream = pointer_to_object(input)->payload.stream.stream; - wint_t c = url_fgetwc(stream); - url_ungetwc(c, stream); + if ( readp( input ) ) { + URL_FILE *stream = pointer_to_object( input )->payload.stream.stream; + wint_t c = url_fgetwc( stream ); + url_ungetwc( c, stream ); - result = make_character(frame_pointer, c); - } - return result; + result = make_character( frame_pointer, c ); + } + return result; } - diff --git a/src/c/io/print.c b/src/c/io/print.c index c9b0f7d..e780b20 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -83,8 +83,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p, if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) { for ( struct pso_pointer cursor = p; !c_nilp( cursor ); cursor = pointer_to_object( cursor )->payload.string.cdr ) { - wchar_t wc = - pointer_to_object( cursor )->payload.string.character; + wchar_t wc = pointer_to_object( cursor )->payload.string.character; write_char( wc, output, escape ); } @@ -189,14 +188,15 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, } else { url_fputws( L"", output ); } - } break; - case FUNCTIONTV: { - struct pso2 *function = pointer_to_object(p); - url_fputws(L"payload.function.meta, output, escape, - indent); - write_char( L'>', output, escape ); - } break; + } + break; + case FUNCTIONTV:{ + struct pso2 *function = pointer_to_object( p ); + url_fputws( L"payload.function.meta, output, escape, + indent ); + write_char( L'>', output, escape ); + } break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -217,13 +217,13 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, indent ); write_char( L'>', output, escape ); break; - case SPECIALTV: { - struct pso2 *function = pointer_to_object(p); - url_fputws(L"payload.function.meta, output, escape, - indent); - write_char( L'>', output, escape ); - } break; + case SPECIALTV:{ + struct pso2 *function = pointer_to_object( p ); + url_fputws( L"payload.function.meta, output, escape, + indent ); + write_char( L'>', output, escape ); + } break; case TRUETV: write_char( L't', output, escape ); break; @@ -281,15 +281,19 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { return result; } -struct pso_pointer c_write(struct pso_pointer frame_pointer, - struct pso_pointer object, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after) { - struct pso_pointer next_pointer = - push_local(frame_pointer, make_frame(5, frame_pointer, object, stream, escape ? t : nil, - nl_before ? t : nil, nl_after ? t : nil)); - struct pso_pointer result = push_local(frame_pointer, write(next_pointer)); +struct pso_pointer c_write( struct pso_pointer frame_pointer, + struct pso_pointer object, + struct pso_pointer stream, bool escape, + bool nl_before, bool nl_after ) { + struct pso_pointer next_pointer = + push_local( frame_pointer, + make_frame( 5, frame_pointer, object, stream, + escape ? t : nil, + nl_before ? t : nil, nl_after ? t : nil ) ); + struct pso_pointer result = + push_local( frame_pointer, write( next_pointer ) ); - return result; + return result; } /** @@ -333,4 +337,3 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) { return result; } - diff --git a/src/c/io/print.h b/src/c/io/print.h index 44f2bfa..233e87d 100644 --- a/src/c/io/print.h +++ b/src/c/io/print.h @@ -26,9 +26,10 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ); struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output, bool escape, int indent ); -struct pso_pointer c_write(struct pso_pointer frame_pointer, - struct pso_pointer object, struct pso_pointer stream, - bool escape, bool nl_before, bool nl_after); +struct pso_pointer c_write( struct pso_pointer frame_pointer, + struct pso_pointer object, + struct pso_pointer stream, bool escape, + bool nl_before, bool nl_after ); #define c_print(f,o,s)(c_write(f,o,s,true,true,false)) #define c_princ(f,o,s)(c_write(f,o,s,false,true,false)) diff --git a/src/c/io/read.c b/src/c/io/read.c index 4813c70..65c2a08 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -146,15 +146,17 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) { URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) { - if ( iswdigit( c ) ){value = ( value * base ) + ( ( int ) c - ( int ) L'0' );} + if ( iswdigit( c ) ) { + value = ( value * base ) + ( ( int ) c - ( int ) L'0' ); + } } url_ungetwc( c, input ); result = make_integer( frame_pointer, value ); } // else exception? #ifdef DEBUG - debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); - debug_dump_object(result, DEBUG_IO, 1); + debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); + debug_dump_object( result, DEBUG_IO, 1 ); #endif return result; @@ -185,13 +187,12 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { url_ungetwc( c, input ); result = c_reverse( frame_pointer, result ); } - #ifdef DEBUG - debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); - debug_print_object( result, DEBUG_IO, 0); - debug_print( L"`\n\t", DEBUG_IO, 0); - debug_dump_object(result, DEBUG_IO, 1); - #endif + debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0 ); + debug_print( L"`\n\t", DEBUG_IO, 0 ); + debug_dump_object( result, DEBUG_IO, 1 ); +#endif return result; } @@ -283,8 +284,8 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { #ifdef DEBUG debug_print( L"Read expression: `", DEBUG_IO, 0 ); debug_print_object( result, DEBUG_IO, 0 ); - debug_print( L"`\n", DEBUG_IO, 0 ); - debug_dump_object(result, DEBUG_IO, 1); + debug_print( L"`\n", DEBUG_IO, 0 ); + debug_dump_object( result, DEBUG_IO, 1 ); #endif return result; diff --git a/src/c/memory/dump.c b/src/c/memory/dump.c index 36a9755..b4c1fd6 100644 --- a/src/c/memory/dump.c +++ b/src/c/memory/dump.c @@ -45,13 +45,14 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix, struct pso_pointer pointer ) { - struct pso2* object = pointer_to_object( pointer ); + struct pso2 *object = pointer_to_object( pointer ); if ( object->payload.string.character == 0 ) { url_fwprintf( output, L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", prefix, object->payload.string.cdr.page, - object->payload.string.cdr.offset, object->header.count ); + object->payload.string.cdr.offset, + object->header.count ); } else { url_fwprintf( output, L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", @@ -60,17 +61,21 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix, object->payload.string.character, object->payload.string.hash, object->payload.string.cdr.page, - object->payload.string.cdr.offset, object->header.count ); + object->payload.string.cdr.offset, + object->header.count ); url_fwprintf( output, L"\t\t value: " ); - in_write( pointer, output, false, 0); - if (stringlikep(pointer)) { - url_fwprintf( output, L"\n\t\t structure: " ); - for ( struct pso_pointer cursor = pointer; !c_nilp(cursor); cursor = c_cdr(cursor)) { - wint_t c = pointer_to_object(cursor)->payload.string.character; - char* tag = (pointer_to_object(cursor)->header.tag.bytes.mnemonic); - url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c); - } - } + in_write( pointer, output, false, 0 ); + if ( stringlikep( pointer ) ) { + url_fwprintf( output, L"\n\t\t structure: " ); + for ( struct pso_pointer cursor = pointer; !c_nilp( cursor ); + cursor = c_cdr( cursor ) ) { + wint_t c = + pointer_to_object( cursor )->payload.string.character; + char *tag = + ( pointer_to_object( cursor )->header.tag.bytes.mnemonic ); + url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c ); + } + } url_fwprintf( output, L"\n" ); } @@ -79,9 +84,9 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix, void dump_frame_context_fragment( URL_FILE *output, struct pso_pointer frame_pointer, - uint arg) { - if ( stackp(frame_pointer )) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); + uint arg ) { + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); url_fwprintf( output, L" <= " ); in_write( frame->payload.stack_frame.arg[arg], output, false, 0 ); @@ -90,7 +95,7 @@ void dump_frame_context_fragment( URL_FILE *output, void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, int depth ) { - if ( stackp(frame_pointer) ) { + if ( stackp( frame_pointer ) ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); url_fwprintf( output, L"\tContext: " ); @@ -98,7 +103,8 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, int i = 0; for ( struct pso_pointer cursor = frame_pointer; i++ < depth && !c_nilp( cursor ); - cursor = pointer_to_pso4(cursor)->payload.stack_frame.previous ) { + cursor = + pointer_to_pso4( cursor )->payload.stack_frame.previous ) { dump_frame_context_fragment( output, cursor, 0 ); } @@ -112,18 +118,20 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer, * @param frame_pointer the pointer to the frame */ void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { - if ( stackp(frame_pointer) ) { + if ( stackp( frame_pointer ) ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); url_fwprintf( output, L"Stack frame %d with %d arguments:\n", - frame->payload.stack_frame.depth, frame->payload.stack_frame.args ); + frame->payload.stack_frame.depth, + frame->payload.stack_frame.args ); dump_frame_context( output, frame_pointer, 4 ); for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) { - struct pso2* object = pointer_to_object( fetch_arg(frame, arg)); + struct pso2 *object = pointer_to_object( fetch_arg( frame, arg ) ); url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ", - arg, object->header.tag.bytes.mnemonic[0], object->header.count ); + arg, object->header.tag.bytes.mnemonic[0], + object->header.count ); in_write( frame->payload.stack_frame.arg[arg], output, false, 0 ); url_fputws( L"\n", output ); @@ -139,13 +147,12 @@ void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) { void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { if ( exceptionp( pointer ) ) { - struct pso3* exep = pointer_to_pso3( pointer); + struct pso3 *exep = pointer_to_pso3( pointer ); in_write( exep->payload.exception.message, output, false, 0 ); url_fputws( L"\n", output ); - dump_stack_trace( output, - exep->payload.exception.stack ); + dump_stack_trace( output, exep->payload.exception.stack ); } else { - while ( stackp( pointer) ) { + while ( stackp( pointer ) ) { dump_frame( output, pointer ); pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous; } @@ -168,142 +175,142 @@ void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) { * to be dumped. */ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { - struct pso_pointer result = nil; - struct pso_pointer stream = nil; - struct pso_pointer pointer = nil; - - if (stackp(frame_pointer)) { - struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso_pointer result = nil; + struct pso_pointer stream = nil; + struct pso_pointer pointer = nil; - pointer = fetch_arg( frame, 0); - stream = fetch_arg( frame, 1); - } else { - pointer = frame_pointer; - } + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); - if (!writep(stream)) { - stream = lisp_stderr; - } - -// URL_FILE* output = file_to_url_file(stderr); -// url_fputws( L"\ndump_object printing to output stream; metadata: ", output ); -// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 ); -// url_fputws( L"\n", output ); -// fflush(stderr); - - URL_FILE* output = pointer_to_object(stream)->payload.stream.stream; + pointer = fetch_arg( frame, 0 ); + stream = fetch_arg( frame, 1 ); + } else { + pointer = frame_pointer; + } - if (c_nilp(pointer)) { - // the object at (node, 0, 0) ought to have been initialised, but may not - // have been... - url_fputws(L"nil of size class 2 at page 0, offset 0, count xxxx\n", output ); - } else { - struct pso2* object = pointer_to_object( pointer ); - url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", - object->header.tag.bytes.mnemonic, - get_tag_value(pointer), - object->header.tag.bytes.size_class, - pointer.page, pointer.offset, - object->header.count ); - - switch ( get_tag_value( pointer) ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons object: car at page %d offset %d, cdr at page %d " - L"offset %d :", - object->payload.cons.car.page, - object->payload.cons.car.offset, - object->payload.cons.cdr.page, - object->payload.cons.cdr.offset); - in_write( pointer, output, false, 0 ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException object: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, - L"\t\tFree object: next at page %d offset %d\n", - object->payload.free.next.page, - object->payload.free.next.offset); - break; - case INTEGERTV: - url_fwprintf( output, L"\t\tInteger object: value %ld\n", - object->payload.integer.value ); - break; - case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); - break; - // case LAMBDATV: - // url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " ); - // in_write( output, object->payload.lambda.args ); - // url_fwprintf( output, L";\n\t\t\tbody: " ); - // in_write( output, object->payload.lambda.body ); - // url_fputws( L"\n", output ); - // break; - // case NILTV: - // break; - // case NLAMBDATV: - // url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " ); - // in_write( output, object->payload.lambda.args ); - // url_fwprintf( output, L";\n\t\t\tbody: " ); - // in_write( output, object->payload.lambda.body ); - // url_fputws( L"\n", output ); - // break; - // case RATIOTV: - // url_fwprintf( output, - // L"\t\tRational object: value %ld/%ld, count %u\n", - // pointer_to_object( object->payload.ratio.dividend ). - // payload.integer.value, - // pointer_to_object( object->payload.ratio.divisor ). - // payload.integer.value, object->count ); - // break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - in_write( object->payload.stream.meta, output, false, 0 ); - url_fputws( L"\n", output ); - break; - // case REALTV: - // url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n", - // object->payload.real.value, object->count ); - // break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - // case TRUETV: - // break; - // case VECTORPOINTTV:{ - // url_fwprintf( output, - // L"\t\tPointer to vector-space object at %p\n", - // object->payload.vectorp.address ); - // struct vector_space_object *vso = object->payload.vectorp.address; - // url_fwprintf( output, - // L"\t\tVector space object of type %4.4s (%d), payload size " - // L"%d bytes\n", - // &vso->header.tag.bytes, vso->header.tag.value, - // vso->header.size ); - // - // switch ( vso->header.tag.value ) { - // case STACKFRAMETV: - // dump_frame( output, pointer ); - // break; - // case HASHTV: - // dump_map( output, pointer ); - // break; - // } - // } - // break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - in_write( object->payload.stream.meta, output, false, 0 ); - url_fputws( L"\n", output ); - break; - } - } - - return result; + if ( !writep( stream ) ) { + stream = lisp_stderr; + } +// URL_FILE* output = file_to_url_file(stderr); +// url_fputws( L"\ndump_object printing to output stream; metadata: ", output ); +// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 ); +// url_fputws( L"\n", output ); +// fflush(stderr); + + URL_FILE *output = pointer_to_object( stream )->payload.stream.stream; + + if ( c_nilp( pointer ) ) { + // the object at (node, 0, 0) ought to have been initialised, but may not + // have been... + url_fputws( L"nil of size class 2 at page 0, offset 0, count xxxx\n", + output ); + } else { + struct pso2 *object = pointer_to_object( pointer ); + url_fwprintf( output, + L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n", + object->header.tag.bytes.mnemonic, + get_tag_value( pointer ), + object->header.tag.bytes.size_class, pointer.page, + pointer.offset, object->header.count ); + + switch ( get_tag_value( pointer ) ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons object: car at page %d offset %d, cdr at page %d " + L"offset %d :", + object->payload.cons.car.page, + object->payload.cons.car.offset, + object->payload.cons.cdr.page, + object->payload.cons.cdr.offset ); + in_write( pointer, output, false, 0 ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException object: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree object: next at page %d offset %d\n", + object->payload.free.next.page, + object->payload.free.next.offset ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger object: value %ld\n", + object->payload.integer.value ); + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + // case LAMBDATV: + // url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " ); + // in_write( output, object->payload.lambda.args ); + // url_fwprintf( output, L";\n\t\t\tbody: " ); + // in_write( output, object->payload.lambda.body ); + // url_fputws( L"\n", output ); + // break; + // case NILTV: + // break; + // case NLAMBDATV: + // url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " ); + // in_write( output, object->payload.lambda.args ); + // url_fwprintf( output, L";\n\t\t\tbody: " ); + // in_write( output, object->payload.lambda.body ); + // url_fputws( L"\n", output ); + // break; + // case RATIOTV: + // url_fwprintf( output, + // L"\t\tRational object: value %ld/%ld, count %u\n", + // pointer_to_object( object->payload.ratio.dividend ). + // payload.integer.value, + // pointer_to_object( object->payload.ratio.divisor ). + // payload.integer.value, object->count ); + // break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + in_write( object->payload.stream.meta, output, false, 0 ); + url_fputws( L"\n", output ); + break; + // case REALTV: + // url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n", + // object->payload.real.value, object->count ); + // break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + // case TRUETV: + // break; + // case VECTORPOINTTV:{ + // url_fwprintf( output, + // L"\t\tPointer to vector-space object at %p\n", + // object->payload.vectorp.address ); + // struct vector_space_object *vso = object->payload.vectorp.address; + // url_fwprintf( output, + // L"\t\tVector space object of type %4.4s (%d), payload size " + // L"%d bytes\n", + // &vso->header.tag.bytes, vso->header.tag.value, + // vso->header.size ); + // + // switch ( vso->header.tag.value ) { + // case STACKFRAMETV: + // dump_frame( output, pointer ); + // break; + // case HASHTV: + // dump_map( output, pointer ); + // break; + // } + // } + // break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + in_write( object->payload.stream.meta, output, false, 0 ); + url_fputws( L"\n", output ); + break; + } + } + + return result; } diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index e16fafb..b5e97d4 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -60,8 +60,8 @@ void print_allocation_table( ) { } #endif -struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, - uint8_t size_class); +struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer, + char *tag, uint8_t size_class ); /** * @brief a means of creating a cons cell without using a stack frame, to @@ -88,20 +88,20 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, * get excessive spurius missing stack frame warnings. Not to be called * outside this file! */ -struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, - uint8_t size_class) { +struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer, + char *tag, uint8_t size_class ) { struct pso_pointer result = pop_freelist( size_class ); #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, - L"\nAllocating object of size class %d with tag `%s`... ", - size_class, tag ); + L"\nAllocating object of size class %d with tag `%s`... ", + size_class, tag ); #endif struct pso2 *obj = pointer_to_object( result ); strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, - result.offset ); + result.offset ); if ( stackp( frame_pointer ) ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); // You can't make a stack frame in the middle of making a stack @@ -116,7 +116,7 @@ struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag, #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, - 0 ); + 0 ); #endif return result; @@ -147,7 +147,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); } - return cheaty_allocate(frame_pointer, tag, size_class); + return cheaty_allocate( frame_pointer, tag, size_class ); } @@ -189,8 +189,10 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { L"\nIncremented object of type %3.3s, size class %d, " L"at page %u, offset %u to count %u", ( ( char * ) & - ( object->header.tag. - bytes.mnemonic + ( object-> + header. + tag.bytes. + mnemonic [0] ) ), ( int ) object->header.tag.bytes.size_class, pointer.page, pointer.offset, object->header.count ); diff --git a/src/c/memory/pso2.h b/src/c/memory/pso2.h index 5c459de..76217d6 100644 --- a/src/c/memory/pso2.h +++ b/src/c/memory/pso2.h @@ -51,8 +51,8 @@ struct pso2 { struct free_payload free; struct function_payload function; struct integer_payload integer; - struct lambda_payload lambda; - struct float_payload real; + struct lambda_payload lambda; + struct float_payload real; struct function_payload special; struct stream_payload stream; struct string_payload string; diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index 5dfdd63..e5ba28a 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -45,7 +45,7 @@ struct pso_pointer search( struct pso_pointer key, debug_print( L"In search; key is: `", DEBUG_BIND, 0 ); debug_print_object( key, DEBUG_BIND, 0 ); debug_print( L"`\n", DEBUG_BIND, 0 ); - debug_dump_object(key, DEBUG_BIND, 1); + debug_dump_object( key, DEBUG_BIND, 1 ); #endif if ( consp( store ) ) { @@ -54,9 +54,9 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer pair = c_car( cursor ); #ifdef DEBUG debug_print( L"Checking `", DEBUG_BIND, 1 ); - debug_print_object( c_car( pair), DEBUG_BIND, 0 ); - debug_print(L"`\n", DEBUG_BIND, 2); - debug_dump_object(c_car(pair), DEBUG_BIND, 2); + debug_print_object( c_car( pair ), DEBUG_BIND, 0 ); + debug_print( L"`\n", DEBUG_BIND, 2 ); + debug_dump_object( c_car( pair ), DEBUG_BIND, 2 ); #endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { @@ -117,14 +117,13 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) { * * @return a pointer to the value of the key in the store, or nil if not found */ -struct pso_pointer assoc( - struct pso_pointer frame_pointer ) { +struct pso_pointer assoc( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_assoc( key, store ); } @@ -145,8 +144,8 @@ struct pso_pointer interned( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_interned( key, store ); } @@ -167,8 +166,8 @@ struct pso_pointer internedp( struct pso_pointer key = fetch_arg( frame, 0 ); struct pso_pointer store = or( make_frame( 2, frame_pointer, fetch_arg( frame, 1 ), - frame->payload. - stack_frame.env ) ); + frame->payload.stack_frame. + env ) ); return c_internedp( key, store ) ? t : nil; } diff --git a/src/c/ops/assoc.h b/src/c/ops/assoc.h index 1fcf981..7cf073d 100644 --- a/src/c/ops/assoc.h +++ b/src/c/ops/assoc.h @@ -16,7 +16,7 @@ #include "memory/pointer.h" -struct pso_pointer assoc(struct pso_pointer frame_pointer); +struct pso_pointer assoc( struct pso_pointer frame_pointer ); struct pso_pointer search( struct pso_pointer key, struct pso_pointer store, bool return_key ); diff --git a/src/c/ops/bind.c b/src/c/ops/bind.c index fbcbfe5..82c1fd9 100644 --- a/src/c/ops/bind.c +++ b/src/c/ops/bind.c @@ -35,4 +35,3 @@ struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) { return cons( make_frame( 2, frame_pointer, binding, store ) ); } - diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index c78e0e7..d0e5744 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -30,31 +30,34 @@ */ struct pso_pointer eval_cond_clause( struct pso_pointer clause, struct pso4 *frame, - struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso_pointer env = fetch_env(frame_pointer); + struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso_pointer env = fetch_env( frame_pointer ); #ifdef DEBUG debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); #endif if ( consp( clause ) ) { - struct pso_pointer test_frame = push_local( frame_pointer, make_frame(1, frame_pointer, c_car(clause))); - struct pso_pointer val = lisp_eval(test_frame); + struct pso_pointer test_frame = + push_local( frame_pointer, + make_frame( 1, frame_pointer, c_car( clause ) ) ); + struct pso_pointer val = lisp_eval( test_frame ); if ( !c_nilp( val ) ) { result = make_cons( frame_pointer, t, - c_progn( frame, frame_pointer, c_cdr( clause ), env ) ); + c_progn( frame, frame_pointer, c_cdr( clause ), + env ) ); #ifdef DEBUG debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); } else { debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 ); debug_print_object( clause, DEBUG_EVAL, 0 ); @@ -62,10 +65,11 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, #endif } } else { - result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), - c_string_to_lisp_string - (frame_pointer, L"Arguments to `cond` must be lists" ), - frame_pointer ); + result = + throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ), + c_string_to_lisp_string( frame_pointer, + L"Arguments to `cond` must be lists" ), + frame_pointer ); } return result; @@ -81,18 +85,18 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, * * @return the value of the last expression of the first successful `clause`. */ -struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) { - struct pso4 *frame = pointer_to_pso4(frame_pointer); +struct pso_pointer lisp_cond( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; bool done = false; for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) { struct pso_pointer clause_pointer = fetch_arg( frame, i ); - // TODO: WHOOPS! This isn't right. If the test of a cond clause - // evaluates to non-nil, but the last form of the clause evaluates - // to nil, the form still succeeded and we should still exit `cond`. - // + // TODO: WHOOPS! This isn't right. If the test of a cond clause + // evaluates to non-nil, but the last form of the clause evaluates + // to nil, the form still succeeded and we should still exit `cond`. + // result = eval_cond_clause( clause_pointer, frame, frame_pointer ); @@ -105,7 +109,7 @@ struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) { #ifdef DEBUG debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); #endif return result; diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index f2ef638..c395b6e 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -46,8 +46,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { if ( c_eq( a, b ) ) { result = true; } else if ( get_tag_value( a ) == get_tag_value( b ) ) { - /* assume true and try to falsify */ - result = true; + /* assume true and try to falsify */ + result = true; struct pso2 *oa = pointer_to_object( a ); struct pso2 *ob = pointer_to_object( b ); diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index b35e947..5dc79f4 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -110,7 +110,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) { debug_print( L" returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); - debug_dump_object(result, DEBUG_EVAL, 1); + debug_dump_object( result, DEBUG_EVAL, 1 ); return result; } @@ -155,11 +155,12 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { * * This is experimental. It almost certainly WILL change. */ -struct pso_pointer lisp_try( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_try( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer body_frame = - push_local( frame_pointer, make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + push_local( frame_pointer, + make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); result = push_local( frame_pointer, lisp_progn( body_frame ) ); @@ -167,16 +168,19 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) { // TODO: need to put the exception into the environment! struct pso_pointer catch_frame = push_local( frame_pointer, make_frame_with_env( 1, frame_pointer, - make_cons( frame_pointer, - make_cons( frame_pointer, + make_cons + ( frame_pointer, + make_cons + ( frame_pointer, c_string_to_lisp_symbol ( frame_pointer, L"*exception*" ), result ), - fetch_env - ( frame_pointer ) ), - frame->payload.stack_frame. - arg[1] ) ); + fetch_env + ( frame_pointer ) ), + frame->payload. + stack_frame.arg + [1] ) ); result = push_local( frame_pointer, lisp_progn( catch_frame ) ); } @@ -195,7 +199,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) { * @return the root namespace. */ struct pso_pointer -lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer) { +lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer ) { return oblist; } @@ -235,10 +239,10 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) { * @param env the environment in which it is to be intepreted. * @return an interpretable function with these `args` and this `body`. */ -struct pso_pointer -lisp_lambda( struct pso_pointer frame_pointer ) { - struct pso4* frame = pointer_to_pso4(frame_pointer); - return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); +struct pso_pointer lisp_lambda( struct pso_pointer frame_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + return make_lambda( frame_pointer, fetch_arg( frame, 0 ), + compose_body( frame_pointer ) ); } /** @@ -253,22 +257,21 @@ lisp_lambda( struct pso_pointer frame_pointer ) { * @return an interpretable special form with these `args` and this `body`. */ struct pso_pointer -lisp_nlambda( struct pso_pointer frame_pointer, - struct pso_pointer env ) { - struct pso4* frame = pointer_to_pso4(frame_pointer); - return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) ); +lisp_nlambda( struct pso_pointer frame_pointer, struct pso_pointer env ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + return make_nlambda( frame_pointer, fetch_arg( frame, 0 ), + compose_body( frame_pointer ) ); } /** * Evaluate a lambda or nlambda expression. */ -struct pso_pointer -eval_lambda( struct pso_pointer frame_pointer ) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso2 *lambda = pointer_to_object(fetch_arg(frame, 0)); - struct pso_pointer args = fetch_arg( frame, 1); +struct pso_pointer eval_lambda( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso2 *lambda = pointer_to_object( fetch_arg( frame, 0 ) ); + struct pso_pointer args = fetch_arg( frame, 1 ); struct pso_pointer new_env = fetch_env( frame_pointer ); struct pso_pointer names = lambda->payload.lambda.args; @@ -299,12 +302,12 @@ eval_lambda( struct pso_pointer frame_pointer ) { /* 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->payload.stack_frame.more */ - struct pso_pointer more_frame = inc_ref( - make_frame(1, frame_pointer, - frame->payload.stack_frame.more)); + struct pso_pointer more_frame = inc_ref( make_frame( 1, frame_pointer, + frame->payload. + stack_frame. + more ) ); - struct pso_pointer vals = - eval_forms( more_frame ); + struct pso_pointer vals = eval_forms( more_frame ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct pso_pointer next = @@ -407,43 +410,46 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r, * * @return a pointer to the new frame. */ -struct pso_pointer make_fn_frame(struct pso_pointer previous, - struct pso_pointer fn_pointer, - struct pso_pointer arg_list) { +struct pso_pointer make_fn_frame( struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list ) { - struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); - struct pso_pointer next_pointer = - push_local(previous, make_frame(1, previous, nil)); - struct pso4 *next_frame = pointer_to_pso4(next_pointer); + struct pso_pointer next_pointer = + push_local( previous, make_frame( 1, previous, nil ) ); + struct pso4 *next_frame = pointer_to_pso4( next_pointer ); new_frame->payload.stack_frame.function = fn_pointer; - int args = 0; - struct pso_pointer cursor; - for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { - // Reusing a frame like this is a bit of an abuse but will save allocation churn. - next_frame->payload.stack_frame.arg[0] = c_car(cursor); - new_frame->payload.stack_frame.arg[args++] = inc_ref( lisp_eval( next_pointer) ); - } - if (consp(cursor)) { - struct pso_pointer more = nil; + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp( cursor ) && args < args_in_frame; + cursor = c_cdr( cursor ) ) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car( cursor ); + new_frame->payload.stack_frame.arg[args++] = + inc_ref( lisp_eval( next_pointer ) ); + } + if ( consp( cursor ) ) { + struct pso_pointer more = nil; - for (; consp(cursor); cursor = c_cdr(cursor)) { - // Reusing a frame like this is a bit of an abuse but will save - // allocation churn. - next_frame->payload.stack_frame.arg[0] = c_car(cursor); - more = make_cons(previous, lisp_eval(next_pointer), more); + for ( ; consp( cursor ); cursor = c_cdr( cursor ) ) { + // Reusing a frame like this is a bit of an abuse but will save + // allocation churn. + next_frame->payload.stack_frame.arg[0] = c_car( cursor ); + more = make_cons( previous, lisp_eval( next_pointer ), more ); args++; - } + } - new_frame->payload.stack_frame.more = push_local( previous, c_reverse( previous, more)); - } + new_frame->payload.stack_frame.more = + push_local( previous, c_reverse( previous, more ) ); + } - new_frame->payload.stack_frame.args = args; + new_frame->payload.stack_frame.args = args; - return new_pointer; + return new_pointer; } /** @@ -457,29 +463,31 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous, * * @return a pointer to the new frame. */ -struct pso_pointer make_special_frame(struct pso_pointer previous, - struct pso_pointer fn_pointer, - struct pso_pointer arg_list) { +struct pso_pointer make_special_frame( struct pso_pointer previous, + struct pso_pointer fn_pointer, + struct pso_pointer arg_list ) { - struct pso_pointer new_pointer = make_frame( 0, previous ); + struct pso_pointer new_pointer = make_frame( 0, previous ); struct pso4 *new_frame = pointer_to_pso4( new_pointer ); new_frame->payload.stack_frame.function = fn_pointer; - int args = 0; - struct pso_pointer cursor; - for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) { - // Reusing a frame like this is a bit of an abuse but will save allocation churn. - new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) ); - } - if (consp(cursor)) { + int args = 0; + struct pso_pointer cursor; + for ( cursor = arg_list; consp( cursor ) && args < args_in_frame; + cursor = c_cdr( cursor ) ) { + // Reusing a frame like this is a bit of an abuse but will save allocation churn. + new_frame->payload.stack_frame.arg[args++] = + inc_ref( c_car( cursor ) ); + } + if ( consp( cursor ) ) { - new_frame->payload.stack_frame.more = inc_ref( cursor); - } + new_frame->payload.stack_frame.more = inc_ref( cursor ); + } - new_frame->payload.stack_frame.args = args; + new_frame->payload.stack_frame.args = args; - return new_pointer; + return new_pointer; } /** @@ -489,15 +497,18 @@ struct pso_pointer make_special_frame(struct pso_pointer previous, * @param env The evaluation environment. * @return the result of evaluating the function with its arguments. */ -struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_apply( struct pso_pointer frame_pointer ) { debug_print( L"Entering apply\n", DEBUG_EVAL, 0 ); struct pso_pointer result = nil; - struct pso4* frame = pointer_to_pso4(frame_pointer); - struct pso_pointer fn_frame = inc_ref( make_frame(1, frame_pointer, c_car( frame->payload.stack_frame.arg[0] ))); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer fn_frame = + inc_ref( make_frame + ( 1, frame_pointer, + c_car( frame->payload.stack_frame.arg[0] ) ) ); struct pso_pointer fn_pointer = - push_local(frame_pointer, eval_form( fn_frame)); - dec_ref( fn_frame); + push_local( frame_pointer, eval_form( fn_frame ) ); + dec_ref( fn_frame ); if ( exceptionp( fn_pointer ) ) { result = fn_pointer; @@ -514,35 +525,33 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { case FUNCTIONTV: { struct pso_pointer next_pointer = - inc_ref( make_fn_frame( frame_pointer, fn_pointer, args )); + inc_ref( make_fn_frame + ( frame_pointer, fn_pointer, args ) ); if ( exceptionp( next_pointer ) ) { result = next_pointer; } else { - result = push_local( frame_pointer, - maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - function. - executable ) ) - (next_pointer ), - fn_pointer )); + result = push_local( frame_pointer, + maybe_fixup_exception_location( ( *( fn_cell->payload.function.executable ) ) + ( next_pointer ), fn_pointer ) ); dec_ref( next_pointer ); } } break; - case KEYTV: { - struct pso_pointer map_frame = - inc_ref(make_frame(1, frame_pointer, c_car(args))); - result = push_local( - frame_pointer, - c_assoc(fn_pointer, - maybe_fixup_exception_location( - eval_form(map_frame), fn_pointer))); - } break; + case KEYTV:{ + struct pso_pointer map_frame = + inc_ref( make_frame + ( 1, frame_pointer, c_car( args ) ) ); + result = + push_local( frame_pointer, + c_assoc( fn_pointer, + maybe_fixup_exception_location + ( eval_form( map_frame ), + fn_pointer ) ) ); + } break; - case LAMBDATV: + case LAMBDATV: { struct pso_pointer next_pointer = make_fn_frame( frame_pointer, fn_pointer, args ); @@ -551,8 +560,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { result = next_pointer; } else { struct pso4 *next = pointer_to_pso4( next_pointer ); - result = - eval_lambda( next_pointer ); + result = eval_lambda( next_pointer ); if ( !exceptionp( result ) ) { dec_ref( next_pointer ); } @@ -561,7 +569,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { break; case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ + /* \todo: if arg[0] is a CONS, treat it as a path */ // result = c_assoc( eval_form( frame, // frame_pointer, @@ -580,8 +588,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { result = next_pointer; } else { struct pso4 *next = pointer_to_pso4( next_pointer ); - result = - eval_lambda( next_pointer ); + result = eval_lambda( next_pointer ); dec_ref( next_pointer ); } } @@ -596,15 +603,12 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { result = next_pointer; } else { result = maybe_fixup_exception_location( ( * - ( fn_cell-> - payload. - special. - executable ) ) + ( fn_cell->payload.special.executable ) ) ( next_pointer ), fn_pointer ); debug_print( L"Special form returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); dec_ref( next_pointer ); } } @@ -617,14 +621,15 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { memset( buffer, '\0', bs ); swprintf( buffer, bs, L"Unexpected cell with tag %u (%3.3s) in function position", - get_tag_value(fn_pointer), + get_tag_value( fn_pointer ), &( fn_cell->header.tag.bytes.mnemonic[0] ) ); struct pso_pointer message = c_string_to_lisp_string( frame_pointer, buffer ); free( buffer ); result = - throw_exception( c_string_to_lisp_symbol( frame_pointer, L"apply" ), - message, frame_pointer ); + throw_exception( c_string_to_lisp_symbol + ( frame_pointer, L"apply" ), message, + frame_pointer ); } } @@ -633,7 +638,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { debug_print( L"apply: returning: ", DEBUG_EVAL, 0 ); debug_print_object( result, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); - debug_dump_object( result, DEBUG_EVAL, 0 ); + debug_dump_object( result, DEBUG_EVAL, 0 ); return result; } @@ -655,42 +660,46 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) { * * 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 pso_pointer -lisp_eval( struct pso_pointer frame_pointer ) { +struct pso_pointer lisp_eval( struct pso_pointer frame_pointer ) { debug_print( L"Eval: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); - struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = frame->payload.stack_frame.arg[0]; - struct pso2 *cell = pointer_to_object(frame->payload.stack_frame.arg[0]); - struct pso_pointer env = fetch_env(frame_pointer); + struct pso2 *cell = pointer_to_object( frame->payload.stack_frame.arg[0] ); + struct pso_pointer env = fetch_env( frame_pointer ); - switch (get_tag_value(result)) { - case CONSTV: { - struct pso_pointer next_pointer = - push_local(frame_pointer, make_frame(2, frame_pointer, - c_car(result), c_cdr(result))); - result = push_local(frame_pointer, lisp_apply(next_pointer)); - } break; + switch ( get_tag_value( result ) ) { + case CONSTV:{ + struct pso_pointer next_pointer = + push_local( frame_pointer, make_frame( 2, frame_pointer, + c_car( result ), + c_cdr( result ) ) ); + result = + push_local( frame_pointer, lisp_apply( next_pointer ) ); + } break; - case SYMBOLTV: + case SYMBOLTV: { #ifdef DEBUG - debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0); - debug_print_object( fetch_arg( frame, 0), DEBUG_EVAL, 0); - debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0); - debug_dump_object( fetch_env(frame_pointer), DEBUG_EVAL, 0); + debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0 ); + debug_print_object( fetch_arg( frame, 0 ), DEBUG_EVAL, 0 ); + debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0 ); + debug_dump_object( fetch_env( frame_pointer ), DEBUG_EVAL, 0 ); #endif struct pso_pointer canonical = - c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) ); + c_interned( frame->payload.stack_frame.arg[0], + fetch_env( frame_pointer ) ); if ( c_nilp( canonical ) ) { struct pso_pointer message = make_cons( frame_pointer, c_string_to_lisp_string - ( frame_pointer, L"Attempt to take value of unbound symbol." ), - frame->payload.stack_frame.arg[0] ); + ( frame_pointer, + L"Attempt to take value of unbound symbol." ), + frame->payload.stack_frame.arg[0] ); result = - throw_exception( c_string_to_lisp_symbol( frame_pointer, L"eval" ), - message, frame_pointer ); + throw_exception( c_string_to_lisp_symbol + ( frame_pointer, L"eval" ), message, + frame_pointer ); } else { result = c_assoc( canonical, env ); // inc_ref( result ); @@ -706,9 +715,9 @@ lisp_eval( struct pso_pointer frame_pointer ) { default: // we've already done this... break; - } + } - debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); + debug_print( L"Eval returning ", DEBUG_EVAL, 0 ); debug_dump_object( result, DEBUG_EVAL, 0 ); return result; @@ -737,17 +746,22 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer, * @param pointer a pointer to the object whose type is requested. * @return As a Lisp string, the tag of the object which is at that pointer. */ -struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer pointer ) { +struct pso_pointer c_type( struct pso_pointer frame_pointer, + struct pso_pointer pointer ) { /* Strings read by `read` have the null character termination. This means * that for the same printable string, the hashcode is different from * strings made with NIL termination. The question is which should be * fixed, and actually that's probably strings read by `read`. However, * for now, it was easier to add a null character here. */ - struct pso_pointer result = make_symbol( frame_pointer, ( wchar_t ) 0, nil ); + struct pso_pointer result = + make_symbol( frame_pointer, ( wchar_t ) 0, nil ); struct pso2 *cell = pointer_to_object( pointer ); for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_symbol( frame_pointer, ( wchar_t ) cell->header.tag.bytes.mnemonic[i], result ); + result = + make_symbol( frame_pointer, + ( wchar_t ) cell->header.tag.bytes.mnemonic[i], + result ); } return result; @@ -761,9 +775,9 @@ struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer * * @return As a Lisp symbol, the tag of `expression`. */ -struct pso_pointer -lisp_type( struct pso_pointer frame_pointer ) { - return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) ); +struct pso_pointer lisp_type( struct pso_pointer frame_pointer ) { + return c_type( frame_pointer, + fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) ); } @@ -779,13 +793,13 @@ lisp_type( struct pso_pointer frame_pointer ) { * @return the source of the `object` indicated, if it is a function, a lambda, * an nlambda, or a spcial form; else `nil`. */ -struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { +struct pso_pointer lisp_source( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; - struct pso4* frame = pointer_to_pso4(frame_pointer); - struct pso2 *cell = - pointer_to_object( fetch_arg( frame, 0) ); - struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" ); - switch ( get_tag_value(fetch_arg( frame, 0)) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso2 *cell = pointer_to_object( fetch_arg( frame, 0 ) ); + struct pso_pointer source_key = + c_string_to_lisp_keyword( frame_pointer, L"source" ); + switch ( get_tag_value( fetch_arg( frame, 0 ) ) ) { case FUNCTIONTV: result = c_assoc( source_key, cell->payload.function.meta ); break; @@ -794,17 +808,19 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { break; case LAMBDATV: result = make_cons( frame_pointer, - c_string_to_lisp_symbol( frame_pointer, L"λ" ), - make_cons( frame_pointer, - cell->payload.lambda.args, - cell->payload.lambda.body ) ); + c_string_to_lisp_symbol( frame_pointer, + L"λ" ), + make_cons( frame_pointer, + cell->payload.lambda.args, + cell->payload.lambda.body ) ); break; case NLAMBDATV: result = make_cons( frame_pointer, - c_string_to_lisp_symbol( frame_pointer, L"nλ" ), - make_cons( frame_pointer, - cell->payload.lambda.args, - cell->payload.lambda.body ) ); + c_string_to_lisp_symbol( frame_pointer, + L"nλ" ), + make_cons( frame_pointer, + cell->payload.lambda.args, + cell->payload.lambda.body ) ); break; } push_local( frame_pointer, result ); @@ -820,7 +836,7 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) { * @return struct pso_pointer a pointer to the result */ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { - struct pso4* frame = pointer_to_pso4( frame_pointer); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = frame->payload.stack_frame.more; for ( int a = @@ -840,51 +856,60 @@ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) { * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) { - struct pso4* frame = pointer_to_pso4( frame_pointer); - struct pso_pointer bindings = fetch_env(frame_pointer); + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer bindings = fetch_env( frame_pointer ); struct pso_pointer result = nil; - for ( struct pso_pointer cursor = fetch_arg( frame, 0); + for ( struct pso_pointer cursor = fetch_arg( frame, 0 ); c_truep( cursor ); cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); struct pso_pointer symbol = c_car( pair ); - struct pso_pointer next_pointer = push_local( frame_pointer, make_frame_with_env( 0, frame_pointer, bindings)); + struct pso_pointer next_pointer = + push_local( frame_pointer, + make_frame_with_env( 0, frame_pointer, bindings ) ); if ( symbolp( symbol ) ) { - add_arg(next_pointer, c_cdr(pair)); - struct pso_pointer val = - eval_form( next_pointer ); + add_arg( next_pointer, c_cdr( pair ) ); + struct pso_pointer val = eval_form( next_pointer ); // debug_print_binding( symbol, val, false, DEBUG_BIND ); - bindings = make_cons( frame_pointer, make_cons( frame_pointer, symbol, val ), bindings ); + bindings = + make_cons( frame_pointer, + make_cons( frame_pointer, symbol, val ), bindings ); } else { result = - throw_exception( c_string_to_lisp_symbol( frame_pointer, L"let" ), - c_string_to_lisp_string( frame_pointer, L"Let: cannot bind, not a symbol" ), + throw_exception( c_string_to_lisp_symbol + ( frame_pointer, L"let" ), + c_string_to_lisp_string( frame_pointer, + L"Let: cannot bind, not a symbol" ), frame_pointer ); break; } } - if (!exceptionp(result)) { + if ( !exceptionp( result ) ) { debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 ); - struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, bindings); - struct pso4* progn_frame = pointer_to_pso4(progn_pointer); + struct pso_pointer progn_pointer = + make_frame_with_env( 0, frame_pointer, bindings ); + struct pso4 *progn_frame = pointer_to_pso4( progn_pointer ); int a = 1; - for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - progn_frame->payload.stack_frame.args ++; + for ( ; a < frame->payload.stack_frame.args && a < args_in_frame; a++ ) { + progn_frame->payload.stack_frame.arg[a - 1] = + fetch_arg( frame, a ); + progn_frame->payload.stack_frame.args++; } - if ( a < frame->payload.stack_frame.args) { - progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a); - progn_frame->payload.stack_frame.more = c_cdr( frame->payload.stack_frame.more); + if ( a < frame->payload.stack_frame.args ) { + progn_frame->payload.stack_frame.arg[a - 1] = + fetch_arg( frame, a ); + progn_frame->payload.stack_frame.more = + c_cdr( frame->payload.stack_frame.more ); } - result = lisp_progn(progn_pointer); + result = lisp_progn( progn_pointer ); } return result; @@ -904,8 +929,8 @@ struct pso_pointer lisp_and( struct pso4 *frame, bool accumulator = true; struct pso_pointer result = frame->payload.stack_frame.more; - for ( int a = 0; accumulator == true && a < frame->payload.stack_frame.args; - a++ ) { + for ( int a = 0; + accumulator == true && a < frame->payload.stack_frame.args; a++ ) { accumulator = truthy( fetch_arg( frame, a ) ); } # diff --git a/src/c/ops/inspect.c b/src/c/ops/inspect.c index 67c883d..bb920e5 100644 --- a/src/c/ops/inspect.c +++ b/src/c/ops/inspect.c @@ -35,8 +35,8 @@ * @param env my environment (from which the stream may be extracted). * @return nil. */ -struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 ); +struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 ); struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); @@ -46,7 +46,7 @@ struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) { : get_default_stream( false, fetch_env( frame_pointer ) ); URL_FILE *output; - dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) ); + dump_object( frame_pointer, fetch_arg( frame, 1 ), fetch_arg( frame, 0 ) ); debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 ); diff --git a/src/c/ops/inspect.h b/src/c/ops/inspect.h index a383dfa..2f9bdae 100644 --- a/src/c/ops/inspect.h +++ b/src/c/ops/inspect.h @@ -17,9 +17,9 @@ /** * Legacy technical debt to be entirely rewritten */ -void dump_object(struct pso_pointer frame_pointer, - struct pso_pointer output, struct pso_pointer pointer ); +void dump_object( struct pso_pointer frame_pointer, + struct pso_pointer output, struct pso_pointer pointer ); struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ); -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/keys.c b/src/c/ops/keys.c index 5eaffdd..0099917 100644 --- a/src/c/ops/keys.c +++ b/src/c/ops/keys.c @@ -20,8 +20,8 @@ * @brief an implementation of `keys` convenient for calling from C * * @param */ -struct pso_pointer c_keys(struct pso_pointer frame_pointer, - struct pso_pointer store ) { +struct pso_pointer c_keys( struct pso_pointer frame_pointer, + struct pso_pointer store ) { struct pso_pointer result = nil; if ( consp( store ) ) { @@ -29,14 +29,14 @@ struct pso_pointer c_keys(struct pso_pointer frame_pointer, pair = c_car( store ) ) { if ( consp( pair ) ) { result = make_cons( frame_pointer, c_car( pair ), result ); - // } else if ( hashtabp( pair ) ) { - // result = c_append( hashmap_keys( pair ), result ); + // } else if ( hashtabp( pair ) ) { + // result = c_append( hashmap_keys( pair ), result ); } store = c_cdr( store ); } - // } else if ( hashtabp( store ) ) { - // result = hashmap_keys( store ); + // } else if ( hashtabp( store ) ) { + // result = hashmap_keys( store ); } return result; @@ -44,7 +44,8 @@ struct pso_pointer c_keys(struct pso_pointer frame_pointer, -struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) { - return c_keys( frame_pointer, pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] ); +struct pso_pointer lisp_keys( struct pso_pointer frame_pointer ) { + return c_keys( frame_pointer, + pointer_to_pso4( frame_pointer )->payload.stack_frame. + arg[0] ); } - diff --git a/src/c/ops/keys.h b/src/c/ops/keys.h index a912936..fa6e03e 100644 --- a/src/c/ops/keys.h +++ b/src/c/ops/keys.h @@ -14,6 +14,6 @@ struct pso_pointer c_keys( struct pso_pointer store ); -struct pso_pointer lisp_keys(struct pso_pointer frame_pointer); +struct pso_pointer lisp_keys( struct pso_pointer frame_pointer ); -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/list_ops.c b/src/c/ops/list_ops.c index 5cb3151..93d7c55 100644 --- a/src/c/ops/list_ops.c +++ b/src/c/ops/list_ops.c @@ -33,4 +33,3 @@ struct pso_pointer count( struct pso_pointer frame_pointer ) { return acquire_integer( frame_pointer, c ); } - diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index 44921b1..d6315b4 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -25,34 +25,43 @@ #include "payloads/cons.h" struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { - struct pso_pointer result = nil; - struct pso4* frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); debug_print( L"Mapcar: ", DEBUG_EVAL, 0 ); debug_dump_object( frame_pointer, DEBUG_EVAL, 0 ); int i = 0; - for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c ); - c = c_cdr( c ) ) { - struct pso_pointer expr = - push_local( frame_pointer, - make_cons( frame_pointer, frame->payload.stack_frame.arg[0], - make_cons( frame_pointer, c_car( c ), nil ) ) ); + for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; + c_truep( c ); c = c_cdr( c ) ) { + struct pso_pointer expr = push_local( frame_pointer, + make_cons( frame_pointer, + frame->payload. + stack_frame.arg[0], + make_cons + ( frame_pointer, + c_car( c ), + nil ) ) ); debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i ); debug_print_object( expr, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); - struct pso_pointer r = lisp_eval( push_local( frame_pointer, make_frame(1, frame_pointer, expr))); + struct pso_pointer r = + lisp_eval( push_local + ( frame_pointer, + make_frame( 1, frame_pointer, expr ) ) ); if ( exceptionp( r ) ) { result = r; break; } else { - result = push_local( frame_pointer, make_cons( frame_pointer, r, result )); + result = + push_local( frame_pointer, + make_cons( frame_pointer, r, result ) ); } debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, result is ", i++ ); debug_print_object( result, DEBUG_EVAL, 0 ); - debug_println( DEBUG_EVAL); + debug_println( DEBUG_EVAL ); } result = consp( result ) ? c_reverse( frame_pointer, result ) : result; diff --git a/src/c/ops/mapcar.h b/src/c/ops/mapcar.h index 50408a9..bb1c24a 100644 --- a/src/c/ops/mapcar.h +++ b/src/c/ops/mapcar.h @@ -14,4 +14,4 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ); -#endif \ No newline at end of file +#endif diff --git a/src/c/ops/progn.c b/src/c/ops/progn.c index 3fdef99..a6a21bb 100644 --- a/src/c/ops/progn.c +++ b/src/c/ops/progn.c @@ -31,14 +31,14 @@ struct pso_pointer c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, struct pso_pointer expressions, struct pso_pointer env ) { struct pso_pointer result = nil; - struct pso_pointer next_pointer = - push_local(frame_pointer, make_frame(1, frame_pointer, nil)); - struct pso4 *next_frame = pointer_to_pso4(next_pointer); + struct pso_pointer next_pointer = + push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) ); + struct pso4 *next_frame = pointer_to_pso4( next_pointer ); while ( consp( expressions ) ) { - next_frame->payload.stack_frame.arg[0] = c_car(expressions); + next_frame->payload.stack_frame.arg[0] = c_car( expressions ); - result = lisp_eval( next_pointer); + result = lisp_eval( next_pointer ); expressions = exceptionp( result ) ? nil : c_cdr( expressions ); } @@ -60,25 +60,25 @@ c_progn( struct pso4 *frame, struct pso_pointer frame_pointer, * @return the value of the last `expression` of the sequence which is my single * argument. */ -struct pso_pointer -lisp_progn( struct pso_pointer frame_pointer) { - struct pso_pointer result = nil; - struct pso4 *frame = pointer_to_pso4(frame_pointer); - struct pso_pointer next_pointer = - push_local(frame_pointer, make_frame(1, frame_pointer, nil)); - struct pso4 *next_frame = pointer_to_pso4(next_pointer); +struct pso_pointer lisp_progn( struct pso_pointer frame_pointer ) { + struct pso_pointer result = nil; + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso_pointer next_pointer = + push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) ); + struct pso4 *next_frame = pointer_to_pso4( next_pointer ); - for (int i = 0; i < args_in_frame; i++) { - next_frame->payload.stack_frame.arg[0] = - frame->payload.stack_frame.arg[i]; + for ( int i = 0; i < args_in_frame; i++ ) { + next_frame->payload.stack_frame.arg[0] = + frame->payload.stack_frame.arg[i]; - result = push_local(frame_pointer, lisp_eval(next_pointer)); - } + result = push_local( frame_pointer, lisp_eval( next_pointer ) ); + } - if (consp(frame->payload.stack_frame.more)) { - result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more, - fetch_env(frame_pointer)); - } + if ( consp( frame->payload.stack_frame.more ) ) { + result = + c_progn( frame, frame_pointer, frame->payload.stack_frame.more, + fetch_env( frame_pointer ) ); + } - return result; + return result; } diff --git a/src/c/ops/progn.h b/src/c/ops/progn.h index 4651485..37e42c3 100644 --- a/src/c/ops/progn.h +++ b/src/c/ops/progn.h @@ -15,9 +15,10 @@ #include "memory/pointer.h" #include "memory/pso4.h" -struct pso_pointer c_progn(struct pso4 *frame, struct pso_pointer frame_pointer, - struct pso_pointer expressions, - struct pso_pointer env); +struct pso_pointer c_progn( struct pso4 *frame, + struct pso_pointer frame_pointer, + struct pso_pointer expressions, + struct pso_pointer env ); -struct pso_pointer lisp_progn(struct pso_pointer frame_pointer); -#endif \ No newline at end of file +struct pso_pointer lisp_progn( struct pso_pointer frame_pointer ); +#endif diff --git a/src/c/ops/quote.c b/src/c/ops/quote.c index f1d3595..15a3c28 100644 --- a/src/c/ops/quote.c +++ b/src/c/ops/quote.c @@ -21,6 +21,6 @@ * * @return the expression. */ -struct pso_pointer quote(struct pso_pointer frame_pointer){ - return fetch_arg(pointer_to_pso4(frame_pointer), 0); -} \ No newline at end of file +struct pso_pointer quote( struct pso_pointer frame_pointer ) { + return fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); +} diff --git a/src/c/ops/quote.h b/src/c/ops/quote.h index 6c6af0b..b203554 100644 --- a/src/c/ops/quote.h +++ b/src/c/ops/quote.h @@ -14,5 +14,5 @@ #include "memory/pointer.h" -struct pso_pointer quote(struct pso_pointer frame_pointer); -#endif \ No newline at end of file +struct pso_pointer quote( struct pso_pointer frame_pointer ); +#endif diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index 8d04f09..009cbf9 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -106,7 +106,7 @@ struct pso_pointer repl( struct pso_pointer frame_pointer ) { dec_ref( base_of_stack ); } - debug_print(L"Leaving repl\n", DEBUG_REPL, 0); + debug_print( L"Leaving repl\n", DEBUG_REPL, 0 ); - return nil; + return nil; } diff --git a/src/c/ops/reverse.c b/src/c/ops/reverse.c index a9be24f..1fb76e5 100644 --- a/src/c/ops/reverse.c +++ b/src/c/ops/reverse.c @@ -49,25 +49,25 @@ struct pso_pointer reverse( struct pso_pointer frame_pointer ) { case KEYTV: result = push_local( frame_pointer, make_string_like_thing( frame_pointer, - object->payload. - string.character, - result, + object-> + payload.string. + character, result, KEYTAG ) ); break; case STRINGTV: result = push_local( frame_pointer, make_string_like_thing( frame_pointer, - object->payload. - string.character, - result, + object-> + payload.string. + character, result, STRINGTAG ) ); break; case SYMBOLTV: result = push_local( frame_pointer, make_string_like_thing( frame_pointer, - object->payload. - string.character, - result, + object-> + payload.string. + character, result, SYMBOLTAG ) ); break; default: @@ -105,8 +105,8 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer, struct pso_pointer result = nil; if ( stackp( frame_pointer ) ) { - result = reverse( make_frame(1, frame_pointer, sequence) ); + result = reverse( make_frame( 1, frame_pointer, sequence ) ); } - + return result; } diff --git a/src/c/ops/string_ops.c b/src/c/ops/string_ops.c index 7111762..7674434 100644 --- a/src/c/ops/string_ops.c +++ b/src/c/ops/string_ops.c @@ -146,8 +146,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) { int i = 0; for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) { buffer[i++] = - ( wchar_t ) ( pointer_to_object( c )->payload. - string.character ); + ( wchar_t ) ( pointer_to_object( c )->payload.string. + character ); } mbstate_t ps; @@ -183,7 +183,7 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { wchar_t c = symbol[i]; - if ( symbol_char_p(c)) { + if ( symbol_char_p( c ) ) { result = make_symbol( frame_pointer, c, result ); } } diff --git a/src/c/ops/string_ops.h b/src/c/ops/string_ops.h index b265dc7..af21a2b 100644 --- a/src/c/ops/string_ops.h +++ b/src/c/ops/string_ops.h @@ -27,11 +27,11 @@ char *lisp_string_to_c_string( struct pso_pointer s ); struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer, - wchar_t * symbol ); + wchar_t *symbol ); struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer, - wchar_t * symbol ); + wchar_t *symbol ); -bool end_of_stringp(struct pso_pointer arg); +bool end_of_stringp( struct pso_pointer arg ); #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 1bdd236..e2d3b58 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -121,29 +121,29 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location, debug_print( L"`\n", DEBUG_ANY, 0 ); if ( !c_nilp( cause ) ) { debug_print( L"\tCaused by: ", DEBUG_ANY, 0 ); - debug_print_object( cause, DEBUG_ANY, 0); + debug_print_object( cause, DEBUG_ANY, 0 ); debug_print( L"`\n", DEBUG_ANY, 0 ); } #endif struct pso2 *cell = pointer_to_object( message ); - if (get_tag_value( message)) { - result = message; - } else { - struct pso_pointer x_frame = inc_ref(make_frame( - 2, frame_pointer, message, - (c_nilp(location) - ? nil - : make_cons(frame_pointer, - make_cons(frame_pointer, - privileged_keyword_location, location), - nil)), - cause)); + if ( get_tag_value( message ) ) { + result = message; + } else { + struct pso_pointer x_frame = + inc_ref( make_frame( 2, frame_pointer, message, + ( c_nilp( location ) + ? nil : make_cons( frame_pointer, + make_cons( frame_pointer, + privileged_keyword_location, + location ), + nil ) ), + cause ) ); - result = push_local(frame_pointer, make_exception(x_frame)); - } + result = push_local( frame_pointer, make_exception( x_frame ) ); + } - return result; + return result; } /** @@ -162,4 +162,3 @@ throw_exception( struct pso_pointer location, struct pso_pointer frame_pointer ) { return throw_exception_with_cause( location, payload, nil, frame_pointer ); } - diff --git a/src/c/payloads/float.h b/src/c/payloads/float.h index 9cfc018..15c4f2c 100644 --- a/src/c/payloads/float.h +++ b/src/c/payloads/float.h @@ -16,7 +16,7 @@ * we could/should use the full 128 bits. */ struct float_payload { - long double value; + long double value; }; -#endif \ No newline at end of file +#endif diff --git a/src/c/payloads/function.c b/src/c/payloads/function.c index 14015ab..a0c6d0d 100644 --- a/src/c/payloads/function.c +++ b/src/c/payloads/function.c @@ -12,14 +12,17 @@ #include "memory/pso2.h" #include "memory/tags.h" -struct pso_pointer make_function( - struct pso_pointer frame_pointer, struct pso_pointer meta, - struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { - struct pso_pointer result = allocate(frame_pointer, FUNCTIONTAG, 2); - struct pso2 *object = pointer_to_object(result); +struct pso_pointer make_function( struct pso_pointer frame_pointer, + struct pso_pointer meta, + struct pso_pointer ( *executable ) ( struct + pso_pointer + frame_pointer ) ) +{ + struct pso_pointer result = allocate( frame_pointer, FUNCTIONTAG, 2 ); + struct pso2 *object = pointer_to_object( result ); - object->payload.function.meta = meta; - object->payload.function.executable = executable; + object->payload.function.meta = meta; + object->payload.function.executable = executable; - return result; + return result; } diff --git a/src/c/payloads/function.h b/src/c/payloads/function.h index 8c7da98..54e7d69 100644 --- a/src/c/payloads/function.h +++ b/src/c/payloads/function.h @@ -39,8 +39,10 @@ struct function_payload { struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer ); }; -struct pso_pointer make_function( - struct pso_pointer frame_pointer, struct pso_pointer meta, - struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); +struct pso_pointer make_function( struct pso_pointer frame_pointer, + struct pso_pointer meta, + struct pso_pointer ( *executable ) ( struct + pso_pointer + frame_pointer ) ); #endif diff --git a/src/c/payloads/keyword.c b/src/c/payloads/keyword.c index 325f4e3..16e11e0 100644 --- a/src/c/payloads/keyword.c +++ b/src/c/payloads/keyword.c @@ -21,7 +21,7 @@ * @param c the character to add (prepend); * @param tail the keyword which is being built. */ - struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); - } +struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, KEYTAG ); +} diff --git a/src/c/payloads/keyword.h b/src/c/payloads/keyword.h index 35bbbe7..56fe481 100644 --- a/src/c/payloads/keyword.h +++ b/src/c/payloads/keyword.h @@ -16,8 +16,8 @@ /* 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. */ - - struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); + +struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif diff --git a/src/c/payloads/lambda.c b/src/c/payloads/lambda.c index b38ad9d..17ee164 100644 --- a/src/c/payloads/lambda.c +++ b/src/c/payloads/lambda.c @@ -13,12 +13,13 @@ #include "memory/pso.h" #include "memory/pso2.h" -struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, - struct pso_pointer args, - struct pso_pointer body, char *tag) { +struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, + char *tag ) { - struct pso_pointer result = allocate(frame_pointer, tag, 2); - struct pso2 *object = pointer_to_object(result); - object->payload.lambda.args = args; - object->payload.lambda.body = body; + struct pso_pointer result = allocate( frame_pointer, tag, 2 ); + struct pso2 *object = pointer_to_object( result ); + object->payload.lambda.args = args; + object->payload.lambda.body = body; } diff --git a/src/c/payloads/lambda.h b/src/c/payloads/lambda.h index 0873719..59131d6 100644 --- a/src/c/payloads/lambda.h +++ b/src/c/payloads/lambda.h @@ -30,9 +30,10 @@ struct lambda_payload { struct pso_pointer body; }; -struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer, - struct pso_pointer args, - struct pso_pointer body, char *tag); - -#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG)) +struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer, + struct pso_pointer args, + struct pso_pointer body, + char *tag ); + +#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG)) #endif diff --git a/src/c/payloads/psse_string.h b/src/c/payloads/psse_string.h index 7e1c75e..2fbab18 100644 --- a/src/c/payloads/psse_string.h +++ b/src/c/payloads/psse_string.h @@ -35,7 +35,7 @@ struct string_payload { struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c, struct pso_pointer tail ); - + struct pso_pointer destroy_string( struct pso_pointer fp ); #endif diff --git a/src/c/payloads/special.c b/src/c/payloads/special.c index abf8d97..4eaf622 100644 --- a/src/c/payloads/special.c +++ b/src/c/payloads/special.c @@ -12,14 +12,17 @@ #include "memory/pso2.h" #include "memory/tags.h" -struct pso_pointer make_special( - struct pso_pointer frame_pointer, struct pso_pointer meta, - struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) { - struct pso_pointer result = allocate(frame_pointer, SPECIALTAG, 2); - struct pso2 *object = pointer_to_object(result); +struct pso_pointer make_special( struct pso_pointer frame_pointer, + struct pso_pointer meta, + struct pso_pointer ( *executable ) ( struct + pso_pointer + frame_pointer ) ) +{ + struct pso_pointer result = allocate( frame_pointer, SPECIALTAG, 2 ); + struct pso2 *object = pointer_to_object( result ); - object->payload.special.meta = meta; - object->payload.special.executable = executable; + object->payload.special.meta = meta; + object->payload.special.executable = executable; - return result; + return result; } diff --git a/src/c/payloads/special.h b/src/c/payloads/special.h index ef913e9..c43f35c 100644 --- a/src/c/payloads/special.h +++ b/src/c/payloads/special.h @@ -22,8 +22,10 @@ * \see NLAMBDATAG. */ -struct pso_pointer make_special( - struct pso_pointer frame_pointer, struct pso_pointer meta, - struct pso_pointer (*executable)(struct pso_pointer frame_pointer)); +struct pso_pointer make_special( struct pso_pointer frame_pointer, + struct pso_pointer meta, + struct pso_pointer ( *executable ) ( struct + pso_pointer + frame_pointer ) ); #endif diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 2e299a4..adf6d11 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -100,22 +100,28 @@ struct pso_pointer push_local( struct pso_pointer frame_pointer, * * @return `nil` on success; potentially an exception on failure. */ -struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer) { - struct pso4* frame = pointer_to_pso4( frame_pointer); +struct pso_pointer add_arg( struct pso_pointer frame_pointer, + struct pso_pointer arg_pointer ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer result = nil; - if (frame->payload.stack_frame.args < args_in_frame) { - frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = push_local(frame_pointer, arg_pointer); + if ( frame->payload.stack_frame.args < args_in_frame ) { + frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = + push_local( frame_pointer, arg_pointer ); } else { struct pso_pointer new_more = c_reverse( frame_pointer, - make_cons( frame_pointer, - arg_pointer, - c_reverse( frame_pointer, frame->payload.stack_frame.more))); - if (exceptionp(new_more)) { + make_cons( frame_pointer, + arg_pointer, + c_reverse + ( frame_pointer, + frame->payload. + stack_frame. + more ) ) ); + if ( exceptionp( new_more ) ) { result = new_more; } else { frame->payload.stack_frame.more = - push_local( frame_pointer, new_more); + push_local( frame_pointer, new_more ); } } @@ -127,7 +133,7 @@ struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer * `env` pointer of the new frame -- callers are responsible for doing so. */ struct pso_pointer in_make_frame( int arg_count, struct pso_pointer previous, - va_list args ) { + va_list args ) { /* NOTE! It is really important not to `push_local` the new_pointer here, * since that would stop stack frames and all the temporary objects they * curate ever being garbage collected! */ @@ -205,13 +211,14 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, va_list args; va_start( args, previous ); - struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); - struct pso4* new_frame = pointer_to_pso4(new_pointer); + struct pso_pointer new_pointer = + in_make_frame( arg_count, previous, args ); + struct pso4 *new_frame = pointer_to_pso4( new_pointer ); - new_frame->payload.stack_frame.env = stackp(previous) ? - inc_ref(pointer_to_pso4(previous)->payload.stack_frame.env) : nil; + new_frame->payload.stack_frame.env = stackp( previous ) ? + inc_ref( pointer_to_pso4( previous )->payload.stack_frame.env ) : nil; - va_end(args); + va_end( args ); return new_pointer; } @@ -238,10 +245,11 @@ struct pso_pointer make_frame_with_env( int arg_count, va_list args; va_start( args, env ); - struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args); - pointer_to_pso4(new_pointer)->payload.stack_frame.env = inc_ref( env); + struct pso_pointer new_pointer = + in_make_frame( arg_count, previous, args ); + pointer_to_pso4( new_pointer )->payload.stack_frame.env = inc_ref( env ); - va_end(args); + va_end( args ); return new_pointer; } @@ -270,8 +278,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer struct pso_pointer arg_length = count( push_local( previous, make_frame( 1, previous, argvalues ) ) ); int arg_count = - integerp( arg_length ) ? pointer_to_object( arg_length )-> - payload.integer.value : 0; + integerp( arg_length ) ? pointer_to_object( arg_length )->payload. + integer.value : 0; #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, L"\nAllocating stack frame with %d arguments at page %d, " @@ -330,8 +338,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer argvalues ) { return make_frame_with_arglist_and_env( previous, argvalues, pointer_to_pso4 - ( previous )->payload.stack_frame. - env ); + ( previous )->payload. + stack_frame.env ); } diff --git a/src/c/payloads/stack.h b/src/c/payloads/stack.h index 7c20409..40e9f54 100644 --- a/src/c/payloads/stack.h +++ b/src/c/payloads/stack.h @@ -54,6 +54,7 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous, struct pso_pointer destroy_stack_frame( struct pso_pointer fp, struct pso_pointer env ); -struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer); +struct pso_pointer add_arg( struct pso_pointer frame_pointer, + struct pso_pointer arg_pointer ); #endif diff --git a/src/c/payloads/stack_payload.h b/src/c/payloads/stack_payload.h index 95a9c2a..117a86a 100644 --- a/src/c/payloads/stack_payload.h +++ b/src/c/payloads/stack_payload.h @@ -42,4 +42,4 @@ struct stack_frame_payload { uint32_t depth; }; -#endif \ No newline at end of file +#endif diff --git a/src/c/payloads/symbol.c b/src/c/payloads/symbol.c index 4030831..2594011 100644 --- a/src/c/payloads/symbol.c +++ b/src/c/payloads/symbol.c @@ -24,6 +24,6 @@ * @param tail the symbol which is being built. */ struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ) { - return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); - } + struct pso_pointer tail ) { + return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG ); +} diff --git a/src/c/payloads/symbol.h b/src/c/payloads/symbol.h index 2b0dd48..35a7375 100644 --- a/src/c/payloads/symbol.h +++ b/src/c/payloads/symbol.h @@ -27,8 +27,8 @@ /* 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. */ - - struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, - struct pso_pointer tail ); + +struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c, + struct pso_pointer tail ); #endif From 6b89779babe2d03311a6244505d549c750c85434 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 6 May 2026 23:42:25 +0100 Subject: [PATCH 75/77] Substantial work on `read-list`, not yet fully working. --- docs/State-of-play.md | 25 +++++++++++++ src/c/io/read.c | 84 +++++++++++++++++++++++++++++++++++++++--- src/c/io/read.h | 9 +++++ src/c/memory/tags.c | 18 ++++++--- src/c/payloads/stack.c | 2 + 5 files changed, 127 insertions(+), 11 deletions(-) diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 709b3d9..641abc0 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,30 @@ # State of Play +## 20260506 + +A day of some achievements. I got `dump` working, although not perfectly, and this helped me diagnose the problem with `equal`, and hence with `assoc`; these are now fixed, and consequently `eval_symbol` now works. + +However the problem was that you cannot mix `wchar_t` and `char32_t`: the same character in the two encodings does not have the same value. So I've reversed the [issue 18](https://git.journeyman.cc/simon/post-scarcity/issues/18) fix. + +I've started work on reading lists, and although it doesn't completely work yet, it's close. + +However! + +### Unclean objects + +It's been obvious for some time that freshly allocated objects are not always clean. + +I'm seeing entries like these in the logs: + +``` +WARNING: Count of 2 in newly allocated object at 3, 5456, should be 0 +WARNING: Count of 4 in newly allocated object at 1, 0, should be 0 +WARNING: Count of 2 in newly allocated object at 4, 5456, should be 0 +WARNING: Count of 8 in newly allocated object at 1, 0, should be 0 +``` + +What's worse than dirty counts is dirty pointers, and we're seeing those, too. This is particularly dangerous for stack frames, but it isn't good for anything. I have a faint worry — I don't *think* this is the problem — that I might be miscalculating offsets, and have objects interfering with one another. I am going to need to have a thorough go at object sanitation, both when objects are freed, and when they're reallocated. In good news, garbage collection of stack frames really is working — but nothing else is yet getting garbage collected. + ## 20260505 ### The stack frame corruption(?) bug diff --git a/src/c/io/read.c b/src/c/io/read.c index 65c2a08..56dc306 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -87,6 +87,13 @@ struct pso_pointer read_example( struct pso_pointer frame_pointer ) { return result; } +struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer) { + return make_exception( make_frame( 1, frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Read: end of input while reading" ) ) ); +} + /** * Function: return the next character from the stream indicated by arg 0; * further arguments are ignored. @@ -115,6 +122,71 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) { return result; } +/** + * @brief advance the `stream` indicated in arg[0] of this stack frame over any + * whitespace characters. The character indicated by arg[2] will be treated as + * potentially the first such character. Returns the first non-space character + * encountered, or an exception. + */ +struct pso_pointer skip_whitespace( struct pso_pointer frame_pointer ) { + 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 (characterp(character)) { + wchar_t wc = pointer_to_object(character)->payload.character.character; + if (!iswspace( wc) && wc != L',') { + result = character; + } + } + + if (c_nilp( result) && readp( stream)) { + URL_FILE* input = pointer_to_object(stream)->payload.stream.stream; + + wint_t wc = url_fgetwc( input); + while ( iswspace(wc) || wc==L',') { wc = url_fgetwc( input); } + result = (wc == WEOF) ? make_eof_exception(frame_pointer) : make_character(frame_pointer, wc); + } + + return result; +} + +struct pso_pointer read_list( struct pso_pointer frame_pointer ) { + 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 (!c_nilp(character) && characterp(character) && + pointer_to_object(character)->payload.character.character == SYNTAX_LPAR) { + // it's OK if an LPAR is passed in, but we don't want it now. + character = nil; + } + if (!c_nilp( character)) { + // if anything other than LPAR is passed in as character, TODO: throw exception. + } + + while ( c_nilp(character) || (characterp(character) && + pointer_to_object(character)->payload.character.character != SYNTAX_RPAR)) { + character = skip_whitespace( make_frame(3, frame_pointer, stream, readtable, character)); + struct pso_pointer r = read( make_frame(3, frame_pointer, stream, readtable, character)); + + if (exceptionp(r)) { + result = r; + break; + } else { + result = make_cons( frame_pointer, r, result); + character = skip_whitespace( make_frame(3, frame_pointer, stream, readtable, character)); + } + } + + return consp(result) ? c_reverse( frame_pointer, result) : result; +} + + /** * @brief Read one integer from the stream and return it. * @@ -226,7 +298,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( character ) ) { - character = read_character( make_frame( 1, frame_pointer, stream ) ); + character = skip_whitespace( make_frame( 1, frame_pointer, stream ) ); } struct pso_pointer readmacro = c_assoc( character, readtable ); @@ -239,16 +311,16 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; switch ( c ) { - case ';': + case SYNTAX_SEMICOLON: 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 SYNTAX_LPAR: + result = read_list( make_frame(3, stream, readtable, character)); + break; case EOF: - result = make_exception( make_frame( 1, frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Read: end of input while reading" ) ) ); + result = make_eof_exception(frame_pointer); break; default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, diff --git a/src/c/io/read.h b/src/c/io/read.h index 5508510..e1cafbb 100644 --- a/src/c/io/read.h +++ b/src/c/io/read.h @@ -13,6 +13,15 @@ #ifndef __psse_io_read_h #define __psse_io_read_h + +#define SYNTAX_LPAR L'(' +#define SYNTAX_RPAR L')' +#define SYNTAX_LBRACE L'{' +#define SYNTAX_RBRACE L'}' +#define SYNTAX_DOT L'.' +#define SYNTAX_COLON L':' +#define SYNTAX_SEMICOLON L';' + struct pso_pointer read_character( struct pso_pointer frame_pointer ); struct pso_pointer read_number( struct pso_pointer frame_pointer ); diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index a77519c..fcb5737 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -20,9 +20,17 @@ #include "ops/string_ops.h" uint32_t get_tag_value( struct pso_pointer p ) { - struct pso2 *object = pointer_to_object( p ); + uint32_t result = 0; + if (p.node == node_index) { + struct pso2 *object = pointer_to_object( p ); + result = object->header.tag.value & 0xffffff; + } else { + // TODO: we need to check local cache, and if not found, request a + // copy from the curating node. + fwprintf( stderr, L"WARNING: tag requested of foreign object at node %d, page %d, offset %d.\n", p.node, p.page, p.offset); + } - return object->header.tag.value & 0xffffff; + return result; } /** @@ -61,12 +69,12 @@ bool check_tag( struct pso_pointer p, uint32_t 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` + * 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 + * @return true if the first TAGLENGTH characters of `s` are equal to the tag * of the object. * @return false otherwise. */ diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index adf6d11..9696a92 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -362,8 +362,10 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->payload.stack_frame.arg[i] ); + frame->payload.stack_frame.arg[i] = nil; } + frame->payload.stack_frame.previous = nil; frame->payload.stack_frame.function = nil; frame->payload.stack_frame.more = nil; From d1bfb029b88f62eaf51f0a6c5c37c12186db42f0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 May 2026 06:47:58 +0100 Subject: [PATCH 76/77] Work on ensuring new objects are clean, but not sure it's successful. Also, start on setting up the read ACL on new objects. --- src/c/environment/environment.c | 8 +-- src/c/environment/function_bindings.c | 24 ++++---- src/c/environment/privileged_keywords.c | 26 ++++++++- src/c/environment/privileged_keywords.h | 4 ++ src/c/io/print.c | 13 +++-- src/c/io/read.c | 76 +++++++++++++++---------- src/c/memory/pso.c | 14 +++++ src/c/memory/tags.c | 6 +- src/c/ops/cond.c | 8 ++- src/c/ops/eval_apply.c | 22 +++---- src/c/ops/mapcar.c | 8 +-- src/c/payloads/stack.c | 4 +- 12 files changed, 141 insertions(+), 72 deletions(-) diff --git a/src/c/environment/environment.c b/src/c/environment/environment.c index c167eb1..8ae1f52 100644 --- a/src/c/environment/environment.c +++ b/src/c/environment/environment.c @@ -103,13 +103,13 @@ struct pso_pointer initialise_environment( uint32_t node ) { debug_print( L"\nEnvironment initialised successfully.\n", DEBUG_BOOTSTRAP, 0 ); - initialise_privileged_keywords( frame_pointer ); + result = + initialise_privileged_keywords( make_frame_with_env + ( 0, frame_pointer, result ) ); result = inc_ref( initialise_function_bindings - ( push_local - ( frame_pointer, - make_frame_with_env( 0, frame_pointer, result ) ) ) ); + ( make_frame_with_env( 0, frame_pointer, result ) ) ); dec_ref( frame_pointer ); } diff --git a/src/c/environment/function_bindings.c b/src/c/environment/function_bindings.c index b393c3c..fb5b639 100644 --- a/src/c/environment/function_bindings.c +++ b/src/c/environment/function_bindings.c @@ -331,22 +331,22 @@ initialise_function_bindings( struct pso_pointer frame_pointer ) { for ( int i = 0; function_initialisers[i].executable != NULL; i++ ) { struct pso_pointer b = c_car( bind_function( frame_pointer, - function_initialisers[i]. - name, - function_initialisers[i]. - documentation, - function_initialisers[i]. - executable ) ); + function_initialisers + [i].name, + function_initialisers + [i].documentation, + function_initialisers + [i].executable ) ); result = make_cons( frame_pointer, b, result ); } for ( int i = 0; special_initialisers[i].executable != NULL; i++ ) { struct pso_pointer b = c_car( bind_special( frame_pointer, - special_initialisers[i]. - name, - special_initialisers[i]. - documentation, - special_initialisers[i]. - executable ) ); + special_initialisers + [i].name, + special_initialisers + [i].documentation, + special_initialisers + [i].executable ) ); result = make_cons( frame_pointer, b, result ); } diff --git a/src/c/environment/privileged_keywords.c b/src/c/environment/privileged_keywords.c index 26f785e..22a010c 100644 --- a/src/c/environment/privileged_keywords.c +++ b/src/c/environment/privileged_keywords.c @@ -19,6 +19,7 @@ #include "memory/pso.h" #include "payloads/cons.h" +#include "payloads/stack.h" #include "ops/string_ops.h" @@ -59,12 +60,27 @@ struct pso_pointer privileged_keyword_system; */ struct pso_pointer privileged_keyword_user; +/** + * The symbol whose binding in the eval-time environment sets the read ACL + * for new objects made. + */ +struct pso_pointer privileged_symbol_friends; -#define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val))) +/** + * This seems like a really abusive use of C macros. It *should* work but will + * be extremely brittle. For use in this function and nowhere else! + * I'm grateful to https://pzemtsov.github.io/2014/05/05/do-macro.html for the + * hack. + */ +#define load_and_lock(var,val)do {var = lock_object(c_string_to_lisp_keyword(frame_pointer, val));\ + r=make_cons(frame_pointer, make_cons(frame_pointer, var, nil), r);\ +} while (0) struct pso_pointer initialise_privileged_keywords( struct pso_pointer frame_pointer ) { + struct pso_pointer r = fetch_env( frame_pointer ); + load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP ); load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION ); load_and_lock( privileged_keyword_layer, PK_LAYER ); @@ -72,4 +88,12 @@ struct pso_pointer initialise_privileged_keywords( struct pso_pointer load_and_lock( privileged_keyword_name, PK_NAME ); load_and_lock( privileged_keyword_system, PK_SYSTEM ); load_and_lock( privileged_keyword_user, PK_USER ); + + privileged_symbol_friends = + lock_object( c_string_to_lisp_symbol( frame_pointer, PS_FRIENDS ) ); + r = make_cons( frame_pointer, + make_cons( frame_pointer, privileged_symbol_friends, nil ), + r ); + + return r; } diff --git a/src/c/environment/privileged_keywords.h b/src/c/environment/privileged_keywords.h index fe08e4c..0ed2be6 100644 --- a/src/c/environment/privileged_keywords.h +++ b/src/c/environment/privileged_keywords.h @@ -21,6 +21,8 @@ #define PK_SYSTEM L"system" #define PK_USER L"user" +#define PS_FRIENDS L"*friends*" + extern struct pso_pointer privileged_keyword_bootstrap; extern struct pso_pointer privileged_keyword_documentation; extern struct pso_pointer privileged_keyword_layer; @@ -29,5 +31,7 @@ extern struct pso_pointer privileged_keyword_name; extern struct pso_pointer privileged_keyword_system; extern struct pso_pointer privileged_keyword_user; +extern struct pso_pointer privileged_symbol_friends; + struct pso_pointer initialise_privileged_keywords( struct pso_pointer env ); #endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */ diff --git a/src/c/io/print.c b/src/c/io/print.c index e780b20..1c35650 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -285,11 +285,14 @@ struct pso_pointer c_write( struct pso_pointer frame_pointer, struct pso_pointer object, struct pso_pointer stream, bool escape, bool nl_before, bool nl_after ) { - struct pso_pointer next_pointer = - push_local( frame_pointer, - make_frame( 5, frame_pointer, object, stream, - escape ? t : nil, - nl_before ? t : nil, nl_after ? t : nil ) ); + struct pso_pointer next_pointer = push_local( frame_pointer, + make_frame( 5, frame_pointer, + object, stream, + escape ? t : nil, + nl_before ? t : + nil, + nl_after ? t : + nil ) ); struct pso_pointer result = push_local( frame_pointer, write( next_pointer ) ); diff --git a/src/c/io/read.c b/src/c/io/read.c index 56dc306..f17349d 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -87,11 +87,11 @@ struct pso_pointer read_example( struct pso_pointer frame_pointer ) { return result; } -struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer) { +struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer ) { return make_exception( make_frame( 1, frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Read: end of input while reading" ) ) ); + c_string_to_lisp_string + ( frame_pointer, + L"Read: end of input while reading" ) ) ); } /** @@ -135,19 +135,25 @@ struct pso_pointer skip_whitespace( struct pso_pointer frame_pointer ) { struct pso_pointer character = fetch_arg( frame, 2 ); struct pso_pointer result = nil; - if (characterp(character)) { - wchar_t wc = pointer_to_object(character)->payload.character.character; - if (!iswspace( wc) && wc != L',') { + if ( characterp( character ) ) { + wchar_t wc = + pointer_to_object( character )->payload.character.character; + if ( !iswspace( wc ) && wc != L',' ) { result = character; } } - if (c_nilp( result) && readp( stream)) { - URL_FILE* input = pointer_to_object(stream)->payload.stream.stream; + if ( c_nilp( result ) && readp( stream ) ) { + URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; - wint_t wc = url_fgetwc( input); - while ( iswspace(wc) || wc==L',') { wc = url_fgetwc( input); } - result = (wc == WEOF) ? make_eof_exception(frame_pointer) : make_character(frame_pointer, wc); + wint_t wc = url_fgetwc( input ); + while ( iswspace( wc ) || wc == L',' ) { + wc = url_fgetwc( input ); + } + result = + ( wc == + WEOF ) ? make_eof_exception( frame_pointer ) : + make_character( frame_pointer, wc ); } return result; @@ -160,30 +166,41 @@ struct pso_pointer read_list( struct pso_pointer frame_pointer ) { struct pso_pointer character = fetch_arg( frame, 2 ); struct pso_pointer result = nil; - if (!c_nilp(character) && characterp(character) && - pointer_to_object(character)->payload.character.character == SYNTAX_LPAR) { + if ( !c_nilp( character ) && characterp( character ) && + pointer_to_object( character )->payload.character.character == + SYNTAX_LPAR ) { // it's OK if an LPAR is passed in, but we don't want it now. character = nil; } - if (!c_nilp( character)) { + if ( !c_nilp( character ) ) { // if anything other than LPAR is passed in as character, TODO: throw exception. } - while ( c_nilp(character) || (characterp(character) && - pointer_to_object(character)->payload.character.character != SYNTAX_RPAR)) { - character = skip_whitespace( make_frame(3, frame_pointer, stream, readtable, character)); - struct pso_pointer r = read( make_frame(3, frame_pointer, stream, readtable, character)); + while ( c_nilp( character ) || ( characterp( character ) && + pointer_to_object( character )-> + payload.character.character != + SYNTAX_RPAR ) ) { + character = + skip_whitespace( make_frame + ( 3, frame_pointer, stream, readtable, + character ) ); + struct pso_pointer r = + read( make_frame + ( 3, frame_pointer, stream, readtable, character ) ); - if (exceptionp(r)) { - result = r; - break; - } else { - result = make_cons( frame_pointer, r, result); - character = skip_whitespace( make_frame(3, frame_pointer, stream, readtable, character)); - } + if ( exceptionp( r ) ) { + result = r; + break; + } else { + result = make_cons( frame_pointer, r, result ); + character = + skip_whitespace( make_frame + ( 3, frame_pointer, stream, readtable, + character ) ); } + } - return consp(result) ? c_reverse( frame_pointer, result) : result; + return consp( result ) ? c_reverse( frame_pointer, result ) : result; } @@ -317,10 +334,11 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { /* skip all characters from semi-colon to the end of the line */ break; case SYNTAX_LPAR: - result = read_list( make_frame(3, stream, readtable, character)); + result = + read_list( make_frame( 3, stream, readtable, character ) ); break; case EOF: - result = make_eof_exception(frame_pointer); + result = make_eof_exception( frame_pointer ); break; default: struct pso_pointer next = make_frame( 3, frame_pointer, stream, diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index b5e97d4..7e5d2c3 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -25,6 +25,8 @@ #include "debug.h" +#include "environment/privileged_keywords.h" + #include "memory/destroy.h" #include "memory/header.h" #include "memory/memory.h" @@ -35,8 +37,11 @@ #include "memory/pso4.h" #include "memory/tags.h" +#include "ops/assoc.h" #include "ops/truth.h" +#include "payloads/stack.h" + #ifdef DEBUG int allocation_table_allocated = 0; int allocation_table_freed = 1; @@ -98,7 +103,16 @@ struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer, #endif struct pso2 *obj = pointer_to_object( result ); + + // ensure memory really is clear, to prevent the 'dirty objects' bug. + int object_size = pow( 2, size_class ) * sizeof( int64_t ); + memset( obj, 0, object_size ); + + // set up basic data + obj->header.tag.bytes.size_class = size_class; strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); + obj->header.access = + c_assoc( privileged_symbol_friends, fetch_env( frame_pointer ) ); debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, result.offset ); diff --git a/src/c/memory/tags.c b/src/c/memory/tags.c index fcb5737..10b1893 100644 --- a/src/c/memory/tags.c +++ b/src/c/memory/tags.c @@ -21,13 +21,15 @@ uint32_t get_tag_value( struct pso_pointer p ) { uint32_t result = 0; - if (p.node == node_index) { + if ( p.node == node_index ) { struct pso2 *object = pointer_to_object( p ); result = object->header.tag.value & 0xffffff; } else { // TODO: we need to check local cache, and if not found, request a // copy from the curating node. - fwprintf( stderr, L"WARNING: tag requested of foreign object at node %d, page %d, offset %d.\n", p.node, p.page, p.offset); + fwprintf( stderr, + L"WARNING: tag requested of foreign object at node %d, page %d, offset %d.\n", + p.node, p.page, p.offset ); } return result; diff --git a/src/c/ops/cond.c b/src/c/ops/cond.c index d0e5744..90b0511 100644 --- a/src/c/ops/cond.c +++ b/src/c/ops/cond.c @@ -41,9 +41,11 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause, #endif if ( consp( clause ) ) { - struct pso_pointer test_frame = - push_local( frame_pointer, - make_frame( 1, frame_pointer, c_car( clause ) ) ); + struct pso_pointer test_frame = push_local( frame_pointer, + make_frame( 1, + frame_pointer, + c_car + ( clause ) ) ); struct pso_pointer val = lisp_eval( test_frame ); if ( !c_nilp( val ) ) { diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index 5dc79f4..54dbd6b 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -158,9 +158,10 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) { struct pso_pointer lisp_try( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer body_frame = - push_local( frame_pointer, - make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) ); + struct pso_pointer body_frame = push_local( frame_pointer, + make_frame( 1, frame_pointer, + fetch_arg( frame, + 0 ) ) ); result = push_local( frame_pointer, lisp_progn( body_frame ) ); @@ -501,10 +502,10 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer ) { debug_print( L"Entering apply\n", DEBUG_EVAL, 0 ); struct pso_pointer result = nil; struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer fn_frame = - inc_ref( make_frame - ( 1, frame_pointer, - c_car( frame->payload.stack_frame.arg[0] ) ) ); + struct pso_pointer fn_frame = inc_ref( make_frame( 1, frame_pointer, + c_car( frame-> + payload.stack_frame.arg + [0] ) ) ); struct pso_pointer fn_pointer = push_local( frame_pointer, eval_form( fn_frame ) ); @@ -865,9 +866,10 @@ struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) { struct pso_pointer pair = c_car( cursor ); struct pso_pointer symbol = c_car( pair ); - struct pso_pointer next_pointer = - push_local( frame_pointer, - make_frame_with_env( 0, frame_pointer, bindings ) ); + struct pso_pointer next_pointer = push_local( frame_pointer, + make_frame_with_env( 0, + frame_pointer, + bindings ) ); if ( symbolp( symbol ) ) { add_arg( next_pointer, c_cdr( pair ) ); diff --git a/src/c/ops/mapcar.c b/src/c/ops/mapcar.c index d6315b4..3a74a4d 100644 --- a/src/c/ops/mapcar.c +++ b/src/c/ops/mapcar.c @@ -46,10 +46,10 @@ struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) { debug_print_object( expr, DEBUG_EVAL, 0 ); debug_println( DEBUG_EVAL ); - struct pso_pointer r = - lisp_eval( push_local - ( frame_pointer, - make_frame( 1, frame_pointer, expr ) ) ); + struct pso_pointer r = lisp_eval( push_local( frame_pointer, + make_frame( 1, + frame_pointer, + expr ) ) ); if ( exceptionp( r ) ) { result = r; diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index 9696a92..248793f 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -362,10 +362,10 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->payload.stack_frame.arg[i] ); - frame->payload.stack_frame.arg[i] = nil; + frame->payload.stack_frame.arg[i] = nil; } - + frame->payload.stack_frame.previous = nil; frame->payload.stack_frame.function = nil; frame->payload.stack_frame.more = nil; From 6f39dae75f6cf57cdcaca643a9653ca692af2af5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 7 May 2026 21:07:16 +0100 Subject: [PATCH 77/77] Tactical commit only. Something is badly broken in `read`, although I think this version is better thwan the last one. --- src/c/io/read.c | 426 ++++++++++++++++++++++---------------------- src/c/memory/dump.c | 8 +- 2 files changed, 217 insertions(+), 217 deletions(-) diff --git a/src/c/io/read.c b/src/c/io/read.c index f17349d..ba95ae6 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -42,9 +42,9 @@ #include "ops/assoc.h" #include "ops/reverse.h" -#include "payloads/stack.h" #include "ops/string_ops.h" #include "ops/truth.h" +#include "payloads/stack.h" // TODO: what I've copied from 0.0.6 is *weirdly* over-complex for just now. // I think I'm going to essentially delete all this and start again. We need @@ -77,21 +77,21 @@ * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_example( struct pso_pointer frame_pointer ) { - 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 read_example(struct pso_pointer frame_pointer) { + 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; } -struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer ) { - return make_exception( make_frame( 1, frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Read: end of input while reading" ) ) ); +struct pso_pointer make_eof_exception(struct pso_pointer frame_pointer) { + return make_exception( + make_frame(1, frame_pointer, + c_string_to_lisp_string( + frame_pointer, L"Read: end of input while reading"))); } /** @@ -106,20 +106,20 @@ struct pso_pointer make_eof_exception( struct pso_pointer frame_pointer ) { * @return a string of one character, namely the next available character * on my stream, if any, else nil. */ -struct pso_pointer read_character( struct pso_pointer frame_pointer ) { - struct pso4 *frame = pointer_to_pso4( frame_pointer ); - struct pso_pointer result = nil; - struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); - if ( readp( stream_pointer ) ) { - wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) ); - result = make_character( frame_pointer, chr ); +struct pso_pointer read_character(struct pso_pointer frame_pointer) { + struct pso4 *frame = pointer_to_pso4(frame_pointer); + struct pso_pointer result = nil; + struct pso_pointer stream_pointer = fetch_arg(frame, 0); + if (readp(stream_pointer)) { + wint_t chr = url_fgetwc(stream_get_url_file(stream_pointer)); + result = make_character(frame_pointer, chr); #ifdef DEBUG - debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr ); + debug_printf(DEBUG_IO, 0, L"\nRead character %lc\n", chr); #endif - } + } - return result; + return result; } /** @@ -128,82 +128,75 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) { * potentially the first such character. Returns the first non-space character * encountered, or an exception. */ -struct pso_pointer skip_whitespace( struct pso_pointer frame_pointer ) { - 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 skip_whitespace(struct pso_pointer frame_pointer) { + 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; + + do { + if (!characterp(character)) { + character = read_character(make_frame( 1, frame_pointer, stream)); + } + if (characterp(character)) { + wchar_t wc = pointer_to_object(character)->payload.character.character; + if (!iswspace(wc) && !iswcntrl(wc) && wc != L',') { + result = character; + } else if (exceptionp(character)){ + result = character; + } else { + character = nil; + } + } + } while (c_nilp(result)); - if ( characterp( character ) ) { - wchar_t wc = - pointer_to_object( character )->payload.character.character; - if ( !iswspace( wc ) && wc != L',' ) { - result = character; - } - } - - if ( c_nilp( result ) && readp( stream ) ) { - URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; - - wint_t wc = url_fgetwc( input ); - while ( iswspace( wc ) || wc == L',' ) { - wc = url_fgetwc( input ); - } - result = - ( wc == - WEOF ) ? make_eof_exception( frame_pointer ) : - make_character( frame_pointer, wc ); - } - - return result; + return result; } -struct pso_pointer read_list( struct pso_pointer frame_pointer ) { - 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 read_list(struct pso_pointer frame_pointer) { + 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 ( !c_nilp( character ) && characterp( character ) && - pointer_to_object( character )->payload.character.character == - SYNTAX_LPAR ) { - // it's OK if an LPAR is passed in, but we don't want it now. - character = nil; - } - if ( !c_nilp( character ) ) { - // if anything other than LPAR is passed in as character, TODO: throw exception. - } + if (!c_nilp(character) && characterp(character) && + pointer_to_object(character)->payload.character.character == + SYNTAX_LPAR) { + // it's OK if an LPAR is passed in, but we don't want it now. + character = nil; + } + if (!c_nilp(character)) { + // if anything other than LPAR is passed in as character, TODO: throw + // exception. + } - while ( c_nilp( character ) || ( characterp( character ) && - pointer_to_object( character )-> - payload.character.character != - SYNTAX_RPAR ) ) { - character = - skip_whitespace( make_frame - ( 3, frame_pointer, stream, readtable, - character ) ); - struct pso_pointer r = - read( make_frame - ( 3, frame_pointer, stream, readtable, character ) ); + do { + character = skip_whitespace( + make_frame(3, frame_pointer, stream, readtable, character)); + struct pso_pointer r = + read(make_frame(3, frame_pointer, stream, readtable, character)); - if ( exceptionp( r ) ) { - result = r; - break; - } else { - result = make_cons( frame_pointer, r, result ); - character = - skip_whitespace( make_frame - ( 3, frame_pointer, stream, readtable, - character ) ); - } - } + if (exceptionp(r)) { + result = r; + break; + } else { + result = make_cons(frame_pointer, r, result); + character = skip_whitespace( + make_frame(3, frame_pointer, stream, readtable, character)); + struct pso2 *ch = pointer_to_object(character); - return consp( result ) ? c_reverse( frame_pointer, result ) : result; + debug_dump_object(character, DEBUG_IO, 2); + } + } while (c_nilp(character) || + (characterp(character) && + pointer_to_object(character)->payload.character.character != + SYNTAX_RPAR)); + + return consp(result) ? c_reverse(frame_pointer, result) : result; } - /** * @brief Read one integer from the stream and return it. * @@ -214,76 +207,78 @@ struct pso_pointer read_list( struct pso_pointer frame_pointer ) { * 1. The read table currently in use; * 2. The character most recently read from that stream. */ -struct pso_pointer read_number( struct pso_pointer frame_pointer ) { - 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 read_number(struct pso_pointer frame_pointer) { + 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 ( c_nilp( character ) ) { - character = - read_character( make_frame( 1, frame_pointer, stream ) ); - } - wchar_t c = c_nilp( character ) - ? 0 : pointer_to_object( character )->payload.character.character; + if (readp(stream)) { + if (c_nilp(character)) { + character = read_character(make_frame(1, frame_pointer, stream)); + } + wchar_t c = + 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 == L','; c = url_fgetwc( input ) ) { - if ( iswdigit( c ) ) { - value = ( value * base ) + ( ( int ) c - ( int ) L'0' ); - } - } + URL_FILE *input = pointer_to_object(stream)->payload.stream.stream; + for (; iswdigit(c) || c == L','; c = url_fgetwc(input)) { + if (iswdigit(c)) { + value = (value * base) + ((int)c - (int)L'0'); + } + } - url_ungetwc( c, input ); - result = make_integer( frame_pointer, value ); - } // else exception? + url_ungetwc(c, input); + result = make_integer(frame_pointer, value); + } // else exception? #ifdef DEBUG - debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value ); - debug_dump_object( result, DEBUG_IO, 1 ); + debug_printf(DEBUG_IO, 0, L"\nRead number %ld\n", value); + debug_dump_object(result, DEBUG_IO, 1); #endif - return result; + return result; } -struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { - 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 read_symbol(struct pso_pointer frame_pointer) { + 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 ( c_nilp( character ) ) { - character = - read_character( make_frame( 1, frame_pointer, stream ) ); - } + if (readp(stream)) { + if (c_nilp(character)) { + character = read_character(make_frame(1, frame_pointer, stream)); + } - wchar_t c = c_nilp( character ) - ? 0 : pointer_to_object( character )->payload.character.character; + wchar_t c = + c_nilp(character) + ? 0 + : pointer_to_object(character)->payload.character.character; - URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; - for ( ; symbol_char_p( c ); c = url_fgetwc( input ) ) { - result = - make_string_like_thing( frame_pointer, c, result, SYMBOLTAG ); - } + URL_FILE *input = pointer_to_object(stream)->payload.stream.stream; + for (; symbol_char_p(c); c = url_fgetwc(input)) { + result = + make_string_like_thing(frame_pointer, c, result, SYMBOLTAG); + } - url_ungetwc( c, input ); - result = c_reverse( frame_pointer, result ); - } + url_ungetwc(c, input); + result = c_reverse(frame_pointer, result); + } #ifdef DEBUG - debug_print( L"\nRead symbol `", DEBUG_IO, 0 ); - debug_print_object( result, DEBUG_IO, 0 ); - debug_print( L"`\n\t", DEBUG_IO, 0 ); - debug_dump_object( result, DEBUG_IO, 1 ); + debug_print(L"\nRead symbol `", DEBUG_IO, 0); + debug_print_object(result, DEBUG_IO, 0); + debug_print(L"`\n\t", DEBUG_IO, 0); + debug_dump_object(result, DEBUG_IO, 1); #endif - return result; + return result; } /** @@ -297,86 +292,85 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) { * 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 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 read(struct pso_pointer frame_pointer) { + 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 ( c_nilp( stream ) ) { - stream = - make_read_stream( frame_pointer, file_to_url_file( stdin ), nil ); - } + if (c_nilp(stream)) { + stream = make_read_stream(frame_pointer, file_to_url_file(stdin), nil); + } - if ( c_nilp( readtable ) ) { - readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) ); - } + if (c_nilp(readtable)) { + readtable = c_assoc(lisp_io_read_table, fetch_env(frame_pointer)); + } - if ( c_nilp( character ) ) { - character = skip_whitespace( make_frame( 1, frame_pointer, stream ) ); - } + if (c_nilp(character)) { + character = skip_whitespace(make_frame(1, frame_pointer, stream)); + } - struct pso_pointer readmacro = c_assoc( character, readtable ); + struct pso_pointer readmacro = c_assoc(character, readtable); - if ( !c_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 (!c_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 SYNTAX_SEMICOLON: - 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 SYNTAX_LPAR: - result = - read_list( make_frame( 3, stream, readtable, character ) ); - break; - case EOF: - result = make_eof_exception( frame_pointer ); - break; - default: - struct pso_pointer next = make_frame( 3, frame_pointer, stream, - readtable, - make_character - ( frame_pointer, c ) ); - inc_ref( next ); - if ( iswdigit( c ) ) { - result = push_local( frame_pointer, read_number( next ) ); - } else if ( symbol_char_p( c ) ) { - result = push_local( frame_pointer, read_symbol( next ) ); - } 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 ); - } -// dec_ref( next ); - break; - } - } + switch (c) { + case SYNTAX_SEMICOLON: + 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 SYNTAX_LPAR: + result = read_list(make_frame(3, frame_pointer, stream, readtable, character)); + break; + case EOF: + result = make_eof_exception(frame_pointer); + break; + default: + struct pso_pointer next = + make_frame(3, frame_pointer, stream, readtable, + make_character(frame_pointer, c)); + inc_ref(next); + if (iswdigit(c)) { + result = push_local(frame_pointer, read_number(next)); + } else if (symbol_char_p(c)) { + result = push_local(frame_pointer, read_symbol(next)); + } 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 ); + } + // dec_ref( next ); + break; + } + } #ifdef DEBUG - debug_print( L"Read expression: `", DEBUG_IO, 0 ); - debug_print_object( result, DEBUG_IO, 0 ); - debug_print( L"`\n", DEBUG_IO, 0 ); - debug_dump_object( result, DEBUG_IO, 1 ); + debug_print(L"Read expression: `", DEBUG_IO, 0); + debug_print_object(result, DEBUG_IO, 0); + debug_print(L"`\n", DEBUG_IO, 0); + debug_dump_object(result, DEBUG_IO, 1); #endif - return result; + return result; } diff --git a/src/c/memory/dump.c b/src/c/memory/dump.c index b4c1fd6..b86f011 100644 --- a/src/c/memory/dump.c +++ b/src/c/memory/dump.c @@ -197,7 +197,9 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { // url_fputws( L"\n", output ); // fflush(stderr); - URL_FILE *output = pointer_to_object( stream )->payload.stream.stream; + URL_FILE *output = writep(stream) ? + pointer_to_object( stream )->payload.stream.stream : + file_to_url_file(stderr); if ( c_nilp( pointer ) ) { // the object at (node, 0, 0) ought to have been initialised, but may not @@ -214,6 +216,10 @@ struct pso_pointer dump_object( struct pso_pointer frame_pointer ) { pointer.offset, object->header.count ); switch ( get_tag_value( pointer ) ) { + case CHARACTERTV: { + wchar_t wc = pointer_to_object(pointer)->payload.character.character; + url_fwprintf(output, L"\t\tCharacter object: character `%lc` (%d)\n", wc, wc); + } break; case CONSTV: url_fwprintf( output, L"\t\tCons object: car at page %d offset %d, cdr at page %d "