post-scarcity/src/c/environment/function_bindings.c

/**
 *  environment/function_bindings.c
 *
 *  Post Scarcity Software Environment:
 *
 *  Provide bindings for substrate functions. At least in theory, these
 *  bindings only need to be initialised on node zero.
 *  todo: they really ought to be in a namespace ::system:bootstrap, once I
 *  have namespaces and paths working.
 *
 *  (c) 2026 Simon Brooke <simon@journeyman.cc>
 *  Licensed under GPL version 2.0, or, at your option, any later version.
 */

#include <stdbool.h>
#include <stdlib.h>
#include <wchar.h>

#include "debug.h"
#include "environment/privileged_keywords.h"

#include "io/io.h"
#include "io/peek.h"
#include "io/print.h"
#include "io/read.h"

#include "memory/node.h"
#include "memory/pointer.h"
#include "memory/tags.h"

#include "ops/assoc.h"
#include "ops/bind.h"
#include "ops/cond.h"
#include "ops/eq.h"
#include "ops/eval_apply.h"
#include "ops/inspect.h"
#include "ops/keys.h"
#include "ops/list_ops.h"
#include "ops/mapcar.h"
#include "ops/progn.h"
#include "ops/quote.h"
#include "ops/repl.h"
#include "ops/reverse.h"
#include "payloads/stack.h"
#include "ops/string_ops.h"
#include "ops/truth.h"

#include "payloads/cons.h"
#include "payloads/function.h"
#include "payloads/special.h"
#include "payloads/stack.h"

/**
 * Bind this compiled `executable` function, as a Lisp function, to
 * this name in the `oblist`.
 * \todo where a function is not compiled from source, we could cache
 * the name on the source pointer. Would make stack frames potentially
 * more readable and aid debugging generally.
 */

struct pso_pointer
bind_function(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc,
			  struct pso_pointer (*executable)(struct pso_pointer)) {
	struct pso_pointer result = fetch_env(frame_pointer);
	struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name);
	struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc);

	struct pso_pointer meta = make_cons(
		frame_pointer,
		make_cons(frame_pointer, privileged_keyword_bootstrap, nil),
		make_cons(frame_pointer,
				  make_cons(frame_pointer, privileged_keyword_name, n),
				  make_cons(frame_pointer,
							make_cons(frame_pointer,
									  privileged_keyword_documentation, d),
							nil)));

	struct pso_pointer r = make_function(frame_pointer, meta, executable);

	debug_print(doc, DEBUG_BOOTSTRAP, 0);
	if (!exceptionp(r)) {
		debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0);
		result =
			make_cons(frame_pointer, make_cons(frame_pointer, n, r), result);
	} else {
		debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0);
	}

	return result;
}

/**
 * Bind this compiled `executable` function, as a Lisp special form, to
 * this `name` in the `oblist`.
 */
struct pso_pointer
bind_special(struct pso_pointer frame_pointer, char32_t *name, char32_t *doc,
			 struct pso_pointer (*executable)(struct pso_pointer)) {
	struct pso_pointer result = fetch_env(frame_pointer);
	struct pso_pointer n = c_string_to_lisp_symbol(frame_pointer, name);
	struct pso_pointer d = c_string_to_lisp_string(frame_pointer, doc);

	struct pso_pointer meta = make_cons(
		frame_pointer,
		make_cons(frame_pointer, privileged_keyword_bootstrap, nil),
		make_cons(frame_pointer,
				  make_cons(frame_pointer, privileged_keyword_name, n),
				  make_cons(frame_pointer,
							make_cons(frame_pointer,
									  privileged_keyword_documentation, d),
							nil)));

	struct pso_pointer r = make_special(frame_pointer, meta, executable);

	debug_print(doc, DEBUG_BOOTSTRAP, 0);
	if (!exceptionp(r)) {
		debug_print(U"... bound\n", DEBUG_BOOTSTRAP, 0);
		result =
			make_cons(frame_pointer, make_cons(frame_pointer, n, r), result);
	} else {
		debug_print(U"... failed to bind\n", DEBUG_BOOTSTRAP, 0);
	}

	return result;
}

struct function_data {
	char32_t *name;
	char32_t *documentation;
	void *executable;
};

/* right, the problem with all those pretty '#ifdefs' which might allow us to
 * simply switch functions on and off just by including or not including .h
 * files is that the C compiler is too primitive to know how many items there
 * are in an array. So this number must be edited manually, and must be right.
 */
#define N_FUNCTION_INITIALISERS 4

/** initialisers for functions */
struct function_data function_initialisers[] = {
#ifdef _psse_io_io_h
	{U"close", U"(close stream): close `stream`.", &lisp_close},
	{U"open",
	 U"(open stream), (open stream write?): open `stream`; if `write?` is "
	 U"present and is non-nil, open for writing, else for reading.",
	 &lisp_open},
	{U"slurp",
	 U"(slurp stream): read the whole contents of this `stream`, "
	 U"which may "
	 U"be an open stream open for reading or a URL, into a string, and return "
	 U"the "
	 U"string.",
	 &lisp_slurp},
#endif
#ifdef __psse_io_peek_h
	{U"peek",
	 U"(peek stream): return the next character which may be read from "
	 U"`stream`, without removing it.",
	 &peek},
#endif
#ifdef __psse_io_print_h
	{U"print",
	 U"(print object), (print object stream) print this `object` in a format "
	 U"suitable to be read by `read`, q.v.; if `stream` is specified and is a "
	 U"stream open for writing, to that stream.",
	 &print},
	{U"princ",
	 U"(princ object), (princ object stream) print this `object` in a format "
	 U"more suited to human readers; if `stream` is specified and is a stream "
	 U"open for writing, to that stream.",
	 &print},
#endif
#ifdef __psse_io_read_h
	{U"read",
	 U"(read stream) read one complete Lisp expression from `stream`, and "
	 U"return that expression unevaluated.",
	 &read},
	{U"read-character",
	 U"(read_character stream): read a single character from `stream` and "
	 U"return it.",
	 &read_character},
	{U"read_number",
	 U"(read-number stream): read a number from `stream` and return it.",
	 &read_number},
	{U"read_symbol",
	 U"(read-symbol stream): read a symbol from `stream` and return it.",
	 &read_symbol},
#endif
#ifdef __psse_ops_assoc_h
	{U"assoc",
	 U"(assoc key store): search `store` for the value associated with "
	 U"`key`.",
	 &assoc},
#endif
#ifdef __psse_ops_bind_h
	{U"bind!",
	 U"(bind! key value store): bind `key` to `value` in this store, modifying "
	 U"the store if it is writable to the user, otherwise returning a new "
	 U"store",
	 &bind},
#endif
#ifdef __psse_ops_eq_h
	{U"eq",
	 U"(eq args...): shallow, cheap equality; returns `t` if all `args...` "
	 U"are the same object, else `nil`.",
	 &eq},
	{U"equal",
	 U"(equal a b): expensive, deep equality: returns `t` if objects `a` "
	 U"and `b` have recursively equal value.",
	 &equal},
#endif
#ifdef __psse_ops_eval_apply_h
	// TODO: there's a lot of other stuff in eval_apply.c, which ought to be in
	// other files but at present isn't.
	{U"apply",
	 U"(apply fn args...): apply this `fn` to these `args...` and return "
	 U"their value.",
	 &lisp_apply},
	{U"eval",
	 U"(eval expression): evaluate this `expression` and return its value",
	 &lisp_eval},
#endif
#ifdef __psse_ops_inspect_h
	{U"inspect",
	 U"(inspect expr), (inspect expr write-stream): inspect one complete "
	 U"lisp expression and return `nil`. If `write-stream` is specified and "
	 U"is a write stream, then print to that stream, else to the stream "
	 U"which is the value of `*out*` in the environment.",
	 &lisp_inspect},
#endif
#ifdef __psse_ops_keys_h
	{U"keys", U"(keys store): returns a list of the keys in this `store`.",
	 &lisp_keys},
#endif
#ifdef __psse_ops_list_ops_h
	{U"count",
	 U"(count sequence): returns the number of top level elements in "
	 U"`sequence`.",
	 &count},
#endif
#ifdef __psse_ops_mapcar_h
	{U"mapcar",
	 U"(mapcar fn list): map this `fn` over this `list`, and return a list "
	 U"of the results.",
	 &lisp_mapcar},
#endif
#ifdef __psse_ops_progn_h
	{U"progn",
	 U"(progn expressions...): Evaluate each expression in "
	 U"`expressions` in turn and return the value of the last.",
	 &lisp_progn},
#endif
#ifdef __psse_ops_repl_h
	{U"repl", U"(repl show_prompt?): Start a new read, eval, print loop.",
	 &repl},
#endif
#ifdef __psse_ops_reverse_h
	{U"reverse",
	 U"(reverse sequence): return a sequence like this `sequence`, but with "
	 U"the order of top level elements reversed.",
	 &reverse},
#endif
#ifdef __psse_ops_truth_h
	{U"and",
	 U"(and expressions...): returns `t` if none of these `expressions...` "
	 U"evaluates to `nil`, else `nil`.",
	 &and},
	{U"nil?",
	 U"(nil? expression): returns `t` if `expression` evaluates to `nil`, else "
	 U"`nil`.",
	 &nilp},
	{U"not",
	 U"(not expression): returns `t` unless `expression` evaluates to `nil`, "
	 U"else "
	 U"`nil`.",
	 &not},
	{U"or",
	 U"(or expressions...): returns `nil` if every one of these `expressions...` "
	 U"evaluates to `nil`, else `t`.",
	 &or},
	{U"true?",
	 U"(true? expression): returns `t` if `expression` evaluates to `t`, else "
	 U"`nil`.",
	 &truep},
#endif

	{U"END MARKER", U"END MARKER", NULL}};

/* right, the problem with all those pretty '#ifdefs' which might allow us to
 * simply switch functions on and off just by including or not including .h
 * files is that the C compiler is too primitive to know how many items there
 * are in an array */
#define N_SPECIAL_INITIALISERS 1

/** initialisers for special forms */
struct function_data special_initialisers[] = {
#ifdef __psse_ops_cond_h
	{U"cond",
	 U"(cond clauses...): special form; conditional. Each `clause` is expected "
	 U"to be a "
	 U"list; if the first item in such a list evaluates to non-nil, the "
	 U"remaining items in that list are evaluated in turn and the value of "
	 U"the last returned. If no arg `clause` has a first element which "
	 U"evaluates to non nil, then nil is returned",
	 &lisp_cond},
#endif
#ifdef __psse_ops_quote_h
	{U"quote",
	 U"(quote expression): special form; protect `expression` from "
	 U"evaluation.",
	 &quote},
#endif
	{U"END MARKER", U"END MARKER", NULL}};

struct pso_pointer
initialise_function_bindings(struct pso_pointer frame_pointer) {
	struct pso_pointer result = fetch_env(frame_pointer);

	for (int i = 0; function_initialisers[i].executable != NULL; i++) {
		result = bind_function(push_local(frame_pointer, make_frame_with_env(0, frame_pointer, result)),
							   function_initialisers[i].name,
							   function_initialisers[i].documentation,
							   function_initialisers[i].executable);
	}
	for (int i = 0; special_initialisers[i].executable != NULL; i++) {
		result = bind_function(push_local( frame_pointer, make_frame_with_env(0, frame_pointer, result)),
							   special_initialisers[i].name,
							   special_initialisers[i].documentation,
							   special_initialisers[i].executable);
	}

	return result;
}