Compare commits
80 commits
master
...
feature/re
| Author | SHA1 | Date | |
|---|---|---|---|
| 6f39dae75f | |||
| d1bfb029b8 | |||
| 6b89779bab | |||
| 80049f2272 | |||
| 5e64a33965 | |||
| 271b7da46a | |||
| c29a95b00d | |||
| cf655e8020 | |||
| 1cfd333e26 | |||
| 818293d4f1 | |||
| 4d480798e8 | |||
| f895a8e359 | |||
| d2efc8ba78 | |||
| 5ec1c926b0 | |||
| fcfdb43b05 | |||
| efa6a3246d | |||
| f4303247b9 | |||
| 8c5dccb5c8 | |||
| 92490ebd5f | |||
| ab0ea09bd4 | |||
| aac4669a3d | |||
| dbeb99759a | |||
| aff1430762 | |||
| f7eabb9b62 | |||
| 63906fe817 | |||
| 22b0160a26 | |||
| 9425506e2a | |||
| 235d455b80 | |||
| dd4176e20b | |||
| aa0d60bbed | |||
| 8d2acbeb0f | |||
| eed4711fee | |||
| ef59563e25 | |||
| aa5b34368e | |||
| 6148d3699f | |||
| f05d1af9d6 | |||
| c59825d7fe | |||
| 812a1be7d9 | |||
| d952623266 | |||
| 521c5d2285 | |||
| 0e8712a076 | |||
| 9a0f186f29 | |||
| 02a4bc3e28 | |||
| ca5671f613 | |||
| cf05e30540 | |||
| 4efe9eab87 | |||
| 83537391a6 | |||
| f915a9993f | |||
| cb3dcb352e | |||
| ba985474f6 | |||
| 04aa32bd5a | |||
| 25c87aac6e | |||
| f751fc8a09 | |||
| c9f50572ab | |||
| b5a2e09763 | |||
| f5f8e38b91 | |||
| b6480aebd5 | |||
| f3a26bc02e | |||
| 9eb0d3c5a0 | |||
| cc8e96eda4 | |||
| a302663b32 | |||
| 1196b3eb1d | |||
| 364d7d2c7b | |||
| 2b22780ccf | |||
| e3f922a8bf | |||
| a8b4a6e69d | |||
| 60921be3d4 | |||
| 1ce9fbda77 | |||
| 04bf001652 | |||
| 00997d3c90 | |||
| cae27731b7 | |||
| 1afb1b9fad | |||
| 154cda8da3 | |||
| 57c5fe314a | |||
| 6c4be8f283 | |||
| 604fca3c24 | |||
| 19d6b0df29 | |||
| 914c35ead0 | |||
| 09051a3e63 | |||
| 99d4794f3b |
206 changed files with 14419 additions and 12321 deletions
7
.clangd
Normal file
7
.clangd
Normal file
|
|
@ -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]
|
||||
4
.gitignore
vendored
4
.gitignore
vendored
|
|
@ -55,3 +55,7 @@ post-scarcity.kdev4
|
|||
\.zig-cache/
|
||||
sq/
|
||||
tmp/
|
||||
utils_src/a.out
|
||||
|
||||
doxyresources/header.html
|
||||
|
||||
|
|
|
|||
3
.gitmodules
vendored
Normal file
3
.gitmodules
vendored
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
[submodule "munit"]
|
||||
path = munit
|
||||
url = https://github.com/nemequ/munit.git
|
||||
20
Makefile
20
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)
|
||||
|
|
@ -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 $(shell find $(SRC_DIRS) -type d)
|
||||
|
||||
TMP_DIR ?= ./tmp
|
||||
|
||||
|
|
@ -20,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
|
||||
|
|
@ -49,8 +51,14 @@ clean:
|
|||
coredumps:
|
||||
ulimit -c unlimited
|
||||
|
||||
repl:
|
||||
$(TARGET) -ps1000 2> tmp/psse.log
|
||||
repl: Makefile $(TARGET)
|
||||
$(TARGET) -p -s1000 -v1023 2> tmp/psse.log
|
||||
|
||||
run: Makefile $(TARGET)
|
||||
$(TARGET) -p -s1000 -v1023 2> tmp/psse.log
|
||||
|
||||
install: Makefile $(TARGET)
|
||||
cp $(TARGET) ~/bin
|
||||
|
||||
|
||||
-include $(DEPS)
|
||||
|
|
|
|||
89
docs/0-1-0-design-decistions.md
Normal file
89
docs/0-1-0-design-decistions.md
Normal file
|
|
@ -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.
|
||||
108
docs/Compiler.md
Normal file
108
docs/Compiler.md
Normal file
|
|
@ -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 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.
|
||||
|
||||
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.
|
||||
71
docs/Dont-know-dont-care.md
Normal file
71
docs/Dont-know-dont-care.md
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
# Don't know, don't care
|
||||
|
||||

