Very, very nearly ready for 0.0.6. Too tired to press the burron tonight.
This commit is contained in:
parent
b720211b7b
commit
1900bca706
29 changed files with 567 additions and 800 deletions
1
CHANGELOG.md
Symbolic link
1
CHANGELOG.md
Symbolic link
|
|
@ -0,0 +1 @@
|
|||
docs/CHANGELOG.md
|
||||
395
README.md
395
README.md
|
|
@ -1,395 +0,0 @@
|
|||
# Post Scarcity Software System, version 0
|
||||
|
||||
tl,dr: look at the [wiki](wiki).
|
||||
|
||||
## State of play
|
||||
|
||||
### Version 0.0.5
|
||||
|
||||
Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [#bindings-currently-available](Bindings currently available) below. Features include hash maps.
|
||||
|
||||
#### Known bugs
|
||||
|
||||
At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now.
|
||||
|
||||
There are ludicrous memory leaks. Essentially the garbage collection strategy isn't yet really working. However, if we are to implement the hypercube architecture in future, a mark and sweep garbage collector will not work, so it's important to get the reference counter working properly.
|
||||
|
||||
#### Unknown bugs
|
||||
|
||||
There are certainly MANY unknown bugs. Please report those you find.
|
||||
|
||||
#### Not yet implemented
|
||||
|
||||
1. There is as yet no **compiler**, and indeed it isn't yet certain what a compiler would even mean. Do all nodes in a machine necessarily share the same processor architecture?
|
||||
2. There's the beginnings of a narrative about how **namespaces** are going to work, but as yet they aren't really implemented.
|
||||
3. There is as yet no implementation of the concept of **users**. Access Control Lists exist but are not used. Related, there's no concept of a **session**.
|
||||
4. There is as yet no **multiprocessor architecture**, not even a simulated one. As it is intended that threading will be implemented by handing off parts of a computation to peer processors, this means there no **threads** either.
|
||||
5. There's no **user interface** beyond a REPL. There isn't even an **editor**, or **history**.
|
||||
6. **Printing to strings** does not work.
|
||||
7. The **exception system**, while it does exist, needs to be radically rethought.
|
||||
|
||||
### Version 0.0.4
|
||||
|
||||
Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release!
|
||||
|
||||
## Introduction
|
||||
|
||||
Long ago when the world was young, I worked on Xerox Dandelion and Daybreak machines which ran Interlisp-D, and Acorn Cambridge Workstation and Archimedes machines which ran Cambridge Lisp (derived from Portable Standard Lisp). At the same time, Lisp Machines Inc, Symbolics, Thinking Machines, Texas Instruments and probably various other companies I've either forgotten or didn't know about built other varieties of dedicated Lisp machines which ran Lisp right down to the metal, with no operating system under them. Those machines were not only far superior to any other contemporary machines; they were also far superior to any machines we've built since. But they were expensive, and UNIX machines with the same raw compute power became very much cheaper; and so they died.
|
||||
|
||||
But in the meantime hardware has become vastly more powerful while software has hardly advanced at all. We don't have software which will run efficiently on the machines of the future, we don't have tools to build it, and it often seems to me we're not even thinking about it.
|
||||
|
||||
Ten years ago I wrote [an essay](http://blog.journeyman.cc/2006/02/post-scarcity-software.html) on what software would look like if we treated our computers as though their power was unlimited (which, compared to what we had at the start of my career, it pretty much is); two years ago I wrote about the [hardware architecture](http://blog.journeyman.cc/2014/10/post-scarcity-hardware.html) which might in future support that hardware.
|
||||
|
||||
What I'm trying to do now is write a detailed low level specification of the underpinnings of the software system, and begin a trial implementation. Version 0 will run as a user-space program on UNIX, but very much with the intention that a later version will run on top of either a micro-kernel or perhaps even just a BIOS. However I've no real plans to build post scarcity hardware - I lack the skills. What I'm aiming for is to be able to run on 64 bit, multiple processor hardware.
|
||||
|
||||
Although I describe it as a 'Lisp environment', for reasons explained in Post Scarcity Software that doesn't mean you will program it in Lisp. It means that the underlying representation of things in the system is Lispy, not Unixy.
|
||||
|
||||
## Bindings currently available
|
||||
|
||||
The following symbols are bound in the bootstrap layer. It is anticipated that
|
||||
|
||||
1. Most of the functions will be overridden by versions of the same function written in Lisp; but
|
||||
2. these implementations will remain available in the namespace `/:bootstrap`.
|
||||
|
||||
### Values
|
||||
|
||||
Note that symbols delimited by asterisks, as in `*in*`, invite rebinding; it is expected, for example, that users will want to rebind input and output streams in their current environment. Rebinding some other symbols, for example `nil`, is unwise.
|
||||
|
||||
#### nil
|
||||
|
||||
The canonical empty list.
|
||||
|
||||
#### t
|
||||
|
||||
The canonical true value.
|
||||
|
||||
#### \*in\*
|
||||
|
||||
The input stream.
|
||||
|
||||
#### \*out\*
|
||||
|
||||
The output stream.
|
||||
|
||||
#### \*log\*
|
||||
|
||||
The logging stream (equivalent to `stderr`).
|
||||
|
||||
#### \*sink\*
|
||||
|
||||
The sink stream (equivalent to `/dev/null`).
|
||||
|
||||
#### \*prompt\*
|
||||
|
||||
The REPL prompt.
|
||||
|
||||
### Functions
|
||||
|
||||
#### (absolute *n*)
|
||||
|
||||
Return the absolute value of a number.
|
||||
|
||||
#### (add *n1* *n2* ...), (+ *n1* *n2* ...)
|
||||
|
||||
Return the result of adding together all the (assumed numeric) arguments supplied.
|
||||
|
||||
#### (append *s1* *s2* ...)
|
||||
|
||||
Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2* and so on for an indefinite number of arguments. All arguments must be sequences of the same type.
|
||||
|
||||
#### (apply *f* *s*)
|
||||
|
||||
Apply the function *f* to the arguments that form the sequence *s*, and return the result.
|
||||
|
||||
#### (assoc *key* *store*)
|
||||
|
||||
Return the value associated with *key* in *store*. *key* may be an object of any type, but keywords, symbols and strings are handled most efficiently. *store* may be an [*association list*](#Association_list), or may be a hashmap.
|
||||
|
||||
#### (car *s*)
|
||||
|
||||
Return the first element of the sequence *s*.
|
||||
|
||||
#### (cdr *s*)
|
||||
|
||||
Return a sequence of all the elements of the sequence *s* except the first.
|
||||
|
||||
#### (close *stream*)
|
||||
|
||||
Closes the indicates stream. Returns `nil`.
|
||||
|
||||
#### (cons *a* *b*)
|
||||
|
||||
Returns a new pair comprising *a* and *b*. If *b* is a list, this has the effect of creating a new list with the element *a* prepended to all the elements of *b*. If *b* is `nil`, this has the effect creating a new list with *a* as the sole element. Otherwise, it just creates a pair.
|
||||
|
||||
#### (divide *n1* *n2*), (/ *n1* *n2*)
|
||||
|
||||
Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, it's likely that the result will be a rational number.
|
||||
|
||||
#### (eq *o1* *o2*)
|
||||
|
||||
Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`.
|
||||
|
||||
#### (equal *o1* *o2*), (= *o1* *o2*)
|
||||
|
||||
Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`.
|
||||
|
||||
#### (exception *message*)
|
||||
|
||||
Throws (returns) an exception, with the specified *message*. Note that this doesn't really work at all well, and that it is extremely likely this signature will change.
|
||||
|
||||
#### (get-hash *key* *hashmap*)
|
||||
|
||||
Like 'assoc', but the store must be a hashmap. Deprecated.
|
||||
|
||||
#### (hashmap *n* *f* *store*)
|
||||
|
||||
Create a hashmap with *n* buckets, using *f* as its hashing function, and initialised with the key/value pairs from *store*. All arguments are optional; if none are passed, will create an empty hashmap with 32 keys and the default hashing function.
|
||||
|
||||
#### (inspect *o*)
|
||||
|
||||
Prints detailed structure of the object *o*. Primarily for debugging.
|
||||
|
||||
#### (keys *store*)
|
||||
|
||||
Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap.
|
||||
|
||||
#### (let *bindings* *form*...)
|
||||
|
||||
Evaluates each of the *forms* in an environment to which ally of these *bindings* have been added. *bindings* must be an [*association list*](#Association_list), and, additionally, all keys in *bindings* must be symbols. Values in the association list will be evaluated before being bound, and this is done sequentially, as in the behaviour of Common Lisp `let*` rather than of Common Lisp `let`.
|
||||
|
||||
#### (list *o*...)
|
||||
|
||||
Returns a list of the values of all of its arguments in sequence.
|
||||
|
||||
#### (mapcar *f* *s*)
|
||||
|
||||
Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results.
|
||||
|
||||
#### (meta *o*), (metadata *o*)
|
||||
|
||||
Returns metadata on *o*.
|
||||
|
||||
#### (multiply *n1* *n2* ...), (\* *n1* *n2* ...)
|
||||
|
||||
Returns the product of multiplying together all of its numeric arguments.
|
||||
|
||||
#### (negative? n1)
|
||||
|
||||
Returns `t` if its argument is a negative number, else `nil`.
|
||||
|
||||
#### (oblist)
|
||||
|
||||
Returns a sequence of all the names bound in the root of the naming system.
|
||||
|
||||
#### (open *url* *read?*)
|
||||
|
||||
Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing.
|
||||
|
||||
#### (print *o* [*stream*])
|
||||
|
||||
Prints the print-name of object *o* to the output stream which is the value of *stream*, or to the value of \*out\* in the current environment if no *stream* is provided.
|
||||
|
||||
#### (put! *map* *key* *value*)
|
||||
|
||||
Puts *value* as the value of *key* in hashmap *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map.
|
||||
|
||||
#### (put-all! *map* *assoc*)
|
||||
|
||||
Puts each (+key* . *value*) pair from the association list *assoc* into this *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map.
|
||||
|
||||
#### (read [*stream*])
|
||||
|
||||
Reads a single Lisp form from the input stream which is the value of *stream*, or from the value of \*in\* in the current environment if no *stream* is provided.
|
||||
|
||||
#### (read-char [*stream*])
|
||||
|
||||
Return the next character from the stream indicated by *stream*, or from the value of \*in\* in the current environment if no *stream* is provided; further arguments are ignored.
|
||||
|
||||
#### (repl [*prompt* *input* *output*))
|
||||
|
||||
Initiate a new Read/Eval/Print loop with this *prompt*, reading from this *input* stream and writing to this *output* stream. All arguments are optional and default sensibly if omitted. TODO: doesn't actually work yet.
|
||||
|
||||
#### (reverse *seq*)
|
||||
|
||||
Return a new sequence of the same type as *seq*, containing the same elements but in the reverse order.
|
||||
|
||||
#### (slurp *in*)
|
||||
|
||||
Reads all available characters on input stream *in* into a string, and returns the string.
|
||||
|
||||
#### (source *fn*)
|
||||
|
||||
Should return the source code of the function or special form *fn*, but as we don't yet
|
||||
have a compiler, doesn't.
|
||||
|
||||
#### (subtract *n1* *n2*), (- *n1* *n2*)
|
||||
|
||||
Subtracts the numeric value *n2* from the numeric value *n1*, and returns the difference.
|
||||
|
||||
#### (throw *message*)
|
||||
|
||||
Throws an exception, with the payload *message*. While *message* is at present most usefully a string, it doesn't have to be. Returns the exception, but as exceptions are handled specially by `eval`, it is returned to the catch block of the nearest `try` expression on the stack.
|
||||
|
||||
#### (time [*milliseconds-since-epoch*])
|
||||
|
||||
Returns a time object whose value is the specified number of *milliseconds-since-epoch*, where the Post Scarcity Software Environment epoch is 14 billion years prior to the UN*X epoch. If *milliseconds-since-epoch* is not specified, returns a time object representing the UTC time when the function was executed.
|
||||
|
||||
#### (type *o*)
|
||||
|
||||
Returns a string representing the type -- actually the tag value -- of the object *o*.
|
||||
|
||||
### Special forms
|
||||
|
||||
#### (cond (test value) ...)
|
||||
|
||||
Evaluates a series of *(test value)* clauses in turn until a test returns non-nil, when the corresponding value is returned and further tests are not evaluated. This is the same syntax as Common Lisp's `cond` implementation, and different from Clojure's.
|
||||
|
||||
It's conventional in Lisp to have a final clause in a `cond` block with the test `t`; however, since we have keywords which are always truthy, it would be equally valid to use `:else` or `:default` as final fallback tests.
|
||||
|
||||
#### (lambda (arg ...) form ...), (λ (arg ...) form ...)
|
||||
|
||||
Returns an anonymous fuction which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form.
|
||||
|
||||
#### (let ((*var* . *val*) ...) form ...)
|
||||
|
||||
Evaluates each of these *form*s sequentially in an environment in which each *var* is bound to the respective *val* in the bindings specified, and returns the value of the last form.
|
||||
|
||||
#### (nlambda (arg ...) form ...), (nλ (arg ...) form ...)
|
||||
|
||||
Returns an anonymous special form which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form.
|
||||
|
||||
#### (progn *f* ...)
|
||||
|
||||
Evaluates each of the forms which are its arguments in turn and returns the value of the last.
|
||||
|
||||
#### (quote *o*), '*o*
|
||||
|
||||
Returns *o*, unevaluated.
|
||||
|
||||
#### (set! *name* *value* [*namespace*])
|
||||
|
||||
Sets (destructively modifies) the value of *name* this *value* in the root namespace. The *namespace* argument is currently ignored but in future is anticipated to be a path specification of a namespace to be modified.
|
||||
|
||||
#### (try (*form* ...) (*handler* ...))
|
||||
|
||||
Attempt to evaluate, sequentially, each of the *form*s in the first sequence, and return the value of the last of them; however, if any of them cause an exception to be thrown, then evaluate sequentially each of the *handler*s in the second sequence.
|
||||
|
||||
It is recommended that you structure this as follows:
|
||||
|
||||
`lisp
|
||||
(try
|
||||
(:body
|
||||
(print "hello")
|
||||
(/ 1 'a)
|
||||
(print "goodbye"))
|
||||
(:catch
|
||||
(print "Well, that failed.")
|
||||
5))
|
||||
`
|
||||
|
||||
Here, `:body` and `:catch` are syntactic sugar which will not affect the final value.
|
||||
|
||||
### Type values
|
||||
|
||||
The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*.
|
||||
|
||||
#### CONS
|
||||
|
||||
An ordinary cons cell: that is to say, a pair.
|
||||
|
||||
#### EXEP
|
||||
|
||||
An exception
|
||||
|
||||
#### FREE
|
||||
|
||||
An unallocated memory cell. User programs should never see this.
|
||||
|
||||
#### FUNC
|
||||
|
||||
A primitive or compiled Lisp function \-- one whose arguments are pre-evaluated.
|
||||
|
||||
#### HASH
|
||||
|
||||
A hash map (in vector space)
|
||||
|
||||
#### INTR
|
||||
|
||||
An arbitrarily large integer number.
|
||||
|
||||
#### KEYW
|
||||
|
||||
A keyword - an interned, self-evaluating string.
|
||||
|
||||
#### LMBA
|
||||
|
||||
A lambda cell. Lambdas are the interpretable (source) versions of functions.
|
||||
|
||||
#### LOOP
|
||||
|
||||
Internal to the workings of the ••loop** function. User functions should never see this.
|
||||
|
||||
#### NIL
|
||||
|
||||
The special cons cell at address {0,0} whose **car** and **cdr** both point to itself. The canonical empty set. Generally, treated as being indicative of falsity.
|
||||
|
||||
#### NLMD
|
||||
|
||||
An nlambda cell. NLambdas are the interpretable (source) versions of special forms.
|
||||
|
||||
#### RTIO
|
||||
|
||||
A rational number, stored as pointers two integers representing dividend and divisor respectively.
|
||||
|
||||
#### READ
|
||||
|
||||
An open read stream.
|
||||
|
||||
#### REAL
|
||||
|
||||
A real number, represented internally as an IEEE 754-2008 `binary64`.
|
||||
|
||||
#### SPFM
|
||||
|
||||
A compiled or primitive special form - one whose arguments are not pre-evaluated but passed as provided.
|
||||
|
||||
#### STAK
|
||||
|
||||
A stack frame. In vector space.
|
||||
|
||||
#### STRG
|
||||
|
||||
A string of [UTF-32](https://en.wikipedia.org/wiki/UTF-32) characters, stored as a linked list. Self evaluating.
|
||||
|
||||
#### SYMB
|
||||
|
||||
A symbol is just like a string except not self-evaluating. Later, there may be some restrictions on what characters are legal in a symbol, but at present there are not.
|
||||
|
||||
#### TIME
|
||||
|
||||
A time stamp. The epoch for the Post Scarcity Software Environment is 14 billion years before the UN*X epoch, and is chosen as being a reasonable estimate for the birth of the universe, and thus of the start of time.
|
||||
|
||||
#### TRUE
|
||||
|
||||
The special cell at address {0,1} which is canonically different from NIL.
|
||||
|
||||
#### VECP
|
||||
|
||||
A pointer to an object in vector space. User functions shouldn't see this, they should see the type of the vector-space object indicated.
|
||||
|
||||
#### VECT
|
||||
|
||||
A vector of objects. In vector space.
|
||||
|
||||
#### WRIT
|
||||
|
||||
An open write stream.
|
||||
|
||||
|
||||
|
||||
## License
|
||||
|
||||
Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc)
|
||||
|
||||
Distributed under the terms of the
|
||||
[GNU General Public License v2](http://www.gnu.org/licenses/gpl-2.0.html)
|
||||
1
README.md
Symbolic link
1
README.md
Symbolic link
|
|
@ -0,0 +1 @@
|
|||
docs/Home.md
|
||||
12
docs/Home.md
12
docs/Home.md
|
|
@ -91,7 +91,7 @@ The following functions are provided as of release 0.0.6:
|
|||
| car | FUNC | `(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence. |
|
||||
| cdr | FUNC | `(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed. |
|
||||
| close | FUNC | `(close stream)`: If `stream` is a stream, close that stream. |
|
||||
| cond | SPFM | null |
|
||||
| cond | SPFM | `(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated. |
|
||||
| cons | FUNC | `(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`. |
|
||||
| count | FUNC | `(count s)`: Return the number of items in the sequence `s`. |
|
||||
| divide | FUNC | `(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`. |
|
||||
|
|
@ -103,7 +103,7 @@ The following functions are provided as of release 0.0.6:
|
|||
| hashmap | FUNC | `(hashmap n-buckets hashfn store write-acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`, and protected by the write access control list `write-acl`. All arguments are optional. The intended difference between a namespace and a hashmap is that a namespace has a write acl and a hashmap doesn't (is not writable), but currently (0.0.6) this functionality is not yet written. |
|
||||
| inspect | FUNC | `(inspect object ouput-stream)`: Print details of this `object` to this `output-stream`, or `*out*` if no `output-stream` is specified. |
|
||||
| keys | FUNC | `(keys store)`: Return a list of all keys in this `store`. |
|
||||
| lambda | SPFM | `(lamda arg-list forms...)`: Construct an interpretable λ funtion. |
|
||||
| lambda | SPFM | `(lambda arg-list forms...)`: Construct an interpretable λ funtion. |
|
||||
| let | SPFM | `(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last. |
|
||||
| list | FUNC | `(list args...)`: Return a list of these `args`. |
|
||||
| mapcar | FUNC | `(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results. |
|
||||
|
|
@ -120,15 +120,15 @@ The following functions are provided as of release 0.0.6:
|
|||
| print | FUNC | `(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`. |
|
||||
| progn | SPFM | `(progn forms...)`: Evaluate these `forms` sequentially, and return the value of the last. |
|
||||
| put! | FUNC | `(put! store key value)`: Stores a value in a namespace; currently (0.0.6), also stores a value in a hashmap, but in future if the `store` is a hashmap then `put!` will return a clone of that hashmap with this `key value` pair added. Expects `store` to be a hashmap or namespace; `key` to be a symbol or a keyword; `value` to be any value. |
|
||||
| put-all! | FUNC | `(put-all! store1 store2)`: If `store1` is a namespace and is writable, copies all key-value pairs from `store2` into `store1`. At present (0.0.6) it does this for hashmaps as well, but in future if `store1` is a hashmap or an namespace which the user does not have permission to write, will return a copy of `store1` with all the key-value pairs from `store2` added. `store1` must be a hashmap or a namespace; `store2` may be either of those or an association list. |
|
||||
| quote | SPFM | `(quote form)`: Returns `form`, unevaluated. More normally expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`. |
|
||||
| put-all! | FUNC | `(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`. At present (0.0.6) it does this for hashmaps as well, but in future if `dest` is a hashmap or a namespace which the user does not have permission to write, will return a copy of `dest` with all the key-value pairs from `source` added. `dest` must be a hashmap or a namespace; `source` may be either of those or an association list. |
|
||||
| quote | SPFM | `(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`. |
|
||||
| ratio->real | FUNC | `(ratio->real r)`: If `r` is a rational number, return the real number equivalent. |
|
||||
| read | FUNC | `(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
|
||||
| read-char | FUNC | `(read-char stream)`: Return the next character from the stream indicated by `stream`. |
|
||||
| read-char | FUNC | `(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment. |
|
||||
| repl | FUNC | `(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional. If `prompt` is present, it will be used as the prompt. If `input` is present and is a readable stream, takes input from that stream. If `output` is present and is a writable stream, prints output to that stream. |
|
||||
| reverse | FUNC | `(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order. |
|
||||
| set | FUNC | null |
|
||||
| set! | SPFM | null |
|
||||
| set! | SPFM | `(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace. |
|
||||
| slurp | FUNC | `(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string. |
|
||||
| source | FUNC | `(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil. Once we get a compiler working, will also return the source code of compiled functions and special forms. |
|
||||
| subtract | FUNC | `(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers. |
|
||||
|
|
|
|||
|
|
@ -2,13 +2,7 @@
|
|||
|
||||
(set! defun!
|
||||
(nlambda
|
||||
form
|
||||
(cond ((symbol? (car form))
|
||||
(set (car form) (apply 'lambda (cdr form))))
|
||||
(t nil))))
|
||||
|
||||
(set! defun!
|
||||
(nlambda
|
||||
"`(defun name arg-list forms...)`: Define an interpreted Lambda function with this `name` and this `arg-list`, whose body is comprised of these `forms`."
|
||||
form
|
||||
(eval (list 'set! (car form) (cons 'lambda (cdr form))))))
|
||||
|
||||
|
|
@ -20,7 +14,7 @@
|
|||
(cond (symbol? (car form))
|
||||
(set! (car form) (apply nlambda (cdr form))))))
|
||||
|
||||
(defsp! cube (x) ((* x x x)))
|
||||
(defun! cube (x) (* x x x))
|
||||
|
||||
(set! p 5)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,20 +1,17 @@
|
|||
;; This version segfaults, I think due to a bug in `let`?
|
||||
;; (set! documentation (lambda (object)
|
||||
;; (cond ((= (type object) "LMDA")
|
||||
;; (let ((d . (nth 3 (source object))))
|
||||
;; (cond ((string? d) d)
|
||||
;; (t (source object)))))
|
||||
;; ((member (type object) '("FUNC" "SPFM"))
|
||||
;; (:documentation (meta object))))))
|
||||
;;
|
||||
;; (set! doc documentation)
|
||||
;; This function depends on:
|
||||
;; `member` (from file `member.lisp`)
|
||||
;; `nth` (from `nth.lisp`)
|
||||
;; `string?` (from `types.lisp`)
|
||||
|
||||
(set! documentation (lambda (object)
|
||||
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
||||
(cond ((member? (type object) '("FUNC" "SPFM"))
|
||||
(:documentation (meta object)))
|
||||
((member? (type object) '("LMDA" "NLMD"))
|
||||
(let ((d . (nth 3 (source object))))
|
||||
(cond ((string? d) d)
|
||||
(t (source object)))))
|
||||
(t object))))
|
||||
|
||||
(set! doc documentation)
|
||||
|
||||
;; This version returns nil even when documentation exists, but doesn't segfault.
|
||||
(set! documentation
|
||||
(lambda (object)
|
||||
"`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
|
||||
(cond ((and (member (type object) '("LMDA" "NLMD"))
|
||||
(string? (nth 3 (source object))))
|
||||
(nth 3 (source object)))
|
||||
((member (type object) '("FUNC" "SPFM"))
|
||||
(:documentation (meta object))))))
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@
|
|||
"`(nil? object)`: Return `t` if object is `nil`, else `t`."
|
||||
(= o nil)))
|
||||
|
||||
(set! member (lambda
|
||||
(set! member? (lambda
|
||||
(item collection)
|
||||
"`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
|
||||
(cond
|
||||
((nil? collection) nil)
|
||||
((= item (car collection)) t)
|
||||
(t (member item (cdr collection))))))
|
||||
(t (member? item (cdr collection))))))
|
||||
|
||||
(member (type member) '("LMDA" "NLMD"))
|
||||
;; (member? (type member?) '("LMDA" "NLMD"))
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ I have blogged a lot in the past about madness and about software, but I don't t
|
|||
|
||||
I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not.
|
||||
|
||||
I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works.
|
||||
|
||||
As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind.
|
||||
I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it wo
|
||||
As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helprks.
|
||||
s subdue the chaos in my mind.
|
||||
|
||||
Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is:
|
||||
|
||||
|
|
|
|||
|
|
@ -126,17 +126,18 @@ struct cons_pointer absolute( struct cons_pointer arg ) {
|
|||
struct cons_pointer result = NIL;
|
||||
struct cons_space_object cell = pointer2cell( arg );
|
||||
|
||||
if ( numberp( arg)) {
|
||||
if ( numberp( arg ) ) {
|
||||
if ( is_negative( arg ) ) {
|
||||
switch ( cell.tag.value ) {
|
||||
case INTEGERTV:
|
||||
result =
|
||||
make_integer( llabs( cell.payload.integer.value ),
|
||||
cell.payload.integer.more );
|
||||
cell.payload.integer.more );
|
||||
break;
|
||||
case RATIOTV:
|
||||
result = make_ratio( absolute( cell.payload.ratio.dividend ),
|
||||
cell.payload.ratio.divisor, false );
|
||||
result =
|
||||
make_ratio( absolute( cell.payload.ratio.dividend ),
|
||||
cell.payload.ratio.divisor, false );
|
||||
break;
|
||||
case REALTV:
|
||||
result = make_real( 0 - cell.payload.real.value );
|
||||
|
|
@ -606,7 +607,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
case RATIOTV:{
|
||||
struct cons_pointer tmp = make_ratio( arg1,
|
||||
make_integer( 1,
|
||||
NIL ), false );
|
||||
NIL ),
|
||||
false );
|
||||
inc_ref( tmp );
|
||||
result = subtract_ratio_ratio( tmp, arg2 );
|
||||
dec_ref( tmp );
|
||||
|
|
@ -632,7 +634,8 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
|
|||
case INTEGERTV:{
|
||||
struct cons_pointer tmp = make_ratio( arg2,
|
||||
make_integer( 1,
|
||||
NIL ), false );
|
||||
NIL ),
|
||||
false );
|
||||
inc_ref( tmp );
|
||||
result = subtract_ratio_ratio( arg1, tmp );
|
||||
dec_ref( tmp );
|
||||
|
|
@ -711,8 +714,7 @@ struct cons_pointer lisp_divide( struct
|
|||
break;
|
||||
case INTEGERTV:{
|
||||
result =
|
||||
make_ratio( frame->arg[0],
|
||||
frame->arg[1], true);
|
||||
make_ratio( frame->arg[0], frame->arg[1], true );
|
||||
}
|
||||
break;
|
||||
case RATIOTV:{
|
||||
|
|
@ -744,8 +746,8 @@ struct cons_pointer lisp_divide( struct
|
|||
case INTEGERTV:{
|
||||
struct cons_pointer one = make_integer( 1, NIL );
|
||||
struct cons_pointer ratio =
|
||||
make_ratio( frame->arg[1], one, false);
|
||||
result = divide_ratio_ratio( frame->arg[0], ratio );
|
||||
make_ratio( frame->arg[1], one, false );
|
||||
result = divide_ratio_ratio( frame->arg[0], ratio );
|
||||
dec_ref( ratio );
|
||||
dec_ref( one );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -72,7 +72,8 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
|
|||
ddrv, drrv, ddrv / gcd, drrv / gcd );
|
||||
result =
|
||||
make_ratio( acquire_integer( ddrv / gcd, NIL ),
|
||||
acquire_integer( drrv / gcd, NIL ), false);
|
||||
acquire_integer( drrv / gcd, NIL ),
|
||||
false );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -182,8 +183,8 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
|
|||
// TODO: this now has to work if `arg1` is an integer
|
||||
struct cons_pointer i =
|
||||
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
|
||||
pointer2cell( arg2 ).payload.ratio.dividend, false ), result =
|
||||
multiply_ratio_ratio( arg1, i );
|
||||
pointer2cell( arg2 ).payload.ratio.dividend, false ),
|
||||
result = multiply_ratio_ratio( arg1, i );
|
||||
|
||||
dec_ref( i );
|
||||
|
||||
|
|
@ -310,13 +311,12 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
|
|||
* @exception if either `dividend` or `divisor` is not an integer.
|
||||
*/
|
||||
struct cons_pointer make_ratio( struct cons_pointer dividend,
|
||||
struct cons_pointer divisor,
|
||||
bool simplify ) {
|
||||
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC);
|
||||
debug_print_object( dividend, DEBUG_ALLOC);
|
||||
debug_print( L"; divisor = ", DEBUG_ALLOC);
|
||||
debug_print_object( divisor, DEBUG_ALLOC);
|
||||
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify);
|
||||
struct cons_pointer divisor, bool simplify ) {
|
||||
debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC );
|
||||
debug_print_object( dividend, DEBUG_ALLOC );
|
||||
debug_print( L"; divisor = ", DEBUG_ALLOC );
|
||||
debug_print_object( divisor, DEBUG_ALLOC );
|
||||
debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify );
|
||||
|
||||
struct cons_pointer result;
|
||||
if ( integerp( dividend ) && integerp( divisor ) ) {
|
||||
|
|
@ -327,7 +327,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
|
|||
cell->payload.ratio.dividend = dividend;
|
||||
cell->payload.ratio.divisor = divisor;
|
||||
|
||||
if ( simplify) {
|
||||
if ( simplify ) {
|
||||
result = simplify_ratio( unsimplified );
|
||||
if ( !eq( result, unsimplified ) ) {
|
||||
dec_ref( unsimplified );
|
||||
|
|
@ -341,9 +341,9 @@ struct cons_pointer make_ratio( struct cons_pointer dividend,
|
|||
( L"Dividend and divisor of a ratio must be integers" ),
|
||||
NIL );
|
||||
}
|
||||
debug_print( L" => ", DEBUG_ALLOC);
|
||||
debug_print( L" => ", DEBUG_ALLOC );
|
||||
debug_print_object( result, DEBUG_ALLOC );
|
||||
debug_println( DEBUG_ALLOC);
|
||||
debug_println( DEBUG_ALLOC );
|
||||
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -32,8 +32,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
|
|||
struct cons_pointer arg2 );
|
||||
|
||||
struct cons_pointer make_ratio( struct cons_pointer dividend,
|
||||
struct cons_pointer divisor,
|
||||
bool simplify );
|
||||
struct cons_pointer divisor, bool simplify );
|
||||
|
||||
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
|
||||
|
||||
|
|
|
|||
15
src/debug.c
15
src/debug.c
|
|
@ -147,15 +147,16 @@ void debug_dump_object( struct cons_pointer pointer, int level ) {
|
|||
/**
|
||||
* Standardise printing of binding trace messages.
|
||||
*/
|
||||
void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level) {
|
||||
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
|
||||
bool deep, int level ) {
|
||||
#ifdef DEBUG
|
||||
// wchar_t * depth = (deep ? L"Deep" : L"Shallow");
|
||||
|
||||
debug_print( (deep ? L"Deep" : L"Shallow"), level);
|
||||
debug_print( L" binding `", level);
|
||||
debug_print_object( key, level);
|
||||
debug_print( L"` to `", level);
|
||||
debug_print_object( val, level);
|
||||
debug_print( L"`\n", level);
|
||||
debug_print( ( deep ? L"Deep" : L"Shallow" ), level );
|
||||
debug_print( L" binding `", level );
|
||||
debug_print_object( key, level );
|
||||
debug_print( L"` to `", level );
|
||||
debug_print_object( val, level );
|
||||
debug_print( L"`\n", level );
|
||||
#endif
|
||||
}
|
||||
|
|
@ -87,6 +87,7 @@ void debug_println( int level );
|
|||
void debug_printf( int level, wchar_t *format, ... );
|
||||
void debug_print_object( struct cons_pointer pointer, int level );
|
||||
void debug_dump_object( struct cons_pointer pointer, int level );
|
||||
void debug_print_binding( struct cons_pointer key, struct cons_pointer val, bool deep, int level);
|
||||
void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
|
||||
bool deep, int level );
|
||||
|
||||
#endif
|
||||
|
|
|
|||
256
src/init.c
256
src/init.c
|
|
@ -71,8 +71,9 @@ struct cons_pointer init_name_symbol = NIL;
|
|||
struct cons_pointer init_primitive_symbol = NIL;
|
||||
|
||||
void maybe_bind_init_symbols( ) {
|
||||
if ( nilp( init_documentation_symbol)) {
|
||||
init_documentation_symbol = c_string_to_lisp_keyword( L"documentation");
|
||||
if ( nilp( init_documentation_symbol ) ) {
|
||||
init_documentation_symbol =
|
||||
c_string_to_lisp_keyword( L"documentation" );
|
||||
}
|
||||
if ( nilp( init_name_symbol ) ) {
|
||||
init_name_symbol = c_string_to_lisp_keyword( L"name" );
|
||||
|
|
@ -83,15 +84,16 @@ void maybe_bind_init_symbols( ) {
|
|||
if ( nilp( privileged_symbol_nil ) ) {
|
||||
privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
|
||||
}
|
||||
if ( nilp( privileged_string_memory_exhausted)) {
|
||||
if ( nilp( privileged_string_memory_exhausted ) ) {
|
||||
// we can't make this string when we need it, because memory is then
|
||||
// exhausted!
|
||||
privileged_string_memory_exhausted = c_string_to_lisp_string( L"Memory exhausted." );
|
||||
privileged_string_memory_exhausted =
|
||||
c_string_to_lisp_string( L"Memory exhausted." );
|
||||
}
|
||||
}
|
||||
|
||||
void free_init_symbols( ) {
|
||||
dec_ref( init_documentation_symbol);
|
||||
dec_ref( init_documentation_symbol );
|
||||
dec_ref( init_name_symbol );
|
||||
dec_ref( init_primitive_symbol );
|
||||
}
|
||||
|
|
@ -110,12 +112,14 @@ struct cons_pointer bind_function( wchar_t *name,
|
|||
struct cons_pointer,
|
||||
struct cons_pointer ) ) {
|
||||
struct cons_pointer n = c_string_to_lisp_symbol( 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 =
|
||||
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
||||
make_cons( make_cons( init_name_symbol, n ),
|
||||
make_cons( make_cons( init_documentation_symbol, d), NIL) ) );
|
||||
make_cons( make_cons
|
||||
( init_documentation_symbol, d ),
|
||||
NIL ) ) );
|
||||
|
||||
struct cons_pointer r =
|
||||
check_exception( deep_bind( n, make_function( meta, executable ) ),
|
||||
|
|
@ -132,20 +136,26 @@ struct cons_pointer bind_function( wchar_t *name,
|
|||
* this `name` in the `oblist`.
|
||||
*/
|
||||
struct cons_pointer bind_special( wchar_t *name,
|
||||
wchar_t *doc,
|
||||
struct cons_pointer ( *executable )
|
||||
( struct stack_frame *, struct cons_pointer,
|
||||
struct cons_pointer ) ) {
|
||||
struct cons_pointer n = c_string_to_lisp_symbol( name );
|
||||
struct cons_pointer d = c_string_to_lisp_string( doc );
|
||||
|
||||
struct cons_pointer meta =
|
||||
make_cons( make_cons( init_primitive_symbol, TRUE ),
|
||||
make_cons( make_cons( init_name_symbol, n ), NIL ) );
|
||||
make_cons( make_cons( init_name_symbol, n ),
|
||||
make_cons( make_cons
|
||||
( init_documentation_symbol, d ),
|
||||
NIL ) ) );
|
||||
|
||||
struct cons_pointer r =
|
||||
check_exception( deep_bind( n, make_special( meta, executable ) ),
|
||||
"bind_special" );
|
||||
|
||||
dec_ref( n );
|
||||
dec_ref( d );
|
||||
|
||||
return r;
|
||||
}
|
||||
|
|
@ -334,96 +344,179 @@ int main( int argc, char *argv[] ) {
|
|||
/*
|
||||
* primitive function operations
|
||||
*/
|
||||
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
|
||||
* HTTP from an address at journeyman? */
|
||||
/* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
|
||||
* HTTP from an address at journeyman? */
|
||||
bind_function( L"absolute",
|
||||
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
|
||||
&lisp_absolute );
|
||||
L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
|
||||
&lisp_absolute );
|
||||
bind_function( L"add",
|
||||
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
|
||||
&lisp_add );
|
||||
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
|
||||
&lisp_add );
|
||||
bind_function( L"and",
|
||||
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
|
||||
&lisp_and);
|
||||
bind_function( L"append", L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
|
||||
&lisp_append );
|
||||
L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
|
||||
&lisp_and );
|
||||
bind_function( L"append",
|
||||
L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
|
||||
&lisp_append );
|
||||
bind_function( L"apply",
|
||||
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
|
||||
&lisp_apply );
|
||||
L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
|
||||
&lisp_apply );
|
||||
bind_function( L"assoc",
|
||||
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
|
||||
&lisp_assoc );
|
||||
L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
|
||||
&lisp_assoc );
|
||||
bind_function( L"car",
|
||||
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
|
||||
&lisp_car );
|
||||
L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
|
||||
&lisp_car );
|
||||
bind_function( L"cdr",
|
||||
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
|
||||
&lisp_cdr );
|
||||
bind_function( L"close", L"`(close stream)`: If `stream` is a stream, close that stream.", &lisp_close );
|
||||
bind_function( L"cons", L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.", &lisp_cons );
|
||||
bind_function( L"count", L"`(count s)`: Return the number of items in the sequence `s`.", &lisp_count);
|
||||
L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
|
||||
&lisp_cdr );
|
||||
bind_function( L"close",
|
||||
L"`(close stream)`: If `stream` is a stream, close that stream.",
|
||||
&lisp_close );
|
||||
bind_function( L"cons",
|
||||
L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.",
|
||||
&lisp_cons );
|
||||
bind_function( L"count",
|
||||
L"`(count s)`: Return the number of items in the sequence `s`.",
|
||||
&lisp_count );
|
||||
bind_function( L"divide",
|
||||
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
|
||||
&lisp_divide );
|
||||
bind_function( L"eq?", L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.", &lisp_eq );
|
||||
bind_function( L"equal?", L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", &lisp_equal );
|
||||
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
|
||||
&lisp_divide );
|
||||
bind_function( L"eq?",
|
||||
L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.",
|
||||
&lisp_eq );
|
||||
bind_function( L"equal?",
|
||||
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
|
||||
&lisp_equal );
|
||||
bind_function( L"eval", L"", &lisp_eval );
|
||||
bind_function( L"exception", L"`(exception message)`: Return (throw) an exception with this `message`.", &lisp_exception );
|
||||
bind_function( L"get-hash", L"`(get-hash arg)`: returns the natural number hash value of `arg`.", &lisp_get_hash );
|
||||
bind_function( L"exception",
|
||||
L"`(exception message)`: Return (throw) an exception with this `message`.",
|
||||
&lisp_exception );
|
||||
bind_function( L"get-hash",
|
||||
L"`(get-hash arg)`: returns the natural number hash value of `arg`.",
|
||||
&lisp_get_hash );
|
||||
bind_function( L"hashmap",
|
||||
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
|
||||
lisp_make_hashmap );
|
||||
L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
|
||||
lisp_make_hashmap );
|
||||
bind_function( L"inspect",
|
||||
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
|
||||
&lisp_inspect );
|
||||
bind_function( L"keys", L"`(keys store)`: Return a list of all keys in this `store`.", &lisp_keys );
|
||||
bind_function( L"list", L"`(list args...): Return a list of these `args`.", &lisp_list );
|
||||
bind_function( L"mapcar", L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.", &lisp_mapcar );
|
||||
bind_function( L"meta", L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", &lisp_metadata );
|
||||
bind_function( L"metadata", L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", &lisp_metadata );
|
||||
bind_function( L"multiply", L"`(* args...)` Multiply these `args`, all of which should be numbers.", &lisp_multiply );
|
||||
bind_function( L"negative?", L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.", &lisp_is_negative );
|
||||
L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
|
||||
&lisp_inspect );
|
||||
bind_function( L"keys",
|
||||
L"`(keys store)`: Return a list of all keys in this `store`.",
|
||||
&lisp_keys );
|
||||
bind_function( L"list", L"`(list args...): Return a list of these `args`.",
|
||||
&lisp_list );
|
||||
bind_function( L"mapcar",
|
||||
L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
|
||||
&lisp_mapcar );
|
||||
bind_function( L"meta",
|
||||
L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
|
||||
&lisp_metadata );
|
||||
bind_function( L"metadata",
|
||||
L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
|
||||
&lisp_metadata );
|
||||
bind_function( L"multiply",
|
||||
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
|
||||
&lisp_multiply );
|
||||
bind_function( L"negative?",
|
||||
L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.",
|
||||
&lisp_is_negative );
|
||||
bind_function( L"not",
|
||||
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
|
||||
&lisp_not);
|
||||
bind_function( L"oblist", L"`(oblist)`: Return the current symbol bindings, as a map.", &lisp_oblist );
|
||||
bind_function( L"open", L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.", &lisp_open );
|
||||
L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
|
||||
&lisp_not );
|
||||
bind_function( L"oblist",
|
||||
L"`(oblist)`: Return the current symbol bindings, as a map.",
|
||||
&lisp_oblist );
|
||||
bind_function( L"open",
|
||||
L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.",
|
||||
&lisp_open );
|
||||
bind_function( L"or",
|
||||
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
|
||||
&lisp_or);
|
||||
bind_function( L"print", L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.", &lisp_print );
|
||||
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
|
||||
&lisp_or );
|
||||
bind_function( L"print",
|
||||
L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.",
|
||||
&lisp_print );
|
||||
bind_function( L"println",
|
||||
L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
|
||||
&lisp_print );
|
||||
bind_function( L"put!", L"", lisp_hashmap_put );
|
||||
bind_function( L"put-all!", L"", &lisp_hashmap_put_all );
|
||||
bind_function( L"ratio->real", L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.", &lisp_ratio_to_real );
|
||||
bind_function( L"read", L"", &lisp_read );
|
||||
bind_function( L"read-char", L"", &lisp_read_char );
|
||||
bind_function( L"repl", L"", &lisp_repl );
|
||||
bind_function( L"reverse", L"", &lisp_reverse );
|
||||
bind_function( L"put-all!",
|
||||
L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
|
||||
&lisp_hashmap_put_all );
|
||||
bind_function( L"ratio->real",
|
||||
L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.",
|
||||
&lisp_ratio_to_real );
|
||||
bind_function( L"read",
|
||||
L"`(read stream)`: read one complete lisp form and return it. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
|
||||
&lisp_read );
|
||||
bind_function( L"read-char",
|
||||
L"`(read-char stream)`: Return the next character. If `stream` is specified and is a read stream, then read from that stream, else the stream which is the value of `*in*` in the environment.",
|
||||
&lisp_read_char );
|
||||
bind_function( L"repl",
|
||||
L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.",
|
||||
&lisp_repl );
|
||||
bind_function( L"reverse",
|
||||
L"`(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order.",
|
||||
&lisp_reverse );
|
||||
bind_function( L"set", L"", &lisp_set );
|
||||
bind_function( L"slurp", L"", &lisp_slurp );
|
||||
bind_function( L"source", L"", &lisp_source );
|
||||
bind_function( L"subtract", L"", &lisp_subtract );
|
||||
bind_function( L"slurp",
|
||||
L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.",
|
||||
&lisp_slurp );
|
||||
bind_function( L"source",
|
||||
L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.",
|
||||
&lisp_source );
|
||||
bind_function( L"subtract",
|
||||
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
||||
&lisp_subtract );
|
||||
bind_function( L"throw", L"", &lisp_exception );
|
||||
bind_function( L"time", L"", &lisp_time );
|
||||
bind_function( L"type", L"", &lisp_type );
|
||||
bind_function( L"+", L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.", &lisp_add );
|
||||
bind_function( L"*", L"", &lisp_multiply );
|
||||
bind_function( L"-", L"", &lisp_subtract );
|
||||
bind_function( L"/", L"", &lisp_divide );
|
||||
bind_function( L"=", L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", &lisp_equal );
|
||||
bind_function( L"time",
|
||||
L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
|
||||
&lisp_time );
|
||||
bind_function( L"type",
|
||||
L"`(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change.",
|
||||
&lisp_type );
|
||||
bind_function( L"+",
|
||||
L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
|
||||
&lisp_add );
|
||||
bind_function( L"*",
|
||||
L"`(* args...)` Multiply these `args`, all of which should be numbers.",
|
||||
&lisp_multiply );
|
||||
bind_function( L"-",
|
||||
L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
|
||||
&lisp_subtract );
|
||||
bind_function( L"/",
|
||||
L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
|
||||
&lisp_divide );
|
||||
bind_function( L"=",
|
||||
L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
|
||||
&lisp_equal );
|
||||
/*
|
||||
* primitive special forms
|
||||
*/
|
||||
bind_special( L"cond", &lisp_cond );
|
||||
bind_special( L"lambda", &lisp_lambda );
|
||||
bind_special( L"\u03bb", &lisp_lambda ); // λ
|
||||
bind_special( L"let", &lisp_let );
|
||||
bind_special( L"nlambda", &lisp_nlambda );
|
||||
bind_special( L"n\u03bb", &lisp_nlambda );
|
||||
bind_special( L"progn", &lisp_progn );
|
||||
bind_special( L"quote", &lisp_quote );
|
||||
bind_special( L"set!", &lisp_set_shriek );
|
||||
bind_special( L"try", &lisp_try );
|
||||
bind_special( L"cond",
|
||||
L"`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated.",
|
||||
&lisp_cond );
|
||||
bind_special( L"lambda",
|
||||
L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.",
|
||||
&lisp_lambda );
|
||||
bind_special( L"\u03bb", L"", &lisp_lambda ); // λ
|
||||
bind_special( L"let",
|
||||
L"`(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last.",
|
||||
&lisp_let );
|
||||
bind_special( L"nlambda",
|
||||
L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.",
|
||||
&lisp_nlambda );
|
||||
bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ
|
||||
bind_special( L"progn",
|
||||
L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.",
|
||||
&lisp_progn );
|
||||
bind_special( L"quote",
|
||||
L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.",
|
||||
&lisp_quote );
|
||||
bind_special( L"set!",
|
||||
L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
|
||||
&lisp_set_shriek );
|
||||
bind_special( L"try", L"", &lisp_try );
|
||||
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
|
||||
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
|
||||
|
||||
|
|
@ -432,8 +525,9 @@ int main( int argc, char *argv[] ) {
|
|||
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
|
||||
|
||||
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
|
||||
while ( (pointer2cell(oblist)).count > 0) {
|
||||
fprintf( stderr, "Dangling refs on oblist: %d\n", (pointer2cell(oblist)).count );
|
||||
while ( ( pointer2cell( oblist ) ).count > 0 ) {
|
||||
fprintf( stderr, "Dangling refs on oblist: %d\n",
|
||||
( pointer2cell( oblist ) ).count );
|
||||
dec_ref( oblist );
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
if ( readp( frame->arg[0] ) ) {
|
||||
result =
|
||||
make_string( url_fgetwc
|
||||
( pointer2cell( frame->arg[0] ).payload.stream.
|
||||
stream ), NIL );
|
||||
( pointer2cell( frame->arg[0] ).payload.
|
||||
stream.stream ), NIL );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
|
|||
|
|
@ -17,15 +17,17 @@
|
|||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "arith/integer.h"
|
||||
#include "debug.h"
|
||||
#include "io/io.h"
|
||||
#include "io/print.h"
|
||||
#include "memory/conspage.h"
|
||||
#include "memory/consspaceobject.h"
|
||||
#include "memory/hashmap.h"
|
||||
#include "arith/integer.h"
|
||||
#include "ops/intern.h"
|
||||
#include "memory/stack.h"
|
||||
#include "io/print.h"
|
||||
#include "time/psse_time.h"
|
||||
#include "memory/vectorspace.h"
|
||||
#include "ops/intern.h"
|
||||
#include "time/psse_time.h"
|
||||
|
||||
/**
|
||||
* print all the characters in the symbol or string indicated by `pointer`
|
||||
|
|
@ -117,7 +119,7 @@ void print_vso( URL_FILE *output, struct cons_pointer pointer ) {
|
|||
print_map( output, pointer );
|
||||
break;
|
||||
case STACKFRAMETV:
|
||||
dump_stack_trace( output, pointer);
|
||||
dump_stack_trace( output, pointer );
|
||||
break;
|
||||
// \todo: others.
|
||||
default:
|
||||
|
|
@ -251,7 +253,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
|
|||
url_fwprintf( output, L"<Time: " );
|
||||
print_string( output, time_to_string( pointer ) );
|
||||
url_fputws( L"; ", output );
|
||||
print_128bit( output, pointer2cell( pointer ).payload.time.value );
|
||||
print_128bit( output, cell.payload.time.value );
|
||||
url_fputwc( L'>', output );
|
||||
break;
|
||||
case TRUETV:
|
||||
|
|
@ -269,12 +271,95 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
|
|||
fwprintf( stderr,
|
||||
L"Error: Unrecognised tag value %d (%4.4s)\n",
|
||||
cell.tag.value, &cell.tag.bytes[0] );
|
||||
// dump_object( stderr, pointer);
|
||||
break;
|
||||
}
|
||||
|
||||
return pointer;
|
||||
}
|
||||
|
||||
/**
|
||||
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
|
||||
* is a write stream, then print to that stream, else the stream which is the value of
|
||||
* `*out*` in the environment.
|
||||
*
|
||||
* * (print expr)
|
||||
* * (print expr write-stream)
|
||||
*
|
||||
* @param frame my stack_frame.
|
||||
* @param frame_pointer a pointer to my stack_frame.
|
||||
* @param env my environment (from which the stream may be extracted).
|
||||
* @return NIL.
|
||||
*/
|
||||
struct cons_pointer
|
||||
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
debug_print( L"Entering print\n", DEBUG_IO );
|
||||
struct cons_pointer result = NIL;
|
||||
URL_FILE *output;
|
||||
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
|
||||
frame->arg[1] : get_default_stream( false, env );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
|
||||
debug_dump_object( out_stream, DEBUG_IO );
|
||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||
inc_ref( out_stream );
|
||||
} else {
|
||||
output = file_to_url_file( stderr );
|
||||
}
|
||||
|
||||
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
|
||||
debug_dump_object( frame->arg[0], DEBUG_IO );
|
||||
|
||||
result = print( output, frame->arg[0] );
|
||||
|
||||
debug_print( L"lisp_print returning\n", DEBUG_IO );
|
||||
debug_dump_object( result, DEBUG_IO );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
dec_ref( out_stream );
|
||||
} else {
|
||||
free( output );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
void println( URL_FILE *output ) {
|
||||
url_fputws( L"\n", output );
|
||||
}
|
||||
|
||||
/**
|
||||
* @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
|
||||
* it is specified and is an output stream, else to `*out*`.
|
||||
*
|
||||
* @param frame
|
||||
* @param frame_pointer
|
||||
* @param env
|
||||
* @return `nil`
|
||||
*/
|
||||
struct cons_pointer
|
||||
lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
URL_FILE *output;
|
||||
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
|
||||
frame->arg[1] : get_default_stream( false, env );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||
inc_ref( out_stream );
|
||||
} else {
|
||||
output = file_to_url_file( stderr );
|
||||
}
|
||||
|
||||
println( output );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
dec_ref( out_stream );
|
||||
} else {
|
||||
free( output );
|
||||
}
|
||||
|
||||
return NIL;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,4 +19,12 @@
|
|||
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
|
||||
void println( URL_FILE * output );
|
||||
|
||||
struct cons_pointer lisp_print( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer lisp_println( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -370,7 +370,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
|
|||
( to_long_double
|
||||
( base ),
|
||||
places_of_decimals ),
|
||||
NIL ), true);
|
||||
NIL ), true );
|
||||
inc_ref( div );
|
||||
|
||||
result = make_real( to_long_double( div ) );
|
||||
|
|
|
|||
|
|
@ -132,11 +132,11 @@ void dump_pages( URL_FILE *output ) {
|
|||
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
|
||||
|
||||
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
|
||||
struct cons_pointer pointer = ( struct cons_pointer ) { i, j};
|
||||
if (!freep( pointer)) {
|
||||
struct cons_pointer pointer = ( struct cons_pointer ) { i, j };
|
||||
if ( !freep( pointer ) ) {
|
||||
dump_object( output, ( struct cons_pointer ) {
|
||||
i, j
|
||||
} );
|
||||
i, j
|
||||
} );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -65,11 +65,16 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
|
|||
if ( cell->count < MAXREFERENCE ) {
|
||||
cell->count++;
|
||||
#ifdef DEBUG
|
||||
debug_printf( DEBUG_ALLOC, L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d", ((char *)cell->tag.bytes), pointer.page, pointer.offset, cell->count);
|
||||
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) {
|
||||
debug_printf( DEBUG_ALLOC, L"; pointer to vector object of type %4.4s.\n", ((char *)(cell->payload.vectorp.tag.bytes)));
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
L"\nIncremented cell of type %4.4s at page %d, offset %d to count %d",
|
||||
( ( char * ) cell->tag.bytes ), pointer.page,
|
||||
pointer.offset, cell->count );
|
||||
if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
L"; pointer to vector object of type %4.4s.\n",
|
||||
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
|
||||
} else {
|
||||
debug_println( DEBUG_ALLOC);
|
||||
debug_println( DEBUG_ALLOC );
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
|
@ -91,11 +96,17 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
|
|||
if ( cell->count > 0 && cell->count != UINT32_MAX ) {
|
||||
cell->count--;
|
||||
#ifdef DEBUG
|
||||
debug_printf( DEBUG_ALLOC, L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d", ((char *)cell->tag.bytes), pointer.page, pointer.offset, cell->count);
|
||||
if ( strncmp( (char *)cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH) == 0) {
|
||||
debug_printf( DEBUG_ALLOC, L"; pointer to vector object of type %4.4s.\n", ((char *)(cell->payload.vectorp.tag.bytes)));
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d",
|
||||
( ( char * ) cell->tag.bytes ), pointer.page,
|
||||
pointer.offset, cell->count );
|
||||
if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH )
|
||||
== 0 ) {
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
L"; pointer to vector object of type %4.4s.\n",
|
||||
( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
|
||||
} else {
|
||||
debug_println( DEBUG_ALLOC);
|
||||
debug_println( DEBUG_ALLOC );
|
||||
}
|
||||
#endif
|
||||
|
||||
|
|
@ -119,8 +130,8 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
|
|||
* strings made with NIL termination. The question is which should be
|
||||
* fixed, and actually that's probably strings read by `read`. However,
|
||||
* for now, it was easier to add a null character here. */
|
||||
struct cons_pointer result = make_string( (wchar_t) 0, NIL);
|
||||
struct cons_space_object * cell = &pointer2cell( pointer );
|
||||
struct cons_pointer result = make_string( ( wchar_t ) 0, NIL );
|
||||
struct cons_space_object *cell = &pointer2cell( pointer );
|
||||
|
||||
if ( cell->tag.value == VECTORPOINTTV ) {
|
||||
struct vector_space_object *vec = pointer_to_vso( pointer );
|
||||
|
|
@ -337,8 +348,8 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
|
|||
cell->payload.string.cdr = tail;
|
||||
|
||||
cell->payload.string.hash = calculate_hash( c, tail );
|
||||
debug_dump_object( pointer, DEBUG_ALLOC);
|
||||
debug_println( DEBUG_ALLOC);
|
||||
debug_dump_object( pointer, DEBUG_ALLOC );
|
||||
debug_println( DEBUG_ALLOC );
|
||||
} else {
|
||||
// \todo should throw an exception!
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
|
|
|
|||
|
|
@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
|
|||
case RATIOTV:
|
||||
url_fwprintf( output,
|
||||
L"\t\tRational cell: value %ld/%ld, count %u\n",
|
||||
pointer2cell( cell.payload.ratio.dividend ).payload.
|
||||
integer.value,
|
||||
pointer2cell( cell.payload.ratio.divisor ).payload.
|
||||
integer.value, cell.count );
|
||||
pointer2cell( cell.payload.ratio.dividend ).
|
||||
payload.integer.value,
|
||||
pointer2cell( cell.payload.ratio.divisor ).
|
||||
payload.integer.value, cell.count );
|
||||
break;
|
||||
case READTV:
|
||||
url_fputws( L"\t\tInput stream; metadata: ", output );
|
||||
|
|
|
|||
|
|
@ -19,6 +19,8 @@
|
|||
#ifndef __dump_h
|
||||
#define __dump_h
|
||||
|
||||
void dump_string_cell( URL_FILE * output, wchar_t *prefix,
|
||||
struct cons_pointer pointer );
|
||||
|
||||
void dump_object( URL_FILE * output, struct cons_pointer pointer );
|
||||
|
||||
|
|
|
|||
|
|
@ -122,8 +122,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
|
|||
if ( nilp( result ) ) {
|
||||
/* i.e. out of memory */
|
||||
result =
|
||||
make_exception( privileged_string_memory_exhausted,
|
||||
previous );
|
||||
make_exception( privileged_string_memory_exhausted, previous );
|
||||
} else {
|
||||
struct stack_frame *frame = get_stack_frame( result );
|
||||
|
||||
|
|
@ -234,7 +233,7 @@ void free_stack_frame( struct stack_frame *frame ) {
|
|||
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC );
|
||||
}
|
||||
|
||||
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer) {
|
||||
struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) {
|
||||
struct stack_frame *frame = get_stack_frame( frame_pointer );
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
|
|
@ -245,27 +244,31 @@ struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer) {
|
|||
return result;
|
||||
}
|
||||
|
||||
void dump_frame_context_fragment( URL_FILE *output, struct cons_pointer frame_pointer) {
|
||||
void dump_frame_context_fragment( URL_FILE *output,
|
||||
struct cons_pointer frame_pointer ) {
|
||||
struct stack_frame *frame = get_stack_frame( frame_pointer );
|
||||
|
||||
if ( frame != NULL ) {
|
||||
url_fwprintf( output, L" <= ");
|
||||
print( output, frame->arg[0]);
|
||||
url_fwprintf( output, L" <= " );
|
||||
print( output, frame->arg[0] );
|
||||
}
|
||||
}
|
||||
|
||||
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer, int depth ) {
|
||||
void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer,
|
||||
int depth ) {
|
||||
struct stack_frame *frame = get_stack_frame( frame_pointer );
|
||||
|
||||
if ( frame != NULL ) {
|
||||
url_fwprintf( output, L"\tContext: ");
|
||||
url_fwprintf( output, L"\tContext: " );
|
||||
|
||||
int i = 0;
|
||||
for (struct cons_pointer cursor = frame_pointer; i++ < depth && !nilp( cursor); cursor = frame_get_previous( cursor)) {
|
||||
dump_frame_context_fragment( output, cursor);
|
||||
for ( struct cons_pointer cursor = frame_pointer;
|
||||
i++ < depth && !nilp( cursor );
|
||||
cursor = frame_get_previous( cursor ) ) {
|
||||
dump_frame_context_fragment( output, cursor );
|
||||
}
|
||||
|
||||
url_fwprintf( output, L"\n");
|
||||
url_fwprintf( output, L"\n" );
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -280,7 +283,7 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
|
|||
if ( frame != NULL ) {
|
||||
url_fwprintf( output, L"Stack frame with %d arguments:\n",
|
||||
frame->args );
|
||||
dump_frame_context( output, frame_pointer, 4);
|
||||
dump_frame_context( output, frame_pointer, 4 );
|
||||
|
||||
for ( int arg = 0; arg < frame->args; arg++ ) {
|
||||
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
|
||||
|
|
|
|||
|
|
@ -126,8 +126,9 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
|
|||
void free_vso( struct cons_pointer pointer ) {
|
||||
struct cons_space_object cell = pointer2cell( pointer );
|
||||
|
||||
debug_printf( DEBUG_ALLOC, L"About to free vector-space object of type %s at 0x%lx\n",
|
||||
(char *) cell.payload.vectorp.tag.bytes,
|
||||
debug_printf( DEBUG_ALLOC,
|
||||
L"About to free vector-space object of type %s at 0x%lx\n",
|
||||
( char * ) cell.payload.vectorp.tag.bytes,
|
||||
cell.payload.vectorp.address );
|
||||
struct vector_space_object *vso = cell.payload.vectorp.address;
|
||||
|
||||
|
|
|
|||
|
|
@ -263,17 +263,18 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
|
|||
* @return false otherwise.
|
||||
*/
|
||||
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result=false;
|
||||
bool result = false;
|
||||
|
||||
struct cons_pointer keys_a = hashmap_keys( a);
|
||||
struct cons_pointer keys_a = hashmap_keys( a );
|
||||
|
||||
if ( c_length( keys_a) == c_length( hashmap_keys( b))) {
|
||||
if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
|
||||
result = true;
|
||||
|
||||
for ( struct cons_pointer i = keys_a; !nilp( i); i = c_cdr( i)) {
|
||||
struct cons_pointer key = c_car( i);
|
||||
if ( !equal( hashmap_get( a, key),hashmap_get( b, key))) {
|
||||
result = false; break;
|
||||
for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
|
||||
struct cons_pointer key = c_car( i );
|
||||
if ( !equal( hashmap_get( a, key ), hashmap_get( b, key ) ) ) {
|
||||
result = false;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -298,23 +299,23 @@ bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
|
|||
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
|
||||
bool result = false;
|
||||
|
||||
if ( eq( a, b)) {
|
||||
result = true; // same
|
||||
if ( eq( a, b ) ) {
|
||||
result = true; // same
|
||||
/* there shouldn't ever be two separate VECP cells which point to the
|
||||
* same address in vector space, so I don't believe it's worth checking
|
||||
* for this.
|
||||
*/
|
||||
} else if ( vectorp( a) && vectorp( b)) {
|
||||
struct vector_space_object * va = pointer_to_vso( a);
|
||||
struct vector_space_object * vb = pointer_to_vso( b);
|
||||
} else if ( vectorp( a ) && vectorp( b ) ) {
|
||||
struct vector_space_object *va = pointer_to_vso( a );
|
||||
struct vector_space_object *vb = pointer_to_vso( b );
|
||||
|
||||
/* what we're saying here is that a namespace is not equal to a map,
|
||||
* even if they have identical logical structure. Is this right? */
|
||||
if ( va->header.tag.value == vb->header.tag.value) {
|
||||
switch ( va->header.tag.value) {
|
||||
if ( va->header.tag.value == vb->header.tag.value ) {
|
||||
switch ( va->header.tag.value ) {
|
||||
case HASHTV:
|
||||
case NAMESPACETV:
|
||||
result = equal_map_map( a, b);
|
||||
result = equal_map_map( a, b );
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
@ -336,7 +337,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
|||
|
||||
bool result = false;
|
||||
|
||||
if ( eq( a, b )) {
|
||||
if ( eq( a, b ) ) {
|
||||
result = true;
|
||||
} else if ( !numberp( a ) && same_type( a, b ) ) {
|
||||
struct cons_space_object *cell_a = &pointer2cell( a );
|
||||
|
|
@ -364,42 +365,47 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|
|||
/* TODO: it is not OK to do this on the stack since list-like
|
||||
* structures can be of indefinite extent. It *must* be done by
|
||||
* iteration (and even that is problematic) */
|
||||
if (cell_a->payload.string.hash == cell_b->payload.string.hash) {
|
||||
wchar_t a_buff[ STRING_SHIPYARD_SIZE], b_buff[ STRING_SHIPYARD_SIZE];
|
||||
if ( cell_a->payload.string.hash ==
|
||||
cell_b->payload.string.hash ) {
|
||||
wchar_t a_buff[STRING_SHIPYARD_SIZE],
|
||||
b_buff[STRING_SHIPYARD_SIZE];
|
||||
uint32_t tag = cell_a->tag.value;
|
||||
int i = 0;
|
||||
|
||||
memset(a_buff,0,sizeof(a_buff));
|
||||
memset(b_buff,0,sizeof(b_buff));
|
||||
memset( a_buff, 0, sizeof( a_buff ) );
|
||||
memset( b_buff, 0, sizeof( b_buff ) );
|
||||
|
||||
for (; (i < (STRING_SHIPYARD_SIZE - 1)) && !nilp( a) && !nilp( b); i++) {
|
||||
for ( ;
|
||||
( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
|
||||
&& !nilp( b ); i++ ) {
|
||||
a_buff[i] = cell_a->payload.string.character;
|
||||
a = c_cdr(a);
|
||||
a = c_cdr( a );
|
||||
cell_a = &pointer2cell( a );
|
||||
|
||||
b_buff[i] = cell_b->payload.string.character;
|
||||
b = c_cdr( b);
|
||||
cell_b = &pointer2cell( b);
|
||||
b = c_cdr( b );
|
||||
cell_b = &pointer2cell( b );
|
||||
}
|
||||
|
||||
#ifdef DEBUG
|
||||
debug_print( L"Comparing '", DEBUG_ARITH);
|
||||
debug_print( a_buff, DEBUG_ARITH);
|
||||
debug_print( L"' to '", DEBUG_ARITH);
|
||||
debug_print( b_buff, DEBUG_ARITH);
|
||||
debug_print( L"'\n", DEBUG_ARITH);
|
||||
debug_print( L"Comparing '", DEBUG_ARITH );
|
||||
debug_print( a_buff, DEBUG_ARITH );
|
||||
debug_print( L"' to '", DEBUG_ARITH );
|
||||
debug_print( b_buff, DEBUG_ARITH );
|
||||
debug_print( L"'\n", DEBUG_ARITH );
|
||||
#endif
|
||||
|
||||
/* OK, now we have wchar string buffers loaded from the objects. We
|
||||
* may not have exhausted either string, so the buffers being equal
|
||||
* isn't sufficient. So we recurse at least once. */
|
||||
|
||||
result = (wcsncmp( a_buff, b_buff, i) == 0) && equal( c_cdr(a), c_cdr(b));
|
||||
result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
|
||||
&& equal( c_cdr( a ), c_cdr( b ) );
|
||||
}
|
||||
break;
|
||||
case VECTORPOINTTV:
|
||||
if ( cell_b->tag.value == VECTORPOINTTV) {
|
||||
result = equal_vector_vector( a, b);
|
||||
if ( cell_b->tag.value == VECTORPOINTTV ) {
|
||||
result = equal_vector_vector( a, b );
|
||||
} else {
|
||||
result = false;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -310,7 +310,8 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
|
|||
debug_print( L"`", DEBUG_BIND );
|
||||
debug_print_object( key, DEBUG_BIND );
|
||||
debug_print( L"` is a ", DEBUG_BIND );
|
||||
debug_printf( DEBUG_BIND, L"%4.4s", (char *)pointer2cell(key).tag.bytes);
|
||||
debug_printf( DEBUG_BIND, L"%4.4s",
|
||||
( char * ) pointer2cell( key ).tag.bytes );
|
||||
debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
|
||||
}
|
||||
|
||||
|
|
@ -329,11 +330,11 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
struct cons_pointer store ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
if (!nilp( key)) {
|
||||
if ( !nilp( key ) ) {
|
||||
if ( consp( store ) ) {
|
||||
for ( struct cons_pointer next = store;
|
||||
nilp( result ) && ( consp( next ) || hashmapp( next ) );
|
||||
next = pointer2cell( next ).payload.cons.cdr ) {
|
||||
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 );
|
||||
|
|
@ -355,9 +356,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
break;
|
||||
default:
|
||||
throw_exception( c_append
|
||||
( c_string_to_lisp_string
|
||||
( L"Store entry is of unknown type: " ),
|
||||
c_type( entry_ptr ) ), NIL );
|
||||
( c_string_to_lisp_string
|
||||
( L"Store entry is of unknown type: " ),
|
||||
c_type( entry_ptr ) ), NIL );
|
||||
}
|
||||
|
||||
// #ifdef DEBUG
|
||||
|
|
@ -379,9 +380,9 @@ struct cons_pointer c_assoc( struct cons_pointer key,
|
|||
// #endif
|
||||
result =
|
||||
throw_exception( c_append
|
||||
( c_string_to_lisp_string
|
||||
( L"Store is of unknown type: " ),
|
||||
c_type( store ) ), NIL );
|
||||
( c_string_to_lisp_string
|
||||
( L"Store is of unknown type: " ),
|
||||
c_type( store ) ), NIL );
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -410,7 +411,7 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp,
|
|||
|
||||
map->payload.hashmap.buckets[bucket_no] =
|
||||
make_cons( make_cons( key, val ),
|
||||
map->payload.hashmap.buckets[bucket_no] );
|
||||
map->payload.hashmap.buckets[bucket_no] );
|
||||
}
|
||||
|
||||
return mapp;
|
||||
|
|
@ -425,12 +426,12 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value,
|
|||
struct cons_pointer result = NIL;
|
||||
|
||||
#ifdef DEBUG
|
||||
bool deep = vectorpointp( store);
|
||||
debug_print_binding( key, value, deep, DEBUG_BIND);
|
||||
bool deep = vectorpointp( store );
|
||||
debug_print_binding( key, value, deep, DEBUG_BIND );
|
||||
|
||||
if (deep) {
|
||||
if ( deep ) {
|
||||
debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
|
||||
pointer2cell(store).payload.vectorp.tag.bytes );
|
||||
pointer2cell( store ).payload.vectorp.tag.bytes );
|
||||
}
|
||||
#endif
|
||||
if ( nilp( value ) ) {
|
||||
|
|
|
|||
|
|
@ -308,7 +308,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
|
||||
* side effect, and needs to be GCed */
|
||||
if ( !nilp( result ) ){
|
||||
if ( !nilp( result ) ) {
|
||||
dec_ref( result );
|
||||
}
|
||||
|
||||
|
|
@ -446,9 +446,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
result = next_pointer;
|
||||
} else {
|
||||
result =
|
||||
( *fn_cell.payload.special.
|
||||
executable ) ( get_stack_frame( next_pointer ),
|
||||
next_pointer, env );
|
||||
( *fn_cell.payload.
|
||||
special.executable ) ( get_stack_frame
|
||||
( next_pointer ),
|
||||
next_pointer, env );
|
||||
debug_print( L"Special form returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL );
|
||||
|
|
@ -872,10 +873,9 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
|
|||
struct cons_pointer env ) {
|
||||
struct cons_pointer result = TRUE;
|
||||
|
||||
if ( frame->args > 1) {
|
||||
for (int b = 1; ( truep( result )) && (b < frame->args); b++)
|
||||
{
|
||||
result = eq( frame->arg[0], fetch_arg( frame, b)) ? TRUE : NIL;
|
||||
if ( frame->args > 1 ) {
|
||||
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
|
||||
result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -897,30 +897,30 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
struct cons_pointer env ) {
|
||||
struct cons_pointer result = TRUE;
|
||||
|
||||
if ( frame->args > 1) {
|
||||
for (int b = 1; ( truep( result )) && (b < frame->args); b++)
|
||||
{
|
||||
result = equal( frame->arg[0], fetch_arg( frame, b)) ? TRUE : NIL;
|
||||
if ( frame->args > 1 ) {
|
||||
for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
|
||||
result =
|
||||
equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
long int c_count (struct cons_pointer p) {
|
||||
struct cons_space_object * cell = &pointer2cell( p);
|
||||
long int c_count( struct cons_pointer p ) {
|
||||
struct cons_space_object *cell = &pointer2cell( p );
|
||||
int result = 0;
|
||||
|
||||
switch (cell->tag.value) {
|
||||
switch ( cell->tag.value ) {
|
||||
case CONSTV:
|
||||
case STRINGTV:
|
||||
/* I think doctrine is that you cannot treat symbols or keywords as
|
||||
* sequences, although internally, of course, they are. Integers are
|
||||
* also internally sequences, but also should not be treated as such.
|
||||
*/
|
||||
for (p; !nilp( p); p = c_cdr( p)) {
|
||||
result ++;
|
||||
}
|
||||
/* I think doctrine is that you cannot treat symbols or keywords as
|
||||
* sequences, although internally, of course, they are. Integers are
|
||||
* also internally sequences, but also should not be treated as such.
|
||||
*/
|
||||
for ( p; !nilp( p ); p = c_cdr( p ) ) {
|
||||
result++;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
@ -942,7 +942,7 @@ long int c_count (struct cons_pointer p) {
|
|||
struct cons_pointer
|
||||
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return acquire_integer( c_count( frame->arg[ 0]), NIL);
|
||||
return acquire_integer( c_count( frame->arg[0] ), NIL );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -1079,54 +1079,6 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
|
|||
return result;
|
||||
}
|
||||
|
||||
/**
|
||||
* Function; print one complete lisp expression and return NIL. If write-stream is specified and
|
||||
* is a write stream, then print to that stream, else the stream which is the value of
|
||||
* `*out*` in the environment.
|
||||
*
|
||||
* * (print expr)
|
||||
* * (print expr write-stream)
|
||||
*
|
||||
* @param frame my stack_frame.
|
||||
* @param frame_pointer a pointer to my stack_frame.
|
||||
* @param env my environment (from which the stream may be extracted).
|
||||
* @return NIL.
|
||||
*/
|
||||
struct cons_pointer
|
||||
lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
debug_print( L"Entering print\n", DEBUG_IO );
|
||||
struct cons_pointer result = NIL;
|
||||
URL_FILE *output;
|
||||
struct cons_pointer out_stream = writep( frame->arg[1] ) ?
|
||||
frame->arg[1] : get_default_stream( false, env );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
|
||||
debug_dump_object( out_stream, DEBUG_IO );
|
||||
output = pointer2cell( out_stream ).payload.stream.stream;
|
||||
inc_ref( out_stream );
|
||||
} else {
|
||||
output = file_to_url_file( stderr );
|
||||
}
|
||||
|
||||
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
|
||||
debug_dump_object( frame->arg[0], DEBUG_IO );
|
||||
|
||||
result = print( output, frame->arg[0] );
|
||||
|
||||
debug_print( L"lisp_print returning\n", DEBUG_IO );
|
||||
debug_dump_object( result, DEBUG_IO );
|
||||
|
||||
if ( writep( out_stream ) ) {
|
||||
dec_ref( out_stream );
|
||||
} else {
|
||||
free( output );
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**
|
||||
* Function: get the Lisp type of the single argument.
|
||||
|
|
@ -1205,36 +1157,40 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
* pair whose car is TRUE and whose cdr is the value of the action part
|
||||
*/
|
||||
struct cons_pointer eval_cond_clause( struct cons_pointer clause,
|
||||
struct stack_frame *frame, struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env) {
|
||||
struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer result = NIL;
|
||||
|
||||
#ifdef DEBUG
|
||||
debug_print( L"\n\tCond clause: ", DEBUG_EVAL );
|
||||
debug_print_object( clause, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL);
|
||||
debug_println( DEBUG_EVAL );
|
||||
#endif
|
||||
|
||||
if (consp(clause)) {
|
||||
struct cons_pointer val = eval_form( frame, frame_pointer, c_car( clause ),
|
||||
env );
|
||||
if ( consp( clause ) ) {
|
||||
struct cons_pointer val =
|
||||
eval_form( frame, frame_pointer, c_car( clause ),
|
||||
env );
|
||||
|
||||
if (!nilp( val)) {
|
||||
result = make_cons( TRUE, c_progn( frame, frame_pointer, c_cdr( clause ),
|
||||
env ));
|
||||
if ( !nilp( val ) ) {
|
||||
result =
|
||||
make_cons( TRUE,
|
||||
c_progn( frame, frame_pointer, c_cdr( clause ),
|
||||
env ) );
|
||||
|
||||
#ifdef DEBUG
|
||||
debug_print(L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL);
|
||||
debug_print_object( result, DEBUG_EVAL);
|
||||
debug_println( DEBUG_EVAL);
|
||||
debug_print( L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL );
|
||||
} else {
|
||||
debug_print(L"\n\t\tclause failed.\n", DEBUG_EVAL);
|
||||
debug_print( L"\n\t\tclause failed.\n", DEBUG_EVAL );
|
||||
#endif
|
||||
}
|
||||
} else {
|
||||
result = throw_exception( c_string_to_lisp_string
|
||||
( L"Arguments to `cond` must be lists" ),
|
||||
frame_pointer );
|
||||
( L"Arguments to `cond` must be lists" ),
|
||||
frame_pointer );
|
||||
}
|
||||
|
||||
return result;
|
||||
|
|
@ -1259,13 +1215,13 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
struct cons_pointer result = NIL;
|
||||
bool done = false;
|
||||
|
||||
for ( int i = 0; (i < frame->args) && !done; i++ ) {
|
||||
struct cons_pointer clause_pointer = fetch_arg( frame, i);
|
||||
for ( int i = 0; ( i < frame->args ) && !done; i++ ) {
|
||||
struct cons_pointer clause_pointer = fetch_arg( frame, i );
|
||||
|
||||
result = eval_cond_clause( clause_pointer, frame, frame_pointer, env);
|
||||
result = eval_cond_clause( clause_pointer, frame, frame_pointer, env );
|
||||
|
||||
if ( !nilp( result ) && truep( c_car( result)) ) {
|
||||
result = c_cdr( result);
|
||||
if ( !nilp( result ) && truep( c_car( result ) ) ) {
|
||||
result = c_cdr( result );
|
||||
done = true;
|
||||
break;
|
||||
}
|
||||
|
|
@ -1273,7 +1229,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
#ifdef DEBUG
|
||||
debug_print( L"\tCond returning: ", DEBUG_EVAL );
|
||||
debug_print_object( result, DEBUG_EVAL );
|
||||
debug_println( DEBUG_EVAL);
|
||||
debug_println( DEBUG_EVAL );
|
||||
#endif
|
||||
|
||||
return result;
|
||||
|
|
@ -1330,7 +1286,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
|
|||
struct cons_pointer env ) {
|
||||
struct cons_pointer message = frame->arg[0];
|
||||
return exceptionp( message ) ? message : throw_exception( message,
|
||||
frame->previous );
|
||||
frame->
|
||||
previous );
|
||||
}
|
||||
|
||||
/**
|
||||
|
|
@ -1426,7 +1383,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
|
|||
if ( exceptionp( expr )
|
||||
&& url_feof( pointer2cell( input ).payload.stream.stream ) ) {
|
||||
/* suppress printing end of stream exception */
|
||||
dec_ref( expr);
|
||||
dec_ref( expr );
|
||||
break;
|
||||
}
|
||||
|
||||
|
|
@ -1513,13 +1470,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
|
|||
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
|
||||
if ( nilp( c_cdr( l1 ) ) ) {
|
||||
return
|
||||
make_string_like_thing( ( pointer2cell( l1 ).payload.
|
||||
string.character ), l2,
|
||||
make_string_like_thing( ( pointer2cell( l1 ).
|
||||
payload.string.character ),
|
||||
l2,
|
||||
pointer2cell( l1 ).tag.value );
|
||||
} else {
|
||||
return
|
||||
make_string_like_thing( ( pointer2cell( l1 ).payload.
|
||||
string.character ),
|
||||
make_string_like_thing( ( pointer2cell( l1 ).
|
||||
payload.string.character ),
|
||||
c_append( c_cdr( l1 ), l2 ),
|
||||
pointer2cell( l1 ).tag.value );
|
||||
}
|
||||
|
|
@ -1632,13 +1590,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
|
|||
struct cons_pointer symbol = c_car( pair );
|
||||
|
||||
if ( symbolp( symbol ) ) {
|
||||
struct cons_pointer val = eval_form( frame, frame_pointer, c_cdr( pair ),
|
||||
bindings );
|
||||
struct cons_pointer val =
|
||||
eval_form( frame, frame_pointer, c_cdr( pair ),
|
||||
bindings );
|
||||
|
||||
debug_print_binding( symbol, val, false, DEBUG_BIND);
|
||||
debug_print_binding( symbol, val, false, DEBUG_BIND );
|
||||
|
||||
bindings =
|
||||
make_cons( make_cons( symbol, val ), bindings );
|
||||
bindings = make_cons( make_cons( symbol, val ), bindings );
|
||||
} else {
|
||||
result =
|
||||
throw_exception( c_string_to_lisp_string
|
||||
|
|
@ -1648,7 +1606,7 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
|
|||
}
|
||||
}
|
||||
|
||||
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND);
|
||||
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND );
|
||||
|
||||
/* i.e., no exception yet */
|
||||
for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) {
|
||||
|
|
@ -1676,13 +1634,13 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
|
|||
* @return struct cons_pointer a pointer to the result
|
||||
*/
|
||||
struct cons_pointer lisp_and( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
bool accumulator = true;
|
||||
struct cons_pointer result = frame->more;
|
||||
|
||||
for ( int a = 0; accumulator == true && a < frame->args; a++) {
|
||||
accumulator = truthy( fetch_arg( frame, a));
|
||||
for ( int a = 0; accumulator == true && a < frame->args; a++ ) {
|
||||
accumulator = truthy( fetch_arg( frame, a ) );
|
||||
}
|
||||
#
|
||||
return accumulator ? TRUE : NIL;
|
||||
|
|
@ -1697,13 +1655,13 @@ struct cons_pointer lisp_and( struct stack_frame *frame,
|
|||
* @return struct cons_pointer a pointer to the result
|
||||
*/
|
||||
struct cons_pointer lisp_or( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
bool accumulator = false;
|
||||
struct cons_pointer result = frame->more;
|
||||
|
||||
for ( int a = 0; accumulator == false && a < frame->args; a++) {
|
||||
accumulator = truthy( fetch_arg( frame, a));
|
||||
for ( int a = 0; accumulator == false && a < frame->args; a++ ) {
|
||||
accumulator = truthy( fetch_arg( frame, a ) );
|
||||
}
|
||||
|
||||
return accumulator ? TRUE : NIL;
|
||||
|
|
@ -1718,7 +1676,7 @@ struct cons_pointer lisp_or( struct stack_frame *frame,
|
|||
* @return struct cons_pointer `t` if the first argument is `nil`, else `nil`.
|
||||
*/
|
||||
struct cons_pointer lisp_not( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return nilp( frame->arg[0]) ? TRUE : NIL;
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env ) {
|
||||
return nilp( frame->arg[0] ) ? TRUE : NIL;
|
||||
}
|
||||
|
|
@ -137,9 +137,6 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
|
|||
struct cons_pointer lisp_equal( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer lisp_print( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer lisp_read( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
|
|
@ -231,14 +228,14 @@ struct cons_pointer lisp_try( struct stack_frame *frame,
|
|||
|
||||
|
||||
struct cons_pointer lisp_and( 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 lisp_or( 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 lisp_not( struct stack_frame *frame,
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
struct cons_pointer frame_pointer,
|
||||
struct cons_pointer env );
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#!/bin/bash
|
||||
|
||||
expected='<Special form: ((:primitive . t) (:name . cond))>'
|
||||
expected='<Special form: ((:primitive . t) (:name . cond) (:documentation . "`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated."))>'
|
||||
actual=`echo "(eval 'cond)" | target/psse 2>/dev/null | tail -1`
|
||||
|
||||
if [ "${expected}" = "${actual}" ]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue