Compare commits
No commits in common. "master" and "intern-rewrite" have entirely different histories.
master
...
intern-rew
34 changed files with 713 additions and 2252 deletions
3
.gitmodules
vendored
3
.gitmodules
vendored
|
|
@ -1,3 +0,0 @@
|
||||||
[submodule "munit"]
|
|
||||||
path = munit
|
|
||||||
url = https://github.com/nemequ/munit.git
|
|
||||||
7
Makefile
7
Makefile
|
|
@ -44,13 +44,10 @@ test: $(TESTS) Makefile $(TARGET)
|
||||||
|
|
||||||
.PHONY: clean
|
.PHONY: clean
|
||||||
clean:
|
clean:
|
||||||
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ $(TMP_DIR)/* *~ core.*
|
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ $(TMP_DIR)/* *~ core
|
||||||
|
|
||||||
coredumps:
|
|
||||||
ulimit -c unlimited
|
|
||||||
|
|
||||||
repl:
|
repl:
|
||||||
$(TARGET) -ps1000 2> tmp/psse.log
|
$(TARGET) -p 2> psse.log
|
||||||
|
|
||||||
|
|
||||||
-include $(DEPS)
|
-include $(DEPS)
|
||||||
|
|
|
||||||
190
README.md
190
README.md
|
|
@ -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
1
README.md
Symbolic link
|
|
@ -0,0 +1 @@
|
||||||
|
docs/Home.md
|
||||||
|
|
@ -1,120 +0,0 @@
|
||||||
# Design decisions for 0.1.0
|
|
||||||
|
|
||||||
This is a document that is likely to be revisited, probably frequently.
|
|
||||||
|
|
||||||
## Retire the 0.0.X codebase
|
|
||||||
|
|
||||||
Move the existing codebase out of the compile space altogether; it is to be
|
|
||||||
treated as a finished rapid prototype, not extended further, and code largely
|
|
||||||
not copied but learned from.
|
|
||||||
|
|
||||||
## Remain open to new substrate languages, but continue in C for now
|
|
||||||
|
|
||||||
I'm disappointed with [Zig](https://ziglang.org/). While the language
|
|
||||||
concepts are beautiful, and if it were stable it would be an excellent tool, it
|
|
||||||
isn't stable. I'm still open to build some of the 0.1.X prototype in Zig, but
|
|
||||||
it isn't the main tool.
|
|
||||||
|
|
||||||
I haven't yet evaluated [Nim](https://nim-lang.org/). I'm prejudiced against
|
|
||||||
its syntax, but, again, I'm open to using it for some of this prototype.
|
|
||||||
|
|
||||||
But for now, I will continue to work in C.
|
|
||||||
|
|
||||||
## Substrate is shallow
|
|
||||||
|
|
||||||
In the 0.0.X prototype, I tried to do too much in the substrate. I tried to
|
|
||||||
write bignums in C, and in this I failed; I would have done much better to
|
|
||||||
get a very small Lisp working well sooner, and build new features in that.
|
|
||||||
|
|
||||||
In 0.1.X the substrate will be much less feature rich, but support the creation
|
|
||||||
of novel types of data object in Lisp.
|
|
||||||
|
|
||||||
## Sysin and sysout are urgent
|
|
||||||
|
|
||||||
If a significant proportion of the system is written in Lisp, it must be
|
|
||||||
possible to save a working Lisp image to file and recover it.
|
|
||||||
|
|
||||||
## Compiler is urgent
|
|
||||||
|
|
||||||
I still don't know how to write a compiler, and writing a compiler will still
|
|
||||||
be a major challenge. But I am now much closer to knowing how to write a
|
|
||||||
compiler than I was. I think it's important to have a compiler, both for
|
|
||||||
performance and for security. Given that we do not have a separate execute ACL,
|
|
||||||
if a user can execute an interpreted function, they can also read its source.
|
|
||||||
|
|
||||||
Generally this is a good thing. For things low down in the stack, it may not
|
|
||||||
be.
|
|
||||||
|
|
||||||
## Paged Space Objects
|
|
||||||
|
|
||||||
Paged space objects will be implemented largely in line with
|
|
||||||
[this document](Paged-space-objects.md).
|
|
||||||
|
|
||||||
## Tags
|
|
||||||
|
|
||||||
Tags will continue to be 32 bit objects, which can be considered as unsigned
|
|
||||||
integer values or as four bytes. However, only the first three bytes will be
|
|
||||||
mnemonic. The fourth byte will indicate the size class of the object; where
|
|
||||||
the size class represents the allocation size, *not* the payload size. The
|
|
||||||
encoding is as in this table:
|
|
||||||
|
|
||||||
| Tag | | | Size of payload | |
|
|
||||||
| ---- | ----------- | --- | --------------- | --------------- |
|
|
||||||
| Bits | Field value | Hex | Number of words | Number of bytes |
|
|
||||||
| ---- | ----------- | --- | --------------- | --------------- |
|
|
||||||
| 0000 | 0 | 0 | 1 | 8 |
|
|
||||||
| 0001 | 1 | 1 | 2 | 16 |
|
|
||||||
| 0010 | 2 | 2 | 4 | 32 |
|
|
||||||
| 0011 | 3 | 3 | 8 | 64 |
|
|
||||||
| 0100 | 4 | 4 | 16 | 128 |
|
|
||||||
| 0101 | 5 | 5 | 32 | 256 |
|
|
||||||
| 0110 | 6 | 6 | 64 | 512 |
|
|
||||||
| 0111 | 7 | 7 | 128 | 1024 |
|
|
||||||
| 1000 | 8 | 8 | 256 | 2048 |
|
|
||||||
| 1001 | 9 | 9 | 512 | 4096 |
|
|
||||||
| 1010 | 10 | A | 1024 | 8192 |
|
|
||||||
| 1011 | 11 | B | 2048 | 16384 |
|
|
||||||
| 1100 | 12 | C | 4096 | 32768 |
|
|
||||||
| 1101 | 13 | D | 8192 | 65536 |
|
|
||||||
| 1110 | 14 | E | 16384 | 131072 |
|
|
||||||
| 1111 | 15 | F | 32768 | 262144 |
|
|
||||||
|
|
||||||
Consequently, an object of size class F will have an allocation size of 32,768
|
|
||||||
words, but a payload size of 32,766 words. This obviously means that size
|
|
||||||
classes 0 and 1 will not exist, since they would not have any payload.
|
|
||||||
|
|
||||||
## Page size
|
|
||||||
|
|
||||||
Every page will be 1,048,576 bytes.
|
|
||||||
|
|
||||||
## Namespaces
|
|
||||||
|
|
||||||
Namespaces will be implemented; in addition to the root namespace, there will
|
|
||||||
be at least the following namespaces:
|
|
||||||
|
|
||||||
### :bootstrap
|
|
||||||
|
|
||||||
Functions written in the substrate language, intended to be replaced for all
|
|
||||||
normal purposes by functions written in Lisp which may call these bootstrap
|
|
||||||
functions. Not ever available to user code.
|
|
||||||
|
|
||||||
### :substrate
|
|
||||||
|
|
||||||
Functions written in the substrate language which *may* be available to
|
|
||||||
user-written code.
|
|
||||||
|
|
||||||
### :system
|
|
||||||
|
|
||||||
Functions, written either in Lisp or in the substrate language, which modify
|
|
||||||
system memory in ways that only trusted and privileged users are permitted to
|
|
||||||
do.
|
|
||||||
|
|
||||||
## Access control
|
|
||||||
|
|
||||||
Obviously, for this to work, access control lists must be implemented and must
|
|
||||||
work.
|
|
||||||
|
|
||||||
## Router is deferred to 0.2.X
|
|
||||||
|
|
||||||
This generation is about producing a better single thread Lisp (but hopefully
|
|
||||||
to build it fast); the hypercube topology is deferred.
|
|
||||||
|
|
@ -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]()
|
|
||||||
70
docs/Home.md
70
docs/Home.md
|
|
@ -1,6 +1,6 @@
|
||||||
# Post Scarcity Software Environment: general documentation
|
# Post Scarcity Software Environment: general documentation
|
||||||
|
|
||||||
Work towards the implementation of a software system for the hardware of the deep future.
|
Work towards the implementation of a software system like that described in [Post Scarcity Software](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/).
|
||||||
|
|
||||||
## Note on canonicity
|
## Note on canonicity
|
||||||
|
|
||||||
|
|
@ -38,59 +38,25 @@ This project is necessarily experimental and exploratory. I write code, it revea
|
||||||
|
|
||||||
## Building
|
## 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.
|
The substrate of this system 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/).
|
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.
|
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
|
## 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.
|
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
|
### Invoking
|
||||||
|
|
||||||
The binary is canonically named `psse`. When invoking the system, the following invocation arguments may be passed:
|
When invoking the system, the following invocation arguments may be passed:
|
||||||
```
|
```
|
||||||
-d Dump memory to standard out at end of run (copious!);
|
-d Dump memory to standard out at end of run (copious!);
|
||||||
-h Print this message and exit;
|
-h Print this message and exit;
|
||||||
-p Show a prompt (default is no prompt);
|
-p Show a prompt (default is no prompt);
|
||||||
-s LIMIT
|
|
||||||
Set a limit to the depth the stack can extend to;
|
|
||||||
-v LEVEL
|
-v LEVEL
|
||||||
Set verbosity to the specified level (0...1024)
|
Set verbosity to the specified level (0...512)
|
||||||
Where bits are interpreted as follows:
|
Where bits are interpreted as follows:
|
||||||
1 ALLOC;
|
1 ALLOC;
|
||||||
2 ARITH;
|
2 ARITH;
|
||||||
|
|
@ -100,8 +66,7 @@ The binary is canonically named `psse`. When invoking the system, the following
|
||||||
32 INPUT/OUTPUT;
|
32 INPUT/OUTPUT;
|
||||||
64 LAMBDA;
|
64 LAMBDA;
|
||||||
128 REPL;
|
128 REPL;
|
||||||
256 STACK;
|
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.
|
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.
|
||||||
|
|
@ -112,10 +77,7 @@ The following functions are provided as of release 0.0.6:
|
||||||
|
|
||||||
| Symbol | Type | Documentation |
|
| Symbol | Type | Documentation |
|
||||||
| ------ | ---- | ------------- |
|
| ------ | ---- | ------------- |
|
||||||
| `*` | FUNC | `(* args...)` Multiplies these `args`, all of which should be numbers, and return the product. |
|
| * | 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 | `(+ 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)`: 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 | `(/ a b)`: Divides `a` by `b` and returns the result. Expects both arguments to be numbers. |
|
||||||
|
|
@ -165,26 +127,14 @@ The following functions are provided as of release 0.0.6:
|
||||||
| 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. |
|
| 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. |
|
| 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. |
|
| 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 | FUNC | null |
|
||||||
| 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. |
|
| 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. |
|
| 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. |
|
| 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. |
|
| 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).|
|
| throw | FUNC | null |
|
||||||
| 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. |
|
| time | FUNC | `(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch. |
|
||||||
| try | SPFM | `(try forms... (catch symbol forms...))`: Doesn't work yet! |
|
| try | SPFM | null |
|
||||||
| 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. |
|
| 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. |
|
| λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ funtion. |
|
||||||
|
|
||||||
## 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.
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,50 +12,58 @@ causes an unbound variable exception to be thrown, while
|
||||||
|
|
||||||
returns the value **"froboz"**. This begs the question of whether there's any difference between **"froboz"** and **'froboz**, and the answer is that at this point I don't know.
|
returns the value **"froboz"**. This begs the question of whether there's any difference between **"froboz"** and **'froboz**, and the answer is that at this point I don't know.
|
||||||
|
|
||||||
There will be a concept of a root [namespace](Namespace.md), in which other namespaces may be bound recursively to form a directed graph. Because at least some namespaces are mutable, the graph is not necessarily acyclic. There will be a concept of a current namespace, that is to say the namespace in which the user is currently working.
|
There will be a concept of a root [namespace](Namespace.html), in which other namespaces may be bound recursively to form a directed graph. Because at least some namespaces are mutable, the graph is not necessarily acyclic. There will be a concept of a current namespace, that is to say the namespace in which the user is currently working.
|
||||||
|
|
||||||
There must be some notation to say distinguish a request for the value of a name in the root namespace and the value of a name in the current namespace. For now I'm proposing that:
|
There must be some notation to say distinguish a request for the value of a name in the root namespace and the value of a name in the current namespace. For now I'm proposing that:
|
||||||
|
|
||||||
(eval 'froboz)
|
(eval froboz)
|
||||||
|
|
||||||
will return the value that **froboz** is bound to in the current namespace;
|
will return the value that **froboz** is bound to in the current namespace;
|
||||||
|
|
||||||
(eval ::/froboz)
|
(eval .froboz)
|
||||||
|
|
||||||
will return the value that **froboz** is bound to in the root namespace;
|
will return the value that **froboz** is bound to in the root namespace;
|
||||||
|
|
||||||
(eval 'foobar/froboz)
|
(eval foobar.froboz)
|
||||||
|
|
||||||
will return the value that **froboz** is bound to in a namespace which is the value of the name **foobar** in the current namespace; and that
|
will return the value that **froboz** is bound to in a namespace which is the value of the name **foobar** in the current namespace; and that
|
||||||
|
|
||||||
(eval ::users:simon:environment/froboz)
|
(eval .system.users.simon.environment.froboz)
|
||||||
|
|
||||||
will return the value that **froboz** is bound to in the environment of the user of the system called **simon** (if that is readable by you).
|
will return the value that **froboz** is bound to in the environment of the user of the system called **simon**.
|
||||||
|
|
||||||
The [exact path separator syntax](Paths.md) may change, but the principal that when interning a symbol it is broken down into a path of tokens, and that the value of each token is sought in a namespace bound to the previous token, is likely to remain.
|
The exact path separator syntax may change, but the principal that when interning a symbol it is broken down into a path of tokens, and that the value of each token is sought in a namespace bound to the previous token, is likely to remain.
|
||||||
|
|
||||||
Obviously if **froboz** is interned in one namespace it is not necessarily interned in another, and vice versa. There's a potentially nasty problem here that two lexically identical strings might be bound in different namespaces, so that there is not one canonical interned **froboz**; if this turns out to cause problems in practice there will need to be a separate canonical [hashtable](Hashtable.md) of individual path elements.
|
Obviously if **froboz** is interned in one namespace it is not necessarily interned in another, and vice versa. There's a potentially nasty problem here that two lexically identical strings might be bound in different namespaces, so that there is not one canonical interned **froboz**; if this turns out to cause problems in practice there will need to be a separate canonical [hashtable](Hashtable.html) of individual path elements.
|
||||||
|
|
||||||
Obviously this means there may be arbitrarily many paths which reference the same data item. This is intended.
|
Obviously this means there may be arbitrarily many paths which reference the same data item. This is intended.
|
||||||
|
|
||||||
## Related functions
|
## Related functions
|
||||||
|
|
||||||
### (intern! path)
|
### (intern! string)
|
||||||
|
|
||||||
Binds *path* to **NIL**. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
|
Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
|
||||||
|
|
||||||
### (intern! path T)
|
### (intern! string T)
|
||||||
|
|
||||||
Binds *path* to **NIL**. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **:friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
||||||
|
|
||||||
|
### (intern! string T write-access-list)
|
||||||
|
|
||||||
|
Binds *string*, considered as a path, to **NIL**. If some namespace along the path doesn't exist, create it as the current user with the read [access control](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/) list taken from the current binding of **friends** in the current environment, and the write access control list taken from the value of *write-access-list*. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
||||||
|
|
||||||
### (set! string value)
|
### (set! string value)
|
||||||
|
|
||||||
Binds *path* to *value*. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
|
Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, throws an exception. Obviously if the current user is not entitled to write to the terminal namespace, also throws an exception.
|
||||||
|
|
||||||
### (set! string value T)
|
### (set! string value T)
|
||||||
|
|
||||||
Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, create it as the current user with both read and write [access control](Access-control.html) lists taken from the current binding of **friends** in the current environment. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
||||||
|
|
||||||
|
### (set! string value T write-access-list)
|
||||||
|
|
||||||
|
Binds *string*, considered as a path, to *value*. If some namespace along the path doesn't exist, create it as the current user with the read [access control](Access-control.html) list taken from the current binding of **friends** in the current environment, and the write access control list taken from the value of *write-access-list*. Obviously if the current user is not entitled to write to the last pre-existing namespace, throws an exception.
|
||||||
|
|
||||||
### (put! string token value)
|
### (put! string token value)
|
||||||
|
|
||||||
Considers *string* as the path to some namespace, and binds *token* in that namespace to *value*. *Token* should not contain any path separator syntax. If the namespace doesn't exist or if the current user is not entitled to write to the namespace, throws an exception.
|
Considers *string* as the path to some namespace, and binds *token* in that namespace to *value*. *Token* should not contain any path separator syntax. If the namespace doesn't exist or if the current user is not entitled to write to the namespace, throws an exception.
|
||||||
|
|
@ -63,16 +71,16 @@ Considers *string* as the path to some namespace, and binds *token* in that name
|
||||||
### (string-to-path string)
|
### (string-to-path string)
|
||||||
|
|
||||||
Behaviour as follows:
|
Behaviour as follows:
|
||||||
(string-to-path ":foo:bar/ban") => (-> (environment) :foo :bar 'ban)
|
(string-to-path "foo.bar.ban") => ("foo" "bar" "ban")
|
||||||
(string-to-path "::foo:bar/ban") => (-> (oblist) :foo :bar 'ban)
|
(string-to-path ".foo.bar.ban") => ("" "foo" "bar" "ban")
|
||||||
|
|
||||||
Obviously if the current user can't read the string, throws an exception. `(oblist)` is currently (version 0.0.6) a function which returns the current value of the root namespace; `(environment)` is a proposed function which returns the current value of the environment of current user (with possibly `(environmnt user-name)` returning the value of the environment of the user indicated by `user-name`, if that is readable by you). The symbol `->` represents a threading macro [similar to Clojure's](https://clojuredocs.org/clojure.core/-%3E).
|
Obviously if the current user can't read the string, throws an exception.
|
||||||
|
|
||||||
### (path-to-string list-of-strings)
|
### (path-to-string list-of-strings)
|
||||||
|
|
||||||
Behaviour as follows:
|
Behaviour as follows:
|
||||||
(path-to-string '(:foo :bar 'ban)) => ":foo:bar/ban"
|
(path-to-string '("foo" "bar" "ban")) => "foo.bar.ban"
|
||||||
(path-to-string '("" :foo :bar 'ban)) => "::foo:bar/ban"
|
(path-to-string '("" "foo" "bar" "ban")) => ".foo.bar.ban"
|
||||||
|
|
||||||
Obviously if the current user can't read some element of *list-of-strings*, throws an exception.
|
Obviously if the current user can't read some element of *list-of-strings*, throws an exception.
|
||||||
|
|
||||||
|
|
|
||||||
112
docs/Roadmap.md
112
docs/Roadmap.md
|
|
@ -1,132 +1,58 @@
|
||||||
# Roadmap
|
# Roadmap
|
||||||
|
|
||||||
With the release of 0.0.6 close, it's time to look at a plan for the future
|
With the release of 0.0.6 close, it's time to look at a plan for the future development of the project.
|
||||||
development of the project.
|
|
||||||
|
|
||||||
I have an almost-working Lisp interpreter, which, as an interpreter, has many
|
I have an almost-working Lisp interpreter, which, as an interpreter, has many of the features of the language I want. It runs in one thread on one processor.
|
||||||
of the features of the language I want. It runs in one thread on one processor.
|
|
||||||
|
|
||||||
Given how experimental this all is, I don't think I need it to be a polished
|
Given how experimental this all is, I don't think I need it to be a polished interpreter, and polished it isn't. Lots of things are broken.
|
||||||
interpreter, and polished it isn't. Lots of things are broken.
|
|
||||||
|
|
||||||
* garbage collection is pretty broken, and I'n beginning to doubt my whole
|
* garbage collection is pretty broken, and I'n beginning to doubt my whole garbage collection strategy;
|
||||||
garbage collection strategy;
|
|
||||||
* bignums are horribly broken;
|
* bignums are horribly broken;
|
||||||
* there's something very broken in shallow-bound symbols, and that matters
|
* there's something very broken in shallow-bound symbols, and that matters and wil have to be fixed;
|
||||||
and will have to be fixed;
|
|
||||||
* there are undoubtedly many other bugs I don't know about.
|
* there are undoubtedly many other bugs I don't know about.
|
||||||
|
|
||||||
However, while I will fix bugs where I can, it's good enough for other people
|
However, while I will fix bugs where I can, it's good enough for other people to play with if they're mad enough, and it's time to move on.
|
||||||
to play with if they're mad enough, and it's time to move on.
|
|
||||||
|
|
||||||
## Next major milestones
|
## Next major milestones
|
||||||
|
|
||||||
### New substrate language?
|
|
||||||
|
|
||||||
I really don't feel competent to write the substrate in C, and I don't think
|
|
||||||
that what exists of the substrate is of sufficient quality. It's too big and
|
|
||||||
too complex. I think what the system needs is a smaller substrate written in
|
|
||||||
a more modern language.
|
|
||||||
|
|
||||||
I propose to evaluate both [Zig](https://ziglang.org/) and
|
|
||||||
[Rust](https://rust-lang.org/), and see whether I can feel more productive in
|
|
||||||
either of those.
|
|
||||||
|
|
||||||
### Smaller substrate
|
|
||||||
|
|
||||||
However, I also think the substrate ought to be smaller. I
|
|
||||||
do not think the substrate should include things like bignum or ratio
|
|
||||||
arithmetic, for example. I'm not convinced that it should include things like
|
|
||||||
hashmaps. If these things are to be written in Lisp, though, it means that
|
|
||||||
there have to be Lisp functions which manipulate memory a long way below the
|
|
||||||
'[don't know, don't care](Post-scarcity-software.md#store-name-and-value)'
|
|
||||||
dictum; this means that these functions have to be system private. But they
|
|
||||||
can be, because access control lists on arbitrary objects have always been
|
|
||||||
part of this architecture.
|
|
||||||
|
|
||||||
### The 0.1.0 branch
|
|
||||||
|
|
||||||
I'm therefore proposing, immediately, to upversion the `develop` branch to
|
|
||||||
0.1.0, and restart pretty much from scratch. For now, the C code will remain in
|
|
||||||
the development tree, and I may fix bugs which annoy me (and possibly other
|
|
||||||
people), but I doubt there now will be a 0.0.7 release, unless I decide that
|
|
||||||
the new substrate languages are a bust.
|
|
||||||
|
|
||||||
So release 0.1.0, which I'll target for 1<sup>st</sup> January 2027, will
|
|
||||||
essentially be a Lisp interpreter running on the new substrate and memory
|
|
||||||
architecture, without any significant new features.
|
|
||||||
|
|
||||||
See [0.1.0 design decisions](0-1-0-design-decisions.md) for more detail.
|
|
||||||
|
|
||||||
### Simulated hypercube
|
### Simulated hypercube
|
||||||
|
|
||||||
There is really no point to this whole project while it remains a single thread
|
There is really no point to this whole project while it remains a single thread running on a single processor. Until I can pass off computation to peer neighbours, I can't begin to understand what the right strategies are for when to do so.
|
||||||
running on a single processor. Until I can pass off computation to peer
|
|
||||||
neighbours, I can't begin to understand what the right strategies are for when
|
|
||||||
to do so.
|
|
||||||
|
|
||||||
`cond` is explicitly sequential, since later clauses should not be executed at
|
`cond` is explicitly sequential, since later clauses should not be executed at all if earlier ones succeed. `progn` is sort of implicitly sequential, since it's the value of the last form in the sequence which will be returned.
|
||||||
all if earlier ones succeed. `progn` is sort of implicitly sequential, since
|
|
||||||
it's the value of the last form in the sequence which will be returned.
|
|
||||||
|
|
||||||
For `mapcar`, the right strategy might be to partition the list argument
|
For `mapcar`, the right strategy might be to partition the list argument between each of the idle neighbours, and then reassemble the results that come bask.
|
||||||
between each of the idle neighbours, and then reassemble the results that come
|
|
||||||
bask.
|
|
||||||
|
|
||||||
For most other things, my hunch is that you pass args which are not
|
For most other things, my hunch is that you pass args which are not self-evaluating to idle neighbours, keeping (at least) one on the originating node to work on while they're busy.
|
||||||
self-evaluating to idle neighbours, keeping (at least) one on the originating
|
|
||||||
node to work on while they're busy.
|
|
||||||
|
|
||||||
But before that can happen, we need a router on each node which can monitor
|
But before that can happen, we need a router on each node which can monitor concurrent traffic on six bidirectional links. I think at least initially what gets written across those links is just S-expressions.
|
||||||
concurrent traffic on six bidirectional links. I think at least initially what
|
|
||||||
gets written across those links is just S-expressions.
|
|
||||||
|
|
||||||
I think a working simulated hypercube is the key milestone for version 0.2.0.
|
I think a working simulated hypercube is the key milestone for version 0.0.7.
|
||||||
|
|
||||||
### Sysout, sysin, and system persistance
|
### Sysout, sysin, and system persistance
|
||||||
|
|
||||||
Doctrine is that the post scarcity computing environment doesn't have a file
|
Doctrine is that the post scarcity computing environment doesn't have a file system, but nevertheless we need some way of making an image of a working system so that, after a catastrophic crash or a power outage, it can be brought back up to a known good state. This also really needs to be in 0.0.7.
|
||||||
system, but nevertheless we need some way of making an image of a working
|
|
||||||
system so that, after a catastrophic crash or a power outage, it can be brought
|
|
||||||
back up to a known good state. This really needs to be in 0.1.1.
|
|
||||||
|
|
||||||
### Better command line experience
|
### Better command line experience
|
||||||
|
|
||||||
The current command line experience is embarrassingly poor. Recallable input
|
The current command line experience is embarrassingly poor. Recallable input history, input line editing, and a proper structure editor are all things that I will need for my comfort.
|
||||||
history, input line editing, and a proper structure editor are all things that
|
|
||||||
I will need for my comfort.
|
|
||||||
|
|
||||||
### Users, groups and ACLs
|
### Users, groups and ACLs
|
||||||
|
|
||||||
Allowing multiple users to work together within the same post scarcity
|
Allowing multiple users to work together within the same post scarcity computing environment while retaining security and privacy is a major goal. So working out ways for users to sign on and be authenticated, and to configure their own environment, and to set up their own access control lists on objects they create, needs to be another nearish term goal. Probably 0.0.8.
|
||||||
computing environment while retaining security and privacy is a major goal. So
|
|
||||||
working out ways for users to sign on and be authenticated, and to configure
|
|
||||||
their own environment, and to set up their own access control lists on objects
|
|
||||||
they create, needs to be another nearish term goal. Probably 0.1.2.
|
|
||||||
|
|
||||||
### Homogeneities, regularities, slots, migration, permeability
|
### Homogeneities, regularities, slots, migration, permeability
|
||||||
|
|
||||||
There are a lot of good ideas about the categorisation and organisation of data
|
There are a lot of good ideas about the categorisation and organisation of data which are sketched in my original [Post scarcity software](Post-scarcity-software.md) essay which I've never really developed further because I didn't have the right software environment for them, which now I shall have. It would be good to build them.
|
||||||
which are sketched in my original
|
|
||||||
[Post scarcity software](Post-scarcity-software.md) essay which I've never
|
|
||||||
really developed further because I didn't have the right software environment
|
|
||||||
for them, which now I shall have. It would be good to build them.
|
|
||||||
|
|
||||||
### Compiler
|
### Compiler
|
||||||
|
|
||||||
I do want this system to have a compiler. I do want compiled functions to be
|
I do want this system to have a compiler. I do want compiled functions to be the default. And I do want to understand how to write my own compiler for a system like this. But until I know what the processor architecture of the system I'm targetting is, worrying too much about a compiler seems premature.
|
||||||
the default. And I do want to understand how to write my own compiler for a
|
|
||||||
system like this. But until I know what the processor architecture of the
|
|
||||||
system I'm targetting is, worrying too much about a compiler seems premature.
|
|
||||||
|
|
||||||
### Graphical User Interface
|
### Graphical User Interface
|
||||||
|
|
||||||
Ultimately I want a graphical user interface at least as fluid and flexible as
|
Ultimately I want a graphical user interface at least as fluid and flexible as what we had on Interlisp machines 40 years ago. It's not a near term goal there.
|
||||||
what we had on Interlisp machines 40 years ago. It's not a near term goal yet.
|
|
||||||
|
|
||||||
### Real hardware
|
### Real hardware
|
||||||
|
|
||||||
This machine would be **very** expensive to build, and there's no way I'm ever
|
This machine would be **very** expensive to build, and there's no way I'm ever going to afford more than a sixty-four node machine. But it would be nice to have software which would run effectively on a four billion node machine, if one could ever be built. I think that has to be the target for version 1.0.0.
|
||||||
going to afford more than a sixty-four node machine. But it would be nice to
|
|
||||||
have software which would run effectively on a four billion node machine, if
|
|
||||||
one could ever be built. I think that has to be the target for version 1.0.0.
|
|
||||||
|
|
@ -1,81 +1,5 @@
|
||||||
# State of Play
|
# State of Play
|
||||||
|
|
||||||
## 20260326
|
|
||||||
|
|
||||||
Most of the memory architecture of the new prototype is now roughed out, but
|
|
||||||
in C, not in a more modern language. It doesn't compile yet.
|
|
||||||
|
|
||||||
My C is getting better... but it needed to!
|
|
||||||
|
|
||||||
## 20260323
|
|
||||||
|
|
||||||
I started an investigastion of the [Zig language](https://ziglang.org/) and
|
|
||||||
come away frustrated. It's definitely an interesting language, and *I think*
|
|
||||||
one capable of doing what I want. But in trying to learn, I checked out
|
|
||||||
someone else's [Lisp interpreter in Zig](https://github.com/cryptocode/bio).
|
|
||||||
The last commit to this project is six months ago, so fairly current; project
|
|
||||||
documentation is polished, implying the project is well advanced and by someone
|
|
||||||
competent.
|
|
||||||
|
|
||||||
It won't build.
|
|
||||||
|
|
||||||
It won't build because there are breaking changes to the build system in the
|
|
||||||
current version of Zig, and, according to helpful people on the Zig language
|
|
||||||
Discord, breaking changes in Zig versions are quite frequent.
|
|
||||||
|
|
||||||
Post-scarcity is a project which procedes slowly, and is very large indeed. I
|
|
||||||
will certainly not complete it before I die.
|
|
||||||
|
|
||||||
I don't feel unstable tools are a good choice.
|
|
||||||
|
|
||||||
I have, however, done more thinking about [Paged space objects], and think I
|
|
||||||
now have a buildable specification.
|
|
||||||
|
|
||||||
## 20260319
|
|
||||||
|
|
||||||
Right, the `member?` bug [is fixed](https://git.journeyman.cc/simon/post-scarcity/issues/11).
|
|
||||||
There are, of course, lots more bugs. But I nevertheless propose to release
|
|
||||||
0.0.6 **now**, because there will always be more bugs, quite a lot works, and
|
|
||||||
I'm thinking about completely rearchitecting the memory system and, at the same
|
|
||||||
time, trying once more to move away from C.
|
|
||||||
|
|
||||||
The reasons are given in [this essay](The-worlds-slowest-ever-rapid-prototype.md).
|
|
||||||
|
|
||||||
This, of course, completely invalidates the [roadmap](Roadmap.md) that I wrote
|
|
||||||
less than a month ago, but that's because I really have been thinking seriously
|
|
||||||
about the future of this project.
|
|
||||||
|
|
||||||
## 20260316
|
|
||||||
|
|
||||||
OK, where we're at:
|
|
||||||
* The garbage collector is doing *even worse* than it was on 4th
|
|
||||||
February, when I did the last serious look at it.
|
|
||||||
* The bignum bugs are not fixed.
|
|
||||||
* You can (optionally) limit runaway stack crashes with a new command line option.
|
|
||||||
* If you enable the stack limiter feature, `(member? 5 '(1 2 3 4))` returns `nil`, as it should, and does not throw a stack limit exception, but if you do not enable it, `(member? 5 '(1 2 3 4))` causes a segfault. WTAF?
|
|
||||||
|
|
||||||
## 20260314
|
|
||||||
|
|
||||||
When I put a debugger on it, the stack limit bug proved shallow.
|
|
||||||
|
|
||||||
I'm tempted to further exercise my debugging skills by having another go at
|
|
||||||
the bignum arithmetic problems.
|
|
||||||
|
|
||||||
However, I've been rethinking the roadmap of the project, and written a long
|
|
||||||
[blog post about it](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/).
|
|
||||||
This isn't a finalised decision yet, but it is something I'm thinking about.
|
|
||||||
|
|
||||||
## 20260311
|
|
||||||
|
|
||||||
I've still been having trouble with runaway recursion — in `member`, but
|
|
||||||
due to a primitive bug I haven't identified — so this morning I've tried
|
|
||||||
to implement a stack limit feature. This has been a real fail at this stage.
|
|
||||||
Many more tests are breaking.
|
|
||||||
|
|
||||||
However, I think having a configurable stack limit would be a good thing, so
|
|
||||||
I'm not yet ready to abandon this feature. I need to work out why it's breaking
|
|
||||||
things.
|
|
||||||
|
|
||||||
## 20260226
|
## 20260226
|
||||||
|
|
||||||
The bug in `member` turned out to be because when a symbol is read by the reader,
|
The bug in `member` turned out to be because when a symbol is read by the reader,
|
||||||
|
|
|
||||||
|
|
@ -1,240 +0,0 @@
|
||||||
# Vector space, Pages, Mark-but-don't-sweep, and the world's slowest ever rapid prototype
|
|
||||||
|
|
||||||
By: Simon Brooke :: 13 March 2026
|
|
||||||
|
|
||||||
I started work on the Post-scarcity Software Environment on the second of January, 2017; which is to say, more than nine years ago. It was never intended to be a rapid prototype; it was intended, largely, to be a giant thought experiment. But now enough of it does work that I can see fundamental design mistakes, and I'm thinking about whether it's time to treat it as a rapid prototype: to take what has been learned from this code, and instead of trying to fix those mistakes, to start again from scratch.
|
|
||||||
|
|
||||||
So what are the mistakes?
|
|
||||||
|
|
||||||
## Allocating only cons-sized objects in pages
|
|
||||||
|
|
||||||
### What currently happens
|
|
||||||
|
|
||||||
The current post-scarcity prototype allocates objects that are the size of a cons cell in 'cons pages'. A cons page is an object that floats in vector space, which is to say the heap, which has a header to identify it, followed by an array of slots each of which is the size of a cons cell. When a cons page is initialised, each slot is initialised as a FREE object, and these are linked together onto the front of the global free list.
|
|
||||||
|
|
||||||
A cons pointer comprises a page part and an offset part. The exact size of these two parts is implementation dependent, but in the present implementation they're both uint32_t, which essentially means you can address four billion pages each of four billion slots; consequently, the size of the pointer is 64 bits, which means that the size of the payload of a cons cell is 128 bits. But a cons cell also needs a header to do housekeeping in, which is
|
|
||||||
|
|
||||||
struct cons_space_object {
|
|
||||||
union {
|
|
||||||
/** the tag (type) of this cell,
|
|
||||||
* considered as bytes */
|
|
||||||
char bytes[TAGLENGTH];
|
|
||||||
/** the tag considered as a number */
|
|
||||||
uint32_t value;
|
|
||||||
} tag;
|
|
||||||
/** the count of the number of references to this cell */
|
|
||||||
uint32_t count;
|
|
||||||
/** cons pointer to the access control list of this cell */
|
|
||||||
struct cons_pointer access;
|
|
||||||
//...
|
|
||||||
|
|
||||||
which is to say, 32 bits tag, 32 bits reference count, 64 bits access control list pointer, total 16 bytes. So the whole cell is 32 bytes.
|
|
||||||
|
|
||||||
We currently have nineteen different types of object which can fit into the size of the payload of a cons cell (plus FREE, which is sort of a non-object, but must exist), namely
|
|
||||||
|
|
||||||
|
|
||||||
| | Tag (byte string) | Tag (numeric) | Interpretation |
|
|
||||||
| ---- | ---- | ---- | ---- |
|
|
||||||
| 1 | CONS | 1397641027 | An ordinary cons cell. |
|
|
||||||
| 2 | EXEP | 1346721861 | An exception.|
|
|
||||||
| 3 | FREE | 1162170950 | An unallocated cell on the free list — should never be encountered by a Lisp function. |
|
|
||||||
| 4 | FUNC | 1129207110 | An ordinary Lisp function — one whose arguments are pre-evaluated. |
|
|
||||||
| 5 | INTR | 1381256777 | An integer number (bignums are integers). |
|
|
||||||
| 6 | KEYW | 1465468235 | A keyword — an interned, self-evaluating string. |
|
|
||||||
| 7 | LMDA | 1094995276 | A lambda cell. Lambdas are the interpretable (source) versions of functions.|
|
|
||||||
| 8 | LOOP | 1347374924 | A loop exit is a special kind of exception which has exactly the same payload as an exception.|
|
|
||||||
| 9 | NIL | 541870414 | The special cons cell at address {0,0} whose car and cdr both point to itself.|
|
|
||||||
| 10 | NLMD | 1145916494 | An nlambda cell. NLambdas are the interpretable (source) versions of special forms.|
|
|
||||||
| 11 | RTIO | 1330205778 | A rational number, stored as pointers to two integers representing dividend and divisor respectively|
|
|
||||||
| 12 | READ | 1145128274 | An open read stream.|
|
|
||||||
| 13 | REAL | 1279346002 | A real number, represented internally as an IEEE 754-2008 binary128.|
|
|
||||||
| 14 | SPFM | 1296453715 | A special form — one whose arguments are not pre-evaluated but passed as provided.|
|
|
||||||
| 15 | STRG | 1196577875 | A string of characters, organised as a linked list.|
|
|
||||||
| 16 | SYMB | 1112365395 | A symbol is just like a keyword except not self-evaluating.|
|
|
||||||
| 17 | TIME | 1162692948 | A time stamp, representing milliseconds since the big bang.|
|
|
||||||
| 18 | TRUE | 1163219540 | The special cons cell at address {0,1} which is canonically different from NIL.|
|
|
||||||
| 19 | VECP | 1346585942 | A pointer to an object in vector space.|
|
|
||||||
| 20 | WRIT | 1414091351 | An open write stream.|
|
|
||||||
|
|
||||||
Obviously it is absurdly wasteful to allocate 32 bits to a tag for twenty different types of object, but
|
|
||||||
|
|
||||||
1. The type system should be extensible; and
|
|
||||||
2. While debugging, it is useful to have human-readable mnemonics as tags.
|
|
||||||
|
|
||||||
But the point is, all these types of thing can be allocated into an identical footprint, which means that a cell can be popped off the free list and populated as any one of these; so that memory churn of objects of these types happens only in cons pages, not in the heap.
|
|
||||||
Why this is a good thing
|
|
||||||
|
|
||||||
Cons cells very often have quite transient life-cycles. They're allocated, and, in the majority of cases, deallocated, in the process of computation; of a single function call. Only a small minority of cons cells become parts of the values of interned symbols, and consequently retained in the long term. In other words, there is a lot of churn of cons cells. If you allocate and deallocate lots of small objects in the heap, the heap rapidly fragments, and then it becomes increasingly difficult to allocate new, larger objects.
|
|
||||||
|
|
||||||
But by organising them in pages with an internal free list, we can manage that churn in managed space, and only bother the heap allocator when all the cells in all the pages that we currently have allocated are themselves allocated.
|
|
||||||
|
|
||||||
Other objects which live in cons space, such as numbers, are also likely to experience considerable churn. Although I needed to solve the churn problem for cons cells, the fact that the same solution automatically generalises to all other cons space objects is a good thing.
|
|
||||||
### Why this needs to be different in future anyway
|
|
||||||
|
|
||||||
A two part cons pointer implies a single integrated address space, but in fact in a massively parallel machine we won't have that. In the final machine, the cons pointer would have to comprise three parts: a node part, a page part, and an offset part. And, indeed, in the next iteration of the project it ought to, because in the next iteration I do want to start experimenting with the hypercube topology. So actually, these parts are probably node: 32 bits; page; 8 bits; offset: 24 bits. So that you could have (in a fully populated machine) a hypercube of four billion nodes, each of which can locally address probably 256 pages each of sixteen million cells; and given that a cell is (currently) eight bytes, that's a total potential address space of 4,722,366,482,869,645,213,696 bytes, which is 4.7x1022, which is rather a lot.
|
|
||||||
|
|
||||||
You also need an additional cell type, CACH, a cache cell, a specialisation of CONS, whose first pointer points to the (foreign) cell which is cached, and whose second pointer points to the local (i.e. in this node's cons space) copy. When a non-local cell is first requested by EVAL,
|
|
||||||
|
|
||||||
1. the communications thread on the node requests it from the ('foreign') node which curates it;
|
|
||||||
2. the foreign node increments the reference counter on its copy;
|
|
||||||
3. the foreign node sends a representation of the content of the cell hoppity-hop across the grid to the requesting node;
|
|
||||||
4. the requesting node pops a cell off its local free list, writes into it the content it has received, increments its reference counter to one, pops a second cell off its free list, writes CACH into the tag, the address of the foreign cell into the first pointer, the address of the newly created copy into the second, and returns this second cell.
|
|
||||||
|
|
||||||
When the reference counter on a CACH cell is decremented to zero,
|
|
||||||
|
|
||||||
1. the communications thread on the requesting node notifies the curating node that the reference can be decremented;
|
|
||||||
2. the curating node decrements the reference and signals back that this has been done;
|
|
||||||
3. the requesting node clears both cells and pushes them back onto its free list.
|
|
||||||
|
|
||||||
### Why we should generalise this idea: stack frames
|
|
||||||
|
|
||||||
We currently allocate stack frames in vector space, which is to say on the heap. The payload of a stack frame is currently 96 bytes (eleven cons pointers plus two 32 bit integers):
|
|
||||||
|
|
||||||
```C
|
|
||||||
/*
|
|
||||||
* number of arguments stored in a stack frame
|
|
||||||
*/
|
|
||||||
#define args_in_frame 8
|
|
||||||
|
|
||||||
/**
|
|
||||||
* A stack frame. Yes, I know it isn't a cons-space object, but it's defined
|
|
||||||
* here to avoid circularity. \todo refactor.
|
|
||||||
*/
|
|
||||||
struct stack_frame {
|
|
||||||
/** the previous frame. */
|
|
||||||
struct cons_pointer previous;
|
|
||||||
/** first 8 arument bindings. */
|
|
||||||
struct cons_pointer arg[args_in_frame];
|
|
||||||
/** list of any further argument bindings. */
|
|
||||||
struct cons_pointer more;
|
|
||||||
/** the function to be called. */
|
|
||||||
struct cons_pointer function;
|
|
||||||
/** the number of arguments provided. */
|
|
||||||
int args;
|
|
||||||
/** the depth of the stack below this frame */
|
|
||||||
int depth;
|
|
||||||
};
|
|
||||||
```
|
|
||||||
|
|
||||||
But because it's a Lisp object in vector space it also needs a vector space object header, so that we can identify it and manage it:
|
|
||||||
|
|
||||||
```c
|
|
||||||
/**
|
|
||||||
* the header which forms the start of every vector space object.
|
|
||||||
*/
|
|
||||||
struct vector_space_header {
|
|
||||||
/** the tag (type) of this vector-space object. */
|
|
||||||
union {
|
|
||||||
/** the tag considered as bytes. */
|
|
||||||
char bytes[TAGLENGTH];
|
|
||||||
/** the tag considered as a number */
|
|
||||||
uint32_t value;
|
|
||||||
} tag;
|
|
||||||
/** back pointer to the vector pointer which uniquely points to this vso */
|
|
||||||
struct cons_pointer vecp;
|
|
||||||
/** the size of my payload, in bytes */
|
|
||||||
uint64_t size;
|
|
||||||
};
|
|
||||||
```
|
|
||||||
|
|
||||||
which is a further twenty bytes, so one hundred and sixteen bytes in total. We're allocating one of these objects every time we evaluate a function; we're deallocating one every time we leave a function. The present prototype will happily run up a stack of several tens of thousands of frames, and collapse it back down again, in a single recursive computation.
|
|
||||||
|
|
||||||
That's a lot of churn.
|
|
||||||
|
|
||||||
If we allocated stack frames in pages, in the same way that we allocate cons cells, that churn would never hit the heap allocator: we would not fragment the heap.
|
|
||||||
Generalising the generalisation
|
|
||||||
|
|
||||||
So we have one set of objects which are each 32 bytes, and one set which are each 116; and just as there are lots of things which are not cons cells which can be fitted into the payload footprint of a cons cell, so I suspect we may find, when we move on to implementing things like regularities, that there many things which are not stack frames which fit into the payload footprint of a stack frame, more or less.
|
|
||||||
|
|
||||||
But the size of a stack frame is closely coupled to the number of registers of the actual hardware of the processor on the node; and though if I ever get round to building an actual prototype that's probably ARM64, I like the idea that there should at least in theory be a custom processor for nodes that runs Lisp on the metal, as the Symbolics Ivory did.
|
|
||||||
|
|
||||||
So while a cons cell payload probably really is 128 bits for all time, a stack frame payload is more mutable. Eight argument registers and one 'more' register seems about right to me, but...
|
|
||||||
|
|
||||||
However, if we say we will have a number of standard sizes of paged objects; that every paged object shall have the same sized header; that all objects on any given page shall be the same size; and that all pages shall fit into the same footprint (that is to say, a page with larger objects must needs have proportionally fewer of them), then we can say that the standard payload sizes, in bytes, shall be powers of two, and that we don't allocate a page for a standard size until we have a request to allocate an object of that size.
|
|
||||||
|
|
||||||
So our standard sizes have payloads of 1, 2, 4, 8, 16, 32, 64, 128, 256, 512...
|
|
||||||
|
|
||||||
I've highlighted 16 because that will accommodate all our existing cons space objects; 32 because that will accommodate my current implementation of hash tables and namespaces,128 because that will accommodate stack frames... But actually, we would do a much more efficient implementation of hash tables if we allocated an object big enough to have a separate pointer for each bucket, so we probably already have a need for three distinct standard sizes of object, and, as I say, I see benefit of having a generalised scheme.
|
|
||||||
|
|
||||||
In the current prototype I'm allocating pages to fit only 1024 cons cells each, because I wanted to be able to test running a free list across multiple pages. My current idea of the final size of a cons page is that it should accommodate 16 million (224) cells, which is 134 million (227) bytes. So on the generalised scheme, we would be able in principle to allocate a single object of up to ~134 megabytes in a page that would fit sixteen million cells, and we would only need to introduce any fragmentation into the heap if we needed to allocate single objects larger than this.
|
|
||||||
|
|
||||||
That seems a very big win.
|
|
||||||
## Mark but don't sweep
|
|
||||||
|
|
||||||
The post scarcity architecture was designed around the idea of a reference counting garbage collector, and I have a very clear idea of how you can make tracking references, and collecting garbage, work across a hypercube
|
|
||||||
|
|
||||||
[^1]: I'm not certain I'm using the word hypercube strictly correctly; the topology I'm contemplating is more than three dimensions but fewer than four. However, the architecture would scale to fractal dimensions greater than four, although I think it would get progressively harder to physically build such machines as the dimensions increase.
|
|
||||||
|
|
||||||
in which pretty much every node is caching copies of objects which actually 'belong to', or are curated by, other nodes — provided that you can make reference counting work at all, which so far I'm struggling to do (but I think this is because I'm stupid, not because it's impossible).
|
|
||||||
|
|
||||||
I don't yet have a clear account of how you could make a non-reference counting garbage collector work across a distributed network.
|
|
||||||
|
|
||||||
However, I can see how, in having pages of equal sized objects, you can make garbage collection very much faster and can probably do it without even interrupting the evaluation thread.
|
|
||||||
|
|
||||||
Conventional mark and sweep garbage collectors — including generational garbage collectors — implement the following algorithm:
|
|
||||||
|
|
||||||
1. Halt execution of program evaluation;
|
|
||||||
2. Trace every single pointer on every single object in the generation being collected, and mark the object each points to;
|
|
||||||
3. Then go through every object in that generation, and those which have not been marked, schedule for overwriting;
|
|
||||||
4. Then move objects which have been marked downwards in memory to fill the voids left by objects which have not been marked (this is the sweeping phase);
|
|
||||||
5. Then correct all the pointers to all the objects which have been moved;
|
|
||||||
6. If that didn't recover enough memory, repeat for the previous generation, recursively;
|
|
||||||
7. Finally restart execution.
|
|
||||||
|
|
||||||
This is a really complicated operation and takes considerable time. It's this which is the main cause of the annoying pauses in programs which use automatic memory management. Of course, in a reference counting system, when you remove the last link to the top node of a large data structure, there is a cascade of decrements below it, but these can take place in a separate thread and do not have to interrupt program execution.
|
|
||||||
|
|
||||||
However, a large part of the cost of the mark-and-sweep algorithm is the sweep phase (and as I say, even generational systems have a sweep phase). The reason you need to sweep is to avoid fragmentation of the heap. If you allocate objects in equal sized pages each of equal sized objects, you can never fragment the heap, so (there is a problem here, but I'm going to ignore it for a moment and then come back to it), you never(ish) need to sweep.
|
|
||||||
|
|
||||||
You instead, when a page becomes full,
|
|
||||||
|
|
||||||
1. Don't halt program execution, but temporarily mark this page as locked (allocation can continue on other pages);
|
|
||||||
2. In a separate thread, trace all the links in this page and pages newer than this page to objects in this page, and mark those objects
|
|
||||||
1. Obviously, if while this is happening the execution thread makes a new link to something on the locked page, then that something needs to be marked;
|
|
||||||
3. Clear all the objects which have not been marked, and push them back onto the free list of the page;
|
|
||||||
4. If all the objects on this page are now on the free list, deallocate this page. Otherwise, remove the locked marker on this page (allocation can resume on this page).
|
|
||||||
|
|
||||||
Program execution never needs to halt. If the node hardware architecture has two cores, an execution core and a communications core, then garbage collection can run on the communications core, and execution doesn't even have to slow. If it proves in practice that this slows communications too much, then perhaps a third core is needed, or perhaps you shift garbage collection back to a separate thread on the evaluation core.
|
|
||||||
The problem
|
|
||||||
|
|
||||||
So, I said there was a problem. Obviously, a page which is empty (every object in it is FREE) can safely be deallocated, and another page, perhaps for objects of a different size, can later be allocated in the same real estate. The problem is that, in the worst case, you might end up with two (or more) pages for a given size of object each of which was less than half full, but neither of which was empty. I don't currently see how you can merge the two pages into one without doing a mark-and-sweep, and without interrupting execution.
|
|
||||||
|
|
||||||
Also, if another node is holding a pointer to an object on one of the two half-empty pages, then the housekeeping to maintain track of which nodes hold pointers to what, and where that has been moved to, becomes very awkward.
|
|
||||||
|
|
||||||
So it may be that a hypercube running mark-but-don't-sweep would eventually suffer from coronary artery disease, which would mean this architecture would be a bust. But it might also be that in practice this wouldn't happen; that newer pages — which is inevitably where churn would occur — would automatically empty and be deallocated in the normal course of computation. I don't know; it's quite likely but I certainly don't have a proof of it.
|
|
||||||
|
|
||||||
## The substrate language
|
|
||||||
|
|
||||||
### Emerging from the stone age
|
|
||||||
|
|
||||||
I started work on the post scarcity software environment, as I say, nine years ago. At that time Rust could not do unions, and I was not aware of Zig at all. I needed — or at least, I thought I needed (and still do think I need) a language in which to write the substrate from which Lisp could be bootstrapped: a language in which the memory management layer would be written.
|
|
||||||
|
|
||||||
I needed a language in which I could write as close to the metal as possible. I chose C, and because I'm allergic to the Byzantine complexity of C++, I chose plain old vanilla C. I've written large programs in C before, but it is not a language I'm comfortable with. When things break horribly in C — as they do — I really struggle. The thing which has really held development of this system back is that I tried to write bignum arithmetic in C, and I have utterly failed to get it working. And then spent literally years beating myself up about it.
|
|
||||||
|
|
||||||
I've also failed to get my garbage collector working to my satisfaction; I don't think I'm incrementing and decrementing counters where I should be, and I feel that far too much garbage is not being collected. But it sort of works. Well enough for now.
|
|
||||||
|
|
||||||
The solutions to these problems would probably be absurdly obvious to someone who is actually a good software engineer, rather than just cos-playing one, but they have proved beyond me.
|
|
||||||
|
|
||||||
I've been unwilling to change the substrate language, because I've done an awful lot of work in the memory architecture in C and up to now I've been pretty satisfied with that work; and because Rust still doesn't look very appealing to me; and because I really have not yet fully evaluated Zig.
|
|
||||||
|
|
||||||
However...
|
|
||||||
|
|
||||||
If I am going to do a big rewrite of the bottom layer of the memory allocation system, then it would make sense to write it in a more modern language.
|
|
||||||
A bootstrap made of bootstraps
|
|
||||||
|
|
||||||
But more! One of the things I'm thinking looking at what I've built so far is that I've tried to do too much in the substrate. Bignums could have been implemented — much more easily, and probably not much less efficiently — in the Lisp layer. So could rationals (and complex numbers, and all sorts of other fancy number systems). So could hash tables and namespaces and regularities and homogeneities and all the other fancy data structures that I want to build.
|
|
||||||
|
|
||||||
To do that, I would need a Lisp which had functions to do low level manipulation of memory structures, which is something I don't want 'user level' programmers to be able to do. But I already have a Lisp with access control lists on every data item, including functions. So it will be trivial to implement a :system privilege layer, and to have functions written at that :system privilege layer that most users would not be entitled to invoke.
|
|
||||||
Conclusion, for now
|
|
||||||
|
|
||||||
Of course, it's now the end of winter, and big software projects are, for me, these days, winter occupations; in summer there is too much to do outside.
|
|
||||||
|
|
||||||
But I think my plan now is to
|
|
||||||
|
|
||||||
1. get version 0.0.6 just a little bit more polished so that other people can — if they're mad enough — play with it; and then call the 0.0.X series done;
|
|
||||||
2. start again with a new 0.1.X series, with a much shallower substrate written probably in Zig, with generalised paged memory objects;
|
|
||||||
3. write the access control list system, something of a use authentication system, something of a privilege layer system;
|
|
||||||
4. write Lisp functions which can directly manipulate memory objects, and, within the paged memory objects framework, define completely new types of memory objects;
|
|
||||||
5. write the north, south, east, west, up, down internode communication channels, so that I can start patching together a virtual hypercube;
|
|
||||||
6. write a launcher (in some language) which can launch n3 instances of the same Lisp image as processes on a single conventional UN*X machine, stitch their channels together so that they can communicate, and allow clients to connect (probably over SSH) so that users can open REPL sessions.
|
|
||||||
|
|
||||||
If I ever get that completed, the next goal is probably a compiler, and the goal after that build a real physical hypercube of edge 2, probably using ARM or RISC-V processors.
|
|
||||||
|
|
@ -3,29 +3,6 @@
|
||||||
;; `nth` (from `nth.lisp`)
|
;; `nth` (from `nth.lisp`)
|
||||||
;; `string?` (from `types.lisp`)
|
;; `string?` (from `types.lisp`)
|
||||||
|
|
||||||
(set! nil? (lambda
|
|
||||||
(o)
|
|
||||||
"`(nil? object)`: Return `t` if object is `nil`, else `t`."
|
|
||||||
(= o nil)))
|
|
||||||
|
|
||||||
(set! member? (lambda
|
|
||||||
(item collection)
|
|
||||||
"`(member? item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
|
|
||||||
(cond
|
|
||||||
((= 0 (count collection)) nil)
|
|
||||||
((= item (car collection)) t)
|
|
||||||
(t (member? item (cdr collection))))))
|
|
||||||
|
|
||||||
;; (member? (type member?) '("LMDA" "NLMD"))
|
|
||||||
|
|
||||||
(set! nth (lambda (n l)
|
|
||||||
"Return the `n`th member of this list `l`, or `nil` if none."
|
|
||||||
(cond ((= nil l) nil)
|
|
||||||
((= n 1) (car l))
|
|
||||||
(t (nth (- n 1) (cdr l))))))
|
|
||||||
|
|
||||||
(set! string? (lambda (o) "True if `o` is a string." (= (type o) "STRG") ) )
|
|
||||||
|
|
||||||
(set! documentation (lambda (object)
|
(set! documentation (lambda (object)
|
||||||
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
||||||
(cond ((member? (type object) '("FUNC" "SPFM"))
|
(cond ((member? (type object) '("FUNC" "SPFM"))
|
||||||
|
|
@ -38,7 +15,3 @@
|
||||||
|
|
||||||
(set! doc documentation)
|
(set! doc documentation)
|
||||||
|
|
||||||
(documentation apply)
|
|
||||||
|
|
||||||
;; (documentation member?)
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,18 +1,14 @@
|
||||||
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
(set! nil? (lambda
|
||||||
|
(o)
|
||||||
|
"`(nil? object)`: Return `t` if object is `nil`, else `t`."
|
||||||
|
(= o nil)))
|
||||||
|
|
||||||
(set! CDR (lambda (o)
|
(set! member? (lambda
|
||||||
(print (list "in CDR; o is: " o) *log*)
|
|
||||||
(let ((r . (cdr o)))
|
|
||||||
(print (list "; returning: " r) *log*)
|
|
||||||
(println *log*)
|
|
||||||
(println *log*)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(set! member?
|
|
||||||
(lambda
|
|
||||||
(item collection)
|
(item collection)
|
||||||
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
|
"`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
|
||||||
(cond
|
(cond
|
||||||
((nil? collection) nil)
|
((nil? collection) nil)
|
||||||
((= item (car collection)) t)
|
((= item (car collection)) t)
|
||||||
(t (member? item (cdr collection))))))
|
(t (member? item (cdr collection))))))
|
||||||
|
|
||||||
|
;; (member? (type member?) '("LMDA" "NLMD"))
|
||||||
|
|
|
||||||
|
|
@ -210,7 +210,7 @@ __int128_t int128_to_integer( __int128_t val,
|
||||||
|
|
||||||
if ( integerp( less_significant ) ) {
|
if ( integerp( less_significant ) ) {
|
||||||
struct cons_space_object *lsc = &pointer2cell( less_significant );
|
struct cons_space_object *lsc = &pointer2cell( less_significant );
|
||||||
// inc_ref( new );
|
inc_ref( new );
|
||||||
lsc->payload.integer.more = new;
|
lsc->payload.integer.more = new;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -226,10 +226,23 @@ struct cons_pointer add_integers( struct cons_pointer a,
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_pointer cursor = NIL;
|
struct cons_pointer cursor = NIL;
|
||||||
|
|
||||||
|
debug_print( L"add_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 );
|
||||||
|
|
||||||
__int128_t carry = 0;
|
__int128_t carry = 0;
|
||||||
bool is_first_cell = true;
|
bool is_first_cell = true;
|
||||||
|
|
||||||
while ( integerp( a ) || integerp( b ) || carry != 0 ) {
|
if ( integerp( a ) && integerp( b ) ) {
|
||||||
|
debug_print( L"add_integers: \n", DEBUG_ARITH );
|
||||||
|
debug_dump_object( a, DEBUG_ARITH );
|
||||||
|
debug_print( L" plus \n", DEBUG_ARITH );
|
||||||
|
debug_dump_object( b, DEBUG_ARITH );
|
||||||
|
debug_println( DEBUG_ARITH );
|
||||||
|
|
||||||
|
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
|
||||||
__int128_t av = cell_value( a, '+', is_first_cell );
|
__int128_t av = cell_value( a, '+', is_first_cell );
|
||||||
__int128_t bv = cell_value( b, '+', is_first_cell );
|
__int128_t bv = cell_value( b, '+', is_first_cell );
|
||||||
__int128_t rv = ( av + bv ) + carry;
|
__int128_t rv = ( av + bv ) + carry;
|
||||||
|
|
@ -244,8 +257,9 @@ struct cons_pointer add_integers( struct cons_pointer a,
|
||||||
debug_print_128bit( rv, DEBUG_ARITH );
|
debug_print_128bit( rv, DEBUG_ARITH );
|
||||||
debug_print( L"\n", DEBUG_ARITH );
|
debug_print( L"\n", DEBUG_ARITH );
|
||||||
|
|
||||||
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
|
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT ) {
|
||||||
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
|
result =
|
||||||
|
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
|
||||||
break;
|
break;
|
||||||
} else {
|
} else {
|
||||||
struct cons_pointer new = make_integer( 0, NIL );
|
struct cons_pointer new = make_integer( 0, NIL );
|
||||||
|
|
@ -261,6 +275,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
|
||||||
is_first_cell = false;
|
is_first_cell = false;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
}
|
||||||
|
|
||||||
debug_print( L"add_integers returning: ", DEBUG_ARITH );
|
debug_print( L"add_integers returning: ", DEBUG_ARITH );
|
||||||
debug_print_object( result, DEBUG_ARITH );
|
debug_print_object( result, DEBUG_ARITH );
|
||||||
|
|
|
||||||
19
src/debug.c
19
src/debug.c
|
|
@ -32,25 +32,6 @@
|
||||||
*/
|
*/
|
||||||
int verbosity = 0;
|
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`.
|
* @brief print this debug `message` to stderr, if `verbosity` matches `level`.
|
||||||
*
|
*
|
||||||
|
|
|
||||||
|
|
@ -79,16 +79,8 @@
|
||||||
*/
|
*/
|
||||||
#define DEBUG_STACK 256
|
#define DEBUG_STACK 256
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief Print messages about equality tests.
|
|
||||||
*
|
|
||||||
* Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
|
|
||||||
*/
|
|
||||||
#define DEBUG_EQUAL 512
|
|
||||||
|
|
||||||
extern int verbosity;
|
extern int verbosity;
|
||||||
|
|
||||||
void debug_print_exception( struct cons_pointer ex_ptr );
|
|
||||||
void debug_print( wchar_t *message, int level );
|
void debug_print( wchar_t *message, int level );
|
||||||
void debug_print_128bit( __int128_t n, int level );
|
void debug_print_128bit( __int128_t n, int level );
|
||||||
void debug_println( int level );
|
void debug_println( int level );
|
||||||
|
|
|
||||||
73
src/init.c
73
src/init.c
|
|
@ -47,12 +47,11 @@
|
||||||
*/
|
*/
|
||||||
struct cons_pointer check_exception( struct cons_pointer pointer,
|
struct cons_pointer check_exception( struct cons_pointer pointer,
|
||||||
char *location_descriptor ) {
|
char *location_descriptor ) {
|
||||||
struct cons_pointer result = pointer;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
|
struct cons_space_object *object = &pointer2cell( pointer );
|
||||||
|
|
||||||
if ( exceptionp( pointer ) ) {
|
if ( exceptionp( pointer ) ) {
|
||||||
struct cons_space_object *object = &pointer2cell( pointer );
|
|
||||||
result = NIL;
|
|
||||||
|
|
||||||
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
|
fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
|
||||||
URL_FILE *ustderr = file_to_url_file( stderr );
|
URL_FILE *ustderr = file_to_url_file( stderr );
|
||||||
fwide( stderr, 1 );
|
fwide( stderr, 1 );
|
||||||
|
|
@ -60,22 +59,27 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
|
||||||
free( ustderr );
|
free( ustderr );
|
||||||
|
|
||||||
dec_ref( pointer );
|
dec_ref( pointer );
|
||||||
|
} else {
|
||||||
|
result = pointer;
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
struct cons_pointer init_documentation_symbol = NIL;
|
||||||
|
struct cons_pointer init_name_symbol = NIL;
|
||||||
|
struct cons_pointer init_primitive_symbol = NIL;
|
||||||
|
|
||||||
void maybe_bind_init_symbols( ) {
|
void maybe_bind_init_symbols( ) {
|
||||||
if ( nilp( privileged_keyword_documentation ) ) {
|
if ( nilp( init_documentation_symbol ) ) {
|
||||||
privileged_keyword_documentation =
|
init_documentation_symbol =
|
||||||
c_string_to_lisp_keyword( L"documentation" );
|
c_string_to_lisp_keyword( L"documentation" );
|
||||||
}
|
}
|
||||||
if ( nilp( privileged_keyword_name ) ) {
|
if ( nilp( init_name_symbol ) ) {
|
||||||
privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
|
init_name_symbol = c_string_to_lisp_keyword( L"name" );
|
||||||
}
|
}
|
||||||
if ( nilp( privileged_keyword_primitive ) ) {
|
if ( nilp( init_primitive_symbol ) ) {
|
||||||
privileged_keyword_primitive =
|
init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" );
|
||||||
c_string_to_lisp_keyword( L"primitive" );
|
|
||||||
}
|
}
|
||||||
if ( nilp( privileged_symbol_nil ) ) {
|
if ( nilp( privileged_symbol_nil ) ) {
|
||||||
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
|
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
|
||||||
|
|
@ -90,17 +94,14 @@ void maybe_bind_init_symbols( ) {
|
||||||
privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
|
privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
|
||||||
}
|
}
|
||||||
if ( nilp( privileged_keyword_payload ) ) {
|
if ( nilp( privileged_keyword_payload ) ) {
|
||||||
privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" );
|
privileged_keyword_location = c_string_to_lisp_keyword( L"payload" );
|
||||||
}
|
|
||||||
if ( nilp( privileged_keyword_cause ) ) {
|
|
||||||
privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" );
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
void free_init_symbols( ) {
|
void free_init_symbols( ) {
|
||||||
dec_ref( privileged_keyword_documentation );
|
dec_ref( init_documentation_symbol );
|
||||||
dec_ref( privileged_keyword_name );
|
dec_ref( init_name_symbol );
|
||||||
dec_ref( privileged_keyword_primitive );
|
dec_ref( init_primitive_symbol );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -120,11 +121,10 @@ struct cons_pointer bind_function( wchar_t *name,
|
||||||
struct cons_pointer d = c_string_to_lisp_string( doc );
|
struct cons_pointer d = c_string_to_lisp_string( doc );
|
||||||
|
|
||||||
struct cons_pointer meta =
|
struct cons_pointer meta =
|
||||||
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
|
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
||||||
make_cons( make_cons( privileged_keyword_name, n ),
|
make_cons( make_cons( init_name_symbol, n ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( privileged_keyword_documentation,
|
( init_documentation_symbol, d ),
|
||||||
d ),
|
|
||||||
NIL ) ) );
|
NIL ) ) );
|
||||||
|
|
||||||
struct cons_pointer r =
|
struct cons_pointer r =
|
||||||
|
|
@ -150,11 +150,10 @@ struct cons_pointer bind_special( wchar_t *name,
|
||||||
struct cons_pointer d = c_string_to_lisp_string( doc );
|
struct cons_pointer d = c_string_to_lisp_string( doc );
|
||||||
|
|
||||||
struct cons_pointer meta =
|
struct cons_pointer meta =
|
||||||
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
|
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
||||||
make_cons( make_cons( privileged_keyword_name, n ),
|
make_cons( make_cons( init_name_symbol, n ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( privileged_keyword_documentation,
|
( init_documentation_symbol, d ),
|
||||||
d ),
|
|
||||||
NIL ) ) );
|
NIL ) ) );
|
||||||
|
|
||||||
struct cons_pointer r =
|
struct cons_pointer r =
|
||||||
|
|
@ -215,8 +214,6 @@ void print_options( FILE *stream ) {
|
||||||
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
|
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
|
||||||
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
|
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
|
||||||
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
|
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
|
||||||
fwprintf( stream,
|
|
||||||
L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" );
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
fwprintf( stream,
|
fwprintf( stream,
|
||||||
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
|
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
|
||||||
|
|
@ -229,8 +226,7 @@ void print_options( FILE *stream ) {
|
||||||
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
|
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
|
||||||
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
|
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
|
||||||
fwprintf( stream, L"\t\t128\tREPL;\n" );
|
fwprintf( stream, L"\t\t128\tREPL;\n" );
|
||||||
fwprintf( stream, L"\t\t256\tSTACK;\n" );
|
fwprintf( stream, L"\t\t256\tSTACK.\n" );
|
||||||
fwprintf( stream, L"\t\t512\tEQUAL.\n" );
|
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -250,7 +246,7 @@ int main( int argc, char *argv[] ) {
|
||||||
exit( 1 );
|
exit( 1 );
|
||||||
}
|
}
|
||||||
|
|
||||||
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
|
while ( ( option = getopt( argc, argv, "phdv:i:" ) ) != -1 ) {
|
||||||
switch ( option ) {
|
switch ( option ) {
|
||||||
case 'd':
|
case 'd':
|
||||||
dump_at_end = true;
|
dump_at_end = true;
|
||||||
|
|
@ -266,9 +262,6 @@ int main( int argc, char *argv[] ) {
|
||||||
case 'p':
|
case 'p':
|
||||||
show_prompt = true;
|
show_prompt = true;
|
||||||
break;
|
break;
|
||||||
case 's':
|
|
||||||
stack_limit = atoi( optarg );
|
|
||||||
break;
|
|
||||||
case 'v':
|
case 'v':
|
||||||
verbosity = atoi( optarg );
|
verbosity = atoi( optarg );
|
||||||
break;
|
break;
|
||||||
|
|
@ -332,7 +325,7 @@ int main( int argc, char *argv[] ) {
|
||||||
( c_string_to_lisp_keyword
|
( c_string_to_lisp_keyword
|
||||||
( L"url" ),
|
( L"url" ),
|
||||||
c_string_to_lisp_string
|
c_string_to_lisp_string
|
||||||
( L"system:standard output" ) ),
|
( L"system:standard output]" ) ),
|
||||||
NIL ) ), false );
|
NIL ) ), false );
|
||||||
bind_value( L"*log*",
|
bind_value( L"*log*",
|
||||||
make_write_stream( file_to_url_file( stderr ),
|
make_write_stream( file_to_url_file( stderr ),
|
||||||
|
|
@ -457,7 +450,7 @@ int main( int argc, char *argv[] ) {
|
||||||
&lisp_print );
|
&lisp_print );
|
||||||
bind_function( L"println",
|
bind_function( L"println",
|
||||||
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
|
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
|
||||||
&lisp_println );
|
&lisp_print );
|
||||||
bind_function( L"put!", L"", lisp_hashmap_put );
|
bind_function( L"put!", L"", lisp_hashmap_put );
|
||||||
bind_function( L"put-all!",
|
bind_function( L"put-all!",
|
||||||
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
|
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
|
||||||
|
|
@ -487,9 +480,7 @@ int main( int argc, char *argv[] ) {
|
||||||
bind_function( L"subtract",
|
bind_function( L"subtract",
|
||||||
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
||||||
&lisp_subtract );
|
&lisp_subtract );
|
||||||
bind_function( L"throw",
|
bind_function( L"throw", L"", &lisp_exception );
|
||||||
L"`(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).",
|
|
||||||
&lisp_exception );
|
|
||||||
bind_function( L"time",
|
bind_function( L"time",
|
||||||
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
|
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
|
||||||
&lisp_time );
|
&lisp_time );
|
||||||
|
|
@ -537,9 +528,7 @@ int main( int argc, char *argv[] ) {
|
||||||
bind_special( L"set!",
|
bind_special( L"set!",
|
||||||
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
|
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
|
||||||
&lisp_set_shriek );
|
&lisp_set_shriek );
|
||||||
bind_special( L"try",
|
bind_special( L"try", L"", &lisp_try );
|
||||||
L"`(try forms... (catch catch-forms...))`: Evaluate `forms` sequentially, and return the value of the last. If an exception is thrown in any, evaluate `catch-forms` sequentially in an environment in which `*exception*` is bound to that exception, and return the value of the last of these.",
|
|
||||||
&lisp_try );
|
|
||||||
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
|
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
|
||||||
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
|
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -101,7 +101,7 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
|
||||||
struct cons_pointer key = c_car( ks );
|
struct cons_pointer key = c_car( ks );
|
||||||
print( output, key );
|
print( output, key );
|
||||||
url_fputwc( btowc( ' ' ), output );
|
url_fputwc( btowc( ' ' ), output );
|
||||||
print( output, hashmap_get( map, key, false ) );
|
print( output, hashmap_get( map, key ) );
|
||||||
|
|
||||||
if ( !nilp( c_cdr( ks ) ) ) {
|
if ( !nilp( c_cdr( ks ) ) ) {
|
||||||
url_fputws( L", ", output );
|
url_fputws( L", ", output );
|
||||||
|
|
@ -348,8 +348,17 @@ lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
if ( writep( out_stream ) ) {
|
if ( writep( out_stream ) ) {
|
||||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||||
|
inc_ref( out_stream );
|
||||||
|
} else {
|
||||||
|
output = file_to_url_file( stderr );
|
||||||
|
}
|
||||||
|
|
||||||
println( output );
|
println( output );
|
||||||
|
|
||||||
|
if ( writep( out_stream ) ) {
|
||||||
|
dec_ref( out_stream );
|
||||||
|
} else {
|
||||||
|
free( output );
|
||||||
}
|
}
|
||||||
|
|
||||||
return NIL;
|
return NIL;
|
||||||
|
|
|
||||||
|
|
@ -65,11 +65,7 @@ struct cons_page *conspages[NCONSPAGES];
|
||||||
* that exception would have to have been pre-built.
|
* that exception would have to have been pre-built.
|
||||||
*/
|
*/
|
||||||
void make_cons_page( ) {
|
void make_cons_page( ) {
|
||||||
struct cons_page *result = NULL;
|
struct cons_page *result = malloc( sizeof( struct cons_page ) );
|
||||||
|
|
||||||
if ( initialised_cons_pages < NCONSPAGES ) {
|
|
||||||
result = malloc( sizeof( struct cons_page ) );
|
|
||||||
}
|
|
||||||
|
|
||||||
if ( result != NULL ) {
|
if ( result != NULL ) {
|
||||||
conspages[initialised_cons_pages] = result;
|
conspages[initialised_cons_pages] = result;
|
||||||
|
|
@ -120,12 +116,12 @@ void make_cons_page( ) {
|
||||||
|
|
||||||
initialised_cons_pages++;
|
initialised_cons_pages++;
|
||||||
} else {
|
} else {
|
||||||
fwide( stderr, 1 );
|
debug_printf( DEBUG_ALLOC,
|
||||||
fwprintf( stderr,
|
|
||||||
L"FATAL: Failed to allocate memory for cons page %d\n",
|
L"FATAL: Failed to allocate memory for cons page %d\n",
|
||||||
initialised_cons_pages );
|
initialised_cons_pages );
|
||||||
exit( 1 );
|
exit( 1 );
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -254,9 +250,8 @@ struct cons_pointer allocate_cell( uint32_t tag ) {
|
||||||
total_cells_allocated++;
|
total_cells_allocated++;
|
||||||
|
|
||||||
debug_printf( DEBUG_ALLOC,
|
debug_printf( DEBUG_ALLOC,
|
||||||
L"Allocated cell of type %4.4s at %u, %u \n",
|
L"Allocated cell of type '%4.4s' at %d, %d \n",
|
||||||
( ( char * ) cell->tag.bytes ), result.page,
|
cell->tag.bytes, result.page, result.offset );
|
||||||
result.offset );
|
|
||||||
} else {
|
} else {
|
||||||
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
|
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -39,32 +39,6 @@ struct cons_pointer privileged_keyword_location = NIL;
|
||||||
*/
|
*/
|
||||||
struct cons_pointer privileged_keyword_payload = NIL;
|
struct cons_pointer privileged_keyword_payload = NIL;
|
||||||
|
|
||||||
/**
|
|
||||||
* Keywords used when constructing exceptions: `:payload`. Instantiated in
|
|
||||||
* `init.c`, q.v.
|
|
||||||
*/
|
|
||||||
struct cons_pointer privileged_keyword_cause = NIL;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:documentation`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*
|
|
||||||
*/
|
|
||||||
struct cons_pointer privileged_keyword_documentation = NIL;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:name`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*/
|
|
||||||
struct cons_pointer privileged_keyword_name = NIL;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:primitive`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*/
|
|
||||||
struct cons_pointer privileged_keyword_primitive = NIL;
|
|
||||||
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* True if the value of the tag on the cell at this `pointer` is this `value`,
|
* True if the value of the tag on the cell at this `pointer` is this `value`,
|
||||||
* or, if the tag of the cell is `VECP`, if the value of the tag of the
|
* or, if the tag of the cell is `VECP`, if the value of the tag of the
|
||||||
|
|
@ -104,7 +78,7 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
|
||||||
cell->count++;
|
cell->count++;
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_printf( DEBUG_ALLOC,
|
debug_printf( DEBUG_ALLOC,
|
||||||
L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
|
L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d",
|
||||||
( ( char * ) cell->tag.bytes ), pointer.page,
|
( ( char * ) cell->tag.bytes ), pointer.page,
|
||||||
pointer.offset, cell->count );
|
pointer.offset, cell->count );
|
||||||
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
|
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
|
||||||
|
|
@ -157,19 +131,6 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
|
||||||
return pointer;
|
return pointer;
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
|
||||||
* given a cons_pointer as argument, return the tag.
|
|
||||||
*/
|
|
||||||
uint32_t get_tag_value( struct cons_pointer pointer ) {
|
|
||||||
uint32_t result = pointer2cell( pointer ).tag.value;
|
|
||||||
|
|
||||||
if ( result == VECTORPOINTTV ) {
|
|
||||||
result = pointer_to_vso( pointer )->header.tag.value;
|
|
||||||
}
|
|
||||||
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Get the Lisp type of the single argument.
|
* Get the Lisp type of the single argument.
|
||||||
* @param pointer a pointer to the object whose type is requested.
|
* @param pointer a pointer to the object whose type is requested.
|
||||||
|
|
@ -438,15 +399,15 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
|
||||||
if ( tag == SYMBOLTV || tag == KEYTV ) {
|
if ( tag == SYMBOLTV || tag == KEYTV ) {
|
||||||
result = make_string_like_thing( c, tail, tag );
|
result = make_string_like_thing( c, tail, tag );
|
||||||
|
|
||||||
// if ( tag == KEYTV ) {
|
if ( tag == KEYTV ) {
|
||||||
// struct cons_pointer r = interned( result, oblist );
|
struct cons_pointer r = interned( result, oblist );
|
||||||
|
|
||||||
// if ( nilp( r ) ) {
|
if ( nilp( r ) ) {
|
||||||
// intern( result, oblist );
|
intern( result, oblist );
|
||||||
// } else {
|
} else {
|
||||||
// result = r;
|
result = r;
|
||||||
// }
|
}
|
||||||
// }
|
}
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
make_exception( c_string_to_lisp_string
|
make_exception( c_string_to_lisp_string
|
||||||
|
|
|
||||||
|
|
@ -68,30 +68,6 @@ extern struct cons_pointer privileged_keyword_location;
|
||||||
*/
|
*/
|
||||||
extern struct cons_pointer privileged_keyword_payload;
|
extern struct cons_pointer privileged_keyword_payload;
|
||||||
|
|
||||||
/**
|
|
||||||
* Keywords used when constructing exceptions: `:cause`. Instantiated in
|
|
||||||
* `init.c`.
|
|
||||||
*/
|
|
||||||
extern struct cons_pointer privileged_keyword_cause;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:documentation`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*/
|
|
||||||
extern struct cons_pointer privileged_keyword_documentation;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:name`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*/
|
|
||||||
extern struct cons_pointer privileged_keyword_name;
|
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief keywords used in documentation: `:primitive`. Instantiated in
|
|
||||||
* `init.c`, q. v.
|
|
||||||
*/
|
|
||||||
extern struct cons_pointer privileged_keyword_primitive;
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* An unallocated cell on the free list - should never be encountered by a Lisp
|
* An unallocated cell on the free list - should never be encountered by a Lisp
|
||||||
* function.
|
* function.
|
||||||
|
|
@ -225,7 +201,7 @@ extern struct cons_pointer privileged_keyword_primitive;
|
||||||
#define READTV 1145128274
|
#define READTV 1145128274
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* A real number, represented internally as an IEEE 754-2008 `binary128`.
|
* A real number, represented internally as an IEEE 754-2008 `binary64`.
|
||||||
*/
|
*/
|
||||||
#define REALTAG "REAL"
|
#define REALTAG "REAL"
|
||||||
|
|
||||||
|
|
@ -257,7 +233,7 @@ extern struct cons_pointer privileged_keyword_primitive;
|
||||||
#define STRINGTV 1196577875
|
#define STRINGTV 1196577875
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* A symbol is just like a keyword except not self-evaluating.
|
* A symbol is just like a string except not self-evaluating.
|
||||||
*/
|
*/
|
||||||
#define SYMBOLTAG "SYMB"
|
#define SYMBOLTAG "SYMB"
|
||||||
|
|
||||||
|
|
@ -332,6 +308,11 @@ extern struct cons_pointer privileged_keyword_primitive;
|
||||||
*/
|
*/
|
||||||
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
|
#define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset]))
|
||||||
|
|
||||||
|
/**
|
||||||
|
* given a cons_pointer as argument, return the tag.
|
||||||
|
*/
|
||||||
|
#define get_tag_value(conspoint) ((pointer2cell(conspoint)).tag.value)
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* true if `conspoint` points to the special cell NIL, else false
|
* true if `conspoint` points to the special cell NIL, else false
|
||||||
* (there should only be one of these so it's slightly redundant).
|
* (there should only be one of these so it's slightly redundant).
|
||||||
|
|
@ -480,8 +461,6 @@ struct stack_frame {
|
||||||
struct cons_pointer function;
|
struct cons_pointer function;
|
||||||
/** the number of arguments provided. */
|
/** the number of arguments provided. */
|
||||||
int args;
|
int args;
|
||||||
/** the depth of the stack below this frame */
|
|
||||||
int depth;
|
|
||||||
};
|
};
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -748,11 +727,6 @@ struct cons_pointer inc_ref( struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer dec_ref( struct cons_pointer pointer );
|
struct cons_pointer dec_ref( struct cons_pointer pointer );
|
||||||
|
|
||||||
/**
|
|
||||||
* given a cons_pointer as argument, return the tag.
|
|
||||||
*/
|
|
||||||
uint32_t get_tag_value( struct cons_pointer pointer );
|
|
||||||
|
|
||||||
struct cons_pointer c_type( struct cons_pointer pointer );
|
struct cons_pointer c_type( struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer c_car( struct cons_pointer arg );
|
struct cons_pointer c_car( struct cons_pointer arg );
|
||||||
|
|
|
||||||
|
|
@ -26,18 +26,12 @@
|
||||||
#include "memory/vectorspace.h"
|
#include "memory/vectorspace.h"
|
||||||
#include "ops/lispops.h"
|
#include "ops/lispops.h"
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief If non-zero, maximum depth of stack.
|
|
||||||
*
|
|
||||||
*/
|
|
||||||
uint32_t stack_limit = 0;
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* set a register in a stack frame. Alwaye use this to do so,
|
* set a register in a stack frame. Alwaye use this to do so,
|
||||||
* because that way we can be sure the inc_ref happens!
|
* because that way we can be sure the inc_ref happens!
|
||||||
*/
|
*/
|
||||||
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
|
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
|
||||||
debug_printf( DEBUG_STACK, L"\tSetting register %d to ", reg );
|
debug_printf( DEBUG_STACK, L"Setting register %d to ", reg );
|
||||||
debug_print_object( value, DEBUG_STACK );
|
debug_print_object( value, DEBUG_STACK );
|
||||||
debug_println( DEBUG_STACK );
|
debug_println( DEBUG_STACK );
|
||||||
dec_ref( frame->arg[reg] ); /* if there was anything in that slot
|
dec_ref( frame->arg[reg] ); /* if there was anything in that slot
|
||||||
|
|
@ -63,11 +57,10 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
|
||||||
|
|
||||||
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
|
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
|
||||||
result = ( struct stack_frame * ) &( vso->payload );
|
result = ( struct stack_frame * ) &( vso->payload );
|
||||||
// debug_printf( DEBUG_STACK,
|
debug_printf( DEBUG_STACK,
|
||||||
// L"\nget_stack_frame: all good, returning %p\n", result );
|
L"get_stack_frame: all good, returning %p\n", result );
|
||||||
} else {
|
} else {
|
||||||
debug_print( L"\nget_stack_frame: fail, returning NULL\n",
|
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
|
||||||
DEBUG_STACK );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
|
|
@ -75,19 +68,17 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Make an empty stack frame, and return it.
|
* Make an empty stack frame, and return it.
|
||||||
*
|
|
||||||
* This function does the actual meat of making the frame.
|
|
||||||
*
|
|
||||||
* @param previous the current top-of-stack;
|
* @param previous the current top-of-stack;
|
||||||
* @param depth the depth of the new frame.
|
* @param env the environment in which evaluation happens.
|
||||||
* @return the new frame, or NULL if memory is exhausted.
|
* @return the new frame, or NULL if memory is exhausted.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
|
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
|
||||||
uint32_t depth ) {
|
|
||||||
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
|
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
|
||||||
struct cons_pointer result =
|
struct cons_pointer result =
|
||||||
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
|
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
|
||||||
|
|
||||||
|
debug_dump_object( result, DEBUG_ALLOC );
|
||||||
|
|
||||||
if ( !nilp( result ) ) {
|
if ( !nilp( result ) ) {
|
||||||
struct stack_frame *frame = get_stack_frame( result );
|
struct stack_frame *frame = get_stack_frame( result );
|
||||||
/*
|
/*
|
||||||
|
|
@ -95,11 +86,10 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
|
||||||
*/
|
*/
|
||||||
|
|
||||||
frame->previous = previous;
|
frame->previous = previous;
|
||||||
frame->depth = depth;
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* The frame has already been cleared with memset in make_vso, but our
|
* clearing the frame with memset would probably be slightly quicker, but
|
||||||
* NIL is not the same as C's NULL.
|
* this is clear.
|
||||||
*/
|
*/
|
||||||
frame->more = NIL;
|
frame->more = NIL;
|
||||||
frame->function = NIL;
|
frame->function = NIL;
|
||||||
|
|
@ -108,8 +98,6 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
|
||||||
for ( int i = 0; i < args_in_frame; i++ ) {
|
for ( int i = 0; i < args_in_frame; i++ ) {
|
||||||
frame->arg[i] = NIL;
|
frame->arg[i] = NIL;
|
||||||
}
|
}
|
||||||
|
|
||||||
debug_dump_object( result, DEBUG_ALLOC );
|
|
||||||
}
|
}
|
||||||
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
|
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
|
||||||
debug_dump_object( result, DEBUG_ALLOC );
|
debug_dump_object( result, DEBUG_ALLOC );
|
||||||
|
|
@ -117,39 +105,6 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
|
||||||
* @brief Make an empty stack frame, and return it.
|
|
||||||
*
|
|
||||||
* This function does the error checking around actual construction.
|
|
||||||
*
|
|
||||||
* @param previous the current top-of-stack;
|
|
||||||
* @param env the environment in which evaluation happens.
|
|
||||||
* @return the new frame, or NULL if memory is exhausted.
|
|
||||||
*/
|
|
||||||
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
|
|
||||||
struct cons_pointer result = NIL;
|
|
||||||
uint32_t depth =
|
|
||||||
( nilp( previous ) ) ? 0 : ( get_stack_frame( previous ) )->depth + 1;
|
|
||||||
|
|
||||||
if ( stack_limit == 0 || stack_limit > depth ) {
|
|
||||||
result = in_make_empty_frame( previous, depth );
|
|
||||||
} else {
|
|
||||||
debug_printf( DEBUG_STACK,
|
|
||||||
L"WARNING: Exceeded stack limit of %d\n", stack_limit );
|
|
||||||
result =
|
|
||||||
make_exception( c_string_to_lisp_string
|
|
||||||
( L"Stack limit exceeded." ), previous );
|
|
||||||
}
|
|
||||||
|
|
||||||
if ( nilp( result ) ) {
|
|
||||||
/* i.e. out of memory */
|
|
||||||
result =
|
|
||||||
make_exception( privileged_string_memory_exhausted, previous );
|
|
||||||
}
|
|
||||||
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Allocate a new stack frame with its previous pointer set to this value,
|
* Allocate a new stack frame with its previous pointer set to this value,
|
||||||
* its arguments set up from these args, evaluated in this env.
|
* its arguments set up from these args, evaluated in this env.
|
||||||
|
|
@ -164,7 +119,11 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
|
||||||
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
|
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
|
||||||
struct cons_pointer result = make_empty_frame( previous );
|
struct cons_pointer result = make_empty_frame( previous );
|
||||||
|
|
||||||
if ( !exceptionp( result ) ) {
|
if ( nilp( result ) ) {
|
||||||
|
/* i.e. out of memory */
|
||||||
|
result =
|
||||||
|
make_exception( privileged_string_memory_exhausted, previous );
|
||||||
|
} else {
|
||||||
struct stack_frame *frame = get_stack_frame( result );
|
struct stack_frame *frame = get_stack_frame( result );
|
||||||
|
|
||||||
while ( frame->args < args_in_frame && consp( args ) ) {
|
while ( frame->args < args_in_frame && consp( args ) ) {
|
||||||
|
|
@ -185,10 +144,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
|
||||||
result = val;
|
result = val;
|
||||||
break;
|
break;
|
||||||
} else {
|
} else {
|
||||||
debug_printf( DEBUG_STACK, L"\tSetting argument %d to ",
|
debug_printf( DEBUG_STACK, L"Setting argument %d to ",
|
||||||
frame->args );
|
frame->args );
|
||||||
debug_print_object( cell.payload.cons.car, DEBUG_STACK );
|
debug_print_object( cell.payload.cons.car, DEBUG_STACK );
|
||||||
debug_print( L"\n", DEBUG_STACK );
|
|
||||||
set_reg( frame, frame->args, val );
|
set_reg( frame, frame->args, val );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -231,7 +189,12 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
|
||||||
|
|
||||||
struct cons_pointer result = make_empty_frame( previous );
|
struct cons_pointer result = make_empty_frame( previous );
|
||||||
|
|
||||||
if ( !exceptionp( result ) ) {
|
if ( nilp( result ) ) {
|
||||||
|
/* i.e. out of memory */
|
||||||
|
result =
|
||||||
|
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
|
||||||
|
previous );
|
||||||
|
} else {
|
||||||
struct stack_frame *frame = get_stack_frame( result );
|
struct stack_frame *frame = get_stack_frame( result );
|
||||||
|
|
||||||
while ( frame->args < args_in_frame && !nilp( args ) ) {
|
while ( frame->args < args_in_frame && !nilp( args ) ) {
|
||||||
|
|
@ -322,14 +285,14 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
|
||||||
struct stack_frame *frame = get_stack_frame( frame_pointer );
|
struct stack_frame *frame = get_stack_frame( frame_pointer );
|
||||||
|
|
||||||
if ( frame != NULL ) {
|
if ( frame != NULL ) {
|
||||||
url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
|
url_fwprintf( output, L"Stack frame with %d arguments:\n",
|
||||||
frame->depth, frame->args );
|
frame->args );
|
||||||
dump_frame_context( output, frame_pointer, 4 );
|
dump_frame_context( output, frame_pointer, 4 );
|
||||||
|
|
||||||
for ( int arg = 0; arg < frame->args; arg++ ) {
|
for ( int arg = 0; arg < frame->args; arg++ ) {
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
|
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
|
||||||
|
|
||||||
url_fwprintf( output, L"\tArg %d:\t%4.4s\tcount: %10u\tvalue: ",
|
url_fwprintf( output, L"Arg %d:\t%4.4s\tcount: %10u\tvalue: ",
|
||||||
arg, cell.tag.bytes, cell.count );
|
arg, cell.tag.bytes, cell.count );
|
||||||
|
|
||||||
print( output, frame->arg[arg] );
|
print( output, frame->arg[arg] );
|
||||||
|
|
|
||||||
|
|
@ -21,8 +21,6 @@
|
||||||
#ifndef __psse_stack_h
|
#ifndef __psse_stack_h
|
||||||
#define __psse_stack_h
|
#define __psse_stack_h
|
||||||
|
|
||||||
#include <stdint.h>
|
|
||||||
|
|
||||||
#include "consspaceobject.h"
|
#include "consspaceobject.h"
|
||||||
#include "conspage.h"
|
#include "conspage.h"
|
||||||
|
|
||||||
|
|
@ -37,8 +35,6 @@
|
||||||
*/
|
*/
|
||||||
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
|
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
|
||||||
|
|
||||||
extern uint32_t stack_limit;
|
|
||||||
|
|
||||||
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
|
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
|
||||||
|
|
||||||
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
|
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
|
||||||
|
|
|
||||||
|
|
@ -74,7 +74,7 @@ bool equal_ld_ld( long double a, long double b ) {
|
||||||
|
|
||||||
bool result = ( fabsl( a - b ) < tolerance );
|
bool result = ( fabsl( a - b ) < tolerance );
|
||||||
|
|
||||||
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
|
debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
@ -272,9 +272,7 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
|
|
||||||
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
||||||
struct cons_pointer key = c_car( i );
|
struct cons_pointer key = c_car( i );
|
||||||
if ( !equal
|
if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) {
|
||||||
( hashmap_get( a, key, false ),
|
|
||||||
hashmap_get( b, key, false ) ) ) {
|
|
||||||
result = false;
|
result = false;
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
@ -332,10 +330,10 @@ bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
* identical structure, else false.
|
* identical structure, else false.
|
||||||
*/
|
*/
|
||||||
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
debug_print( L"\nequal: ", DEBUG_EQUAL );
|
debug_print( L"\nequal: ", DEBUG_ARITH );
|
||||||
debug_print_object( a, DEBUG_EQUAL );
|
debug_print_object( a, DEBUG_ARITH );
|
||||||
debug_print( L" = ", DEBUG_EQUAL );
|
debug_print( L" = ", DEBUG_ARITH );
|
||||||
debug_print_object( b, DEBUG_EQUAL );
|
debug_print_object( b, DEBUG_ARITH );
|
||||||
|
|
||||||
bool result = false;
|
bool result = false;
|
||||||
|
|
||||||
|
|
@ -389,11 +387,11 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
}
|
}
|
||||||
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_print( L"Comparing '", DEBUG_EQUAL );
|
debug_print( L"Comparing '", DEBUG_ARITH );
|
||||||
debug_print( a_buff, DEBUG_EQUAL );
|
debug_print( a_buff, DEBUG_ARITH );
|
||||||
debug_print( L"' to '", DEBUG_EQUAL );
|
debug_print( L"' to '", DEBUG_ARITH );
|
||||||
debug_print( b_buff, DEBUG_EQUAL );
|
debug_print( b_buff, DEBUG_ARITH );
|
||||||
debug_print( L"'\n", DEBUG_EQUAL );
|
debug_print( L"'\n", DEBUG_ARITH );
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* OK, now we have wchar string buffers loaded from the objects. We
|
/* OK, now we have wchar string buffers loaded from the objects. We
|
||||||
|
|
@ -427,7 +425,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
* I'll ignore them, too, for now.
|
* I'll ignore them, too, for now.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
|
debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
283
src/ops/intern.c
283
src/ops/intern.c
|
|
@ -191,7 +191,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
|
||||||
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
|
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
|
||||||
pair = c_car( assoc ) ) {
|
pair = c_car( assoc ) ) {
|
||||||
/* TODO: this is really hammering the memory management system, because
|
/* TODO: this is really hammering the memory management system, because
|
||||||
* it will make a new clone for every key/value pair added. Fix. */
|
* it will make a new lone for every key/value pair added. Fix. */
|
||||||
if ( consp( pair ) ) {
|
if ( consp( pair ) ) {
|
||||||
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
|
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
|
||||||
} else if ( hashmapp( pair ) ) {
|
} else if ( hashmapp( pair ) ) {
|
||||||
|
|
@ -205,7 +205,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
|
||||||
for ( struct cons_pointer keys = hashmap_keys( assoc );
|
for ( struct cons_pointer keys = hashmap_keys( assoc );
|
||||||
!nilp( keys ); keys = c_cdr( keys ) ) {
|
!nilp( keys ); keys = c_cdr( keys ) ) {
|
||||||
struct cons_pointer key = c_car( keys );
|
struct cons_pointer key = c_car( keys );
|
||||||
hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
|
hashmap_put( mapp, key, hashmap_get( assoc, key ) );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
@ -216,33 +216,17 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
|
||||||
/** Get a value from a hashmap.
|
/** Get a value from a hashmap.
|
||||||
*
|
*
|
||||||
* Note that this is here, rather than in memory/hashmap.c, because it is
|
* Note that this is here, rather than in memory/hashmap.c, because it is
|
||||||
* closely tied in with search_store, q.v.
|
* closely tied in with c_assoc, q.v.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
||||||
struct cons_pointer key, bool return_key ) {
|
struct cons_pointer key ) {
|
||||||
#ifdef DEBUG
|
|
||||||
debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
|
|
||||||
debug_print_object( key, DEBUG_BIND );
|
|
||||||
debug_print( L"`; store of type `", DEBUG_BIND );
|
|
||||||
debug_print_object( c_type( mapp ), DEBUG_BIND );
|
|
||||||
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
|
|
||||||
return_key ? "key" : "value" );
|
|
||||||
#endif
|
|
||||||
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
|
if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
|
||||||
struct vector_space_object *map = pointer_to_vso( mapp );
|
struct vector_space_object *map = pointer_to_vso( mapp );
|
||||||
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
|
uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
|
||||||
|
|
||||||
result =
|
result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
|
||||||
search_store( key, map->payload.hashmap.buckets[bucket_no],
|
|
||||||
return_key );
|
|
||||||
}
|
}
|
||||||
#ifdef DEBUG
|
|
||||||
debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
|
|
||||||
debug_print_object( result, DEBUG_BIND );
|
|
||||||
debug_print( L"`\n", DEBUG_BIND );
|
|
||||||
#endif
|
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
@ -283,151 +267,84 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
// (keys set let quote read equal *out* *log* oblist cons source cond close meta mapcar negative? open subtract eval nλ *in* *sink* cdr set! reverse slurp try assoc eq add list time car t *prompt* absolute append apply divide exception get-hash hashmap inspect metadata multiply print put! put-all! read-char repl throw type + * - / = lambda λ nlambda progn)
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* @brief `(search-store key store return-key?)` Search this `store` for this
|
* If this key is lexically identical to a key in this store, return the key
|
||||||
* a key lexically identical to this `key`.
|
* from the store (so that later when we want to retrieve a value, an eq test
|
||||||
*
|
* will work); otherwise return NIL.
|
||||||
* If found, then, if `return-key?` is non-nil, return the copy found in the
|
|
||||||
* `store`, else return the value associated with it.
|
|
||||||
*
|
|
||||||
* At this stage the following structures are legal stores:
|
|
||||||
* 1. an association list comprising (key . value) dotted pairs;
|
|
||||||
* 2. a hashmap;
|
|
||||||
* 3. a namespace (which for these purposes is identical to a hashmap);
|
|
||||||
* 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
|
|
||||||
* level items;
|
|
||||||
* 5. such a hybrid list, but where the last CDR pointer is to a hashmap
|
|
||||||
* rather than to a cons sell or to `nil`.
|
|
||||||
*
|
|
||||||
* This is over-complex and type 5 should be disallowed, but it will do for
|
|
||||||
* now.
|
|
||||||
*/
|
*/
|
||||||
struct cons_pointer search_store( struct cons_pointer key,
|
struct cons_pointer interned( struct cons_pointer key,
|
||||||
struct cons_pointer store,
|
struct cons_pointer store ) {
|
||||||
bool return_key ) {
|
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
#ifdef DEBUG
|
debug_print( L"interned: Checking for interned value of `", DEBUG_BIND );
|
||||||
debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
|
|
||||||
debug_print_object( key, DEBUG_BIND );
|
debug_print_object( key, DEBUG_BIND );
|
||||||
debug_print( L"`; store of type `", DEBUG_BIND );
|
debug_print( L"`\n", DEBUG_BIND );
|
||||||
debug_print_object( c_type( store ), DEBUG_BIND );
|
|
||||||
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
|
|
||||||
return_key ? "key" : "value" );
|
|
||||||
#endif
|
|
||||||
|
|
||||||
switch ( get_tag_value( key ) ) {
|
if ( symbolp( key ) || keywordp( key ) ) {
|
||||||
case SYMBOLTV:
|
struct cons_space_object *cell = &pointer2cell( store );
|
||||||
case KEYTV:
|
|
||||||
struct cons_space_object *store_cell = &pointer2cell( store );
|
|
||||||
|
|
||||||
switch ( get_tag_value( store ) ) {
|
switch ( cell->tag.value ) {
|
||||||
case CONSTV:
|
case CONSTV:
|
||||||
for ( struct cons_pointer cursor = store;
|
for ( struct cons_pointer next = store;
|
||||||
nilp( result ) && ( consp( cursor )
|
nilp( result ) && consp( next ); next = c_cdr( next ) ) {
|
||||||
|| hashmapp( cursor ) );
|
if ( !nilp( next ) ) {
|
||||||
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
|
// struct cons_space_object entry =
|
||||||
switch ( get_tag_value( cursor ) ) {
|
// pointer2cell( c_car( next) );
|
||||||
case CONSTV:
|
|
||||||
struct cons_pointer entry_ptr =
|
|
||||||
c_car( cursor );
|
|
||||||
|
|
||||||
switch ( get_tag_value( entry_ptr ) ) {
|
if ( equal( key, c_car( next ) ) ) {
|
||||||
case CONSTV:
|
result = key;
|
||||||
if ( equal( key, c_car( entry_ptr ) ) ) {
|
}
|
||||||
result =
|
}
|
||||||
return_key ? c_car( entry_ptr )
|
|
||||||
: c_cdr( entry_ptr );
|
|
||||||
goto found;
|
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case HASHTV:
|
case VECTORPOINTTV:
|
||||||
case NAMESPACETV:
|
if ( hashmapp( store ) || namespacep( store ) ) {
|
||||||
result =
|
// get the right hash bucket and recursively call interned on that.
|
||||||
hashmap_get( entry_ptr, key,
|
struct vector_space_object *map = pointer_to_vso( store );
|
||||||
return_key );
|
uint32_t bucket_no =
|
||||||
break;
|
get_hash( key ) % map->payload.hashmap.n_buckets;
|
||||||
default:
|
|
||||||
result =
|
|
||||||
throw_exception
|
|
||||||
( c_string_to_lisp_symbol
|
|
||||||
( L"search-store (entry)" ),
|
|
||||||
make_cons
|
|
||||||
( c_string_to_lisp_string
|
|
||||||
( L"Unexpected store type: " ),
|
|
||||||
c_type( c_car( entry_ptr ) ) ),
|
|
||||||
NIL );
|
|
||||||
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case HASHTV:
|
|
||||||
case NAMESPACETV:
|
|
||||||
debug_print
|
|
||||||
( L"\n\tHashmap as top-level value in list",
|
|
||||||
DEBUG_BIND );
|
|
||||||
result =
|
result =
|
||||||
hashmap_get( cursor, key, return_key );
|
interned( key,
|
||||||
break;
|
map->payload.hashmap.buckets[bucket_no] );
|
||||||
default:
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_symbol
|
throw_exception( c_string_to_lisp_symbol
|
||||||
( L"search-store (cursor)" ),
|
( L"interned?" ),
|
||||||
make_cons
|
|
||||||
( c_string_to_lisp_string
|
|
||||||
( L"Unexpected store type: " ),
|
|
||||||
c_type( cursor ) ),
|
|
||||||
NIL );
|
|
||||||
}
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case HASHTV:
|
|
||||||
case NAMESPACETV:
|
|
||||||
result = hashmap_get( store, key, return_key );
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
result =
|
|
||||||
throw_exception( c_string_to_lisp_symbol
|
|
||||||
( L"search-store (store)" ),
|
|
||||||
make_cons( c_string_to_lisp_string
|
make_cons( c_string_to_lisp_string
|
||||||
( L"Unexpected store type: " ),
|
( L"Unexpected store type: " ),
|
||||||
c_type( store ) ), NIL );
|
c_type( store ) ), NIL );
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"interned?" ),
|
||||||
|
make_cons
|
||||||
|
( c_string_to_lisp_string
|
||||||
|
( L"Unexpected store type: " ),
|
||||||
|
c_type( store ) ), NIL );
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
break;
|
} else {
|
||||||
case EXCEPTIONTV:
|
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_symbol
|
throw_exception( c_string_to_lisp_symbol( L"interned?" ),
|
||||||
( L"search-store (exception)" ),
|
make_cons
|
||||||
make_cons( c_string_to_lisp_string
|
( c_string_to_lisp_string
|
||||||
( L"Unexpected key type: " ),
|
( L"Unexpected key type: " ), c_type( key ) ),
|
||||||
c_type( key ) ), NIL );
|
NIL );
|
||||||
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
result =
|
|
||||||
throw_exception( c_string_to_lisp_symbol
|
|
||||||
( L"search-store (key)" ),
|
|
||||||
make_cons( c_string_to_lisp_string
|
|
||||||
( L"Unexpected key type: " ),
|
|
||||||
c_type( key ) ), NIL );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
found:
|
debug_print( L"interned: returning `", DEBUG_BIND );
|
||||||
|
|
||||||
debug_print( L"search-store: returning `", DEBUG_BIND );
|
|
||||||
debug_print_object( result, DEBUG_BIND );
|
debug_print_object( result, DEBUG_BIND );
|
||||||
debug_print( L"`\n", DEBUG_BIND );
|
debug_print( L"`\n", DEBUG_BIND );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
struct cons_pointer interned( struct cons_pointer key,
|
|
||||||
struct cons_pointer store ) {
|
|
||||||
return search_store( key, store, true );
|
|
||||||
}
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* @brief Implementation of `interned?` in C.
|
* @brief Implementation of `interned?` in C: predicate wrapped around interned.
|
||||||
*
|
*
|
||||||
* @param key the key to search for.
|
* @param key the key to search for.
|
||||||
* @param store the store to search in.
|
* @param store the store to search in.
|
||||||
|
|
@ -435,36 +352,7 @@ struct cons_pointer interned( struct cons_pointer key,
|
||||||
*/
|
*/
|
||||||
struct cons_pointer internedp( struct cons_pointer key,
|
struct cons_pointer internedp( struct cons_pointer key,
|
||||||
struct cons_pointer store ) {
|
struct cons_pointer store ) {
|
||||||
struct cons_pointer result = NIL;
|
return nilp( interned( key, store ) ) ? NIL : TRUE;
|
||||||
|
|
||||||
if ( consp( store ) ) {
|
|
||||||
for ( struct cons_pointer pair = c_car( store );
|
|
||||||
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
|
|
||||||
if ( consp( pair ) ) {
|
|
||||||
if ( equal( c_car( pair ), key ) ) {
|
|
||||||
// yes, this should be `eq`, but if symbols are correctly
|
|
||||||
// interned this will work efficiently, and if not it will
|
|
||||||
// still work.
|
|
||||||
result = TRUE;
|
|
||||||
}
|
|
||||||
} else if ( hashmapp( pair ) ) {
|
|
||||||
result = internedp( key, pair );
|
|
||||||
}
|
|
||||||
|
|
||||||
store = c_cdr( store );
|
|
||||||
}
|
|
||||||
} else if ( hashmapp( store ) ) {
|
|
||||||
struct vector_space_object *map = pointer_to_vso( store );
|
|
||||||
|
|
||||||
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
|
|
||||||
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
|
|
||||||
!nilp( c ); c = c_cdr( c ) ) {
|
|
||||||
result = internedp( key, c );
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
return result;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -477,7 +365,68 @@ struct cons_pointer internedp( struct cons_pointer key,
|
||||||
*/
|
*/
|
||||||
struct cons_pointer c_assoc( struct cons_pointer key,
|
struct cons_pointer c_assoc( struct cons_pointer key,
|
||||||
struct cons_pointer store ) {
|
struct cons_pointer store ) {
|
||||||
return search_store( key, store, false );
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
|
if ( !nilp( key ) ) {
|
||||||
|
if ( consp( store ) ) {
|
||||||
|
for ( struct cons_pointer next = store;
|
||||||
|
nilp( result ) && ( consp( next ) || hashmapp( next ) );
|
||||||
|
next = pointer2cell( next ).payload.cons.cdr ) {
|
||||||
|
if ( consp( next ) ) {
|
||||||
|
// #ifdef DEBUG
|
||||||
|
// debug_print( L"\nc_assoc; key is `", DEBUG_BIND );
|
||||||
|
// debug_print_object( key, DEBUG_BIND );
|
||||||
|
// debug_print( L"`\n", DEBUG_BIND );
|
||||||
|
// #endif
|
||||||
|
|
||||||
|
struct cons_pointer entry_ptr = c_car( next );
|
||||||
|
struct cons_space_object entry = pointer2cell( entry_ptr );
|
||||||
|
|
||||||
|
switch ( entry.tag.value ) {
|
||||||
|
case CONSTV:
|
||||||
|
if ( equal( key, entry.payload.cons.car ) ) {
|
||||||
|
result = entry.payload.cons.cdr;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case VECTORPOINTTV:
|
||||||
|
result = hashmap_get( entry_ptr, key );
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
throw_exception( c_string_to_lisp_symbol
|
||||||
|
( L"assoc" ),
|
||||||
|
c_append( c_string_to_lisp_string
|
||||||
|
( L"Store entry is of unknown type: " ),
|
||||||
|
c_type( entry_ptr ) ),
|
||||||
|
NIL );
|
||||||
|
}
|
||||||
|
|
||||||
|
// #ifdef DEBUG
|
||||||
|
// debug_print( L"c_assoc `", DEBUG_BIND );
|
||||||
|
// debug_print_object( key, DEBUG_BIND );
|
||||||
|
// debug_print( L"` returning: ", DEBUG_BIND );
|
||||||
|
// debug_print_object( result, DEBUG_BIND );
|
||||||
|
// debug_println( DEBUG_BIND );
|
||||||
|
// #endif
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} else if ( hashmapp( store ) || namespacep( store ) ) {
|
||||||
|
result = hashmap_get( store, key );
|
||||||
|
} else if ( !nilp( store ) ) {
|
||||||
|
// #ifdef DEBUG
|
||||||
|
// debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
|
||||||
|
// debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes);
|
||||||
|
// debug_print( L"`\n", DEBUG_BIND );
|
||||||
|
// #endif
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"assoc" ),
|
||||||
|
c_append
|
||||||
|
( c_string_to_lisp_string
|
||||||
|
( L"Store is of unknown type: " ),
|
||||||
|
c_type( store ) ), NIL );
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
|
||||||
|
|
@ -20,9 +20,6 @@
|
||||||
#ifndef __intern_h
|
#ifndef __intern_h
|
||||||
#define __intern_h
|
#define __intern_h
|
||||||
|
|
||||||
#include <stdbool.h>
|
|
||||||
|
|
||||||
|
|
||||||
extern struct cons_pointer privileged_symbol_nil;
|
extern struct cons_pointer privileged_symbol_nil;
|
||||||
|
|
||||||
extern struct cons_pointer oblist;
|
extern struct cons_pointer oblist;
|
||||||
|
|
@ -34,7 +31,7 @@ void free_hashmap( struct cons_pointer ptr );
|
||||||
void dump_map( URL_FILE * output, struct cons_pointer pointer );
|
void dump_map( URL_FILE * output, struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
||||||
struct cons_pointer key, bool return_key );
|
struct cons_pointer key );
|
||||||
|
|
||||||
struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
||||||
struct cons_pointer key,
|
struct cons_pointer key,
|
||||||
|
|
@ -49,9 +46,6 @@ struct cons_pointer make_hashmap( uint32_t n_buckets,
|
||||||
struct cons_pointer hash_fn,
|
struct cons_pointer hash_fn,
|
||||||
struct cons_pointer write_acl );
|
struct cons_pointer write_acl );
|
||||||
|
|
||||||
struct cons_pointer search_store( struct cons_pointer key,
|
|
||||||
struct cons_pointer store, bool return_key );
|
|
||||||
|
|
||||||
struct cons_pointer c_assoc( struct cons_pointer key,
|
struct cons_pointer c_assoc( struct cons_pointer key,
|
||||||
struct cons_pointer store );
|
struct cons_pointer store );
|
||||||
|
|
||||||
|
|
@ -61,6 +55,9 @@ struct cons_pointer interned( struct cons_pointer key,
|
||||||
struct cons_pointer internedp( struct cons_pointer key,
|
struct cons_pointer internedp( struct cons_pointer key,
|
||||||
struct cons_pointer environment );
|
struct cons_pointer environment );
|
||||||
|
|
||||||
|
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
||||||
|
struct cons_pointer key );
|
||||||
|
|
||||||
struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
||||||
struct cons_pointer key,
|
struct cons_pointer key,
|
||||||
struct cons_pointer val );
|
struct cons_pointer val );
|
||||||
|
|
@ -75,7 +72,4 @@ struct cons_pointer deep_bind( struct cons_pointer key,
|
||||||
struct cons_pointer intern( struct cons_pointer key,
|
struct cons_pointer intern( struct cons_pointer key,
|
||||||
struct cons_pointer environment );
|
struct cons_pointer environment );
|
||||||
|
|
||||||
struct cons_pointer internedp( struct cons_pointer key,
|
|
||||||
struct cons_pointer store );
|
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
|
||||||
|
|
@ -91,10 +91,8 @@ struct cons_pointer eval_form( struct stack_frame *parent,
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_empty_frame( parent_pointer );
|
make_empty_frame( parent_pointer );
|
||||||
|
// inc_ref( next_pointer );
|
||||||
|
|
||||||
if ( exceptionp( next_pointer ) ) {
|
|
||||||
result = next_pointer;
|
|
||||||
} else {
|
|
||||||
struct stack_frame *next = get_stack_frame( next_pointer );
|
struct stack_frame *next = get_stack_frame( next_pointer );
|
||||||
set_reg( next, 0, form );
|
set_reg( next, 0, form );
|
||||||
next->args = 1;
|
next->args = 1;
|
||||||
|
|
@ -108,7 +106,6 @@ struct cons_pointer eval_form( struct stack_frame *parent,
|
||||||
dec_ref( next_pointer );
|
dec_ref( next_pointer );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -275,6 +272,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
|
||||||
|
|
||||||
names = c_cdr( names );
|
names = c_cdr( names );
|
||||||
}
|
}
|
||||||
|
// inc_ref( new_env );
|
||||||
|
|
||||||
/* \todo if there's more than `args_in_frame` arguments, bind those too. */
|
/* \todo if there's more than `args_in_frame` arguments, bind those too. */
|
||||||
} else if ( symbolp( names ) ) {
|
} else if ( symbolp( names ) ) {
|
||||||
|
|
@ -295,6 +293,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
|
||||||
}
|
}
|
||||||
|
|
||||||
new_env = set( names, vals, new_env );
|
new_env = set( names, vals, new_env );
|
||||||
|
// inc_ref( new_env );
|
||||||
}
|
}
|
||||||
|
|
||||||
while ( !nilp( body ) ) {
|
while ( !nilp( body ) ) {
|
||||||
|
|
@ -309,7 +308,9 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
|
||||||
|
|
||||||
/* if a result is not the terminal result in the lambda, it's a
|
/* if a result is not the terminal result in the lambda, it's a
|
||||||
* side effect, and needs to be GCed */
|
* side effect, and needs to be GCed */
|
||||||
|
if ( !nilp( result ) ) {
|
||||||
dec_ref( result );
|
dec_ref( result );
|
||||||
|
}
|
||||||
|
|
||||||
result = eval_form( frame, frame_pointer, sexpr, new_env );
|
result = eval_form( frame, frame_pointer, sexpr, new_env );
|
||||||
|
|
||||||
|
|
@ -318,7 +319,6 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
// TODO: I think we do need to dec_ref everything on new_env back to env
|
|
||||||
// dec_ref( new_env );
|
// dec_ref( new_env );
|
||||||
|
|
||||||
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
|
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
|
||||||
|
|
@ -343,6 +343,8 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
|
||||||
|
|
||||||
struct cons_pointer payload =
|
struct cons_pointer payload =
|
||||||
pointer2cell( result ).payload.exception.payload;
|
pointer2cell( result ).payload.exception.payload;
|
||||||
|
/* TODO: should name_key also be a privileged keyword? */
|
||||||
|
struct cons_pointer name_key = c_string_to_lisp_keyword( L"name" );
|
||||||
|
|
||||||
switch ( get_tag_value( payload ) ) {
|
switch ( get_tag_value( payload ) ) {
|
||||||
case NILTV:
|
case NILTV:
|
||||||
|
|
@ -353,7 +355,7 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
|
||||||
payload ) ) ) {
|
payload ) ) ) {
|
||||||
pointer2cell( result ).payload.exception.payload =
|
pointer2cell( result ).payload.exception.payload =
|
||||||
set( privileged_keyword_location,
|
set( privileged_keyword_location,
|
||||||
c_assoc( privileged_keyword_name,
|
c_assoc( name_key,
|
||||||
fn_cell->payload.function.meta ),
|
fn_cell->payload.function.meta ),
|
||||||
payload );
|
payload );
|
||||||
}
|
}
|
||||||
|
|
@ -362,13 +364,15 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
|
||||||
default:
|
default:
|
||||||
pointer2cell( result ).payload.exception.payload =
|
pointer2cell( result ).payload.exception.payload =
|
||||||
make_cons( make_cons( privileged_keyword_location,
|
make_cons( make_cons( privileged_keyword_location,
|
||||||
c_assoc( privileged_keyword_name,
|
c_assoc( name_key,
|
||||||
fn_cell->payload.function.
|
fn_cell->payload.function.
|
||||||
meta ) ),
|
meta ) ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( privileged_keyword_payload,
|
( privileged_keyword_payload,
|
||||||
payload ), NIL ) );
|
payload ), NIL ) );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
dec_ref( name_key );
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
|
|
@ -408,7 +412,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer exep = NIL;
|
struct cons_pointer exep = NIL;
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_stack_frame( frame_pointer, args, env );
|
make_stack_frame( frame_pointer, args, env );
|
||||||
|
// inc_ref( next_pointer );
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -439,7 +443,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer exep = NIL;
|
struct cons_pointer exep = NIL;
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_stack_frame( frame_pointer, args, env );
|
make_stack_frame( frame_pointer, args, env );
|
||||||
|
// inc_ref( next_pointer );
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -468,7 +472,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_special_frame( frame_pointer, args, env );
|
make_special_frame( frame_pointer, args, env );
|
||||||
|
// inc_ref( next_pointer );
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -485,7 +489,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_special_frame( frame_pointer, args, env );
|
make_special_frame( frame_pointer, args, env );
|
||||||
|
// inc_ref( next_pointer );
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -573,7 +577,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
message, frame_pointer );
|
message, frame_pointer );
|
||||||
} else {
|
} else {
|
||||||
result = c_assoc( canonical, env );
|
result = c_assoc( canonical, env );
|
||||||
// inc_ref( result );
|
inc_ref( result );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
|
@ -919,26 +923,17 @@ lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer c_keys( struct cons_pointer store ) {
|
struct cons_pointer c_keys( struct cons_pointer store ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( consp( store ) ) {
|
if ( hashmapp( store ) ) {
|
||||||
for ( struct cons_pointer pair = c_car( store ); !nilp( pair );
|
|
||||||
pair = c_car( store ) ) {
|
|
||||||
if ( consp( pair ) ) {
|
|
||||||
result = make_cons( c_car( pair ), result );
|
|
||||||
} else if ( hashmapp( pair ) ) {
|
|
||||||
result = c_append( hashmap_keys( pair ), result );
|
|
||||||
}
|
|
||||||
|
|
||||||
store = c_cdr( store );
|
|
||||||
}
|
|
||||||
} else if ( hashmapp( store ) ) {
|
|
||||||
result = hashmap_keys( store );
|
result = hashmap_keys( store );
|
||||||
|
} else if ( consp( store ) ) {
|
||||||
|
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
|
||||||
|
result = make_cons( c_car( c ), result );
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
struct cons_pointer lisp_keys( struct stack_frame *frame,
|
struct cons_pointer lisp_keys( struct stack_frame *frame,
|
||||||
struct cons_pointer frame_pointer,
|
struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
|
|
@ -1057,15 +1052,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
frame->arg[0] : get_default_stream( true, env );
|
frame->arg[0] : get_default_stream( true, env );
|
||||||
|
|
||||||
if ( readp( in_stream ) ) {
|
if ( readp( in_stream ) ) {
|
||||||
debug_print( L"lisp_read: setting input stream\n",
|
debug_print( L"lisp_read: setting input stream\n", DEBUG_IO );
|
||||||
DEBUG_IO | DEBUG_REPL );
|
|
||||||
debug_dump_object( in_stream, DEBUG_IO );
|
debug_dump_object( in_stream, DEBUG_IO );
|
||||||
input = pointer2cell( in_stream ).payload.stream.stream;
|
input = pointer2cell( in_stream ).payload.stream.stream;
|
||||||
inc_ref( in_stream );
|
inc_ref( in_stream );
|
||||||
} else {
|
} else {
|
||||||
/* should not happen, but has done. */
|
|
||||||
debug_print( L"WARNING: invalid input stream; defaulting!\n",
|
|
||||||
DEBUG_IO | DEBUG_REPL );
|
|
||||||
input = file_to_url_file( stdin );
|
input = file_to_url_file( stdin );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -1198,7 +1189,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
while ( consp( expressions ) ) {
|
while ( consp( expressions ) ) {
|
||||||
struct cons_pointer r = result;
|
struct cons_pointer r = result;
|
||||||
|
inc_ref( r );
|
||||||
result = eval_form( frame, frame_pointer, c_car( expressions ), env );
|
result = eval_form( frame, frame_pointer, c_car( expressions ), env );
|
||||||
dec_ref( r );
|
dec_ref( r );
|
||||||
|
|
||||||
|
|
@ -1229,6 +1220,7 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
|
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
|
||||||
struct cons_pointer r = result;
|
struct cons_pointer r = result;
|
||||||
|
inc_ref( r );
|
||||||
|
|
||||||
result = eval_form( frame, frame_pointer, frame->arg[i], env );
|
result = eval_form( frame, frame_pointer, frame->arg[i], env );
|
||||||
|
|
||||||
|
|
@ -1270,15 +1262,11 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
|
||||||
env ) );
|
env ) );
|
||||||
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
|
debug_print( L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL );
|
||||||
debug_print_object( clause, DEBUG_EVAL );
|
|
||||||
debug_print( L" succeeded; returning: ", DEBUG_EVAL );
|
|
||||||
debug_print_object( result, DEBUG_EVAL );
|
debug_print_object( result, DEBUG_EVAL );
|
||||||
debug_println( DEBUG_EVAL );
|
debug_println( DEBUG_EVAL );
|
||||||
} else {
|
} else {
|
||||||
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
|
debug_print( L"\n\t\tclause failed.\n", DEBUG_EVAL );
|
||||||
debug_print_object( clause, DEBUG_EVAL );
|
|
||||||
debug_print( L" failed.\n", DEBUG_EVAL );
|
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -1331,34 +1319,23 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Throw an exception with a cause.
|
* Throw an exception.
|
||||||
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
||||||
* lisp function; but it is nevertheless to be preferred to make_exception. A
|
* lisp function; but it is nevertheless to be preferred to make_exception. A
|
||||||
* real `throw_exception`, which does, will be needed.
|
* real `throw_exception`, which does, will be needed.
|
||||||
* object pointing to it. Then this should become a normal lisp function
|
* object pointing to it. Then this should become a normal lisp function
|
||||||
* which expects a normally bound frame and environment, such that
|
* which expects a normally bound frame and environment, such that
|
||||||
* frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
|
* frame->arg[0] is the message, and frame->arg[1] is the cons-space
|
||||||
* pointer to the frame in which the exception occurred.
|
* pointer to the frame in which the exception occurred.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
|
|
||||||
struct cons_pointer message,
|
|
||||||
struct cons_pointer cause,
|
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
frame_pointer ) {
|
throw_exception( struct cons_pointer location,
|
||||||
|
struct cons_pointer message,
|
||||||
|
struct cons_pointer frame_pointer ) {
|
||||||
|
debug_print( L"\nERROR: ", DEBUG_EVAL );
|
||||||
|
debug_dump_object( message, DEBUG_EVAL );
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
#ifdef DEBUG
|
|
||||||
debug_print( L"\nERROR: `", 511 );
|
|
||||||
debug_print_object( message, 511 );
|
|
||||||
debug_print( L"` at `", 511 );
|
|
||||||
debug_print_object( location, 511 );
|
|
||||||
debug_print( L"`\n", 511 );
|
|
||||||
if ( !nilp( cause ) ) {
|
|
||||||
debug_print( L"\tCaused by: ", 511 );
|
|
||||||
debug_print_object( cause, 511 );
|
|
||||||
debug_print( L"`\n", 511 );
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
struct cons_space_object *cell = &pointer2cell( message );
|
struct cons_space_object *cell = &pointer2cell( message );
|
||||||
|
|
||||||
if ( cell->tag.value == EXCEPTIONTV ) {
|
if ( cell->tag.value == EXCEPTIONTV ) {
|
||||||
|
|
@ -1370,33 +1347,10 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
|
||||||
location ),
|
location ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( privileged_keyword_payload,
|
( privileged_keyword_payload,
|
||||||
message ),
|
message ), NIL ) ), frame_pointer );
|
||||||
( nilp( cause ) ? NIL :
|
|
||||||
make_cons( make_cons
|
|
||||||
( privileged_keyword_cause,
|
|
||||||
cause ), NIL ) ) ) ),
|
|
||||||
frame_pointer );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
/**
|
|
||||||
* Throw an exception.
|
|
||||||
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
|
||||||
* lisp function; but it is nevertheless to be preferred to make_exception. A
|
|
||||||
* real `throw_exception`, which does, will be needed.
|
|
||||||
* object pointing to it. Then this should become a normal lisp function
|
|
||||||
* which expects a normally bound frame and environment, such that
|
|
||||||
* frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
|
|
||||||
* pointer to the frame in which the exception occurred.
|
|
||||||
*/
|
|
||||||
struct cons_pointer
|
|
||||||
throw_exception( struct cons_pointer location,
|
|
||||||
struct cons_pointer payload,
|
|
||||||
struct cons_pointer frame_pointer ) {
|
|
||||||
return throw_exception_with_cause( location, payload, NIL, frame_pointer );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -1422,9 +1376,10 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer message = frame->arg[0];
|
struct cons_pointer message = frame->arg[0];
|
||||||
|
|
||||||
return exceptionp( message ) ? message :
|
return exceptionp( message ) ? message : throw_exception( message,
|
||||||
throw_exception_with_cause( message, frame->arg[1], frame->arg[2],
|
frame->arg[1],
|
||||||
frame->previous );
|
frame->
|
||||||
|
previous );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -1444,11 +1399,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer expr = NIL;
|
struct cons_pointer expr = NIL;
|
||||||
|
|
||||||
#ifdef DEBUG
|
debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" );
|
||||||
debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL );
|
|
||||||
debug_print_object( env, DEBUG_REPL );
|
|
||||||
debug_print( L"`\n", DEBUG_REPL );
|
|
||||||
#endif
|
|
||||||
|
|
||||||
struct cons_pointer input = get_default_stream( true, env );
|
struct cons_pointer input = get_default_stream( true, env );
|
||||||
struct cons_pointer output = get_default_stream( false, env );
|
struct cons_pointer output = get_default_stream( false, env );
|
||||||
|
|
@ -1463,7 +1414,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
|
set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
|
||||||
input = frame->arg[1];
|
input = frame->arg[1];
|
||||||
}
|
}
|
||||||
if ( writep( frame->arg[2] ) ) {
|
if ( readp( frame->arg[2] ) ) {
|
||||||
new_env =
|
new_env =
|
||||||
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
|
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
|
||||||
output = frame->arg[2];
|
output = frame->arg[2];
|
||||||
|
|
@ -1473,16 +1424,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
inc_ref( output );
|
inc_ref( output );
|
||||||
inc_ref( prompt_name );
|
inc_ref( prompt_name );
|
||||||
|
|
||||||
/* output should NEVER BE nil; but during development it has happened.
|
URL_FILE *os = pointer2cell( output ).payload.stream.stream;
|
||||||
* To allow debugging under such circumstances, we need an emergency
|
|
||||||
* default. */
|
|
||||||
URL_FILE *os =
|
|
||||||
!writep( output ) ? file_to_url_file( stdout ) :
|
|
||||||
pointer2cell( output ).payload.stream.stream;
|
|
||||||
if ( !writep( output ) ) {
|
|
||||||
debug_print( L"WARNING: invalid output; defaulting!\n",
|
|
||||||
DEBUG_IO | DEBUG_REPL );
|
|
||||||
}
|
|
||||||
|
|
||||||
/* \todo this is subtly wrong. If we were evaluating
|
/* \todo this is subtly wrong. If we were evaluating
|
||||||
* (print (eval (read)))
|
* (print (eval (read)))
|
||||||
|
|
@ -1499,10 +1442,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
* \todo the whole process of resolving symbol values needs to be revisited
|
* \todo the whole process of resolving symbol values needs to be revisited
|
||||||
* when we get onto namespaces. */
|
* when we get onto namespaces. */
|
||||||
/* OK, there's something even more subtle here if the root namespace is a map.
|
/* OK, there's something even more subtle here if the root namespace is a map.
|
||||||
* H'mmmm...
|
* H'mmmm... */
|
||||||
* I think that now the oblist is a hashmap masquerading as a namespace,
|
|
||||||
* we should no longer have to do this. TODO: test, and if so, delete this
|
|
||||||
* statement. */
|
|
||||||
if ( !eq( oblist, old_oblist ) ) {
|
if ( !eq( oblist, old_oblist ) ) {
|
||||||
struct cons_pointer cursor = oblist;
|
struct cons_pointer cursor = oblist;
|
||||||
|
|
||||||
|
|
@ -1546,9 +1486,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
dec_ref( expr );
|
dec_ref( expr );
|
||||||
}
|
}
|
||||||
|
|
||||||
if ( nilp( output ) ) {
|
|
||||||
free( os );
|
|
||||||
}
|
|
||||||
dec_ref( input );
|
dec_ref( input );
|
||||||
dec_ref( output );
|
dec_ref( output );
|
||||||
dec_ref( prompt_name );
|
dec_ref( prompt_name );
|
||||||
|
|
@ -1677,6 +1614,7 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame,
|
||||||
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
|
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
|
||||||
struct cons_pointer expr =
|
struct cons_pointer expr =
|
||||||
make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) );
|
make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) );
|
||||||
|
inc_ref( expr );
|
||||||
|
|
||||||
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
|
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
|
||||||
debug_print_object( expr, DEBUG_EVAL );
|
debug_print_object( expr, DEBUG_EVAL );
|
||||||
|
|
|
||||||
|
|
@ -190,11 +190,6 @@ struct cons_pointer lisp_cond( struct stack_frame *frame,
|
||||||
struct cons_pointer frame_pointer,
|
struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env );
|
struct cons_pointer env );
|
||||||
|
|
||||||
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
|
|
||||||
struct cons_pointer message,
|
|
||||||
struct cons_pointer cause,
|
|
||||||
struct cons_pointer
|
|
||||||
frame_pointer );
|
|
||||||
/**
|
/**
|
||||||
* Throw an exception.
|
* Throw an exception.
|
||||||
* `throw_exception` is a misnomer, because it doesn't obey the calling
|
* `throw_exception` is a misnomer, because it doesn't obey the calling
|
||||||
|
|
|
||||||
|
|
@ -8,4 +8,4 @@
|
||||||
* Licensed under GPL version 2.0, or, at your option, any later version.
|
* Licensed under GPL version 2.0, or, at your option, any later version.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
#define VERSION "0.0.6"
|
#define VERSION "0.0.6-SNAPSHOT"
|
||||||
|
|
|
||||||
|
|
@ -2,9 +2,9 @@
|
||||||
|
|
||||||
result=0
|
result=0
|
||||||
|
|
||||||
expected='11'
|
|
||||||
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1`
|
|
||||||
echo -n "$0: let with two bindings, one form in body..."
|
echo -n "$0: let with two bindings, one form in body..."
|
||||||
|
expected='11'
|
||||||
|
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
@ -14,9 +14,9 @@ else
|
||||||
result=`echo "${result} + 1" | bc`
|
result=`echo "${result} + 1" | bc`
|
||||||
fi
|
fi
|
||||||
|
|
||||||
expected='1'
|
|
||||||
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1`
|
|
||||||
echo -n "$0: let with two bindings, two forms in body..."
|
echo -n "$0: let with two bindings, two forms in body..."
|
||||||
|
expected='1'
|
||||||
|
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
|
||||||
|
|
@ -1,108 +0,0 @@
|
||||||
#!/bin/bash
|
|
||||||
|
|
||||||
result=0
|
|
||||||
|
|
||||||
expected='t'
|
|
||||||
output=`target/psse $1 <<EOF
|
|
||||||
(progn
|
|
||||||
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
|
||||||
(set! member?
|
|
||||||
(lambda
|
|
||||||
(item collection)
|
|
||||||
(cond
|
|
||||||
((nil? collection) nil)
|
|
||||||
((= item (car collection)) t)
|
|
||||||
(t (member? item (cdr collection))))))
|
|
||||||
(member? 1 '(1 2 3 4)))
|
|
||||||
EOF`
|
|
||||||
actual=`echo $output | tail -1`
|
|
||||||
|
|
||||||
echo -n "$0 $1: (member? 1 '(1 2 3 4))... "
|
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
|
||||||
then
|
|
||||||
echo "OK"
|
|
||||||
else
|
|
||||||
echo "Fail: expected '${expected}', got '${actual}'"
|
|
||||||
result=`echo "${result} + 1" | bc`
|
|
||||||
fi
|
|
||||||
|
|
||||||
expected='t'
|
|
||||||
output=`target/psse $1 <<EOF
|
|
||||||
(progn
|
|
||||||
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
|
||||||
(set! member?
|
|
||||||
(lambda
|
|
||||||
(item collection)
|
|
||||||
(cond
|
|
||||||
((nil? collection) nil)
|
|
||||||
((= item (car collection)) t)
|
|
||||||
(t (member? item (cdr collection))))))
|
|
||||||
(member? 4 '(1 2 3 4)))
|
|
||||||
EOF`
|
|
||||||
actual=`echo $output | tail -1`
|
|
||||||
|
|
||||||
echo -n "$0: (member? 4 '(1 2 3 4))... "
|
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
|
||||||
then
|
|
||||||
echo "OK"
|
|
||||||
else
|
|
||||||
echo "Fail: expected '${expected}', got '${actual}'"
|
|
||||||
result=`echo "${result} + 1" | bc`
|
|
||||||
fi
|
|
||||||
|
|
||||||
|
|
||||||
expected='nil'
|
|
||||||
output=`target/psse $1 <<EOF
|
|
||||||
(progn
|
|
||||||
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
|
||||||
(set! member?
|
|
||||||
(lambda
|
|
||||||
(item collection)
|
|
||||||
;; (progn (print (list "In member; collection is:" collection)) (println))
|
|
||||||
(cond
|
|
||||||
((nil? collection) nil)
|
|
||||||
((= item (car collection)) t)
|
|
||||||
(t (member? item (cdr collection))))))
|
|
||||||
(member? 5 '(1 2 3 4)))
|
|
||||||
EOF`
|
|
||||||
actual=`echo $output | tail -1`
|
|
||||||
|
|
||||||
echo -n "$0: (member? 5 '(1 2 3 4))... "
|
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
|
||||||
then
|
|
||||||
echo "OK"
|
|
||||||
else
|
|
||||||
echo "Fail: expected '${expected}', got '${actual}'"
|
|
||||||
result=`echo "${result} + 1" | bc`
|
|
||||||
fi
|
|
||||||
|
|
||||||
expected='nil'
|
|
||||||
output=`target/psse $1 -s100<<EOF
|
|
||||||
(progn
|
|
||||||
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
|
||||||
(set! member?
|
|
||||||
(lambda
|
|
||||||
(item collection)
|
|
||||||
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
|
|
||||||
(cond
|
|
||||||
((nil? collection) nil)
|
|
||||||
((= item (car collection)) t)
|
|
||||||
(t (member? item (cdr collection))))))
|
|
||||||
(member? 5 '(1 2 3 4)))
|
|
||||||
EOF`
|
|
||||||
actual=`echo $output | tail -1`
|
|
||||||
|
|
||||||
echo -n "$0: (member? 5 '(1 2 3 4)) with stack limit... "
|
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
|
||||||
then
|
|
||||||
echo "OK"
|
|
||||||
else
|
|
||||||
echo "Fail: expected '${expected}', got '${actual}'"
|
|
||||||
result=`echo "${result} + 1" | bc`
|
|
||||||
fi
|
|
||||||
|
|
||||||
exit $result
|
|
||||||
|
|
@ -4,7 +4,7 @@ result=0
|
||||||
|
|
||||||
echo -n "$0: progn with one form... "
|
echo -n "$0: progn with one form... "
|
||||||
expected='5'
|
expected='5'
|
||||||
actual=`echo "(progn (add 2 3))" | target/psse | tail -1`
|
actual=`echo "(progn (add 2 3))" | target/psse 2>/dev/null | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
@ -16,7 +16,7 @@ fi
|
||||||
|
|
||||||
echo -n "$0: progn with two forms... "
|
echo -n "$0: progn with two forms... "
|
||||||
expected='"foo"'
|
expected='"foo"'
|
||||||
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1`
|
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2>/dev/null | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
#!/bin/bash
|
#!/bin/bash
|
||||||
|
|
||||||
expected='nil 3,628,800'
|
expected='nil 3,628,800'
|
||||||
output=`target/psse <<EOF
|
output=`target/psse 2>/dev/null <<EOF
|
||||||
(progn
|
(progn
|
||||||
(set! fact
|
(set! fact
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
|
|
|
||||||
|
|
@ -40,7 +40,7 @@ else
|
||||||
fi
|
fi
|
||||||
|
|
||||||
echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
|
echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
|
||||||
expected='Exception: ((:location . /) (:payload . "Cannot divide: not a number"))'
|
expected='Exception: "Cannot divide: not a number"'
|
||||||
actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
|
actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue