Added logical operators and, not and or. Closes #3

This commit is contained in:
Simon Brooke 2026-02-24 01:45:51 +00:00
parent 8df304bc60
commit 62ebaf9819
13 changed files with 422 additions and 132 deletions

View file

@ -12,22 +12,22 @@ I never liked this 'four distinct spaces' idea. As I wrote way back in my first
So I'm now back to the idea of each node treating its physical memory as one undifferentiated vector space, with its own cons pages, being arrays of equal sized cons-space objects, floating in that vector space. I'm proposing two new types of cons space object. So I'm now back to the idea of each node treating its physical memory as one undifferentiated vector space, with its own cons pages, being arrays of equal sized cons-space objects, floating in that vector space. I'm proposing two new types of cons space object.
The idea of having four distinct spaces per node was that each node would curate just one cons page, and that each cons pointer was 128 bits comprising 64 bits of originating node address, and 64 bits of page offset. The idea of having four distinct spaces per node was that each node would curate just one cons page, and that each cons pointer was 64 bits comprising 32 bits of originating node address, and 32 bits of page offset.
I'm still thinking that 128 bits is a not-unreasonable size for a cons pointer, but that it should now be considered made up of three distinct fields, node address, page number, offset. The exact sizes of each of those fields can be variable, but I'm still thinking that 64 bits is a not-unreasonable size for a cons pointer, but that it should now be considered made up of three distinct fields, node address, page number, offset. The exact sizes of each of those fields can be variable, but
``` ```
+------*------*----------+ +------*------*---------+
| 0 | 32 | 64...127 | | 0 | 32 | 40...63 |
+------*------*----------+ +------*------*---------+
| Node | Page | Offset | | Node | Page | Offset |
+------*------*----------+ +------*------*---------+
``` ```
would allow for a hypercube with edges a billion cells long, each capable of addressing 2,535,301,200,456,458,802,993,406,410,752 (2.5x10<sup>30</sup>) bytes. As this is very substantially more than the number of atoms in the universe, a machine of that size could never be built; so this schema is sufficient for any possible machine which ever could be built! would allow for a hypercube with edges 536,870,912 &mdash; half a billion &mdash; nodes long, with each node capable of addressing 256 pages of each of 16,777,216 cells for a total of 4 billion cells, each of 32 bytes. So the cells alone addressable by a single node could occupy 2<sup>37</sup> = 137,438,953,472 bytes; but each node would have a 64 bit address bus, so the potential heap is vastly larger.
In practice, I don't actually need a 128 bit cons pointer, and at some stage I may make a pragmatic decision to make it smaller. But the whole idea of the post scarcity computing project is to design systems as though there weren't physical constraints on them, so I'm not proposing to change it yet. In practice, I don't actually need a 64 bit cons pointer, and at some stage I may make a pragmatic decision to make it smaller. But the whole idea of the post scarcity computing project is to design systems as though there weren't physical constraints on them, so I'm not proposing to change it yet.
## The `CACH` Cell ## The `CACH` Cell
@ -55,3 +55,21 @@ In designing the bootstrapping cons space object types of the system, I've desig
There are a lot of different sorts of things you can store in 128 bits of memory. You can divide it up into fields any way you please, and store anything you like &mdash; that will fit &mdash; in those fields. There are a lot of different sorts of things you can store in 128 bits of memory. You can divide it up into fields any way you please, and store anything you like &mdash; that will fit &mdash; in those fields.
## The Node Processor hardware
I suggested in my earlier essay that the node processors could be off the shelf parts, probably ARM chips. But the router still needs to be custom silicon. If you were to do custom silicon for the node processor, what would it look like?
Well, firstly, although it could have a very small instruction set, I don't think it would count as strictly a RISC processor. The reason it wouldn't is that some of the instructions would be themselves recursive, meaning they could not complete in a single clock cycle.
So, what does it look like?
Firstly, it must have at least one register in which it can construct a complete cons space object, which is to say, 256 bits.
It must have sufficient registers to represent the full content of a stack frame, which is to say eleven 64 bit cons pointers and one 32 bit argument counter, so at least 736 bits (but 768 probably makes more sense). But note that a function call with zero args needs only 160 bits, one with one arg needs only 224 bits, one with three, 288 bits register. So when evaluating functions with low numbers of arguments, it's at least potentially possible for the processor to use unused bits in the stack frame register as additional shipyards in which to assemble cons space objects.
H'mmm. You need two stack frame registers, one for the frame you're evaluating, and one for the frame you're assembling. I think you also need an additional cons space object shipyard, for the cons space object (VECP) which will point to the current frame when is released.
### Instructions

4
lisp/documentation.lisp Normal file
View file

@ -0,0 +1,4 @@
(set! documentation (lambda (name)
(:documentation (meta name))))
(set! doc documentation)

3
lisp/greaterp.lisp Normal file
View file

@ -0,0 +1,3 @@
(set! > (lambda (a b)
)

7
lisp/member.lisp Normal file
View file

@ -0,0 +1,7 @@
(set! member (lambda
(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))))))

6
lisp/nth.lisp Normal file
View file

@ -0,0 +1,6 @@
(set! nth (lambda (n l)
"Return the `n`th member of this list `l`, or `nil` if none."
(cond ((= nil l) nil)
((= n 1) (car l))
(t (nth (- n 1) (cdr l))))))

View file

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

View file

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

View file

@ -64,6 +64,35 @@ bool zerop( struct cons_pointer arg ) {
return result; return result;
} }
// TODO: think about
// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) {
// bool result = false;
// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
// if (cell_1->tag.value == cell_2->tag.value) {
// switch ( cell_1->tag.value ) {
// case INTEGERTV:{
// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) {
// result = cell_1->payload.integer.value > cell_2->payload.integer.value;
// }
// // else deal with comparing bignums...
// }
// break;
// case RATIOTV:
// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2);
// break;
// case REALTV:
// result = ( cell.payload.real.value == 0 );
// break;
// }
// }
// return result;
// }
/** /**
* does this `arg` point to a negative number? * does this `arg` point to a negative number?
*/ */
@ -86,24 +115,35 @@ bool is_negative( struct cons_pointer arg ) {
return result; return result;
} }
/**
* @brief if `arg` is a number, return the absolute value of that number, else
* `NIL`
*
* @param arg a cons space object, probably a number.
* @return struct cons_pointer
*/
struct cons_pointer absolute( struct cons_pointer arg ) { struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg ); struct cons_space_object cell = pointer2cell( arg );
if ( is_negative( arg ) ) { if ( numberp( arg)) {
switch ( cell.tag.value ) { if ( is_negative( arg ) ) {
case INTEGERTV: switch ( cell.tag.value ) {
result = case INTEGERTV:
make_integer( llabs( cell.payload.integer.value ), result =
cell.payload.integer.more ); make_integer( llabs( cell.payload.integer.value ),
break; cell.payload.integer.more );
case RATIOTV: break;
result = make_ratio( absolute( cell.payload.ratio.dividend ), case RATIOTV:
cell.payload.ratio.divisor, false ); result = make_ratio( absolute( cell.payload.ratio.dividend ),
break; cell.payload.ratio.divisor, false );
case REALTV: break;
result = make_real( 0 - cell.payload.real.value ); case REALTV:
break; result = make_real( 0 - cell.payload.real.value );
break;
}
} else {
result = arg;
} }
} }

View file

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

View file

