Compare commits

..

No commits in common. "master" and "feature-2" have entirely different histories.

64 changed files with 1552 additions and 4657 deletions

3
.gitmodules vendored
View file

@ -1,3 +0,0 @@
[submodule "munit"]
path = munit
url = https://github.com/nemequ/munit.git

View file

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

973
Doxyfile

File diff suppressed because it is too large Load diff

View file

@ -30,7 +30,6 @@ $(TARGET): $(OBJS) Makefile
doc: $(SRCS) Makefile Doxyfile doc: $(SRCS) Makefile Doxyfile
doxygen doxygen
tar czvf target/doc.tgz doc
format: $(SRCS) $(HDRS) Makefile format: $(SRCS) $(HDRS) Makefile
ifeq ($(shell uname -s), Darwin) ifeq ($(shell uname -s), Darwin)
@ -44,13 +43,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)

487
README.md
View file

@ -1,190 +1,395 @@
# Post Scarcity Software Environment: general documentation # Post Scarcity Software System, version 0
Work towards the implementation of a software system for the hardware of the deep future. tl,dr: look at the [wiki](wiki).
## Note on canonicity ## State of play
*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`.* ### Version 0.0.5
## State of Play Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [#bindings-currently-available](Bindings currently available) below. Features include hash maps.
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). #### Known bugs
## Roadmap At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now.
There is now a [roadmap](https://www.journeyman.cc/post-scarcity/html/md_workspace_2post-scarcity_2docs_2_roadmap.html) for the project. There are ludicrous memory leaks. Essentially the garbage collection strategy isn't yet really working. However, if we are to implement the hypercube architecture in future, a mark and sweep garbage collector will not work, so it's important to get the reference counter working properly.
## AWFUL WARNING 1 #### Unknown bugs
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. There are certainly MANY unknown bugs. Please report those you find.
What it sets out to be is a Lisp-like system which: #### Not yet implemented
* 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; 1. There is as yet no **compiler**, and indeed it isn't yet certain what a compiler would even mean. Do all nodes in a machine necessarily share the same processor architecture?
* Can make reasonable use of machines with at least billions of processors; 2. There's the beginnings of a narrative about how **namespaces** are going to work, but as yet they aren't really implemented.
* Can concurrently support significant numbers of users, all doing different things, without them ever interfering with one another; 3. There is as yet no implementation of the concept of **users**. Access Control Lists exist but are not used. Related, there's no concept of a **session**.
* Can ensure that users cannot escalate privilege; 4. There is as yet no **multiprocessor architecture**, not even a simulated one. As it is intended that threading will be implemented by handing off parts of a computation to peer processors, this means there no **threads** either.
* Can ensure users private data remains private. 5. There's no **user interface** beyond a REPL. There isn't even an **editor**, or **history**.
6. **Printing to strings** does not work.
7. The **exception system**, while it does exist, needs to be radically rethought.
When Linus Torvalds sat down in his bedroom to write Linux, he had something usable in only a few months. BUT: ### Version 0.0.4
* Linus was young, energetic, and extremely talented; I am none of those things. Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release!
* 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 ## Introduction
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. Long ago when the world was young, I worked on Xerox Dandelion and Daybreak machines which ran Interlisp-D, and Acorn Cambridge Workstation and Archimedes machines which ran Cambridge Lisp (derived from Portable Standard Lisp). At the same time, Lisp Machines Inc, Symbolics, Thinking Machines, Texas Instruments and probably various other companies I've either forgotten or didn't know about built other varieties of dedicated Lisp machines which ran Lisp right down to the metal, with no operating system under them. Those machines were not only far superior to any other contemporary machines; they were also far superior to any machines we've built since. But they were expensive, and UNIX machines with the same raw compute power became very much cheaper; and so they died.
## Building But in the meantime hardware has become vastly more powerful while software has hardly advanced at all. We don't have software which will run efficiently on the machines of the future, we don't have tools to build it, and it often seems to me we're not even thinking about it.
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. Ten years ago I wrote [an essay](http://blog.journeyman.cc/2006/02/post-scarcity-software.html) on what software would look like if we treated our computers as though their power was unlimited (which, compared to what we had at the start of my career, it pretty much is); two years ago I wrote about the [hardware architecture](http://blog.journeyman.cc/2014/10/post-scarcity-hardware.html) which might in future support that hardware.
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/). What I'm trying to do now is write a detailed low level specification of the underpinnings of the software system, and begin a trial implementation. Version 0 will run as a user-space program on UNIX, but very much with the intention that a later version will run on top of either a micro-kernel or perhaps even just a BIOS. However I've no real plans to build post scarcity hardware - I lack the skills. What I'm aiming for is to be able to run on 64 bit, multiple processor hardware.
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. Although I describe it as a 'Lisp environment', for reasons explained in Post Scarcity Software that doesn't mean you will program it in Lisp. It means that the underlying representation of things in the system is Lispy, not Unixy.
This has been developed on Debian but probably builds on any 64 bit UN*X; however I do **not** guarantee this. ## Bindings currently available
### Make targets The following symbols are bound in the bootstrap layer. It is anticipated that
#### default 1. Most of the functions will be overridden by versions of the same function written in Lisp; but
2. these implementations will remain available in the namespace `/:bootstrap`.
The default `make` target will produce an executable as `target/psse`. ### Values
#### clean Note that symbols delimited by asterisks, as in `*in*`, invite rebinding; it is expected, for example, that users will want to rebind input and output streams in their current environment. Rebinding some other symbols, for example `nil`, is unwise.
`make clean` will remove all compilation detritus; it will also remove temporary files. #### nil
#### doc The canonical empty list.
`make doc` will generate documentation in the `doc` directory. Depends on `doxygen` being present on your system. #### t
#### format The canonical true value.
`make format` will standardise the formay of C code. Depends on the GNU `indent` program being present on your system. #### \*in\*
#### REPL The input stream.
`make repl` will start a read-eval-print loop. `*log*` is directed to `tmp/psse.log`. #### \*out\*
#### test The output stream.
`make test` will run all unit tests. #### \*log\*
## In use The logging stream (equivalent to `stderr`).
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. #### \*sink\*
### Documentation The sink stream (equivalent to `/dev/null`).
There is [documentation](https://www.journeyman.cc/post-scarcity/doc/html/). #### \*prompt\*
### Invoking The REPL prompt.
The binary is canonically named `psse`. When invoking the system, the following invocation arguments may be passed: ### Functions
```
-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. #### (absolute *n*)
### Functions and symbols Return the absolute value of a number.
The following functions are provided as of release 0.0.6: #### (add *n1* *n2* ...), (+ *n1* *n2* ...)
| Symbol | Type | Documentation | Return the result of adding together all the (assumed numeric) arguments supplied.
| ------ | ---- | ------------- |
| `*` | 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 #### (append *s1* *s2* ...)
The following bugs are known in 0.0.6: Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2* and so on for an indefinite number of arguments. All arguments must be sequences of the same type.
1. bignum arithmetic does not work (returns wrong answers, does not throw exception); #### (apply *f* *s*)
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. Apply the function *f* to the arguments that form the sequence *s*, and return the result.
#### (assoc *key* *store*)
Return the value associated with *key* in *store*. *key* may be an object of any type, but keywords, symbols and strings are handled most efficiently. *store* may be an [*association list*](#Association_list), or may be a hashmap.
#### (car *s*)
Return the first element of the sequence *s*.
#### (cdr *s*)
Return a sequence of all the elements of the sequence *s* except the first.
#### (close *stream*)
Closes the indicates stream. Returns `nil`.
#### (cons *a* *b*)
Returns a new pair comprising *a* and *b*. If *b* is a list, this has the effect of creating a new list with the element *a* prepended to all the elements of *b*. If *b* is `nil`, this has the effect creating a new list with *a* as the sole element. Otherwise, it just creates a pair.
#### (divide *n1* *n2*), (/ *n1* *n2*)
Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, it's likely that the result will be a rational number.
#### (eq *o1* *o2*)
Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`.
#### (equal *o1* *o2*), (= *o1* *o2*)
Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`.
#### (exception *message*)
Throws (returns) an exception, with the specified *message*. Note that this doesn't really work at all well, and that it is extremely likely this signature will change.
#### (get-hash *key* *hashmap*)
Like 'assoc', but the store must be a hashmap. Deprecated.
#### (hashmap *n* *f* *store*)
Create a hashmap with *n* buckets, using *f* as its hashing function, and initialised with the key/value pairs from *store*. All arguments are optional; if none are passed, will create an empty hashmap with 32 keys and the default hashing function.
#### (inspect *o*)
Prints detailed structure of the object *o*. Primarily for debugging.
#### (keys *store*)
Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap.
#### (let *bindings* *form*...)
Evaluates each of the *forms* in an environment to which ally of these *bindings* have been added. *bindings* must be an [*association list*](#Association_list), and, additionally, all keys in *bindings* must be symbols. Values in the association list will be evaluated before being bound, and this is done sequentially, as in the behaviour of Common Lisp `let*` rather than of Common Lisp `let`.
#### (list *o*...)
Returns a list of the values of all of its arguments in sequence.
#### (mapcar *f* *s*)
Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results.
#### (meta *o*), (metadata *o*)
Returns metadata on *o*.
#### (multiply *n1* *n2* ...), (\* *n1* *n2* ...)
Returns the product of multiplying together all of its numeric arguments.
#### (negative? n1)
Returns `t` if its argument is a negative number, else `nil`.
#### (oblist)
Returns a sequence of all the names bound in the root of the naming system.
#### (open *url* *read?*)
Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing.
#### (print *o* [*stream*])
Prints the print-name of object *o* to the output stream which is the value of *stream*, or to the value of \*out\* in the current environment if no *stream* is provided.
#### (put! *map* *key* *value*)
Puts *value* as the value of *key* in hashmap *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map.
#### (put-all! *map* *assoc*)
Puts each (+key* . *value*) pair from the association list *assoc* into this *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map.
#### (read [*stream*])
Reads a single Lisp form from the input stream which is the value of *stream*, or from the value of \*in\* in the current environment if no *stream* is provided.
#### (read-char [*stream*])
Return the next character from the stream indicated by *stream*, or from the value of \*in\* in the current environment if no *stream* is provided; further arguments are ignored.
#### (repl [*prompt* *input* *output*))
Initiate a new Read/Eval/Print loop with this *prompt*, reading from this *input* stream and writing to this *output* stream. All arguments are optional and default sensibly if omitted. TODO: doesn't actually work yet.
#### (reverse *seq*)
Return a new sequence of the same type as *seq*, containing the same elements but in the reverse order.
#### (slurp *in*)
Reads all available characters on input stream *in* into a string, and returns the string.
#### (source *fn*)
Should return the source code of the function or special form *fn*, but as we don't yet
have a compiler, doesn't.
#### (subtract *n1* *n2*), (- *n1* *n2*)
Subtracts the numeric value *n2* from the numeric value *n1*, and returns the difference.
#### (throw *message*)
Throws an exception, with the payload *message*. While *message* is at present most usefully a string, it doesn't have to be. Returns the exception, but as exceptions are handled specially by `eval`, it is returned to the catch block of the nearest `try` expression on the stack.
#### (time [*milliseconds-since-epoch*])
Returns a time object whose value is the specified number of *milliseconds-since-epoch*, where the Post Scarcity Software Environment epoch is 14 billion years prior to the UN*X epoch. If *milliseconds-since-epoch* is not specified, returns a time object representing the UTC time when the function was executed.
#### (type *o*)
Returns a string representing the type -- actually the tag value -- of the object *o*.
### Special forms
#### (cond (test value) ...)
Evaluates a series of *(test value)* clauses in turn until a test returns non-nil, when the corresponding value is returned and further tests are not evaluated. This is the same syntax as Common Lisp's `cond` implementation, and different from Clojure's.
It's conventional in Lisp to have a final clause in a `cond` block with the test `t`; however, since we have keywords which are always truthy, it would be equally valid to use `:else` or `:default` as final fallback tests.
#### (lambda (arg ...) form ...), (λ (arg ...) form ...)
Returns an anonymous fuction which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form.
#### (let ((*var* . *val*) ...) form ...)
Evaluates each of these *form*s sequentially in an environment in which each *var* is bound to the respective *val* in the bindings specified, and returns the value of the last form.
#### (nlambda (arg ...) form ...), (nλ (arg ...) form ...)
Returns an anonymous special form which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form.
#### (progn *f* ...)
Evaluates each of the forms which are its arguments in turn and returns the value of the last.
#### (quote *o*), '*o*
Returns *o*, unevaluated.
#### (set! *name* *value* [*namespace*])
Sets (destructively modifies) the value of *name* this *value* in the root namespace. The *namespace* argument is currently ignored but in future is anticipated to be a path specification of a namespace to be modified.
#### (try (*form* ...) (*handler* ...))
Attempt to evaluate, sequentially, each of the *form*s in the first sequence, and return the value of the last of them; however, if any of them cause an exception to be thrown, then evaluate sequentially each of the *handler*s in the second sequence.
It is recommended that you structure this as follows:
`lisp
(try
(:body
(print "hello")
(/ 1 'a)
(print "goodbye"))
(:catch
(print "Well, that failed.")
5))
`
Here, `:body` and `:catch` are syntactic sugar which will not affect the final value.
### Type values
The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*.
#### CONS
An ordinary cons cell: that is to say, a pair.
#### EXEP
An exception
#### FREE
An unallocated memory cell. User programs should never see this.
#### FUNC
A primitive or compiled Lisp function \-- one whose arguments are pre-evaluated.
#### HASH
A hash map (in vector space)
#### INTR
An arbitrarily large integer number.
#### KEYW
A keyword - an interned, self-evaluating string.
#### LMBA
A lambda cell. Lambdas are the interpretable (source) versions of functions.
#### LOOP
Internal to the workings of the ••loop** function. User functions should never see this.
#### NIL
The special cons cell at address {0,0} whose **car** and **cdr** both point to itself. The canonical empty set. Generally, treated as being indicative of falsity.
#### NLMD
An nlambda cell. NLambdas are the interpretable (source) versions of special forms.
#### RTIO
A rational number, stored as pointers two integers representing dividend and divisor respectively.
#### READ
An open read stream.
#### REAL
A real number, represented internally as an IEEE 754-2008 `binary64`.
#### SPFM
A compiled or primitive special form - one whose arguments are not pre-evaluated but passed as provided.
#### STAK
A stack frame. In vector space.
#### STRG
A string of [UTF-32](https://en.wikipedia.org/wiki/UTF-32) characters, stored as a linked list. Self evaluating.
#### SYMB
A symbol is just like a string except not self-evaluating. Later, there may be some restrictions on what characters are legal in a symbol, but at present there are not.
#### TIME
A time stamp. The epoch for the Post Scarcity Software Environment is 14 billion years before the UN*X epoch, and is chosen as being a reasonable estimate for the birth of the universe, and thus of the start of time.
#### TRUE
The special cell at address {0,1} which is canonically different from NIL.
#### VECP
A pointer to an object in vector space. User functions shouldn't see this, they should see the type of the vector-space object indicated.
#### VECT
A vector of objects. In vector space.
#### WRIT
An open write stream.
## License
Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc)
Distributed under the terms of the
[GNU General Public License v2](http://www.gnu.org/licenses/gpl-2.0.html)

View file

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

View file

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

View file

@ -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
@ -8,11 +8,7 @@ Work towards the implementation of a software system for the hardware of the dee
## State of Play ## State of Play
You can read about the current [state of play](State-of-play.md). You can read about the current [state of play](md_home_2simon_2workspace_2post-scarcity_2docs_2state-of-play.html).
## Roadmap
There is now a [roadmap](Roadmap.md) for the project.
## AWFUL WARNING 1 ## AWFUL WARNING 1
@ -21,8 +17,8 @@ This does not work. It isn't likely to work any time soon. If you want to learn
What it sets out to be is a Lisp-like system which: 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 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 make reasonable use of machines with at least tens of thousands of processors;
* Can concurrently support significant numbers of users, all doing different things, without them ever interfering with one another; * Can concurrently support significant numbers of concurrent users, all doing different things, without them ever interfering with one another;
* Can ensure that users cannot escalate privilege; * Can ensure that users cannot escalate privilege;
* Can ensure users private data remains private. * Can ensure users private data remains private.
@ -36,155 +32,3 @@ When Linus Torvalds sat down in his bedroom to write Linux, he had something usa
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. 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 symbol forms...))`: Doesn't work yet! |
| type | FUNC | `(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change. |
| λ | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ function. |
## 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.

View file

@ -1,5 +1,3 @@
# Implementing Post Scarcity Hardware
The address space hinted at by using 64 bit cons-space and a 64 bit vector space containing objects each of whose length may be up to 1.4e20 bytes (2^64 of 64 bit words) is so large that a completely populated post-scarcity hardware machine can probably never be built. But that doesn't mean I'm wrong to specify such an address space: if we can make this architecture work for machines that can't (yet, anyway) be built, it will work for machines that can; and, changing the size of the pointers, which one might wish to do for storage economy, can be done with a few edits to consspaceobject.h. The address space hinted at by using 64 bit cons-space and a 64 bit vector space containing objects each of whose length may be up to 1.4e20 bytes (2^64 of 64 bit words) is so large that a completely populated post-scarcity hardware machine can probably never be built. But that doesn't mean I'm wrong to specify such an address space: if we can make this architecture work for machines that can't (yet, anyway) be built, it will work for machines that can; and, changing the size of the pointers, which one might wish to do for storage economy, can be done with a few edits to consspaceobject.h.
But, for the moment, let's discuss a potential 32 bit psh machine, and how it might be built. But, for the moment, let's discuss a potential 32 bit psh machine, and how it might be built.

View file

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

View file

@ -1,75 +0,0 @@
# Post Scarcity Hardware: the crystal, take two
In my previous essay on hardware for the Post Scarcity system, [Implementing Post Scarcity Hardware](Implementing-post-scarcity-hardware.md), I proposed a hypercube structure built of modules called crystals, each itself a cube of 64 modules called nodes, arranged in an 8 x 8 x 8 lattice, and each having bidirectional serial connections to its up, down, north, south, east and west neighbours. A single crystal can form a hypercube in itself by linking the cells of each of its outside faces to the cells on its opposite face; or they can be plugged together to form larger hypercubes.
In that essay I proposed a number of details on which my thinking has moved on.
First, I proposed that the nodes should be based on commercially available 32 or 64 bit processors. Custom hardware would be needed on each node only for its router, which runs the six bidirectional connections to neighbours. For prototyping that still makes sense, although I will sketch an idea for fully custom hardware in this essay.
I suggested that the address space of each node might be partitioned into four fixed and distinct spaces: its locally curated cons space for its own locally created cells; its locally curated vector space, for larger locally created objects; a space for cached copies of cons cells curated by other nodes; and a space for cached copies of vector space objects curated by other nodes.
I never liked this 'four distinct spaces' idea. As I wrote way back in my first essay on [Post Scarcity software](Post-scarcity-software.md), one of the things that essay was in reaction against was the fixed size stacks on (e.g.) the Java virtual machine, and, more generally, that a software system should hit a wall when it ran out of memory in some arbitrarily delimited space.
So I'm now back to the idea of each node treating its physical memory as one undifferentiated vector space, with its own cons pages, being arrays of equal sized cons-space objects, floating in that vector space. I'm proposing two new types of cons space object.
The idea of having four distinct spaces per node was that each node would curate just one cons page, and that each cons pointer was 64 bits comprising 32 bits of originating node address, and 32 bits of page offset.
I'm still thinking that 64 bits is a not-unreasonable size for a cons pointer, but that it should now be considered made up of three distinct fields, node address, page number, offset. The exact sizes of each of those fields can be variable, but
```
+------*------*---------+
| 0 | 32 | 40...63 |
+------*------*---------+
| Node | Page | Offset |
+------*------*---------+
```
would allow for a hypercube with edges 536,870,912 &mdash; half a billion &mdash; nodes long, with each node capable of addressing 256 pages of each of 16,777,216 cells for a total of 4 billion cells, each of 32 bytes. So the cells alone addressable by a single node could occupy 2<sup>37</sup> = 137,438,953,472 bytes; but each node would have a 64 bit address bus, so the potential heap is vastly larger.
In practice, I don't actually need a 64 bit cons pointer, and at some stage I may make a pragmatic decision to make it smaller. But the whole idea of the post scarcity computing project is to design systems as though there weren't physical constraints on them, so I'm not proposing to change it yet.
## The `CACH` Cell
The first of these is the cache cell, with the tag `CACH`. A cache cell is like a cons cell, which is like a cons cell except that its `CAR` points to the foreign object which has been cached, and its `CDR` points to the local copy.
There is a local namespace, `*cache*`, which holds a pointer to each such `CACH` cell indexed by the address of the foreign object it points to. A local sweep operation notes cells pointed to by any local cache cell in the `*cache*` which have only one remaining reference, removes the `CACH` cell from the `*cache*` into a temporary holding store (probably an assoc list, possibly a private namespace), sends a message to the owning node to decrement the reference to the object, and, on receiving confirmation that this has been received, decrements (and thus frees) the `CACH` cell and local copy.
Obviously, when any user space function references a cache cell as argument, what is fetched is the locally cached copy of the foreign object, an indirection which needs to be handled by `eval`. When a user space function references a foreign object of which there is a local copy in `*cache*`, then the local copy is fetched. If there isn't a local copy in cache, then execution is obviously halted while the master copy is fetched hopitty hop across the hypercube, which is obviously expensive and undesirable.
Consequently, copies of essential variables, functions and namespaces should be broadcast at bootstrap time and copied by each node. The only mutable things in this system are namespaces and output streams. Output streams are only readable by their destination, so nothing else needs to be alerted if they change. But any node may hold a cached copy of a namespace, so if a namespace is changed a change notification needs to be broadcast, or else every time a function on a node references a name in namespace, execution needs to halt while the curating node is queried whether the the binding has changed.
Both of these solutions are expensive. Probably the best compromise is to have two tiers of namespaces, those which broadcast changes (probably reserved for essential system namespaces), and those which have to be checked when accessed. Note that, provided the binding hasn't changed, nothing below the binding can have changed unless it also is a namespace, so nothing needs to be refetched.
## The `PROT` cell
I've given myself 32 bits of tag space, mainly to allow a simple representation of mnemonics as tags. For this reason, all the tags I've so far assigned have values which, considered as ASCII strings, represent four upper case characters. There are thus 456,976 possible upper case tags, and an equal number of possible lower case tags. I have a thought that tags encoding mnemonics in all upper could be tags of system level cons space object types, and tags encoding mnemonics in all lower could be tags of user created cons space object types.
But if users are able to create their own new types of cons space object, there has to be a way of specifying to the system how to use those novel cell types, and what sorts of operations are legal on them.
This is where the `PROT` &mdash; or `PROT`otype &mdash; cell comes in.
A cons space object is something which can be stored in [a cons cell](Cons-space.md), which has a fixed payload size of 128 bits.
In designing the bootstrapping cons space object types of the system, I've designed cells which are essentially two 64 bit pointers (such as `CONS` or `RTIO`); one which is a single 128 bit [IEEE754]() floating point number (`REAL`); one which is a single `unsigned __int128` (`TIME`); several which comprise one 32 bit `wide character`, some padding, and a cons pointer to another cell of the same type (`KEYW`, `STRG`, `SYMB`); one which comprises a tag, some padding, and a 64 bit pointer into vector space (`VECP`); ones that are simply markers and have no payload (`LOOP`, `WRKR`) , and so on.
There are a lot of different sorts of things you can store in 128 bits of memory. You can divide it up into fields any way you please, and store anything you like &mdash; that will fit &mdash; in those fields.
## The Node Processor hardware
I suggested in my earlier essay that the node processors could be off the shelf parts, probably ARM chips. But the router still needs to be custom silicon. If you were to do custom silicon for the node processor, what would it look like?
Well, firstly, although it could have a very small instruction set, I don't think it would count as strictly a RISC processor. The reason it wouldn't is that some of the instructions would be themselves recursive, meaning they could not complete in a single clock cycle.
So, what does it look like?
Firstly, it must have at least one register in which it can construct a complete cons space object, which is to say, 256 bits.
It must have sufficient registers to represent the full content of a stack frame, which is to say eleven 64 bit cons pointers and one 32 bit argument counter, so at least 736 bits (but 768 probably makes more sense). But note that a function call with zero args needs only 160 bits, one with one arg needs only 224 bits, one with three, 288 bits register. So when evaluating functions with low numbers of arguments, it's at least potentially possible for the processor to use unused bits in the stack frame register as additional shipyards in which to assemble cons space objects.
H'mmm. You need two stack frame registers, one for the frame you're evaluating, and one for the frame you're assembling. I think you also need an additional cons space object shipyard, for the cons space object (VECP) which will point to the current frame when is released.
### Instructions

View file

@ -1,132 +0,0 @@
# Roadmap
With the release of 0.0.6 close, it's time to look at a plan for the future
development of the project.
I have an almost-working Lisp interpreter, which, as an interpreter, has many
of the features of the language I want. It runs in one thread on one processor.
Given how experimental this all is, I don't think I need it to be a polished
interpreter, and polished it isn't. Lots of things are broken.
* garbage collection is pretty broken, and I'n beginning to doubt my whole
garbage collection strategy;
* bignums are horribly broken;
* there's something very broken in shallow-bound symbols, and that matters
and will have to be fixed;
* there are undoubtedly many other bugs I don't know about.
However, while I will fix bugs where I can, it's good enough for other people
to play with if they're mad enough, and it's time to move on.
## 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
There is really no point to this whole project while it remains a single thread
running on a single processor. Until I can pass off computation to peer
neighbours, I can't begin to understand what the right strategies are for when
to do so.
`cond` is explicitly sequential, since later clauses should not be executed at
all if earlier ones succeed. `progn` is sort of implicitly sequential, since
it's the value of the last form in the sequence which will be returned.
For `mapcar`, the right strategy might be to partition the list argument
between each of the idle neighbours, and then reassemble the results that come
bask.
For most other things, my hunch is that you pass args which are not
self-evaluating to idle neighbours, keeping (at least) one on the originating
node to work on while they're busy.
But before that can happen, we need a router on each node which can monitor
concurrent traffic on six bidirectional links. I think at least initially what
gets written across those links is just S-expressions.
I think a working simulated hypercube is the key milestone for version 0.2.0.
### Sysout, sysin, and system persistance
Doctrine is that the post scarcity computing environment doesn't have a file
system, but nevertheless we need some way of making an image of a working
system so that, after a catastrophic crash or a power outage, it can be brought
back up to a known good state. This really needs to be in 0.1.1.
### Better command line experience
The current command line experience is embarrassingly poor. Recallable input
history, input line editing, and a proper structure editor are all things that
I will need for my comfort.
### Users, groups and ACLs
Allowing multiple users to work together within the same post scarcity
computing environment while retaining security and privacy is a major goal. So
working out ways for users to sign on and be authenticated, and to configure
their own environment, and to set up their own access control lists on objects
they create, needs to be another nearish term goal. Probably 0.1.2.
### Homogeneities, regularities, slots, migration, permeability
There are a lot of good ideas about the categorisation and organisation of data
which are sketched in my original
[Post scarcity software](Post-scarcity-software.md) essay which I've never
really developed further because I didn't have the right software environment
for them, which now I shall have. It would be good to build them.
### Compiler
I do want this system to have a compiler. I do want compiled functions to be
the default. And I do want to understand how to write my own compiler for a
system like this. But until I know what the processor architecture of the
system I'm targetting is, worrying too much about a compiler seems premature.
### Graphical User Interface
Ultimately I want a graphical user interface at least as fluid and flexible as
what we had on Interlisp machines 40 years ago. It's not a near term goal yet.
### Real hardware
This machine would be **very** expensive to build, and there's no way I'm ever
going to afford more than a sixty-four node machine. But it would be nice to
have software which would run effectively on a four billion node machine, if
one could ever be built. I think that has to be the target for version 1.0.0.

View file

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

View file

@ -1,8 +1,4 @@
# On the topology of the hardware of the deep future ![HAL 9000 - a vision of the hardware of the deep future](https://vignette4.wikia.nocookie.net/2001/images/5/59/Hal_console.jpg/revision/latest?cb=20090823025755)In thinking about how to write a software architecture that won't quickly become obsolescent, I find that I'm thinking increasingly about the hardware on which it will run.
![HAL 9000 - a vision of the hardware of the deep future](https://vignette4.wikia.nocookie.net/2001/images/5/59/Hal_console.jpg/revision/latest?cb=20090823025755)
In thinking about how to write a software architecture that won't quickly become obsolescent, I find that I'm thinking increasingly about the hardware on which it will run.
In [Post Scarcity Hardware](Post-scarcity-hardware.html) I envisaged a single privileged node which managed main memory. Since then I've come to thing that this is a brittle design which will lead to bottle necks, and that each cons page will be managed by a separate node. So there needs to be a hardware architecture which provides the shortest possible paths between nodes. In [Post Scarcity Hardware](Post-scarcity-hardware.html) I envisaged a single privileged node which managed main memory. Since then I've come to thing that this is a brittle design which will lead to bottle necks, and that each cons page will be managed by a separate node. So there needs to be a hardware architecture which provides the shortest possible paths between nodes.
@ -18,7 +14,7 @@ If you take a square grid and place a processor at every intersection, it has at
So far so good. Now, let's take square grids and stack them. This gives each node at most six proximal neighbours. We form a cube, and the longest distance between two nodes is `3x`. We can link the nodes on the left of the cube to the corresponding nodes on the right and form a (thick walled) cylinder, and the longest distance between two nodes is `2.5x`. Now join the nodes at the top of the cube to the corresponding nodes at the bottom, and we have a thick walled torus. The maximum distance between is now `2x`. So far so good. Now, let's take square grids and stack them. This gives each node at most six proximal neighbours. We form a cube, and the longest distance between two nodes is `3x`. We can link the nodes on the left of the cube to the corresponding nodes on the right and form a (thick walled) cylinder, and the longest distance between two nodes is `2.5x`. Now join the nodes at the top of the cube to the corresponding nodes at the bottom, and we have a thick walled torus. The maximum distance between is now `2x`.
Let's stop for a moment and think about the difference between logical and physical topology. Suppose we have a printed circuit board with 199 processors on it in a regular grid. We probably could physically bend the circuit board to form a cylinder, but there's no need to do so. We achieve exactly the same connection architecture simply by using wires to connect the left side to the right. And if we use wires to connect those at the top with those at the bottom, we've formed a logical torus even though the board is still flat. Let's stop for a moment and think about the difference between logical and physical topology. Suppose we have a printed circuit board with 100 processors on it in a regular grid. We probably could physically bend the circuit board to form a cylinder, but there's no need to do so. We achieve exactly the same connection architecture simply by using wires to connect the left side to the right. And if we use wires to connect those at the top with those at the bottom, we've formed a logical torus even though the board is still flat.
It doesn't even need to be a square board. We could have each processor on a separate board in a rack, with each board having four connectors probably all along the same edge, and use patch wires to connect the boards together into a logical torus. It doesn't even need to be a square board. We could have each processor on a separate board in a rack, with each board having four connectors probably all along the same edge, and use patch wires to connect the boards together into a logical torus.

View file

@ -1,305 +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 &mdash; in `member`, but
due to a primitive bug I haven't identified &mdash; 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
The bug in `member` turned out to be because when a symbol is read by the reader,
it has a null character appended as its last character, after all the visibly
printing characters. When the type string is being generated, it doesn't. I've
fudged this for now by giving the type strings an appended null character, but
the right solution is almost certainly to not add the null character in either
case &mdash; i.e. revert today's 'fix' and instead fix the reader.
I've also done a lot of documentation, and I've found the courage to do some
investigation on the bignum bug. However, I've workeg until 04:00, which is
neither sane nor healthy, so I shall stop.
## 20260225
A productive day!
I awoke with a plan to fix `cond`. This morning, I execoted it, and it worked.
This afternoon, I fixed `let`. And this evening, I greatly improved `equal`.
The bug in `member` is still unresolved.
We're getting very close to the release of 0.0.6.
## 20260224
Found a bug in subtraction, which I hoped might be a clue into the bignum bug;
but it proved just to be a careless bug in the small integer cache code (and
therefore a new regression). Fixed this one, easily.
In the process spotted a new bug in subtracting rationals, which I haven't yet
looked at.
Currently working on a bug which is either in `let` or `cond`, which is leading
to non-terminating recursion...
H'mmm, there are bugs in both.
#### `let`
The unit test for let is segfaulting. That's a new regression today, because in
last night's buildv it doesn't segfault. I don't know what's wrong, but to be
honest I haven't looked very hard because I'm trying to fix the bug in `cond`.
#### `cond`
The unit test for `cond` still passes, so the bug that I'm seeing is not
triggered by it. So it's not necessarily a new bug. What's happening? Well,
`member` doesn't terminate.
The definition is as follows:
```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
((nil? collection) nil)
((= item (car collection)) t)
(t (member item (cdr collection))))))
```
In the execution trace, with tracing of bind, eval and lambda enabled, I'm
seeing this loop on the stack:
```
Stack frame with 1 arguments:
Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA"
Arg 0: CONS count: 6 value: (member item (cdr collection))
Stack frame with 3 arguments:
Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection))
Arg 0: CONS count: 7 value: ((nil? collection) nil)
Arg 1: CONS count: 7 value: ((= item (car collection)) t)
Arg 2: CONS count: 7 value: (t (member item (cdr collection)))
Stack frame with 1 arguments:
Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil)
Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
Stack frame with 2 arguments:
Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
Arg 0: STRG count: 19 value: "LMDA"
Arg 1: NIL count: 4294967295 value: nil
Stack frame with 1 arguments:
Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA"
Arg 0: CONS count: 6 value: (member item (cdr collection))
Stack frame with 3 arguments:
Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection))
Arg 0: CONS count: 7 value: ((nil? collection) nil)
Arg 1: CONS count: 7 value: ((= item (car collection)) t)
Arg 2: CONS count: 7 value: (t (member item (cdr collection)))
Stack frame with 1 arguments:
Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil)
Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
Stack frame with 2 arguments:
Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
Arg 0: STRG count: 19 value: "LMDA"
Arg 1: NIL count: 4294967295 value: nil
```
This then just goes on, and on, and on. The longest instance I've got the trace of wound up more than a third of a million stack frames before I killed it. What appears to be happening is that the cond clause
```lisp
((nil? collection) nil)
```
Executes correctly and returns nil; but that instead of terminating the cond expression at that point it continues and executes the following two clauses, resulting in (infinite) recursion.
This is bad.
But what's worse is that the clause
```lisp
((= item (car collection)) t)
```
also doesn't terminate the `cond` expression, even when it should.
And the reason? From the trace, it appears that clauses *never* succeed. But if that's true, how come the unit tests are passing?
Problem for another day.
I'm not going to commit today's work to git, because I don't want to commit something I know segfaults.
## 20260220
### State of the build
The only unit tests that are failing now are the bignum tests, which I have
consciously parked as a future problem, and the memory leak, similarly. The
leak is a lot less bad than it was, but I'm worried that stack frames
are not being freed.
If you run
```
cat lisp/fact.lisp | target/psse -d 2>&1 |\
grep 'Vector space object of type' | sort | uniq -c | sort -rn
```
you get a huge number (currently 394) of stack frames in the memory dump; they
should all have been reclaimed. There's other stuff in the memory dump as well,
```
422 CONS ;; cons cells, obviously
394 VECP ;; pointers to vector space objects -- specifically, the stack frames
335 SYMB ;; symbols
149 INTR ;; integers
83 STRG ;; strings
46 FUNC ;; primitive (i.e. written in C) functions
25 KEYW ;; keywords
10 SPFM ;; primitive special forms
3 WRIT ;; write streams: `*out*`, `*log*`, `*sink*`
1 TRUE ;; t
1 READ ;; read stream: `*in*`
1 NIL ;; nil
1 LMDA ;; lambda function, specifically `fact`
```
Generally, for each character in a string, symbol or keyword there will be one
cell (`STRG`, `SYMB`, or `KEYW`) cell, so the high number of STRG cells is not
especially surprising. It looks as though none of the symbols bound in the
oblist are being recovered on exit, which is undesirable but not catastrophic,
since it's a fixed burden of memory which isn't expanding.
But the fact that stack frames aren't being reclaimed is serious.
### Update, 19:31
Right, investigating this more deeply, I found that `make_empty_frame` was doing
an `inc_ref` it should not have been, Having fixed that I'm down to 27 frames
left in the dump. That's very close to the number which will be generated by
running `(fact 25)`, so I expect it is now only stack frames for interpreted
functions which are not being reclaimed. This give me something to work on!
## 20260215
Both of yesterday's regressions are fixed. Memory problem still in much the
same state.
> Allocation summary: allocated 1210; deallocated 10; not deallocated 1200.
That left the add ratios problem which was deeper. I had unintended unterminated
recursion happening there. :-(
It burned through 74 cons pages each of 1,024 cons cells, total 76,800 cells,
and 19,153 stack frames. before it got there; and then threw the exception back
up through each of those 19,153 stack frames. But the actual exception message
was `Unrecognised tag value 0 ( )`, which is not enormously helpful.
S
However, once I had recognised what the problem was, it was quickly fSixed, with
the added bonus that the new solution will automatically work for bignum
fractions once bignums are working.
So we're down to eight unit tests failing: the memory leak, one unimplemented
feature, and the bignum problem.
At the end of the day I decided to chew up some memory by doing a series of
moderately large computations, to see how much memory is being successfully
deallocated.
```lisp
:: (mapcar fact '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
(1 2 6 24 120 720 5,040 40,320 362,880 3,628,800 39,916,800 479,001,600
1,932,053,504 1,278,945,280 2,004,310,016 2,004,189,184 4,006,445,056
3,396,534,272 109,641,728 2,192,834,560)
::
Allocation summary: allocated 10136; deallocated 548; not deallocated 9588.
```
So, about 5%. This is still a major problem, and is making me doubt my reference
counting strategy. Must do better!
Note that the reason that the numbers become eratic past about two billion is
the bignum arithmetic bug.
## 20260214 ## 20260214
### Memory leaks ### Memory leaks

View file

@ -1,8 +1,14 @@
(set! symbol? (lambda (x) (equal (type x) "SYMB"))) (set! symbolp (lambda (x) (equal (type x) "SYMB")))
(set! defun!
(nlambda
form
(cond ((symbolp (car form))
(set (car form) (apply 'lambda (cdr form))))
(t nil))))
(set! defun! (set! defun!
(nlambda (nlambda
"`(defun name arg-list forms...)`: Define an interpreted Lambda function with this `name` and this `arg-list`, whose body is comprised of these `forms`."
form form
(eval (list 'set! (car form) (cons 'lambda (cdr form)))))) (eval (list 'set! (car form) (cons 'lambda (cdr form))))))
@ -11,10 +17,10 @@
(set! defsp! (set! defsp!
(nlambda (nlambda
form form
(cond (symbol? (car form)) (cond (symbolp (car form))
(set! (car form) (apply nlambda (cdr form)))))) (set! (car form) (apply nlambda (cdr form))))))
(defun! cube (x) (* x x x)) (defsp! cube (x) ((* x x x)))
(set! p 5) (set! p 5)

View file

@ -1,44 +0,0 @@
;; This function depends on:
;; `member` (from file `member.lisp`)
;; `nth` (from `nth.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)
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
(cond ((member? (type object) '("FUNC" "SPFM"))
(:documentation (meta object)))
((member? (type object) '("LMDA" "NLMD"))
(let ((d . (nth 3 (source object))))
(cond ((string? d) d)
(t (source object)))))
(t object))))
(set! doc documentation)
(documentation apply)
;; (documentation member?)

View file

@ -4,6 +4,6 @@
(cond ((= n 1) 1) (cond ((= n 1) 1)
(t (* n (fact (- n 1))))))) (t (* n (fact (- n 1)))))))
(fact 25) ; (fact 1000)

View file

@ -1,3 +0,0 @@
(set! > (lambda (a b)
"`(> a b)`: Return `t` if `a` is a number greater than `b`, else `nil`."
(not (negative? (- a b)))))

View file

@ -1,18 +0,0 @@
(set! nil? (lambda (o) (= (type o) "NIL ")))
(set! CDR (lambda (o)
(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)
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
(cond
((nil? collection) nil)
((= item (car collection)) t)
(t (member? item (cdr collection))))))

View file

@ -0,0 +1,6 @@
(set! or (lambda values
"True if any of `values` are non-nil."
(cond
((nil? values) nil)
((car values) t)
(t (eval (cons 'or (cdr values)))))))

View file

@ -1,6 +0,0 @@
(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))))))

View file

@ -46,7 +46,3 @@
"This blows up: 10^37, which is a three cell bignum." "This blows up: 10^37, which is a three cell bignum."
(inspect (set! final (+ z z z z z z z z z z))) (inspect (set! final (+ z z z z z z z z z z)))
(mapcar (lambda (n) (list (:name (meta n)) (:documentation (meta n)))) (keys (oblist)))
((keys "`(keys store)`: Return a list of all keys in this `store`.") (set nil) (let nil) (quote nil) (nil nil) (read nil) (nil nil) (nil nil) (oblist "`(oblist)`: Return the current symbol bindings, as a map.") (cons "`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.") (source nil) (cond nil) (nil nil) (eq? "`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.") (close "`(close stream)`: If `stream` is a stream, close that stream.") (meta "`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.") (nil nil) (not "`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.") (mapcar "`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.") (negative? "`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.") (open "`(open url read?)`: Open a stream to this `url`. If `read` is present and is non-nil, open it for reading, else writing.") (subtract nil) (nil nil) (nil nil) (nil nil) (or "`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.") (nil nil) (and "`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.") (count "`(count s)`: Return the number of items in the sequence `s`.") (eval nil) ( nil) (nil nil) (nil nil) (nil nil) (nil nil) (cdr "`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.") (equal? "`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.") (set! nil) (nil nil) (nil nil) (reverse nil) (slurp nil) (try nil) (assoc "`(assoc key store)`: Return the value associated with this `key` in this `store`.") (nil nil) (add "`(+ args...)`: If `args` are all numbers, return the sum of those numbers.") (list "`(list args...): Return a list of these `args`.") (time nil) (car "`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.") (nil nil) (nil nil) (nil nil) (absolute "`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.") (append "`(append args...)`: If args are all collections, return the concatenation of those collections.") (apply "`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.") (divide "`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.") (exception "`(exception message)`: Return (throw) an exception with this `message`.") (get-hash "`(get-hash arg)`: returns the natural number hash value of `arg`.") (hashmap "`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.") (inspect "`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.") (metadata "`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.") (multiply "`(* args...)` Multiply these `args`, all of which should be numbers.") (print "`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.") (put! nil) (put-all! nil) (ratio->real "`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.") (read-char nil) (repl nil) (throw nil) (type nil) (+ "`(+ args...)`: If `args` are all numbers, return the sum of those numbers.") (* nil) (- nil) (/ nil) (= "`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.") (lambda nil) (λ nil) (nlambda nil) (progn nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil))

View file

@ -1,17 +1,17 @@
(set! cons? (lambda (o) "True if `o` is a cons cell." (= (type o) "CONS") ) ) (set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) )
(set! exception? (lambda (o) "True if `o` is an exception." (= (type o) "EXEP"))) (set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP")))
(set! free? (lambda (o) "Trus if `o` is a free cell - this should be impossible!" (= (type o) "FREE"))) (set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE")))
(set! function? (lambda (o) "True if `o` is a compiled function." (= (type o) "EXEP"))) (set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP")))
(set! integer? (lambda (o) "True if `o` is an integer." (= (type o) "INTR"))) (set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR")))
(set! lambda? (lambda (o) "True if `o` is an interpreted (source) function." (= (type o) "LMDA"))) (set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA")))
(set! nil? (lambda (o) "True if `o` is the canonical nil value." (= (type o) "NIL "))) (set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL ")))
(set! nlambda? (lambda (o) "True if `o` is an interpreted (source) special form." (= (type o) "NLMD"))) (set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD")))
(set! rational? (lambda (o) "True if `o` is an rational number." (= (type o) "RTIO"))) (set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO")))
(set! read? (lambda (o) "True if `o` is a read stream." (= (type o) "READ") ) ) (set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) )
(set! real? (lambda (o) "True if `o` is an real number." (= (type o) "REAL"))) (set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL")))
(set! special? (lambda (o) "True if `o` is a compiled special form." (= (type o) "SPFM") ) ) (set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) )
(set! string? (lambda (o) "True if `o` is a string." (= (type o) "STRG") ) ) (set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) )
(set! symbol? (lambda (o) "True if `o` is a symbol." (= (type o) "SYMB") ) ) (set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) )
(set! true? (lambda (o) "True if `o` is the canonical true value." (= (type o) "TRUE") ) ) (set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) )
(set! write? (lambda (o) "True if `o` is a write stream." (= (type o) "WRIT") ) ) (set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) )

View file

@ -6,9 +6,9 @@ I have blogged a lot in the past about madness and about software, but I don't t
I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not. I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not.
I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it wo I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works.
As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helprks.
s subdue the chaos in my mind. As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind.
Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is: Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is:

View file

@ -138,7 +138,7 @@ struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
if ( !small_int_cache_initialised ) { if ( !small_int_cache_initialised ) {
for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) { for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) {
small_int_cache[i] = make_integer( i, NIL ); small_int_cache[i] = make_integer( i, NIL );
pointer2cell( small_int_cache[i] ).count = MAXREFERENCE; // lock it in so it can't be GC'd pointer2cell( small_int_cache[i] ).count = UINT32_MAX; // lock it in so it can't be GC'd
} }
small_int_cache_initialised = true; small_int_cache_initialised = true;
debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC ); debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC );
@ -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,39 +226,54 @@ 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 ) ) {
__int128_t av = cell_value( a, '+', is_first_cell ); debug_print( L"add_integers: \n", DEBUG_ARITH );
__int128_t bv = cell_value( b, '+', is_first_cell ); debug_dump_object( a, DEBUG_ARITH );
__int128_t rv = ( av + bv ) + carry; debug_print( L" plus \n", DEBUG_ARITH );
debug_dump_object( b, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
debug_print( L"add_integers: av = ", DEBUG_ARITH ); while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
debug_print_128bit( av, DEBUG_ARITH ); __int128_t av = cell_value( a, '+', is_first_cell );
debug_print( L"; bv = ", DEBUG_ARITH ); __int128_t bv = cell_value( b, '+', is_first_cell );
debug_print_128bit( bv, DEBUG_ARITH ); __int128_t rv = ( av + bv ) + carry;
debug_print( L"; carry = ", DEBUG_ARITH );
debug_print_128bit( carry, DEBUG_ARITH );
debug_print( L"; rv = ", DEBUG_ARITH );
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) { debug_print( L"add_integers: av = ", DEBUG_ARITH );
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL ); debug_print_128bit( av, DEBUG_ARITH );
break; debug_print( L"; bv = ", DEBUG_ARITH );
} else { debug_print_128bit( bv, DEBUG_ARITH );
struct cons_pointer new = make_integer( 0, NIL ); debug_print( L"; carry = ", DEBUG_ARITH );
carry = int128_to_integer( rv, cursor, new ); debug_print_128bit( carry, DEBUG_ARITH );
cursor = new; debug_print( L"; rv = ", DEBUG_ARITH );
debug_print_128bit( rv, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( nilp( result ) ) { if ( carry == 0 && ( rv >= 0 || rv < SMALL_INT_LIMIT ) ) {
result = cursor; result =
acquire_integer( ( int64_t ) ( rv & 0xffffffff ), NIL );
break;
} else {
struct cons_pointer new = make_integer( 0, NIL );
carry = int128_to_integer( rv, cursor, new );
cursor = new;
if ( nilp( result ) ) {
result = cursor;
}
a = pointer2cell( a ).payload.integer.more;
b = pointer2cell( b ).payload.integer.more;
is_first_cell = false;
} }
a = pointer2cell( a ).payload.integer.more;
b = pointer2cell( b ).payload.integer.more;
is_first_cell = false;
} }
} }
@ -506,3 +521,21 @@ bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) {
return result; return result;
} }
/**
* true if `a` is an integer, and `b` is a real number whose value is the
* value of that integer.
*/
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( integerp( a ) && realp( b ) ) {
long double bv = pointer2cell( b ).payload.real.value;
if ( floor( bv ) == bv ) {
result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv;
}
}
return result;
}

View file

@ -13,8 +13,6 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdint.h> #include <stdint.h>
#include "memory/consspaceobject.h"
#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;} #define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;}
#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;} #define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;}

View file

@ -64,35 +64,6 @@ bool zerop( struct cons_pointer arg ) {
return result; return result;
} }
// TODO: think about
// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) {
// bool result = false;
// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
// if (cell_1->tag.value == cell_2->tag.value) {
// switch ( cell_1->tag.value ) {
// case INTEGERTV:{
// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) {
// result = cell_1->payload.integer.value > cell_2->payload.integer.value;
// }
// // else deal with comparing bignums...
// }
// break;
// case RATIOTV:
// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2);
// break;
// case REALTV:
// result = ( cell.payload.real.value == 0 );
// break;
// }
// }
// return result;
// }
/** /**
* does this `arg` point to a negative number? * does this `arg` point to a negative number?
*/ */
@ -115,36 +86,24 @@ bool is_negative( struct cons_pointer arg ) {
return result; return result;
} }
/**
* @brief if `arg` is a number, return the absolute value of that number, else
* `NIL`
*
* @param arg a cons space object, probably a number.
* @return struct cons_pointer
*/
struct cons_pointer absolute( struct cons_pointer arg ) { struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
if ( numberp( arg ) ) { if ( is_negative( arg ) ) {
if ( is_negative( arg ) ) { switch ( cell.tag.value ) {
switch ( cell.tag.value ) { case INTEGERTV:
case INTEGERTV: result =
result = make_integer( llabs( cell.payload.integer.value ),
make_integer( llabs( cell.payload.integer.value ), cell.payload.integer.more );
cell.payload.integer.more ); break;
break; case RATIOTV:
case RATIOTV: result = make_ratio( absolute( cell.payload.ratio.dividend ),
result = cell.payload.ratio.divisor );
make_ratio( absolute( cell.payload.ratio.dividend ), break;
cell.payload.ratio.divisor, false ); case REALTV:
break; result = make_real( 0 - cell.payload.real.value );
case REALTV: break;
result = make_real( 0 - cell.payload.real.value );
break;
}
} else {
result = arg;
} }
} }
@ -296,11 +255,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = result = throw_exception( c_string_to_lisp_string
throw_exception( c_string_to_lisp_symbol( L"+" ), ( L"Cannot add: not a number" ),
c_string_to_lisp_string frame_pointer );
( L"Cannot add: not a number" ),
frame_pointer );
break; break;
} }
break; break;
@ -321,11 +278,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = result = throw_exception( c_string_to_lisp_string
throw_exception( c_string_to_lisp_symbol( L"+" ), ( L"Cannot add: not a number" ),
c_string_to_lisp_string frame_pointer );
( L"Cannot add: not a number" ),
frame_pointer );
break; break;
} }
break; break;
@ -336,8 +291,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break; break;
default: default:
result = exceptionp( arg2 ) ? arg2 : result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_symbol( L"+" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot add: not a number" ), ( L"Cannot add: not a number" ),
frame_pointer ); frame_pointer );
} }
@ -433,8 +387,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ), ( L"Cannot multiply: argument 2 is not a number: " ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -460,8 +413,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( make_cons
make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ), ( L"Cannot multiply: argument 2 is not a number" ),
c_type( arg2 ) ), c_type( arg2 ) ),
@ -474,8 +426,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"*" ), result = throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ), ( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ), c_type( arg1 ) ),
frame_pointer ); frame_pointer );
@ -553,7 +504,7 @@ struct cons_pointer negative( struct cons_pointer arg ) {
break; break;
case RATIOTV: case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ), result = make_ratio( negative( cell.payload.ratio.dividend ),
cell.payload.ratio.divisor, false ); cell.payload.ratio.divisor );
break; break;
case REALTV: case REALTV:
result = make_real( 0 - to_long_double( arg ) ); result = make_real( 0 - to_long_double( arg ) );
@ -615,8 +566,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case RATIOTV:{ case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1, struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1, make_integer( 1,
NIL ), NIL ) );
false );
inc_ref( tmp ); inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 ); result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp ); dec_ref( tmp );
@ -628,8 +578,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -643,8 +592,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2, struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1, make_integer( 1,
NIL ), NIL ) );
false );
inc_ref( tmp ); inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp ); result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp ); dec_ref( tmp );
@ -659,8 +607,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) ); to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -671,8 +618,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"-" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot subtract: not a number" ), ( L"Cannot subtract: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -724,14 +670,21 @@ struct cons_pointer lisp_divide( struct
result = frame->arg[1]; result = frame->arg[1];
break; break;
case INTEGERTV:{ case INTEGERTV:{
result = struct cons_pointer unsimplified =
make_ratio( frame->arg[0], frame->arg[1], true ); make_ratio( frame->arg[0],
frame->arg[1] );
/* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} }
break; break;
case RATIOTV:{ case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[0], one, false ); make_ratio( frame->arg[0], one );
inc_ref( ratio ); inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] ); result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio ); dec_ref( ratio );
@ -743,8 +696,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -757,8 +709,10 @@ struct cons_pointer lisp_divide( struct
break; break;
case INTEGERTV:{ case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer one = make_integer( 1, NIL );
inc_ref( one );
struct cons_pointer ratio = struct cons_pointer ratio =
make_ratio( frame->arg[1], one, false ); make_ratio( frame->arg[1], one );
inc_ref( ratio );
result = divide_ratio_ratio( frame->arg[0], ratio ); result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio ); dec_ref( ratio );
dec_ref( one ); dec_ref( one );
@ -774,8 +728,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -787,8 +740,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) ); to_long_double( frame->arg[1] ) );
break; break;
default: default:
result = throw_exception( c_string_to_lisp_symbol( L"/" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Cannot divide: not a number" ), ( L"Cannot divide: not a number" ),
frame_pointer ); frame_pointer );
break; break;
@ -796,30 +748,3 @@ struct cons_pointer lisp_divide( struct
return result; return result;
} }
/**
* @brief Function: return a real (approcimately) equal in value to the ratio
* which is the first argument.
*
* @param frame
* @param frame_pointer
* @param env
* @return struct cons_pointer a pointer to a real
*/
// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
// struct cons_pointer env )
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_pointer rat = frame->arg[0];
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat ) ) {
result = make_real( c_ratio_to_ld( rat ) );
} // TODO: else throw an exception?
return result;
}

View file

@ -31,19 +31,6 @@
*/ */
#define INTEGER_BIT_SHIFT (60) #define INTEGER_BIT_SHIFT (60)
/**
* @brief return `true` if arg is `nil`, else `false`.
*
* Note that this doesn't really belong in `peano.h`, but after code cleanup it
* was the last thing remaining in either `boolean.c` or `boolean.h`, and it
* wasn't worth keeping two files around for one one-line macro.
*
* @param arg
* @return true if the sole argument is `nil`.
* @return false otherwise.
*/
#define truthy(arg)(!nilp(arg))
bool zerop( struct cons_pointer arg ); bool zerop( struct cons_pointer arg );
struct cons_pointer negative( struct cons_pointer arg ); struct cons_pointer negative( struct cons_pointer arg );
@ -88,8 +75,4 @@ struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif /* PEANO_H */ #endif /* PEANO_H */

View file

@ -11,21 +11,19 @@
#include <math.h> #include <math.h>
#include <stdio.h> #include <stdio.h>
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
#include "arith/real.h"
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h" #include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/stack.h" #include "debug.h"
#include "ops/equal.h" #include "ops/equal.h"
#include "arith/integer.h"
#include "ops/lispops.h" #include "ops/lispops.h"
#include "arith/peano.h"
#include "io/print.h"
#include "arith/ratio.h"
/** /**
* @brief return, as an int64_t, the greatest common divisor of `m` and `n`, * return, as a int64_t, the greatest common divisor of `m` and `n`,
*/ */
int64_t greatest_common_divisor( int64_t m, int64_t n ) { int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o; int o;
@ -39,7 +37,7 @@ int64_t greatest_common_divisor( int64_t m, int64_t n ) {
} }
/** /**
* @brief return, as an int64_t, the least common multiple of `m` and `n`, * return, as a int64_t, the least common multiple of `m` and `n`,
*/ */
int64_t least_common_multiple( int64_t m, int64_t n ) { int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n; return m / greatest_common_divisor( m, n ) * n;
@ -64,16 +62,14 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
if ( gcd > 1 ) { if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) { if ( drrv / gcd == 1 ) {
result = result = acquire_integer( ddrv / gcd, NIL );
acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL );
} else { } else {
debug_printf( DEBUG_ARITH, debug_printf( DEBUG_ARITH,
L"simplify_ratio: %ld/%ld => %ld/%ld\n", L"simplify_ratio: %ld/%ld => %ld/%ld\n",
ddrv, drrv, ddrv / gcd, drrv / gcd ); ddrv, drrv, ddrv / gcd, drrv / gcd );
result = result =
make_ratio( acquire_integer( ddrv / gcd, NIL ), make_ratio( acquire_integer( ddrv / gcd, NIL ),
acquire_integer( drrv / gcd, NIL ), acquire_integer( drrv / gcd, NIL ) );
false );
} }
} }
} }
@ -93,40 +89,74 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
*/ */
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
struct cons_pointer r; struct cons_pointer r, result;
debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH ); debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH ); debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) { if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object *cell1 = &pointer2cell( arg1 ); struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object *cell2 = &pointer2cell( arg2 ); struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v;
struct cons_pointer divisor = debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm,
multiply_integers( cell1->payload.ratio.divisor, m1, m2 );
cell2->payload.ratio.divisor );
struct cons_pointer dividend = if ( dr1v == dr2v ) {
add_integers( multiply_integers( cell1->payload.ratio.dividend, r = make_ratio( acquire_integer( dd1v + dd2v, NIL ),
cell2->payload.ratio.divisor ), cell1.payload.ratio.divisor );
multiply_integers( cell2->payload.ratio.dividend, } else {
cell1->payload.ratio.divisor ) ); struct cons_pointer dd1vm = acquire_integer( dd1v * m1, NIL ),
r = make_ratio( dividend, divisor, true ); dr1vm = acquire_integer( dr1v * m1, NIL ),
dd2vm = acquire_integer( dd2v * m2, NIL ),
dr2vm = acquire_integer( dr2v * m2, NIL ),
r1 = make_ratio( dd1vm, dr1vm ),
r2 = make_ratio( dd2vm, dr2vm );
r = add_ratio_ratio( r1, r2 );
if ( !eq( r, r1 ) ) {
dec_ref( r1 );
}
if ( !eq( r, r2 ) ) {
dec_ref( r2 );
}
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
* r1 and r2 should be enought to garbage collect them. */
}
result = simplify_ratio( r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else { } else {
r = throw_exception( c_string_to_lisp_symbol( L"+" ), result =
make_cons( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ), ( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1, make_cons( arg1,
make_cons( arg2, NIL ) ) ), make_cons( arg2, NIL ) ) ),
NIL ); NIL );
} }
debug_print( L"add_ratio_ratio => ", DEBUG_ARITH ); debug_print( L" => ", DEBUG_ARITH );
debug_print_object( r, DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH );
return r; return result;
} }
@ -140,14 +170,10 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" + ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: not longer works
struct cons_pointer one = acquire_integer( 1, NIL ), struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false ); ratio = make_ratio( intarg, one );
result = add_ratio_ratio( ratio, ratarg ); result = add_ratio_ratio( ratio, ratarg );
@ -155,18 +181,13 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
dec_ref( ratio ); dec_ref( ratio );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"+" ), throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ), ( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg, make_cons( intarg,
make_cons( ratarg, make_cons( ratarg,
NIL ) ) ), NIL ); NIL ) ) ), NIL );
} }
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result; return result;
} }
@ -178,22 +199,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
*/ */
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" / ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
// TODO: this now has to work if `arg1` is an integer // TODO: this now has to work if `arg1` is an integer
struct cons_pointer i = struct cons_pointer i =
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
pointer2cell( arg2 ).payload.ratio.dividend, false ), pointer2cell( arg2 ).payload.ratio.dividend ), result =
result = multiply_ratio_ratio( arg1, i ); multiply_ratio_ratio( arg1, i );
dec_ref( i ); dec_ref( i );
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result; return result;
} }
@ -230,22 +243,22 @@ struct cons_pointer multiply_ratio_ratio( struct
struct cons_pointer dividend = acquire_integer( ddrv, NIL ); struct cons_pointer dividend = acquire_integer( ddrv, NIL );
struct cons_pointer divisor = acquire_integer( drrv, NIL ); struct cons_pointer divisor = acquire_integer( drrv, NIL );
result = make_ratio( dividend, divisor, true ); struct cons_pointer unsimplified = make_ratio( dividend, divisor );
result = simplify_ratio( unsimplified );
release_integer( dividend ); release_integer( dividend );
release_integer( divisor ); release_integer( divisor );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL ); NIL );
} }
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result; return result;
} }
@ -259,29 +272,20 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) { struct cons_pointer ratarg ) {
struct cons_pointer result; struct cons_pointer result;
debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH );
debug_print_object( intarg, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH );
debug_print_object( ratarg, DEBUG_ARITH );
if ( integerp( intarg ) && ratiop( ratarg ) ) { if ( integerp( intarg ) && ratiop( ratarg ) ) {
// TODO: no longer works; fix
struct cons_pointer one = acquire_integer( 1, NIL ), struct cons_pointer one = acquire_integer( 1, NIL ),
ratio = make_ratio( intarg, one, false ); ratio = make_ratio( intarg, one );
result = multiply_ratio_ratio( ratio, ratarg ); result = multiply_ratio_ratio( ratio, ratarg );
release_integer( one ); release_integer( one );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"*" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL ); NIL );
} }
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result; return result;
} }
@ -294,11 +298,6 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
*/ */
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) { struct cons_pointer arg2 ) {
debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L" * ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
struct cons_pointer i = negative( arg2 ), struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i ); result = add_ratio_ratio( arg1, i );
@ -315,13 +314,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
* @exception if either `dividend` or `divisor` is not an integer. * @exception if either `dividend` or `divisor` is not an integer.
*/ */
struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor, bool simplify ) { struct cons_pointer divisor ) {
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC );
debug_print_object( dividend, DEBUG_ALLOC );
debug_print( L"; divisor = ", DEBUG_ALLOC );
debug_print_object( divisor, DEBUG_ALLOC );
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify );
struct cons_pointer result; struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) { if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend ); inc_ref( dividend );
@ -331,24 +324,18 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
cell->payload.ratio.dividend = dividend; cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor; cell->payload.ratio.divisor = divisor;
if ( simplify ) { result = simplify_ratio( unsimplified );
result = simplify_ratio( unsimplified ); if ( !eq( result, unsimplified ) ) {
if ( !eq( result, unsimplified ) ) { dec_ref( unsimplified );
dec_ref( unsimplified );
}
} else {
result = unsimplified;
} }
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ), ( L"Dividend and divisor of a ratio must be integers" ),
NIL ); NIL );
} }
debug_print( L" => ", DEBUG_ALLOC ); // debug_print( L"make_ratio returning:\n", DEBUG_ARITH);
debug_print_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ARITH );
debug_println( DEBUG_ALLOC );
return result; return result;
} }
@ -374,38 +361,3 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
return result; return result;
} }
/**
* @brief convert a ratio to an equivalent long double.
*
* @param rat a pointer to a ratio.
* @return long double
*/
long double c_ratio_to_ld( struct cons_pointer rat ) {
long double result = NAN;
debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
debug_print_object( rat, DEBUG_ARITH );
if ( ratiop( rat ) ) {
struct cons_space_object *cell_a = &pointer2cell( rat );
struct cons_pointer dv = cell_a->payload.ratio.divisor;
struct cons_space_object *dv_cell = &pointer2cell( dv );
struct cons_pointer dd = cell_a->payload.ratio.dividend;
struct cons_space_object *dd_cell = &pointer2cell( dd );
if ( nilp( dv_cell->payload.integer.more )
&& nilp( dd_cell->payload.integer.more ) ) {
result =
( ( long double ) dd_cell->payload.integer.value ) /
( ( long double ) dv_cell->payload.integer.value );;
} else {
fwprintf( stderr,
L"real conversion is not yet implemented for bignums rationals." );
}
}
debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result );
return result;
}

View file

@ -32,10 +32,8 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ); struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer make_ratio( struct cons_pointer dividend,
struct cons_pointer divisor, bool simplify ); struct cons_pointer divisor );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
long double c_ratio_to_ld( struct cons_pointer rat );
#endif #endif

View file

@ -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`.
* *
@ -162,20 +143,3 @@ void debug_dump_object( struct cons_pointer pointer, int level ) {
} }
#endif #endif
} }
/**
* Standardise printing of binding trace messages.
*/
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level ) {
#ifdef DEBUG
// wchar_t * depth = (deep ? L"Deep" : L"Shallow");
debug_print( ( deep ? L"Deep" : L"Shallow" ), level );
debug_print( L" binding `", level );
debug_print_object( key, level );
debug_print( L"` to `", level );
debug_print_object( val, level );
debug_print( L"`\n", level );
#endif
}

View file

@ -8,11 +8,8 @@
*/ */
#include <ctype.h> #include <ctype.h>
#include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include "memory/consspaceobject.h"
#ifndef __debug_print_h #ifndef __debug_print_h
#define __debug_print_h #define __debug_print_h
@ -79,23 +76,13 @@
*/ */
#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 );
void debug_printf( int level, wchar_t *format, ... ); void debug_printf( int level, wchar_t *format, ... );
void debug_print_object( struct cons_pointer pointer, int level ); void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level );
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
bool deep, int level );
#endif #endif

View file

@ -20,22 +20,22 @@
/* libcurl, used for io */ /* libcurl, used for io */
#include <curl/curl.h> #include <curl/curl.h>
#include "arith/peano.h" #include "version.h"
#include "arith/ratio.h"
#include "debug.h"
#include "io/fopen.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h" #include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "memory/stack.h" #include "memory/stack.h"
#include "debug.h"
#include "memory/hashmap.h"
#include "ops/intern.h" #include "ops/intern.h"
#include "io/io.h"
#include "io/fopen.h"
#include "ops/lispops.h" #include "ops/lispops.h"
#include "ops/meta.h" #include "ops/meta.h"
#include "arith/peano.h"
#include "io/print.h"
#include "repl.h" #include "repl.h"
#include "io/fopen.h"
#include "time/psse_time.h" #include "time/psse_time.h"
#include "version.h"
/** /**
* @brief If `pointer` is an exception, display that exception to stderr, * @brief If `pointer` is an exception, display that exception to stderr,
@ -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,47 +59,31 @@ 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_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_name_symbol ) ) {
privileged_keyword_documentation = init_name_symbol = c_string_to_lisp_keyword( L"name" );
c_string_to_lisp_keyword( L"documentation" );
} }
if ( nilp( privileged_keyword_name ) ) { if ( nilp( init_primitive_symbol ) ) {
privileged_keyword_name = c_string_to_lisp_keyword( L"name" ); init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" );
}
if ( nilp( privileged_keyword_primitive ) ) {
privileged_keyword_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" );
} }
// we can't make this string when we need it, because memory is then
// exhausted!
if ( nilp( privileged_string_memory_exhausted ) ) {
privileged_string_memory_exhausted =
c_string_to_lisp_string( L"Memory exhausted." );
}
if ( nilp( privileged_keyword_location ) ) {
privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
}
if ( nilp( privileged_keyword_payload ) ) {
privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" );
}
if ( nilp( privileged_keyword_cause ) ) {
privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" );
}
} }
void free_init_symbols( ) { void free_init_symbols( ) {
dec_ref( privileged_keyword_documentation ); dec_ref( init_name_symbol );
dec_ref( privileged_keyword_name ); dec_ref( init_primitive_symbol );
dec_ref( privileged_keyword_primitive );
} }
/** /**
@ -111,28 +94,21 @@ void free_init_symbols( ) {
* more readable and aid debugging generally. * more readable and aid debugging generally.
*/ */
struct cons_pointer bind_function( wchar_t *name, struct cons_pointer bind_function( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ) ) { struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
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 NIL ) );
( privileged_keyword_documentation,
d ),
NIL ) ) );
struct cons_pointer r = struct cons_pointer r =
check_exception( deep_bind( n, make_function( meta, executable ) ), check_exception( deep_bind( n, make_function( meta, executable ) ),
"bind_function" ); "bind_function" );
dec_ref( n ); dec_ref( n );
dec_ref( d );
return r; return r;
} }
@ -142,27 +118,20 @@ struct cons_pointer bind_function( wchar_t *name,
* this `name` in the `oblist`. * this `name` in the `oblist`.
*/ */
struct cons_pointer bind_special( wchar_t *name, struct cons_pointer bind_special( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, struct cons_pointer, ( struct stack_frame *, struct cons_pointer,
struct cons_pointer ) ) { struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
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 ), NIL ) );
make_cons( make_cons
( privileged_keyword_documentation,
d ),
NIL ) ) );
struct cons_pointer r = struct cons_pointer r =
check_exception( deep_bind( n, make_special( meta, executable ) ), check_exception( deep_bind( n, make_special( meta, executable ) ),
"bind_special" ); "bind_special" );
dec_ref( n ); dec_ref( n );
dec_ref( d );
return r; return r;
} }
@ -215,9 +184,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
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" );
fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" );
@ -229,9 +195,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
} }
/** /**
@ -250,7 +214,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 +230,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;
@ -300,8 +261,6 @@ int main( int argc, char *argv[] ) {
*/ */
bind_symbol_value( privileged_symbol_nil, NIL, true ); bind_symbol_value( privileged_symbol_nil, NIL, true );
bind_value( L"t", TRUE, true ); bind_value( L"t", TRUE, true );
bind_symbol_value( privileged_keyword_location, TRUE, true );
bind_symbol_value( privileged_keyword_payload, TRUE, true );
/* /*
* standard input, output, error and sink streams * standard input, output, error and sink streams
@ -332,7 +291,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 ),
@ -359,207 +318,78 @@ int main( int argc, char *argv[] ) {
/* /*
* primitive function operations * primitive function operations
*/ */
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system. bind_function( L"absolute", &lisp_absolute );
* HTTP from an address at journeyman? */ bind_function( L"add", &lisp_add );
bind_function( L"absolute", bind_function( L"append", &lisp_append );
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.", bind_function( L"apply", &lisp_apply );
&lisp_absolute ); bind_function( L"assoc", &lisp_assoc );
bind_function( L"add", bind_function( L"car", &lisp_car );
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.", bind_function( L"cdr", &lisp_cdr );
&lisp_add ); bind_function( L"close", &lisp_close );
bind_function( L"and", bind_function( L"cons", &lisp_cons );
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.", bind_function( L"divide", &lisp_divide );
&lisp_and ); bind_function( L"eq", &lisp_eq );
bind_function( L"append", bind_function( L"equal", &lisp_equal );
L"`(append args...)`: If args are all collections, return the concatenation of those collections.", bind_function( L"eval", &lisp_eval );
&lisp_append ); bind_function( L"exception", &lisp_exception );
bind_function( L"apply", bind_function( L"get-hash", &lisp_get_hash );
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.", bind_function( L"hashmap", lisp_make_hashmap );
&lisp_apply ); bind_function( L"inspect", &lisp_inspect );
bind_function( L"assoc", bind_function( L"keys", &lisp_keys );
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.", bind_function( L"list", &lisp_list );
&lisp_assoc ); bind_function( L"mapcar", &lisp_mapcar );
bind_function( L"car", bind_function( L"meta", &lisp_metadata );
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.", bind_function( L"metadata", &lisp_metadata );
&lisp_car ); bind_function( L"multiply", &lisp_multiply );
bind_function( L"cdr", bind_function( L"negative?", &lisp_is_negative );
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.", bind_function( L"oblist", &lisp_oblist );
&lisp_cdr ); bind_function( L"open", &lisp_open );
bind_function( L"close", bind_function( L"print", &lisp_print );
L"`(close stream)`: If `stream` is a stream, close that stream.", bind_function( L"put!", lisp_hashmap_put );
&lisp_close ); bind_function( L"put-all!", &lisp_hashmap_put_all );
bind_function( L"cons", bind_function( L"read", &lisp_read );
L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.", bind_function( L"read-char", &lisp_read_char );
&lisp_cons ); bind_function( L"repl", &lisp_repl );
bind_function( L"count", bind_function( L"reverse", &lisp_reverse );
L"`(count s)`: Return the number of items in the sequence `s`.", bind_function( L"set", &lisp_set );
&lisp_count ); bind_function( L"slurp", &lisp_slurp );
bind_function( L"divide", bind_function( L"source", &lisp_source );
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.", bind_function( L"subtract", &lisp_subtract );
&lisp_divide ); bind_function( L"throw", &lisp_exception );
bind_function( L"eq?", bind_function( L"time", &lisp_time );
L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.", bind_function( L"type", &lisp_type );
&lisp_eq ); bind_function( L"+", &lisp_add );
bind_function( L"equal?", bind_function( L"*", &lisp_multiply );
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", bind_function( L"-", &lisp_subtract );
&lisp_equal ); bind_function( L"/", &lisp_divide );
bind_function( L"eval", L"", &lisp_eval ); bind_function( L"=", &lisp_equal );
bind_function( L"exception",
L"`(exception message)`: Return (throw) an exception with this `message`.",
&lisp_exception );
bind_function( L"get-hash",
L"`(get-hash arg)`: returns the natural number hash value of `arg`.",
&lisp_get_hash );
bind_function( L"hashmap",
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
lisp_make_hashmap );
bind_function( L"inspect",
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
&lisp_inspect );
bind_function( L"interned?",
L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.",
&lisp_internedp );
bind_function( L"keys",
L"`(keys store)`: Return a list of all keys in this `store`.",
&lisp_keys );
bind_function( L"list",
L"`(list args...)`: Return a list of these `args`.",
&lisp_list );
bind_function( L"mapcar",
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
&lisp_mapcar );
bind_function( L"meta",
L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"metadata",
L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
&lisp_metadata );
bind_function( L"multiply",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"negative?",
L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.",
&lisp_is_negative );
bind_function( L"not",
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
&lisp_not );
bind_function( L"oblist",
L"`(oblist)`: Return the current symbol bindings, as a map.",
&lisp_oblist );
bind_function( L"open",
L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.",
&lisp_open );
bind_function( L"or",
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
&lisp_or );
bind_function( L"print",
L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.",
&lisp_print );
bind_function( L"println",
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
&lisp_println );
bind_function( L"put!", L"", lisp_hashmap_put );
bind_function( L"put-all!",
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
&lisp_hashmap_put_all );
bind_function( L"ratio->real",
L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.",
&lisp_ratio_to_real );
bind_function( L"read",
L"`(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read );
bind_function( L"read-char",
L"`(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
&lisp_read_char );
bind_function( L"repl",
L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.",
&lisp_repl );
bind_function( L"reverse",
L"`(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order.",
&lisp_reverse );
bind_function( L"set", L"", &lisp_set );
bind_function( L"slurp",
L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.",
&lisp_slurp );
bind_function( L"source",
L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.",
&lisp_source );
bind_function( L"subtract",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"throw",
L"`(throw message cause)`: Throw an exception with this `message`, and, if specified, this `cause` (which is expected to be an exception but need not be).",
&lisp_exception );
bind_function( L"time",
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
&lisp_time );
bind_function( L"type",
L"`(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change.",
&lisp_type );
bind_function( L"+",
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
&lisp_add );
bind_function( L"*",
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
&lisp_multiply );
bind_function( L"-",
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
&lisp_subtract );
bind_function( L"/",
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
&lisp_divide );
bind_function( L"=",
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
&lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special( L"cond", bind_special( L"cond", &lisp_cond );
L"`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated.", bind_special( L"lambda", &lisp_lambda );
&lisp_cond ); bind_special( L"\u03bb", &lisp_lambda ); // λ
bind_special( L"lambda", bind_special( L"let", &lisp_let );
L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.", bind_special( L"nlambda", &lisp_nlambda );
&lisp_lambda ); bind_special( L"n\u03bb", &lisp_nlambda );
bind_special( L"\u03bb", L"", &lisp_lambda ); // λ bind_special( L"progn", &lisp_progn );
bind_special( L"let", bind_special( L"quote", &lisp_quote );
L"`(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last.", bind_special( L"set!", &lisp_set_shriek );
&lisp_let ); bind_special( L"try", &lisp_try );
bind_special( L"nlambda",
L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.",
&lisp_nlambda );
bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ
bind_special( L"progn",
L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.",
&lisp_progn );
bind_special( L"quote",
L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.",
&lisp_quote );
bind_special( L"set!",
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
&lisp_set_shriek );
bind_special( L"try",
L"`(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 );
repl( show_prompt ); repl( show_prompt );
debug_dump_object( oblist, DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP );
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
while ( ( pointer2cell( oblist ) ).count > 0 ) {
fprintf( stderr, "Dangling refs on oblist: %d\n",
( pointer2cell( oblist ) ).count );
dec_ref( oblist );
}
free_init_symbols( );
if ( dump_at_end ) { if ( dump_at_end ) {
dump_pages( file_to_url_file( stdout ) ); dump_pages( file_to_url_file( stdout ) );
} }
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
dec_ref( oblist );
free_init_symbols( );
summarise_allocation( ); summarise_allocation( );
curl_global_cleanup( ); curl_global_cleanup( );
return ( 0 ); return ( 0 );

View file

@ -420,7 +420,7 @@ struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
/** /**
* Function: return a stream open on the URL indicated by the first argument; * Function: return a stream open on the URL indicated by the first argument;
* if a second argument is present and is non-nil, open it for writing. At * if a second argument is present and is non-nil, open it for reading. At
* present, further arguments are ignored and there is no mechanism to open * present, further arguments are ignored and there is no mechanism to open
* to append, or error if the URL is faulty or indicates an unavailable * to append, or error if the URL is faulty or indicates an unavailable
* resource. * resource.

View file

@ -17,17 +17,15 @@
#include <wchar.h> #include <wchar.h>
#include <wctype.h> #include <wctype.h>
#include "arith/integer.h"
#include "debug.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h" #include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/hashmap.h" #include "memory/hashmap.h"
#include "memory/stack.h" #include "arith/integer.h"
#include "memory/vectorspace.h"
#include "ops/intern.h" #include "ops/intern.h"
#include "memory/stack.h"
#include "io/print.h"
#include "time/psse_time.h" #include "time/psse_time.h"
#include "memory/vectorspace.h"
/** /**
* print all the characters in the symbol or string indicated by `pointer` * print all the characters in the symbol or string indicated by `pointer`
@ -101,7 +99,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 );
@ -118,9 +116,6 @@ void print_vso( URL_FILE *output, struct cons_pointer pointer ) {
case HASHTV: case HASHTV:
print_map( output, pointer ); print_map( output, pointer );
break; break;
case STACKFRAMETV:
dump_stack_trace( output, pointer );
break;
// \todo: others. // \todo: others.
default: default:
fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
@ -253,7 +248,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
url_fwprintf( output, L"<Time: " ); url_fwprintf( output, L"<Time: " );
print_string( output, time_to_string( pointer ) ); print_string( output, time_to_string( pointer ) );
url_fputws( L"; ", output ); url_fputws( L"; ", output );
print_128bit( output, cell.payload.time.value ); print_128bit( output, pointer2cell( pointer ).payload.time.value );
url_fputwc( L'>', output ); url_fputwc( L'>', output );
break; break;
case TRUETV: case TRUETV:
@ -271,86 +266,12 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
fwprintf( stderr, fwprintf( stderr,
L"Error: Unrecognised tag value %d (%4.4s)\n", L"Error: Unrecognised tag value %d (%4.4s)\n",
cell.tag.value, &cell.tag.bytes[0] ); cell.tag.value, &cell.tag.bytes[0] );
// dump_object( stderr, pointer);
break; break;
} }
return pointer; return pointer;
} }
/**
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
* is a write stream, then print to that stream, else the stream which is the value of
* `*out*` in the environment.
*
* * (print expr)
* * (print expr write-stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (from which the stream may be extracted).
* @return NIL.
*/
struct cons_pointer
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print( L"Entering print\n", DEBUG_IO );
struct cons_pointer result = NIL;
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
debug_dump_object( out_stream, DEBUG_IO );
output = pointer2cell( out_stream ).payload.stream.stream;
inc_ref( out_stream );
} else {
output = file_to_url_file( stderr );
}
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
result = print( output, frame->arg[0] );
debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
if ( writep( out_stream ) ) {
dec_ref( out_stream );
} else {
free( output );
}
return result;
}
void println( URL_FILE *output ) { void println( URL_FILE *output ) {
url_fputws( L"\n", output ); url_fputws( L"\n", output );
} }
/**
* @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
* it is specified and is an output stream, else to `*out*`.
*
* @param frame
* @param frame_pointer
* @param env
* @return `nil`
*/
struct cons_pointer
lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
URL_FILE *output;
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
frame->arg[1] : get_default_stream( false, env );
if ( writep( out_stream ) ) {
output = pointer2cell( out_stream ).payload.stream.stream;
println( output );
}
return NIL;
}

View file

@ -19,12 +19,4 @@
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
void println( URL_FILE * output ); void println( URL_FILE * output );
struct cons_pointer lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_println( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif #endif

View file

@ -90,7 +90,7 @@ struct cons_pointer read_path( URL_FILE *input, wint_t initial,
switch ( initial ) { switch ( initial ) {
case '/': case '/':
prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL ); prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL);
break; break;
case '$': case '$':
case LSESSION: case LSESSION:
@ -167,8 +167,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( url_feof( input ) ) { if ( url_feof( input ) ) {
result = result =
throw_exception( c_string_to_lisp_symbol( L"read" ), throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
@ -178,8 +177,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = throw_exception( c_string_to_lisp_symbol( L"read" ), result = throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"End of input while reading" ), ( L"End of input while reading" ),
frame_pointer ); frame_pointer );
break; break;
@ -268,8 +266,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol_or_key( input, SYMBOLTV, c ); result = read_symbol_or_key( input, SYMBOLTV, c );
} else { } else {
result = result =
throw_exception( c_string_to_lisp_symbol( L"read" ), throw_exception( make_cons( c_string_to_lisp_string
make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
make_string( c, NIL ) ), make_string( c, NIL ) ),
frame_pointer ); frame_pointer );
@ -316,8 +313,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
switch ( c ) { switch ( c ) {
case LPERIOD: case LPERIOD:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ), return throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Malformed number: too many periods" ), ( L"Malformed number: too many periods" ),
frame_pointer ); frame_pointer );
} else { } else {
@ -328,8 +324,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
break; break;
case LSLASH: case LSLASH:
if ( seen_period || !nilp( dividend ) ) { if ( seen_period || !nilp( dividend ) ) {
return throw_exception( c_string_to_lisp_symbol( L"read" ), return throw_exception( c_string_to_lisp_string
c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ), ( L"Malformed number: dividend of rational must be integer" ),
frame_pointer ); frame_pointer );
} else { } else {
@ -375,7 +370,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
( to_long_double ( to_long_double
( base ), ( base ),
places_of_decimals ), places_of_decimals ),
NIL ), true ); NIL ) );
inc_ref( div ); inc_ref( div );
result = make_real( to_long_double( div ) ); result = make_real( to_long_double( div ) );
@ -383,7 +378,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
dec_ref( div ); dec_ref( div );
} else if ( integerp( dividend ) ) { } else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
result = make_ratio( dividend, result, true ); result = make_ratio( dividend, result );
} }
if ( neg ) { if ( neg ) {

View file

@ -45,12 +45,6 @@ int initialised_cons_pages = 0;
*/ */
struct cons_pointer freelist = NIL; struct cons_pointer freelist = NIL;
/**
* The exception message printed when the world blows up, initialised in
* `maybe_bind_init_symbols()` in `init.c`, q.v.
*/
struct cons_pointer privileged_string_memory_exhausted;
/** /**
* An array of pointers to cons pages. * An array of pointers to cons pages.
*/ */
@ -65,11 +59,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 +110,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 );
} }
} }
/** /**
@ -136,12 +126,9 @@ void dump_pages( URL_FILE *output ) {
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
for ( int j = 0; j < CONSPAGESIZE; j++ ) { for ( int j = 0; j < CONSPAGESIZE; j++ ) {
struct cons_pointer pointer = ( struct cons_pointer ) { i, j }; dump_object( output, ( struct cons_pointer ) {
if ( !freep( pointer ) ) { i, j
dump_object( output, ( struct cons_pointer ) { } );
i, j
} );
}
} }
} }
} }
@ -254,9 +241,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!" );
} }

View file

@ -49,8 +49,6 @@ struct cons_page {
struct cons_space_object cell[CONSPAGESIZE]; struct cons_space_object cell[CONSPAGESIZE];
}; };
extern struct cons_pointer privileged_string_memory_exhausted;
extern struct cons_pointer freelist; extern struct cons_pointer freelist;
extern struct cons_page *conspages[NCONSPAGES]; extern struct cons_page *conspages[NCONSPAGES];

View file

@ -27,44 +27,6 @@
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/intern.h" #include "ops/intern.h"
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`q.v.
*/
struct cons_pointer privileged_keyword_location = NIL;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`, q.v.
*/
struct cons_pointer privileged_keyword_payload = NIL;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`, q.v.
*/
struct cons_pointer privileged_keyword_cause = NIL;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*
*/
struct cons_pointer privileged_keyword_documentation = NIL;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_name = NIL;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
struct cons_pointer privileged_keyword_primitive = NIL;
/** /**
* True if the value of the tag on the cell at this `pointer` is this `value`, * 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
@ -73,11 +35,11 @@ struct cons_pointer privileged_keyword_primitive = NIL;
bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false; bool result = false;
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
result = cell->tag.value == value; result = cell.tag.value == value;
if ( result == false ) { if ( result == false ) {
if ( cell->tag.value == VECTORPOINTTV ) { if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) { if ( vec != NULL ) {
@ -102,19 +64,6 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
if ( cell->count < MAXREFERENCE ) { if ( cell->count < MAXREFERENCE ) {
cell->count++; cell->count++;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC );
}
#endif
} }
return pointer; return pointer;
@ -133,20 +82,6 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
if ( cell->count > 0 && cell->count != UINT32_MAX ) { if ( cell->count > 0 && cell->count != UINT32_MAX ) {
cell->count--; cell->count--;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d",
( ( char * ) cell->tag.bytes ), pointer.page,
pointer.offset, cell->count );
if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH )
== 0 ) {
debug_printf( DEBUG_ALLOC,
L"; pointer to vector object of type %4.4s.\n",
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
} else {
debug_println( DEBUG_ALLOC );
}
#endif
if ( cell->count == 0 ) { if ( cell->count == 0 ) {
free_cell( pointer ); free_cell( pointer );
@ -157,34 +92,17 @@ 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.
* @return As a Lisp string, the tag of the object which is at that pointer. * @return As a Lisp string, the tag of the object which is at that pointer.
*/ */
struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer c_type( struct cons_pointer pointer ) {
/* Strings read by `read` have the null character termination. This means struct cons_pointer result = NIL;
* that for the same printable string, the hashcode is different from struct cons_space_object cell = pointer2cell( pointer );
* strings made with NIL termination. The question is which should be
* fixed, and actually that's probably strings read by `read`. However,
* for now, it was easier to add a null character here. */
struct cons_pointer result = make_string( ( wchar_t ) 0, NIL );
struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->tag.value == VECTORPOINTTV ) { if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) ==
0 ) {
struct vector_space_object *vec = pointer_to_vso( pointer ); struct vector_space_object *vec = pointer_to_vso( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
@ -193,7 +111,7 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
} }
} else { } else {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_string( ( wchar_t ) cell->tag.bytes[i], result ); result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
} }
} }
@ -216,7 +134,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
/** /**
* Implementation of cdr in C. If arg is not a sequence, or the current user is * Implementation of cdr in C. If arg is not a sequence, or the current user is
* not authorised to read it, does not error but returns nil. * not authorised to read it,does not error but returns nil.
*/ */
struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
@ -399,12 +317,10 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
cell->payload.string.cdr = tail; cell->payload.string.cdr = tail;
cell->payload.string.hash = calculate_hash( c, tail ); cell->payload.string.hash = calculate_hash( c, tail );
debug_dump_object( pointer, DEBUG_ALLOC );
debug_println( DEBUG_ALLOC );
} else { } else {
// \todo should throw an exception! // \todo should throw an exception!
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC,
L"Warning: only %4.4s can be prepended to %4.4s\n", L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
tag, tag ); tag, tag );
} }
@ -438,15 +354,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 = internedp( 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

View file

@ -56,42 +56,6 @@
*/ */
#define EXCEPTIONTV 1346721861 #define EXCEPTIONTV 1346721861
/**
* Keywords used when constructing exceptions: `:location`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_location;
/**
* Keywords used when constructing exceptions: `:payload`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_payload;
/**
* Keywords used when constructing exceptions: `:cause`. Instantiated in
* `init.c`.
*/
extern struct cons_pointer privileged_keyword_cause;
/**
* @brief keywords used in documentation: `:documentation`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_documentation;
/**
* @brief keywords used in documentation: `:name`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_name;
/**
* @brief keywords used in documentation: `:primitive`. Instantiated in
* `init.c`, q. v.
*/
extern struct cons_pointer privileged_keyword_primitive;
/** /**
* An unallocated cell on the free list - should never be encountered by a Lisp * An unallocated cell on the free list - should never be encountered by a Lisp
* function. * function.
@ -225,7 +189,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 +221,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"
@ -348,11 +312,6 @@ extern struct cons_pointer privileged_keyword_primitive;
*/ */
#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) #define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV))
/**
* true if `conspoint` points to an unassigned cell, else false
*/
#define freep(conspoint) (check_tag(conspoint,FREETV))
/** /**
* true if `conspoint` points to a function cell, else false * true if `conspoint` points to a function cell, else false
*/ */
@ -480,8 +439,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 +705,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 );

View file

@ -19,8 +19,6 @@
#ifndef __dump_h #ifndef __dump_h
#define __dump_h #define __dump_h
void dump_string_cell( URL_FILE * output, wchar_t *prefix,
struct cons_pointer pointer );
void dump_object( URL_FILE * output, struct cons_pointer pointer ); void dump_object( URL_FILE * output, struct cons_pointer pointer );

View file

@ -17,27 +17,21 @@
#include <stdlib.h> #include <stdlib.h>
#include "debug.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h"
#include "memory/dump.h" #include "memory/dump.h"
#include "ops/lispops.h"
#include "io/print.h"
#include "memory/stack.h" #include "memory/stack.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/lispops.h"
/**
* @brief If non-zero, maximum depth of stack.
*
*/
uint32_t stack_limit = 0;
/** /**
* set a register in a stack frame. Alwaye use this to do so, * 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,12 @@ 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( 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 && consp( args ) ) { while ( frame->args < args_in_frame && consp( args ) ) {
@ -185,10 +145,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 );
} }
@ -203,15 +162,12 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
env ); env );
frame->more = more; frame->more = more;
inc_ref( more ); inc_ref( more );
for ( ; !nilp( args ); args = c_cdr( args ) ) {
frame->args++;
}
} }
} }
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
} }
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result; return result;
} }
@ -231,7 +187,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 ) ) {
@ -274,44 +235,6 @@ void free_stack_frame( struct stack_frame *frame ) {
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC );
} }
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
struct cons_pointer result = NIL;
if ( frame != NULL ) {
result = frame->previous;
}
return result;
}
void dump_frame_context_fragment( URL_FILE *output,
struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L" <= " );
print( output, frame->arg[0] );
}
}
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer,
int depth ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
url_fwprintf( output, L"\tContext: " );
int i = 0;
for ( struct cons_pointer cursor = frame_pointer;
i++ < depth && !nilp( cursor );
cursor = frame_get_previous( cursor ) ) {
dump_frame_context_fragment( output, cursor );
}
url_fwprintf( output, L"\n" );
}
}
/** /**
* Dump a stackframe to this stream for debugging * Dump a stackframe to this stream for debugging
@ -322,15 +245,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 );
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%c%c%c%c\tcount: %10u\tvalue: ",
arg, cell.tag.bytes, cell.count ); arg, cell.tag.bytes[0], cell.tag.bytes[1],
cell.tag.bytes[2], cell.tag.bytes[3], cell.count );
print( output, frame->arg[arg] ); print( output, frame->arg[arg] );
url_fputws( L"\n", output ); url_fputws( L"\n", output );

View file

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

View file

@ -13,8 +13,6 @@
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <stdio.h> #include <stdio.h>
/* /*
* wide characters * wide characters
*/ */
@ -24,7 +22,6 @@
#include "memory/conspage.h" #include "memory/conspage.h"
#include "memory/consspaceobject.h" #include "memory/consspaceobject.h"
#include "debug.h" #include "debug.h"
#include "io/io.h"
#include "memory/hashmap.h" #include "memory/hashmap.h"
#include "memory/stack.h" #include "memory/stack.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
@ -126,9 +123,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
void free_vso( struct cons_pointer pointer ) { void free_vso( struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n",
L"About to free vector-space object of type %s at 0x%lx\n",
( char * ) cell.payload.vectorp.tag.bytes,
cell.payload.vectorp.address ); cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address; struct vector_space_object *vso = cell.payload.vectorp.address;

View file

@ -9,17 +9,12 @@
#include <math.h> #include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include <string.h>
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "arith/integer.h" #include "arith/integer.h"
#include "arith/peano.h" #include "arith/peano.h"
#include "arith/ratio.h" #include "arith/ratio.h"
#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/vectorspace.h"
#include "ops/equal.h"
#include "ops/intern.h"
/** /**
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
@ -53,295 +48,14 @@ bool end_of_string( struct cons_pointer string ) {
pointer2cell( string ).payload.string.character == '\0'; pointer2cell( string ).payload.string.character == '\0';
} }
/**
* @brief compare two long doubles and returns true if they are the same to
* within a tolerance of one part in a billion.
*
* @param a
* @param b
* @return true if `a` and `b` are equal to within one part in a billion.
* @return false otherwise.
*/
bool equal_ld_ld( long double a, long double b ) {
long double fa = fabsl( a );
long double fb = fabsl( b );
/* difference of magnitudes */
long double diff = fabsl( fa - fb );
/* average magnitude of the two */
long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
/* amount of difference we will tolerate for equality */
long double tolerance = av * 0.000000001;
bool result = ( fabsl( a - b ) < tolerance );
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp real -- if it isn't a real, things will break.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
if ( nilp( cell_a->payload.integer.more ) ) {
result =
equal_ld_ld( ( long double ) cell_a->payload.integer.value,
cell_b->payload.real.value );
} else {
fwprintf( stderr,
L"\nequality is not yet implemented for bignums compared to reals." );
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp integer -- if it isn't an integer, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_integer( a, b );
break;
case REALTV:
result = equal_integer_real( a, b );
break;
case RATIOTV:
result = false;
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a lisp real -- if it isn't an real, things will break.
* @param b a lisp number.
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = false;
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_b->tag.value ) {
case INTEGERTV:
result = equal_integer_real( b, a );
break;
case REALTV:{
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( cell_a->payload.real.value,
cell_b->payload.real.value );
}
break;
case RATIOTV:
struct cons_space_object *cell_a = &pointer2cell( a );
result =
equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
break;
}
debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
return result;
}
/**
* @brief Private function, don't use. It depends on its arguments being
* numbers and doesn't sanity check them.
*
* @param a a number
* @param b a number
* @return true if the two numbers have equal value.
* @return false if they don't.
*/
bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
bool result = eq( a, b );
debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
debug_print_object( a, DEBUG_ARITH );
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
if ( !result ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
switch ( cell_a->tag.value ) {
case INTEGERTV:
result = equal_integer_number( a, b );
break;
case REALTV:
result = equal_real_number( a, b );
break;
case RATIOTV:
switch ( cell_b->tag.value ) {
case INTEGERTV:
/* as ratios are simplified by make_ratio, any
* ratio that would simplify to an integer is an
* integer, TODO: no longer always true. */
result = false;
break;
case REALTV:
result = equal_real_number( b, a );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b );
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
break;
/* can't throw an exception from here, but non-numbers
* shouldn't have been passed in anyway, so no default. */
}
}
debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
result );
return result;
}
/**
* @brief equality of two map-like things.
*
* The list returned by `keys` on a map-like thing is not sorted, and is not
* guaranteed always to come out in the same order. So equality is established
* if:
* 1. the length of the keys list is the same; and
* 2. the value of each key in the keys list for map `a` is the same in map `a`
* and in map `b`.
*
* Private function, do not use outside this file, **WILL NOT** work
* unless both arguments are VECPs.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
struct cons_pointer keys_a = hashmap_keys( a );
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
result = true;
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
struct cons_pointer key = c_car( i );
if ( !equal
( hashmap_get( a, key, false ),
hashmap_get( b, key, false ) ) ) {
result = false;
break;
}
}
}
return result;
}
/**
* @brief equality of two vector-space things.
*
* Expensive, but we need to be able to check for equality of at least hashmaps
* and namespaces.
*
* Private function, do not use outside this file, not guaranteed to work
* unless both arguments are VECPs pointing to map like things.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( eq( a, b ) ) {
result = true; // same
/* there shouldn't ever be two separate VECP cells which point to the
* same address in vector space, so I don't believe it's worth checking
* for this.
*/
} else if ( vectorp( a ) && vectorp( b ) ) {
struct vector_space_object *va = pointer_to_vso( a );
struct vector_space_object *vb = pointer_to_vso( b );
/* what we're saying here is that a namespace is not equal to a map,
* even if they have identical logical structure. Is this right? */
if ( va->header.tag.value == vb->header.tag.value ) {
switch ( va->header.tag.value ) {
case HASHTV:
case NAMESPACETV:
result = equal_map_map( a, b );
break;
}
}
}
// else can't throw an exception from here but TODO: should log.
return result;
}
/** /**
* Deep, and thus expensive, equality: true if these two objects have * Deep, and thus expensive, equality: true if these two objects have
* 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 ); bool result = eq( a, b );
debug_print_object( a, DEBUG_EQUAL );
debug_print( L" = ", DEBUG_EQUAL );
debug_print_object( b, DEBUG_EQUAL );
bool result = false; if ( !result && same_type( a, b ) ) {
if ( eq( a, b ) ) {
result = true;
} else if ( !numberp( a ) && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b ); struct cons_space_object *cell_b = &pointer2cell( b );
@ -367,48 +81,39 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/* TODO: it is not OK to do this on the stack since list-like /* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by * structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */ * iteration (and even that is problematic) */
if ( cell_a->payload.string.hash == result =
cell_b->payload.string.hash ) { cell_a->payload.string.hash == cell_b->payload.string.hash
wchar_t a_buff[STRING_SHIPYARD_SIZE], && cell_a->payload.string.character ==
b_buff[STRING_SHIPYARD_SIZE]; cell_b->payload.string.character
uint32_t tag = cell_a->tag.value; &&
int i = 0; ( equal
( cell_a->payload.string.cdr,
memset( a_buff, 0, sizeof( a_buff ) ); cell_b->payload.string.cdr )
memset( b_buff, 0, sizeof( b_buff ) ); || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.cdr ) ) );
for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
&& !nilp( b ); i++ ) {
a_buff[i] = cell_a->payload.string.character;
a = c_cdr( a );
cell_a = &pointer2cell( a );
b_buff[i] = cell_b->payload.string.character;
b = c_cdr( b );
cell_b = &pointer2cell( b );
}
#ifdef DEBUG
debug_print( L"Comparing '", DEBUG_EQUAL );
debug_print( a_buff, DEBUG_EQUAL );
debug_print( L"' to '", DEBUG_EQUAL );
debug_print( b_buff, DEBUG_EQUAL );
debug_print( L"'\n", DEBUG_EQUAL );
#endif
/* OK, now we have wchar string buffers loaded from the objects. We
* may not have exhausted either string, so the buffers being equal
* isn't sufficient. So we recurse at least once. */
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
&& equal( c_cdr( a ), c_cdr( b ) );
}
break; break;
case VECTORPOINTTV: case INTEGERTV:
if ( cell_b->tag.value == VECTORPOINTTV ) { result =
result = equal_vector_vector( a, b ); ( cell_a->payload.integer.value ==
} else { cell_b->payload.integer.value ) &&
result = false; equal( cell_a->payload.integer.more,
cell_b->payload.integer.more );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b );
break;
case REALTV:
{
double num_a = to_long_double( a );
double num_b = to_long_double( b );
double max = fabs( num_a ) > fabs( num_b )
? fabs( num_a )
: fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
} }
break; break;
default: default:
@ -416,18 +121,20 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
break; break;
} }
} else if ( numberp( a ) && numberp( b ) ) { } else if ( numberp( a ) && numberp( b ) ) {
result = equal_number_number( a, b ); if ( integerp( a ) ) {
result = equal_integer_real( a, b );
} else if ( integerp( b ) ) {
result = equal_integer_real( b, a );
}
} }
/* /*
* there's only supposed ever to be one T and one NIL cell, so each * there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq. * should be caught by eq; equality of vector-space objects is a whole
* * other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so * I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now. * I'll ignore them, too, for now.
*/ */
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
return result; return result;
} }

View file

@ -15,12 +15,6 @@
#ifndef __equal_h #ifndef __equal_h
#define __equal_h #define __equal_h
/**
* size of buffer for assembling strings. Likely to be useful to
* read, too.
*/
#define STRING_SHIPYARD_SIZE 1024
/** /**
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false. * the same object, else false.

View file

@ -18,7 +18,6 @@
*/ */
#include <stdbool.h> #include <stdbool.h>
#include <string.h>
/* /*
* wide characters * wide characters
*/ */
@ -191,7 +190,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 +204,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 +215,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,185 +266,51 @@ 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
* a key lexically identical to this `key`.
*
* If found, then, if `return-key?` is non-nil, return the copy found in the
* `store`, else return the value associated with it.
*
* At this stage the following structures are legal stores:
* 1. an association list comprising (key . value) dotted pairs;
* 2. a hashmap;
* 3. a namespace (which for these purposes is identical to a hashmap);
* 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
* level items;
* 5. such a hybrid list, but where the last CDR pointer is to a hashmap
* rather than to a cons sell or to `nil`.
*
* This is over-complex and type 5 should be disallowed, but it will do for
* now.
*/
struct cons_pointer search_store( struct cons_pointer key,
struct cons_pointer store,
bool return_key ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`; store of type `", DEBUG_BIND );
debug_print_object( c_type( store ), DEBUG_BIND );
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
return_key ? "key" : "value" );
#endif
switch ( get_tag_value( key ) ) {
case SYMBOLTV:
case KEYTV:
struct cons_space_object *store_cell = &pointer2cell( store );
switch ( get_tag_value( store ) ) {
case CONSTV:
for ( struct cons_pointer cursor = store;
nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) {
case CONSTV:
struct cons_pointer entry_ptr =
c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) {
case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) {
result =
return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr );
goto found;
}
break;
case HASHTV:
case NAMESPACETV:
result =
hashmap_get( entry_ptr, key,
return_key );
break;
default:
result =
throw_exception
( c_string_to_lisp_symbol
( L"search-store (entry)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( c_car( entry_ptr ) ) ),
NIL );
}
break;
case HASHTV:
case NAMESPACETV:
debug_print
( L"\n\tHashmap as top-level value in list",
DEBUG_BIND );
result =
hashmap_get( cursor, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (cursor)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( cursor ) ),
NIL );
}
}
break;
case HASHTV:
case NAMESPACETV:
result = hashmap_get( store, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (store)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( store ) ), NIL );
break;
}
break;
case EXCEPTIONTV:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (exception)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (key)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
}
found:
debug_print( L"search-store: returning `", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
return result;
}
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer store ) {
return search_store( key, store, true );
}
/** /**
* @brief Implementation of `interned?` in C. * Implementation of interned? in C. The final implementation if interned? will
* deal with stores which can be association lists or hashtables or hybrids of
* the two, but that will almost certainly be implemented in lisp.
* *
* @param key the key to search for. * If this key is lexically identical to a key in this store, return the key
* @param store the store to search in. * from the store (so that later when we want to retrieve a value, an eq test
* @return struct cons_pointer `t` if the key was found, else `nil`. * will work); otherwise return NIL.
*/ */
struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer
struct cons_pointer store ) { internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( consp( store ) ) { if ( symbolp( key ) || keywordp( key ) ) {
for ( struct cons_pointer pair = c_car( store ); // TODO: I see what I was doing here and it would be the right thing to
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) { // do for stores which are old-fashioned assoc lists, but it will not work
if ( consp( pair ) ) { // for my new hybrid stores.
if ( equal( c_car( pair ), key ) ) { // for ( struct cons_pointer next = store;
// yes, this should be `eq`, but if symbols are correctly // nilp( result ) && consp( next );
// interned this will work efficiently, and if not it will // next = pointer2cell( next ).payload.cons.cdr ) {
// still work. // struct cons_space_object entry =
result = TRUE; // pointer2cell( pointer2cell( next ).payload.cons.car );
}
} else if ( hashmapp( pair ) ) {
result = internedp( key, pair );
}
store = c_cdr( store ); // debug_print( L"Internedp: checking whether `", DEBUG_BIND );
} // debug_print_object( key, DEBUG_BIND );
} else if ( hashmapp( store ) ) { // debug_print( L"` equals `", DEBUG_BIND );
struct vector_space_object *map = pointer_to_vso( store ); // debug_print_object( entry.payload.cons.car, DEBUG_BIND );
// debug_print( L"`\n", DEBUG_BIND );
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { // if ( equal( key, entry.payload.cons.car ) ) {
for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; // result = entry.payload.cons.car;
!nilp( c ); c = c_cdr( c ) ) { // }
result = internedp( key, c ); if ( !nilp( c_assoc( key, store ) ) ) {
} result = key;
} else if ( equal( key, privileged_symbol_nil ) ) {
result = privileged_symbol_nil;
} }
} else {
debug_print( L"`", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"` is a ", DEBUG_BIND );
debug_print_object( c_type( key ), DEBUG_BIND );
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
} }
return result; return result;
@ -477,7 +326,55 @@ 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;
debug_print( L"c_assoc; key is `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
if ( consp( store ) ) {
for ( struct cons_pointer next = store;
nilp( result ) && ( consp( next ) || hashmapp( next ) );
next = pointer2cell( next ).payload.cons.cdr ) {
if ( consp( next ) ) {
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_append
( c_string_to_lisp_string
( L"Store entry is of unknown type: " ),
c_type( entry_ptr ) ), NIL );
}
}
}
} else if ( hashmapp( store ) ) {
result = hashmap_get( store, key );
} else if ( !nilp( store ) ) {
debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
debug_print_object( c_type( store ), DEBUG_BIND );
debug_print( L"`\n", DEBUG_BIND );
result =
throw_exception( c_append
( c_string_to_lisp_string
( L"Store is of unknown type: " ),
c_type( store ) ), NIL );
}
debug_print( L"c_assoc returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND );
return result;
} }
/** /**
@ -501,52 +398,70 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
// hashmap to a bigger number of buckets, and return that. // hashmap to a bigger number of buckets, and return that.
map->payload.hashmap.buckets[bucket_no] = map->payload.hashmap.buckets[bucket_no] =
make_cons( make_cons( key, val ), inc_ref( make_cons( make_cons( key, val ),
map->payload.hashmap.buckets[bucket_no] ); map->payload.hashmap.buckets[bucket_no] ) );
} }
debug_print( L"hashmap_put:\n", DEBUG_BIND );
debug_dump_object( mapp, DEBUG_BIND );
return mapp; return mapp;
} }
/** /**
* If this store is modifiable, add this key value pair to it. Otherwise, * Return a new key/value store containing all the key/value pairs in this
* return a new key/value store containing all the key/value pairs in this * store with this key/value pair added to the front.
* store with this key/value pair added to the front. */
*/
struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { struct cons_pointer store ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG debug_print( L"set: binding `", DEBUG_BIND );
bool deep = eq( store, oblist ); debug_print_object( key, DEBUG_BIND );
debug_print_binding( key, value, deep, DEBUG_BIND ); debug_print( L"` to `", DEBUG_BIND );
debug_print_object( value, DEBUG_BIND );
debug_print( L"` in store ", DEBUG_BIND );
debug_dump_object( store, DEBUG_BIND );
debug_println( DEBUG_BIND );
if ( deep ) { debug_printf( DEBUG_BIND, L"set: store is %s\n`",
debug_printf( DEBUG_BIND, L"\t-> %4.4s\n", lisp_string_to_c_string( c_type( store ) ) );
pointer2cell( store ).payload.vectorp.tag.bytes ); if ( nilp( value ) ) {
} result = store;
#endif } else if ( nilp( store ) || consp( store ) ) {
if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store ); result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) { } else if ( hashmapp( store ) ) {
debug_print( L"set: storing in hashmap\n", DEBUG_BIND );
result = hashmap_put( store, key, value ); result = hashmap_put( store, key, value );
} }
debug_print( L"set returning ", DEBUG_BIND );
debug_print_object( result, DEBUG_BIND );
debug_println( DEBUG_BIND );
return result; return result;
} }
/** /**
* @brief Binds this `key` to this `value` in the global oblist, and returns the `key`. * @brief Binds this key to this value in the global oblist.
*/ */
struct cons_pointer struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { deep_bind( struct cons_pointer key, struct cons_pointer value ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND ); debug_print( L"Entering deep_bind\n", DEBUG_BIND );
struct cons_pointer old = oblist;
debug_print( L"deep_bind: binding `", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND );
debug_print( L"` to ", DEBUG_BIND );
debug_print_object( value, DEBUG_BIND );
debug_println( DEBUG_BIND );
oblist = set( key, value, oblist ); oblist = set( key, value, oblist );
if ( consp( oblist ) ) {
inc_ref( oblist );
dec_ref( old );
}
debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print( L"deep_bind returning ", DEBUG_BIND );
debug_print_object( key, DEBUG_BIND ); debug_print_object( key, DEBUG_BIND );
debug_println( DEBUG_BIND ); debug_println( DEBUG_BIND );
@ -557,7 +472,7 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) {
/** /**
* Ensure that a canonical copy of this key is bound in this environment, and * Ensure that a canonical copy of this key is bound in this environment, and
* return that canonical copy. If there is currently no such binding, create one * return that canonical copy. If there is currently no such binding, create one
* with the value TRUE. * with the value NIL.
*/ */
struct cons_pointer struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) { intern( struct cons_pointer key, struct cons_pointer environment ) {
@ -565,9 +480,9 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer canonical = internedp( key, environment ); struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
/* /*
* not currently bound. TODO: this should bind to NIL? * not currently bound
*/ */
result = set( key, TRUE, environment ); result = set( key, NIL, environment );
} }
return result; return result;

View file

@ -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,18 +46,15 @@ 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 );
struct cons_pointer interned( struct cons_pointer key,
struct cons_pointer environment );
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 +69,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

File diff suppressed because it is too large Load diff

View file

@ -131,15 +131,15 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer lisp_inspect( 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 lisp_internedp( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( 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 lisp_equal( struct stack_frame *frame, struct cons_pointer lisp_equal( 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 lisp_print( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
@ -149,9 +149,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_reverse( 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
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
@ -190,19 +187,13 @@ 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
* signature of a lisp function; but it is nevertheless to be preferred to * signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed. * make_exception. A real `throw_exception`, which does, will be needed.
*/ */
struct cons_pointer throw_exception( struct cons_pointer location, struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer message,
struct cons_pointer frame_pointer ); struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer lisp_exception( struct stack_frame *frame,
@ -234,17 +225,4 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer lisp_try( 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 lisp_and( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_or( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif #endif

View file

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

View file

@ -77,7 +77,7 @@ expected='6.25'
actual=`echo "(+ 6.000000001 1/4)" |\ actual=`echo "(+ 6.000000001 1/4)" |\
target/psse 2> /dev/null |\ target/psse 2> /dev/null |\
sed -r '/^\s*$/d' |\ sed -r '/^\s*$/d' |\
sed 's/0*$//'` sed 's/0*$//'
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
@ -86,7 +86,7 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` result=`echo "${result} + 1" | bc `
fi fi
exit ${result} exit ${result}

View file

@ -1,13 +1,13 @@
#!/bin/bash #!/bin/bash
result=0 return=0
##################################################################### #####################################################################
# last 'smallnum' value: # last 'smallnum' value:
# sbcl calculates (expt 2 59) => 576460752303423488 # sbcl calculates (expt 2 59) => 576460752303423488
expected='576460752303423488' expected='576460752303423488'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! expt (lambda (set! expt (lambda
(n x) (n x)
@ -26,7 +26,7 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` return=1
fi fi
##################################################################### #####################################################################
@ -34,7 +34,7 @@ fi
# sbcl calculates (expt 2 60) => 1152921504606846976 # sbcl calculates (expt 2 60) => 1152921504606846976
expected='1152921504606846976' expected='1152921504606846976'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! expt (lambda (set! expt (lambda
(n x) (n x)
@ -53,7 +53,7 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` return=1
fi fi
##################################################################### #####################################################################
@ -61,7 +61,7 @@ fi
# sbcl calculates (expt 2 61) => 2305843009213693952 # sbcl calculates (expt 2 61) => 2305843009213693952
expected='2305843009213693952' expected='2305843009213693952'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! expt (lambda (set! expt (lambda
(n x) (n x)
@ -80,13 +80,15 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` return=1
fi fi
# sbcl calculates (expt 2 64) => 18446744073709551616 # sbcl calculates (expt 2 64) => 18446744073709551616
expected='18446744073709551616' expected='18446744073709551616'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! expt (lambda (set! expt (lambda
(n x) (n x)
@ -105,13 +107,13 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` return=1
fi fi
# sbcl calculates (expt 2 65) => 36893488147419103232 # sbcl calculates (expt 2 65) => 36893488147419103232
expected='36893488147419103232' expected='36893488147419103232'
output=`target/psse 2>/dev/null <<EOF output=`target/psse <<EOF
(progn (progn
(set! expt (lambda (set! expt (lambda
(n x) (n x)
@ -130,7 +132,7 @@ then
echo "OK" echo "OK"
else else
echo "Fail: expected '${expected}', got '${actual}'" echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc` return=1
fi fi
exit ${result} exit ${return}

View file

@ -5,7 +5,7 @@ result=0
echo -n "$0: cond with one clause... " echo -n "$0: cond with one clause... "
expected='5' expected='5'
actual=`echo "(cond ((equal? 2 2) 5))" | target/psse 2>/dev/null | tail -1` actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then
@ -18,7 +18,7 @@ fi
echo -n "$0: cond with two clauses... " echo -n "$0: cond with two clauses... "
expected='"should"' expected='"should"'
actual=`echo "(cond ((equal? 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2>/dev/null | tail -1` actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]
then then

View file

@ -1,206 +0,0 @@
#!/bin/bash
# Tests for equality.
result=0
echo -n "$0: integers... "
expected="t"
actual=`echo "(= 5 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different integers... "
expected="nil"
actual=`echo "(= 4 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: reals... "
expected="t"
actual=`echo "(= 5.001 5.001)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different reals... "
expected="nil"
actual=`echo "(= 5.001 5.002)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: ratios... "
expected="t"
actual=`echo "(= 4/5 4/5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: equivalent ratios... "
expected="t"
actual=`echo "(= 4/5 12/15)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different ratios... "
expected="nil"
actual=`echo "(= 4/5 5/5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: atoms... "
expected="t"
actual=`echo "(= 'foo 'foo)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different atoms... "
expected="nil"
actual=`echo "(= 'foo 'bar)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: keywords... "
expected="t"
actual=`echo "(= :foo :foo)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different keywords... "
expected="nil"
actual=`echo "(= :foo :bar)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: strings... "
expected="t"
actual=`echo '(= "foo" "foo")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different strings... "
expected="nil"
actual=`echo '(= "foo" "bar")' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: maps... "
expected="t"
actual=`echo '(= {:foo 1 :bar 2} {:bar 2 :foo 1})' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: different maps... "
expected="nil"
actual=`echo '(= {:foo 1 :bar 2} {:bar 1 :foo 2})' | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

View file

@ -1,6 +1,6 @@
#!/bin/bash #!/bin/bash
expected='<Special form: ((:primitive . t) (:name . cond) (:documentation . "`(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."))>' expected='<Special form: ((:primitive . t) (:name . cond))>'
actual=`echo "(eval 'cond)" | target/psse 2>/dev/null | tail -1` actual=`echo "(eval 'cond)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ] if [ "${expected}" = "${actual}" ]

View file

@ -2,9 +2,9 @@
result=0 result=0
echo -n "$0: let with two bindings, one form in body..."
expected='11' expected='11'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1` actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1`
echo -n "$0: let with two bindings, one form in body... "
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

View file

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

View file

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

View file

@ -1,12 +1,12 @@
#!/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)
(cond ((= n 1) 1) (cond ((= n 1) 1)
(t (* n (fact (- n 1))))))) (t (* n (fact (- n 1)))))))
nil) nil)
(fact 10) (fact 10)
EOF` EOF`

View file

@ -1,190 +0,0 @@
#!/bin/bash
# Tests for smallnum subtraction
result=0
echo -n "$0: (- 5 4)... "
expected="1"
actual=`echo "(- 5 4)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 5.0 4)... "
expected="1"
actual=`echo "(- 5.0 4)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 5 4.0)... "
expected="1"
actual=`echo "(- 5 4.0)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 5.01 4.0)... "
expected="1.0100000000000000002082"
actual=`echo "(- 5.01 4.0)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 5 4/5)... "
expected="24/5"
actual=`echo "(- 5 4/5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: max smallint (- 1152921504606846975 1)... "
expected="1,152,921,504,606,846,974"
actual=`echo "(- 1152921504606846975 1)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: max smallint (- 1152921504606846975 1152921504606846974)... "
expected="1"
actual=`echo "(- 1152921504606846975 1152921504606846974)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 4 5)... "
expected="-1"
actual=`echo "(- 4 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 4 5.0)... "
expected="-1"
actual=`echo "(- 4 5.0)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 4.0 5)... "
expected="-1"
actual=`echo "(- 4.0 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 4.0 5.01)... "
expected="-1.0100000000000000002082"
actual=`echo "(- 4.0 5.01)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: (- 4/5 5)... "
expected="-3/5"
actual=`echo "(- 4/5 5)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: max smallint (- 1 1152921504606846975)... "
expected="-1,152,921,504,606,846,974"
actual=`echo "(- 1 1152921504606846975)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
echo -n "$0: max smallint (- 1152921504606846974 1152921504606846975)... "
expected="-1"
actual=`echo "(- 1152921504606846974 1152921504606846975)" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
result=`echo "${result} + 1" | bc`
fi
exit ${result}

View file

@ -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}" ]