Compare commits

..

80 commits

Author SHA1 Message Date
6f39dae75f Tactical commit only. Something is badly broken in read, although I think
this version is better thwan the last one.
2026-05-07 21:07:16 +01:00
d1bfb029b8 Work on ensuring new objects are clean, but not sure it's successful.
Also, start on setting up the read ACL on new objects.
2026-05-07 06:47:58 +01:00
6b89779bab Substantial work on read-list, not yet fully working. 2026-05-06 23:42:25 +01:00
80049f2272 Ran a 'make format', because !'m close to being able to merge this feature. 2026-05-06 16:45:56 +01:00
5e64a33965 Major step forward: equal is now working, and consequently so is assoc. 2026-05-06 16:42:18 +01:00
271b7da46a Right, I have finally undone the issue #18 change. It was a nice idea,
but I have not made it work.
2026-05-06 15:32:35 +01:00
c29a95b00d Got dump working, to try to investigate the assoc bug. Much better
dump output, but `assoc` still doesn't work for read symbols, and
we now have a segfault on exit.
2026-05-06 12:23:46 +01:00
cf655e8020 Investigating why symbols created by read are not equal to those created in C. 2026-05-06 09:16:46 +01:00
1cfd333e26 Merge branch 'feature/reengineering-17-21' of ssh://git.journeyman.cc:4022/simon/post-scarcity into feature/reengineering-17-21 2026-05-05 19:37:02 +01:00
818293d4f1 Moved everything from ops/stack_ops (which were not ops) to payloads/stack.
Added io functions to function_bindings.
2026-05-05 19:16:44 +01:00
4d480798e8 Tactical commit: things in 'stack_ops' really didn't belong in ops; moving. 2026-05-05 17:21:16 +01:00
f895a8e359 Added an end of the day not to state of play 2026-05-04 21:26:36 +01:00
d2efc8ba78 Now happy with what's appearing in the oblist. Reader is very broken. 2026-05-04 19:26:09 +01:00
5ec1c926b0 And, of course, I'd forgotten to add the files for quote. 2026-05-04 18:24:38 +01:00
fcfdb43b05 I *think* that's all the bootstrap functions being bound in the environment. 2026-05-04 18:23:46 +01:00
efa6a3246d Started work on binding functions. Not yet complete. 2026-05-04 16:15:57 +01:00
f4303247b9 Added files which were missed by the last commit. 2026-05-04 13:15:30 +01:00
8c5dccb5c8 My monster, she builds! 2026-05-04 10:34:07 +01:00
92490ebd5f Still grinding incrementally forward, through barbed wire entanglements.
Morale fading.
2026-05-03 17:26:53 +01:00
ab0ea09bd4 Still still doesn't compile. Progress is being made, but it's fair awfy slow. 2026-05-03 14:17:31 +01:00
aac4669a3d Still doesn't compile, but I think excellent progress. 2026-04-28 11:54:15 +01:00
dbeb99759a Merge branch 'feature/reengineering-17-21' of ssh://git.journeyman.cc:4022/simon/post-scarcity into feature/reengineering-17-21 2026-04-26 09:44:59 +01:00
aff1430762 Brought dump in from 0.0.6. This may be a mistake and I may reverse it. 2026-04-26 09:44:09 +01:00
f7eabb9b62 Working on eval/apply. Unfinished, does not build. More significantly,
as the focus ot this prototype is supposed to be building things in
Lisp,
I've started deliberately copying stuff that mostly works directly from
the 0.0.6 branch into this branch. After all, if it's going to be
replaced in Lisp, it doesn't have to be the most elegant C.
2026-04-25 21:52:05 +01:00
63906fe817 Print is less badly broken. Read is less badly broken. GC is too aggressive. 2026-04-24 21:20:23 +01:00
22b0160a26 Builds and runs, but print is badly broken. Need some rethink. 2026-04-24 09:22:06 +01:00
9425506e2a OK, garbage collection is now working a little bit. 2026-04-23 17:34:07 +01:00
235d455b80 More memory debugging, but what it shows is that deallocation is not happening. 2026-04-23 14:45:51 +01:00
dd4176e20b Not much progess. Priority has to be in fixing debug_printf. 2026-04-23 12:29:10 +01:00
aa0d60bbed It compiles. It runs. Nothing works, but it also doesn't crash. Victory! 2026-04-23 11:50:30 +01:00
8d2acbeb0f Still making progress. Dropped the archive because it was causing problems. 2026-04-22 21:09:15 +01:00
eed4711fee Another inconclusive session: still nothing works, still making progress. 2026-04-22 18:16:00 +01:00
ef59563e25 Still in progress. Nothing workds. 2026-04-21 14:43:09 +01:00
aa5b34368e Modified make_cons and make_frame to illustrate the pattern I
want to apply generally. This does not compile!
2026-04-20 23:21:30 +01:00
6148d3699f Right, I'm committing this session because I'm too cold and tired to go on.
It does not at present build (and it's going to take a good bit more work
before it does).
2026-04-20 18:29:28 +01:00
f05d1af9d6 Successfully added mutexes protecting freelist access. No behaviour change. 2026-04-20 13:59:47 +01:00
c59825d7fe Closes #18. Change to char32_t everywhere; builds fine, behaviour as before. 2026-04-20 12:10:38 +01:00
812a1be7d9 Work on simplifying the Doxygen CSS; which was entirely a side project. 2026-04-20 10:12:55 +01:00
d952623266 Preparing for the great documentation reskinning! 2026-04-19 16:28:50 +01:00
521c5d2285 Work on customising Doxygen output. 2026-04-19 13:32:00 +01:00
0e8712a076 Further work on print; still not working properly. 2026-04-18 17:20:19 +01:00
9a0f186f29 Things working much better now. assoc works. Currently printing of
string-like-things does not work, but I suspect that's shallow.
2026-04-18 15:44:14 +01:00
02a4bc3e28 Hot damn! When you see an obvious, stupid bug you created, you can't unsee it! 2026-04-18 11:02:35 +01:00
ca5671f613 String-like-things are being created and printed correctly; bind is broken. 2026-04-17 18:40:32 +01:00
cf05e30540 Well, we have a REPL. It blows up horribly, but we have one. 2026-04-17 14:20:31 +01:00
4efe9eab87 Very close to a basic REPL now. 2026-04-16 22:32:02 +01:00
83537391a6 Written the constructor for exceptions; in the process, added a
metadata slot as a first class slot of exceptions.
2026-04-16 21:33:48 +01:00
f915a9993f Fixed assigning arguments to slots in the frame; also fixed a bug in bind...
But did that by switching away from using Lisp calling convention, because
that broke horribly. This is bad news and must be sorted out.
2026-04-16 17:13:20 +01:00
cb3dcb352e OK, the problem is that make_frame fails to put the arguments into the frame.
I do not (yet) know why not, but that is the problem.
2026-04-16 12:34:47 +01:00
ba985474f6 Initialisation almost succeeds. nil and t are successfully instantiated.
We then go into a mess of exceptions which trigger exceptions until we run out
of allocatable memory, but all those exceptions and stack frames are correctly
allocated and torn down again afterwards, so.... sort of good?
2026-04-16 11:39:01 +01:00
04aa32bd5a Whoops! several new files missed from recent commits. 2026-04-16 00:24:03 +01:00
25c87aac6e Added debug messages to initialisation functions, but getting a segfault.
Not going to debug that tonight!
2026-04-16 00:22:24 +01:00
f751fc8a09 More code, closer to working, still builds. 2026-04-15 22:47:44 +01:00
c9f50572ab Many more ops written, and it compiles. Nothing works yet. 2026-04-15 19:50:10 +01:00
b5a2e09763 Things that are self-evaluating can self-evaluate. 2026-04-13 14:52:05 +01:00
f5f8e38b91 Added a note on things to read for the compiler. 2026-04-03 11:14:39 +01:00
b6480aebd5 Converted everything to the new lisp calling convention.
Fixes #19
2026-04-01 17:11:10 +01:00
f3a26bc02e Added bind; but mainly, tactical commit before changinh lisp calling
convention
2026-04-01 16:35:06 +01:00
9eb0d3c5a0 I think read will now read integers and symbols, but it's untested.
Everything compiles.
2026-04-01 16:06:16 +01:00
cc8e96eda4 Further small changes on the way to a reader. 2026-04-01 08:50:35 +01:00
a302663b32 Well, I really made a mess with the last commit; this one sorts it out. 2026-03-31 20:09:37 +01:00
1196b3eb1d read isn't written yet, but I think all the building blocks I need for it are.
Compiles and runs; does nothing yet.
2026-03-31 20:01:01 +01:00
364d7d2c7b Compiles again, now with bootstrap-layer print implemented, but not yet tested.
To get print implemented, I also had to implement a lot of other things.
2026-03-31 15:05:44 +01:00
2b22780ccf This once again does NOT compile. I've done work on macros; they don't work yet.. 2026-03-30 21:49:08 +01:00
e3f922a8bf Added character as a first class object. Stepped through a run; it all works. 2026-03-30 13:29:26 +01:00
a8b4a6e69d My monster, it not only compiles, it now runs! 2026-03-30 11:52:41 +01:00
60921be3d4 Much more progress, still doesn't compile. 2026-03-30 09:35:34 +01:00
1ce9fbda77 Still not fixed... 2026-03-29 17:25:08 +01:00
04bf001652 Progress, but it still doesn't build. I think I'm close, now... 2026-03-29 12:03:31 +01:00
00997d3c90 Down to to compilation errors. Had to reinstate individual size-class headers. 2026-03-29 11:07:30 +01:00
cae27731b7 Huge amount of work. Does not even nearly compile, but it's nearer. 2026-03-28 23:46:14 +00:00
1afb1b9fad Added work on making namespaces threadsafe. 2026-03-28 11:56:36 +00:00
154cda8da3 Added a 'state of play' update; changed the strapline in Home.md 2026-03-26 09:20:41 +00:00
57c5fe314a Things which should have been saved before the last commit. Sigh. 2026-03-26 09:03:27 +00:00
6c4be8f283 Lots more code written, and I think most of it's OK; but it doesn't compile yet. 2026-03-26 09:01:46 +00:00
604fca3c24 Got most of the new memory architecture roughed out. 2026-03-25 11:24:33 +00:00
19d6b0df29 Firming up the roadmap for the 0.1.X prototype 2026-03-24 16:53:54 +00:00
914c35ead0 Moved legacy code into archive, ready for a new rapid(?) prototype.
I may regret doing this!
2026-03-24 16:25:09 +00:00
09051a3e63 Added an essay on the design of paged space objects; started experimenting in Zig. 2026-03-23 18:47:00 +00:00
99d4794f3b Upversioned the C source tree to '0.0.7-SNAPSHOT', but proposing to start experimental
work towards 0.1.0 in separate source trees.
2026-03-19 13:59:06 +00:00
207 changed files with 11788 additions and 12523 deletions

