Merge branch 'master' of ssh://git.journeyman.cc:4022/simon/post-scarcity
This commit is contained in:
commit
afda60b8e2
32 changed files with 1399 additions and 474 deletions
7
Makefile
7
Makefile
|
|
@ -44,10 +44,13 @@ 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) -p 2> psse.log
|
$(TARGET) -ps1000 2> tmp/psse.log
|
||||||
|
|
||||||
|
|
||||||
-include $(DEPS)
|
-include $(DEPS)
|
||||||
|
|
|
||||||
70
docs/Home.md
70
docs/Home.md
|
|
@ -38,25 +38,59 @@ This project is necessarily experimental and exploratory. I write code, it revea
|
||||||
|
|
||||||
## Building
|
## Building
|
||||||
|
|
||||||
The substrate of this system is written in plain old fashioned C and built with a Makefile. I regret this decision; I think either Zig or Rust would have been better places to start; but neither of them were sufficiently well developed to support what I wanted to do when I did start.
|
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/).
|
To build, you need a C compiler; I use GCC, others may work. You need a make utility; I use GNU Make. You need [libcurl](https://curl.se/libcurl/).
|
||||||
|
|
||||||
With these dependencies in place, clone the repository from [here](https://git.journeyman.cc/simon/post-scarcity/), and run `make` in the resulting project directory. If all goes well you will find and executable, `psse`, in the target directory.
|
With these dependencies in place, clone the repository from [here](https://git.journeyman.cc/simon/post-scarcity/), and run `make` in the resulting project directory. If all goes well you will find and executable, `psse`, in the target directory.
|
||||||
|
|
||||||
|
This has been developed on Debian but probably builds on any 64 bit UN*X; however I do **not** guarantee this.
|
||||||
|
|
||||||
|
### Make targets
|
||||||
|
|
||||||
|
#### default
|
||||||
|
|
||||||
|
The default `make` target will produce an executable as `target/psse`.
|
||||||
|
|
||||||
|
#### clean
|
||||||
|
|
||||||
|
`make clean` will remove all compilation detritus; it will also remove temporary files.
|
||||||
|
|
||||||
|
#### doc
|
||||||
|
|
||||||
|
`make doc` will generate documentation in the `doc` directory. Depends on `doxygen` being present on your system.
|
||||||
|
|
||||||
|
#### format
|
||||||
|
|
||||||
|
`make format` will standardise the formay of C code. Depends on the GNU `indent` program being present on your system.
|
||||||
|
|
||||||
|
#### REPL
|
||||||
|
|
||||||
|
`make repl` will start a read-eval-print loop. `*log*` is directed to `tmp/psse.log`.
|
||||||
|
|
||||||
|
#### test
|
||||||
|
|
||||||
|
`make test` will run all unit tests.
|
||||||
|
|
||||||
## In use
|
## In use
|
||||||
|
|
||||||
What works just now is a not very good, not very efficient Lisp interpreter which does not conform to any existing Lisp standard. You can start a REPL, and you can write and evaluate functions. You can't yet save or load your functions. It's interesting mainly because of its architecture, and where it's intended to go, rather than where it is now.
|
What works just now is a not very good, not very efficient Lisp interpreter which does not conform to any existing Lisp standard. You can start a REPL, and you can write and evaluate functions. You can't yet save or load your functions. It's interesting mainly because of its architecture, and where it's intended to go, rather than where it is now.
|
||||||
|
|
||||||
|
### Documentation
|
||||||
|
|
||||||
|
There is [documentation](https://www.journeyman.cc/post-scarcity/doc/html/).
|
||||||
|
|
||||||
### Invoking
|
### Invoking
|
||||||
|
|
||||||
When invoking the system, the following invocation arguments may be passed:
|
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!);
|
-d Dump memory to standard out at end of run (copious!);
|
||||||
-h Print this message and exit;
|
-h Print this message and exit;
|
||||||
-p Show a prompt (default is no prompt);
|
-p Show a prompt (default is no prompt);
|
||||||
|
-s LIMIT
|
||||||
|
Set a limit to the depth the stack can extend to;
|
||||||
-v LEVEL
|
-v LEVEL
|
||||||
Set verbosity to the specified level (0...512)
|
Set verbosity to the specified level (0...1024)
|
||||||
Where bits are interpreted as follows:
|
Where bits are interpreted as follows:
|
||||||
1 ALLOC;
|
1 ALLOC;
|
||||||
2 ARITH;
|
2 ARITH;
|
||||||
|
|
@ -66,7 +100,8 @@ When invoking the system, the following invocation arguments may be passed:
|
||||||
32 INPUT/OUTPUT;
|
32 INPUT/OUTPUT;
|
||||||
64 LAMBDA;
|
64 LAMBDA;
|
||||||
128 REPL;
|
128 REPL;
|
||||||
256 STACK.
|
256 STACK;
|
||||||
|
512 EQUAL.
|
||||||
```
|
```
|
||||||
|
|
||||||
Note that any verbosity level produces a great deal of output, and although standardising the output to make it more legible is something I'm continually working on, it's still hard to read the output. It is printed to stderr, so can be redirected to a file for later analysis, which is the best plan.
|
Note that any verbosity level produces a great deal of output, and although standardising the output to make it more legible is something I'm continually working on, it's still hard to read the output. It is printed to stderr, so can be redirected to a file for later analysis, which is the best plan.
|
||||||
|
|
@ -77,7 +112,10 @@ The following functions are provided as of release 0.0.6:
|
||||||
|
|
||||||
| Symbol | Type | Documentation |
|
| Symbol | Type | Documentation |
|
||||||
| ------ | ---- | ------------- |
|
| ------ | ---- | ------------- |
|
||||||
| * | FUNC | `(* args...)` Multiplies these `args`, all of which should be numbers, and return the product. |
|
| `*` | FUNC | `(* args...)` Multiplies these `args`, all of which should be numbers, and return the product. |
|
||||||
|
| `*in*` | READ | The standard input stream. |
|
||||||
|
| `*log*` | WRIT | The standard logging stream (stderr). |
|
||||||
|
| `*out*` | WRIT | The standard output stream. |
|
||||||
| + | FUNC | `(+ args...)`: If `args` are all numbers, returns the sum of those numbers. |
|
| + | FUNC | `(+ args...)`: If `args` are all numbers, returns the sum of those numbers. |
|
||||||
| - | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
|
| - | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
|
||||||
| / | FUNC | `(/ a b)`: Divides `a` by `b` and returns the result. Expects both arguments to be numbers. |
|
| / | FUNC | `(/ a b)`: Divides `a` by `b` and returns the result. Expects both arguments to be numbers. |
|
||||||
|
|
@ -112,7 +150,7 @@ The following functions are provided as of release 0.0.6:
|
||||||
| multiply | FUNC | `(multiply args...)` Multiply these `args`, all of which should be numbers, and return the product. |
|
| 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`. |
|
| 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. |
|
| 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`. |
|
| 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. |
|
| 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. |
|
| 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. |
|
| 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. |
|
||||||
|
|
@ -127,14 +165,26 @@ The following functions are provided as of release 0.0.6:
|
||||||
| read-char | FUNC | `(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
|
| read-char | FUNC | `(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
|
||||||
| repl | FUNC | `(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional. If `prompt` is present, it will be used as the prompt. If `input` is present and is a readable stream, takes input from that stream. If `output` is present and is a writable stream, prints output to that stream. |
|
| repl | FUNC | `(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional. If `prompt` is present, it will be used as the prompt. If `input` is present and is a readable stream, takes input from that stream. If `output` is present and is a writable stream, prints output to that stream. |
|
||||||
| reverse | FUNC | `(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order. |
|
| reverse | FUNC | `(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order. |
|
||||||
| set | FUNC | null |
|
| 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. |
|
| set! | SPFM | `(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. |
|
||||||
| slurp | FUNC | `(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string. |
|
| slurp | FUNC | `(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string. |
|
||||||
| source | FUNC | `(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil. Once we get a compiler working, will also return the source code of compiled functions and special forms. |
|
| source | FUNC | `(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil. Once we get a compiler working, will also return the source code of compiled functions and special forms. |
|
||||||
| subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
|
| subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
|
||||||
| throw | FUNC | null |
|
| 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. |
|
| 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 | null |
|
| 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. |
|
| 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 λ funtion. |
|
| λ | 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.
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,58 +12,50 @@ 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.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 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 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 .system.users.simon.environment.froboz)
|
(eval ::users:simon:environment/froboz)
|
||||||
|
|
||||||
will return the value that **froboz** is bound to in the environment of the user of the system called **simon**.
|
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).
|
||||||
|
|
||||||
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.
|
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.
|
||||||
|
|
||||||
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 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 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! string)
|
### (intern! path)
|
||||||
|
|
||||||
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.
|
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.
|
||||||
|
|
||||||
### (intern! string T)
|
### (intern! path T)
|
||||||
|
|
||||||
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.
|
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.
|
||||||
|
|
||||||
### (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 *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.
|
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.
|
||||||
|
|
||||||
### (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.
|
||||||
|
|
@ -71,16 +63,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") => ("foo" "bar" "ban")
|
(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)
|
||||||
|
|
||||||
Obviously if the current user can't read the string, throws an exception.
|
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).
|
||||||
|
|
||||||
### (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.
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,50 @@
|
||||||
# State of Play
|
# State of Play
|
||||||
|
|
||||||
|
## 20260319
|
||||||
|
|
||||||
|
Right, the `member?` bug [is fixed](https://git.journeyman.cc/simon/post-scarcity/issues/11).
|
||||||
|
There are, of course, lots more bugs. But I nevertheless propose to release
|
||||||
|
0.0.6 **now**, because there will always be more bugs, quite a lot works, and
|
||||||
|
I'm thinking about completely rearchitecting the memory system and, at the same
|
||||||
|
time, trying once more to move away from C.
|
||||||
|
|
||||||
|
The reasons are given in [this essay](The-worlds-slowest-ever-rapid-prototype.md).
|
||||||
|
|
||||||
|
This, of course, completely invalidates the [roadmap](Roadmap.md) that I wrote
|
||||||
|
less than a month ago, but that's because I really have been thinking seriously
|
||||||
|
about the future of this project.
|
||||||
|
|
||||||
|
## 20260316
|
||||||
|
|
||||||
|
OK, where we're at:
|
||||||
|
* The garbage collector is doing *even worse* than it was on 4th
|
||||||
|
February, when I did the last serious look at it.
|
||||||
|
* The bignum bugs are not fixed.
|
||||||
|
* You can (optionally) limit runaway stack crashes with a new command line option.
|
||||||
|
* If you enable the stack limiter feature, `(member? 5 '(1 2 3 4))` returns `nil`, as it should, and does not throw a stack limit exception, but if you do not enable it, `(member? 5 '(1 2 3 4))` causes a segfault. WTAF?
|
||||||
|
|
||||||
|
## 20260314
|
||||||
|
|
||||||
|
When I put a debugger on it, the stack limit bug proved shallow.
|
||||||
|
|
||||||
|
I'm tempted to further exercise my debugging skills by having another go at
|
||||||
|
the bignum arithmetic problems.
|
||||||
|
|
||||||
|
However, I've been rethinking the roadmap of the project, and written a long
|
||||||
|
[blog post about it](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/).
|
||||||
|
This isn't a finalised decision yet, but it is something I'm thinking about.
|
||||||
|
|
||||||
|
## 20260311
|
||||||
|
|
||||||
|
I've still been having trouble with runaway recursion — in `member`, but
|
||||||
|
due to a primitive bug I haven't identified — so this morning I've tried
|
||||||
|
to implement a stack limit feature. This has been a real fail at this stage.
|
||||||
|
Many more tests are breaking.
|
||||||
|
|
||||||
|
However, I think having a configurable stack limit would be a good thing, so
|
||||||
|
I'm not yet ready to abandon this feature. I need to work out why it's breaking
|
||||||
|
things.
|
||||||
|
|
||||||
## 20260226
|
## 20260226
|
||||||
|
|
||||||
The bug in `member` turned out to be because when a symbol is read by the reader,
|
The bug in `member` turned out to be because when a symbol is read by the reader,
|
||||||
|
|
|
||||||
240
docs/The-worlds-slowest-ever-rapid-prototype.md
Normal file
240
docs/The-worlds-slowest-ever-rapid-prototype.md
Normal file
|
|
@ -0,0 +1,240 @@
|
||||||
|
# Vector space, Pages, Mark-but-don't-sweep, and the world's slowest ever rapid prototype
|
||||||
|
|
||||||
|
By: Simon Brooke :: 13 March 2026
|
||||||
|
|
||||||
|
I started work on the Post-scarcity Software Environment on the second of January, 2017; which is to say, more than nine years ago. It was never intended to be a rapid prototype; it was intended, largely, to be a giant thought experiment. But now enough of it does work that I can see fundamental design mistakes, and I'm thinking about whether it's time to treat it as a rapid prototype: to take what has been learned from this code, and instead of trying to fix those mistakes, to start again from scratch.
|
||||||
|
|
||||||
|
So what are the mistakes?
|
||||||
|
|
||||||
|
## Allocating only cons-sized objects in pages
|
||||||
|
|
||||||
|
### What currently happens
|
||||||
|
|
||||||
|
The current post-scarcity prototype allocates objects that are the size of a cons cell in 'cons pages'. A cons page is an object that floats in vector space, which is to say the heap, which has a header to identify it, followed by an array of slots each of which is the size of a cons cell. When a cons page is initialised, each slot is initialised as a FREE object, and these are linked together onto the front of the global free list.
|
||||||
|
|
||||||
|
A cons pointer comprises a page part and an offset part. The exact size of these two parts is implementation dependent, but in the present implementation they're both uint32_t, which essentially means you can address four billion pages each of four billion slots; consequently, the size of the pointer is 64 bits, which means that the size of the payload of a cons cell is 128 bits. But a cons cell also needs a header to do housekeeping in, which is
|
||||||
|
|
||||||
|
struct cons_space_object {
|
||||||
|
union {
|
||||||
|
/** the tag (type) of this cell,
|
||||||
|
* considered as bytes */
|
||||||
|
char bytes[TAGLENGTH];
|
||||||
|
/** the tag considered as a number */
|
||||||
|
uint32_t value;
|
||||||
|
} tag;
|
||||||
|
/** the count of the number of references to this cell */
|
||||||
|
uint32_t count;
|
||||||
|
/** cons pointer to the access control list of this cell */
|
||||||
|
struct cons_pointer access;
|
||||||
|
//...
|
||||||
|
|
||||||
|
which is to say, 32 bits tag, 32 bits reference count, 64 bits access control list pointer, total 16 bytes. So the whole cell is 32 bytes.
|
||||||
|
|
||||||
|
We currently have nineteen different types of object which can fit into the size of the payload of a cons cell (plus FREE, which is sort of a non-object, but must exist), namely
|
||||||
|
|
||||||
|
|
||||||
|
| | Tag (byte string) | Tag (numeric) | Interpretation |
|
||||||
|
| ---- | ---- | ---- | ---- |
|
||||||
|
| 1 | CONS | 1397641027 | An ordinary cons cell. |
|
||||||
|
| 2 | EXEP | 1346721861 | An exception.|
|
||||||
|
| 3 | FREE | 1162170950 | An unallocated cell on the free list — should never be encountered by a Lisp function. |
|
||||||
|
| 4 | FUNC | 1129207110 | An ordinary Lisp function — one whose arguments are pre-evaluated. |
|
||||||
|
| 5 | INTR | 1381256777 | An integer number (bignums are integers). |
|
||||||
|
| 6 | KEYW | 1465468235 | A keyword — an interned, self-evaluating string. |
|
||||||
|
| 7 | LMDA | 1094995276 | A lambda cell. Lambdas are the interpretable (source) versions of functions.|
|
||||||
|
| 8 | LOOP | 1347374924 | A loop exit is a special kind of exception which has exactly the same payload as an exception.|
|
||||||
|
| 9 | NIL | 541870414 | The special cons cell at address {0,0} whose car and cdr both point to itself.|
|
||||||
|
| 10 | NLMD | 1145916494 | An nlambda cell. NLambdas are the interpretable (source) versions of special forms.|
|
||||||
|
| 11 | RTIO | 1330205778 | A rational number, stored as pointers to two integers representing dividend and divisor respectively|
|
||||||
|
| 12 | READ | 1145128274 | An open read stream.|
|
||||||
|
| 13 | REAL | 1279346002 | A real number, represented internally as an IEEE 754-2008 binary128.|
|
||||||
|
| 14 | SPFM | 1296453715 | A special form — one whose arguments are not pre-evaluated but passed as provided.|
|
||||||
|
| 15 | STRG | 1196577875 | A string of characters, organised as a linked list.|
|
||||||
|
| 16 | SYMB | 1112365395 | A symbol is just like a keyword except not self-evaluating.|
|
||||||
|
| 17 | TIME | 1162692948 | A time stamp, representing milliseconds since the big bang.|
|
||||||
|
| 18 | TRUE | 1163219540 | The special cons cell at address {0,1} which is canonically different from NIL.|
|
||||||
|
| 19 | VECP | 1346585942 | A pointer to an object in vector space.|
|
||||||
|
| 20 | WRIT | 1414091351 | An open write stream.|
|
||||||
|
|
||||||
|
Obviously it is absurdly wasteful to allocate 32 bits to a tag for twenty different types of object, but
|
||||||
|
|
||||||
|
1. The type system should be extensible; and
|
||||||
|
2. While debugging, it is useful to have human-readable mnemonics as tags.
|
||||||
|
|
||||||
|
But the point is, all these types of thing can be allocated into an identical footprint, which means that a cell can be popped off the free list and populated as any one of these; so that memory churn of objects of these types happens only in cons pages, not in the heap.
|
||||||
|
Why this is a good thing
|
||||||
|
|
||||||
|
Cons cells very often have quite transient life-cycles. They're allocated, and, in the majority of cases, deallocated, in the process of computation; of a single function call. Only a small minority of cons cells become parts of the values of interned symbols, and consequently retained in the long term. In other words, there is a lot of churn of cons cells. If you allocate and deallocate lots of small objects in the heap, the heap rapidly fragments, and then it becomes increasingly difficult to allocate new, larger objects.
|
||||||
|
|
||||||
|
But by organising them in pages with an internal free list, we can manage that churn in managed space, and only bother the heap allocator when all the cells in all the pages that we currently have allocated are themselves allocated.
|
||||||
|
|
||||||
|
Other objects which live in cons space, such as numbers, are also likely to experience considerable churn. Although I needed to solve the churn problem for cons cells, the fact that the same solution automatically generalises to all other cons space objects is a good thing.
|
||||||
|
### Why this needs to be different in future anyway
|
||||||
|
|
||||||
|
A two part cons pointer implies a single integrated address space, but in fact in a massively parallel machine we won't have that. In the final machine, the cons pointer would have to comprise three parts: a node part, a page part, and an offset part. And, indeed, in the next iteration of the project it ought to, because in the next iteration I do want to start experimenting with the hypercube topology. So actually, these parts are probably node: 32 bits; page; 8 bits; offset: 24 bits. So that you could have (in a fully populated machine) a hypercube of four billion nodes, each of which can locally address probably 256 pages each of sixteen million cells; and given that a cell is (currently) eight bytes, that's a total potential address space of 4,722,366,482,869,645,213,696 bytes, which is 4.7x1022, which is rather a lot.
|
||||||
|
|
||||||
|
You also need an additional cell type, CACH, a cache cell, a specialisation of CONS, whose first pointer points to the (foreign) cell which is cached, and whose second pointer points to the local (i.e. in this node's cons space) copy. When a non-local cell is first requested by EVAL,
|
||||||
|
|
||||||
|
1. the communications thread on the node requests it from the ('foreign') node which curates it;
|
||||||
|
2. the foreign node increments the reference counter on its copy;
|
||||||
|
3. the foreign node sends a representation of the content of the cell hoppity-hop across the grid to the requesting node;
|
||||||
|
4. the requesting node pops a cell off its local free list, writes into it the content it has received, increments its reference counter to one, pops a second cell off its free list, writes CACH into the tag, the address of the foreign cell into the first pointer, the address of the newly created copy into the second, and returns this second cell.
|
||||||
|
|
||||||
|
When the reference counter on a CACH cell is decremented to zero,
|
||||||
|
|
||||||
|
1. the communications thread on the requesting node notifies the curating node that the reference can be decremented;
|
||||||
|
2. the curating node decrements the reference and signals back that this has been done;
|
||||||
|
3. the requesting node clears both cells and pushes them back onto its free list.
|
||||||
|
|
||||||
|
### Why we should generalise this idea: stack frames
|
||||||
|
|
||||||
|
We currently allocate stack frames in vector space, which is to say on the heap. The payload of a stack frame is currently 96 bytes (eleven cons pointers plus two 32 bit integers):
|
||||||
|
|
||||||
|
```C
|
||||||
|
/*
|
||||||
|
* number of arguments stored in a stack frame
|
||||||
|
*/
|
||||||
|
#define args_in_frame 8
|
||||||
|
|
||||||
|
/**
|
||||||
|
* A stack frame. Yes, I know it isn't a cons-space object, but it's defined
|
||||||
|
* here to avoid circularity. \todo refactor.
|
||||||
|
*/
|
||||||
|
struct stack_frame {
|
||||||
|
/** the previous frame. */
|
||||||
|
struct cons_pointer previous;
|
||||||
|
/** first 8 arument bindings. */
|
||||||
|
struct cons_pointer arg[args_in_frame];
|
||||||
|
/** list of any further argument bindings. */
|
||||||
|
struct cons_pointer more;
|
||||||
|
/** the function to be called. */
|
||||||
|
struct cons_pointer function;
|
||||||
|
/** the number of arguments provided. */
|
||||||
|
int args;
|
||||||
|
/** the depth of the stack below this frame */
|
||||||
|
int depth;
|
||||||
|
};
|
||||||
|
```
|
||||||
|
|
||||||
|
But because it's a Lisp object in vector space it also needs a vector space object header, so that we can identify it and manage it:
|
||||||
|
|
||||||
|
```c
|
||||||
|
/**
|
||||||
|
* the header which forms the start of every vector space object.
|
||||||
|
*/
|
||||||
|
struct vector_space_header {
|
||||||
|
/** the tag (type) of this vector-space object. */
|
||||||
|
union {
|
||||||
|
/** the tag considered as bytes. */
|
||||||
|
char bytes[TAGLENGTH];
|
||||||
|
/** the tag considered as a number */
|
||||||
|
uint32_t value;
|
||||||
|
} tag;
|
||||||
|
/** back pointer to the vector pointer which uniquely points to this vso */
|
||||||
|
struct cons_pointer vecp;
|
||||||
|
/** the size of my payload, in bytes */
|
||||||
|
uint64_t size;
|
||||||
|
};
|
||||||
|
```
|
||||||
|
|
||||||
|
which is a further twenty bytes, so one hundred and sixteen bytes in total. We're allocating one of these objects every time we evaluate a function; we're deallocating one every time we leave a function. The present prototype will happily run up a stack of several tens of thousands of frames, and collapse it back down again, in a single recursive computation.
|
||||||
|
|
||||||
|
That's a lot of churn.
|
||||||
|
|
||||||
|
If we allocated stack frames in pages, in the same way that we allocate cons cells, that churn would never hit the heap allocator: we would not fragment the heap.
|
||||||
|
Generalising the generalisation
|
||||||
|
|
||||||
|
So we have one set of objects which are each 32 bytes, and one set which are each 116; and just as there are lots of things which are not cons cells which can be fitted into the payload footprint of a cons cell, so I suspect we may find, when we move on to implementing things like regularities, that there many things which are not stack frames which fit into the payload footprint of a stack frame, more or less.
|
||||||
|
|
||||||
|
But the size of a stack frame is closely coupled to the number of registers of the actual hardware of the processor on the node; and though if I ever get round to building an actual prototype that's probably ARM64, I like the idea that there should at least in theory be a custom processor for nodes that runs Lisp on the metal, as the Symbolics Ivory did.
|
||||||
|
|
||||||
|
So while a cons cell payload probably really is 128 bits for all time, a stack frame payload is more mutable. Eight argument registers and one 'more' register seems about right to me, but...
|
||||||
|
|
||||||
|
However, if we say we will have a number of standard sizes of paged objects; that every paged object shall have the same sized header; that all objects on any given page shall be the same size; and that all pages shall fit into the same footprint (that is to say, a page with larger objects must needs have proportionally fewer of them), then we can say that the standard payload sizes, in bytes, shall be powers of two, and that we don't allocate a page for a standard size until we have a request to allocate an object of that size.
|
||||||
|
|
||||||
|
So our standard sizes have payloads of 1, 2, 4, 8, 16, 32, 64, 128, 256, 512...
|
||||||
|
|
||||||
|
I've highlighted 16 because that will accommodate all our existing cons space objects; 32 because that will accommodate my current implementation of hash tables and namespaces,128 because that will accommodate stack frames... But actually, we would do a much more efficient implementation of hash tables if we allocated an object big enough to have a separate pointer for each bucket, so we probably already have a need for three distinct standard sizes of object, and, as I say, I see benefit of having a generalised scheme.
|
||||||
|
|
||||||
|
In the current prototype I'm allocating pages to fit only 1024 cons cells each, because I wanted to be able to test running a free list across multiple pages. My current idea of the final size of a cons page is that it should accommodate 16 million (224) cells, which is 134 million (227) bytes. So on the generalised scheme, we would be able in principle to allocate a single object of up to ~134 megabytes in a page that would fit sixteen million cells, and we would only need to introduce any fragmentation into the heap if we needed to allocate single objects larger than this.
|
||||||
|
|
||||||
|
That seems a very big win.
|
||||||
|
## Mark but don't sweep
|
||||||
|
|
||||||
|
The post scarcity architecture was designed around the idea of a reference counting garbage collector, and I have a very clear idea of how you can make tracking references, and collecting garbage, work across a hypercube
|
||||||
|
|
||||||
|
[^1]: I'm not certain I'm using the word hypercube strictly correctly; the topology I'm contemplating is more than three dimensions but fewer than four. However, the architecture would scale to fractal dimensions greater than four, although I think it would get progressively harder to physically build such machines as the dimensions increase.
|
||||||
|
|
||||||
|
in which pretty much every node is caching copies of objects which actually 'belong to', or are curated by, other nodes — provided that you can make reference counting work at all, which so far I'm struggling to do (but I think this is because I'm stupid, not because it's impossible).
|
||||||
|
|
||||||
|
I don't yet have a clear account of how you could make a non-reference counting garbage collector work across a distributed network.
|
||||||
|
|
||||||
|
However, I can see how, in having pages of equal sized objects, you can make garbage collection very much faster and can probably do it without even interrupting the evaluation thread.
|
||||||
|
|
||||||
|
Conventional mark and sweep garbage collectors — including generational garbage collectors — implement the following algorithm:
|
||||||
|
|
||||||
|
1. Halt execution of program evaluation;
|
||||||
|
2. Trace every single pointer on every single object in the generation being collected, and mark the object each points to;
|
||||||
|
3. Then go through every object in that generation, and those which have not been marked, schedule for overwriting;
|
||||||
|
4. Then move objects which have been marked downwards in memory to fill the voids left by objects which have not been marked (this is the sweeping phase);
|
||||||
|
5. Then correct all the pointers to all the objects which have been moved;
|
||||||
|
6. If that didn't recover enough memory, repeat for the previous generation, recursively;
|
||||||
|
7. Finally restart execution.
|
||||||
|
|
||||||
|
This is a really complicated operation and takes considerable time. It's this which is the main cause of the annoying pauses in programs which use automatic memory management. Of course, in a reference counting system, when you remove the last link to the top node of a large data structure, there is a cascade of decrements below it, but these can take place in a separate thread and do not have to interrupt program execution.
|
||||||
|
|
||||||
|
However, a large part of the cost of the mark-and-sweep algorithm is the sweep phase (and as I say, even generational systems have a sweep phase). The reason you need to sweep is to avoid fragmentation of the heap. If you allocate objects in equal sized pages each of equal sized objects, you can never fragment the heap, so (there is a problem here, but I'm going to ignore it for a moment and then come back to it), you never(ish) need to sweep.
|
||||||
|
|
||||||
|
You instead, when a page becomes full,
|
||||||
|
|
||||||
|
1. Don't halt program execution, but temporarily mark this page as locked (allocation can continue on other pages);
|
||||||
|
2. In a separate thread, trace all the links in this page and pages newer than this page to objects in this page, and mark those objects
|
||||||
|
1. Obviously, if while this is happening the execution thread makes a new link to something on the locked page, then that something needs to be marked;
|
||||||
|
3. Clear all the objects which have not been marked, and push them back onto the free list of the page;
|
||||||
|
4. If all the objects on this page are now on the free list, deallocate this page. Otherwise, remove the locked marker on this page (allocation can resume on this page).
|
||||||
|
|
||||||
|
Program execution never needs to halt. If the node hardware architecture has two cores, an execution core and a communications core, then garbage collection can run on the communications core, and execution doesn't even have to slow. If it proves in practice that this slows communications too much, then perhaps a third core is needed, or perhaps you shift garbage collection back to a separate thread on the evaluation core.
|
||||||
|
The problem
|
||||||
|
|
||||||
|
So, I said there was a problem. Obviously, a page which is empty (every object in it is FREE) can safely be deallocated, and another page, perhaps for objects of a different size, can later be allocated in the same real estate. The problem is that, in the worst case, you might end up with two (or more) pages for a given size of object each of which was less than half full, but neither of which was empty. I don't currently see how you can merge the two pages into one without doing a mark-and-sweep, and without interrupting execution.
|
||||||
|
|
||||||
|
Also, if another node is holding a pointer to an object on one of the two half-empty pages, then the housekeeping to maintain track of which nodes hold pointers to what, and where that has been moved to, becomes very awkward.
|
||||||
|
|
||||||
|
So it may be that a hypercube running mark-but-don't-sweep would eventually suffer from coronary artery disease, which would mean this architecture would be a bust. But it might also be that in practice this wouldn't happen; that newer pages — which is inevitably where churn would occur — would automatically empty and be deallocated in the normal course of computation. I don't know; it's quite likely but I certainly don't have a proof of it.
|
||||||
|
|
||||||
|
## The substrate language
|
||||||
|
|
||||||
|
### Emerging from the stone age
|
||||||
|
|
||||||
|
I started work on the post scarcity software environment, as I say, nine years ago. At that time Rust could not do unions, and I was not aware of Zig at all. I needed — or at least, I thought I needed (and still do think I need) a language in which to write the substrate from which Lisp could be bootstrapped: a language in which the memory management layer would be written.
|
||||||
|
|
||||||
|
I needed a language in which I could write as close to the metal as possible. I chose C, and because I'm allergic to the Byzantine complexity of C++, I chose plain old vanilla C. I've written large programs in C before, but it is not a language I'm comfortable with. When things break horribly in C — as they do — I really struggle. The thing which has really held development of this system back is that I tried to write bignum arithmetic in C, and I have utterly failed to get it working. And then spent literally years beating myself up about it.
|
||||||
|
|
||||||
|
I've also failed to get my garbage collector working to my satisfaction; I don't think I'm incrementing and decrementing counters where I should be, and I feel that far too much garbage is not being collected. But it sort of works. Well enough for now.
|
||||||
|
|
||||||
|
The solutions to these problems would probably be absurdly obvious to someone who is actually a good software engineer, rather than just cos-playing one, but they have proved beyond me.
|
||||||
|
|
||||||
|
I've been unwilling to change the substrate language, because I've done an awful lot of work in the memory architecture in C and up to now I've been pretty satisfied with that work; and because Rust still doesn't look very appealing to me; and because I really have not yet fully evaluated Zig.
|
||||||
|
|
||||||
|
However...
|
||||||
|
|
||||||
|
If I am going to do a big rewrite of the bottom layer of the memory allocation system, then it would make sense to write it in a more modern language.
|
||||||
|
A bootstrap made of bootstraps
|
||||||
|
|
||||||
|
But more! One of the things I'm thinking looking at what I've built so far is that I've tried to do too much in the substrate. Bignums could have been implemented — much more easily, and probably not much less efficiently — in the Lisp layer. So could rationals (and complex numbers, and all sorts of other fancy number systems). So could hash tables and namespaces and regularities and homogeneities and all the other fancy data structures that I want to build.
|
||||||
|
|
||||||
|
To do that, I would need a Lisp which had functions to do low level manipulation of memory structures, which is something I don't want 'user level' programmers to be able to do. But I already have a Lisp with access control lists on every data item, including functions. So it will be trivial to implement a :system privilege layer, and to have functions written at that :system privilege layer that most users would not be entitled to invoke.
|
||||||
|
Conclusion, for now
|
||||||
|
|
||||||
|
Of course, it's now the end of winter, and big software projects are, for me, these days, winter occupations; in summer there is too much to do outside.
|
||||||
|
|
||||||
|
But I think my plan now is to
|
||||||
|
|
||||||
|
1. get version 0.0.6 just a little bit more polished so that other people can — if they're mad enough — play with it; and then call the 0.0.X series done;
|
||||||
|
2. start again with a new 0.1.X series, with a much shallower substrate written probably in Zig, with generalised paged memory objects;
|
||||||
|
3. write the access control list system, something of a use authentication system, something of a privilege layer system;
|
||||||
|
4. write Lisp functions which can directly manipulate memory objects, and, within the paged memory objects framework, define completely new types of memory objects;
|
||||||
|
5. write the north, south, east, west, up, down internode communication channels, so that I can start patching together a virtual hypercube;
|
||||||
|
6. write a launcher (in some language) which can launch n3 instances of the same Lisp image as processes on a single conventional UN*X machine, stitch their channels together so that they can communicate, and allow clients to connect (probably over SSH) so that users can open REPL sessions.
|
||||||
|
|
||||||
|
If I ever get that completed, the next goal is probably a compiler, and the goal after that build a real physical hypercube of edge 2, probably using ARM or RISC-V processors.
|
||||||
|
|
@ -3,6 +3,29 @@
|
||||||
;; `nth` (from `nth.lisp`)
|
;; `nth` (from `nth.lisp`)
|
||||||
;; `string?` (from `types.lisp`)
|
;; `string?` (from `types.lisp`)
|
||||||
|
|
||||||
|
(set! nil? (lambda
|
||||||
|
(o)
|
||||||
|
"`(nil? object)`: Return `t` if object is `nil`, else `t`."
|
||||||
|
(= o nil)))
|
||||||
|
|
||||||
|
(set! member? (lambda
|
||||||
|
(item collection)
|
||||||
|
"`(member? item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
|
||||||
|
(cond
|
||||||
|
((= 0 (count collection)) nil)
|
||||||
|
((= item (car collection)) t)
|
||||||
|
(t (member? item (cdr collection))))))
|
||||||
|
|
||||||
|
;; (member? (type member?) '("LMDA" "NLMD"))
|
||||||
|
|
||||||
|
(set! nth (lambda (n l)
|
||||||
|
"Return the `n`th member of this list `l`, or `nil` if none."
|
||||||
|
(cond ((= nil l) nil)
|
||||||
|
((= n 1) (car l))
|
||||||
|
(t (nth (- n 1) (cdr l))))))
|
||||||
|
|
||||||
|
(set! string? (lambda (o) "True if `o` is a string." (= (type o) "STRG") ) )
|
||||||
|
|
||||||
(set! documentation (lambda (object)
|
(set! documentation (lambda (object)
|
||||||
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
||||||
(cond ((member? (type object) '("FUNC" "SPFM"))
|
(cond ((member? (type object) '("FUNC" "SPFM"))
|
||||||
|
|
@ -15,3 +38,7 @@
|
||||||
|
|
||||||
(set! doc documentation)
|
(set! doc documentation)
|
||||||
|
|
||||||
|
(documentation apply)
|
||||||
|
|
||||||
|
;; (documentation member?)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,14 +1,18 @@
|
||||||
(set! nil? (lambda
|
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
||||||
(o)
|
|
||||||
"`(nil? object)`: Return `t` if object is `nil`, else `t`."
|
|
||||||
(= o nil)))
|
|
||||||
|
|
||||||
(set! member? (lambda
|
(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)
|
(item collection)
|
||||||
"`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
|
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
|
||||||
(cond
|
(cond
|
||||||
((nil? collection) nil)
|
((nil? collection) nil)
|
||||||
((= item (car collection)) t)
|
((= item (car collection)) t)
|
||||||
(t (member? item (cdr collection))))))
|
(t (member? item (cdr collection))))))
|
||||||
|
|
||||||
;; (member? (type member?) '("LMDA" "NLMD"))
|
|
||||||
|
|
|
||||||
|
|
@ -210,7 +210,7 @@ __int128_t int128_to_integer( __int128_t val,
|
||||||
|
|
||||||
if ( integerp( less_significant ) ) {
|
if ( integerp( less_significant ) ) {
|
||||||
struct cons_space_object *lsc = &pointer2cell( less_significant );
|
struct cons_space_object *lsc = &pointer2cell( less_significant );
|
||||||
inc_ref( new );
|
// inc_ref( new );
|
||||||
lsc->payload.integer.more = new;
|
lsc->payload.integer.more = new;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -226,23 +226,10 @@ 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;
|
||||||
|
|
||||||
if ( integerp( a ) && integerp( b ) ) {
|
while ( integerp( a ) || integerp( b ) || carry != 0 ) {
|
||||||
debug_print( L"add_integers: \n", DEBUG_ARITH );
|
|
||||||
debug_dump_object( a, DEBUG_ARITH );
|
|
||||||
debug_print( L" plus \n", DEBUG_ARITH );
|
|
||||||
debug_dump_object( b, DEBUG_ARITH );
|
|
||||||
debug_println( DEBUG_ARITH );
|
|
||||||
|
|
||||||
while ( !nilp( a ) || !nilp( b ) || carry != 0 ) {
|
|
||||||
__int128_t av = cell_value( a, '+', is_first_cell );
|
__int128_t av = cell_value( a, '+', is_first_cell );
|
||||||
__int128_t bv = cell_value( b, '+', is_first_cell );
|
__int128_t bv = cell_value( b, '+', is_first_cell );
|
||||||
__int128_t rv = ( av + bv ) + carry;
|
__int128_t rv = ( av + bv ) + carry;
|
||||||
|
|
@ -257,9 +244,8 @@ struct cons_pointer add_integers( struct cons_pointer a,
|
||||||
debug_print_128bit( rv, DEBUG_ARITH );
|
debug_print_128bit( rv, DEBUG_ARITH );
|
||||||
debug_print( L"\n", DEBUG_ARITH );
|
debug_print( L"\n", DEBUG_ARITH );
|
||||||
|
|
||||||
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT ) {
|
if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
|
||||||
result =
|
result = acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
|
||||||
acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
|
|
||||||
break;
|
break;
|
||||||
} else {
|
} else {
|
||||||
struct cons_pointer new = make_integer( 0, NIL );
|
struct cons_pointer new = make_integer( 0, NIL );
|
||||||
|
|
@ -275,7 +261,6 @@ struct cons_pointer add_integers( struct cons_pointer a,
|
||||||
is_first_cell = false;
|
is_first_cell = false;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
|
||||||
|
|
||||||
debug_print( L"add_integers returning: ", DEBUG_ARITH );
|
debug_print( L"add_integers returning: ", DEBUG_ARITH );
|
||||||
debug_print_object( result, DEBUG_ARITH );
|
debug_print_object( result, DEBUG_ARITH );
|
||||||
|
|
|
||||||
|
|
@ -296,7 +296,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
||||||
to_long_double( arg2 ) );
|
to_long_double( arg2 ) );
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result = throw_exception( c_string_to_lisp_string
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot add: not a number" ),
|
( L"Cannot add: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -319,7 +321,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
|
||||||
to_long_double( arg2 ) );
|
to_long_double( arg2 ) );
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result = throw_exception( c_string_to_lisp_string
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot add: not a number" ),
|
( L"Cannot add: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -332,7 +336,8 @@ 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_string
|
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot add: not a number" ),
|
( L"Cannot add: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
}
|
}
|
||||||
|
|
@ -428,7 +433,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result =
|
result =
|
||||||
throw_exception( make_cons
|
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||||
|
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 ) ),
|
||||||
|
|
@ -454,7 +460,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result =
|
result =
|
||||||
throw_exception( make_cons
|
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||||
|
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 ) ),
|
||||||
|
|
@ -467,7 +474,8 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
|
||||||
to_long_double( arg2 ) );
|
to_long_double( arg2 ) );
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result = throw_exception( make_cons( c_string_to_lisp_string
|
result = throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
( L"Cannot multiply: argument 1 is not a number" ),
|
( L"Cannot multiply: argument 1 is not a number" ),
|
||||||
c_type( arg1 ) ),
|
c_type( arg1 ) ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
|
|
@ -620,7 +628,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot subtract: not a number" ),
|
( L"Cannot subtract: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -650,7 +659,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot subtract: not a number" ),
|
( L"Cannot subtract: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -661,7 +671,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"-" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot subtract: not a number" ),
|
( L"Cannot subtract: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -732,7 +743,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot divide: not a number" ),
|
( L"Cannot divide: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -762,7 +774,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot divide: not a number" ),
|
( L"Cannot divide: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -774,7 +787,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"/" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Cannot divide: not a number" ),
|
( L"Cannot divide: not a number" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
|
||||||
|
|
@ -114,7 +114,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
|
||||||
cell1->payload.ratio.divisor ) );
|
cell1->payload.ratio.divisor ) );
|
||||||
r = make_ratio( dividend, divisor, true );
|
r = make_ratio( dividend, divisor, true );
|
||||||
} else {
|
} else {
|
||||||
r = throw_exception( make_cons( c_string_to_lisp_string
|
r = throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
|
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
|
||||||
make_cons( arg1,
|
make_cons( arg1,
|
||||||
make_cons( arg2, NIL ) ) ),
|
make_cons( arg2, NIL ) ) ),
|
||||||
|
|
@ -154,7 +155,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
|
||||||
dec_ref( ratio );
|
dec_ref( ratio );
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( make_cons( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"+" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
|
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
|
||||||
make_cons( intarg,
|
make_cons( intarg,
|
||||||
make_cons( ratarg,
|
make_cons( ratarg,
|
||||||
|
|
@ -234,7 +236,8 @@ struct cons_pointer multiply_ratio_ratio( struct
|
||||||
release_integer( divisor );
|
release_integer( divisor );
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||||
|
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 );
|
||||||
}
|
}
|
||||||
|
|
@ -269,7 +272,8 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
|
||||||
release_integer( one );
|
release_integer( one );
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"*" ),
|
||||||
|
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 );
|
||||||
}
|
}
|
||||||
|
|
@ -337,7 +341,8 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Dividend and divisor of a ratio must be integers" ),
|
( L"Dividend and divisor of a ratio must be integers" ),
|
||||||
NIL );
|
NIL );
|
||||||
}
|
}
|
||||||
|
|
|
||||||
19
src/debug.c
19
src/debug.c
|
|
@ -32,6 +32,25 @@
|
||||||
*/
|
*/
|
||||||
int verbosity = 0;
|
int verbosity = 0;
|
||||||
|
|
||||||
|
/**
|
||||||
|
* When debugging, we want to see exceptions as they happen, because they may
|
||||||
|
* not make their way back down the stack to whatever is expected to handle
|
||||||
|
* them.
|
||||||
|
*/
|
||||||
|
void debug_print_exception( struct cons_pointer ex_ptr ) {
|
||||||
|
#ifdef DEBUG
|
||||||
|
if ( ( verbosity != 0 ) && exceptionp( ex_ptr ) ) {
|
||||||
|
fwide( stderr, 1 );
|
||||||
|
fputws( L"EXCEPTION: ", stderr );
|
||||||
|
|
||||||
|
URL_FILE *ustderr = file_to_url_file( stderr );
|
||||||
|
fwide( stderr, 1 );
|
||||||
|
print( ustderr, ex_ptr );
|
||||||
|
free( ustderr );
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* @brief print this debug `message` to stderr, if `verbosity` matches `level`.
|
* @brief print this debug `message` to stderr, if `verbosity` matches `level`.
|
||||||
*
|
*
|
||||||
|
|
|
||||||
|
|
@ -79,8 +79,16 @@
|
||||||
*/
|
*/
|
||||||
#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 );
|
||||||
|
|
|
||||||
87
src/init.c
87
src/init.c
|
|
@ -47,11 +47,12 @@
|
||||||
*/
|
*/
|
||||||
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 = NIL;
|
struct cons_pointer result = pointer;
|
||||||
|
|
||||||
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 );
|
||||||
|
|
@ -59,43 +60,47 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
|
||||||
free( ustderr );
|
free( ustderr );
|
||||||
|
|
||||||
dec_ref( pointer );
|
dec_ref( pointer );
|
||||||
} else {
|
|
||||||
result = pointer;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
struct cons_pointer init_documentation_symbol = NIL;
|
|
||||||
struct cons_pointer init_name_symbol = NIL;
|
|
||||||
struct cons_pointer init_primitive_symbol = NIL;
|
|
||||||
|
|
||||||
void maybe_bind_init_symbols( ) {
|
void maybe_bind_init_symbols( ) {
|
||||||
if ( nilp( init_documentation_symbol ) ) {
|
if ( nilp( privileged_keyword_documentation ) ) {
|
||||||
init_documentation_symbol =
|
privileged_keyword_documentation =
|
||||||
c_string_to_lisp_keyword( L"documentation" );
|
c_string_to_lisp_keyword( L"documentation" );
|
||||||
}
|
}
|
||||||
if ( nilp( init_name_symbol ) ) {
|
if ( nilp( privileged_keyword_name ) ) {
|
||||||
init_name_symbol = c_string_to_lisp_keyword( L"name" );
|
privileged_keyword_name = c_string_to_lisp_keyword( L"name" );
|
||||||
}
|
}
|
||||||
if ( nilp( init_primitive_symbol ) ) {
|
if ( nilp( privileged_keyword_primitive ) ) {
|
||||||
init_primitive_symbol = c_string_to_lisp_keyword( L"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" );
|
||||||
}
|
}
|
||||||
if ( nilp( privileged_string_memory_exhausted ) ) {
|
|
||||||
// we can't make this string when we need it, because memory is then
|
// we can't make this string when we need it, because memory is then
|
||||||
// exhausted!
|
// exhausted!
|
||||||
|
if ( nilp( privileged_string_memory_exhausted ) ) {
|
||||||
privileged_string_memory_exhausted =
|
privileged_string_memory_exhausted =
|
||||||
c_string_to_lisp_string( L"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( init_documentation_symbol );
|
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 );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -115,10 +120,11 @@ struct cons_pointer bind_function( wchar_t *name,
|
||||||
struct cons_pointer d = c_string_to_lisp_string( doc );
|
struct cons_pointer d = c_string_to_lisp_string( doc );
|
||||||
|
|
||||||
struct cons_pointer meta =
|
struct cons_pointer meta =
|
||||||
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
|
||||||
make_cons( make_cons( init_name_symbol, n ),
|
make_cons( make_cons( privileged_keyword_name, n ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( init_documentation_symbol, d ),
|
( privileged_keyword_documentation,
|
||||||
|
d ),
|
||||||
NIL ) ) );
|
NIL ) ) );
|
||||||
|
|
||||||
struct cons_pointer r =
|
struct cons_pointer r =
|
||||||
|
|
@ -144,10 +150,11 @@ struct cons_pointer bind_special( wchar_t *name,
|
||||||
struct cons_pointer d = c_string_to_lisp_string( doc );
|
struct cons_pointer d = c_string_to_lisp_string( doc );
|
||||||
|
|
||||||
struct cons_pointer meta =
|
struct cons_pointer meta =
|
||||||
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
make_cons( make_cons( privileged_keyword_primitive, TRUE ),
|
||||||
make_cons( make_cons( init_name_symbol, n ),
|
make_cons( make_cons( privileged_keyword_name, n ),
|
||||||
make_cons( make_cons
|
make_cons( make_cons
|
||||||
( init_documentation_symbol, d ),
|
( privileged_keyword_documentation,
|
||||||
|
d ),
|
||||||
NIL ) ) );
|
NIL ) ) );
|
||||||
|
|
||||||
struct cons_pointer r =
|
struct cons_pointer r =
|
||||||
|
|
@ -208,6 +215,8 @@ void print_options( FILE *stream ) {
|
||||||
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
|
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
|
||||||
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
|
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
|
||||||
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
|
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
|
||||||
|
fwprintf( stream,
|
||||||
|
L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" );
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
fwprintf( stream,
|
fwprintf( stream,
|
||||||
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
|
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
|
||||||
|
|
@ -220,7 +229,8 @@ void print_options( FILE *stream ) {
|
||||||
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
|
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
|
||||||
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
|
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
|
||||||
fwprintf( stream, L"\t\t128\tREPL;\n" );
|
fwprintf( stream, L"\t\t128\tREPL;\n" );
|
||||||
fwprintf( stream, L"\t\t256\tSTACK.\n" );
|
fwprintf( stream, L"\t\t256\tSTACK;\n" );
|
||||||
|
fwprintf( stream, L"\t\t512\tEQUAL.\n" );
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -240,7 +250,7 @@ int main( int argc, char *argv[] ) {
|
||||||
exit( 1 );
|
exit( 1 );
|
||||||
}
|
}
|
||||||
|
|
||||||
while ( ( option = getopt( argc, argv, "phdv:i:" ) ) != -1 ) {
|
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
|
||||||
switch ( option ) {
|
switch ( option ) {
|
||||||
case 'd':
|
case 'd':
|
||||||
dump_at_end = true;
|
dump_at_end = true;
|
||||||
|
|
@ -256,6 +266,9 @@ 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;
|
||||||
|
|
@ -287,6 +300,8 @@ 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
|
||||||
|
|
@ -317,7 +332,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 ),
|
||||||
|
|
@ -401,10 +416,14 @@ int main( int argc, char *argv[] ) {
|
||||||
bind_function( L"inspect",
|
bind_function( L"inspect",
|
||||||
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
|
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
|
||||||
&lisp_inspect );
|
&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",
|
bind_function( L"keys",
|
||||||
L"`(keys store)`: Return a list of all keys in this `store`.",
|
L"`(keys store)`: Return a list of all keys in this `store`.",
|
||||||
&lisp_keys );
|
&lisp_keys );
|
||||||
bind_function( L"list", L"`(list args...): Return a list of these `args`.",
|
bind_function( L"list",
|
||||||
|
L"`(list args...)`: Return a list of these `args`.",
|
||||||
&lisp_list );
|
&lisp_list );
|
||||||
bind_function( L"mapcar",
|
bind_function( L"mapcar",
|
||||||
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
|
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
|
||||||
|
|
@ -438,7 +457,7 @@ int main( int argc, char *argv[] ) {
|
||||||
&lisp_print );
|
&lisp_print );
|
||||||
bind_function( L"println",
|
bind_function( L"println",
|
||||||
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
|
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
|
||||||
&lisp_print );
|
&lisp_println );
|
||||||
bind_function( L"put!", L"", lisp_hashmap_put );
|
bind_function( L"put!", L"", lisp_hashmap_put );
|
||||||
bind_function( L"put-all!",
|
bind_function( L"put-all!",
|
||||||
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
|
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
|
||||||
|
|
@ -468,7 +487,9 @@ int main( int argc, char *argv[] ) {
|
||||||
bind_function( L"subtract",
|
bind_function( L"subtract",
|
||||||
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
||||||
&lisp_subtract );
|
&lisp_subtract );
|
||||||
bind_function( L"throw", L"", &lisp_exception );
|
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",
|
bind_function( L"time",
|
||||||
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
|
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
|
||||||
&lisp_time );
|
&lisp_time );
|
||||||
|
|
@ -516,7 +537,9 @@ int main( int argc, char *argv[] ) {
|
||||||
bind_special( L"set!",
|
bind_special( L"set!",
|
||||||
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
|
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
|
||||||
&lisp_set_shriek );
|
&lisp_set_shriek );
|
||||||
bind_special( L"try", L"", &lisp_try );
|
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 );
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -101,7 +101,7 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
|
||||||
struct cons_pointer key = c_car( ks );
|
struct cons_pointer key = c_car( ks );
|
||||||
print( output, key );
|
print( output, key );
|
||||||
url_fputwc( btowc( ' ' ), output );
|
url_fputwc( btowc( ' ' ), output );
|
||||||
print( output, hashmap_get( map, key ) );
|
print( output, hashmap_get( map, key, false ) );
|
||||||
|
|
||||||
if ( !nilp( c_cdr( ks ) ) ) {
|
if ( !nilp( c_cdr( ks ) ) ) {
|
||||||
url_fputws( L", ", output );
|
url_fputws( L", ", output );
|
||||||
|
|
@ -348,17 +348,8 @@ lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
if ( writep( out_stream ) ) {
|
if ( writep( out_stream ) ) {
|
||||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||||
inc_ref( out_stream );
|
|
||||||
} else {
|
|
||||||
output = file_to_url_file( stderr );
|
|
||||||
}
|
|
||||||
|
|
||||||
println( output );
|
println( output );
|
||||||
|
|
||||||
if ( writep( out_stream ) ) {
|
|
||||||
dec_ref( out_stream );
|
|
||||||
} else {
|
|
||||||
free( output );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
return NIL;
|
return NIL;
|
||||||
|
|
|
||||||
|
|
@ -167,7 +167,8 @@ 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_string
|
throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||||
|
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 ) {
|
||||||
|
|
@ -177,7 +178,8 @@ 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_string
|
result = throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"End of input while reading" ),
|
( L"End of input while reading" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
@ -266,7 +268,8 @@ 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( make_cons( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||||
|
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 );
|
||||||
|
|
@ -313,7 +316,8 @@ 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_string
|
return throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Malformed number: too many periods" ),
|
( L"Malformed number: too many periods" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -324,7 +328,8 @@ 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_string
|
return throw_exception( c_string_to_lisp_symbol( L"read" ),
|
||||||
|
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 {
|
||||||
|
|
|
||||||
|
|
@ -65,7 +65,11 @@ 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 = malloc( sizeof( struct cons_page ) );
|
struct cons_page *result = NULL;
|
||||||
|
|
||||||
|
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;
|
||||||
|
|
@ -116,12 +120,12 @@ void make_cons_page( ) {
|
||||||
|
|
||||||
initialised_cons_pages++;
|
initialised_cons_pages++;
|
||||||
} else {
|
} else {
|
||||||
debug_printf( DEBUG_ALLOC,
|
fwide( stderr, 1 );
|
||||||
|
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 );
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -250,8 +254,9 @@ 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 %d, %d \n",
|
L"Allocated cell of type %4.4s at %u, %u \n",
|
||||||
cell->tag.bytes, result.page, result.offset );
|
( ( char * ) cell->tag.bytes ), result.page,
|
||||||
|
result.offset );
|
||||||
} else {
|
} else {
|
||||||
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
|
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -27,6 +27,44 @@
|
||||||
#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
|
||||||
|
|
@ -35,11 +73,11 @@
|
||||||
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 ) {
|
||||||
|
|
@ -66,7 +104,7 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
|
||||||
cell->count++;
|
cell->count++;
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_printf( DEBUG_ALLOC,
|
debug_printf( DEBUG_ALLOC,
|
||||||
L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d",
|
L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
|
||||||
( ( char * ) cell->tag.bytes ), pointer.page,
|
( ( char * ) cell->tag.bytes ), pointer.page,
|
||||||
pointer.offset, cell->count );
|
pointer.offset, cell->count );
|
||||||
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
|
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
|
||||||
|
|
@ -119,6 +157,19 @@ 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.
|
||||||
|
|
@ -387,15 +438,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 = internedp( result, oblist );
|
// struct cons_pointer r = interned( result, oblist );
|
||||||
|
|
||||||
if ( nilp( r ) ) {
|
// if ( nilp( r ) ) {
|
||||||
intern( result, oblist );
|
// intern( result, oblist );
|
||||||
} else {
|
// } else {
|
||||||
result = r;
|
// result = r;
|
||||||
}
|
// }
|
||||||
}
|
// }
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
make_exception( c_string_to_lisp_string
|
make_exception( c_string_to_lisp_string
|
||||||
|
|
|
||||||
|
|
@ -56,6 +56,42 @@
|
||||||
*/
|
*/
|
||||||
#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.
|
||||||
|
|
@ -189,7 +225,7 @@
|
||||||
#define READTV 1145128274
|
#define READTV 1145128274
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* A real number, represented internally as an IEEE 754-2008 `binary64`.
|
* A real number, represented internally as an IEEE 754-2008 `binary128`.
|
||||||
*/
|
*/
|
||||||
#define REALTAG "REAL"
|
#define REALTAG "REAL"
|
||||||
|
|
||||||
|
|
@ -221,7 +257,7 @@
|
||||||
#define STRINGTV 1196577875
|
#define STRINGTV 1196577875
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* A symbol is just like a string except not self-evaluating.
|
* A symbol is just like a keyword except not self-evaluating.
|
||||||
*/
|
*/
|
||||||
#define SYMBOLTAG "SYMB"
|
#define SYMBOLTAG "SYMB"
|
||||||
|
|
||||||
|
|
@ -444,6 +480,8 @@ 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;
|
||||||
};
|
};
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -710,6 +748,11 @@ struct cons_pointer inc_ref( struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer dec_ref( struct cons_pointer pointer );
|
struct cons_pointer dec_ref( struct cons_pointer pointer );
|
||||||
|
|
||||||
|
/**
|
||||||
|
* given a cons_pointer as argument, return the tag.
|
||||||
|
*/
|
||||||
|
uint32_t get_tag_value( struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer c_type( struct cons_pointer pointer );
|
struct cons_pointer c_type( struct cons_pointer pointer );
|
||||||
|
|
||||||
struct cons_pointer c_car( struct cons_pointer arg );
|
struct cons_pointer c_car( struct cons_pointer arg );
|
||||||
|
|
|
||||||
|
|
@ -26,12 +26,18 @@
|
||||||
#include "memory/vectorspace.h"
|
#include "memory/vectorspace.h"
|
||||||
#include "ops/lispops.h"
|
#include "ops/lispops.h"
|
||||||
|
|
||||||
|
/**
|
||||||
|
* @brief If non-zero, maximum depth of stack.
|
||||||
|
*
|
||||||
|
*/
|
||||||
|
uint32_t stack_limit = 0;
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* set a register in a stack frame. Alwaye use this to do so,
|
* set a register in a stack frame. Alwaye use this to do so,
|
||||||
* because that way we can be sure the inc_ref happens!
|
* because that way we can be sure the inc_ref happens!
|
||||||
*/
|
*/
|
||||||
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
|
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) {
|
||||||
debug_printf( DEBUG_STACK, L"Setting register %d to ", reg );
|
debug_printf( DEBUG_STACK, L"\tSetting 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
|
||||||
|
|
@ -57,10 +63,11 @@ 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"get_stack_frame: all good, returning %p\n", result );
|
// L"\nget_stack_frame: all good, returning %p\n", result );
|
||||||
} else {
|
} else {
|
||||||
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
|
debug_print( L"\nget_stack_frame: fail, returning NULL\n",
|
||||||
|
DEBUG_STACK );
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
|
|
@ -68,17 +75,19 @@ 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 env the environment in which evaluation happens.
|
* @param depth the depth of the new frame.
|
||||||
* @return the new frame, or NULL if memory is exhausted.
|
* @return the new frame, or NULL if memory is exhausted.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
|
struct cons_pointer in_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 );
|
||||||
/*
|
/*
|
||||||
|
|
@ -86,10 +95,11 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
|
||||||
*/
|
*/
|
||||||
|
|
||||||
frame->previous = previous;
|
frame->previous = previous;
|
||||||
|
frame->depth = depth;
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* clearing the frame with memset would probably be slightly quicker, but
|
* The frame has already been cleared with memset in make_vso, but our
|
||||||
* this is clear.
|
* NIL is not the same as C's NULL.
|
||||||
*/
|
*/
|
||||||
frame->more = NIL;
|
frame->more = NIL;
|
||||||
frame->function = NIL;
|
frame->function = NIL;
|
||||||
|
|
@ -98,6 +108,8 @@ struct cons_pointer 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 );
|
||||||
|
|
@ -105,6 +117,39 @@ struct cons_pointer 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.
|
||||||
|
|
@ -119,11 +164,7 @@ 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 ( nilp( result ) ) {
|
if ( !exceptionp( result ) ) {
|
||||||
/* i.e. out of memory */
|
|
||||||
result =
|
|
||||||
make_exception( privileged_string_memory_exhausted, previous );
|
|
||||||
} else {
|
|
||||||
struct stack_frame *frame = get_stack_frame( result );
|
struct stack_frame *frame = get_stack_frame( result );
|
||||||
|
|
||||||
while ( frame->args < args_in_frame && consp( args ) ) {
|
while ( frame->args < args_in_frame && consp( args ) ) {
|
||||||
|
|
@ -144,9 +185,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
|
||||||
result = val;
|
result = val;
|
||||||
break;
|
break;
|
||||||
} else {
|
} else {
|
||||||
debug_printf( DEBUG_STACK, L"Setting argument %d to ",
|
debug_printf( DEBUG_STACK, L"\tSetting 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 );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -161,6 +203,10 @@ 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_print( L"make_stack_frame: returning\n", DEBUG_STACK );
|
||||||
|
|
@ -185,12 +231,7 @@ 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 ( nilp( result ) ) {
|
if ( !exceptionp( 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 ) ) {
|
||||||
|
|
@ -281,14 +322,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 with %d arguments:\n",
|
url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
|
||||||
frame->args );
|
frame->depth, frame->args );
|
||||||
dump_frame_context( output, frame_pointer, 4 );
|
dump_frame_context( output, frame_pointer, 4 );
|
||||||
|
|
||||||
for ( int arg = 0; arg < frame->args; arg++ ) {
|
for ( int arg = 0; arg < frame->args; arg++ ) {
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
|
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
|
||||||
|
|
||||||
url_fwprintf( output, L"Arg %d:\t%4.4s\tcount: %10u\tvalue: ",
|
url_fwprintf( output, L"\tArg %d:\t%4.4s\tcount: %10u\tvalue: ",
|
||||||
arg, cell.tag.bytes, cell.count );
|
arg, cell.tag.bytes, cell.count );
|
||||||
|
|
||||||
print( output, frame->arg[arg] );
|
print( output, frame->arg[arg] );
|
||||||
|
|
|
||||||
|
|
@ -21,6 +21,8 @@
|
||||||
#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"
|
||||||
|
|
||||||
|
|
@ -35,6 +37,8 @@
|
||||||
*/
|
*/
|
||||||
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
|
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
|
||||||
|
|
||||||
|
extern uint32_t stack_limit;
|
||||||
|
|
||||||
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
|
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
|
||||||
|
|
||||||
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
|
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
|
||||||
|
|
|
||||||
|
|
@ -74,7 +74,7 @@ bool equal_ld_ld( long double a, long double b ) {
|
||||||
|
|
||||||
bool result = ( fabsl( a - b ) < tolerance );
|
bool result = ( fabsl( a - b ) < tolerance );
|
||||||
|
|
||||||
debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result );
|
debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
@ -272,7 +272,9 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
|
|
||||||
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
||||||
struct cons_pointer key = c_car( i );
|
struct cons_pointer key = c_car( i );
|
||||||
if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) {
|
if ( !equal
|
||||||
|
( hashmap_get( a, key, false ),
|
||||||
|
hashmap_get( b, key, false ) ) ) {
|
||||||
result = false;
|
result = false;
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
@ -330,10 +332,10 @@ bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
* identical structure, else false.
|
* identical structure, else false.
|
||||||
*/
|
*/
|
||||||
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
debug_print( L"\nequal: ", DEBUG_ARITH );
|
debug_print( L"\nequal: ", DEBUG_EQUAL );
|
||||||
debug_print_object( a, DEBUG_ARITH );
|
debug_print_object( a, DEBUG_EQUAL );
|
||||||
debug_print( L" = ", DEBUG_ARITH );
|
debug_print( L" = ", DEBUG_EQUAL );
|
||||||
debug_print_object( b, DEBUG_ARITH );
|
debug_print_object( b, DEBUG_EQUAL );
|
||||||
|
|
||||||
bool result = false;
|
bool result = false;
|
||||||
|
|
||||||
|
|
@ -375,8 +377,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
memset( a_buff, 0, sizeof( a_buff ) );
|
memset( a_buff, 0, sizeof( a_buff ) );
|
||||||
memset( b_buff, 0, sizeof( b_buff ) );
|
memset( b_buff, 0, sizeof( b_buff ) );
|
||||||
|
|
||||||
for ( ;
|
for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
|
||||||
( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
|
|
||||||
&& !nilp( b ); i++ ) {
|
&& !nilp( b ); i++ ) {
|
||||||
a_buff[i] = cell_a->payload.string.character;
|
a_buff[i] = cell_a->payload.string.character;
|
||||||
a = c_cdr( a );
|
a = c_cdr( a );
|
||||||
|
|
@ -388,11 +389,11 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
}
|
}
|
||||||
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_print( L"Comparing '", DEBUG_ARITH );
|
debug_print( L"Comparing '", DEBUG_EQUAL );
|
||||||
debug_print( a_buff, DEBUG_ARITH );
|
debug_print( a_buff, DEBUG_EQUAL );
|
||||||
debug_print( L"' to '", DEBUG_ARITH );
|
debug_print( L"' to '", DEBUG_EQUAL );
|
||||||
debug_print( b_buff, DEBUG_ARITH );
|
debug_print( b_buff, DEBUG_EQUAL );
|
||||||
debug_print( L"'\n", DEBUG_ARITH );
|
debug_print( L"'\n", DEBUG_EQUAL );
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* OK, now we have wchar string buffers loaded from the objects. We
|
/* OK, now we have wchar string buffers loaded from the objects. We
|
||||||
|
|
@ -426,7 +427,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
||||||
* I'll ignore them, too, for now.
|
* I'll ignore them, too, for now.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result );
|
debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
323
src/ops/intern.c
323
src/ops/intern.c
|
|
@ -191,7 +191,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
|
||||||
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
|
for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
|
||||||
pair = c_car( assoc ) ) {
|
pair = c_car( assoc ) ) {
|
||||||
/* TODO: this is really hammering the memory management system, because
|
/* TODO: this is really hammering the memory management system, because
|
||||||
* it will make a new lone for every key/value pair added. Fix. */
|
* it will make a new clone for every key/value pair added. Fix. */
|
||||||
if ( consp( pair ) ) {
|
if ( consp( pair ) ) {
|
||||||
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
|
mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
|
||||||
} else if ( hashmapp( pair ) ) {
|
} else if ( hashmapp( pair ) ) {
|
||||||
|
|
@ -205,7 +205,7 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
|
||||||
for ( struct cons_pointer keys = hashmap_keys( assoc );
|
for ( struct cons_pointer keys = hashmap_keys( assoc );
|
||||||
!nilp( keys ); keys = c_cdr( keys ) ) {
|
!nilp( keys ); keys = c_cdr( keys ) ) {
|
||||||
struct cons_pointer key = c_car( keys );
|
struct cons_pointer key = c_car( keys );
|
||||||
hashmap_put( mapp, key, hashmap_get( assoc, key ) );
|
hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
@ -216,17 +216,33 @@ 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 c_assoc, q.v.
|
* closely tied in with search_store, q.v.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
||||||
struct cons_pointer key ) {
|
struct cons_pointer key, bool return_key ) {
|
||||||
|
#ifdef DEBUG
|
||||||
|
debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
|
||||||
|
debug_print_object( key, DEBUG_BIND );
|
||||||
|
debug_print( L"`; store of type `", DEBUG_BIND );
|
||||||
|
debug_print_object( c_type( mapp ), DEBUG_BIND );
|
||||||
|
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
|
||||||
|
return_key ? "key" : "value" );
|
||||||
|
#endif
|
||||||
|
|
||||||
struct cons_pointer result = NIL;
|
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 = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
|
result =
|
||||||
|
search_store( key, map->payload.hashmap.buckets[bucket_no],
|
||||||
|
return_key );
|
||||||
}
|
}
|
||||||
|
#ifdef DEBUG
|
||||||
|
debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
|
||||||
|
debug_print_object( result, DEBUG_BIND );
|
||||||
|
debug_print( L"`\n", DEBUG_BIND );
|
||||||
|
#endif
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
@ -267,52 +283,185 @@ 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)
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Implementation of interned? in C. The final implementation if interned? will
|
* @brief `(search-store key store return-key?)` Search this `store` for this
|
||||||
* deal with stores which can be association lists or hashtables or hybrids of
|
* a key lexically identical to this `key`.
|
||||||
* the two, but that will almost certainly be implemented in lisp.
|
|
||||||
*
|
*
|
||||||
* If this key is lexically identical to a key in this store, return the key
|
* If found, then, if `return-key?` is non-nil, return the copy found in the
|
||||||
* from the store (so that later when we want to retrieve a value, an eq test
|
* `store`, else return the value associated with it.
|
||||||
* will work); otherwise return NIL.
|
*
|
||||||
|
* 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
|
struct cons_pointer search_store( struct cons_pointer key,
|
||||||
internedp( struct cons_pointer key, struct cons_pointer store ) {
|
struct cons_pointer store,
|
||||||
|
bool return_key ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( symbolp( key ) || keywordp( key ) ) {
|
#ifdef DEBUG
|
||||||
// TODO: I see what I was doing here and it would be the right thing to
|
debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
|
||||||
// do for stores which are old-fashioned assoc lists, but it will not work
|
|
||||||
// for my new hybrid stores.
|
|
||||||
// for ( struct cons_pointer next = store;
|
|
||||||
// nilp( result ) && consp( next );
|
|
||||||
// next = pointer2cell( next ).payload.cons.cdr ) {
|
|
||||||
// struct cons_space_object entry =
|
|
||||||
// pointer2cell( pointer2cell( next ).payload.cons.car );
|
|
||||||
|
|
||||||
// debug_print( L"Internedp: checking whether `", DEBUG_BIND );
|
|
||||||
// debug_print_object( key, DEBUG_BIND );
|
|
||||||
// debug_print( L"` equals `", DEBUG_BIND );
|
|
||||||
// debug_print_object( entry.payload.cons.car, DEBUG_BIND );
|
|
||||||
// debug_print( L"`\n", DEBUG_BIND );
|
|
||||||
|
|
||||||
// if ( equal( key, entry.payload.cons.car ) ) {
|
|
||||||
// result = entry.payload.cons.car;
|
|
||||||
// }
|
|
||||||
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_object( key, DEBUG_BIND );
|
||||||
debug_print( L"` is a ", DEBUG_BIND );
|
debug_print( L"`; store of type `", DEBUG_BIND );
|
||||||
debug_printf( DEBUG_BIND, L"%4.4s",
|
debug_print_object( c_type( store ), DEBUG_BIND );
|
||||||
( char * ) pointer2cell( key ).tag.bytes );
|
debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
|
||||||
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
|
return_key ? "key" : "value" );
|
||||||
|
#endif
|
||||||
|
|
||||||
|
switch ( get_tag_value( key ) ) {
|
||||||
|
case SYMBOLTV:
|
||||||
|
case KEYTV:
|
||||||
|
struct cons_space_object *store_cell = &pointer2cell( store );
|
||||||
|
|
||||||
|
switch ( get_tag_value( store ) ) {
|
||||||
|
case CONSTV:
|
||||||
|
for ( struct cons_pointer cursor = store;
|
||||||
|
nilp( result ) && ( consp( cursor )
|
||||||
|
|| hashmapp( cursor ) );
|
||||||
|
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
|
||||||
|
switch ( get_tag_value( cursor ) ) {
|
||||||
|
case CONSTV:
|
||||||
|
struct cons_pointer entry_ptr =
|
||||||
|
c_car( cursor );
|
||||||
|
|
||||||
|
switch ( get_tag_value( entry_ptr ) ) {
|
||||||
|
case CONSTV:
|
||||||
|
if ( equal( key, c_car( entry_ptr ) ) ) {
|
||||||
|
result =
|
||||||
|
return_key ? c_car( entry_ptr )
|
||||||
|
: c_cdr( entry_ptr );
|
||||||
|
goto found;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case HASHTV:
|
||||||
|
case NAMESPACETV:
|
||||||
|
result =
|
||||||
|
hashmap_get( entry_ptr, key,
|
||||||
|
return_key );
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
result =
|
||||||
|
throw_exception
|
||||||
|
( c_string_to_lisp_symbol
|
||||||
|
( L"search-store (entry)" ),
|
||||||
|
make_cons
|
||||||
|
( c_string_to_lisp_string
|
||||||
|
( L"Unexpected store type: " ),
|
||||||
|
c_type( c_car( entry_ptr ) ) ),
|
||||||
|
NIL );
|
||||||
|
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case HASHTV:
|
||||||
|
case NAMESPACETV:
|
||||||
|
debug_print
|
||||||
|
( L"\n\tHashmap as top-level value in list",
|
||||||
|
DEBUG_BIND );
|
||||||
|
result =
|
||||||
|
hashmap_get( cursor, key, return_key );
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol
|
||||||
|
( L"search-store (cursor)" ),
|
||||||
|
make_cons
|
||||||
|
( c_string_to_lisp_string
|
||||||
|
( L"Unexpected store type: " ),
|
||||||
|
c_type( cursor ) ),
|
||||||
|
NIL );
|
||||||
|
}
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case HASHTV:
|
||||||
|
case NAMESPACETV:
|
||||||
|
result = hashmap_get( store, key, return_key );
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol
|
||||||
|
( L"search-store (store)" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
|
( L"Unexpected store type: " ),
|
||||||
|
c_type( store ) ), NIL );
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case EXCEPTIONTV:
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol
|
||||||
|
( L"search-store (exception)" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
|
( L"Unexpected key type: " ),
|
||||||
|
c_type( key ) ), NIL );
|
||||||
|
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol
|
||||||
|
( L"search-store (key)" ),
|
||||||
|
make_cons( c_string_to_lisp_string
|
||||||
|
( L"Unexpected key type: " ),
|
||||||
|
c_type( key ) ), NIL );
|
||||||
|
}
|
||||||
|
|
||||||
|
found:
|
||||||
|
|
||||||
|
debug_print( L"search-store: returning `", DEBUG_BIND );
|
||||||
|
debug_print_object( result, DEBUG_BIND );
|
||||||
|
debug_print( L"`\n", DEBUG_BIND );
|
||||||
|
|
||||||
|
return result;
|
||||||
|
}
|
||||||
|
|
||||||
|
struct cons_pointer interned( struct cons_pointer key,
|
||||||
|
struct cons_pointer store ) {
|
||||||
|
return search_store( key, store, true );
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* @brief Implementation of `interned?` in C.
|
||||||
|
*
|
||||||
|
* @param key the key to search for.
|
||||||
|
* @param store the store to search in.
|
||||||
|
* @return struct cons_pointer `t` if the key was found, else `nil`.
|
||||||
|
*/
|
||||||
|
struct cons_pointer internedp( struct cons_pointer key,
|
||||||
|
struct cons_pointer store ) {
|
||||||
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
|
if ( consp( store ) ) {
|
||||||
|
for ( struct cons_pointer pair = c_car( store );
|
||||||
|
eq( result, NIL ) && !nilp( pair ); pair = c_car( store ) ) {
|
||||||
|
if ( consp( pair ) ) {
|
||||||
|
if ( equal( c_car( pair ), key ) ) {
|
||||||
|
// yes, this should be `eq`, but if symbols are correctly
|
||||||
|
// interned this will work efficiently, and if not it will
|
||||||
|
// still work.
|
||||||
|
result = TRUE;
|
||||||
|
}
|
||||||
|
} else if ( hashmapp( pair ) ) {
|
||||||
|
result = internedp( key, pair );
|
||||||
|
}
|
||||||
|
|
||||||
|
store = c_cdr( store );
|
||||||
|
}
|
||||||
|
} else if ( hashmapp( store ) ) {
|
||||||
|
struct vector_space_object *map = pointer_to_vso( store );
|
||||||
|
|
||||||
|
for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
|
||||||
|
for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
|
||||||
|
!nilp( c ); c = c_cdr( c ) ) {
|
||||||
|
result = internedp( key, c );
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
|
|
@ -328,65 +477,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
|
||||||
*/
|
*/
|
||||||
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 result = NIL;
|
return search_store( key, store, false );
|
||||||
|
|
||||||
if ( !nilp( key ) ) {
|
|
||||||
if ( consp( store ) ) {
|
|
||||||
for ( struct cons_pointer next = store;
|
|
||||||
nilp( result ) && ( consp( next ) || hashmapp( next ) );
|
|
||||||
next = pointer2cell( next ).payload.cons.cdr ) {
|
|
||||||
if ( consp( next ) ) {
|
|
||||||
// #ifdef DEBUG
|
|
||||||
// debug_print( L"\nc_assoc; key is `", DEBUG_BIND );
|
|
||||||
// debug_print_object( key, DEBUG_BIND );
|
|
||||||
// debug_print( L"`\n", DEBUG_BIND );
|
|
||||||
// #endif
|
|
||||||
|
|
||||||
struct cons_pointer entry_ptr = c_car( next );
|
|
||||||
struct cons_space_object entry = pointer2cell( entry_ptr );
|
|
||||||
|
|
||||||
switch ( entry.tag.value ) {
|
|
||||||
case CONSTV:
|
|
||||||
if ( equal( key, entry.payload.cons.car ) ) {
|
|
||||||
result = entry.payload.cons.cdr;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case VECTORPOINTTV:
|
|
||||||
result = hashmap_get( entry_ptr, key );
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
throw_exception( c_append
|
|
||||||
( c_string_to_lisp_string
|
|
||||||
( L"Store entry is of unknown type: " ),
|
|
||||||
c_type( entry_ptr ) ), NIL );
|
|
||||||
}
|
|
||||||
|
|
||||||
// #ifdef DEBUG
|
|
||||||
// debug_print( L"c_assoc `", DEBUG_BIND );
|
|
||||||
// debug_print_object( key, DEBUG_BIND );
|
|
||||||
// debug_print( L"` returning: ", DEBUG_BIND );
|
|
||||||
// debug_print_object( result, DEBUG_BIND );
|
|
||||||
// debug_println( DEBUG_BIND );
|
|
||||||
// #endif
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} else if ( hashmapp( store ) ) {
|
|
||||||
result = hashmap_get( store, key );
|
|
||||||
} else if ( !nilp( store ) ) {
|
|
||||||
// #ifdef DEBUG
|
|
||||||
// debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND );
|
|
||||||
// debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes);
|
|
||||||
// debug_print( L"`\n", DEBUG_BIND );
|
|
||||||
// #endif
|
|
||||||
result =
|
|
||||||
throw_exception( c_append
|
|
||||||
( c_string_to_lisp_string
|
|
||||||
( L"Store is of unknown type: " ),
|
|
||||||
c_type( store ) ), NIL );
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
return result;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -414,11 +505,15 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
||||||
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;
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Return a new key/value store containing all the key/value pairs in this
|
* If this store is modifiable, add this key value pair to it. Otherwise,
|
||||||
|
* return a new key/value store containing all the key/value pairs in this
|
||||||
* store with this key/value pair added to the front.
|
* 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,
|
||||||
|
|
@ -426,7 +521,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
bool deep = vectorpointp( store );
|
bool deep = eq( store, oblist );
|
||||||
debug_print_binding( key, value, deep, DEBUG_BIND );
|
debug_print_binding( key, value, deep, DEBUG_BIND );
|
||||||
|
|
||||||
if ( deep ) {
|
if ( deep ) {
|
||||||
|
|
@ -434,9 +529,7 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
||||||
pointer2cell( store ).payload.vectorp.tag.bytes );
|
pointer2cell( store ).payload.vectorp.tag.bytes );
|
||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
if ( nilp( value ) ) {
|
if ( nilp( store ) || consp( store ) ) {
|
||||||
result = store;
|
|
||||||
} else 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 ) ) {
|
||||||
result = hashmap_put( store, key, value );
|
result = hashmap_put( store, key, value );
|
||||||
|
|
@ -452,16 +545,8 @@ 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;
|
|
||||||
|
|
||||||
oblist = set( key, value, oblist );
|
oblist = set( key, value, oblist );
|
||||||
|
|
||||||
// The oblist is not now an assoc list, and I don't think it will be again.
|
|
||||||
// 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 );
|
||||||
|
|
@ -480,7 +565,7 @@ 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
|
* not currently bound. TODO: this should bind to NIL?
|
||||||
*/
|
*/
|
||||||
result = set( key, TRUE, environment );
|
result = set( key, TRUE, environment );
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -20,6 +20,9 @@
|
||||||
#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;
|
||||||
|
|
@ -31,7 +34,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 );
|
struct cons_pointer key, bool return_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,
|
||||||
|
|
@ -46,14 +49,17 @@ 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 internedp( struct cons_pointer key,
|
struct cons_pointer interned( struct cons_pointer key,
|
||||||
struct cons_pointer environment );
|
struct cons_pointer environment );
|
||||||
|
|
||||||
struct cons_pointer hashmap_get( struct cons_pointer mapp,
|
struct cons_pointer internedp( struct cons_pointer key,
|
||||||
struct cons_pointer key );
|
struct cons_pointer environment );
|
||||||
|
|
||||||
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,
|
||||||
|
|
@ -69,4 +75,7 @@ struct cons_pointer deep_bind( struct cons_pointer key,
|
||||||
struct cons_pointer intern( struct cons_pointer key,
|
struct cons_pointer intern( struct cons_pointer key,
|
||||||
struct cons_pointer environment );
|
struct cons_pointer environment );
|
||||||
|
|
||||||
|
struct cons_pointer internedp( struct cons_pointer key,
|
||||||
|
struct cons_pointer store );
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
|
||||||
|
|
@ -91,8 +91,10 @@ struct cons_pointer eval_form( struct stack_frame *parent,
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_empty_frame( parent_pointer );
|
make_empty_frame( parent_pointer );
|
||||||
// inc_ref( next_pointer );
|
|
||||||
|
|
||||||
|
if ( exceptionp( next_pointer ) ) {
|
||||||
|
result = next_pointer;
|
||||||
|
} else {
|
||||||
struct stack_frame *next = get_stack_frame( next_pointer );
|
struct stack_frame *next = get_stack_frame( next_pointer );
|
||||||
set_reg( next, 0, form );
|
set_reg( next, 0, form );
|
||||||
next->args = 1;
|
next->args = 1;
|
||||||
|
|
@ -106,6 +108,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
|
||||||
dec_ref( next_pointer );
|
dec_ref( next_pointer );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
}
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -248,7 +251,7 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
* Evaluate a lambda or nlambda expression.
|
* Evaluate a lambda or nlambda expression.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
|
||||||
struct cons_pointer frame_pointer, struct cons_pointer env ) {
|
struct cons_pointer frame_pointer, struct cons_pointer env ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
|
|
@ -257,8 +260,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
struct cons_pointer new_env = env;
|
struct cons_pointer new_env = env;
|
||||||
struct cons_pointer names = cell.payload.lambda.args;
|
struct cons_pointer names = cell->payload.lambda.args;
|
||||||
struct cons_pointer body = cell.payload.lambda.body;
|
struct cons_pointer body = cell->payload.lambda.body;
|
||||||
|
|
||||||
if ( consp( names ) ) {
|
if ( consp( names ) ) {
|
||||||
/* if `names` is a list, bind successive items from that list
|
/* if `names` is a list, bind successive items from that list
|
||||||
|
|
@ -272,7 +275,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
|
|
||||||
names = c_cdr( names );
|
names = c_cdr( names );
|
||||||
}
|
}
|
||||||
// inc_ref( new_env );
|
|
||||||
|
|
||||||
/* \todo if there's more than `args_in_frame` arguments, bind those too. */
|
/* \todo if there's more than `args_in_frame` arguments, bind those too. */
|
||||||
} else if ( symbolp( names ) ) {
|
} else if ( symbolp( names ) ) {
|
||||||
|
|
@ -293,7 +295,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
}
|
}
|
||||||
|
|
||||||
new_env = set( names, vals, new_env );
|
new_env = set( names, vals, new_env );
|
||||||
// inc_ref( new_env );
|
|
||||||
}
|
}
|
||||||
|
|
||||||
while ( !nilp( body ) ) {
|
while ( !nilp( body ) ) {
|
||||||
|
|
@ -308,9 +309,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
|
|
||||||
/* if a result is not the terminal result in the lambda, it's a
|
/* if a result is not the terminal result in the lambda, it's a
|
||||||
* side effect, and needs to be GCed */
|
* side effect, and needs to be GCed */
|
||||||
if ( !nilp( result ) ) {
|
|
||||||
dec_ref( result );
|
dec_ref( result );
|
||||||
}
|
|
||||||
|
|
||||||
result = eval_form( frame, frame_pointer, sexpr, new_env );
|
result = eval_form( frame, frame_pointer, sexpr, new_env );
|
||||||
|
|
||||||
|
|
@ -319,6 +318,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
// TODO: I think we do need to dec_ref everything on new_env back to env
|
||||||
// dec_ref( new_env );
|
// dec_ref( new_env );
|
||||||
|
|
||||||
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
|
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
|
||||||
|
|
@ -328,6 +328,52 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* if `r` is an exception, and it doesn't have a location, fix up its location from
|
||||||
|
* the name associated with this fn_pointer, if any.
|
||||||
|
*/
|
||||||
|
struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
|
||||||
|
struct cons_pointer
|
||||||
|
fn_pointer ) {
|
||||||
|
struct cons_pointer result = r;
|
||||||
|
|
||||||
|
if ( exceptionp( result )
|
||||||
|
&& ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) {
|
||||||
|
struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
|
||||||
|
|
||||||
|
struct cons_pointer payload =
|
||||||
|
pointer2cell( result ).payload.exception.payload;
|
||||||
|
|
||||||
|
switch ( get_tag_value( payload ) ) {
|
||||||
|
case NILTV:
|
||||||
|
case CONSTV:
|
||||||
|
case HASHTV:
|
||||||
|
{
|
||||||
|
if ( nilp( c_assoc( privileged_keyword_location,
|
||||||
|
payload ) ) ) {
|
||||||
|
pointer2cell( result ).payload.exception.payload =
|
||||||
|
set( privileged_keyword_location,
|
||||||
|
c_assoc( privileged_keyword_name,
|
||||||
|
fn_cell->payload.function.meta ),
|
||||||
|
payload );
|
||||||
|
}
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
pointer2cell( result ).payload.exception.payload =
|
||||||
|
make_cons( make_cons( privileged_keyword_location,
|
||||||
|
c_assoc( privileged_keyword_name,
|
||||||
|
fn_cell->payload.function.
|
||||||
|
meta ) ),
|
||||||
|
make_cons( make_cons
|
||||||
|
( privileged_keyword_payload,
|
||||||
|
payload ), NIL ) );
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return result;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Internal guts of apply.
|
* Internal guts of apply.
|
||||||
|
|
@ -348,10 +394,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
if ( exceptionp( fn_pointer ) ) {
|
if ( exceptionp( fn_pointer ) ) {
|
||||||
result = fn_pointer;
|
result = fn_pointer;
|
||||||
} else {
|
} else {
|
||||||
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
|
struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
|
||||||
struct cons_pointer args = c_cdr( frame->arg[0] );
|
struct cons_pointer args = c_cdr( frame->arg[0] );
|
||||||
|
|
||||||
switch ( fn_cell.tag.value ) {
|
switch ( get_tag_value( fn_pointer ) ) {
|
||||||
case EXCEPTIONTV:
|
case EXCEPTIONTV:
|
||||||
/* just pass exceptions straight back */
|
/* just pass exceptions straight back */
|
||||||
result = fn_pointer;
|
result = fn_pointer;
|
||||||
|
|
@ -362,17 +408,19 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer exep = NIL;
|
struct cons_pointer exep = NIL;
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_stack_frame( frame_pointer, args, env );
|
make_stack_frame( frame_pointer, args, env );
|
||||||
// inc_ref( next_pointer );
|
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
struct stack_frame *next =
|
struct stack_frame *next =
|
||||||
get_stack_frame( next_pointer );
|
get_stack_frame( next_pointer );
|
||||||
|
|
||||||
result =
|
result = maybe_fixup_exception_location( ( *
|
||||||
( *fn_cell.payload.function.executable ) ( next,
|
( fn_cell->payload.function.executable ) )
|
||||||
|
( next,
|
||||||
next_pointer,
|
next_pointer,
|
||||||
env );
|
env ),
|
||||||
|
fn_pointer );
|
||||||
dec_ref( next_pointer );
|
dec_ref( next_pointer );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
@ -391,7 +439,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer exep = NIL;
|
struct cons_pointer exep = NIL;
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_stack_frame( frame_pointer, args, env );
|
make_stack_frame( frame_pointer, args, env );
|
||||||
// inc_ref( next_pointer );
|
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -406,8 +454,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case VECTORPOINTTV:
|
|
||||||
switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
|
|
||||||
case HASHTV:
|
case HASHTV:
|
||||||
/* \todo: if arg[0] is a CONS, treat it as a path */
|
/* \todo: if arg[0] is a CONS, treat it as a path */
|
||||||
result = c_assoc( eval_form( frame,
|
result = c_assoc( eval_form( frame,
|
||||||
|
|
@ -417,14 +463,12 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
[0] ) ), env ),
|
[0] ) ), env ),
|
||||||
fn_pointer );
|
fn_pointer );
|
||||||
break;
|
break;
|
||||||
}
|
|
||||||
break;
|
|
||||||
|
|
||||||
case NLAMBDATV:
|
case NLAMBDATV:
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_special_frame( frame_pointer, args, env );
|
make_special_frame( frame_pointer, args, env );
|
||||||
// inc_ref( next_pointer );
|
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
|
|
@ -441,15 +485,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
{
|
{
|
||||||
struct cons_pointer next_pointer =
|
struct cons_pointer next_pointer =
|
||||||
make_special_frame( frame_pointer, args, env );
|
make_special_frame( frame_pointer, args, env );
|
||||||
inc_ref( next_pointer );
|
|
||||||
if ( exceptionp( next_pointer ) ) {
|
if ( exceptionp( next_pointer ) ) {
|
||||||
result = next_pointer;
|
result = next_pointer;
|
||||||
} else {
|
} else {
|
||||||
result =
|
result = maybe_fixup_exception_location( ( *
|
||||||
( *fn_cell.payload.
|
( fn_cell->payload.special.executable ) )
|
||||||
special.executable ) ( get_stack_frame
|
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
|
||||||
( next_pointer ),
|
|
||||||
next_pointer, env );
|
|
||||||
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
||||||
debug_print_object( result, DEBUG_EVAL );
|
debug_print_object( result, DEBUG_EVAL );
|
||||||
debug_println( DEBUG_EVAL );
|
debug_println( DEBUG_EVAL );
|
||||||
|
|
@ -465,13 +507,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
memset( buffer, '\0', bs );
|
memset( buffer, '\0', bs );
|
||||||
swprintf( buffer, bs,
|
swprintf( buffer, bs,
|
||||||
L"Unexpected cell with tag %d (%4.4s) in function position",
|
L"Unexpected cell with tag %d (%4.4s) in function position",
|
||||||
fn_cell.tag.value, &fn_cell.tag.bytes[0] );
|
fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) );
|
||||||
struct cons_pointer message =
|
struct cons_pointer message =
|
||||||
c_string_to_lisp_string( buffer );
|
c_string_to_lisp_string( buffer );
|
||||||
free( buffer );
|
free( buffer );
|
||||||
result = throw_exception( message, frame_pointer );
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"apply" ),
|
||||||
|
message, frame_pointer );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
debug_print( L"c_apply: returning: ", DEBUG_EVAL );
|
debug_print( L"c_apply: returning: ", DEBUG_EVAL );
|
||||||
|
|
@ -508,26 +553,27 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
debug_dump_object( frame_pointer, DEBUG_EVAL );
|
debug_dump_object( frame_pointer, DEBUG_EVAL );
|
||||||
|
|
||||||
struct cons_pointer result = frame->arg[0];
|
struct cons_pointer result = frame->arg[0];
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[0] );
|
struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
|
||||||
|
|
||||||
switch ( cell.tag.value ) {
|
switch ( cell->tag.value ) {
|
||||||
case CONSTV:
|
case CONSTV:
|
||||||
result = c_apply( frame, frame_pointer, env );
|
result = c_apply( frame, frame_pointer, env );
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case SYMBOLTV:
|
case SYMBOLTV:
|
||||||
{
|
{
|
||||||
struct cons_pointer canonical =
|
struct cons_pointer canonical = interned( frame->arg[0], env );
|
||||||
internedp( frame->arg[0], env );
|
|
||||||
if ( nilp( canonical ) ) {
|
if ( nilp( canonical ) ) {
|
||||||
struct cons_pointer message =
|
struct cons_pointer message =
|
||||||
make_cons( c_string_to_lisp_string
|
make_cons( c_string_to_lisp_string
|
||||||
( L"Attempt to take value of unbound symbol." ),
|
( L"Attempt to take value of unbound symbol." ),
|
||||||
frame->arg[0] );
|
frame->arg[0] );
|
||||||
result = throw_exception( message, frame_pointer );
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"eval" ),
|
||||||
|
message, frame_pointer );
|
||||||
} else {
|
} else {
|
||||||
result = c_assoc( canonical, env );
|
result = c_assoc( canonical, env );
|
||||||
inc_ref( result );
|
// inc_ref( result );
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
|
@ -625,7 +671,8 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
result = frame->arg[1];
|
result = frame->arg[1];
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( make_cons
|
throw_exception( c_string_to_lisp_symbol( L"set" ),
|
||||||
|
make_cons
|
||||||
( c_string_to_lisp_string
|
( c_string_to_lisp_string
|
||||||
( L"The first argument to `set` is not a symbol: " ),
|
( L"The first argument to `set` is not a symbol: " ),
|
||||||
make_cons( frame->arg[0], NIL ) ),
|
make_cons( frame->arg[0], NIL ) ),
|
||||||
|
|
@ -664,7 +711,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
result = val;
|
result = val;
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( make_cons
|
throw_exception( c_string_to_lisp_symbol( L"set!" ),
|
||||||
|
make_cons
|
||||||
( c_string_to_lisp_string
|
( c_string_to_lisp_string
|
||||||
( L"The first argument to `set!` is not a symbol: " ),
|
( L"The first argument to `set!` is not a symbol: " ),
|
||||||
make_cons( frame->arg[0], NIL ) ),
|
make_cons( frame->arg[0], NIL ) ),
|
||||||
|
|
@ -736,24 +784,25 @@ struct cons_pointer
|
||||||
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[0] );
|
struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
|
||||||
|
|
||||||
switch ( cell.tag.value ) {
|
switch ( cell->tag.value ) {
|
||||||
case CONSTV:
|
case CONSTV:
|
||||||
result = cell.payload.cons.car;
|
result = cell->payload.cons.car;
|
||||||
break;
|
break;
|
||||||
case NILTV:
|
case NILTV:
|
||||||
break;
|
break;
|
||||||
case READTV:
|
case READTV:
|
||||||
result =
|
result =
|
||||||
make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
|
make_string( url_fgetwc( cell->payload.stream.stream ), NIL );
|
||||||
break;
|
break;
|
||||||
case STRINGTV:
|
case STRINGTV:
|
||||||
result = make_string( cell.payload.string.character, NIL );
|
result = make_string( cell->payload.string.character, NIL );
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"car" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Attempt to take CAR of non sequence" ),
|
( L"Attempt to take CAR of non sequence" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
}
|
}
|
||||||
|
|
@ -780,24 +829,25 @@ struct cons_pointer
|
||||||
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[0] );
|
struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
|
||||||
|
|
||||||
switch ( cell.tag.value ) {
|
switch ( cell->tag.value ) {
|
||||||
case CONSTV:
|
case CONSTV:
|
||||||
result = cell.payload.cons.cdr;
|
result = cell->payload.cons.cdr;
|
||||||
break;
|
break;
|
||||||
case NILTV:
|
case NILTV:
|
||||||
break;
|
break;
|
||||||
case READTV:
|
case READTV:
|
||||||
url_fgetwc( cell.payload.stream.stream );
|
url_fgetwc( cell->payload.stream.stream );
|
||||||
result = frame->arg[0];
|
result = frame->arg[0];
|
||||||
break;
|
break;
|
||||||
case STRINGTV:
|
case STRINGTV:
|
||||||
result = cell.payload.string.cdr;
|
result = cell->payload.string.cdr;
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"cdr" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Attempt to take CDR of non sequence" ),
|
( L"Attempt to take CDR of non sequence" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
}
|
}
|
||||||
|
|
@ -835,23 +885,60 @@ struct cons_pointer lisp_length( struct stack_frame *frame,
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
return c_assoc( frame->arg[0], frame->arg[1] );
|
return c_assoc( frame->arg[0],
|
||||||
|
nilp( frame->arg[1] ) ? oblist : frame->arg[1] );
|
||||||
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.
|
||||||
|
*
|
||||||
|
* @param frame
|
||||||
|
* @param frame_pointer
|
||||||
|
* @param env
|
||||||
|
* @return struct cons_pointer
|
||||||
|
*/
|
||||||
|
struct cons_pointer
|
||||||
|
lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
struct cons_pointer env ) {
|
||||||
|
struct cons_pointer result = internedp( frame->arg[0],
|
||||||
|
nilp( frame->arg[1] ) ? oblist :
|
||||||
|
frame->arg[1] );
|
||||||
|
|
||||||
|
if ( exceptionp( result ) ) {
|
||||||
|
struct cons_pointer old = result;
|
||||||
|
struct cons_space_object *cell = &( pointer2cell( result ) );
|
||||||
|
result =
|
||||||
|
throw_exception( c_string_to_lisp_symbol( L"interned?" ),
|
||||||
|
cell->payload.exception.payload, frame_pointer );
|
||||||
|
dec_ref( old );
|
||||||
|
}
|
||||||
|
|
||||||
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
struct cons_pointer c_keys( struct cons_pointer store ) {
|
struct cons_pointer c_keys( struct cons_pointer store ) {
|
||||||
struct cons_pointer result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
if ( hashmapp( store ) ) {
|
if ( consp( store ) ) {
|
||||||
result = hashmap_keys( store );
|
for ( struct cons_pointer pair = c_car( store ); !nilp( pair );
|
||||||
} else if ( consp( store ) ) {
|
pair = c_car( store ) ) {
|
||||||
for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) {
|
if ( consp( pair ) ) {
|
||||||
result = make_cons( c_car( c ), result );
|
result = make_cons( c_car( pair ), result );
|
||||||
|
} else if ( hashmapp( pair ) ) {
|
||||||
|
result = c_append( hashmap_keys( pair ), result );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
store = c_cdr( store );
|
||||||
|
}
|
||||||
|
} else if ( hashmapp( store ) ) {
|
||||||
|
result = hashmap_keys( store );
|
||||||
}
|
}
|
||||||
|
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
struct cons_pointer lisp_keys( struct stack_frame *frame,
|
struct cons_pointer lisp_keys( struct stack_frame *frame,
|
||||||
struct cons_pointer frame_pointer,
|
struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
|
|
@ -970,11 +1057,15 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
frame->arg[0] : get_default_stream( true, env );
|
frame->arg[0] : get_default_stream( true, env );
|
||||||
|
|
||||||
if ( readp( in_stream ) ) {
|
if ( readp( in_stream ) ) {
|
||||||
debug_print( L"lisp_read: setting input stream\n", DEBUG_IO );
|
debug_print( L"lisp_read: setting input stream\n",
|
||||||
|
DEBUG_IO | DEBUG_REPL );
|
||||||
debug_dump_object( in_stream, DEBUG_IO );
|
debug_dump_object( in_stream, DEBUG_IO );
|
||||||
input = pointer2cell( in_stream ).payload.stream.stream;
|
input = pointer2cell( in_stream ).payload.stream.stream;
|
||||||
inc_ref( in_stream );
|
inc_ref( in_stream );
|
||||||
} else {
|
} else {
|
||||||
|
/* should not happen, but has done. */
|
||||||
|
debug_print( L"WARNING: invalid input stream; defaulting!\n",
|
||||||
|
DEBUG_IO | DEBUG_REPL );
|
||||||
input = file_to_url_file( stdin );
|
input = file_to_url_file( stdin );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -1107,7 +1198,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
while ( consp( expressions ) ) {
|
while ( consp( expressions ) ) {
|
||||||
struct cons_pointer r = result;
|
struct cons_pointer r = result;
|
||||||
inc_ref( r );
|
|
||||||
result = eval_form( frame, frame_pointer, c_car( expressions ), env );
|
result = eval_form( frame, frame_pointer, c_car( expressions ), env );
|
||||||
dec_ref( r );
|
dec_ref( r );
|
||||||
|
|
||||||
|
|
@ -1138,7 +1229,6 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
|
|
||||||
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
|
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
|
||||||
struct cons_pointer r = result;
|
struct cons_pointer r = result;
|
||||||
inc_ref( r );
|
|
||||||
|
|
||||||
result = eval_form( frame, frame_pointer, frame->arg[i], env );
|
result = eval_form( frame, frame_pointer, frame->arg[i], env );
|
||||||
|
|
||||||
|
|
@ -1180,15 +1270,20 @@ struct cons_pointer eval_cond_clause( struct cons_pointer clause,
|
||||||
env ) );
|
env ) );
|
||||||
|
|
||||||
#ifdef DEBUG
|
#ifdef DEBUG
|
||||||
debug_print( L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL );
|
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
|
||||||
|
debug_print_object( clause, DEBUG_EVAL );
|
||||||
|
debug_print( L" succeeded; returning: ", DEBUG_EVAL );
|
||||||
debug_print_object( result, DEBUG_EVAL );
|
debug_print_object( result, DEBUG_EVAL );
|
||||||
debug_println( DEBUG_EVAL );
|
debug_println( DEBUG_EVAL );
|
||||||
} else {
|
} else {
|
||||||
debug_print( L"\n\t\tclause failed.\n", DEBUG_EVAL );
|
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL );
|
||||||
|
debug_print_object( clause, DEBUG_EVAL );
|
||||||
|
debug_print( L" failed.\n", DEBUG_EVAL );
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
result = throw_exception( c_string_to_lisp_string
|
result = throw_exception( c_string_to_lisp_symbol( L"cond" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Arguments to `cond` must be lists" ),
|
( L"Arguments to `cond` must be lists" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
}
|
}
|
||||||
|
|
@ -1235,6 +1330,58 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
return result;
|
return result;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Throw an exception with a cause.
|
||||||
|
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
||||||
|
* lisp function; but it is nevertheless to be preferred to make_exception. A
|
||||||
|
* real `throw_exception`, which does, will be needed.
|
||||||
|
* object pointing to it. Then this should become a normal lisp function
|
||||||
|
* which expects a normally bound frame and environment, such that
|
||||||
|
* frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
|
||||||
|
* pointer to the frame in which the exception occurred.
|
||||||
|
*/
|
||||||
|
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
|
||||||
|
struct cons_pointer message,
|
||||||
|
struct cons_pointer cause,
|
||||||
|
struct cons_pointer
|
||||||
|
frame_pointer ) {
|
||||||
|
struct cons_pointer result = NIL;
|
||||||
|
|
||||||
|
#ifdef DEBUG
|
||||||
|
debug_print( L"\nERROR: `", 511 );
|
||||||
|
debug_print_object( message, 511 );
|
||||||
|
debug_print( L"` at `", 511 );
|
||||||
|
debug_print_object( location, 511 );
|
||||||
|
debug_print( L"`\n", 511 );
|
||||||
|
if ( !nilp( cause ) ) {
|
||||||
|
debug_print( L"\tCaused by: ", 511 );
|
||||||
|
debug_print_object( cause, 511 );
|
||||||
|
debug_print( L"`\n", 511 );
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
struct cons_space_object *cell = &pointer2cell( message );
|
||||||
|
|
||||||
|
if ( cell->tag.value == EXCEPTIONTV ) {
|
||||||
|
result = message;
|
||||||
|
} else {
|
||||||
|
result =
|
||||||
|
make_exception( make_cons
|
||||||
|
( make_cons( privileged_keyword_location,
|
||||||
|
location ),
|
||||||
|
make_cons( make_cons
|
||||||
|
( privileged_keyword_payload,
|
||||||
|
message ),
|
||||||
|
( nilp( cause ) ? NIL :
|
||||||
|
make_cons( make_cons
|
||||||
|
( privileged_keyword_cause,
|
||||||
|
cause ), NIL ) ) ) ),
|
||||||
|
frame_pointer );
|
||||||
|
}
|
||||||
|
|
||||||
|
return result;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
* Throw an exception.
|
* Throw an exception.
|
||||||
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
|
||||||
|
|
@ -1242,25 +1389,14 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
* real `throw_exception`, which does, will be needed.
|
* real `throw_exception`, which does, will be needed.
|
||||||
* object pointing to it. Then this should become a normal lisp function
|
* object pointing to it. Then this should become a normal lisp function
|
||||||
* which expects a normally bound frame and environment, such that
|
* which expects a normally bound frame and environment, such that
|
||||||
* frame->arg[0] is the message, and frame->arg[1] is the cons-space
|
* frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
|
||||||
* pointer to the frame in which the exception occurred.
|
* pointer to the frame in which the exception occurred.
|
||||||
*/
|
*/
|
||||||
struct cons_pointer
|
struct cons_pointer
|
||||||
throw_exception( struct cons_pointer message,
|
throw_exception( struct cons_pointer location,
|
||||||
|
struct cons_pointer payload,
|
||||||
struct cons_pointer frame_pointer ) {
|
struct cons_pointer frame_pointer ) {
|
||||||
debug_print( L"\nERROR: ", DEBUG_EVAL );
|
return throw_exception_with_cause( location, payload, NIL, frame_pointer );
|
||||||
debug_dump_object( message, DEBUG_EVAL );
|
|
||||||
struct cons_pointer result = NIL;
|
|
||||||
|
|
||||||
struct cons_space_object cell = pointer2cell( message );
|
|
||||||
|
|
||||||
if ( cell.tag.value == EXCEPTIONTV ) {
|
|
||||||
result = message;
|
|
||||||
} else {
|
|
||||||
result = make_exception( message, frame_pointer );
|
|
||||||
}
|
|
||||||
|
|
||||||
return result;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -1270,7 +1406,7 @@ throw_exception( struct cons_pointer message,
|
||||||
* normally return. A function which detects a problem it cannot resolve
|
* normally return. A function which detects a problem it cannot resolve
|
||||||
* *should* return an exception.
|
* *should* return an exception.
|
||||||
*
|
*
|
||||||
* * (exception message frame)
|
* * (exception message location)
|
||||||
*
|
*
|
||||||
* @param frame my stack frame.
|
* @param frame my stack frame.
|
||||||
* @param frame_pointer a pointer to my stack_frame.
|
* @param frame_pointer a pointer to my stack_frame.
|
||||||
|
|
@ -1285,9 +1421,10 @@ struct cons_pointer
|
||||||
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer message = frame->arg[0];
|
struct cons_pointer message = frame->arg[0];
|
||||||
return exceptionp( message ) ? message : throw_exception( message,
|
|
||||||
frame->
|
return exceptionp( message ) ? message :
|
||||||
previous );
|
throw_exception_with_cause( message, frame->arg[1], frame->arg[2],
|
||||||
|
frame->previous );
|
||||||
}
|
}
|
||||||
|
|
||||||
/**
|
/**
|
||||||
|
|
@ -1307,7 +1444,11 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
struct cons_pointer env ) {
|
struct cons_pointer env ) {
|
||||||
struct cons_pointer expr = NIL;
|
struct cons_pointer expr = NIL;
|
||||||
|
|
||||||
debug_printf( DEBUG_REPL, L"Entering new inner REPL\n" );
|
#ifdef DEBUG
|
||||||
|
debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL );
|
||||||
|
debug_print_object( env, DEBUG_REPL );
|
||||||
|
debug_print( L"`\n", DEBUG_REPL );
|
||||||
|
#endif
|
||||||
|
|
||||||
struct cons_pointer input = get_default_stream( true, env );
|
struct cons_pointer input = get_default_stream( true, env );
|
||||||
struct cons_pointer output = get_default_stream( false, env );
|
struct cons_pointer output = get_default_stream( false, env );
|
||||||
|
|
@ -1322,7 +1463,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
|
set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
|
||||||
input = frame->arg[1];
|
input = frame->arg[1];
|
||||||
}
|
}
|
||||||
if ( readp( frame->arg[2] ) ) {
|
if ( writep( frame->arg[2] ) ) {
|
||||||
new_env =
|
new_env =
|
||||||
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
|
set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
|
||||||
output = frame->arg[2];
|
output = frame->arg[2];
|
||||||
|
|
@ -1332,8 +1473,16 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
inc_ref( output );
|
inc_ref( output );
|
||||||
inc_ref( prompt_name );
|
inc_ref( prompt_name );
|
||||||
|
|
||||||
URL_FILE *os = pointer2cell( output ).payload.stream.stream;
|
/* output should NEVER BE nil; but during development it has happened.
|
||||||
|
* To allow debugging under such circumstances, we need an emergency
|
||||||
|
* default. */
|
||||||
|
URL_FILE *os =
|
||||||
|
!writep( output ) ? file_to_url_file( stdout ) :
|
||||||
|
pointer2cell( output ).payload.stream.stream;
|
||||||
|
if ( !writep( output ) ) {
|
||||||
|
debug_print( L"WARNING: invalid output; defaulting!\n",
|
||||||
|
DEBUG_IO | DEBUG_REPL );
|
||||||
|
}
|
||||||
|
|
||||||
/* \todo this is subtly wrong. If we were evaluating
|
/* \todo this is subtly wrong. If we were evaluating
|
||||||
* (print (eval (read)))
|
* (print (eval (read)))
|
||||||
|
|
@ -1350,7 +1499,10 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
* \todo the whole process of resolving symbol values needs to be revisited
|
* \todo the whole process of resolving symbol values needs to be revisited
|
||||||
* when we get onto namespaces. */
|
* when we get onto namespaces. */
|
||||||
/* OK, there's something even more subtle here if the root namespace is a map.
|
/* OK, there's something even more subtle here if the root namespace is a map.
|
||||||
* H'mmmm... */
|
* H'mmmm...
|
||||||
|
* I think that now the oblist is a hashmap masquerading as a namespace,
|
||||||
|
* we should no longer have to do this. TODO: test, and if so, delete this
|
||||||
|
* statement. */
|
||||||
if ( !eq( oblist, old_oblist ) ) {
|
if ( !eq( oblist, old_oblist ) ) {
|
||||||
struct cons_pointer cursor = oblist;
|
struct cons_pointer cursor = oblist;
|
||||||
|
|
||||||
|
|
@ -1394,6 +1546,9 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
||||||
dec_ref( expr );
|
dec_ref( expr );
|
||||||
}
|
}
|
||||||
|
|
||||||
|
if ( nilp( output ) ) {
|
||||||
|
free( os );
|
||||||
|
}
|
||||||
dec_ref( input );
|
dec_ref( input );
|
||||||
dec_ref( output );
|
dec_ref( output );
|
||||||
dec_ref( prompt_name );
|
dec_ref( prompt_name );
|
||||||
|
|
@ -1420,24 +1575,24 @@ struct cons_pointer lisp_source( 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 result = NIL;
|
struct cons_pointer result = NIL;
|
||||||
struct cons_space_object cell = pointer2cell( frame->arg[0] );
|
struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
|
||||||
struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
|
struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
|
||||||
switch ( cell.tag.value ) {
|
switch ( cell->tag.value ) {
|
||||||
case FUNCTIONTV:
|
case FUNCTIONTV:
|
||||||
result = c_assoc( source_key, cell.payload.function.meta );
|
result = c_assoc( source_key, cell->payload.function.meta );
|
||||||
break;
|
break;
|
||||||
case SPECIALTV:
|
case SPECIALTV:
|
||||||
result = c_assoc( source_key, cell.payload.special.meta );
|
result = c_assoc( source_key, cell->payload.special.meta );
|
||||||
break;
|
break;
|
||||||
case LAMBDATV:
|
case LAMBDATV:
|
||||||
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
|
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
|
||||||
make_cons( cell.payload.lambda.args,
|
make_cons( cell->payload.lambda.args,
|
||||||
cell.payload.lambda.body ) );
|
cell->payload.lambda.body ) );
|
||||||
break;
|
break;
|
||||||
case NLAMBDATV:
|
case NLAMBDATV:
|
||||||
result = make_cons( c_string_to_lisp_symbol( L"nlambda" ),
|
result = make_cons( c_string_to_lisp_symbol( L"nlambda" ),
|
||||||
make_cons( cell.payload.lambda.args,
|
make_cons( cell->payload.lambda.args,
|
||||||
cell.payload.lambda.body ) );
|
cell->payload.lambda.body ) );
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
// \todo suffers from premature GC, and I can't see why!
|
// \todo suffers from premature GC, and I can't see why!
|
||||||
|
|
@ -1460,7 +1615,8 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
|
||||||
c_append( c_cdr( l1 ), l2 ) );
|
c_append( c_cdr( l1 ), l2 ) );
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Can't append: not same type" ), NIL );
|
( L"Can't append: not same type" ), NIL );
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
|
|
@ -1482,12 +1638,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
|
||||||
pointer2cell( l1 ).tag.value );
|
pointer2cell( l1 ).tag.value );
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Can't append: not same type" ), NIL );
|
( L"Can't append: not same type" ), NIL );
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"append" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Can't append: not a sequence" ), NIL );
|
( L"Can't append: not a sequence" ), NIL );
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
@ -1519,7 +1677,6 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame,
|
||||||
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
|
for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) {
|
||||||
struct cons_pointer expr =
|
struct cons_pointer expr =
|
||||||
make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) );
|
make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) );
|
||||||
inc_ref( expr );
|
|
||||||
|
|
||||||
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
|
debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i );
|
||||||
debug_print_object( expr, DEBUG_EVAL );
|
debug_print_object( expr, DEBUG_EVAL );
|
||||||
|
|
@ -1599,7 +1756,8 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
|
||||||
bindings = make_cons( make_cons( symbol, val ), bindings );
|
bindings = make_cons( make_cons( symbol, val ), bindings );
|
||||||
} else {
|
} else {
|
||||||
result =
|
result =
|
||||||
throw_exception( c_string_to_lisp_string
|
throw_exception( c_string_to_lisp_symbol( L"let" ),
|
||||||
|
c_string_to_lisp_string
|
||||||
( L"Let: cannot bind, not a symbol" ),
|
( L"Let: cannot bind, not a symbol" ),
|
||||||
frame_pointer );
|
frame_pointer );
|
||||||
break;
|
break;
|
||||||
|
|
|
||||||
|
|
@ -131,6 +131,9 @@ 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 );
|
||||||
|
|
@ -187,13 +190,19 @@ 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 message,
|
struct cons_pointer throw_exception( struct cons_pointer location,
|
||||||
|
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,
|
||||||
|
|
|
||||||
|
|
@ -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-SNAPSHOT"
|
#define VERSION "0.0.6"
|
||||||
|
|
|
||||||
|
|
@ -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 2>/dev/null | tail -1`
|
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | 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
|
||||||
|
|
||||||
echo -n "$0: let with two bindings, two forms in body..."
|
|
||||||
expected='1'
|
expected='1'
|
||||||
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -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..."
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
|
||||||
108
unit-tests/memberp.sh
Normal file
108
unit-tests/memberp.sh
Normal file
|
|
@ -0,0 +1,108 @@
|
||||||
|
#!/bin/bash
|
||||||
|
|
||||||
|
result=0
|
||||||
|
|
||||||
|
expected='t'
|
||||||
|
output=`target/psse $1 <<EOF
|
||||||
|
(progn
|
||||||
|
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
||||||
|
(set! member?
|
||||||
|
(lambda
|
||||||
|
(item collection)
|
||||||
|
(cond
|
||||||
|
((nil? collection) nil)
|
||||||
|
((= item (car collection)) t)
|
||||||
|
(t (member? item (cdr collection))))))
|
||||||
|
(member? 1 '(1 2 3 4)))
|
||||||
|
EOF`
|
||||||
|
actual=`echo $output | tail -1`
|
||||||
|
|
||||||
|
echo -n "$0 $1: (member? 1 '(1 2 3 4))... "
|
||||||
|
|
||||||
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
then
|
||||||
|
echo "OK"
|
||||||
|
else
|
||||||
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
|
result=`echo "${result} + 1" | bc`
|
||||||
|
fi
|
||||||
|
|
||||||
|
expected='t'
|
||||||
|
output=`target/psse $1 <<EOF
|
||||||
|
(progn
|
||||||
|
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
||||||
|
(set! member?
|
||||||
|
(lambda
|
||||||
|
(item collection)
|
||||||
|
(cond
|
||||||
|
((nil? collection) nil)
|
||||||
|
((= item (car collection)) t)
|
||||||
|
(t (member? item (cdr collection))))))
|
||||||
|
(member? 4 '(1 2 3 4)))
|
||||||
|
EOF`
|
||||||
|
actual=`echo $output | tail -1`
|
||||||
|
|
||||||
|
echo -n "$0: (member? 4 '(1 2 3 4))... "
|
||||||
|
|
||||||
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
then
|
||||||
|
echo "OK"
|
||||||
|
else
|
||||||
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
|
result=`echo "${result} + 1" | bc`
|
||||||
|
fi
|
||||||
|
|
||||||
|
|
||||||
|
expected='nil'
|
||||||
|
output=`target/psse $1 <<EOF
|
||||||
|
(progn
|
||||||
|
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
||||||
|
(set! member?
|
||||||
|
(lambda
|
||||||
|
(item collection)
|
||||||
|
;; (progn (print (list "In member; collection is:" collection)) (println))
|
||||||
|
(cond
|
||||||
|
((nil? collection) nil)
|
||||||
|
((= item (car collection)) t)
|
||||||
|
(t (member? item (cdr collection))))))
|
||||||
|
(member? 5 '(1 2 3 4)))
|
||||||
|
EOF`
|
||||||
|
actual=`echo $output | tail -1`
|
||||||
|
|
||||||
|
echo -n "$0: (member? 5 '(1 2 3 4))... "
|
||||||
|
|
||||||
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
then
|
||||||
|
echo "OK"
|
||||||
|
else
|
||||||
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
|
result=`echo "${result} + 1" | bc`
|
||||||
|
fi
|
||||||
|
|
||||||
|
expected='nil'
|
||||||
|
output=`target/psse $1 -s100<<EOF
|
||||||
|
(progn
|
||||||
|
(set! nil? (lambda (o) (= (type o) "NIL ")))
|
||||||
|
(set! member?
|
||||||
|
(lambda
|
||||||
|
(item collection)
|
||||||
|
;; (print (list "in member?: " 'item item 'collection collection) *log*)(println *log*)
|
||||||
|
(cond
|
||||||
|
((nil? collection) nil)
|
||||||
|
((= item (car collection)) t)
|
||||||
|
(t (member? item (cdr collection))))))
|
||||||
|
(member? 5 '(1 2 3 4)))
|
||||||
|
EOF`
|
||||||
|
actual=`echo $output | tail -1`
|
||||||
|
|
||||||
|
echo -n "$0: (member? 5 '(1 2 3 4)) with stack limit... "
|
||||||
|
|
||||||
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
then
|
||||||
|
echo "OK"
|
||||||
|
else
|
||||||
|
echo "Fail: expected '${expected}', got '${actual}'"
|
||||||
|
result=`echo "${result} + 1" | bc`
|
||||||
|
fi
|
||||||
|
|
||||||
|
exit $result
|
||||||
|
|
@ -4,7 +4,7 @@ result=0
|
||||||
|
|
||||||
echo -n "$0: progn with one form... "
|
echo -n "$0: progn with one form... "
|
||||||
expected='5'
|
expected='5'
|
||||||
actual=`echo "(progn (add 2 3))" | target/psse 2>/dev/null | tail -1`
|
actual=`echo "(progn (add 2 3))" | target/psse | 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 2>/dev/null | tail -1`
|
actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
then
|
then
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
#!/bin/bash
|
#!/bin/bash
|
||||||
|
|
||||||
expected='nil 3,628,800'
|
expected='nil 3,628,800'
|
||||||
output=`target/psse 2>/dev/null <<EOF
|
output=`target/psse <<EOF
|
||||||
(progn
|
(progn
|
||||||
(set! fact
|
(set! fact
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
|
|
|
||||||
|
|
@ -40,7 +40,7 @@ else
|
||||||
fi
|
fi
|
||||||
|
|
||||||
echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
|
echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
|
||||||
expected='Exception: "Cannot divide: not a number"'
|
expected='Exception: ((:location . /) (:payload . "Cannot divide: not a number"))'
|
||||||
actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
|
actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
|
||||||
|
|
||||||
if [ "${expected}" = "${actual}" ]
|
if [ "${expected}" = "${actual}" ]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue