simon/post-scarcity
1
0
Fork 0
Code Issues 4 Pull requests Projects Releases Packages Wiki Activity Actions

Made eq and equal vararg functions, and appended ? to their names as predicates.

Browse source
This commit is contained in:
Simon Brooke 2026-02-25 15:24:02 +00:00
parent 8c63272214
commit 3665326c55
7 changed files with 94 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

11
src/init.c
View file

@ -361,11 +361,12 @@ int main( int argc, char *argv[] ) {
&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 a b)`: Return `t` if `a` and `b` are the exact same object, else `nil`.", &lisp_eq );
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"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 );
@ -393,7 +394,7 @@ int main( int argc, char *argv[] ) {
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"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 );
@ -405,11 +406,11 @@ int main( int argc, char *argv[] ) {
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"`(+ 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"", &lisp_equal );
bind_function( L"=", L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.", &lisp_equal );
/*
* primitive special forms
*/

32
src/ops/equal.c
View file

@ -333,9 +333,11 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
debug_print( L" = ", DEBUG_ARITH );
debug_print_object( b, DEBUG_ARITH );
bool result = eq( a, b );
if ( !result && same_type( a, b ) ) {
bool result = false;
if ( eq( a, b )) {
result = true;
} else if ( !numberp( a ) && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
@ -378,30 +380,6 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.cdr ) ) );
break;
case INTEGERTV:
result =
( cell_a->payload.integer.value ==
cell_b->payload.integer.value ) &&
equal( cell_a->payload.integer.more,
cell_b->payload.integer.more );
break;
case RATIOTV:
result = equal_ratio_ratio( a, b );
break;
case REALTV:
{
double num_a = to_long_double( a );
double num_b = to_long_double( b );
double max = fabs( num_a ) > fabs( num_b )
? fabs( num_a )
: fabs( num_b );
/*
* not more different than one part in a million - close enough
*/
result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
case VECTORPOINTTV:
if ( cell_b->tag.value == VECTORPOINTTV) {
result = equal_vector_vector( a, b);

68
src/ops/lispops.c
View file

@ -870,12 +870,16 @@ struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
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);
}
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;
}
}
return result;
}
/**
@ -891,12 +895,54 @@ 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 ) {
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);
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;
}
}
return result;
}
long int c_count (struct cons_pointer p) {
struct cons_space_object * cell = &pointer2cell( p);
int result = 0;
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 ++;
}
}
return result;
}
/**
* Function: return the number of top level forms in the object which is
* the first (and only) argument, if it is a sequence (which for current
* purposes means a list or a string)
*
* * (count l)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
* @param env my environment (ignored).
* @return the number of top level forms in a list, or characters in a
* string, else 0.
*/
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);
}
/**

3
src/ops/lispops.h
View file

@ -149,6 +149,9 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer
lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.

2
unit-tests/add.sh
View file

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

4
unit-tests/cond.sh
View file

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

40
unit-tests/let.sh
View file

@ -2,28 +2,28 @@
result=0
echo -n "$0: let with two bindings, one form in body..."
expected='11'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1`
# echo -n "$0: let with two bindings, one form in body..."
# expected='11'
# actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
# if [ "${expected}" = "${actual}" ]
# then
# echo "OK"
# else
# echo "Fail: expected '$expected', got '$actual'"
# result=`echo "${result} + 1" | bc`
# fi
echo -n "$0: let with two bindings, two forms in body..."
expected='1'
actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1`
# echo -n "$0: let with two bindings, two forms in body..."
# expected='1'
# actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
result=`echo "${result} + 1" | bc`
fi
# if [ "${expected}" = "${actual}" ]
# then
# echo "OK"
# else
# echo "Fail: expected '$expected', got '$actual'"
# result=`echo "${result} + 1" | bc`
# fi
exit ${result}