@ -67,10 +67,14 @@ struct cons_pointer check_exception( struct cons_pointer pointer,
return result; return result;
} }
struct cons_pointer init_documentation_symbol = NIL;
struct cons_pointer init_name_symbol = NIL; struct cons_pointer init_name_symbol = NIL;
struct cons_pointer init_primitive_symbol = NIL; struct cons_pointer init_primitive_symbol = NIL;
void maybe_bind_init_symbols( ) { void maybe_bind_init_symbols( ) {
if ( nilp( init_documentation_symbol)) {
init_documentation_symbol = c_string_to_lisp_keyword( L"documentation");
}
if ( nilp( init_name_symbol ) ) { if ( nilp( init_name_symbol ) ) {
init_name_symbol = c_string_to_lisp_keyword( L"name" ); init_name_symbol = c_string_to_lisp_keyword( L"name" );
} }
@ -83,6 +87,7 @@ void maybe_bind_init_symbols( ) {
} }
void free_init_symbols( ) { void free_init_symbols( ) {
dec_ref( init_documentation_symbol);
dec_ref( init_name_symbol ); dec_ref( init_name_symbol );
dec_ref( init_primitive_symbol ); dec_ref( init_primitive_symbol );
} }
@ -95,21 +100,25 @@ void free_init_symbols( ) {
* more readable and aid debugging generally. * more readable and aid debugging generally.
*/ */
struct cons_pointer bind_function( wchar_t *name, struct cons_pointer bind_function( wchar_t *name,
wchar_t *doc,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer, struct cons_pointer,
struct cons_pointer ) ) { struct cons_pointer ) ) {
struct cons_pointer n = c_string_to_lisp_symbol( name ); struct cons_pointer n = c_string_to_lisp_symbol( name );
struct cons_pointer d = c_string_to_lisp_string( doc);
struct cons_pointer meta = struct cons_pointer meta =
make_cons( make_cons( init_primitive_symbol, TRUE ), make_cons( make_cons( init_primitive_symbol, TRUE ),
make_cons( make_cons( init_name_symbol, n ), make_cons( make_cons( init_name_symbol, n ),
NIL ) ); make_cons( make_cons( init_documentation_symbol, d), NIL) ) );
struct cons_pointer r = struct cons_pointer r =
check_exception( deep_bind( n, make_function( meta, executable ) ), check_exception( deep_bind( n, make_function( meta, executable ) ),
"bind_function" ); "bind_function" );
dec_ref( n ); dec_ref( n );
dec_ref( d );
return r; return r;
} }
@ -321,52 +330,82 @@ int main( int argc, char *argv[] ) {
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function( L"absolute", &lisp_absolute ); /* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
bind_function( L"add", &lisp_add ); * HTTP from an address at journeyman? */
bind_function( L"append", &lisp_append ); bind_function( L"absolute",
bind_function( L"apply", &lisp_apply ); L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
bind_function( L"assoc", &lisp_assoc ); &lisp_absolute );
bind_function( L"car", &lisp_car ); bind_function( L"add",
bind_function( L"cdr", &lisp_cdr ); L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
bind_function( L"close", &lisp_close ); &lisp_add );
bind_function( L"cons", &lisp_cons ); bind_function( L"and",
bind_function( L"divide", &lisp_divide ); L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
bind_function( L"eq", &lisp_eq ); &lisp_and);
bind_function( L"equal", &lisp_equal ); bind_function( L"append", L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
bind_function( L"eval", &lisp_eval ); &lisp_append );
bind_function( L"exception", &lisp_exception ); bind_function( L"apply",
bind_function( L"get-hash", &lisp_get_hash ); L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
bind_function( L"hashmap", lisp_make_hashmap ); &lisp_apply );
bind_function( L"inspect", &lisp_inspect ); bind_function( L"assoc",
bind_function( L"keys", &lisp_keys ); L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
bind_function( L"list", &lisp_list ); &lisp_assoc );
bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"car",
bind_function( L"meta", &lisp_metadata ); L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
bind_function( L"metadata", &lisp_metadata ); &lisp_car );
bind_function( L"multiply", &lisp_multiply ); bind_function( L"cdr",
bind_function( L"negative?", &lisp_is_negative ); L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
bind_function( L"oblist", &lisp_oblist ); &lisp_cdr );
bind_function( L"open", &lisp_open ); bind_function( L"close", L"`(close stream)`: If `stream` is a stream, close that stream.", &lisp_close );
bind_function( L"print", &lisp_print ); 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"put!", lisp_hashmap_put ); bind_function( L"divide",
bind_function( L"put-all!", &lisp_hashmap_put_all ); L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
bind_function( L"ratio->real", &lisp_ratio_to_real ); &lisp_divide );
bind_function( L"read", &lisp_read ); bind_function( L"eq", L"`(eq a b)`: Return `t` if `a` and `b` are the exact same object, else `nil`.", &lisp_eq );
bind_function( L"read-char", &lisp_read_char ); bind_function( L"equal", L"`(eq a b)`: Return `t` if `a` and `b` have logically equivalent value, else `nil`.", &lisp_equal );
bind_function( L"repl", &lisp_repl ); bind_function( L"eval", L"", &lisp_eval );
bind_function( L"reverse", &lisp_reverse ); bind_function( L"exception", L"`(exception message)`: Return (throw) an exception with this `message`.", &lisp_exception );
bind_function( L"set", &lisp_set ); bind_function( L"get-hash", L"`(get-hash arg)`: returns the natural number hash value of `arg`.", &lisp_get_hash );
bind_function( L"slurp", &lisp_slurp ); bind_function( L"hashmap",
bind_function( L"source", &lisp_source ); L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
bind_function( L"subtract", &lisp_subtract ); lisp_make_hashmap );
bind_function( L"throw", &lisp_exception ); bind_function( L"inspect",
bind_function( L"time", &lisp_time ); L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
bind_function( L"type", &lisp_type ); &lisp_inspect );
bind_function( L"+", &lisp_add ); bind_function( L"keys", L"`(keys store)`: Return a list of all keys in this `store`.", &lisp_keys );
bind_function( L"*", &lisp_multiply ); bind_function( L"list", L"`(list args...): Return a list of these `args`.", &lisp_list );
bind_function( L"-", &lisp_subtract ); 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"/", &lisp_divide ); bind_function( L"meta", L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.", &lisp_metadata );
bind_function( L"=", &lisp_equal ); 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 read?)`: Open a stream to this `url`. If `read` is present and is non-nil, open it for reading, else writing.", &lisp_open );
bind_function( L"or",
L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
&lisp_or);
bind_function( L"print", L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.", &lisp_print );
bind_function( L"put!", L"", lisp_hashmap_put );
bind_function( L"put-all!", L"", &lisp_hashmap_put_all );
bind_function( L"ratio->real", L"", &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"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"throw", L"", &lisp_exception );
bind_function( L"time", L"", &lisp_time );
bind_function( L"type", L"", &lisp_type );
bind_function( L"+", L"", &lisp_add );
bind_function( L"*", L"", &lisp_multiply );
bind_function( L"-", L"", &lisp_subtract );
bind_function( L"/", L"", &lisp_divide );
bind_function( L"=", L"", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */

View file

@ -10,12 +10,15 @@
#include <math.h> #include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "arith/integer.h" #include "arith/integer.h"
#include "arith/peano.h" #include "arith/peano.h"
#include "arith/ratio.h" #include "arith/ratio.h"
#include "debug.h" #include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/vectorspace.h"
#include "ops/equal.h"
#include "ops/intern.h"
/** /**
* Shallow, and thus cheap, equality: true if these two objects are * Shallow, and thus cheap, equality: true if these two objects are
@ -240,6 +243,86 @@ bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
return result; return result;
} }
/**
* @brief equality of two map-like things.
*
* The list returned by `keys` on a map-like thing is not sorted, and is not
* guaranteed always to come out in the same order. So equality is established
* if:
* 1. the length of the keys list is the same; and
* 2. the value of each key in the keys list for map `a` is the same in map `a`
* and in map `b`.
*
* Private function, do not use outside this file, **WILL NOT** work
* unless both arguments are VECPs.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
bool result=false;
struct cons_pointer keys_a = hashmap_keys( a);
if ( c_length( keys_a) == c_length( hashmap_keys( b))) {
result = true;
for ( struct cons_pointer i = keys_a; !nilp( i); i = c_cdr( i)) {
struct cons_pointer key = c_car( i);
if ( !equal( hashmap_get( a, key),hashmap_get( b, key))) {
result = false; break;
}
}
}
return result;
}
/**
* @brief equality of two vector-space things.
*
* Expensive, but we need to be able to check for equality of at least hashmaps
* and namespaces.
*
* Private function, do not use outside this file, not guaranteed to work
* unless both arguments are VECPs pointing to map like things.
*
* @param a a pointer to a vector space object.
* @param b another pointer to a vector space object.
* @return true if the two objects have the same logical structure.
* @return false otherwise.
*/
bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
if ( eq( a, b)) {
result = true; // same
/* there shouldn't ever be two separate VECP cells which point to the
* same address in vector space, so I don't believe it's worth checking
* for this.
*/
} else if ( vectorp( a) && vectorp( b)) {
struct vector_space_object * va = pointer_to_vso( a);
struct vector_space_object * vb = pointer_to_vso( b);
/* what we're saying here is that a namespace is not equal to a map,
* even if they have identical logical structure. Is this right? */
if ( va->header.tag.value == vb->header.tag.value) {
switch ( va->header.tag.value) {
case HASHTV:
case NAMESPACETV:
result = equal_map_map( a, b);
break;
}
}
}
// else can't throw an exception from here but TODO: should log.
return result;
}
/** /**
* Deep, and thus expensive, equality: true if these two objects have * Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false. * identical structure, else false.
@ -319,6 +402,13 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
result = fabs( num_a - num_b ) < ( max / 1000000.0 ); result = fabs( num_a - num_b ) < ( max / 1000000.0 );
} }
break; break;
case VECTORPOINTTV:
if ( cell_b->tag.value == VECTORPOINTTV) {
result = equal_vector_vector( a, b);
} else {
result = false;
}
break;
default: default:
result = false; result = false;
break; break;
@ -329,8 +419,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/* /*
* there's only supposed ever to be one T and one NIL cell, so each * there's only supposed ever to be one T and one NIL cell, so each
* should be caught by eq; equality of vector-space objects is a whole * should be caught by eq.
* other ball game so we won't deal with it now (and indeed may never). *
* I'm not certain what equality means for read and write streams, so * I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now. * I'll ignore them, too, for now.
*/ */

View file

@ -24,19 +24,20 @@
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include "memory/consspaceobject.h"
#include "memory/conspage.h"
#include "debug.h"
#include "memory/dump.h"
#include "ops/equal.h"
#include "arith/integer.h" #include "arith/integer.h"
#include "ops/intern.h" #include "arith/peano.h"
#include "debug.h"
#include "io/io.h" #include "io/io.h"
#include "ops/lispops.h"
#include "io/print.h" #include "io/print.h"
#include "io/read.h" #include "io/read.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/stack.h" #include "memory/stack.h"
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "memory/dump.h"
#include "ops/equal.h"
#include "ops/intern.h"
#include "ops/lispops.h"
/** /**
* @brief the name of the symbol to which the prompt is bound; * @brief the name of the symbol to which the prompt is bound;
@ -74,7 +75,6 @@ struct cons_pointer eval_form( struct stack_frame *parent,
/* things which evaluate to themselves */ /* things which evaluate to themselves */
case EXCEPTIONTV: case EXCEPTIONTV:
case FREETV: // shouldn't happen, but anyway... case FREETV: // shouldn't happen, but anyway...
// FUNCTIONTV, LAMBDATV, NLAMBDATV, SPECIALTV ?
case INTEGERTV: case INTEGERTV:
case KEYTV: case KEYTV:
case LOOPTV: // don't think this should happen... case LOOPTV: // don't think this should happen...
@ -85,7 +85,6 @@ struct cons_pointer eval_form( struct stack_frame *parent,
case STRINGTV: case STRINGTV:
case TIMETV: case TIMETV:
case TRUETV: case TRUETV:
// case VECTORPOINTTV: ?
case WRITETV: case WRITETV:
break; break;
default: default:
@ -243,10 +242,10 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
} }
void log_binding( struct cons_pointer name, struct cons_pointer val ) { void log_binding( struct cons_pointer name, struct cons_pointer val ) {
debug_print( L"\n\tBinding ", DEBUG_ALLOC ); debug_print( L"\n\tBinding ", DEBUG_LAMBDA );
debug_dump_object( name, DEBUG_ALLOC ); debug_dump_object( name, DEBUG_LAMBDA );
debug_print( L" to ", DEBUG_ALLOC ); debug_print( L" to ", DEBUG_LAMBDA );
debug_dump_object( val, DEBUG_ALLOC ); debug_dump_object( val, DEBUG_LAMBDA );
} }
/** /**
@ -305,12 +304,15 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA );
debug_print_object( sexpr, DEBUG_LAMBDA ); debug_print_object( sexpr, DEBUG_LAMBDA );
// debug_print( L"\t env is: ", DEBUG_LAMBDA );
// debug_print_object( new_env, DEBUG_LAMBDA );
debug_println( DEBUG_LAMBDA ); debug_println( DEBUG_LAMBDA );
/* if a result is not the terminal result in the lambda, it's a /* if a result is not the terminal result in the lambda, it's a
* side effect, and needs to be GCed */ * side effect, and needs to be GCed */
if ( !nilp( result ) ) if ( !nilp( result ) ){
dec_ref( result ); // dec_ref( result );
}
result = eval_form( frame, frame_pointer, sexpr, new_env ); result = eval_form( frame, frame_pointer, sexpr, new_env );
@ -319,7 +321,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
} }
} }
dec_ref( new_env ); // dec_ref( new_env );
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
debug_print_object( result, DEBUG_LAMBDA ); debug_print_object( result, DEBUG_LAMBDA );
@ -870,7 +872,12 @@ struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; if ( frame->args == 2) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} else {
return throw_exception( c_string_to_lisp_string( L"Wrong number of args to `eq`."),
frame_pointer);
}
} }
/** /**
@ -886,7 +893,12 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; if ( frame->args == 2) {
return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} else {
return throw_exception( c_string_to_lisp_string( L"Wrong number of args to `equal`."),
frame_pointer);
}
} }
/** /**
@ -1507,6 +1519,14 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame,
return result; return result;
} }
/**
* @brief construct and return a list of arbitrarily many arguments.
*
* @param frame The stack frame.
* @param frame_pointer A pointer to the stack frame.
* @param env The evaluation environment.
* @return struct cons_pointer a pointer to the result
*/
struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer lisp_list( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
@ -1563,35 +1583,70 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
} }
// struct cons_pointer c_concat( struct cons_pointer a, struct cons_pointer b) { /**
// struct cons_pointer result = b; * @brief Boolean `and` of arbitrarily many arguments.
*
* @param frame The stack frame.
* @param frame_pointer A pointer to the stack frame.
* @param env The evaluation environment.
* @return struct 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 ) {
bool accumulator = true;
struct cons_pointer result = frame->more;
// if ( nilp( b.tag.value)) { for ( int a = 0; accumulator == true && a < args_in_frame; a++) {
// result = make_cons( a, b); accumulator = truthy( frame->arg[ a]);
// } else { }
// if ( ! nilp( a)) {
// if (a.tag.value == b.tag.value) {
// struct cons_pointer tail = c_concat( c_cdr( a), b); if ( accumulator && ! nilp( frame->more)) {
for ( struct cons_pointer rest = frame->more; accumulator == true && !nilp( rest); rest = c_cdr(rest)) {
accumulator = truthy( c_car( rest));
}
}
// switch ( a.tag.value) { return accumulator ? TRUE : NIL;
// case CONSTV: }
// result = make_cons( c_car( a), tail);
// break;
// case KEYTV:
// case STRINGTV:
// case SYMBOLTV:
// result = make_string_like_thing()
// } /**
* @brief Boolean `or` of arbitrarily many arguments.
*
* @param frame The stack frame.
* @param frame_pointer A pointer to the stack frame.
* @param env The evaluation environment.
* @return struct 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 ) {
bool accumulator = false;
struct cons_pointer result = frame->more;
// } else { for ( int a = 0; accumulator == false && a < args_in_frame; a++) {
// // throw an exception accumulator = truthy( frame->arg[ a]);
// } }
// }
// }
if ( ! accumulator && ! nilp( frame->more)) {
for ( struct cons_pointer rest = frame->more; accumulator == false && !nilp( rest); rest = c_cdr(rest)) {
accumulator = truthy( c_car( rest));
}
}
return accumulator ? TRUE : NIL;
}
// return result; /**
// } * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`.
*
* @param frame The stack frame.
* @param frame_pointer A pointer to the stack frame.
* @param env The evaluation environment.
* @return struct 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;
}

View file

@ -225,4 +225,17 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_and( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_or( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_not( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
#endif #endif