7
.clangd Normal file
View 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]

2
.gitignore vendored
View file

@ -55,5 +55,7 @@ post-scarcity.kdev4
\.zig-cache/
sq/
tmp/
utils_src/a.out
doxyresources/header.html

View file

@ -48,7 +48,7 @@ PROJECT_NAME = "Post Scarcity"
# could be handy for archiving the generated documentation or if some version
# control system is used.
PROJECT_NUMBER = 0.0.6
PROJECT_NUMBER = 0.1.0
# Using the PROJECT_BRIEF tag one can provide an optional one line description
# for a project that appears at the top of each page and should give viewer a
@ -931,7 +931,7 @@ WARN_LINE_FORMAT = "at line $line of file $file"
# specified the warning and error messages are written to standard output
# (stdout).
WARN_LOGFILE = doxy.log
WARN_LOGFILE = tmp/doxy.log
#---------------------------------------------------------------------------
# Configuration options related to the input files
@ -943,7 +943,7 @@ WARN_LOGFILE = doxy.log
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched.
INPUT = src \
INPUT = src/c \
docs \
lisp
@ -1336,7 +1336,7 @@ HTML_FOOTER =
# obsolete.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_STYLESHEET =
HTML_STYLESHEET = doxyresources/customdoxygen.css
# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# cascading style sheets that are included after the standard style sheets
@ -1377,7 +1377,7 @@ HTML_EXTRA_FILES =
# The default value is: AUTO_LIGHT.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_COLORSTYLE = AUTO_DARK
HTML_COLORSTYLE = AUTO_LIGHT
# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen
# will adjust the colors in the style sheet and background images according to

View file

@ -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)

190
README.md
View file

@ -1,190 +0,0 @@
# Post Scarcity Software Environment: general documentation
Work towards the implementation of a software system for the hardware of the deep future.
## Note on canonicity
*Originally most of this documentation was on a wiki attached to the [GitHub project](https://github.com/simon-brooke/post-scarcity); when that was transferred to [my own foregejo instance](https://git.journeyman.cc/simon/post-scarcity) the wiki was copied. However, it's more convenient to keep documentation in the project with the source files, and version controlled in the same Git repository. So while both wikis still exist, they should no longer be considered canonical. The canonical version is in `/docs`, and is incorporated by [Doxygen](https://www.doxygen.nl/) into the generated documentation — which is generated into `/doc` using the command `make doc`.*
## State of Play
You can read about the current [state of play](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_state-of-play.html).
## Roadmap
There is now a [roadmap](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_roadmap.html) for the project.
## AWFUL WARNING 1
This does not work. It isn't likely to work any time soon. If you want to learn Lisp, don't start here; try Clojure, Scheme or Common Lisp (in which case I recommend Steel Bank Common Lisp). If you want to learn how Lisp works, still don't start here. This isn't ever going to be anything like a conventional Lisp environment.
What it sets out to be is a Lisp-like system which:
* Can make use (albeit not, at least at first, very efficiently) of machines with at least [Zettabytes](http://highscalability.com/blog/2012/9/11/how-big-is-a-petabyte-exabyte-zettabyte-or-a-yottabyte.html) of RAM;
* Can make reasonable use of machines with at least billions of processors;
* Can concurrently support significant numbers of users, all doing different things, without them ever interfering with one another;
* Can ensure that users cannot escalate privilege;
* Can ensure users private data remains private.
When Linus Torvalds sat down in his bedroom to write Linux, he had something usable in only a few months. BUT:
* Linus was young, energetic, and extremely talented; I am none of those things.
* Linus was trying to build a clone of something which already existed and was known to work. Nothing like what I'm aiming for exists.
* Linus was able to adopt the GNU user space stack. There is no user space stack for this idea; I don't even know what one would look like.
## AWFUL WARNING 2
This project is necessarily experimental and exploratory. I write code, it reveals new problems, I think about them, and I mutate the design. This documentation does not always keep up with the developing source code.
## Building
The substrate of this version is written in plain old fashioned C and built with a Makefile. I regret this decision; I think either Zig or Rust would have been better places to start; but neither of them were sufficiently well developed to support what I wanted to do when I did start.
To build, you need a C compiler; I use GCC, others may work. You need a make utility; I use GNU Make. You need [libcurl](https://curl.se/libcurl/).
With these dependencies in place, clone the repository from [here](https://git.journeyman.cc/simon/post-scarcity/), and run `make` in the resulting project directory. If all goes well you will find and executable, `psse`, in the target directory.
This has been developed on Debian but probably builds on any 64 bit UN*X; however I do **not** guarantee this.
### Make targets
#### default
The default `make` target will produce an executable as `target/psse`.
#### clean
`make clean` will remove all compilation detritus; it will also remove temporary files.
#### doc
`make doc` will generate documentation in the `doc` directory. Depends on `doxygen` being present on your system.
#### format
`make format` will standardise the formay of C code. Depends on the GNU `indent` program being present on your system.
#### REPL
`make repl` will start a read-eval-print loop. `*log*` is directed to `tmp/psse.log`.
#### test
`make test` will run all unit tests.
## In use
What works just now is a not very good, not very efficient Lisp interpreter which does not conform to any existing Lisp standard. You can start a REPL, and you can write and evaluate functions. You can't yet save or load your functions. It's interesting mainly because of its architecture, and where it's intended to go, rather than where it is now.
### Documentation
There is [documentation](https://www.journeyman.cc/post-scarcity/doc/html/).
### Invoking
The binary is canonically named `psse`. When invoking the system, the following invocation arguments may be passed:
```
-d Dump memory to standard out at end of run (copious!);
-h Print this message and exit;
-p Show a prompt (default is no prompt);
-s LIMIT
Set a limit to the depth the stack can extend to;
-v LEVEL
Set verbosity to the specified level (0...1024)
Where bits are interpreted as follows:
1 ALLOC;
2 ARITH;
4 BIND;
8 BOOTSTRAP;
16 EVAL;
32 INPUT/OUTPUT;
64 LAMBDA;
128 REPL;
256 STACK;
512 EQUAL.
```
Note that any verbosity level produces a great deal of output, and although standardising the output to make it more legible is something I'm continually working on, it's still hard to read the output. It is printed to stderr, so can be redirected to a file for later analysis, which is the best plan.
### Functions and symbols
The following functions are provided as of release 0.0.6:
| Symbol | Type | Documentation |
| ------ | ---- | ------------- |
| `*` | FUNC | `(* args...)` Multiplies these `args`, all of which should be numbers, and return the product. |
| `*in*` | READ | The standard input stream. |
| `*log*` | WRIT | The standard logging stream (stderr). |
| `*out*` | WRIT | The standard output stream. |
| + | FUNC | `(+ args...)`: If `args` are all numbers, returns the sum of those numbers. |
| - | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
| / | FUNC | `(/ a b)`: Divides `a` by `b` and returns the result. Expects both arguments to be numbers. |
| = | FUNC | `(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`. |
| absolute | FUNC | `(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`. |
| add | FUNC | `(+ args...)`: If `args` are all numbers, return the sum of those numbers. |
| and | FUNC | `(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`. |
| append | FUNC | `(append args...)`: If `args` are all sequences, return the concatenation of those sequences. |
| apply | FUNC | `(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value. |
| assoc | FUNC | `(assoc key store)`: Return the value associated with this `key` in this `store`. |
| car | FUNC | `(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence. |
| cdr | FUNC | `(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed. |
| close | FUNC | `(close stream)`: If `stream` is a stream, close that stream. |
| cond | SPFM | `(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated. |
| cons | FUNC | `(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`. |
| count | FUNC | `(count s)`: Return the number of items in the sequence `s`. |
| divide | FUNC | `(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`. |
| eq? | FUNC | `(eq? args...)`: Return `t` if all args are the exact same object, else `nil`. |
| equal? | FUNC | `(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`. |
| eval | FUNC | `(eval form)`: Evaluates `form` and returns the result. |
| exception | FUNC | `(exception message)`: Return (throw) an exception with this `message`. |
| get-hash | FUNC | `(get-hash arg)`: Returns the natural number hash value of `arg`. This is the default hash function used by hashmaps and namespaces, but obviously others can be supplied. |
| hashmap | FUNC | `(hashmap n-buckets hashfn store write-acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`, and protected by the write access control list `write-acl`. All arguments are optional. The intended difference between a namespace and a hashmap is that a namespace has a write acl and a hashmap doesn't (is not writable), but currently (0.0.6) this functionality is not yet written. |
| inspect | FUNC | `(inspect object ouput-stream)`: Print details of this `object` to this `output-stream`, or `*out*` if no `output-stream` is specified. |
| keys | FUNC | `(keys store)`: Return a list of all keys in this `store`. |
| lambda | SPFM | `(lambda arg-list forms...)`: Construct an interpretable λ funtion. |
| let | SPFM | `(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last. |
| list | FUNC | `(list args...)`: Return a list of these `args`. |
| mapcar | FUNC | `(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results. |
| meta | FUNC | `(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`. |
| metadata | FUNC | `(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`. |
| multiply | FUNC | `(multiply args...)` Multiply these `args`, all of which should be numbers, and return the product. |
| negative? | FUNC | `(negative? n)`: Return `t` if `n` is a negative number, else `nil`. |
| nlambda | SPFM | `(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated. |
| not | FUNC | `(not arg)`: Return `t` only if `arg` is `nil`, else `nil`. |
| nλ | SPFM | `(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated. |
| oblist | FUNC | `(oblist)`: Return the current top-level symbol bindings, as a map. |
| open | FUNC | `(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading. |
| or | FUNC | `(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`. |
| print | FUNC | `(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`. |
| progn | SPFM | `(progn forms...)`: Evaluate these `forms` sequentially, and return the value of the last. |
| put! | FUNC | `(put! store key value)`: Stores a value in a namespace; currently (0.0.6), also stores a value in a hashmap, but in future if the `store` is a hashmap then `put!` will return a clone of that hashmap with this `key value` pair added. Expects `store` to be a hashmap or namespace; `key` to be a symbol or a keyword; `value` to be any value. |
| put-all! | FUNC | `(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`. At present (0.0.6) it does this for hashmaps as well, but in future if `dest` is a hashmap or a namespace which the user does not have permission to write, will return a copy of `dest` with all the key-value pairs from `source` added. `dest` must be a hashmap or a namespace; `source` may be either of those or an association list. |
| quote | SPFM | `(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`. |
| ratio->real | FUNC | `(ratio->real r)`: If `r` is a rational number, return the real number equivalent. |
| read | FUNC | `(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
| read-char | FUNC | `(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
| repl | FUNC | `(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional. If `prompt` is present, it will be used as the prompt. If `input` is present and is a readable stream, takes input from that stream. If `output` is present and is a writable stream, prints output to that stream. |
| reverse | FUNC | `(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order. |
| set | FUNC | `(set symbol value namespace)`: Binds the value `symbol` in the specified `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. |
| set! | SPFM | `(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. |
| slurp | FUNC | `(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string. |
| source | FUNC | `(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil. Once we get a compiler working, will also return the source code of compiled functions and special forms. |
| subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
| throw | FUNC | `(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).|
| time | FUNC | `(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch. |
| try | SPFM | `(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these. |
| type | FUNC | `(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change. |
| λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ function. |
## Known bugs
The following bugs are known in 0.0.6:
1. bignum arithmetic does not work (returns wrong answers, does not throw exception);
2. subtraction of ratios is broken (returns wrong answers, does not throw exception);
3. equality of hashmaps is broken (returns wrong answers, does not throw exception);
4. The garbage collector doesn't work at all well.
There are certainly very many unknown bugs.

1
README.md Symbolic link
View file

@ -0,0 +1 @@
docs/Home.md

View file

@ -29,26 +29,9 @@ get a very small Lisp working well sooner, and build new features in that.
In 0.1.X the substrate will be much less feature rich, but support the creation
of novel types of data object in Lisp.
## Sysin and sysout are urgent
If a significant proportion of the system is written in Lisp, it must be
possible to save a working Lisp image to file and recover it.
## Compiler is urgent
I still don't know how to write a compiler, and writing a compiler will still
be a major challenge. But I am now much closer to knowing how to write a
compiler than I was. I think it's important to have a compiler, both for
performance and for security. Given that we do not have a separate execute ACL,
if a user can execute an interpreted function, they can also read its source.
Generally this is a good thing. For things low down in the stack, it may not
be.
## Paged Space Objects
Paged space objects will be implemented largely in line with
[this document](Paged-space-objects.md).
Paged space objects will be implemented largely in line with [this document](Paged-space-objects.md).
## Tags
@ -79,9 +62,7 @@ encoding is as in this table:
| 1110 | 14 | E | 16384 | 131072 |
| 1111 | 15 | F | 32768 | 262144 |
Consequently, an object of size class F will have an allocation size of 32,768
words, but a payload size of 32,766 words. This obviously means that size
classes 0 and 1 will not exist, since they would not have any payload.
Consequently, an object of size class F will have an allocation size of 32,768 words, but a payload size of 32,766 words. This obviously means that size classes 0 and 1 will not exist, since they would not have any payload.
## Page size
@ -89,32 +70,20 @@ Every page will be 1,048,576 bytes.
## Namespaces
Namespaces will be implemented; in addition to the root namespace, there will
be at least the following namespaces:
Namespaces will be implemented; in addition to the root namespace, there will be at least the following namespaces:
### :bootstrap
Functions written in the substrate language, intended to be replaced for all
normal purposes by functions written in Lisp which may call these bootstrap
functions. Not ever available to user code.
Functions written in the substrate language, intended to be replaced for all normal purposes by functions written in Lisp which may call these bootstrap functions. Not ever available to user code.
### :substrate
Functions written in the substrate language which *may* be available to
user-written code.
Functions written in the substrate language which *may* be available to user-written code.
### :system
Functions, written either in Lisp or in the substrate language, which modify
system memory in ways that only trusted and privileged users are permitted to
do.
Functions, written either in Lisp or in the substrate language, which modify system memory in ways that only trusted and privileged users are permitted to do.
## Access control
Obviously, for this to work, access control lists must be implemented and must
work.
## Router is deferred to 0.2.X
This generation is about producing a better single thread Lisp (but hopefully
to build it fast); the hypercube topology is deferred.
Obviously, for this to work, access control lists must be implemented and must work.

View file

@ -1,37 +0,0 @@
# Change log
## Version 0.0.6
The **MY MONSTER, SHE LIVES** release. But also, the *pretend the problems aren't there* release.
You can hack on this. It mostly doesn't blow up. Bignum arithmetic is broken, but doesn't either segfault or go into non-terminating guru meditations. A lot of garbage isn't getting collected and probably in a long session you will run out of memory, but I haven't yet really characterised how bad this problem is. Subtraction of rationals is broken, which is probably a shallow bug. Map equality is broken, which is also probably fixable.
### There is no hypercube
The hypercube router is not yet written. That is the next major milestone, although it will be for a simulated hypercube running on a single conventional UN*X machine rather than for an actual hardware hypercube.
### There is no compiler
No compiler has been written. That's partly because I don't really know how to write a computer, but it's also because I don't yet know what processor architecture the compiler needs to target.
### There's not much user interface
The user interface is just a very basic REPL. You can't currently even persist your session. You can't edit the input line. You can't save or load files. There is no editor and no debugger. There's certainly no graphics. Exit the REPL by typing [ctrl]-D.
### So what is there?
However, there is a basic Lisp environment in which you can write and evaluate functions. It's not as good as any fully developed Lisp, you won't want to use this for anything at all yet except just experimenting with it and perhaps hacking on it.
### Unit tests known to fail at this release
Broadly, all the bignum unit tests fail. There are major problems in the bignum subsystem, which I'm ashamed of but I'm stuck on, and rather than bashing my head on a problem on which I was making no progress I've decided to leave that for now and concentrate on other things.
Apart from the bignum tests, the following unit tests fail:
| Test | Comment |
| ---- | ------- |
| unit-tests/equal.sh: maps... Fail: expected 't', got 'nil' | Maps in which the same keys have the same values should be equal. Currently they're not. This is a bug. It will be fixed |
| unit-tests/memory.sh => Fail: expected '7106', got '54' | Memory which should be being recovered currently isn't, and this is a major issue. It may mean my garbage collection strategy is fundamentally flawed and may have to be replaced. |
| unit-tests/subtract.sh: (- 4/5 5)... Fail: expected '-3/5', got '3/5' | Subtraction of rational numbers is failing. This is a bug. It will be fixed. |
There are probably many other bugs. If you find them, please report them [here]()

108
docs/Compiler.md Normal file
View 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.

View file

@ -0,0 +1,71 @@
# Don't know, don't care
![The famous XKCD cartoon showing all modern digital infrastructure depending on a single person's spare-time project](https://imgs.xkcd.com/comics/dependency.png)
One of the key design principles of the Post Scarcity computing project since my 2006 essay, [Post Scarcity Software](Post-scarcity-software.md), has been "don't know, don't care."
The reason for this is simple. Modern computing systems are extremely complex. It is impossible for someone to be expert on every component of the system. To produce excellent work, it is necessary to specialise, to avoid being distracted by the necessary intricacies of the things on which your work depends, or of the (not yet conceived) intricacies of the work of other people which will ultimately depend on yours. It is necessary to trust.
Randal Munroe's graphic which I've used to illustrate this essay looks like a joke, but it isn't.
[Daniel Stenberg](https://en.wikipedia.org/wiki/Daniel_Stenberg) lives not in Nebraska, but in Sweden. He wrote what became [libcurl](https://curl.se/) in 1996, not 2003. He is still its primary maintainer. It pretty much is true to say that all modern digital infrastructure depends on it. It is a basic component which fetches data over a broad range of internet protocols, negotiating the appropriate security. There *are* alternatives to libcurl in (some) other software environments, but it is extremely widely used. Because it deals with security, it is critical; any vulnerability in it needs to be fixed quickly, because it has very major impact.
The current [post-scarcity software environment](https://git.journeyman.cc/simon/post-scarcity) depends on libcurl, because of course it does. You certainly use libcurl yourself, even if you don't know it. You probably used it to fetch this document, in order to read it.
I don't need to know the intricacies of URL schemae, or of Internet protocols, or of security, to the level of detail Daniel does. I've never even reviewed his code. I trust him to know what he's doing.
Daniel's not alone, of course. Linus Torvalds wrote Linux in a university dorm room in Finland; now it powers the vast majority of servers on the Internet, and the vast majority of mobile phones in the world, and, quite incidentally, a cheap Chinese camera drone I bought to film bike rides. Linux is now an enormous project with thousands of contributors, but Linus is still the person who holds it together. [Rasmus Lerdorf](https://en.wikipedia.org/wiki/Rasmus_Lerdorf), from Greenland, wrote PHP to run his personal home page (the clue is in the name); Mark Zuckerberg used PHP to write Facebook; Michel Valdrighi used PHP to write something called b/cafelog, which Matt Mullenweg further developed into WordPress.
There are thousands of others, of course; and, at the layer of hardware, on which all software depends, there are thousands of others whose names I do not even know. I'm vaguely aware of the architects of the ARM chip, but I had to look them up just now because I couldn't remember their names. I know that the ARM is at least a spiritual descendant of the 6502, but I don't know who designed that or anything of their story; and the antecedents behind that I don't know at all. The people behind all the many other chips which make up a working computer? I know nothing about them.
(In any case, if one seriously wanted to build this thing, it would be better to have custom hardware — one would probably have to have custom hardware at least for the router — and if one were to have custom hardware it would be nice if it ran something very close to Lisp right down on the silicon, as the [Symbolics Ivory](https://gwern.net/doc/cs/hardware/1987-baker.pdf) chips did; so you probably wouldn't use ARM cores at all.)
I have met and personally spoken with most of the people behind the Internet protocol stack, but I don't need to have done so in order to use it; and, indeed, the reason that [Jon Postel](https://en.wikipedia.org/wiki/Jon_Postel) bought me a beer was so that he could sit me down and very gently explain how badly I'd misunderstood something.
-----
But this is the point. We don't need to know, or have known, these people to build on their work. We don't have to, and cannot in detail, fully understand their work. There is simply too much of it, its complexity would overwhelm us.
We don't know. We don't care. And that is a protective mechanism, a mechanism which is necessary in order to allow us to focus on our own task, if we are to produce excellent work. If we are to create a meaningful contribution on which the creators of the future can build.
-----
But there is a paradox, here, one of many conceptual paradoxes that I have encountered working on the Post Scarcity project.
I am essentially a philosopher, or possibly a dilettante, rather than an engineer. When [Danny Hillis](https://longnow.org/people/board/danny0/) came up with the conception of the [Connection Machine](), a machine which is consciously one of the precursors of the post-scarcity project, he sought expert collaborators — and was so successful in doing so that [he persuaded Richard Feynman to join the project](https://longnow.org/ideas/richard-feynman-and-the-connection-machine/). I haven't recruited any collaborators. I don't have the social skills. And I don't have sufficient confidence that my idea is even good in itself.
In building the first software prototype, I realised that I don't even properly understand what it means to [intern](http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/fun_intern.html) something. I realised that I still don't understand how in many Common Lisp implementations, for any integer number `n`, `(eq n n)` can return true. I note that in practice it *does*, but I don't understand how it's done.
In the current post scarcity prototype, it *is* true for very small values of `n`, because I cache an array of small positive integers as an optimisation hack to prevent memory churn, but that's very special case and I cannot believe that Common Lisp implementations are doing it for significantly larger numbers of integers. I note that in SBCL, two bignums of equal value are not `eq`, so presumably SBCL is doing some sort of hack similar to mine, but I do not know how it works and I *shouldn't* care.
Platonically, two instances of the same number *should be* the same object; but we do not live in a Platonic world and I don't want to. I'm perfectly happy that `eq` (which should perhaps be renamed `identical?`) should not work for numbers.
What the behaviour is of the functions that we use, at whatever layer in the stack we work, does matter. We do need to know that. But what happens under the surface in order to deliver that behaviour? We don't need to know. We don't need to care. And we shouldn't, because that way leads to runaway recursion: behind every component, there is another component, which makes other compromises with physical matter which make good engineering sense to the people who understand that component well enough to design and to maintain it.
The stack is not of infinite depth, of course. At its base is silicon, and traces of metals on silicon, and the behaviour of electrons as they interact with individual atoms in those traces. That is knowable, in principle, by someone. But there are sufficiently many layers in the stack, and sufficient complexity in each layer, that to have a good, clear, understanding of every layer is beyond the mental capacity of anyone I know, and, I believe, is generally beyond the mental capacity of any single person.
-----
But this is the point. The point is I do need to know, and do need to care, if I am to complete this project on my own; and I don't have sufficient faith in the utility of the project (or my ability to communicate that utility) that I believe that anyone else will ever care enough to contribute to it.
And I don't have the skills, or the energy, or, indeed, the remaining time, to build any of it excellently. If it is to be built, I need collaborators; but I don't have the social skills to attract collaborators, or probably to work with them; and, actually, if I did have expert collaborators there would probably be no place for me in the project, because I don't have excellence at anything.
-----
I realise that I don't even really understand what a hypercube is. I describe my architecture as a hypercube. It is a cube because it has three axes, even though each of those axes is conceptually circular. Because the axes are circular, the thing can only be approximated in three dimensional space by using links of flexible wire or glass fibres to join things which, in three dimensional topology, cannot otherwise be joined; it is therefore slightly more than three dimensional while being considerably less than four dimensional.
I *think* this is also Hillis' understanding of a hypercube, but I could be wrong on that.
Of course, my architecture could be generalised to have four, or five, or six, or more circular axes
[^1]: Could it? I'm reasonably confident that it could have *six* circular axes, but I cannot picture in my head how the grid intersections of a four-and-a-bit dimensional grid would work.
, and this would result in each node having more immediate neighbours, which would potentially speed up computation by shortening hop paths. But I cannot help feeling that with each additional axis there comes a very substantial increase in the complexity of physically routing the wires, so three-and-a-bit dimensions may be as good as you practically get.
I don't have the mathematical skill to mentally model how a computation would scale through this structure. It's more an 'if I build it I will find out whether this is computationally efficient' than an 'I have a principled idea of why this should be computationally efficient.' Intuitively, it *should be* more efficient than a [von Neumann architecture](https://en.wikipedia.org/wiki/Von_Neumann_architecture), and it's easy to give an account of how it can address (much) more memory than obvious developments of our current architectures. But I don't have a good feel of the actual time cost of copying data hoppity-hop across the structure, or the heuristics of when it will be beneficial to shard a computation between neighbours.
-----
Which brings me back to why I'm doing this. I'm doing it, principally, to quiet the noises in my brain; as an exercise in preventing my propensity for psychiatric melt-down from overwhelming me. It isn't, essentially, well-directed engineering. It is, essentially, self-prescribed therapy. There is no reason why anyone else should be interested.
Which is, actually, rather solipsistic. Not a thought I like!

View file

@ -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

View 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 (exGCU), 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,,
,,,,
,,,,
,,,,
,,,,
,,,,
1 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.
2 Culture GSV Determinist System The largest GSV class built by the Culture, composed of multiple separate hulls. Population 6 billion.
3 Culture GSV Eschatologist (temporary name) Ocean A comparatively small GSV class, designed for combat and military manufacturing.
4 Culture GSV Irregular Apocalypse
5 Culture GSV No More Mr Nice Guy
6 Culture LSV Profit Margin
7 Culture GCU Nervous Energy Mountain
8 Culture GCU Prosthetic Conscience
9 Culture ROU Revisionist Killer
10 Culture ROU Trade Surplus Killer
11 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.
12 Idiran Light Cruiser The Hand of God 137
13 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.
14 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.
15 Culture GSV Cargo Cult
16 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).
17
18 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.
19 Culture GSV So Much For Subtlety Range
20 Culture GSV Unfortunate Conflict Of Evidence
21 Culture GSV Youthful Indiscretion
22 Culture GCU Flexible Demeanour
23 Culture GCU Just Read The Instructions Elon Musk named three SpaceX autonomous spaceport drone ships after these ships.
24 Culture GCU Of Course I Still Love You
25 Culture (D)ROU Zealot
26 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]
27 Culture LOU Gunboat Diplomat An allusion to the concept of gunboat diplomacy.
28 Culture Superlifter Kiss My Ass River
29 Culture Superlifter Prime Mover An allusion to the Aristotelian philosophical concept of the prime mover, in humorous reference to the function of a Superlifter.
30 Culture Clipper Screw Loose
31 Azadian Battlecruiser Invincible Flagship of the Empire of Azad.
32 Culture GSV Bad For Business
33 Culture GCU Ablation*
34 Culture GCU Arbitrary Escarpment The only ship actually appearing in the book, and one of its main settings.
35 (middle series)
36 Culture GCU Arrested Development*
37 Culture GCU A Series Of Unlikely Explanations
38 Culture GCU A Ship With A View*
39 Culture GCU Big Sexy Beast
40 Culture GCU Boo!
41 Culture GCU Cantankerous
42 Culture GCU Credibility Problem*
43 Culture GCU Dramatic Exit*
44 Culture GCU Excuses And Accusations*
45 Culture GCU Funny, It Worked Last Time...
46 Culture GCU God Told Me To Do It*
47 Culture GCU Halation Effect*
48 Culture GCU Happy Idiot Talk*
49 Culture GCU Helpless In The Face Of Your Beauty*
50 Culture GCU Heresiarch*
51 Culture GCU I Thought He Was With You
52 Culture GCU It'll Be Over By Christmas
53 Culture GCU Just Another Victim Of The Ambient Morality*
54 Culture GCU Minority Report*
55 Culture GCU Never Talk To Strangers
56 Culture GCU Not Wanted On Voyage*
57 Culture GCU Only Slightly Bent
58 Culture GCU Perfidy*
59 Culture GCU Sacrificial Victim*
60 Culture GCU Space Monster
61 Culture GCU Stranger Here Myself*
62 Culture GCU Synchronize Your Dogmas*
63 Culture GCU Thank You And Goodnight*
64 Culture GCU The Precise Nature Of The Catastrophe*
65 Culture GCU Ultimate Ship The Second
66 Culture GCU Undesirable Alien*
67 Culture GCU Unwitting Accomplice*
68 Culture GCU Well I Was In The Neighbourhood*
69 Culture GCU You'll Thank Me Later*
70 Culture GCU You Would If You Really Loved Me*
71 Culture GSV Congenital Optimist
72 Culture GSV Size Isn't Everything Length of over 80 kilometers. Parent ship of the Sweet and Full of Grace.
73 Culture GSV What Are The Civilian Applications? Continent Limited edition Prompt subclass. Can outrun a Very Fast Picket.
74 Culture GCU Just Testing
75 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.
76 Culture GCU Very Little Gravitas Indeed Part of the "... Gravitas ..." running gag.[7]
77 Culture VFP/(D)ROU Xenophobe Torturer
78 Culture GSV Anticipation Of A New Lover's Arrival, The Plate
79 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).
80 Culture GSV Ethics Gradient Range Parent ship of the Fate Amenable To Change. References ethical relativism, where no moral position is absolute.
81 Culture GSV Honest Mistake Parent ship of the Grey Area.
82 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.
83 Culture GSV Uninvited Guest
84 Culture GSV Use Psychology
85 Culture GSV What Is The Answer And Why?
86 Culture GSV Wisdom Like Silence Continent Controlled by three Minds.
87 Culture GSV Yawning Angel Range Top speed, 146,000 × light-speed.
88 Culture GSV Zero Gravitas Part of the "... Gravitas ..." running gag.[7]
89 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.
90 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.
91 Culture LSV Serious Callers Only Tundra
92 Culture GCV Steely Glint Plains Parent ship of the Attitude Adjuster.
93 Culture GCU Different Tan Mountain
94 Culture GCU Fate Amenable To Change Escarpment Child ship of the Ethics Gradient.
95 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.
96 Culture GCU It's Character Forming
97 Culture GCU Jaundiced Outlook Ridge Child ship of the Sleeper Service.
98 Culture GCU Problem Child Troubadour Early (vs Excession-contemporary) GCU, historical mention. Nominally captained by Zreyn Tramow.
99 Culture GCU Reasonable Excuse
100 Culture GCU Recent Convert
101 Culture GCU Tactical Grace Escarpment
102 Culture GCU Unacceptable Behaviour Child ship of the Quietly Confident (Sleeper Service).
103 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).
104 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.
105 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.
106 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.
107 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.
108 Culture OU T3OU 118 Type Three
109 Culture OU T3OU 736 Type Three
110 Culture Superlifter Charitable View Cliff Top sprint speed, 221,000 × light-speed (faster than contemporary ROUs).
111 Culture Cruise Ship Just Passing Through
112 Culture I Blame My Mother
113 Culture I Blame Your Mother
114 Culture Convertcraft Main Battle Unit Full Refund (formerly MBU 604) Empire Former Homomdan MBU, now Culture Convertcraft
115 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.
116 later Sleeper Service
117 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.
118 Culture Ulterior Highpoint Possibly not a ship (described only as an "Ulterior Entity").
119 Culture Ulterior (AhForgetIt Tendency), Eccentric Shoot Them Later
120 Culture Ulterior (Zetetic Elench) Explorer Ship Appeal To Reason Part of the Stargazer Clan.
121 Culture Ulterior (Zetetic Elench) Explorer Ship Break Even
122 Culture Ulterior (Zetetic Elench) Explorer Ship Long View
123 Culture Ulterior (Zetetic Elench) Explorer Ship Peace Makes Plenty
124 Culture Ulterior (Zetetic Elench) Explorer Ship Sober Counsel
125 Culture Ulterior (Zetetic Elench) Explorer Ship Within Reason
126 Affront Frightspear
127 Affront Light Cruiser Furious Purpose Meteorite
128 Affront Kiss The Blade
129 Affront Riptalon
130 Affront SacSlicer II
131 Affront Wingclipper
132 Affront Battleship Xenoclast
133 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.
134 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.
135 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.
136 Culture GSV Lasting Damage II The ship incorporating the backup copy Mind of the Lasting Damage.
137 Culture GSV Sanctioned Parts List
138 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.
139 Culture ROU Nuisance Value Torturer
140 Culture VFP/(D)ROU Resistance Is Character-Forming Gangster
141 Culture Superlifter Vulgarian
142 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.
143 Culture Lacking That Small Match Temperament†
144 Culture GCU Poke It With A Stick†
145 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."
146 Culture Hand Me The Gun And Ask Me Again†
147 Culture But Who's Counting?† LOU Me, I'm Counting provides the answer.
148 Culture Germane Riposte†
149 Culture We Haven't Met But You're A Great Fan Of Mine†
150 Culture All The Same, I Saw It First†
151 Culture Ravished By The Sheer Implausibility Of That Last Statement†
152 Culture Zero Credibility†
153 Culture Charming But Irrational†
154 Culture Demented But Determined†
155 Culture You May Not Be The Coolest Person Here†
156 Culture Lucid Nonsense†
157 Culture Awkward Customer†
158 Culture Thorough But... Unreliable†
159 Culture Advanced Case Of Chronic Patheticism†
160 Culture Another Fine Product From The Nonsense Factory†
161 Culture Conventional Wisdom†
162 Culture In One Ear† Part of the expression "in one ear and out the other".
163 Culture Fine Till You Came Along†
164 Culture I Blame The Parents†
165 Culture Inappropriate Response†
166 Culture A Momentary Lapse Of Sanity†
167 Culture Lapsed Pacifist†
168 Culture Reformed Nice Guy†
169 Culture Pride Comes Before A Fall†
170 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).
171 Culture Now Look What You've Made Me Do†
172 Culture Kiss This Then†
173 Chelgrian Privateer Winter Storm
174 Chelgrian Temple ship Piety
175 Chelgrian Temple ship Soulhaven
176 Culture GSV Seed Drill Ocean
177 Culture MSV Don't Try This At Home Steppe
178 Culture LSV Xenoglossicist Air
179 Culture GCV Subtle Shift In Emphasis Plains
180 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.
181 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.
182 Culture GCU Lightly Seared On The Reality Grill
183 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".
184 Culture GCU Qualifier Trench
185 Culture GCU Transient Atmospheric Phenomenon Transient Atmospheric Phenomenon has been suggested as an alternative name for a UFO
186 Culture GCU You Naughty Monsters
187 Culture FP/(D)GOU Eight Rounds Rapid Delinquent
188 Culture VFP/(D)ROU You'll Clean That Up Before You Leave Gangster
189 Culture Now We Try It My Way Erratic An ancient ship, originally an Interstellar-class ship of the now-obsolete General Transport Craft type.
190 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]
191
192 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."
193 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.
194 Morthanveld Cat.4 CleaveHull “On First Seeing Jhiriit” This ship is not mentioned in the story itself, only in the book's appendix.
195 Morthanveld Cat.5 SwellHull “Fasilyce, Upon Waking”
196 Morthanveld Great Ship Inspiral, Coalescence, Ringdown Comparable to a GSV; the name refers to stages in the merger of two black holes.
197 Nariscene Star Cruiser Hence the Fortress Comet
198 Nariscene Hundredth Idiot, The White Dwarf Name derived from a Nariscene proverb.
199 Culture GSV Dressed Up To Party
200 Culture GSV Pelagian Equator
201 Culture GSV Sense Amid Madness, Wit Amidst Folly Plate
202 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.
203 Culture GCU Armchair Traveller Mountain
204 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.
205 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.
206 Culture FP/(D)GOU No One Knows What The Dead Think Formerly known as the GOU Obliterating Angel.
207 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.
208 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).
209 Culture Beastly To The Animals
210 Culture Fixed Grin
211 Culture Hidden Income Type not mentioned in novel, but possibly General Transport Craft (see Matter).[why?]
212 Culture Scar Glamour
213 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".
214 Culture Ulterior, Eccentric FP/(D)LOU Me, I'm Counting Hooligan Another ship in the Culture is called But Who's Counting?.
215 GFCF Contact Craft Messenger Of Truth Succour
216 GFCF Minor Destructor Vessel Fractious Person
217 GFCF Minor Destructor Vessel Rubric Of Ruin
218 GFCF Abundance Of Onslaught Deepest Regrets Deepest Regrets-class ships are capital ships and the pride of the GFCF fleet.
219 GFCF Vision Of Hope Surpassed Deepest Regrets
220 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.
221 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.
222 Nauptre Reliquaria Bismuth Category 8401.00 Partial Photic Boundary
223 Culture GSV A Fine Disregard For Awkward Facts
224 Culture GSV Contents May Differ Atmosphere
225 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.
226 Culture GSV Just The Washing Instruction Chip In Life's Rich Tapestry
227 Culture GSV Kakistocrat Home GSV of Mistake Not… "Kakistocrat" is Ancient Greek, meaning "worst ruler", a humorous inversion of "aristocrat".
228 Culture GSV Teething Problems
229 Culture GSV Unreliable Witness Parent ship of the Smile Tolerantly.
230 Culture MSV Passing By And Thought I'd Drop In Desert
231 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]
232 Culture LSV You Call This Clean? Blue
233 Culture GCU Displacement Activity River Class name previously used for a Superlifter class in The Player of Games.
234 Culture GCU Warm, Considering Delta
235 Culture LCU Anything Legal Considered Ridge Class possibly downgraded from GCU (designated as such in Excession, set five centuries earlier).
236 Culture LCU Beats Working Scree The smallest class of Contact Unit: 80m long, with a human crew of five.
237 Culture GOU Headcrash Delinquent
238 Culture GOU Questionable Ethics
239 Culture GOU Xenocrat Delinquent
240 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".
241 Culture LOU New Toy
242 Culture VFP/(D)LOU Rapid Random Response Unit Troublemaker
243 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."
244 Culture VFP/(D)ROU Outstanding Contribution To The Historical Process Psychopath Twice referred to as “Ex-Psychopath-class”[10]
245 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.
246 Culture FP/(D)ROU Value Judgement Thug See above.
247 Culture Superlifter Zoologist Boulder
248 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.
249 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.
250 Gzilt IR-HAS cruiser 5*Gelish-Oplule Indefinite Range, High Acceleration/Speed
251 Gzilt IR-HVW battlecruiser 7*Uagren Indefinite Range, High Velocity/Weapon-load
252 Gzilt IR-FWS battleship 8*Churkun Indefinite Range, Full Weapon Spectrum
253 Iwenick Space-Capable Inter-Element Transportation Component Iberre Private yacht, named after the owner's father-mother.
254 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).
255 Liseiden Collective Purposes Vessel Abalule-Sheliz
256 Liseiden Collective Purposes Vessel Gellemtyan-Asool-Anafawaya (First Class) Flagship
257 Liseiden Collective Purposes Vessel Laskuil-Hliz
258 Liseiden Collective Purposes Vessel Quiatrea-Anang
259 Liseiden Fulanya-Guang
260 Ronte Melancholia Enshrines All Triumph Interstitial/Exploratory
261 Zihdren-Remnanter Adjunct Entity Oceanic Dissonance
262 Zihdren-Remnanter Ceremonial Representative Carrying Ship Exaltation-Parsimony III
263
264
265
266
267

View 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.

View 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.

View file

@ -1,5 +1,491 @@
# 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 &mdash; or at least, ceased to be actively developed &mdash; 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/) &mdash; 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 &mdash; of course you can! &mdash; 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 &mdash; I like [seergdb](https://github.com/epasveer/seer) &mdash; 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 &mdash; 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 &mdash; 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 &mdash; my brain really is fucked &mdash; 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 &mdash; 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 &mdash; 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 &mdash; and the `0.1.0` design doctrine that I should only code in C things which are absolutely necessary to bootstrap the Lisp compiler &mdash; 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 &mdash; 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 &mdash; 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
* &lambda;
* 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

268
docs/shipnames.md Normal file
View 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

View file

@ -2,161 +2,161 @@
html {
/* page base colors */
--page-background-color: black;
--page-foreground-color: #C9D1D9;
--page-link-color: #90A5CE;
--page-visited-link-color: #A3B4D7;
--page-background-color: #ffffff;
--page-foreground-color: #000000;
--page-link-color: #204080;
--page-visited-link-color: #4060a0;
/* index */
--index-odd-item-bg-color: #0B101A;
--index-even-item-bg-color: black;
--index-header-color: #C4CFE5;
--index-separator-color: #334975;
--index-odd-item-bg-color: #e0e0e0;
--index-even-item-bg-color: #ffffff;
--index-header-color: #000000;
--index-separator-color: #a0a0a0;
/* header */
--header-background-color: #070B11;
--header-separator-color: #141C2E;
--header-gradient-image: url('nav_hd.png');
--group-header-separator-color: #283A5D;
--group-header-color: #90A5CE;
--inherit-header-color: #A0A0A0;
--header-background-color: #e0e0e0;
--header-separator-color: #c0c0e0;
--header-gradient-image: url('nav_h.png');
--group-header-separator-color: #8080c0;
--group-header-color: #204060;
--inherit-header-color: #808080;
--footer-foreground-color: #5B7AB7;
--footer-logo-width: 60px;
--citation-label-color: #90A5CE;
--glow-color: cyan;
--footer-foreground-color: #202060;
--footer-logo-width: 104px;
--citation-label-color: #204060;
--glow-color: #00ffff;
--title-background-color: #090D16;
--title-separator-color: #354C79;
--directory-separator-color: #283A5D;
--separator-color: #283A5D;
--title-background-color: #ffffff;
--title-separator-color: #4060a0;
--directory-separator-color: #80a0c0;
--separator-color: #4060a0;
--blockquote-background-color: #101826;
--blockquote-border-color: #283A5D;
--blockquote-background-color: #e0e0e0;
--blockquote-border-color: #80a0c0;
--scrollbar-thumb-color: #283A5D;
--scrollbar-background-color: #070B11;
--scrollbar-thumb-color: #80a0c0;
--scrollbar-background-color: #e0e0e0;
--icon-background-color: #334975;
--icon-foreground-color: #C4CFE5;
--icon-doc-image: url('docd.svg');
--icon-folder-open-image: url('folderopend.svg');
--icon-folder-closed-image: url('folderclosedd.svg');
--icon-background-color: #6080c0;
--icon-foreground-color: #ffffff;
--icon-doc-image: url('doc.svg');
--icon-folder-open-image: url('folderopen.svg');
--icon-folder-closed-image: url('folderclosed.svg');
/* brief member declaration list */
--memdecl-background-color: #0B101A;
--memdecl-separator-color: #2C3F65;
--memdecl-foreground-color: #BBB;
--memdecl-template-color: #7C95C6;
--memdecl-background-color: #e0e0e0;
--memdecl-separator-color: #c0e0e0;
--memdecl-foreground-color: #555;
--memdecl-template-color: #4060a0;
/* detailed member list */
--memdef-border-color: #233250;
--memdef-title-background-color: #1B2840;
--memdef-title-gradient-image: url('nav_fd.png');
--memdef-proto-background-color: #19243A;
--memdef-proto-text-color: #9DB0D4;
--memdef-proto-text-shadow: 0px 1px 1px rgba(0, 0, 0, 0.9);
--memdef-doc-background-color: black;
--memdef-param-name-color: #D28757;
--memdef-template-color: #7C95C6;
--memdef-border-color: #a0a0c0;
--memdef-title-background-color: #e0e0e0;
--memdef-title-gradient-image: url('nav_f.png');
--memdef-proto-background-color: #c0e0e0;
--memdef-proto-text-color: #202040;
--memdef-proto-text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9);
--memdef-doc-background-color: #ffffff;
--memdef-param-name-color: #602020;
--memdef-template-color: #4060a0;
/* tables */
--table-cell-border-color: #283A5D;
--table-header-background-color: #283A5D;
--table-header-foreground-color: #C4CFE5;
--table-cell-border-color: #204060;
--table-header-background-color: #204060;
--table-header-foreground-color: #e0e0e0;
/* labels */
--label-background-color: #354C7B;
--label-left-top-border-color: #4665A2;
--label-right-bottom-border-color: #283A5D;
--label-foreground-color: #CCCCCC;
--label-background-color: #6080c0;
--label-left-top-border-color: #4060a0;
--label-right-bottom-border-color: #c0c0e0;
--label-foreground-color: #ffffff;
/** navigation bar/tree/menu */
--nav-background-color: #101826;
--nav-foreground-color: #364D7C;
--nav-gradient-image: url('tab_bd.png');
--nav-gradient-hover-image: url('tab_hd.png');
--nav-gradient-active-image: url('tab_ad.png');
--nav-gradient-active-image-parent: url("../tab_ad.png");
--nav-separator-image: url('tab_sd.png');
--nav-breadcrumb-image: url('bc_sd.png');
--nav-breadcrumb-border-color: #2A3D61;
--nav-splitbar-image: url('splitbard.png');
--nav-background-color: #e0e0e0;
--nav-foreground-color: #204060;
--nav-gradient-image: url('tab_b.png');
--nav-gradient-hover-image: url('tab_h.png');
--nav-gradient-active-image: url('tab_a.png');
--nav-gradient-active-image-parent: url("../tab_a.png");
--nav-separator-image: url('tab_s.png');
--nav-breadcrumb-image: url('bc_s.png');
--nav-breadcrumb-border-color: #c0c0e0;
--nav-splitbar-image: url('splitbar.png');
--nav-font-size-level1: 13px;
--nav-font-size-level2: 10px;
--nav-font-size-level3: 9px;
--nav-text-normal-color: #B6C4DF;
--nav-text-hover-color: #DCE2EF;
--nav-text-active-color: #DCE2EF;
--nav-text-normal-shadow: 0px 1px 1px black;
--nav-text-normal-color: #202040;
--nav-text-hover-color: #ffffff;
--nav-text-active-color: #ffffff;
--nav-text-normal-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9);
--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0);
--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0);
--nav-menu-button-color: #B6C4DF;
--nav-menu-background-color: #05070C;
--nav-menu-foreground-color: #BBBBBB;
--nav-menu-toggle-color: rgba(255, 255, 255, 0.2);
--nav-arrow-color: #334975;
--nav-arrow-selected-color: #90A5CE;
--nav-menu-button-color: #204060;
--nav-menu-background-color: #ffffff;
--nav-menu-foreground-color: #404040;
--nav-menu-toggle-color: rgba(255, 255, 255, 0.5);
--nav-arrow-color: #80a0c0;
--nav-arrow-selected-color: #80a0c0;
/* table of contents */
--toc-background-color: #151E30;
--toc-border-color: #202E4A;
--toc-header-color: #A3B4D7;
--toc-down-arrow-image: url("data:image/svg+xml;utf8,<svg xmlns='http://www.w3.org/2000/svg' version='1.1' height='10px' width='5px'><text x='0' y='5' font-size='10' fill='grey'>&%238595;</text></svg>");
--toc-background-color: #e0e0e0;
--toc-border-color: #c0c0e0;
--toc-header-color: #4060a0;
--toc-down-arrow-image: url("data:image/svg+xml;utf8,<svg xmlns='http://www.w3.org/2000/svg' version='1.1' height='10px' width='5px' fill='grey'><text x='0' y='5' font-size='10'>&%238595;</text></svg>");
/** search field */
--search-background-color: black;
--search-foreground-color: #C5C5C5;
--search-magnification-image: url('mag_d.svg');
--search-magnification-select-image: url('mag_seld.svg');
--search-active-color: #C5C5C5;
--search-filter-background-color: #101826;
--search-filter-foreground-color: #90A5CE;
--search-filter-border-color: #7C95C6;
--search-filter-highlight-text-color: #BCC9E2;
--search-filter-highlight-bg-color: #283A5D;
--search-results-background-color: #101826;
--search-results-foreground-color: #90A5CE;
--search-results-border-color: #7C95C6;
--search-box-shadow: inset 0.5px 0.5px 3px 0px #2F436C;
--search-background-color: #ffffff;
--search-foreground-color: #808080;
--search-magnification-image: url('mag.svg');
--search-magnification-select-image: url('mag_sel.svg');
--search-active-color: #000000;
--search-filter-background-color: #e0e0e0;
--search-filter-foreground-color: #000000;
--search-filter-border-color: #80a0c0;
--search-filter-highlight-text-color: #ffffff;
--search-filter-highlight-bg-color: #204080;
--search-results-foreground-color: #404080;
--search-results-background-color: #e0e0e0;
--search-results-border-color: #000000;
--search-box-shadow: inset 0.5px 0.5px 3px 0px #555;
/** code fragments */
--code-keyword-color: #CC99CD;
--code-type-keyword-color: #AB99CD;
--code-flow-keyword-color: #E08000;
--code-comment-color: #717790;
--code-preprocessor-color: #65CABE;
--code-string-literal-color: #7EC699;
--code-char-literal-color: #00E0F0;
--code-xml-cdata-color: #C9D1D9;
--code-vhdl-digit-color: #FF00FF;
--code-vhdl-char-color: #C0C0C0;
--code-vhdl-keyword-color: #CF53C9;
--code-vhdl-logic-color: #FF0000;
--code-link-color: #79C0FF;
--code-external-link-color: #79C0FF;
--fragment-foreground-color: #C9D1D9;
--fragment-background-color: black;
--fragment-border-color: #30363D;
--fragment-lineno-border-color: #30363D;
--fragment-lineno-background-color: black;
--fragment-lineno-foreground-color: #6E7681;
--fragment-lineno-link-fg-color: #6E7681;
--fragment-lineno-link-bg-color: #303030;
--fragment-lineno-link-hover-fg-color: #8E96A1;
--fragment-lineno-link-hover-bg-color: #505050;
--tooltip-foreground-color: #C9D1D9;
--tooltip-background-color: #202020;
--tooltip-border-color: #C9D1D9;
--tooltip-doc-color: #D9E1E9;
--tooltip-declaration-color: #20C348;
--tooltip-link-color: #79C0FF;
--tooltip-shadow: none;
--code-keyword-color: #008000;
--code-type-keyword-color: #604020;
--code-flow-keyword-color: #e08000;
--code-comment-color: #800000;
--code-preprocessor-color: #806020;
--code-string-literal-color: #002080;
--code-char-literal-color: #008080;
--code-xml-cdata-color: #000000;
--code-vhdl-digit-color: #e000e0;
--code-vhdl-char-color: #000000;
--code-vhdl-keyword-color: #600060;
--code-vhdl-logic-color: #e00000;
--code-link-color: #4060a0;
--code-external-link-color: #4060a0;
--fragment-foreground-color: #000000;
--fragment-background-color: #e0e0e0;
--fragment-border-color: #c0c0e0;
--fragment-lineno-border-color: #00e000;
--fragment-lineno-background-color: #e0e0e0;
--fragment-lineno-foreground-color: #000000;
--fragment-lineno-link-fg-color: #4060a0;
--fragment-lineno-link-bg-color: #c0c0c0;
--fragment-lineno-link-hover-fg-color: #4060a0;
--fragment-lineno-link-hover-bg-color: #c0c0c0;
--tooltip-foreground-color: #000000;
--tooltip-background-color: #ffffff;
--tooltip-border-color: #808080;
--tooltip-doc-color: grey;
--tooltip-declaration-color: #006000;
--tooltip-link-color: #4060a0;
--tooltip-shadow: 1px 1px 7px #808080;
--fold-line-color: #808080;
--fold-minus-image: url('minusd.svg');
--fold-plus-image: url('plusd.svg');
--fold-minus-image-relpath: url('../../minusd.svg');
--fold-plus-image-relpath: url('../../plusd.svg');
--fold-minus-image: url('minus.svg');
--fold-plus-image: url('plus.svg');
--fold-minus-image-relpath: url('../../minus.svg');
--fold-plus-image-relpath: url('../../plus.svg');
/** font-family */
--font-family-normal: Roboto,sans-serif;
@ -170,166 +170,166 @@ html {
}
@media (prefers-color-scheme: light) {
html:not(.light-mode) {
color-scheme: light;
@media (prefers-color-scheme: dark) {
html:not(.dark-mode) {
color-scheme: dark;
/* page base colors */
--page-background-color: white;
--page-foreground-color: black;
--page-link-color: #3D578C;
--page-visited-link-color: #4665A2;
--page-background-color: #000000;
--page-foreground-color: #c0c0c0;
--page-link-color: #80a0c0;
--page-visited-link-color: #a0a0c0;
/* index */
--index-odd-item-bg-color: #F8F9FC;
--index-even-item-bg-color: white;
--index-header-color: black;
--index-separator-color: #A0A0A0;
--index-odd-item-bg-color: #000000;
--index-even-item-bg-color: #000000;
--index-header-color: #c0c0e0;
--index-separator-color: #204060;
/* header */
--header-background-color: #F9FAFC;
--header-separator-color: #C4CFE5;
--header-gradient-image: url('nav_h.png');
--group-header-separator-color: #879ECB;
--group-header-color: #354C7B;
--inherit-header-color: gray;
--header-background-color: #000000;
--header-separator-color: #000020;
--header-gradient-image: url('nav_hd.png');
--group-header-separator-color: #202040;
--group-header-color: #80a0c0;
--inherit-header-color: #a0a0a0;
--footer-foreground-color: #2A3D61;
--footer-logo-width: 104px;
--citation-label-color: #334975;
--glow-color: cyan;
--footer-foreground-color: #4060a0;
--footer-logo-width: 60px;
--citation-label-color: #80a0c0;
--glow-color: #00ffff;
--title-background-color: white;
--title-separator-color: #5373B4;
--directory-separator-color: #9CAFD4;
--separator-color: #4A6AAA;
--title-background-color: #000000;
--title-separator-color: #204060;
--directory-separator-color: #202040;
--separator-color: #202040;
--blockquote-background-color: #F7F8FB;
--blockquote-border-color: #9CAFD4;
--blockquote-background-color: #000020;
--blockquote-border-color: #202040;
--scrollbar-thumb-color: #9CAFD4;
--scrollbar-background-color: #F9FAFC;
--scrollbar-thumb-color: #202040;
--scrollbar-background-color: #000000;
--icon-background-color: #728DC1;
--icon-foreground-color: white;
--icon-doc-image: url('doc.svg');
--icon-folder-open-image: url('folderopen.svg');
--icon-folder-closed-image: url('folderclosed.svg');
--icon-background-color: #204060;
--icon-foreground-color: #c0c0e0;
--icon-doc-image: url('docd.svg');
--icon-folder-open-image: url('folderopend.svg');
--icon-folder-closed-image: url('folderclosedd.svg');
/* brief member declaration list */
--memdecl-background-color: #F9FAFC;
--memdecl-separator-color: #DEE4F0;
--memdecl-foreground-color: #555;
--memdecl-template-color: #4665A2;
--memdecl-background-color: #000000;
--memdecl-separator-color: #202060;
--memdecl-foreground-color: #BBB;
--memdecl-template-color: #6080c0;
/* detailed member list */
--memdef-border-color: #A8B8D9;
--memdef-title-background-color: #E2E8F2;
--memdef-title-gradient-image: url('nav_f.png');
--memdef-proto-background-color: #DFE5F1;
--memdef-proto-text-color: #253555;
--memdef-proto-text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9);
--memdef-doc-background-color: white;
--memdef-param-name-color: #602020;
--memdef-template-color: #4665A2;
--memdef-border-color: #202040;
--memdef-title-background-color: #002040;
--memdef-title-gradient-image: url('nav_fd.png');
--memdef-proto-background-color: #002020;
--memdef-proto-text-color: #80a0c0;
--memdef-proto-text-shadow: 0px 1px 1px rgba(0, 0, 0, 0.9);
--memdef-doc-background-color: #000000;
--memdef-param-name-color: #c08040;
--memdef-template-color: #6080c0;
/* tables */
--table-cell-border-color: #2D4068;
--table-header-background-color: #374F7F;
--table-header-foreground-color: #FFFFFF;
--table-cell-border-color: #202040;
--table-header-background-color: #202040;
--table-header-foreground-color: #c0c0e0;
/* labels */
--label-background-color: #728DC1;
--label-left-top-border-color: #5373B4;
--label-right-bottom-border-color: #C4CFE5;
--label-foreground-color: white;
--label-background-color: #204060;
--label-left-top-border-color: #4060a0;
--label-right-bottom-border-color: #202040;
--label-foreground-color: #c0c0c0;
/** navigation bar/tree/menu */
--nav-background-color: #F9FAFC;
--nav-foreground-color: #364D7C;
--nav-gradient-image: url('tab_b.png');
--nav-gradient-hover-image: url('tab_h.png');
--nav-gradient-active-image: url('tab_a.png');
--nav-gradient-active-image-parent: url("../tab_a.png");
--nav-separator-image: url('tab_s.png');
--nav-breadcrumb-image: url('bc_s.png');
--nav-breadcrumb-border-color: #C2CDE4;
--nav-splitbar-image: url('splitbar.png');
--nav-background-color: #000020;
--nav-foreground-color: #204060;
--nav-gradient-image: url('tab_bd.png');
--nav-gradient-hover-image: url('tab_hd.png');
--nav-gradient-active-image: url('tab_ad.png');
--nav-gradient-active-image-parent: url("../tab_ad.png");
--nav-separator-image: url('tab_sd.png');
--nav-breadcrumb-image: url('bc_sd.png');
--nav-breadcrumb-border-color: #202060;
--nav-splitbar-image: url('splitbard.png');
--nav-font-size-level1: 13px;
--nav-font-size-level2: 10px;
--nav-font-size-level3: 9px;
--nav-text-normal-color: #283A5D;
--nav-text-hover-color: white;
--nav-text-active-color: white;
--nav-text-normal-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9);
--nav-text-normal-color: #a0c0c0;
--nav-text-hover-color: #c0e0e0;
--nav-text-active-color: #c0e0e0;
--nav-text-normal-shadow: 0px 1px 1px #000000;
--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0);
--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0);
--nav-menu-button-color: #364D7C;
--nav-menu-background-color: white;
--nav-menu-foreground-color: #555555;
--nav-menu-toggle-color: rgba(255, 255, 255, 0.5);
--nav-arrow-color: #9CAFD4;
--nav-arrow-selected-color: #9CAFD4;
--nav-menu-button-color: #a0c0c0;
--nav-menu-background-color: #000000;
--nav-menu-foreground-color: #a0a0a0;
--nav-menu-toggle-color: rgba(255, 255, 255, 0.2);
--nav-arrow-color: #204060;
--nav-arrow-selected-color: #80a0c0;
/* table of contents */
--toc-background-color: #F4F6FA;
--toc-border-color: #D8DFEE;
--toc-header-color: #4665A2;
--toc-down-arrow-image: url("data:image/svg+xml;utf8,<svg xmlns='http://www.w3.org/2000/svg' version='1.1' height='10px' width='5px' fill='grey'><text x='0' y='5' font-size='10'>&%238595;</text></svg>");
--toc-background-color: #000020;
--toc-border-color: #202040;
--toc-header-color: #a0a0c0;
--toc-down-arrow-image: url("data:image/svg+xml;utf8,<svg xmlns='http://www.w3.org/2000/svg' version='1.1' height='10px' width='5px'><text x='0' y='5' font-size='10' fill='grey'>&%238595;</text></svg>");
/** search field */
--search-background-color: white;
--search-foreground-color: #909090;
--search-magnification-image: url('mag.svg');
--search-magnification-select-image: url('mag_sel.svg');
--search-active-color: black;
--search-filter-background-color: #F9FAFC;
--search-filter-foreground-color: black;
--search-filter-border-color: #90A5CE;
--search-filter-highlight-text-color: white;
--search-filter-highlight-bg-color: #3D578C;
--search-results-foreground-color: #425E97;
--search-results-background-color: #EEF1F7;
--search-results-border-color: black;
--search-box-shadow: inset 0.5px 0.5px 3px 0px #555;
--search-background-color: #000000;
--search-foreground-color: #c0c0c0;
--search-magnification-image: url('mag_d.svg');
--search-magnification-select-image: url('mag_seld.svg');
--search-active-color: #c0c0c0;
--search-filter-background-color: #000020;
--search-filter-foreground-color: #80a0c0;
--search-filter-border-color: #6080c0;
--search-filter-highlight-text-color: #a0c0e0;
--search-filter-highlight-bg-color: #202040;
--search-results-background-color: #000020;
--search-results-foreground-color: #80a0c0;
--search-results-border-color: #6080c0;
--search-box-shadow: inset 0.5px 0.5px 3px 0px #2F436C;
/** code fragments */
--code-keyword-color: #008000;
--code-type-keyword-color: #604020;
--code-flow-keyword-color: #E08000;
--code-comment-color: #800000;
--code-preprocessor-color: #806020;
--code-string-literal-color: #002080;
--code-char-literal-color: #008080;
--code-xml-cdata-color: black;
--code-vhdl-digit-color: #FF00FF;
--code-vhdl-char-color: #000000;
--code-vhdl-keyword-color: #700070;
--code-vhdl-logic-color: #FF0000;
--code-link-color: #4665A2;
--code-external-link-color: #4665A2;
--fragment-foreground-color: black;
--fragment-background-color: #FBFCFD;
--fragment-border-color: #C4CFE5;
--fragment-lineno-border-color: #00FF00;
--fragment-lineno-background-color: #E8E8E8;
--fragment-lineno-foreground-color: black;
--fragment-lineno-link-fg-color: #4665A2;
--fragment-lineno-link-bg-color: #D8D8D8;
--fragment-lineno-link-hover-fg-color: #4665A2;
--fragment-lineno-link-hover-bg-color: #C8C8C8;
--tooltip-foreground-color: black;
--tooltip-background-color: white;
--tooltip-border-color: gray;
--tooltip-doc-color: grey;
--tooltip-declaration-color: #006318;
--tooltip-link-color: #4665A2;
--tooltip-shadow: 1px 1px 7px gray;
--code-keyword-color: #c080c0;
--code-type-keyword-color: #a080c0;
--code-flow-keyword-color: #e08000;
--code-comment-color: #606080;
--code-preprocessor-color: #60c0a0;
--code-string-literal-color: #60c080;
--code-char-literal-color: #00e0e0;
--code-xml-cdata-color: #c0c0c0;
--code-vhdl-digit-color: #e000e0;
--code-vhdl-char-color: #c0c0c0;
--code-vhdl-keyword-color: #c040c0;
--code-vhdl-logic-color: #e00000;
--code-link-color: #60c0e0;
--code-external-link-color: #60c0e0;
--fragment-foreground-color: #c0c0c0;
--fragment-background-color: #000000;
--fragment-border-color: #202020;
--fragment-lineno-border-color: #202020;
--fragment-lineno-background-color: #000000;
--fragment-lineno-foreground-color: #606080;
--fragment-lineno-link-fg-color: #606080;
--fragment-lineno-link-bg-color: #202020;
--fragment-lineno-link-hover-fg-color: #8080a0;
--fragment-lineno-link-hover-bg-color: #404040;
--tooltip-foreground-color: #c0c0c0;
--tooltip-background-color: #202020;
--tooltip-border-color: #c0c0c0;
--tooltip-doc-color: #c0e0e0;
--tooltip-declaration-color: #20c040;
--tooltip-link-color: #60c0e0;
--tooltip-shadow: none;
--fold-line-color: #808080;
--fold-minus-image: url('minus.svg');
--fold-plus-image: url('plus.svg');
--fold-minus-image-relpath: url('../../minus.svg');
--fold-plus-image-relpath: url('../../plus.svg');
--fold-minus-image: url('minusd.svg');
--fold-plus-image: url('plusd.svg');
--fold-minus-image-relpath: url('../../minusd.svg');
--fold-plus-image-relpath: url('../../plusd.svg');
/** font-family */
--font-family-normal: Roboto,sans-serif;
@ -1524,49 +1524,49 @@ dl.note {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #D0C000;
border-color: #c0c000;
}
dl.warning, dl.attention {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #FF0000;
border-color: #e00000;
}
dl.pre, dl.post, dl.invariant {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #00D000;
border-color: #00c000;
}
dl.deprecated {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #505050;
border-color: #404040;
}
dl.todo {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #00C0E0;
border-color: #00c0e0;
}
dl.test {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #3030E0;
border-color: #2020e0;
}
dl.bug {
margin-left: -7px;
padding-left: 3px;
border-left: 4px solid;
border-color: #C08050;
border-color: #c08040;
}
dl.section dd {

1
munit Submodule

@ -0,0 +1 @@
Subproject commit fbbdf1467eb0d04a6ee465def2e529e4c87f2118

View file

@ -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;
}

View file

@ -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

View file

@ -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;
}

View file

@ -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 */

View file

@ -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;
}

View file

@ -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

View file

@ -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;
}

View file

@ -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 */

View file

@ -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;
}

View file

@ -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
View 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 &infin;.
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.

View file

@ -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
//}

View file

@ -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

View 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;
}

View 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

View 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`.",
&not},
{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.",
&quote},
#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;
}

View 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

View 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;
}

View 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
View 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

View file

@ -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

View file

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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"" ),
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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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;
}

Some files were not shown because too many files have changed in this diff Show more