|
||||
|
||||
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!
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
267
docs/List of spacecraft in the Culture series.csv
Normal file
267
docs/List of spacecraft in the Culture series.csv
Normal file
|
|
@ -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,,
|
||||
,,,,
|
||||
,,,,
|
||||
,,,,
|
||||
,,,,
|
||||
,,,,
|
||||
|
141
docs/Nodes-threads-locks-links.md
Normal file
141
docs/Nodes-threads-locks-links.md
Normal file
|
|
@ -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 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`.
|
||||
|
||||
### 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.
|
||||
|
||||
69
docs/Paged-space-objects.md
Normal file
69
docs/Paged-space-objects.md
Normal file
|
|
@ -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.
|
||||
|
|
@ -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 1<sup>st</sup> 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.
|
||||
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.
|
||||
|
|
@ -1,5 +1,522 @@
|
|||
# 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
|
||||
|
||||
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
|
||||
<exception: ("Invalid object in sequence")>
|
||||
```
|
||||
|
||||
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!
|
||||
|
||||
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, 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.
|
||||
|
||||
### 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.
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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.
|
||||
|
||||
#### 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 <simon@journeyman.cc>
|
||||
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 <simon@journeyman.cc>
|
||||
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
|
||||
|
||||
### 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;
|
||||
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 `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)
|
||||
|
||||
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.
|
||||
|
||||
### 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
|
||||
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
|
||||
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
|
||||
in C, not in a more modern language. It doesn't compile yet.
|
||||
|
||||
My C is getting better... but it needed to!
|
||||
|
||||
## 20260323
|
||||
|
||||
I started an investigastion of the [Zig language](https://ziglang.org/) and
|
||||
come away frustrated. It's definitely an interesting language, and *I think*
|
||||
one capable of doing what I want. But in trying to learn, I checked out
|
||||
someone else's [Lisp interpreter in Zig](https://github.com/cryptocode/bio).
|
||||
The last commit to this project is six months ago, so fairly current; project
|
||||
documentation is polished, implying the project is well advanced and by someone
|
||||
competent.
|
||||
|
||||
It won't build.
|
||||
|
||||
It won't build because there are breaking changes to the build system in the
|
||||
current version of Zig, and, according to helpful people on the Zig language
|
||||
Discord, breaking changes in Zig versions are quite frequent.
|
||||
|
||||
Post-scarcity is a project which procedes slowly, and is very large indeed. I
|
||||
will certainly not complete it before I die.
|
||||
|
||||
I don't feel unstable tools are a good choice.
|
||||
|
||||
I have, however, done more thinking about [Paged space objects], and think I
|
||||
now have a buildable specification.
|
||||
|
||||
## 20260319
|
||||
|
||||
Right, the `member?` bug [is fixed](https://git.journeyman.cc/simon/post-scarcity/issues/11).
|
||||
|
|
|
|||
268
docs/shipnames.md
Normal file
268
docs/shipnames.md
Normal file
|
|
@ -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
|
||||
2045
doxyresources/customdoxygen.css
Normal file
2045
doxyresources/customdoxygen.css
Normal file
File diff suppressed because it is too large
Load diff
1
munit
Submodule
1
munit
Submodule
|
|
@ -0,0 +1 @@
|
|||
Subproject commit fbbdf1467eb0d04a6ee465def2e529e4c87f2118
|
||||
|
|
@ -1,508 +0,0 @@
|
|||
/*
|
||||
* integer.c
|
||||
*
|
||||
* functions for integer cells.
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#define _GNU_SOURCE
|
||||
#include <limits.h>
|
||||
#include <math.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <inttypes.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
/*
|
||||
* integer.h
|
||||
*
|
||||
* functions for integer cells.
|
||||
*
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __integer_h
|
||||
#define __integer_h
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#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
|
||||
|
|
@ -1,825 +0,0 @@
|
|||
/*
|
||||
* peano.c
|
||||
*
|
||||
* Basic peano arithmetic
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <ctype.h>
|
||||
#include <math.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
|
|
@ -1,95 +0,0 @@
|
|||
/*
|
||||
* peano.h
|
||||
*
|
||||
* Basic peano arithmetic
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* 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 */
|
||||
|
|
@ -1,411 +0,0 @@
|
|||
/*
|
||||
* ratio.c
|
||||
*
|
||||
* functions for rational number cells.
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#define _GNU_SOURCE
|
||||
#include <math.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
/**
|
||||
* ratio.h
|
||||
*
|
||||
* functions for rational number cells.
|
||||
*
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* 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
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
/*
|
||||
* real.c
|
||||
*
|
||||
* functions for real number cells.
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* 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;
|
||||
}
|
||||
|
|
@ -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 */
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
/*
|
||||
* authorised.c
|
||||
*
|
||||
* For now, a dummy authorising everything.
|
||||
*
|
||||
* (c) 2021 Simon Brooke <simon@journeyman.cc>
|
||||
* 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;
|
||||
}
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
/*
|
||||
* authorise.h
|
||||
*
|
||||
* Basic implementation of a authorisation.
|
||||
*
|
||||
* (c) 2021 Simon Brooke <simon@journeyman.cc>
|
||||
* 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
|
||||
24
src/c/arith/READMDE.md
Normal file
24
src/c/arith/READMDE.md
Normal file
|
|
@ -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.
|
||||
|
|
@ -1,66 +1,52 @@
|
|||
/*
|
||||
* debug.c
|
||||
/**
|
||||
* debug.c
|
||||
*
|
||||
* Better debug log messages.
|
||||
* Post Scarcity Software Environment: debugging messages.
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
* Print debugging output.
|
||||
*
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "memory/consspaceobject.h"
|
||||
#include "debug.h"
|
||||
#include "memory/dump.h"
|
||||
|
||||
#include "io/fopen.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.
|
||||
*/
|
||||
#include "memory/dump.h"
|
||||
|
||||
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.
|
||||
*
|
||||
* 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 ) {
|
||||
void debug_print( char32_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
|
||||
|
|
@ -73,6 +59,10 @@ void debug_print( wchar_t *message, int level ) {
|
|||
* 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
|
||||
|
|
@ -100,6 +90,9 @@ void debug_print_128bit( __int128_t n, int 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
|
||||
|
|
@ -116,11 +109,22 @@ void debug_println( int level ) {
|
|||
*
|
||||
* 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, wchar_t *format, ... ) {
|
||||
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 );
|
||||
|
|
@ -128,6 +132,7 @@ void debug_printf( int level, wchar_t *format, ... ) {
|
|||
#endif
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* @brief print the object indicated by this `pointer` to stderr, if `verbosity`
|
||||
* matches `level`.
|
||||
|
|
@ -135,12 +140,12 @@ void debug_printf( int level, wchar_t *format, ... ) {
|
|||
* `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 ) {
|
||||
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 );
|
||||
print( ustderr, pointer );
|
||||
in_write( pointer, ustderr, PRINT_VARIANT_PRINT, indent );
|
||||
free( ustderr );
|
||||
}
|
||||
#endif
|
||||
|
|
@ -152,30 +157,30 @@ void debug_print_object( struct cons_pointer pointer, int 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_dump_object( struct cons_pointer pointer, int level ) {
|
||||
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 );
|
||||
dump_object( 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
|
||||
// wchar_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
|
||||
}
|
||||
///**
|
||||
// * 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
|
||||
// // char32_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
|
||||
//}
|
||||
|
|
@ -1,20 +1,31 @@
|
|||
/*
|
||||
* debug.h
|
||||
/**
|
||||
* debug.h
|
||||
*
|
||||
* Better debug log messages.
|
||||
* Post Scarcity Software Environment: entry point.
|
||||
*
|
||||
* (c) 2017 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
* Print debugging output.
|
||||
*
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_debug_h
|
||||
#define __psse_debug_h
|
||||
#include <ctype.h>
|
||||
#include <stdbool.h>
|
||||
#include <stddef.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#include "memory/consspaceobject.h"
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <uchar.h>
|
||||
#include <uchar.h>
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#ifndef __debug_print_h
|
||||
#define __debug_print_h
|
||||
#include "memory/pointer.h"
|
||||
|
||||
/**
|
||||
* @brief Print messages debugging memory allocation.
|
||||
|
|
@ -86,16 +97,28 @@
|
|||
*/
|
||||
#define DEBUG_EQUAL 512
|
||||
|
||||
/**
|
||||
* @brief sum of all previous DEBUG_ values.
|
||||
*/
|
||||
#define DEBUG_ANY 1023
|
||||
|
||||
/**
|
||||
* @brief Verbosity (and content) of debugging output
|
||||
*
|
||||
* Interpreted as a sequence of topic-specific flags, see above.
|
||||
*/
|
||||
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, 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, wchar_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 );
|
||||
|
||||
void debug_printf( int level, int indent, char32_t * format, ... );
|
||||
|
||||
#endif
|
||||
118
src/c/environment/environment.c
Normal file
118
src/c/environment/environment.c
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
/**
|
||||
* environment/environment.c
|
||||
*
|
||||
* Initialise a MINIMAL environment.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stdbool.h>
|
||||
|
||||
#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"
|
||||
#include "memory/pso.h"
|
||||
#include "memory/pso2.h"
|
||||
#include "memory/tags.h"
|
||||
|
||||
#include "ops/bind.h"
|
||||
#include "ops/string_ops.h"
|
||||
|
||||
#include "payloads/psse_string.h"
|
||||
|
||||
#include "payloads/stack.h"
|
||||
#include "ops/truth.h"
|
||||
#include "payloads/stack.h"
|
||||
|
||||
/**
|
||||
* @brief Flag to prevent re-initialisation.
|
||||
*/
|
||||
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.
|
||||
*/
|
||||
|
||||
struct pso_pointer initialise_environment( uint32_t node ) {
|
||||
struct pso_pointer result = initialise_memory( 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 );
|
||||
struct pso_pointer n = allocate( frame_pointer, 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;
|
||||
lock_object( nil );
|
||||
debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 );
|
||||
} else {
|
||||
result = nil;
|
||||
debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 );
|
||||
}
|
||||
}
|
||||
if ( !c_nilp( result ) ) {
|
||||
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
|
||||
if ( ( n.page == 0 ) && ( n.offset == 4 ) ) {
|
||||
struct pso2 *object = pointer_to_object( n );
|
||||
object->payload.string.character = L't';
|
||||
object->payload.cons.cdr = t;
|
||||
|
||||
t = n;
|
||||
lock_object( t );
|
||||
debug_print( L"success\n", DEBUG_BOOTSTRAP, 0 );
|
||||
} else {
|
||||
result = nil;
|
||||
debug_print( L"fail\n", DEBUG_BOOTSTRAP, 0 );
|
||||
}
|
||||
}
|
||||
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, L"nil" ), nil,
|
||||
nil ) );
|
||||
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, 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 );
|
||||
|
||||
result =
|
||||
initialise_privileged_keywords( make_frame_with_env
|
||||
( 0, frame_pointer, result ) );
|
||||
|
||||
result =
|
||||
inc_ref( initialise_function_bindings
|
||||
( make_frame_with_env( 0, frame_pointer, result ) ) );
|
||||
|
||||
dec_ref( frame_pointer );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
16
src/c/environment/environment.h
Normal file
16
src/c/environment/environment.h
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
/**
|
||||
* environment/environment.h
|
||||
*
|
||||
* Initialise a MINIMAL environment.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_environment_environment_h
|
||||
#define __psse_environment_environment_h
|
||||
|
||||
#include <stdint.h>
|
||||
struct pso_pointer initialise_environment( uint32_t node );
|
||||
|
||||
#endif
|
||||
354
src/c/environment/function_bindings.c
Normal file
354
src/c/environment/function_bindings.c
Normal file
|
|
@ -0,0 +1,354 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdlib.h>
|
||||
#include <wchar.h>
|
||||
|
||||
#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"
|
||||
|
||||
#include "ops/assoc.h"
|
||||
#include "ops/bind.h"
|
||||
#include "ops/cond.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 "payloads/stack.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
|
||||
* 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_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 );
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 );
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
struct function_data {
|
||||
wchar_t *name;
|
||||
wchar_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_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},
|
||||
#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},
|
||||
#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},
|
||||
#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},
|
||||
#endif
|
||||
#ifdef __psse_ops_assoc_h
|
||||
{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},
|
||||
#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},
|
||||
#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},
|
||||
#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},
|
||||
#endif
|
||||
#ifdef __psse_ops_keys_h
|
||||
{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},
|
||||
#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},
|
||||
#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},
|
||||
#endif
|
||||
#ifdef __psse_ops_repl_h
|
||||
{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},
|
||||
#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},
|
||||
#endif
|
||||
|
||||
{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
|
||||
* 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
|
||||
{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},
|
||||
#endif
|
||||
{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 );
|
||||
|
||||
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;
|
||||
}
|
||||
17
src/c/environment/function_bindings.h
Normal file
17
src/c/environment/function_bindings.h
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* 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
|
||||
99
src/c/environment/privileged_keywords.c
Normal file
99
src/c/environment/privileged_keywords.c
Normal file
|
|
@ -0,0 +1,99 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* 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 "payloads/stack.h"
|
||||
|
||||
#include "ops/string_ops.h"
|
||||
|
||||
|
||||
/**
|
||||
* layer metadata for functions written in C
|
||||
*/
|
||||
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).
|
||||
*/
|
||||
struct pso_pointer privileged_keyword_location;
|
||||
|
||||
/**
|
||||
* name metadata for compiled functions.
|
||||
*/
|
||||
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;
|
||||
|
||||
/**
|
||||
* The symbol whose binding in the eval-time environment sets the read ACL
|
||||
* for new objects made.
|
||||
*/
|
||||
struct pso_pointer privileged_symbol_friends;
|
||||
|
||||
/**
|
||||
* 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 );
|
||||
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 );
|
||||
|
||||
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;
|
||||
}
|
||||
37
src/c/environment/privileged_keywords.h
Normal file
37
src/c/environment/privileged_keywords.h
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
/**
|
||||
* privileged_keywords.h
|
||||
*
|
||||
* Post Scarcity Soctware Environment
|
||||
*
|
||||
* Keywords guaranteed to be present in the environment on each node.
|
||||
*
|
||||
* Copyright (c): 27 Apr 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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_
|
||||
#include "memory/pointer.h"
|
||||
|
||||
#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"
|
||||
|
||||
#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;
|
||||
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;
|
||||
|
||||
extern struct pso_pointer privileged_symbol_friends;
|
||||
|
||||
struct pso_pointer initialise_privileged_keywords( struct pso_pointer env );
|
||||
#endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */
|
||||
19
src/c/io/alphabets.h
Normal file
19
src/c/io/alphabets.h
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* 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
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
#ifdef FOPEN_STANDALONE
|
||||
CURLSH *io_share;
|
||||
#else
|
||||
#include "memory/consspaceobject.h"
|
||||
#include "memory/pso2.h"
|
||||
#include "io/io.h"
|
||||
#include "utils.h"
|
||||
#endif
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
/*
|
||||
* fopen.h
|
||||
* io/fopen.h
|
||||
*
|
||||
* adapted from https://curl.haxx.se/libcurl/c/fopen.html.
|
||||
*
|
||||
676
src/c/io/io.c
Normal file
676
src/c/io/io.c
Normal file
|
|
@ -0,0 +1,676 @@
|
|||
/*
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <grp.h>
|
||||
#include <langinfo.h>
|
||||
#include <pwd.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <sys/stat.h>
|
||||
#include <sys/types.h>
|
||||
#include <time.h>
|
||||
#include <uchar.h>
|
||||
#include <unistd.h>
|
||||
#include <uuid/uuid.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include <curl/curl.h>
|
||||
|
||||
// #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/pso.h"
|
||||
#include "memory/pso2.h"
|
||||
#include "memory/pso4.h"
|
||||
#include "memory/tags.h"
|
||||
|
||||
// #include "ops/intern.h"
|
||||
// #include "ops/lispops.h"
|
||||
|
||||
#include "ops/assoc.h"
|
||||
#include "ops/bind.h"
|
||||
#include "payloads/stack.h"
|
||||
#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"
|
||||
#include "payloads/read_stream.h"
|
||||
#include "payloads/stack.h"
|
||||
#include "payloads/write_stream.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 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;
|
||||
|
||||
/**
|
||||
* @brief bound to the Lisp symbol representing C_IO_PROMPT in initialisation
|
||||
*/
|
||||
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_read_table;
|
||||
|
||||
|
||||
/**
|
||||
* 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.
|
||||
*
|
||||
* @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( );
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
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( 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_read_table =
|
||||
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, 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_read_table,
|
||||
nil, env ) ) ) ) ) );
|
||||
|
||||
lisp_stdin =
|
||||
lock_object( make_read_stream
|
||||
( frame_pointer, file_to_url_file( stdin ),
|
||||
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-input" ) ),
|
||||
frame_pointer ) ) );
|
||||
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( frame_pointer,
|
||||
file_to_url_file( stdout ),
|
||||
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, frame_pointer, lisp_io_out, lisp_stdout, env ) );
|
||||
}
|
||||
|
||||
if ( !c_nilp( env ) && !exceptionp( env ) ) {
|
||||
lisp_stderr =
|
||||
lock_object( make_write_stream
|
||||
( frame_pointer, file_to_url_file( stderr ),
|
||||
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-log" ) ),
|
||||
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 );
|
||||
debug_print_object( env, DEBUG_IO, 0 );
|
||||
return env;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* 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;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* @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
|
||||
* 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 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 )
|
||||
== 0 ) {
|
||||
result = t;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
struct pso_pointer add_meta_integer( struct pso_pointer frame_pointer,
|
||||
struct pso_pointer meta, wchar_t *key,
|
||||
long int value ) {
|
||||
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 frame_pointer,
|
||||
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 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 frame_pointer,
|
||||
struct pso_pointer meta, wchar_t *key,
|
||||
time_t *value ) {
|
||||
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 );
|
||||
}
|
||||
|
||||
/**
|
||||
* 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,
|
||||
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] );
|
||||
wchar_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 *object = pointer_to_object( stream );
|
||||
URL_FILE *s = pointer_to_object( stream )->payload.stream.stream;
|
||||
struct pso_pointer meta =
|
||||
add_meta_string( frame_pointer, object->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( frame_pointer, meta, L"owner",
|
||||
pwd->pw_name );
|
||||
} else {
|
||||
meta =
|
||||
add_meta_integer( frame_pointer, meta, L"owner",
|
||||
statbuf.st_uid );
|
||||
}
|
||||
|
||||
if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) {
|
||||
meta =
|
||||
add_meta_string( frame_pointer, meta, L"group",
|
||||
grp->gr_name );
|
||||
} else {
|
||||
meta =
|
||||
add_meta_integer( frame_pointer, meta, L"group",
|
||||
statbuf.st_gid );
|
||||
}
|
||||
|
||||
meta =
|
||||
add_meta_integer( frame_pointer, meta, L"size",
|
||||
( intmax_t ) statbuf.st_size );
|
||||
meta =
|
||||
add_meta_time( frame_pointer, 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. */
|
||||
object->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;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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;
|
||||
* 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_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 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( 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.
|
||||
*
|
||||
* * (slurp stream)
|
||||
*
|
||||
* @param frame_pointer a pointer to my stack frame.
|
||||
* @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 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 );
|
||||
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( frame_pointer, ( wchar_t ) c, nil );
|
||||
cell->payload.string.cdr = cursor;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
68
src/c/io/io.h
Normal file
68
src/c/io/io.h
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
|
||||
/*
|
||||
* io.h
|
||||
*
|
||||
* Communication between PSSE and the outside world, via libcurl.
|
||||
*
|
||||
* (c) 2019 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_io_io_h
|
||||
#define __psse_io_io_h
|
||||
|
||||
#include <curl/curl.h>
|
||||
#include <stdbool.h>
|
||||
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wctype.h>
|
||||
|
||||
#include "io/fopen.h"
|
||||
#include "memory/pointer.h"
|
||||
|
||||
extern CURLSH *io_share;
|
||||
|
||||
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*"
|
||||
#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;
|
||||
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 );
|
||||
|
||||
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 lisp_open( struct pso_pointer frame_pointer );
|
||||
struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
41
src/c/io/peek.c
Normal file
41
src/c/io/peek.c
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
/**
|
||||
* io/peek.c
|
||||
*
|
||||
* Post Scarcity Software Environment: peek.
|
||||
*
|
||||
* look at the next character on the input stream, without consuming it.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <curl/curl.h>
|
||||
|
||||
#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;
|
||||
}
|
||||
20
src/c/io/peek.h
Normal file
20
src/c/io/peek.h
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_io_peek_h
|
||||
#define __psse_io_peek_h
|
||||
#include <stdbool.h>
|
||||
|
||||
struct pso_pointer peek( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
342
src/c/io/print.c
Normal file
342
src/c/io/print.c
Normal file
|
|
@ -0,0 +1,342 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <uchar.h>
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
/* libcurl, used for io */
|
||||
#include <curl/curl.h>
|
||||
|
||||
#include "io/fopen.h"
|
||||
#include "io/io.h"
|
||||
#include "io/print.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"
|
||||
|
||||
#include "ops/string_ops.h"
|
||||
#include "payloads/character.h"
|
||||
#include "payloads/cons.h"
|
||||
#include "payloads/exception.h"
|
||||
#include "payloads/integer.h"
|
||||
|
||||
#include "payloads/stack.h"
|
||||
#include "ops/truth.h"
|
||||
|
||||
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
|
||||
bool escape, int indent );
|
||||
|
||||
/**
|
||||
* @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_string_like_thing( struct pso_pointer p,
|
||||
URL_FILE *output, bool escape ) {
|
||||
switch ( get_tag_value( p ) ) {
|
||||
case KEYTV:
|
||||
write_char( L':', output, escape );
|
||||
break;
|
||||
case STRINGTV:
|
||||
if ( escape )
|
||||
write_char( L'"', output, escape );
|
||||
break;
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
write_char( wc, output, escape );
|
||||
}
|
||||
}
|
||||
|
||||
if ( stringp( p ) ) {
|
||||
if ( escape )
|
||||
write_char( L'"', output, escape );
|
||||
}
|
||||
|
||||
return p;
|
||||
}
|
||||
|
||||
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, 0 );
|
||||
|
||||
if ( exceptionp( result ) )
|
||||
break;
|
||||
|
||||
switch ( get_tag_value( object->payload.cons.cdr ) ) {
|
||||
case NILTV:
|
||||
break;
|
||||
case CONSTV:
|
||||
write_char( L' ', output, escape );
|
||||
break;
|
||||
default:
|
||||
url_fputws( L" . ", output );
|
||||
result =
|
||||
in_write( object->payload.cons.cdr, output, escape,
|
||||
0 );
|
||||
}
|
||||
}
|
||||
} else {
|
||||
// TODO: return exception
|
||||
}
|
||||
|
||||
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.
|
||||
*
|
||||
* @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, int indent ) {
|
||||
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:
|
||||
write_char( L'(', output, escape );
|
||||
result = write_list_content( p, output, escape );
|
||||
write_char( L')', output, escape );
|
||||
break;
|
||||
case EXCEPTIONTV:{
|
||||
struct pso3 *exception = pointer_to_pso3( p );
|
||||
|
||||
if ( exception != NULL ) {
|
||||
url_fputws( L"<exception: ", output );
|
||||
in_write( exception->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"<broken exception :-( >", output );
|
||||
}
|
||||
}
|
||||
break;
|
||||
case FUNCTIONTV:{
|
||||
struct pso2 *function = pointer_to_object( p );
|
||||
url_fputws( L"<function: ", output );
|
||||
in_write( function->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 ) );
|
||||
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,
|
||||
indent );
|
||||
write_char( L'>', output, escape );
|
||||
break;
|
||||
case SPECIALTV:{
|
||||
struct pso2 *function = pointer_to_object( p );
|
||||
url_fputws( L"<special form: ", output );
|
||||
in_write( function->payload.function.meta, output, escape,
|
||||
indent );
|
||||
write_char( L'>', output, escape );
|
||||
} break;
|
||||
case TRUETV:
|
||||
write_char( L't', output, escape );
|
||||
break;
|
||||
default:
|
||||
// TODO: return exception
|
||||
}
|
||||
} else {
|
||||
// TODO: return exception
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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.
|
||||
*
|
||||
* (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.
|
||||
* @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 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;
|
||||
struct pso2 *stream_obj = pointer_to_object( stream );
|
||||
|
||||
if ( writep( stream ) ) {
|
||||
URL_FILE *output = stream_obj->payload.stream.stream;
|
||||
|
||||
if ( nl_before )
|
||||
url_fputwc( L'\n', output );
|
||||
|
||||
result = in_write( object, output, escape, 0 );
|
||||
|
||||
url_fputwc( nl_after ? L'\n' : L' ', output );
|
||||
} else {
|
||||
result =
|
||||
make_exception( make_frame( 1, frame_pointer,
|
||||
c_string_to_lisp_string
|
||||
( frame_pointer,
|
||||
L"Bad write stream passed to write." ) ) );
|
||||
}
|
||||
|
||||
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.
|
||||
*
|
||||
* (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.
|
||||
*/
|
||||
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 ) );
|
||||
|
||||
struct pso_pointer result = write( next );
|
||||
|
||||
dec_ref( next );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief princ is pretty much like print except things are printed `unescaped`
|
||||
*/
|
||||
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 ) );
|
||||
|
||||
struct pso_pointer result = write( next );
|
||||
|
||||
dec_ref( next );
|
||||
|
||||
return result;
|
||||
}
|
||||
37
src/c/io/print.h
Normal file
37
src/c/io/print.h
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_io_print_h
|
||||
#define __psse_io_print_h
|
||||
#include <stdbool.h>
|
||||
|
||||
#include "io/fopen.h"
|
||||
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
|
||||
#define PRINT_VARIANT_PRINC 2
|
||||
|
||||
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
|
||||
376
src/c/io/read.c
Normal file
376
src/c/io/read.c
Normal file
|
|
@ -0,0 +1,376 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <math.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "debug.h"
|
||||
|
||||
#include "io/io.h"
|
||||
#include "io/read.h"
|
||||
#include "memory/node.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/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"
|
||||
#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
|
||||
// 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.
|
||||
*
|
||||
* 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 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;
|
||||
}
|
||||
|
||||
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.
|
||||
*
|
||||
* * (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)) {
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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;
|
||||
|
||||
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));
|
||||
|
||||
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.
|
||||
}
|
||||
|
||||
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));
|
||||
struct pso2 *ch = pointer_to_object(character);
|
||||
|
||||
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.
|
||||
*
|
||||
* 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_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;
|
||||
|
||||
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_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);
|
||||
#endif
|
||||
|
||||
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;
|
||||
|
||||
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 (; 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);
|
||||
}
|
||||
#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
|
||||
|
||||
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 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(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(character)) {
|
||||
character = skip_whitespace(make_frame(1, frame_pointer, stream));
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
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);
|
||||
#endif
|
||||
|
||||
return result;
|
||||
}
|
||||
33
src/c/io/read.h
Normal file
33
src/c/io/read.h
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#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 );
|
||||
|
||||
struct pso_pointer read_symbol( struct pso_pointer frame_pointer );
|
||||
|
||||
struct pso_pointer read( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
65
src/c/memory/destroy.c
Normal file
65
src/c/memory/destroy.c
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* 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( 1, nil, p );
|
||||
inc_ref( f );
|
||||
|
||||
switch ( get_tag_value( p ) ) {
|
||||
case CONSTV:
|
||||
destroy_cons( f );
|
||||
break;
|
||||
case EXCEPTIONTV:
|
||||
destroy_exception( f );
|
||||
break;
|
||||
case KEYTV:
|
||||
case STRINGTV:
|
||||
case SYMBOLTV:
|
||||
destroy_string( f );
|
||||
break;
|
||||
case STACKTV:
|
||||
// destroy_stack_frame( f, nil );
|
||||
break;
|
||||
// TODO: others.
|
||||
}
|
||||
|
||||
dec_ref( f );
|
||||
return result;
|
||||
}
|
||||
17
src/c/memory/destroy.h
Normal file
17
src/c/memory/destroy.h
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
/**
|
||||
* memory/destroy.h
|
||||
*
|
||||
* Despatcher for destructor functions when objects are freed.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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
|
||||
322
src/c/memory/dump.c
Normal file
322
src/c/memory/dump.c
Normal file
|
|
@ -0,0 +1,322 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
|
||||
#include <stdint.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
/*
|
||||
* wide characters
|
||||
*/
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "io/fopen.h"
|
||||
#include "io/io.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 "ops/truth.h"
|
||||
#include "ops/truth.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: " );
|
||||
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 = 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
|
||||
// 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 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 "
|
||||
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;
|
||||
}
|
||||
17
src/c/memory/dump.h
Normal file
17
src/c/memory/dump.h
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
/**
|
||||
* memory/dump.h
|
||||
*
|
||||
* Dump objects to the error stream for.debuging purposes
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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( struct pso_pointer pointer );
|
||||
|
||||
|
||||
#endif /* SRC_C_MEMORY_DUMP_H_ */
|
||||
44
src/c/memory/header.h
Normal file
44
src/c/memory/header.h
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
/**
|
||||
* memory/header.h
|
||||
*
|
||||
* Header for all page space objects
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_header_h
|
||||
#define __psse_memory_header_h
|
||||
|
||||
#include <bits/stdint-uintn.h>
|
||||
|
||||
#include "memory/pointer.h"
|
||||
|
||||
#define TAGLENGTH 3
|
||||
|
||||
#define MAXREFERENCE 4294967295
|
||||
|
||||
/**
|
||||
* @brief Header for all paged space objects.
|
||||
*
|
||||
*/
|
||||
struct pso_header {
|
||||
union {
|
||||
/** the tag (type) of this object,
|
||||
* considered as bytes */
|
||||
struct {
|
||||
/** mnemonic for this type; */
|
||||
char mnemonic[TAGLENGTH];
|
||||
/** size class for this object */
|
||||
uint8_t size_class;
|
||||
} bytes;
|
||||
/** the tag considered as a number */
|
||||
uint32_t value;
|
||||
} tag;
|
||||
/** the count of the number of references to this object */
|
||||
uint32_t count;
|
||||
/** pointer to the access control list of this object */
|
||||
struct pso_pointer access;
|
||||
};
|
||||
|
||||
#endif
|
||||
145
src/c/memory/memory.c
Normal file
145
src/c/memory/memory.c
Normal file
|
|
@ -0,0 +1,145 @@
|
|||
/**
|
||||
* memory/memory.c
|
||||
*
|
||||
* The memory management subsystem.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <pthread.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#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 "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.
|
||||
*/
|
||||
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.
|
||||
*/
|
||||
bool memory_initialised = false;
|
||||
|
||||
|
||||
/**
|
||||
* @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 ) {
|
||||
struct pso_pointer result = nil;
|
||||
if ( memory_initialised ) {
|
||||
result =
|
||||
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;
|
||||
}
|
||||
#ifdef DEBUG
|
||||
debug_print( L"Memory initialised", DEBUG_BOOTSTRAP, 0 );
|
||||
#endif
|
||||
memory_initialised = true;
|
||||
}
|
||||
|
||||
return t;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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 ) {
|
||||
struct pso_pointer result = t;
|
||||
|
||||
if ( size_class <= MAX_SIZE_CLASS ) {
|
||||
if ( c_nilp( freelists[size_class] ) ) {
|
||||
result = allocate_page( size_class );
|
||||
}
|
||||
|
||||
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 ) && !c_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 ) {
|
||||
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"\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;
|
||||
}
|
||||
}
|
||||
} // 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] );
|
||||
}
|
||||
37
src/c/memory/memory.h
Normal file
37
src/c/memory/memory.h
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
/**
|
||||
* memory/memory.h
|
||||
*
|
||||
* The memory management subsystem.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_memory_h
|
||||
#define __psse_memory_memory_h
|
||||
#include <pthread.h>
|
||||
#include <stdbool.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
|
||||
|
||||
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[];
|
||||
extern bool memory_initialised;
|
||||
#endif
|
||||
101
src/c/memory/node.c
Normal file
101
src/c/memory/node.c
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <bits/stdint-uintn.h>
|
||||
|
||||
#include "environment/environment.h"
|
||||
|
||||
#include "io/io.h"
|
||||
|
||||
#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 "payloads/stack.h"
|
||||
#include "ops/string_ops.h"
|
||||
#include "ops/truth.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.
|
||||
*
|
||||
* 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;
|
||||
|
||||
/**
|
||||
* @brief The canonical `nil` pointer
|
||||
*
|
||||
*/
|
||||
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, 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.
|
||||
*/
|
||||
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 the environment created during initialisation.
|
||||
*/
|
||||
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;
|
||||
if ( initialise_io( ) == 0 ) {
|
||||
result = initialise_default_streams( base_of_stack, result );
|
||||
} else {
|
||||
result =
|
||||
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;
|
||||
}
|
||||
42
src/c/memory/node.h
Normal file
42
src/c/memory/node.h
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_node_h
|
||||
#define __psse_memory_node_h
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
|
||||
/**
|
||||
* @brief The index of this node in the hypercube.
|
||||
*
|
||||
*/
|
||||
extern uint32_t node_index;
|
||||
|
||||
extern bool node_initialised;
|
||||
|
||||
/**
|
||||
* @brief The canonical `nil` pointer
|
||||
*
|
||||
*/
|
||||
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 );
|
||||
|
||||
#endif
|
||||
371
src/c/memory/page.c
Normal file
371
src/c/memory/page.c
Normal file
|
|
@ -0,0 +1,371 @@
|
|||
/**
|
||||
* memory/page.c
|
||||
*
|
||||
* Page for paged space psoects.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <math.h>
|
||||
#include <string.h>
|
||||
#include <stdint.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include "debug.h"
|
||||
|
||||
#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"
|
||||
#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"
|
||||
#include "memory/tags.h"
|
||||
|
||||
#include "payloads/free.h"
|
||||
|
||||
#include "ops/truth.h"
|
||||
|
||||
/**
|
||||
* @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.
|
||||
*/
|
||||
union page *pages[NPAGES];
|
||||
|
||||
/**
|
||||
* @brief the number of pages which have thus far been allocated.
|
||||
*
|
||||
*/
|
||||
uint32_t npages_allocated = 0;
|
||||
|
||||
/**
|
||||
* Initialise arrays for objects of different size classes, in this case class 2.
|
||||
* 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 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-- ) {
|
||||
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 );
|
||||
object->payload.free.next = result;
|
||||
|
||||
result =
|
||||
make_pointer( node_index, page_index,
|
||||
( uint16_t ) ( i * obj_size ) );
|
||||
}
|
||||
|
||||
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 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];
|
||||
object->header.tag.bytes.size_class = size_class;
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 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];
|
||||
object->header.tag.bytes.size_class = size_class;
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 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];
|
||||
object->header.tag.bytes.size_class = size_class;
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 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];
|
||||
object->header.tag.bytes.size_class = size_class;
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 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];
|
||||
object->header.tag.bytes.size_class = size_class;
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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 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 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 );
|
||||
|
||||
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( ( c_nilp( result )
|
||||
&& ( page_index != 0 ) ) ? L"fail.\n" : L"success.\n",
|
||||
DEBUG_ALLOC, 0 );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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.
|
||||
*
|
||||
* @param size_class an integer in the range 0...MAX_SIZE_CLASS.
|
||||
* @return t on success, an exception if an error occurred.
|
||||
*/
|
||||
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++ ) {
|
||||
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 ) {
|
||||
void *pg = calloc( sizeof( union page ), 1 );
|
||||
|
||||
if ( pg != NULL ) {
|
||||
memset( pg, 0, sizeof( union page ) );
|
||||
pages[npages_allocated] = pg;
|
||||
debug_printf( DEBUG_ALLOC, 0,
|
||||
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] );
|
||||
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",
|
||||
npages_allocated, size_class,
|
||||
freelists[size_class].page,
|
||||
freelists[size_class].offset );
|
||||
|
||||
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 {
|
||||
// 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;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief allow other files to see the current value of npages_allocated, but not
|
||||
* change it.
|
||||
*/
|
||||
uint32_t get_pages_allocated( ) {
|
||||
return npages_allocated;
|
||||
}
|
||||
79
src/c/memory/page.h
Normal file
79
src/c/memory/page.h
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
/**
|
||||
* memory/page.h
|
||||
*
|
||||
* Page for paged space psoects.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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/pointer.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"
|
||||
|
||||
/**
|
||||
* 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 union page *pages[NPAGES];
|
||||
|
||||
/**
|
||||
* @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 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 allocate_page( uint8_t size_class );
|
||||
|
||||
uint32_t get_pages_allocated( );
|
||||
|
||||
#endif
|
||||
117
src/c/memory/pointer.c
Normal file
117
src/c/memory/pointer.c
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
/**
|
||||
* memory/node.h
|
||||
*
|
||||
* The node on which this instance resides.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
#include "memory/node.h"
|
||||
#include "memory/page.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, offset };
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief returns the in-memory address of the object indicated by this
|
||||
* 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 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 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];
|
||||
}
|
||||
}
|
||||
// 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;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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;
|
||||
}
|
||||
53
src/c/memory/pointer.h
Normal file
53
src/c/memory/pointer.h
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
/**
|
||||
* memory/pointer.h
|
||||
*
|
||||
* A pointer to a paged space object.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pointer_h
|
||||
#define __psse_memory_pointer_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
/**
|
||||
* @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;
|
||||
};
|
||||
|
||||
|
||||
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
|
||||
327
src/c/memory/pso.c
Normal file
327
src/c/memory/pso.c
Normal file
|
|
@ -0,0 +1,327 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <math.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <uchar.h>
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "debug.h"
|
||||
|
||||
#include "environment/privileged_keywords.h"
|
||||
|
||||
#include "memory/destroy.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 "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;
|
||||
|
||||
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
|
||||
|
||||
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.
|
||||
*
|
||||
* @param car
|
||||
* @param cdr
|
||||
*
|
||||
* return cons
|
||||
*/
|
||||
struct pso_pointer cheaty_make_cons( struct pso_pointer car,
|
||||
struct pso_pointer cdr ) {
|
||||
struct pso_pointer result = cheaty_allocate( nil, CONSTAG, 2 );
|
||||
struct pso2 *obj = pointer_to_object( result );
|
||||
|
||||
obj->payload.cons.car = car;
|
||||
obj->payload.cons.cdr = cdr;
|
||||
|
||||
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 );
|
||||
|
||||
// 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 );
|
||||
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`.
|
||||
*
|
||||
* 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 ) {
|
||||
if ( memory_initialised && c_nilp( frame_pointer ) ) {
|
||||
fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr );
|
||||
}
|
||||
|
||||
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;
|
||||
int hs = sizeof( struct pso_header ) / sizeof( uint64_t );
|
||||
int p = pow( 2, sc );
|
||||
|
||||
int result = abs( p - hs );
|
||||
|
||||
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 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
|
||||
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++;
|
||||
#ifdef DEBUG
|
||||
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] ) ),
|
||||
( 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;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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 ) {
|
||||
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 ( 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, "
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
return pointer;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief Prevent an object ever being dereferenced.
|
||||
*
|
||||
* @param pointer pointer to an object to lock.
|
||||
*
|
||||
* @return the `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 pointer ) {
|
||||
struct pso_pointer result = nil;
|
||||
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( 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++ ) {
|
||||
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, "
|
||||
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;
|
||||
}
|
||||
33
src/c/memory/pso.h
Normal file
33
src/c/memory/pso.h
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
/**
|
||||
* memory/pso.h
|
||||
*
|
||||
* Paged space objects.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso_h
|
||||
#define __psse_memory_pso_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#include "memory/header.h"
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso4.h"
|
||||
|
||||
struct pso_pointer allocate( struct pso_pointer frame_pointer, 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 free_object( struct pso_pointer p );
|
||||
|
||||
#ifdef DEBUG
|
||||
void print_allocation_table( );
|
||||
#endif
|
||||
#endif
|
||||
65
src/c/memory/pso2.h
Normal file
65
src/c/memory/pso2.h
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
/**
|
||||
* memory/pso2.h
|
||||
*
|
||||
* Paged space object of size class 2, four words total, two words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso2_h
|
||||
#define __psse_memory_pso2_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#include "payloads/psse_string.h"
|
||||
#include "memory/header.h"
|
||||
#include "payloads/character.h"
|
||||
#include "payloads/float.h"
|
||||
#include "payloads/free.h"
|
||||
#include "payloads/function.h"
|
||||
#include "payloads/integer.h"
|
||||
#include "payloads/lambda.h"
|
||||
#include "payloads/read_stream.h"
|
||||
#include "payloads/time.h"
|
||||
#include "payloads/vector_pointer.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
|
||||
* payload.
|
||||
*
|
||||
*/
|
||||
struct pso2 {
|
||||
struct pso_header header;
|
||||
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 float_payload real;
|
||||
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;
|
||||
};
|
||||
|
||||
#endif
|
||||
40
src/c/memory/pso3.h
Normal file
40
src/c/memory/pso3.h
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
/**
|
||||
* memory/pso3.h
|
||||
*
|
||||
* Paged space object of size class 3, 8 words total, 6 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso3_h
|
||||
#define __psse_memory_pso3_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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;
|
||||
};
|
||||
|
||||
#define pointer_to_pso3(p)((struct pso3*)pointer_to_object_of_size_class(p,3))
|
||||
|
||||
|
||||
#endif
|
||||
13
src/c/memory/pso4.c
Normal file
13
src/c/memory/pso4.c
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
/**
|
||||
* memory/pso4.c
|
||||
*
|
||||
* Paged space object of size class 4, 16 words total, 14 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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"
|
||||
38
src/c/memory/pso4.h
Normal file
38
src/c/memory/pso4.h
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
/**
|
||||
* memory/pso4.h
|
||||
*
|
||||
* Paged space object of size class 4, 16 words total, 14 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso4_h
|
||||
#define __psse_memory_pso4_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#include "memory/header.h"
|
||||
|
||||
#include "payloads/free.h"
|
||||
#include "payloads/stack_payload.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;
|
||||
};
|
||||
|
||||
// struct pso4 *pointer_to_pso4( struct pso_pointer p );
|
||||
#define pointer_to_pso4(p)((struct pso4*)pointer_to_object(p))
|
||||
|
||||
#endif
|
||||
32
src/c/memory/pso5.h
Normal file
32
src/c/memory/pso5.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/pso5.h
|
||||
*
|
||||
* Paged space object of size class 5, 32 words total, 30 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso5_h
|
||||
#define __psse_memory_pso5_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/pso6.h
Normal file
32
src/c/memory/pso6.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/pso6.h
|
||||
*
|
||||
* Paged space object of size class 6, 64 words total, 62 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso6_h
|
||||
#define __psse_memory_pso6_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/pso7.h
Normal file
32
src/c/memory/pso7.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/pso7.h
|
||||
*
|
||||
* Paged space object of size class 7, 128 words total, 126 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso7_h
|
||||
#define __psse_memory_pso7_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/pso8.h
Normal file
32
src/c/memory/pso8.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/pso8.h
|
||||
*
|
||||
* Paged space object of size class 8, 256 words total, 254 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso8_h
|
||||
#define __psse_memory_pso8_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/pso9.h
Normal file
32
src/c/memory/pso9.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/pso9.h
|
||||
*
|
||||
* Paged space object of size class 9, 512 words total, 510 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_pso9_h
|
||||
#define __psse_memory_pso9_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psoa.h
Normal file
32
src/c/memory/psoa.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psoa.h
|
||||
*
|
||||
* Paged space object of size class a, 1024 words total, 1022 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psoa_h
|
||||
#define __psse_memory_psoa_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psob.h
Normal file
32
src/c/memory/psob.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psob.h
|
||||
*
|
||||
* Paged space object of size class b, 2048 words total, 2046 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psob_h
|
||||
#define __psse_memory_psob_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psoc.h
Normal file
32
src/c/memory/psoc.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psoc.h
|
||||
*
|
||||
* Paged space object of size class c, 4096 words total, 4094 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psoc_h
|
||||
#define __psse_memory_psoc_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psod.h
Normal file
32
src/c/memory/psod.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psod.h
|
||||
*
|
||||
* Paged space object of size class d, 8192 words total, 8190 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psod_h
|
||||
#define __psse_memory_psod_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psoe.h
Normal file
32
src/c/memory/psoe.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psoe.h
|
||||
*
|
||||
* Paged space object of size class e, 16384 words total, 16382 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psoe_h
|
||||
#define __psse_memory_psoe_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
32
src/c/memory/psof.h
Normal file
32
src/c/memory/psof.h
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
/**
|
||||
* memory/psof.h
|
||||
*
|
||||
* Paged space object of size class f, 32768 words total, 32766 words payload.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_psof_h
|
||||
#define __psse_memory_psof_h
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
#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
|
||||
88
src/c/memory/tags.c
Normal file
88
src/c/memory/tags.c
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
#include <string.h>
|
||||
|
||||
#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 ) {
|
||||
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 result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @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 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( frame_pointer,
|
||||
( 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.
|
||||
*
|
||||
* @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 );
|
||||
}
|
||||
145
src/c/memory/tags.h
Normal file
145
src/c/memory/tags.h
Normal file
|
|
@ -0,0 +1,145 @@
|
|||
/**
|
||||
* memory/tags.h
|
||||
*
|
||||
* Tags for all page space and vector objects known to the bootstrap layer.
|
||||
*
|
||||
* All macros!
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_memory_tags_h
|
||||
#define __psse_memory_tags_h
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
|
||||
#define TAGLENGTH 3
|
||||
|
||||
#define CHARACTERTAG "CHR"
|
||||
#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 PACKSTRTAG "PST"
|
||||
#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 "TRL"
|
||||
#define VECTORTAG "VEC"
|
||||
#define VECTORPOINTTAG "VSP"
|
||||
#define WRITETAG "WRT"
|
||||
|
||||
#define CHARACTERTV 5392451
|
||||
#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 PACKSTRTV 5526352
|
||||
#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 5526103
|
||||
// 5526103
|
||||
/**
|
||||
* @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 );
|
||||
|
||||
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
|
||||
* 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 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))
|
||||
// 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))
|
||||
/** 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))
|
||||
#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
|
||||
// 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))
|
||||
|
||||
|
||||
#endif
|
||||
16
src/c/ops/README.md
Normal file
16
src/c/ops/README.md
Normal file
|
|
@ -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`.
|
||||
173
src/c/ops/assoc.c
Normal file
173
src/c/ops/assoc.c
Normal file
|
|
@ -0,0 +1,173 @@
|
|||
/**
|
||||
* ops/assoc.c
|
||||
*
|
||||
* Post Scarcity Software Environment: assoc.
|
||||
*
|
||||
* Search a store for the value associated with a key.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stdbool.h>
|
||||
|
||||
#include "debug.h"
|
||||
#include "memory/node.h"
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso2.h"
|
||||
#include "memory/tags.h"
|
||||
|
||||
#include "payloads/cons.h"
|
||||
#include "payloads/stack.h"
|
||||
|
||||
#include "ops/eq.h"
|
||||
#include "payloads/stack.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;
|
||||
|
||||
#ifdef DEBUG
|
||||
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 );
|
||||
#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, 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 );
|
||||
#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, 2 );
|
||||
#endif
|
||||
}
|
||||
#ifdef DEBUG
|
||||
debug_println( DEBUG_BIND );
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
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 c_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 c_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 c_internedp( struct pso_pointer key, struct pso_pointer store ) {
|
||||
return !c_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( 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 ) );
|
||||
|
||||
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 ) {
|
||||
#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 ) );
|
||||
|
||||
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 ) {
|
||||
#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 ) );
|
||||
|
||||
return c_internedp( key, store ) ? t : nil;
|
||||
}
|
||||
30
src/c/ops/assoc.h
Normal file
30
src/c/ops/assoc.h
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
/**
|
||||
* ops/assoc.h
|
||||
*
|
||||
* Post Scarcity Software Environment: assoc.
|
||||
*
|
||||
* Search a store for the value associated with a key.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_assoc_h
|
||||
#define __psse_ops_assoc_h
|
||||
|
||||
#include <stdbool.h>
|
||||
|
||||
#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 );
|
||||
|
||||
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 );
|
||||
|
||||
bool c_internedp( struct pso_pointer key, struct pso_pointer store );
|
||||
#endif
|
||||
37
src/c/ops/bind.c
Normal file
37
src/c/ops/bind.c
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* 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 "payloads/stack.h"
|
||||
|
||||
#include "payloads/cons.h"
|
||||
#include "payloads/function.h"
|
||||
#include "payloads/stack.h"
|
||||
|
||||
/**
|
||||
* (bind key value store)
|
||||
*/
|
||||
struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) {
|
||||
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 binding =
|
||||
cons( make_frame( 2, frame_pointer, key, value ) );
|
||||
|
||||
return cons( make_frame( 2, frame_pointer, binding, store ) );
|
||||
}
|
||||
22
src/c/ops/bind.h
Normal file
22
src/c/ops/bind.h
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
/**
|
||||
* ops/bind.h
|
||||
*
|
||||
* Post Scarcity Software Environment: bind.
|
||||
*
|
||||
* Bind a name to a value in a store.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_bind_h
|
||||
#define __psse_ops_bind_h
|
||||
#include <stdbool.h>
|
||||
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso4.h"
|
||||
|
||||
|
||||
struct pso_pointer lisp_bind( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
118
src/c/ops/cond.c
Normal file
118
src/c/ops/cond.c
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
|
||||
/**
|
||||
* @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/pso4.h"
|
||||
#include "memory/tags.h"
|
||||
|
||||
#include "ops/eval_apply.h"
|
||||
#include "ops/progn.h"
|
||||
#include "payloads/stack.h"
|
||||
#include "ops/string_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 . <value>)` 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 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 );
|
||||
#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 );
|
||||
|
||||
if ( !c_nilp( val ) ) {
|
||||
result =
|
||||
make_cons( frame_pointer, 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...)
|
||||
*
|
||||
* @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 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 );
|
||||
|
||||
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;
|
||||
}
|
||||
20
src/c/ops/cond.h
Normal file
20
src/c/ops/cond.h
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* 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
|
||||
150
src/c/ops/eq.c
Normal file
150
src/c/ops/eq.c
Normal file
|
|
@ -0,0 +1,150 @@
|
|||
/**
|
||||
* ops/eq.c
|
||||
*
|
||||
* Post Scarcity Software Environment: eq.
|
||||
*
|
||||
* Test for pointer equality; bootstrap level tests for object equality.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#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/function.h"
|
||||
#include "payloads/integer.h"
|
||||
#include "payloads/stack.h"
|
||||
#include "payloads/stack.h"
|
||||
#include "ops/truth.h"
|
||||
|
||||
/**
|
||||
* @brief Function; do these two pointers point to the same object?
|
||||
*
|
||||
* 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!
|
||||
*
|
||||
* @param a a pointer;
|
||||
* @param b another pointer;
|
||||
* @return `true` if they are the same, else `false`
|
||||
*/
|
||||
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 c_equal( struct pso_pointer a, struct pso_pointer b ) {
|
||||
bool result = false;
|
||||
|
||||
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 );
|
||||
|
||||
switch ( get_tag_value( a ) ) {
|
||||
case CHARACTERTV:
|
||||
result =
|
||||
( oa->payload.character.character ==
|
||||
ob->payload.character.character );
|
||||
break;
|
||||
case CONSTV:
|
||||
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
|
||||
== ob->payload.integer.value );
|
||||
break;
|
||||
case KEYTV:
|
||||
case STRINGTV:
|
||||
case SYMBOLTV:
|
||||
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 );
|
||||
b = c_cdr( b );
|
||||
} else {
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
}
|
||||
result = result && c_nilp( a ) && c_nilp( b );
|
||||
break;
|
||||
default:
|
||||
result = false;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* Function; do all arguments to this function point to the same object?
|
||||
*
|
||||
* Shallow, cheap equality.
|
||||
*
|
||||
* * (eq? args...)
|
||||
*
|
||||
* @return `t` if all args are pointers to the same object, else `nil`;
|
||||
*/
|
||||
struct pso_pointer eq(
|
||||
#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 result = t;
|
||||
|
||||
if ( frame->payload.stack_frame.args > 1 ) {
|
||||
for ( int b = 1;
|
||||
( c_truep( result ) ) && ( b < frame->payload.stack_frame.args );
|
||||
b++ ) {
|
||||
result =
|
||||
c_eq( fetch_arg( frame, 0 ), fetch_arg( frame, b ) ) ? t : nil;
|
||||
}
|
||||
}
|
||||
|
||||
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 arg2)
|
||||
*
|
||||
* @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 ) {
|
||||
#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;
|
||||
}
|
||||
38
src/c/ops/eq.h
Normal file
38
src/c/ops/eq.h
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
/**
|
||||
* ops/eq.h
|
||||
*
|
||||
* Post Scarcity Software Environment: eq.
|
||||
*
|
||||
* Test for pointer equality.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_eq_h
|
||||
#define __psse_ops_eq_h
|
||||
#include <stdbool.h>
|
||||
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso4.h"
|
||||
|
||||
#include "payloads/function.h"
|
||||
|
||||
bool c_eq( struct pso_pointer a, struct pso_pointer b );
|
||||
|
||||
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 equal(
|
||||
#ifndef MANAGED_POINTER_ONLY
|
||||
struct pso4 *frame,
|
||||
#endif
|
||||
struct pso_pointer frame_pointer );
|
||||
|
||||
|
||||
#endif
|
||||
976
src/c/ops/eval_apply.c
Normal file
976
src/c/ops/eval_apply.c
Normal file
|
|
@ -0,0 +1,976 @@
|
|||
/**
|
||||
* ops/eval_apply.c
|
||||
*
|
||||
* Post Scarcity Software Environment: eval and apply.
|
||||
*
|
||||
* apply: Apply a function to arguments in an environment.
|
||||
* eval: Evaluate a form in an environment.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#include "debug.h"
|
||||
|
||||
#include "environment/privileged_keywords.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"
|
||||
|
||||
#include "ops/assoc.h"
|
||||
#include "ops/bind.h"
|
||||
#include "ops/eval_apply.h"
|
||||
#include "ops/progn.h"
|
||||
#include "ops/reverse.h"
|
||||
#include "payloads/stack.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"
|
||||
#include "payloads/symbol.h"
|
||||
|
||||
/**
|
||||
* 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 );
|
||||
#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 );
|
||||
debug_dump_object( result, DEBUG_EVAL, 1 );
|
||||
|
||||
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 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;
|
||||
|
||||
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( frame_pointer, 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 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 ) ) );
|
||||
|
||||
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 =
|
||||
push_local( frame_pointer, make_frame_with_env( 1, 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] ) );
|
||||
result = push_local( frame_pointer, lisp_progn( 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 ) {
|
||||
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 );
|
||||
}
|
||||
}
|
||||
|
||||
debug_print( L"compose_body returning ", DEBUG_LAMBDA, 0 );
|
||||
debug_dump_object( body, DEBUG_LAMBDA, 0 );
|
||||
|
||||
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 ) {
|
||||
struct pso4 *frame = pointer_to_pso4( frame_pointer );
|
||||
return make_lambda( frame_pointer, fetch_arg( frame, 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 ) {
|
||||
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 new_env = fetch_env( frame_pointer );
|
||||
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 );
|
||||
#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 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 =
|
||||
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 {
|
||||
new_env = 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_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 =
|
||||
push_local( previous, c_reverse( previous, more ) );
|
||||
}
|
||||
|
||||
new_frame->payload.stack_frame.args = args;
|
||||
|
||||
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.
|
||||
* @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 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 =
|
||||
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 pso_pointer args = c_cdr( frame->payload.stack_frame.arg[0] );
|
||||
|
||||
switch ( get_tag_value( fn_pointer ) ) {
|
||||
case EXCEPTIONTV:
|
||||
/* just pass exceptions straight back */
|
||||
result = fn_pointer;
|
||||
break;
|
||||
|
||||
case FUNCTIONTV:
|
||||
{
|
||||
struct pso_pointer next_pointer =
|
||||
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 ) );
|
||||
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 LAMBDATV:
|
||||
{
|
||||
struct pso_pointer next_pointer =
|
||||
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( next_pointer );
|
||||
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, fn_pointer, args );
|
||||
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
struct pso4 *next = pointer_to_pso4( next_pointer );
|
||||
result = eval_lambda( next_pointer );
|
||||
dec_ref( next_pointer );
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case SPECIALTV:
|
||||
{
|
||||
struct pso_pointer next_pointer =
|
||||
make_special_frame( frame_pointer, fn_pointer, args );
|
||||
|
||||
if ( exceptionp( next_pointer ) ) {
|
||||
result = next_pointer;
|
||||
} else {
|
||||
result = maybe_fixup_exception_location( ( *
|
||||
( 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 );
|
||||
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 %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( frame_pointer, buffer );
|
||||
free( buffer );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol
|
||||
( frame_pointer, L"apply" ), message,
|
||||
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;
|
||||
}
|
||||
|
||||
/**
|
||||
* Function; evaluate the expression which is the first argument in the frame;
|
||||
* further arguments are ignored.
|
||||
*
|
||||
* * (eval expression)
|
||||
*
|
||||
* @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 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 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;
|
||||
|
||||
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 ) ) {
|
||||
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] );
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_symbol
|
||||
( frame_pointer, 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:
|
||||
// we've already done this...
|
||||
break;
|
||||
}
|
||||
|
||||
debug_print( L"Eval 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];
|
||||
}
|
||||
|
||||
/**
|
||||
* 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;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* Function: get the Lisp type of the single argument.
|
||||
*
|
||||
* * (type expression)
|
||||
*
|
||||
* @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 ) );
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* 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 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 ) ) ) {
|
||||
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( 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 = 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 );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief construct and return a list of arbitrarily many arguments.
|
||||
*
|
||||
* (list args...)
|
||||
*
|
||||
* @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 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 = make_cons( frame_pointer, 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 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 );
|
||||
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( next_pointer );
|
||||
|
||||
// debug_print_binding( symbol, val, false, DEBUG_BIND );
|
||||
|
||||
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" ),
|
||||
frame_pointer );
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
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;
|
||||
|
||||
}
|
||||
|
||||
/**
|
||||
* @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 = true;
|
||||
struct pso_pointer result = frame->payload.stack_frame.more;
|
||||
|
||||
for ( int a = 0;
|
||||
accumulator == true && 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;
|
||||
}
|
||||
26
src/c/ops/eval_apply.h
Normal file
26
src/c/ops/eval_apply.h
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* 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 lisp_apply( struct pso_pointer frame_pointer );
|
||||
|
||||
|
||||
struct pso_pointer lisp_eval( struct pso_pointer frame_pointer );
|
||||
|
||||
|
||||
#endif
|
||||
54
src/c/ops/inspect.c
Normal file
54
src/c/ops/inspect.c
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
/**
|
||||
* inspect.c
|
||||
*
|
||||
* Post Scarcity Soctware Environment
|
||||
*
|
||||
* Display the contents of an object; later, in explorable form.
|
||||
*
|
||||
* Copyright (c): 25 Apr 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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/inspect.h"
|
||||
#include "payloads/stack.h"
|
||||
|
||||
/**
|
||||
* Function: dump/
|
||||
*
|
||||
* * (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;
|
||||
|
||||
dump_object( frame_pointer, fetch_arg( frame, 1 ), fetch_arg( frame, 0 ) );
|
||||
|
||||
debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 );
|
||||
|
||||
return result;
|
||||
}
|
||||
25
src/c/ops/inspect.h
Normal file
25
src/c/ops/inspect.h
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
/**
|
||||
* inspect.h
|
||||
*
|
||||
* Post Scarcity Soctware Environment
|
||||
*
|
||||
* Display the contents of an object; later, in explorable form.
|
||||
*
|
||||
* Copyright (c): 25 Apr 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_inspect_h
|
||||
#define __psse_ops_inspect_h
|
||||
|
||||
#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
|
||||
51
src/c/ops/keys.c
Normal file
51
src/c/ops/keys.c
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
/**
|
||||
* 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 <simon@journeyman.cc>
|
||||
* 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 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 = make_cons( frame_pointer, 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( frame_pointer,
|
||||
pointer_to_pso4( frame_pointer )->payload.stack_frame.
|
||||
arg[0] );
|
||||
}
|
||||
19
src/c/ops/keys.h
Normal file
19
src/c/ops/keys.h
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_keys_h
|
||||
#define __psse_ops_keys_h
|
||||
|
||||
struct pso_pointer c_keys( struct pso_pointer store );
|
||||
|
||||
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
35
src/c/ops/list_ops.c
Normal file
35
src/c/ops/list_ops.c
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
/**
|
||||
* ops/list_ops.c
|
||||
*
|
||||
* Post Scarcity Software Environment: list_ops.
|
||||
*
|
||||
* Operations on cons cells.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso2.h"
|
||||
#include "memory/pso4.h"
|
||||
|
||||
#include "payloads/stack.h"
|
||||
|
||||
#include "payloads/cons.h"
|
||||
#include "payloads/integer.h"
|
||||
#include "payloads/stack.h"
|
||||
|
||||
#include "ops/truth.h"
|
||||
|
||||
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 c = 0;
|
||||
|
||||
for ( struct pso_pointer cursor = list; !c_nilp( cursor );
|
||||
cursor = c_cdr( cursor ) ) {
|
||||
c++;
|
||||
}
|
||||
|
||||
return acquire_integer( frame_pointer, c );
|
||||
}
|
||||
22
src/c/ops/list_ops.h
Normal file
22
src/c/ops/list_ops.h
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
/**
|
||||
* ops/list_ops.h
|
||||
*
|
||||
* Post Scarcity Software Environment: list_ops.
|
||||
*
|
||||
* Operations on cons cells.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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"
|
||||
|
||||
#include "payloads/function.h"
|
||||
|
||||
struct pso_pointer count( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
74
src/c/ops/mapcar.c
Normal file
74
src/c/ops/mapcar.c
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
/**
|
||||
* ops/mapcar.c
|
||||
*
|
||||
* Post Scarcity Software Environment: mapcar.
|
||||
*
|
||||
* map a function across a sequence of forms.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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 "payloads/stack.h"
|
||||
#include "ops/truth.h"
|
||||
|
||||
#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 );
|
||||
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 ) ) );
|
||||
|
||||
debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i );
|
||||
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 ) ) );
|
||||
|
||||
if ( exceptionp( r ) ) {
|
||||
result = r;
|
||||
break;
|
||||
} else {
|
||||
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 );
|
||||
}
|
||||
|
||||
result = consp( result ) ? c_reverse( frame_pointer, result ) : result;
|
||||
|
||||
debug_print( L"Mapcar returning: ", DEBUG_EVAL, 0 );
|
||||
debug_print_object( result, DEBUG_EVAL, 0 );
|
||||
debug_println( DEBUG_EVAL );
|
||||
|
||||
return result;
|
||||
}
|
||||
17
src/c/ops/mapcar.h
Normal file
17
src/c/ops/mapcar.h
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
/**
|
||||
* ops/mapcar.h
|
||||
*
|
||||
* Post Scarcity Software Environment: mapcar.
|
||||
*
|
||||
* map a function across a sequence of forms.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#ifndef __psse_ops_mapcar_h
|
||||
#define __psse_ops_mapcar_h
|
||||
|
||||
struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer );
|
||||
|
||||
#endif
|
||||
84
src/c/ops/progn.c
Normal file
84
src/c/ops/progn.c
Normal file
|
|
@ -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 <simon@journeyman.cc>
|
||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||
*/
|
||||
|
||||
#include <stdbool.h>
|
||||
|
||||
#include "memory/node.h"
|
||||
#include "memory/pointer.h"
|
||||
#include "memory/pso4.h"
|
||||
#include "memory/tags.h"
|
||||
|
||||
#include "ops/eval_apply.h"
|
||||
#include "payloads/stack.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,
|
||||
fetch_env( frame_pointer ) );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
24
src/c/ops/progn.h
Normal file
24
src/c/ops/progn.h
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
/**
|
||||
* ops/progn.c
|
||||
*
|
||||
* Post Scarcity Software Environment: progn.
|
||||
*
|
||||
* Evaluate a sequence of expressions and return the value of the last.
|
||||
*
|
||||
* (c) 2026 Simon Brooke <simon@journeyman.cc>
|
||||
* 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
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue