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

Ran a 'make format', because !'m close to being able to merge this feature.

Browse source
This commit is contained in:
Simon Brooke 2026-05-06 16:45:56 +01:00
parent 5e64a33965
commit 80049f2272
52 changed files with 936 additions and 843 deletions
Download patch file Download diff file Expand all files Collapse all files

15
src/c/environment/environment.c
View file

@ -81,7 +81,7 @@ struct pso_pointer initialise_environment( uint32_t node ) {
}
}
if ( !exceptionp( result ) ) {
frame_pointer = inc_ref( make_frame(0, nil));
frame_pointer = inc_ref( make_frame( 0, nil ) );
result =
lisp_bind( make_frame
( 3, frame_pointer,
@ -103,13 +103,16 @@ struct pso_pointer initialise_environment( uint32_t node ) {
debug_print( L"\nEnvironment initialised successfully.\n",
DEBUG_BOOTSTRAP, 0 );
initialise_privileged_keywords(frame_pointer);
initialise_privileged_keywords( frame_pointer );
result = inc_ref( initialise_function_bindings(push_local(
frame_pointer, make_frame_with_env(0, frame_pointer, result))));
result =
inc_ref( initialise_function_bindings
( push_local
( frame_pointer,
make_frame_with_env( 0, frame_pointer, result ) ) ) );
dec_ref(frame_pointer);
dec_ref( frame_pointer );
}
return result;
return result;
}

410
src/c/environment/function_bindings.c
View file

@ -59,34 +59,40 @@
*/
struct pso_pointer
bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_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);
bind_function( struct pso_pointer frame_pointer, wchar_t *name, wchar_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_layer, privileged_keyword_bootstrap),
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 meta = make_cons( frame_pointer,
make_cons( frame_pointer,
privileged_keyword_layer,
privileged_keyword_bootstrap ),
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);
struct pso_pointer r = make_function( frame_pointer, meta, executable );
debug_print(doc, DEBUG_BOOTSTRAP, 0);
if (!exceptionp(r)) {
debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0);
result =
make_cons(frame_pointer, make_cons(frame_pointer, n, r), result);
} else {
debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0);
}
debug_print( doc, DEBUG_BOOTSTRAP, 0 );
if ( !exceptionp( r ) ) {
debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 );
result =
make_cons( frame_pointer, make_cons( frame_pointer, n, r ),
result );
} else {
debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 );
}
return result;
return result;
}
/**
@ -94,40 +100,46 @@ bind_function(struct pso_pointer frame_pointer, wchar_t *name, wchar_t *doc,
* this `name` in the `oblist`.
*/
struct pso_pointer
bind_special(struct pso_pointer frame_pointer, wchar_t *name, wchar_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);
bind_special( struct pso_pointer frame_pointer, wchar_t *name, wchar_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 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);
struct pso_pointer r = make_special( frame_pointer, meta, executable );
debug_print(doc, DEBUG_BOOTSTRAP, 0);
if (!exceptionp(r)) {
debug_print(L"... bound\n", DEBUG_BOOTSTRAP, 0);
result =
make_cons(frame_pointer, make_cons(frame_pointer, n, r), result);
} else {
debug_print(L"... failed to bind\n", DEBUG_BOOTSTRAP, 0);
}
debug_print( doc, DEBUG_BOOTSTRAP, 0 );
if ( !exceptionp( r ) ) {
debug_print( L"... bound\n", DEBUG_BOOTSTRAP, 0 );
result =
make_cons( frame_pointer, make_cons( frame_pointer, n, r ),
result );
} else {
debug_print( L"... failed to bind\n", DEBUG_BOOTSTRAP, 0 );
}
return result;
return result;
}
struct function_data {
wchar_t *name;
wchar_t *documentation;
void *executable;
wchar_t *name;
wchar_t *documentation;
void *executable;
};
/* right, the problem with all those pretty '#ifdefs' which might allow us to
@ -140,152 +152,151 @@ struct function_data {
/** initialisers for functions */
struct function_data function_initialisers[] = {
#ifdef _psse_io_io_h
{L"close", L"(close stream): close `stream`.", &lisp_close},
{L"open",
L"(open stream), (open stream write?): open `stream`; if `write?` is "
L"present and is non-nil, open for writing, else for reading.",
&lisp_open},
{L"slurp",
L"(slurp stream): read the whole contents of this `stream`, "
L"which may "
L"be an open stream open for reading or a URL, into a string, and return "
L"the "
L"string.",
&lisp_slurp},
{L"close", L"(close stream): close `stream`.", &lisp_close},
{L"open",
L"(open stream), (open stream write?): open `stream`; if `write?` is "
L"present and is non-nil, open for writing, else for reading.",
&lisp_open},
{L"slurp",
L"(slurp stream): read the whole contents of this `stream`, "
L"which may "
L"be an open stream open for reading or a URL, into a string, and return "
L"the " L"string.",
&lisp_slurp},
#endif
#ifdef __psse_io_peek_h
{L"peek",
L"(peek stream): return the next character which may be read from "
L"`stream`, without removing it.",
&peek},
{L"peek",
L"(peek stream): return the next character which may be read from "
L"`stream`, without removing it.",
&peek},
#endif
#ifdef __psse_io_print_h
{L"print",
L"(print object), (print object stream) print this `object` in a format "
L"suitable to be read by `read`, q.v.; if `stream` is specified and is a "
L"stream open for writing, to that stream.",
&print},
{L"princ",
L"(princ object), (princ object stream) print this `object` in a format "
L"more suited to human readers; if `stream` is specified and is a stream "
L"open for writing, to that stream.",
&print},
{L"print",
L"(print object), (print object stream) print this `object` in a format "
L"suitable to be read by `read`, q.v.; if `stream` is specified and is a "
L"stream open for writing, to that stream.",
&print},
{L"princ",
L"(princ object), (princ object stream) print this `object` in a format "
L"more suited to human readers; if `stream` is specified and is a stream "
L"open for writing, to that stream.",
&print},
#endif
#ifdef __psse_io_read_h
{L"read",
L"(read stream) read one complete Lisp expression from `stream`, and "
L"return that expression unevaluated.",
&read},
{L"read-character",
L"(read-character stream): read a single character from `stream` and "
L"return it.",
&read_character},
{L"read-number",
L"(read-number stream): read a number from `stream` and return it.",
&read_number},
{L"read-symbol",
L"(read-symbol stream): read a symbol from `stream` and return it.",
&read_symbol},
{L"read",
L"(read stream) read one complete Lisp expression from `stream`, and "
L"return that expression unevaluated.",
&read},
{L"read-character",
L"(read-character stream): read a single character from `stream` and "
L"return it.",
&read_character},
{L"read-number",
L"(read-number stream): read a number from `stream` and return it.",
&read_number},
{L"read-symbol",
L"(read-symbol stream): read a symbol from `stream` and return it.",
&read_symbol},
#endif
#ifdef __psse_ops_assoc_h
{L"assoc",
L"(assoc key store): search `store` for the value associated with "
L"`key`.",
&assoc},
{L"assoc",
L"(assoc key store): search `store` for the value associated with "
L"`key`.",
&assoc},
#endif
#ifdef __psse_ops_bind_h
{L"bind!",
L"(bind! key value store): bind `key` to `value` in this store, modifying "
L"the store if it is writable to the user, otherwise returning a new "
L"store",
&bind},
{L"bind!",
L"(bind! key value store): bind `key` to `value` in this store, modifying "
L"the store if it is writable to the user, otherwise returning a new "
L"store",
&bind},
#endif
#ifdef __psse_ops_eq_h
{L"eq",
L"(eq args...): shallow, cheap equality; returns `t` if all `args...` "
L"are the same object, else `nil`.",
&eq},
{L"equal",
L"(equal a b): expensive, deep equality: returns `t` if objects `a` "
L"and `b` have recursively equal value.",
&equal},
{L"eq",
L"(eq args...): shallow, cheap equality; returns `t` if all `args...` "
L"are the same object, else `nil`.",
&eq},
{L"equal",
L"(equal a b): expensive, deep equality: returns `t` if objects `a` "
L"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.
{L"apply",
L"(apply fn args...): apply this `fn` to these `args...` and return "
L"their value.",
&lisp_apply},
{L"eval",
L"(eval expression): evaluate this `expression` and return its value",
&lisp_eval},
// TODO: there's a lot of other stuff in eval_apply.c, which ought to be in
// other files but at present isn't.
{L"apply",
L"(apply fn args...): apply this `fn` to these `args...` and return "
L"their value.",
&lisp_apply},
{L"eval",
L"(eval expression): evaluate this `expression` and return its value",
&lisp_eval},
#endif
#ifdef __psse_ops_inspect_h
{L"inspect",
L"(inspect expr), (inspect expr write-stream): inspect one complete "
L"lisp expression and return `nil`. If `write-stream` is specified and "
L"is a write stream, then print to that stream, else to the stream "
L"which is the value of `*out*` in the environment.",
&lisp_inspect},
{L"inspect",
L"(inspect expr), (inspect expr write-stream): inspect one complete "
L"lisp expression and return `nil`. If `write-stream` is specified and "
L"is a write stream, then print to that stream, else to the stream "
L"which is the value of `*out*` in the environment.",
&lisp_inspect},
#endif
#ifdef __psse_ops_keys_h
{L"keys", L"(keys store): returns a list of the keys in this `store`.",
&lisp_keys},
{L"keys", L"(keys store): returns a list of the keys in this `store`.",
&lisp_keys},
#endif
#ifdef __psse_ops_list_ops_h
{L"count",
L"(count sequence): returns the number of top level elements in "
L"`sequence`.",
&count},
{L"count",
L"(count sequence): returns the number of top level elements in "
L"`sequence`.",
&count},
#endif
#ifdef __psse_ops_mapcar_h
{L"mapcar",
L"(mapcar fn list): map this `fn` over this `list`, and return a list "
L"of the results.",
&lisp_mapcar},
{L"mapcar",
L"(mapcar fn list): map this `fn` over this `list`, and return a list "
L"of the results.",
&lisp_mapcar},
#endif
#ifdef __psse_ops_progn_h
{L"progn",
L"(progn expressions...): Evaluate each expression in "
L"`expressions` in turn and return the value of the last.",
&lisp_progn},
{L"progn",
L"(progn expressions...): Evaluate each expression in "
L"`expressions` in turn and return the value of the last.",
&lisp_progn},
#endif
#ifdef __psse_ops_repl_h
{L"repl", L"(repl show_prompt?): Start a new read, eval, print loop.",
&repl},
{L"repl", L"(repl show_prompt?): Start a new read, eval, print loop.",
&repl},
#endif
#ifdef __psse_ops_reverse_h
{L"reverse",
L"(reverse sequence): return a sequence like this `sequence`, but with "
L"the order of top level elements reversed.",
&reverse},
{L"reverse",
L"(reverse sequence): return a sequence like this `sequence`, but with "
L"the order of top level elements reversed.",
&reverse},
#endif
#ifdef __psse_ops_truth_h
{L"and",
L"(and expressions...): returns `t` if none of these `expressions...` "
L"evaluates to `nil`, else `nil`.",
&and},
{L"nil?",
L"(nil? expression): returns `t` if `expression` evaluates to `nil`, else "
L"`nil`.",
&nilp},
{L"not",
L"(not expression): returns `t` unless `expression` evaluates to `nil`, "
L"else "
L"`nil`.",
&not},
{L"or",
L"(or expressions...): returns `nil` if every one of these `expressions...` "
L"evaluates to `nil`, else `t`.",
&or},
{L"true?",
L"(true? expression): returns `t` if `expression` evaluates to `t`, else "
L"`nil`.",
&truep},
{L"and",
L"(and expressions...): returns `t` if none of these `expressions...` "
L"evaluates to `nil`, else `nil`.",
&and},
{L"nil?",
L"(nil? expression): returns `t` if `expression` evaluates to `nil`, else "
L"`nil`.",
&nilp},
{L"not",
L"(not expression): returns `t` unless `expression` evaluates to `nil`, "
L"else " L"`nil`.",
&not},
{L"or",
L"(or expressions...): returns `nil` if every one of these `expressions...` "
L"evaluates to `nil`, else `t`.",
&or},
{L"true?",
L"(true? expression): returns `t` if `expression` evaluates to `t`, else "
L"`nil`.",
&truep},
#endif
{L"END MARKER", L"END MARKER", NULL}};
{L"END MARKER", L"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
@ -296,41 +307,48 @@ struct function_data function_initialisers[] = {
/** initialisers for special forms */
struct function_data special_initialisers[] = {
#ifdef __psse_ops_cond_h
{L"cond",
L"(cond clauses...): special form; conditional. Each `clause` is expected "
L"to be a "
L"list; if the first item in such a list evaluates to non-nil, the "
L"remaining items in that list are evaluated in turn and the value of "
L"the last returned. If no arg `clause` has a first element which "
L"evaluates to non nil, then nil is returned",
&lisp_cond},
{L"cond",
L"(cond clauses...): special form; conditional. Each `clause` is expected "
L"to be a "
L"list; if the first item in such a list evaluates to non-nil, the "
L"remaining items in that list are evaluated in turn and the value of "
L"the last returned. If no arg `clause` has a first element which "
L"evaluates to non nil, then nil is returned",
&lisp_cond},
#endif
#ifdef __psse_ops_quote_h
{L"quote",
L"(quote expression): special form; protect `expression` from "
L"evaluation.",
&quote},
{L"quote",
L"(quote expression): special form; protect `expression` from "
L"evaluation.",
&quote},
#endif
{L"END MARKER", L"END MARKER", NULL}};
{L"END MARKER", L"END MARKER", NULL}
};
struct pso_pointer
initialise_function_bindings(struct pso_pointer frame_pointer) {
struct pso_pointer result = fetch_env(frame_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++) {
struct pso_pointer b = c_car( bind_function( frame_pointer,
function_initialisers[i].name,
function_initialisers[i].documentation,
function_initialisers[i].executable));
result = make_cons( frame_pointer, b, result);
}
for (int i = 0; special_initialisers[i].executable != NULL; i++) {
struct pso_pointer b = c_car( bind_special( frame_pointer,
special_initialisers[i].name,
special_initialisers[i].documentation,
special_initialisers[i].executable));
result = make_cons( frame_pointer, b, result);
}
for ( int i = 0; function_initialisers[i].executable != NULL; i++ ) {
struct pso_pointer b = c_car( bind_function( frame_pointer,
function_initialisers[i].
name,
function_initialisers[i].
documentation,
function_initialisers[i].
executable ) );
result = make_cons( frame_pointer, b, result );
}
for ( int i = 0; special_initialisers[i].executable != NULL; i++ ) {
struct pso_pointer b = c_car( bind_special( frame_pointer,
special_initialisers[i].
name,
special_initialisers[i].
documentation,
special_initialisers[i].
executable ) );
result = make_cons( frame_pointer, b, result );
}
return result;
}
return result;
}

4
src/c/environment/function_bindings.h
View file

@ -13,5 +13,5 @@
#define __psse_environment_function_bindings_h
struct pso_pointer
initialise_function_bindings(struct pso_pointer frame_pointer);
#endif
initialise_function_bindings( struct pso_pointer frame_pointer );
#endif

19
src/c/environment/privileged_keywords.c
View file

@ -63,12 +63,13 @@ struct pso_pointer privileged_keyword_user;
#define load_and_lock(var,val)(var = lock_object(c_string_to_lisp_keyword(frame_pointer, val)))
struct pso_pointer initialise_privileged_keywords(struct pso_pointer frame_pointer) {
load_and_lock(privileged_keyword_bootstrap, PK_BOOTSTRAP);
load_and_lock(privileged_keyword_documentation, PK_DOCUMENTATION);
load_and_lock(privileged_keyword_layer, PK_LAYER);
load_and_lock(privileged_keyword_location, PK_LOCATION);
load_and_lock( privileged_keyword_name, PK_NAME);
load_and_lock(privileged_keyword_system, PK_SYSTEM);
load_and_lock(privileged_keyword_user, PK_USER);
}
struct pso_pointer initialise_privileged_keywords( struct pso_pointer
frame_pointer ) {
load_and_lock( privileged_keyword_bootstrap, PK_BOOTSTRAP );
load_and_lock( privileged_keyword_documentation, PK_DOCUMENTATION );
load_and_lock( privileged_keyword_layer, PK_LAYER );
load_and_lock( privileged_keyword_location, PK_LOCATION );
load_and_lock( privileged_keyword_name, PK_NAME );
load_and_lock( privileged_keyword_system, PK_SYSTEM );
load_and_lock( privileged_keyword_user, PK_USER );
}

2
src/c/environment/privileged_keywords.h
View file

@ -29,5 +29,5 @@ extern struct pso_pointer privileged_keyword_name;
extern struct pso_pointer privileged_keyword_system;
extern struct pso_pointer privileged_keyword_user;
struct pso_pointer initialise_privileged_keywords( struct pso_pointer env);
struct pso_pointer initialise_privileged_keywords( struct pso_pointer env );
#endif /* SRC_C_ENVIRONMENT_PRIVILEGED_KEYWORDS_H_ */

2
src/c/io/alphabets.h
View file

@ -16,4 +16,4 @@
#define GREEK L"ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσςΤτΥυΦφΧχΨψΩω"
#define ELDERFUTHARK L"ᚠᚢᚦᚨᚱᚲᚷᚹᚺᚾᛁᛃᛈᛇᛉᛊᛏᛒᛖᛗᛚᛜᛞᛟ"
#endif
#endif

14
src/c/io/io.c
View file

@ -371,8 +371,8 @@ struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer result = nil;
if ( characterp( c ) && readp( r ) ) {
if ( url_ungetwc( ( wint_t )
( pointer_to_object( c )->payload.character.
character ),
( pointer_to_object( c )->payload.
character.character ),
pointer_to_object( r )->payload.stream.stream ) >=
0 ) {
result = t;
@ -393,13 +393,13 @@ struct pso_pointer push_back_character( struct pso_pointer c,
* @param env my environment.
* @return T if the stream was successfully closed, else nil.
*/
struct pso_pointer lisp_close( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_close( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) || writep( fetch_arg( frame, 0 ) ) ) {
if ( url_fclose
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.stream.
stream )
( pointer_to_object( fetch_arg( frame, 0 ) )->payload.
stream.stream )
== 0 ) {
result = t;
}
@ -593,7 +593,7 @@ URL_FILE *stream_get_url_file( struct pso_pointer s ) {
* @param frame_pointer a pointer to my stack frame.
* @return a stream open on the URL indicated by the first argument.
*/
struct pso_pointer lisp_open( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_open( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( stringp( fetch_arg( frame, 0 ) ) ) {
@ -651,7 +651,7 @@ struct pso_pointer lisp_open( struct pso_pointer frame_pointer) {
* @return return a string representing all characters from the stream
* indicated by arg 0
*/
struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if ( readp( fetch_arg( frame, 0 ) ) ) {

27
src/c/io/io.h
View file

@ -24,9 +24,10 @@
extern CURLSH *io_share;
int initialise_io();
struct pso_pointer initialise_default_streams(struct pso_pointer frame_pointer,
struct pso_pointer env);
int initialise_io( );
struct pso_pointer initialise_default_streams( struct pso_pointer
frame_pointer,
struct pso_pointer env );
#define C_IO_IN L"*in*"
#define C_IO_OUT L"*out*"
@ -49,19 +50,19 @@ extern struct pso_pointer lisp_stderr;
extern struct pso_pointer lisp_io_prompt;
URL_FILE *file_to_url_file(FILE *f);
wint_t url_fgetwc(URL_FILE *input);
wint_t url_ungetwc(wint_t wc, URL_FILE *input);
URL_FILE *file_to_url_file( FILE * f );
wint_t url_fgetwc( URL_FILE * input );
wint_t url_ungetwc( wint_t wc, URL_FILE * input );
struct pso_pointer push_back_character(struct pso_pointer c,
struct pso_pointer r);
struct pso_pointer push_back_character( struct pso_pointer c,
struct pso_pointer r );
struct pso_pointer get_default_stream(bool inputp, struct pso_pointer env);
struct pso_pointer get_default_stream( bool inputp, struct pso_pointer env );
URL_FILE *stream_get_url_file(struct pso_pointer s);
URL_FILE *stream_get_url_file( struct pso_pointer s );
struct pso_pointer lisp_close(struct pso_pointer frame_pointer);
struct pso_pointer lisp_open(struct pso_pointer frame_pointer);
struct pso_pointer lisp_slurp(struct pso_pointer frame_pointer);
struct pso_pointer lisp_close( struct pso_pointer frame_pointer );
struct pso_pointer lisp_open( struct pso_pointer frame_pointer );
struct pso_pointer lisp_slurp( struct pso_pointer frame_pointer );
#endif

23
src/c/io/peek.c
View file

@ -25,18 +25,17 @@
*
* (peek stream)
*/
struct pso_pointer peek(struct pso_pointer frame_pointer) {
struct pso_pointer result = nil;
struct pso_pointer input =
pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0];
struct pso_pointer peek( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso_pointer input =
pointer_to_pso4( frame_pointer )->payload.stack_frame.arg[0];
if (readp(input)) {
URL_FILE *stream = pointer_to_object(input)->payload.stream.stream;
wint_t c = url_fgetwc(stream);
url_ungetwc(c, stream);
if ( readp( input ) ) {
URL_FILE *stream = pointer_to_object( input )->payload.stream.stream;
wint_t c = url_fgetwc( stream );
url_ungetwc( c, stream );
result = make_character(frame_pointer, c);
}
return result;
result = make_character( frame_pointer, c );
}
return result;
}

55
src/c/io/print.c
View file

@ -83,8 +83,7 @@ struct pso_pointer print_string_like_thing( struct pso_pointer p,
if ( keywordp( p ) || stringp( p ) || symbolp( p ) ) {
for ( struct pso_pointer cursor = p; !c_nilp( cursor );
cursor = pointer_to_object( cursor )->payload.string.cdr ) {
wchar_t wc =
pointer_to_object( cursor )->payload.string.character;
wchar_t wc = pointer_to_object( cursor )->payload.string.character;
write_char( wc, output, escape );
}
@ -189,14 +188,15 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
} else {
url_fputws( L"<broken exception :-( >", output );
}
} break;
case FUNCTIONTV: {
struct pso2 *function = pointer_to_object(p);
url_fputws(L"<function: ", output);
in_write(function->payload.function.meta, output, escape,
indent);
write_char( L'>', output, escape );
} break;
}
break;
case FUNCTIONTV:{
struct pso2 *function = pointer_to_object( p );
url_fputws( L"<function: ", output );
in_write( function->payload.function.meta, output, escape,
indent );
write_char( L'>', output, escape );
} break;
case INTEGERTV:
url_fwprintf( output, L"%d",
( int64_t ) ( object->payload.integer.value ) );
@ -217,13 +217,13 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output,
indent );
write_char( L'>', output, escape );
break;
case SPECIALTV: {
struct pso2 *function = pointer_to_object(p);
url_fputws(L"<special form: ", output);
in_write(function->payload.function.meta, output, escape,
indent);
write_char( L'>', output, escape );
} break;
case SPECIALTV:{
struct pso2 *function = pointer_to_object( p );
url_fputws( L"<special form: ", output );
in_write( function->payload.function.meta, output, escape,
indent );
write_char( L'>', output, escape );
} break;
case TRUETV:
write_char( L't', output, escape );
break;
@ -281,15 +281,19 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) {
return result;
}
struct pso_pointer c_write(struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after) {
struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(5, frame_pointer, object, stream, escape ? t : nil,
nl_before ? t : nil, nl_after ? t : nil));
struct pso_pointer result = push_local(frame_pointer, write(next_pointer));
struct pso_pointer c_write( struct pso_pointer frame_pointer,
struct pso_pointer object,
struct pso_pointer stream, bool escape,
bool nl_before, bool nl_after ) {
struct pso_pointer next_pointer =
push_local( frame_pointer,
make_frame( 5, frame_pointer, object, stream,
escape ? t : nil,
nl_before ? t : nil, nl_after ? t : nil ) );
struct pso_pointer result =
push_local( frame_pointer, write( next_pointer ) );
return result;
return result;
}
/**
@ -333,4 +337,3 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) {
return result;
}

7
src/c/io/print.h
View file

@ -26,9 +26,10 @@ struct pso_pointer princ( struct pso_pointer frame_pointer );
struct pso_pointer in_write( struct pso_pointer p, URL_FILE * output,
bool escape, int indent );
struct pso_pointer c_write(struct pso_pointer frame_pointer,
struct pso_pointer object, struct pso_pointer stream,
bool escape, bool nl_before, bool nl_after);
struct pso_pointer c_write( struct pso_pointer frame_pointer,
struct pso_pointer object,
struct pso_pointer stream, bool escape,
bool nl_before, bool nl_after );
#define c_print(f,o,s)(c_write(f,o,s,true,true,false))
#define c_princ(f,o,s)(c_write(f,o,s,false,true,false))

23
src/c/io/read.c
View file

@ -146,15 +146,17 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) {
if ( iswdigit( c ) ){value = ( value * base ) + ( ( int ) c - ( int ) L'0' );}
if ( iswdigit( c ) ) {
value = ( value * base ) + ( ( int ) c - ( int ) L'0' );
}
}
url_ungetwc( c, input );
result = make_integer( frame_pointer, value );
} // else exception?
#ifdef DEBUG
debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value );
debug_dump_object(result, DEBUG_IO, 1);
debug_printf( DEBUG_IO, 0, L"\nRead number %ld\n", value );
debug_dump_object( result, DEBUG_IO, 1 );
#endif
return result;
@ -185,13 +187,12 @@ struct pso_pointer read_symbol( struct pso_pointer frame_pointer ) {
url_ungetwc( c, input );
result = c_reverse( frame_pointer, result );
}
#ifdef DEBUG
debug_print( L"\nRead symbol `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0);
debug_print( L"`\n\t", DEBUG_IO, 0);
debug_dump_object(result, DEBUG_IO, 1);
#endif
debug_print( L"\nRead symbol `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0 );
debug_print( L"`\n\t", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 1 );
#endif
return result;
}
@ -283,8 +284,8 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) {
#ifdef DEBUG
debug_print( L"Read expression: `", DEBUG_IO, 0 );
debug_print_object( result, DEBUG_IO, 0 );
debug_print( L"`\n", DEBUG_IO, 0 );
debug_dump_object(result, DEBUG_IO, 1);
debug_print( L"`\n", DEBUG_IO, 0 );
debug_dump_object( result, DEBUG_IO, 1 );
#endif
return result;

327
src/c/memory/dump.c
View file

@ -45,13 +45,14 @@
void dump_string_cell( URL_FILE *output, wchar_t *prefix,
struct pso_pointer pointer ) {
struct pso2* object = pointer_to_object( pointer );
struct pso2 *object = pointer_to_object( pointer );
if ( object->payload.string.character == 0 ) {
url_fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
object->payload.string.cdr.page,
object->payload.string.cdr.offset, object->header.count );
object->payload.string.cdr.offset,
object->header.count );
} else {
url_fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n",
@ -60,17 +61,21 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
object->payload.string.character,
object->payload.string.hash,
object->payload.string.cdr.page,
object->payload.string.cdr.offset, object->header.count );
object->payload.string.cdr.offset,
object->header.count );
url_fwprintf( output, L"\t\t value: " );
in_write( pointer, output, false, 0);
if (stringlikep(pointer)) {
url_fwprintf( output, L"\n\t\t structure: " );
for ( struct pso_pointer cursor = pointer; !c_nilp(cursor); cursor = c_cdr(cursor)) {
wint_t c = pointer_to_object(cursor)->payload.string.character;
char* tag = (pointer_to_object(cursor)->header.tag.bytes.mnemonic);
url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c);
}
}
in_write( pointer, output, false, 0 );
if ( stringlikep( pointer ) ) {
url_fwprintf( output, L"\n\t\t structure: " );
for ( struct pso_pointer cursor = pointer; !c_nilp( cursor );
cursor = c_cdr( cursor ) ) {
wint_t c =
pointer_to_object( cursor )->payload.string.character;
char *tag =
( pointer_to_object( cursor )->header.tag.bytes.mnemonic );
url_fwprintf( output, L"[%3.3s %lc (%d)]", tag, c, c );
}
}
url_fwprintf( output, L"\n" );
}
@ -79,9 +84,9 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
void dump_frame_context_fragment( URL_FILE *output,
struct pso_pointer frame_pointer,
uint arg) {
if ( stackp(frame_pointer )) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
uint arg ) {
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L" <= " );
in_write( frame->payload.stack_frame.arg[arg], output, false, 0 );
@ -90,7 +95,7 @@ void dump_frame_context_fragment( URL_FILE *output,
void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
int depth ) {
if ( stackp(frame_pointer) ) {
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L"\tContext: " );
@ -98,7 +103,8 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
int i = 0;
for ( struct pso_pointer cursor = frame_pointer;
i++ < depth && !c_nilp( cursor );
cursor = pointer_to_pso4(cursor)->payload.stack_frame.previous ) {
cursor =
pointer_to_pso4( cursor )->payload.stack_frame.previous ) {
dump_frame_context_fragment( output, cursor, 0 );
}
@ -112,18 +118,20 @@ void dump_frame_context( URL_FILE *output, struct pso_pointer frame_pointer,
* @param frame_pointer the pointer to the frame
*/
void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) {
if ( stackp(frame_pointer) ) {
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
frame->payload.stack_frame.depth, frame->payload.stack_frame.args );
frame->payload.stack_frame.depth,
frame->payload.stack_frame.args );
dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->payload.stack_frame.args; arg++ ) {
struct pso2* object = pointer_to_object( fetch_arg(frame, arg));
struct pso2 *object = pointer_to_object( fetch_arg( frame, arg ) );
url_fwprintf( output, L"\tArg %d:\t%3.3s\tcount: %10u\tvalue: ",
arg, object->header.tag.bytes.mnemonic[0], object->header.count );
arg, object->header.tag.bytes.mnemonic[0],
object->header.count );
in_write( frame->payload.stack_frame.arg[arg], output, false, 0 );
url_fputws( L"\n", output );
@ -139,13 +147,12 @@ void dump_frame( URL_FILE *output, struct pso_pointer frame_pointer ) {
void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) {
if ( exceptionp( pointer ) ) {
struct pso3* exep = pointer_to_pso3( pointer);
struct pso3 *exep = pointer_to_pso3( pointer );
in_write( exep->payload.exception.message, output, false, 0 );
url_fputws( L"\n", output );
dump_stack_trace( output,
exep->payload.exception.stack );
dump_stack_trace( output, exep->payload.exception.stack );
} else {
while ( stackp( pointer) ) {
while ( stackp( pointer ) ) {
dump_frame( output, pointer );
pointer = pointer_to_pso4( pointer )->payload.stack_frame.previous;
}
@ -168,142 +175,142 @@ void dump_stack_trace( URL_FILE *output, struct pso_pointer pointer ) {
* to be dumped.
*/
struct pso_pointer dump_object( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso_pointer stream = nil;
struct pso_pointer pointer = nil;
if (stackp(frame_pointer)) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer result = nil;
struct pso_pointer stream = nil;
struct pso_pointer pointer = nil;
pointer = fetch_arg( frame, 0);
stream = fetch_arg( frame, 1);
} else {
pointer = frame_pointer;
}
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
if (!writep(stream)) {
stream = lisp_stderr;
}
// URL_FILE* output = file_to_url_file(stderr);
// url_fputws( L"\ndump_object printing to output stream; metadata: ", output );
// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 );
// url_fputws( L"\n", output );
// fflush(stderr);
URL_FILE* output = pointer_to_object(stream)->payload.stream.stream;
pointer = fetch_arg( frame, 0 );
stream = fetch_arg( frame, 1 );
} else {
pointer = frame_pointer;
}
if (c_nilp(pointer)) {
// the object at (node, 0, 0) ought to have been initialised, but may not
// have been...
url_fputws(L"nil of size class 2 at page 0, offset 0, count xxxx\n", output );
} else {
struct pso2* object = pointer_to_object( pointer );
url_fwprintf( output, L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n",
object->header.tag.bytes.mnemonic,
get_tag_value(pointer),
object->header.tag.bytes.size_class,
pointer.page, pointer.offset,
object->header.count );
switch ( get_tag_value( pointer) ) {
case CONSTV:
url_fwprintf( output,
L"\t\tCons object: car at page %d offset %d, cdr at page %d "
L"offset %d :",
object->payload.cons.car.page,
object->payload.cons.car.offset,
object->payload.cons.cdr.page,
object->payload.cons.cdr.offset);
in_write( pointer, output, false, 0 );
url_fputws( L"\n", output );
break;
case EXCEPTIONTV:
url_fwprintf( output, L"\t\tException object: " );
dump_stack_trace( output, pointer );
break;
case FREETV:
url_fwprintf( output,
L"\t\tFree object: next at page %d offset %d\n",
object->payload.free.next.page,
object->payload.free.next.offset);
break;
case INTEGERTV:
url_fwprintf( output, L"\t\tInteger object: value %ld\n",
object->payload.integer.value );
break;
case KEYTV:
dump_string_cell( output, L"Keyword", pointer );
break;
// case LAMBDATV:
// url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " );
// in_write( output, object->payload.lambda.args );
// url_fwprintf( output, L";\n\t\t\tbody: " );
// in_write( output, object->payload.lambda.body );
// url_fputws( L"\n", output );
// break;
// case NILTV:
// break;
// case NLAMBDATV:
// url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " );
// in_write( output, object->payload.lambda.args );
// url_fwprintf( output, L";\n\t\t\tbody: " );
// in_write( output, object->payload.lambda.body );
// url_fputws( L"\n", output );
// break;
// case RATIOTV:
// url_fwprintf( output,
// L"\t\tRational object: value %ld/%ld, count %u\n",
// pointer_to_object( object->payload.ratio.dividend ).
// payload.integer.value,
// pointer_to_object( object->payload.ratio.divisor ).
// payload.integer.value, object->count );
// break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );
in_write( object->payload.stream.meta, output, false, 0 );
url_fputws( L"\n", output );
break;
// case REALTV:
// url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n",
// object->payload.real.value, object->count );
// break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
// case TRUETV:
// break;
// case VECTORPOINTTV:{
// url_fwprintf( output,
// L"\t\tPointer to vector-space object at %p\n",
// object->payload.vectorp.address );
// struct vector_space_object *vso = object->payload.vectorp.address;
// url_fwprintf( output,
// L"\t\tVector space object of type %4.4s (%d), payload size "
// L"%d bytes\n",
// &vso->header.tag.bytes, vso->header.tag.value,
// vso->header.size );
//
// switch ( vso->header.tag.value ) {
// case STACKFRAMETV:
// dump_frame( output, pointer );
// break;
// case HASHTV:
// dump_map( output, pointer );
// break;
// }
// }
// break;
case WRITETV:
url_fputws( L"\t\tOutput stream; metadata: ", output );
in_write( object->payload.stream.meta, output, false, 0 );
url_fputws( L"\n", output );
break;
}
}
return result;
if ( !writep( stream ) ) {
stream = lisp_stderr;
}
// URL_FILE* output = file_to_url_file(stderr);
// url_fputws( L"\ndump_object printing to output stream; metadata: ", output );
// in_write( pointer_to_object(stream)->payload.stream.meta, output, false, 0 );
// url_fputws( L"\n", output );
// fflush(stderr);
URL_FILE *output = pointer_to_object( stream )->payload.stream.stream;
if ( c_nilp( pointer ) ) {
// the object at (node, 0, 0) ought to have been initialised, but may not
// have been...
url_fputws( L"nil of size class 2 at page 0, offset 0, count xxxx\n",
output );
} else {
struct pso2 *object = pointer_to_object( pointer );
url_fwprintf( output,
L"\t%3.3s (%d) of size class %d at page %d, offset %d count %u\n",
object->header.tag.bytes.mnemonic,
get_tag_value( pointer ),
object->header.tag.bytes.size_class, pointer.page,
pointer.offset, object->header.count );
switch ( get_tag_value( pointer ) ) {
case CONSTV:
url_fwprintf( output,
L"\t\tCons object: car at page %d offset %d, cdr at page %d "
L"offset %d :",
object->payload.cons.car.page,
object->payload.cons.car.offset,
object->payload.cons.cdr.page,
object->payload.cons.cdr.offset );
in_write( pointer, output, false, 0 );
url_fputws( L"\n", output );
break;
case EXCEPTIONTV:
url_fwprintf( output, L"\t\tException object: " );
dump_stack_trace( output, pointer );
break;
case FREETV:
url_fwprintf( output,
L"\t\tFree object: next at page %d offset %d\n",
object->payload.free.next.page,
object->payload.free.next.offset );
break;
case INTEGERTV:
url_fwprintf( output, L"\t\tInteger object: value %ld\n",
object->payload.integer.value );
break;
case KEYTV:
dump_string_cell( output, L"Keyword", pointer );
break;
// case LAMBDATV:
// url_fwprintf( output, L"\t\t\u03bb object;\n\t\t args: " );
// in_write( output, object->payload.lambda.args );
// url_fwprintf( output, L";\n\t\t\tbody: " );
// in_write( output, object->payload.lambda.body );
// url_fputws( L"\n", output );
// break;
// case NILTV:
// break;
// case NLAMBDATV:
// url_fwprintf( output, L"\t\tn\u03bb object; \n\t\targs: " );
// in_write( output, object->payload.lambda.args );
// url_fwprintf( output, L";\n\t\t\tbody: " );
// in_write( output, object->payload.lambda.body );
// url_fputws( L"\n", output );
// break;
// case RATIOTV:
// url_fwprintf( output,
// L"\t\tRational object: value %ld/%ld, count %u\n",
// pointer_to_object( object->payload.ratio.dividend ).
// payload.integer.value,
// pointer_to_object( object->payload.ratio.divisor ).
// payload.integer.value, object->count );
// break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );
in_write( object->payload.stream.meta, output, false, 0 );
url_fputws( L"\n", output );
break;
// case REALTV:
// url_fwprintf( output, L"\t\tReal object: value %Lf, count %u\n",
// object->payload.real.value, object->count );
// break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
// case TRUETV:
// break;
// case VECTORPOINTTV:{
// url_fwprintf( output,
// L"\t\tPointer to vector-space object at %p\n",
// object->payload.vectorp.address );
// struct vector_space_object *vso = object->payload.vectorp.address;
// url_fwprintf( output,
// L"\t\tVector space object of type %4.4s (%d), payload size "
// L"%d bytes\n",
// &vso->header.tag.bytes, vso->header.tag.value,
// vso->header.size );
//
// switch ( vso->header.tag.value ) {
// case STACKFRAMETV:
// dump_frame( output, pointer );
// break;
// case HASHTV:
// dump_map( output, pointer );
// break;
// }
// }
// break;
case WRITETV:
url_fputws( L"\t\tOutput stream; metadata: ", output );
in_write( object->payload.stream.meta, output, false, 0 );
url_fputws( L"\n", output );
break;
}
}
return result;
}

24
src/c/memory/pso.c
View file

@ -60,8 +60,8 @@ void print_allocation_table( ) {
}
#endif
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag,
uint8_t size_class);
struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer,
char *tag, uint8_t size_class );
/**
* @brief a means of creating a cons cell without using a stack frame, to
@ -88,20 +88,20 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
* get excessive spurius missing stack frame warnings. Not to be called
* outside this file!
*/
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag,
uint8_t size_class) {
struct pso_pointer cheaty_allocate( struct pso_pointer frame_pointer,
char *tag, uint8_t size_class ) {
struct pso_pointer result = pop_freelist( size_class );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating object of size class %d with tag `%s`... ",
size_class, tag );
L"\nAllocating object of size class %d with tag `%s`... ",
size_class, tag );
#endif
struct pso2 *obj = pointer_to_object( result );
strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH );
debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page,
result.offset );
result.offset );
if ( stackp( frame_pointer ) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
// You can't make a stack frame in the middle of making a stack
@ -116,7 +116,7 @@ struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag,
#ifdef DEBUG
debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC,
0 );
0 );
#endif
return result;
@ -147,7 +147,7 @@ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr );
}
return cheaty_allocate(frame_pointer, tag, size_class);
return cheaty_allocate( frame_pointer, tag, size_class );
}
@ -189,8 +189,10 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
L"\nIncremented object of type %3.3s, size class %d, "
L"at page %u, offset %u to count %u", ( ( char * )
&
( object->header.tag.
bytes.mnemonic
( object->
header.
tag.bytes.
mnemonic
[0] ) ),
( int ) object->header.tag.bytes.size_class,
pointer.page, pointer.offset, object->header.count );

4
src/c/memory/pso2.h
View file

@ -51,8 +51,8 @@ struct pso2 {
struct free_payload free;
struct function_payload function;
struct integer_payload integer;
struct lambda_payload lambda;
struct float_payload real;
struct lambda_payload lambda;
struct float_payload real;
struct function_payload special;
struct stream_payload stream;
struct string_payload string;

23
src/c/ops/assoc.c
View file

@ -45,7 +45,7 @@ struct pso_pointer search( struct pso_pointer key,
debug_print( L"In search; key is: `", DEBUG_BIND, 0 );
debug_print_object( key, DEBUG_BIND, 0 );
debug_print( L"`\n", DEBUG_BIND, 0 );
debug_dump_object(key, DEBUG_BIND, 1);
debug_dump_object( key, DEBUG_BIND, 1 );
#endif
if ( consp( store ) ) {
@ -54,9 +54,9 @@ struct pso_pointer search( struct pso_pointer key,
struct pso_pointer pair = c_car( cursor );
#ifdef DEBUG
debug_print( L"Checking `", DEBUG_BIND, 1 );
debug_print_object( c_car( pair), DEBUG_BIND, 0 );
debug_print(L"`\n", DEBUG_BIND, 2);
debug_dump_object(c_car(pair), DEBUG_BIND, 2);
debug_print_object( c_car( pair ), DEBUG_BIND, 0 );
debug_print( L"`\n", DEBUG_BIND, 2 );
debug_dump_object( c_car( pair ), DEBUG_BIND, 2 );
#endif
if ( consp( pair ) && c_equal( c_car( pair ), key ) ) {
@ -117,14 +117,13 @@ bool c_internedp( struct pso_pointer key, struct pso_pointer store ) {
*
* @return a pointer to the value of the key in the store, or nil if not found
*/
struct pso_pointer assoc(
struct pso_pointer frame_pointer ) {
struct pso_pointer assoc( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
frame->payload.stack_frame.
env ) );
return c_assoc( key, store );
}
@ -145,8 +144,8 @@ struct pso_pointer interned(
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
frame->payload.stack_frame.
env ) );
return c_interned( key, store );
}
@ -167,8 +166,8 @@ struct pso_pointer internedp(
struct pso_pointer key = fetch_arg( frame, 0 );
struct pso_pointer store = or( make_frame( 2, frame_pointer,
fetch_arg( frame, 1 ),
frame->payload.
stack_frame.env ) );
frame->payload.stack_frame.
env ) );
return c_internedp( key, store ) ? t : nil;
}

2
src/c/ops/assoc.h
View file

@ -16,7 +16,7 @@
#include "memory/pointer.h"
struct pso_pointer assoc(struct pso_pointer frame_pointer);
struct pso_pointer assoc( struct pso_pointer frame_pointer );
struct pso_pointer search( struct pso_pointer key,
struct pso_pointer store, bool return_key );

1
src/c/ops/bind.c
View file

@ -35,4 +35,3 @@ struct pso_pointer lisp_bind( struct pso_pointer frame_pointer ) {
return cons( make_frame( 2, frame_pointer, binding, store ) );
}

42
src/c/ops/cond.c
View file

@ -30,31 +30,34 @@
*/
struct pso_pointer eval_cond_clause( struct pso_pointer clause,
struct pso4 *frame,
struct pso_pointer frame_pointer) {
struct pso_pointer result = nil;
struct pso_pointer env = fetch_env(frame_pointer);
struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso_pointer env = fetch_env( frame_pointer );
#ifdef DEBUG
debug_print( L"\n\tCond clause: ", DEBUG_EVAL, 0 );
debug_print_object( clause, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
#endif
if ( consp( clause ) ) {
struct pso_pointer test_frame = push_local( frame_pointer, make_frame(1, frame_pointer, c_car(clause)));
struct pso_pointer val = lisp_eval(test_frame);
struct pso_pointer test_frame =
push_local( frame_pointer,
make_frame( 1, frame_pointer, c_car( clause ) ) );
struct pso_pointer val = lisp_eval( test_frame );
if ( !c_nilp( val ) ) {
result =
make_cons( frame_pointer, t,
c_progn( frame, frame_pointer, c_cdr( clause ), env ) );
c_progn( frame, frame_pointer, c_cdr( clause ),
env ) );
#ifdef DEBUG
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 );
debug_print_object( clause, DEBUG_EVAL, 0 );
debug_print( L" succeeded; returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
} else {
debug_print( L"\n\t\tCond clause ", DEBUG_EVAL, 0 );
debug_print_object( clause, DEBUG_EVAL, 0 );
@ -62,10 +65,11 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
#endif
}
} else {
result = throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ),
c_string_to_lisp_string
(frame_pointer, L"Arguments to `cond` must be lists" ),
frame_pointer );
result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"cond" ),
c_string_to_lisp_string( frame_pointer,
L"Arguments to `cond` must be lists" ),
frame_pointer );
}
return result;
@ -81,18 +85,18 @@ struct pso_pointer eval_cond_clause( struct pso_pointer clause,
*
* @return the value of the last expression of the first successful `clause`.
*/
struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) {
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer lisp_cond( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
bool done = false;
for ( int i = 0; ( i < frame->payload.stack_frame.args ) && !done; i++ ) {
struct pso_pointer clause_pointer = fetch_arg( frame, i );
// TODO: WHOOPS! This isn't right. If the test of a cond clause
// evaluates to non-nil, but the last form of the clause evaluates
// to nil, the form still succeeded and we should still exit `cond`.
//
// TODO: WHOOPS! This isn't right. If the test of a cond clause
// evaluates to non-nil, but the last form of the clause evaluates
// to nil, the form still succeeded and we should still exit `cond`.
//
result = eval_cond_clause( clause_pointer, frame, frame_pointer );
@ -105,7 +109,7 @@ struct pso_pointer lisp_cond(struct pso_pointer frame_pointer) {
#ifdef DEBUG
debug_print( L"\tCond returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
#endif
return result;

4
src/c/ops/eq.c
View file

@ -46,8 +46,8 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) {
if ( c_eq( a, b ) ) {
result = true;
} else if ( get_tag_value( a ) == get_tag_value( b ) ) {
/* assume true and try to falsify */
result = true;
/* assume true and try to falsify */
result = true;
struct pso2 *oa = pointer_to_object( a );
struct pso2 *ob = pointer_to_object( b );

375
src/c/ops/eval_apply.c
View file

@ -110,7 +110,7 @@ struct pso_pointer eval_form( struct pso_pointer frame_pointer ) {
debug_print( L" returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL );
debug_dump_object(result, DEBUG_EVAL, 1);
debug_dump_object( result, DEBUG_EVAL, 1 );
return result;
}
@ -155,11 +155,12 @@ struct pso_pointer eval_forms( struct pso_pointer frame_pointer ) {
*
* This is experimental. It almost certainly WILL change.
*/
struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_try( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer body_frame =
push_local( frame_pointer, make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) );
push_local( frame_pointer,
make_frame( 1, frame_pointer, fetch_arg( frame, 0 ) ) );
result = push_local( frame_pointer, lisp_progn( body_frame ) );
@ -167,16 +168,19 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
// TODO: need to put the exception into the environment!
struct pso_pointer catch_frame =
push_local( frame_pointer, make_frame_with_env( 1, frame_pointer,
make_cons( frame_pointer,
make_cons( frame_pointer,
make_cons
( frame_pointer,
make_cons
( frame_pointer,
c_string_to_lisp_symbol
( frame_pointer,
L"*exception*" ),
result ),
fetch_env
( frame_pointer ) ),
frame->payload.stack_frame.
arg[1] ) );
fetch_env
( frame_pointer ) ),
frame->payload.
stack_frame.arg
[1] ) );
result = push_local( frame_pointer, lisp_progn( catch_frame ) );
}
@ -195,7 +199,7 @@ struct pso_pointer lisp_try( struct pso_pointer frame_pointer) {
* @return the root namespace.
*/
struct pso_pointer
lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer) {
lisp_oblist( struct pso4 *frame, struct pso_pointer frame_pointer ) {
return oblist;
}
@ -235,10 +239,10 @@ struct pso_pointer compose_body( struct pso_pointer frame_pointer ) {
* @param env the environment in which it is to be intepreted.
* @return an interpretable function with these `args` and this `body`.
*/
struct pso_pointer
lisp_lambda( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4(frame_pointer);
return make_lambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) );
struct pso_pointer lisp_lambda( struct pso_pointer frame_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return make_lambda( frame_pointer, fetch_arg( frame, 0 ),
compose_body( frame_pointer ) );
}
/**
@ -253,22 +257,21 @@ lisp_lambda( struct pso_pointer frame_pointer ) {
* @return an interpretable special form with these `args` and this `body`.
*/
struct pso_pointer
lisp_nlambda( struct pso_pointer frame_pointer,
struct pso_pointer env ) {
struct pso4* frame = pointer_to_pso4(frame_pointer);
return make_nlambda( frame_pointer, fetch_arg(frame, 0), compose_body( frame_pointer ) );
lisp_nlambda( struct pso_pointer frame_pointer, struct pso_pointer env ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
return make_nlambda( frame_pointer, fetch_arg( frame, 0 ),
compose_body( frame_pointer ) );
}
/**
* Evaluate a lambda or nlambda expression.
*/
struct pso_pointer
eval_lambda( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso2 *lambda = pointer_to_object(fetch_arg(frame, 0));
struct pso_pointer args = fetch_arg( frame, 1);
struct pso_pointer eval_lambda( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso2 *lambda = pointer_to_object( fetch_arg( frame, 0 ) );
struct pso_pointer args = fetch_arg( frame, 1 );
struct pso_pointer new_env = fetch_env( frame_pointer );
struct pso_pointer names = lambda->payload.lambda.args;
@ -299,12 +302,12 @@ eval_lambda( struct pso_pointer frame_pointer ) {
/* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */
/* \todo eval all the things in frame->payload.stack_frame.more */
struct pso_pointer more_frame = inc_ref(
make_frame(1, frame_pointer,
frame->payload.stack_frame.more));
struct pso_pointer more_frame = inc_ref( make_frame( 1, frame_pointer,
frame->payload.
stack_frame.
more ) );
struct pso_pointer vals =
eval_forms( more_frame );
struct pso_pointer vals = eval_forms( more_frame );
for ( int i = args_in_frame - 1; i >= 0; i-- ) {
struct pso_pointer next =
@ -407,43 +410,46 @@ struct pso_pointer maybe_fixup_exception_location( struct pso_pointer r,
*
* @return a pointer to the new frame.
*/
struct pso_pointer make_fn_frame(struct pso_pointer previous,
struct pso_pointer fn_pointer,
struct pso_pointer arg_list) {
struct pso_pointer make_fn_frame( struct pso_pointer previous,
struct pso_pointer fn_pointer,
struct pso_pointer arg_list ) {
struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
struct pso_pointer next_pointer =
push_local(previous, make_frame(1, previous, nil));
struct pso4 *next_frame = pointer_to_pso4(next_pointer);
struct pso_pointer next_pointer =
push_local( previous, make_frame( 1, previous, nil ) );
struct pso4 *next_frame = pointer_to_pso4( next_pointer );
new_frame->payload.stack_frame.function = fn_pointer;
int args = 0;
struct pso_pointer cursor;
for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car(cursor);
new_frame->payload.stack_frame.arg[args++] = inc_ref( lisp_eval( next_pointer) );
}
if (consp(cursor)) {
struct pso_pointer more = nil;
int args = 0;
struct pso_pointer cursor;
for ( cursor = arg_list; consp( cursor ) && args < args_in_frame;
cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car( cursor );
new_frame->payload.stack_frame.arg[args++] =
inc_ref( lisp_eval( next_pointer ) );
}
if ( consp( cursor ) ) {
struct pso_pointer more = nil;
for (; consp(cursor); cursor = c_cdr(cursor)) {
// Reusing a frame like this is a bit of an abuse but will save
// allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car(cursor);
more = make_cons(previous, lisp_eval(next_pointer), more);
for ( ; consp( cursor ); cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save
// allocation churn.
next_frame->payload.stack_frame.arg[0] = c_car( cursor );
more = make_cons( previous, lisp_eval( next_pointer ), more );
args++;
}
}
new_frame->payload.stack_frame.more = push_local( previous, c_reverse( previous, more));
}
new_frame->payload.stack_frame.more =
push_local( previous, c_reverse( previous, more ) );
}
new_frame->payload.stack_frame.args = args;
new_frame->payload.stack_frame.args = args;
return new_pointer;
return new_pointer;
}
/**
@ -457,29 +463,31 @@ struct pso_pointer make_fn_frame(struct pso_pointer previous,
*
* @return a pointer to the new frame.
*/
struct pso_pointer make_special_frame(struct pso_pointer previous,
struct pso_pointer fn_pointer,
struct pso_pointer arg_list) {
struct pso_pointer make_special_frame( struct pso_pointer previous,
struct pso_pointer fn_pointer,
struct pso_pointer arg_list ) {
struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso_pointer new_pointer = make_frame( 0, previous );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
new_frame->payload.stack_frame.function = fn_pointer;
int args = 0;
struct pso_pointer cursor;
for ( cursor = arg_list; consp(cursor) && args < args_in_frame; cursor = c_cdr(cursor)) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn.
new_frame->payload.stack_frame.arg[args++] = inc_ref( c_car(cursor) );
}
if (consp(cursor)) {
int args = 0;
struct pso_pointer cursor;
for ( cursor = arg_list; consp( cursor ) && args < args_in_frame;
cursor = c_cdr( cursor ) ) {
// Reusing a frame like this is a bit of an abuse but will save allocation churn.
new_frame->payload.stack_frame.arg[args++] =
inc_ref( c_car( cursor ) );
}
if ( consp( cursor ) ) {
new_frame->payload.stack_frame.more = inc_ref( cursor);
}
new_frame->payload.stack_frame.more = inc_ref( cursor );
}
new_frame->payload.stack_frame.args = args;
new_frame->payload.stack_frame.args = args;
return new_pointer;
return new_pointer;
}
/**
@ -489,15 +497,18 @@ struct pso_pointer make_special_frame(struct pso_pointer previous,
* @param env The evaluation environment.
* @return the result of evaluating the function with its arguments.
*/
struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_apply( struct pso_pointer frame_pointer ) {
debug_print( L"Entering apply\n", DEBUG_EVAL, 0 );
struct pso_pointer result = nil;
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso_pointer fn_frame = inc_ref( make_frame(1, frame_pointer, c_car( frame->payload.stack_frame.arg[0] )));
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer fn_frame =
inc_ref( make_frame
( 1, frame_pointer,
c_car( frame->payload.stack_frame.arg[0] ) ) );
struct pso_pointer fn_pointer =
push_local(frame_pointer, eval_form( fn_frame));
dec_ref( fn_frame);
push_local( frame_pointer, eval_form( fn_frame ) );
dec_ref( fn_frame );
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
@ -514,35 +525,33 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
case FUNCTIONTV:
{
struct pso_pointer next_pointer =
inc_ref( make_fn_frame( frame_pointer, fn_pointer, args ));
inc_ref( make_fn_frame
( frame_pointer, fn_pointer, args ) );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
result = push_local( frame_pointer,
maybe_fixup_exception_location( ( *
( fn_cell->
payload.
function.
executable ) )
(next_pointer ),
fn_pointer ));
result = push_local( frame_pointer,
maybe_fixup_exception_location( ( *( fn_cell->payload.function.executable ) )
( next_pointer ), fn_pointer ) );
dec_ref( next_pointer );
}
}
break;
case KEYTV: {
struct pso_pointer map_frame =
inc_ref(make_frame(1, frame_pointer, c_car(args)));
result = push_local(
frame_pointer,
c_assoc(fn_pointer,
maybe_fixup_exception_location(
eval_form(map_frame), fn_pointer)));
} break;
case KEYTV:{
struct pso_pointer map_frame =
inc_ref( make_frame
( 1, frame_pointer, c_car( args ) ) );
result =
push_local( frame_pointer,
c_assoc( fn_pointer,
maybe_fixup_exception_location
( eval_form( map_frame ),
fn_pointer ) ) );
} break;
case LAMBDATV:
case LAMBDATV:
{
struct pso_pointer next_pointer =
make_fn_frame( frame_pointer, fn_pointer, args );
@ -551,8 +560,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer;
} else {
struct pso4 *next = pointer_to_pso4( next_pointer );
result =
eval_lambda( next_pointer );
result = eval_lambda( next_pointer );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
@ -561,7 +569,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
break;
case HASHTV:
/* \todo: if arg[0] is a CONS, treat it as a path */
/* \todo: if arg[0] is a CONS, treat it as a path */
// result = c_assoc( eval_form( frame,
// frame_pointer,
@ -580,8 +588,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer;
} else {
struct pso4 *next = pointer_to_pso4( next_pointer );
result =
eval_lambda( next_pointer );
result = eval_lambda( next_pointer );
dec_ref( next_pointer );
}
}
@ -596,15 +603,12 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
result = next_pointer;
} else {
result = maybe_fixup_exception_location( ( *
( fn_cell->
payload.
special.
executable ) )
( fn_cell->payload.special.executable ) )
( next_pointer ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL,
0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
dec_ref( next_pointer );
}
}
@ -617,14 +621,15 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %u (%3.3s) in function position",
get_tag_value(fn_pointer),
get_tag_value( fn_pointer ),
&( fn_cell->header.tag.bytes.mnemonic[0] ) );
struct pso_pointer message =
c_string_to_lisp_string( frame_pointer, buffer );
free( buffer );
result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"apply" ),
message, frame_pointer );
throw_exception( c_string_to_lisp_symbol
( frame_pointer, L"apply" ), message,
frame_pointer );
}
}
@ -633,7 +638,7 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
debug_print( L"apply: returning: ", DEBUG_EVAL, 0 );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL );
debug_dump_object( result, DEBUG_EVAL, 0 );
debug_dump_object( result, DEBUG_EVAL, 0 );
return result;
}
@ -655,42 +660,46 @@ struct pso_pointer lisp_apply( struct pso_pointer frame_pointer) {
* * If a special form, passes the cdr of expression to the special form as argument.
* @exception if `expression` is a symbol which is not bound in `env`.
*/
struct pso_pointer
lisp_eval( struct pso_pointer frame_pointer ) {
struct pso_pointer lisp_eval( struct pso_pointer frame_pointer ) {
debug_print( L"Eval: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.arg[0];
struct pso2 *cell = pointer_to_object(frame->payload.stack_frame.arg[0]);
struct pso_pointer env = fetch_env(frame_pointer);
struct pso2 *cell = pointer_to_object( frame->payload.stack_frame.arg[0] );
struct pso_pointer env = fetch_env( frame_pointer );
switch (get_tag_value(result)) {
case CONSTV: {
struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(2, frame_pointer,
c_car(result), c_cdr(result)));
result = push_local(frame_pointer, lisp_apply(next_pointer));
} break;
switch ( get_tag_value( result ) ) {
case CONSTV:{
struct pso_pointer next_pointer =
push_local( frame_pointer, make_frame( 2, frame_pointer,
c_car( result ),
c_cdr( result ) ) );
result =
push_local( frame_pointer, lisp_apply( next_pointer ) );
} break;
case SYMBOLTV:
case SYMBOLTV:
{
#ifdef DEBUG
debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0);
debug_print_object( fetch_arg( frame, 0), DEBUG_EVAL, 0);
debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0);
debug_dump_object( fetch_env(frame_pointer), DEBUG_EVAL, 0);
debug_print( L"\nEvaluating symbol `", DEBUG_EVAL, 0 );
debug_print_object( fetch_arg( frame, 0 ), DEBUG_EVAL, 0 );
debug_print( L"`\n\tEnvironment is: ", DEBUG_EVAL, 0 );
debug_dump_object( fetch_env( frame_pointer ), DEBUG_EVAL, 0 );
#endif
struct pso_pointer canonical =
c_interned( frame->payload.stack_frame.arg[0], fetch_env(frame_pointer) );
c_interned( frame->payload.stack_frame.arg[0],
fetch_env( frame_pointer ) );
if ( c_nilp( canonical ) ) {
struct pso_pointer message =
make_cons( frame_pointer, c_string_to_lisp_string
( frame_pointer, L"Attempt to take value of unbound symbol." ),
frame->payload.stack_frame.arg[0] );
( frame_pointer,
L"Attempt to take value of unbound symbol." ),
frame->payload.stack_frame.arg[0] );
result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"eval" ),
message, frame_pointer );
throw_exception( c_string_to_lisp_symbol
( frame_pointer, L"eval" ), message,
frame_pointer );
} else {
result = c_assoc( canonical, env );
// inc_ref( result );
@ -706,9 +715,9 @@ lisp_eval( struct pso_pointer frame_pointer ) {
default:
// we've already done this...
break;
}
}
debug_print( L"Eval returning ", DEBUG_EVAL, 0 );
debug_print( L"Eval returning ", DEBUG_EVAL, 0 );
debug_dump_object( result, DEBUG_EVAL, 0 );
return result;
@ -737,17 +746,22 @@ lisp_quote( struct pso4 *frame, struct pso_pointer frame_pointer,
* @param pointer a pointer to the object whose type is requested.
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer pointer ) {
struct pso_pointer c_type( struct pso_pointer frame_pointer,
struct pso_pointer pointer ) {
/* Strings read by `read` have the null character termination. This means
* that for the same printable string, the hashcode is different from
* 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 pso_pointer result = make_symbol( frame_pointer, ( wchar_t ) 0, nil );
struct pso_pointer result =
make_symbol( frame_pointer, ( wchar_t ) 0, nil );
struct pso2 *cell = pointer_to_object( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
result = make_symbol( frame_pointer, ( wchar_t ) cell->header.tag.bytes.mnemonic[i], result );
result =
make_symbol( frame_pointer,
( wchar_t ) cell->header.tag.bytes.mnemonic[i],
result );
}
return result;
@ -761,9 +775,9 @@ struct pso_pointer c_type( struct pso_pointer frame_pointer, struct pso_pointer
*
* @return As a Lisp symbol, the tag of `expression`.
*/
struct pso_pointer
lisp_type( struct pso_pointer frame_pointer ) {
return c_type( frame_pointer, fetch_arg( pointer_to_pso4( frame_pointer), 0) );
struct pso_pointer lisp_type( struct pso_pointer frame_pointer ) {
return c_type( frame_pointer,
fetch_arg( pointer_to_pso4( frame_pointer ), 0 ) );
}
@ -779,13 +793,13 @@ lisp_type( struct pso_pointer frame_pointer ) {
* @return the source of the `object` indicated, if it is a function, a lambda,
* an nlambda, or a spcial form; else `nil`.
*/
struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
struct pso_pointer lisp_source( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso2 *cell =
pointer_to_object( fetch_arg( frame, 0) );
struct pso_pointer source_key = c_string_to_lisp_keyword( frame_pointer, L"source" );
switch ( get_tag_value(fetch_arg( frame, 0)) ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso2 *cell = pointer_to_object( fetch_arg( frame, 0 ) );
struct pso_pointer source_key =
c_string_to_lisp_keyword( frame_pointer, L"source" );
switch ( get_tag_value( fetch_arg( frame, 0 ) ) ) {
case FUNCTIONTV:
result = c_assoc( source_key, cell->payload.function.meta );
break;
@ -794,17 +808,19 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
break;
case LAMBDATV:
result = make_cons( frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"λ" ),
make_cons( frame_pointer,
cell->payload.lambda.args,
cell->payload.lambda.body ) );
c_string_to_lisp_symbol( frame_pointer,
L"λ" ),
make_cons( frame_pointer,
cell->payload.lambda.args,
cell->payload.lambda.body ) );
break;
case NLAMBDATV:
result = make_cons( frame_pointer,
c_string_to_lisp_symbol( frame_pointer, L"nλ" ),
make_cons( frame_pointer,
cell->payload.lambda.args,
cell->payload.lambda.body ) );
c_string_to_lisp_symbol( frame_pointer,
L"nλ" ),
make_cons( frame_pointer,
cell->payload.lambda.args,
cell->payload.lambda.body ) );
break;
}
push_local( frame_pointer, result );
@ -820,7 +836,7 @@ struct pso_pointer lisp_source( struct pso_pointer frame_pointer) {
* @return struct pso_pointer a pointer to the result
*/
struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a =
@ -840,51 +856,60 @@ struct pso_pointer lisp_list( struct pso_pointer frame_pointer ) {
* This is `let*` in Common Lisp parlance; `let` in Clojure parlance.
*/
struct pso_pointer lisp_let( struct pso_pointer frame_pointer ) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer bindings = fetch_env(frame_pointer);
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer bindings = fetch_env( frame_pointer );
struct pso_pointer result = nil;
for ( struct pso_pointer cursor = fetch_arg( frame, 0);
for ( struct pso_pointer cursor = fetch_arg( frame, 0 );
c_truep( cursor ); cursor = c_cdr( cursor ) ) {
struct pso_pointer pair = c_car( cursor );
struct pso_pointer symbol = c_car( pair );
struct pso_pointer next_pointer = push_local( frame_pointer, make_frame_with_env( 0, frame_pointer, bindings));
struct pso_pointer next_pointer =
push_local( frame_pointer,
make_frame_with_env( 0, frame_pointer, bindings ) );
if ( symbolp( symbol ) ) {
add_arg(next_pointer, c_cdr(pair));
struct pso_pointer val =
eval_form( next_pointer );
add_arg( next_pointer, c_cdr( pair ) );
struct pso_pointer val = eval_form( next_pointer );
// debug_print_binding( symbol, val, false, DEBUG_BIND );
bindings = make_cons( frame_pointer, make_cons( frame_pointer, symbol, val ), bindings );
bindings =
make_cons( frame_pointer,
make_cons( frame_pointer, symbol, val ), bindings );
} else {
result =
throw_exception( c_string_to_lisp_symbol( frame_pointer, L"let" ),
c_string_to_lisp_string( frame_pointer, L"Let: cannot bind, not a symbol" ),
throw_exception( c_string_to_lisp_symbol
( frame_pointer, L"let" ),
c_string_to_lisp_string( frame_pointer,
L"Let: cannot bind, not a symbol" ),
frame_pointer );
break;
}
}
if (!exceptionp(result)) {
if ( !exceptionp( result ) ) {
debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND, 0 );
struct pso_pointer progn_pointer = make_frame_with_env( 0, frame_pointer, bindings);
struct pso4* progn_frame = pointer_to_pso4(progn_pointer);
struct pso_pointer progn_pointer =
make_frame_with_env( 0, frame_pointer, bindings );
struct pso4 *progn_frame = pointer_to_pso4( progn_pointer );
int a = 1;
for (; a < frame->payload.stack_frame.args && a < args_in_frame; a++) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a);
progn_frame->payload.stack_frame.args ++;
for ( ; a < frame->payload.stack_frame.args && a < args_in_frame; a++ ) {
progn_frame->payload.stack_frame.arg[a - 1] =
fetch_arg( frame, a );
progn_frame->payload.stack_frame.args++;
}
if ( a < frame->payload.stack_frame.args) {
progn_frame->payload.stack_frame.arg[a-1] = fetch_arg( frame, a);
progn_frame->payload.stack_frame.more = c_cdr( frame->payload.stack_frame.more);
if ( a < frame->payload.stack_frame.args ) {
progn_frame->payload.stack_frame.arg[a - 1] =
fetch_arg( frame, a );
progn_frame->payload.stack_frame.more =
c_cdr( frame->payload.stack_frame.more );
}
result = lisp_progn(progn_pointer);
result = lisp_progn( progn_pointer );
}
return result;
@ -904,8 +929,8 @@ struct pso_pointer lisp_and( struct pso4 *frame,
bool accumulator = true;
struct pso_pointer result = frame->payload.stack_frame.more;
for ( int a = 0; accumulator == true && a < frame->payload.stack_frame.args;
a++ ) {
for ( int a = 0;
accumulator == true && a < frame->payload.stack_frame.args; a++ ) {
accumulator = truthy( fetch_arg( frame, a ) );
}
#

6
src/c/ops/inspect.c
View file

@ -35,8 +35,8 @@
* @param env my environment (from which the stream may be extracted).
* @return nil.
*/
struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) {
debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 );
struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer ) {
debug_print( L"Entering lisp_inspect\n", DEBUG_IO, 0 );
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
@ -46,7 +46,7 @@ struct pso_pointer lisp_inspect(struct pso_pointer frame_pointer) {
: get_default_stream( false, fetch_env( frame_pointer ) );
URL_FILE *output;
dump_object( frame_pointer, fetch_arg(frame,1), fetch_arg(frame, 0) );
dump_object( frame_pointer, fetch_arg( frame, 1 ), fetch_arg( frame, 0 ) );
debug_print( L"Leaving lisp_inspect", DEBUG_IO, 0 );

6
src/c/ops/inspect.h
View file

@ -17,9 +17,9 @@
/**
* Legacy technical debt to be entirely rewritten
*/
void dump_object(struct pso_pointer frame_pointer,
struct pso_pointer output, struct pso_pointer pointer );
void dump_object( struct pso_pointer frame_pointer,
struct pso_pointer output, struct pso_pointer pointer );
struct pso_pointer lisp_inspect( struct pso_pointer frame_pointer );
#endif
#endif

19
src/c/ops/keys.c
View file

@ -20,8 +20,8 @@
* @brief an implementation of `keys` convenient for calling from C
*
* @param */
struct pso_pointer c_keys(struct pso_pointer frame_pointer,
struct pso_pointer store ) {
struct pso_pointer c_keys( struct pso_pointer frame_pointer,
struct pso_pointer store ) {
struct pso_pointer result = nil;
if ( consp( store ) ) {
@ -29,14 +29,14 @@ struct pso_pointer c_keys(struct pso_pointer frame_pointer,
pair = c_car( store ) ) {
if ( consp( pair ) ) {
result = make_cons( frame_pointer, c_car( pair ), result );
// } else if ( hashtabp( pair ) ) {
// result = c_append( hashmap_keys( pair ), result );
// } else if ( hashtabp( pair ) ) {
// result = c_append( hashmap_keys( pair ), result );
}
store = c_cdr( store );
}
// } else if ( hashtabp( store ) ) {
// result = hashmap_keys( store );
// } else if ( hashtabp( store ) ) {
// result = hashmap_keys( store );
}
return result;
@ -44,7 +44,8 @@ struct pso_pointer c_keys(struct pso_pointer frame_pointer,
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer) {
return c_keys( frame_pointer, pointer_to_pso4(frame_pointer)->payload.stack_frame.arg[0] );
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer ) {
return c_keys( frame_pointer,
pointer_to_pso4( frame_pointer )->payload.stack_frame.
arg[0] );
}

4
src/c/ops/keys.h
View file

@ -14,6 +14,6 @@
struct pso_pointer c_keys( struct pso_pointer store );
struct pso_pointer lisp_keys(struct pso_pointer frame_pointer);
struct pso_pointer lisp_keys( struct pso_pointer frame_pointer );
#endif
#endif

1
src/c/ops/list_ops.c
View file

@ -33,4 +33,3 @@ struct pso_pointer count( struct pso_pointer frame_pointer ) {
return acquire_integer( frame_pointer, c );
}

33
src/c/ops/mapcar.c
View file

@ -25,34 +25,43 @@
#include "payloads/cons.h"
struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4* frame = pointer_to_pso4(frame_pointer);
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
debug_print( L"Mapcar: ", DEBUG_EVAL, 0 );
debug_dump_object( frame_pointer, DEBUG_EVAL, 0 );
int i = 0;
for ( struct pso_pointer c = frame->payload.stack_frame.arg[1]; c_truep( c );
c = c_cdr( c ) ) {
struct pso_pointer expr =
push_local( frame_pointer,
make_cons( frame_pointer, frame->payload.stack_frame.arg[0],
make_cons( frame_pointer, c_car( c ), nil ) ) );
for ( struct pso_pointer c = frame->payload.stack_frame.arg[1];
c_truep( c ); c = c_cdr( c ) ) {
struct pso_pointer expr = push_local( frame_pointer,
make_cons( frame_pointer,
frame->payload.
stack_frame.arg[0],
make_cons
( frame_pointer,
c_car( c ),
nil ) ) );
debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, evaluating ", i );
debug_print_object( expr, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
struct pso_pointer r = lisp_eval( push_local( frame_pointer, make_frame(1, frame_pointer, expr)));
struct pso_pointer r =
lisp_eval( push_local
( frame_pointer,
make_frame( 1, frame_pointer, expr ) ) );
if ( exceptionp( r ) ) {
result = r;
break;
} else {
result = push_local( frame_pointer, make_cons( frame_pointer, r, result ));
result =
push_local( frame_pointer,
make_cons( frame_pointer, r, result ) );
}
debug_printf( DEBUG_EVAL, 0, L"Mapcar %d, result is ", i++ );
debug_print_object( result, DEBUG_EVAL, 0 );
debug_println( DEBUG_EVAL);
debug_println( DEBUG_EVAL );
}
result = consp( result ) ? c_reverse( frame_pointer, result ) : result;

2
src/c/ops/mapcar.h
View file

@ -14,4 +14,4 @@
struct pso_pointer lisp_mapcar( struct pso_pointer frame_pointer );
#endif
#endif

44
src/c/ops/progn.c
View file

@ -31,14 +31,14 @@ struct pso_pointer
c_progn( struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer expressions, struct pso_pointer env ) {
struct pso_pointer result = nil;
struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(1, frame_pointer, nil));
struct pso4 *next_frame = pointer_to_pso4(next_pointer);
struct pso_pointer next_pointer =
push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) );
struct pso4 *next_frame = pointer_to_pso4( next_pointer );
while ( consp( expressions ) ) {
next_frame->payload.stack_frame.arg[0] = c_car(expressions);
next_frame->payload.stack_frame.arg[0] = c_car( expressions );
result = lisp_eval( next_pointer);
result = lisp_eval( next_pointer );
expressions = exceptionp( result ) ? nil : c_cdr( expressions );
}
@ -60,25 +60,25 @@ c_progn( struct pso4 *frame, struct pso_pointer frame_pointer,
* @return the value of the last `expression` of the sequence which is my single
* argument.
*/
struct pso_pointer
lisp_progn( struct pso_pointer frame_pointer) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4(frame_pointer);
struct pso_pointer next_pointer =
push_local(frame_pointer, make_frame(1, frame_pointer, nil));
struct pso4 *next_frame = pointer_to_pso4(next_pointer);
struct pso_pointer lisp_progn( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil;
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer next_pointer =
push_local( frame_pointer, make_frame( 1, frame_pointer, nil ) );
struct pso4 *next_frame = pointer_to_pso4( next_pointer );
for (int i = 0; i < args_in_frame; i++) {
next_frame->payload.stack_frame.arg[0] =
frame->payload.stack_frame.arg[i];
for ( int i = 0; i < args_in_frame; i++ ) {
next_frame->payload.stack_frame.arg[0] =
frame->payload.stack_frame.arg[i];
result = push_local(frame_pointer, lisp_eval(next_pointer));
}
result = push_local( frame_pointer, lisp_eval( next_pointer ) );
}
if (consp(frame->payload.stack_frame.more)) {
result = c_progn(frame, frame_pointer, frame->payload.stack_frame.more,
fetch_env(frame_pointer));
}
if ( consp( frame->payload.stack_frame.more ) ) {
result =
c_progn( frame, frame_pointer, frame->payload.stack_frame.more,
fetch_env( frame_pointer ) );
}
return result;
return result;
}

11
src/c/ops/progn.h
View file

@ -15,9 +15,10 @@
#include "memory/pointer.h"
#include "memory/pso4.h"
struct pso_pointer c_progn(struct pso4 *frame, struct pso_pointer frame_pointer,
struct pso_pointer expressions,
struct pso_pointer env);
struct pso_pointer c_progn( struct pso4 *frame,
struct pso_pointer frame_pointer,
struct pso_pointer expressions,
struct pso_pointer env );
struct pso_pointer lisp_progn(struct pso_pointer frame_pointer);
#endif
struct pso_pointer lisp_progn( struct pso_pointer frame_pointer );
#endif

6
src/c/ops/quote.c
View file

@ -21,6 +21,6 @@
*
* @return the expression.
*/
struct pso_pointer quote(struct pso_pointer frame_pointer){
return fetch_arg(pointer_to_pso4(frame_pointer), 0);
}
struct pso_pointer quote( struct pso_pointer frame_pointer ) {
return fetch_arg( pointer_to_pso4( frame_pointer ), 0 );
}

4
src/c/ops/quote.h
View file

@ -14,5 +14,5 @@
#include "memory/pointer.h"
struct pso_pointer quote(struct pso_pointer frame_pointer);
#endif
struct pso_pointer quote( struct pso_pointer frame_pointer );
#endif

4
src/c/ops/repl.c
View file

@ -106,7 +106,7 @@ struct pso_pointer repl( struct pso_pointer frame_pointer ) {
dec_ref( base_of_stack );
}
debug_print(L"Leaving repl\n", DEBUG_REPL, 0);
debug_print( L"Leaving repl\n", DEBUG_REPL, 0 );
return nil;
return nil;
}

22
src/c/ops/reverse.c
View file

@ -49,25 +49,25 @@ struct pso_pointer reverse( struct pso_pointer frame_pointer ) {
case KEYTV:
result = push_local( frame_pointer,
make_string_like_thing( frame_pointer,
object->payload.
string.character,
result,
object->
payload.string.
character, result,
KEYTAG ) );
break;
case STRINGTV:
result = push_local( frame_pointer,
make_string_like_thing( frame_pointer,
object->payload.
string.character,
result,
object->
payload.string.
character, result,
STRINGTAG ) );
break;
case SYMBOLTV:
result = push_local( frame_pointer,
make_string_like_thing( frame_pointer,
object->payload.
string.character,
result,
object->
payload.string.
character, result,
SYMBOLTAG ) );
break;
default:
@ -105,8 +105,8 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer result = nil;
if ( stackp( frame_pointer ) ) {
result = reverse( make_frame(1, frame_pointer, sequence) );
result = reverse( make_frame( 1, frame_pointer, sequence ) );
}
return result;
}

6
src/c/ops/string_ops.c
View file

@ -146,8 +146,8 @@ char *lisp_string_to_c_string( struct pso_pointer s ) {
int i = 0;
for ( struct pso_pointer c = s; !c_nilp( c ); c = c_cdr( c ) ) {
buffer[i++] =
( wchar_t ) ( pointer_to_object( c )->payload.
string.character );
( wchar_t ) ( pointer_to_object( c )->payload.string.
character );
}
mbstate_t ps;
@ -183,7 +183,7 @@ struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer,
for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) {
wchar_t c = symbol[i];
if ( symbol_char_p(c)) {
if ( symbol_char_p( c ) ) {
result = make_symbol( frame_pointer, c, result );
}
}

6
src/c/ops/string_ops.h
View file

@ -27,11 +27,11 @@ char *lisp_string_to_c_string( struct pso_pointer s );
struct pso_pointer c_string_to_lisp_keyword( struct pso_pointer frame_pointer,
wchar_t * symbol );
wchar_t *symbol );
struct pso_pointer c_string_to_lisp_symbol( struct pso_pointer frame_pointer,
wchar_t * symbol );
wchar_t *symbol );
bool end_of_stringp(struct pso_pointer arg);
bool end_of_stringp( struct pso_pointer arg );
#endif

33
src/c/payloads/exception.c
View file

@ -121,29 +121,29 @@ struct pso_pointer throw_exception_with_cause( struct pso_pointer location,
debug_print( L"`\n", DEBUG_ANY, 0 );
if ( !c_nilp( cause ) ) {
debug_print( L"\tCaused by: ", DEBUG_ANY, 0 );
debug_print_object( cause, DEBUG_ANY, 0);
debug_print_object( cause, DEBUG_ANY, 0 );
debug_print( L"`\n", DEBUG_ANY, 0 );
}
#endif
struct pso2 *cell = pointer_to_object( message );
if (get_tag_value( message)) {
result = message;
} else {
struct pso_pointer x_frame = inc_ref(make_frame(
2, frame_pointer, message,
(c_nilp(location)
? nil
: make_cons(frame_pointer,
make_cons(frame_pointer,
privileged_keyword_location, location),
nil)),
cause));
if ( get_tag_value( message ) ) {
result = message;
} else {
struct pso_pointer x_frame =
inc_ref( make_frame( 2, frame_pointer, message,
( c_nilp( location )
? nil : make_cons( frame_pointer,
make_cons( frame_pointer,
privileged_keyword_location,
location ),
nil ) ),
cause ) );
result = push_local(frame_pointer, make_exception(x_frame));
}
result = push_local( frame_pointer, make_exception( x_frame ) );
}
return result;
return result;
}
/**
@ -162,4 +162,3 @@ throw_exception( struct pso_pointer location,
struct pso_pointer frame_pointer ) {
return throw_exception_with_cause( location, payload, nil, frame_pointer );
}

4
src/c/payloads/float.h
View file

@ -16,7 +16,7 @@
* we could/should use the full 128 bits.
*/
struct float_payload {
long double value;
long double value;
};
#endif
#endif

19
src/c/payloads/function.c
View file

@ -12,14 +12,17 @@
#include "memory/pso2.h"
#include "memory/tags.h"
struct pso_pointer make_function(
struct pso_pointer frame_pointer, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) {
struct pso_pointer result = allocate(frame_pointer, FUNCTIONTAG, 2);
struct pso2 *object = pointer_to_object(result);
struct pso_pointer make_function( struct pso_pointer frame_pointer,
struct pso_pointer meta,
struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, FUNCTIONTAG, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.function.meta = meta;
object->payload.function.executable = executable;
object->payload.function.meta = meta;
object->payload.function.executable = executable;
return result;
return result;
}

8
src/c/payloads/function.h
View file

@ -39,8 +39,10 @@ struct function_payload {
struct pso_pointer ( *executable ) ( struct pso_pointer frame_pointer );
};
struct pso_pointer make_function(
struct pso_pointer frame_pointer, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer));
struct pso_pointer make_function( struct pso_pointer frame_pointer,
struct pso_pointer meta,
struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) );
#endif

8
src/c/payloads/keyword.c
View file

@ -21,7 +21,7 @@
* @param c the character to add (prepend);
* @param tail the keyword which is being built.
*/
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, KEYTAG );
}
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, KEYTAG );
}

6
src/c/payloads/keyword.h
View file

@ -16,8 +16,8 @@
/* TODO: for now, Keyword shares a payload with String, but this may change.
* Strings are of indefinite length, but keywords are really not, and might
* fit into any size class. */
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer make_keyword( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail );
#endif

15
src/c/payloads/lambda.c
View file

@ -13,12 +13,13 @@
#include "memory/pso.h"
#include "memory/pso2.h"
struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer,
struct pso_pointer args,
struct pso_pointer body, char *tag) {
struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer,
struct pso_pointer args,
struct pso_pointer body,
char *tag ) {
struct pso_pointer result = allocate(frame_pointer, tag, 2);
struct pso2 *object = pointer_to_object(result);
object->payload.lambda.args = args;
object->payload.lambda.body = body;
struct pso_pointer result = allocate( frame_pointer, tag, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.lambda.args = args;
object->payload.lambda.body = body;
}

11
src/c/payloads/lambda.h
View file

@ -30,9 +30,10 @@ struct lambda_payload {
struct pso_pointer body;
};
struct pso_pointer make_lambda_like_thing(struct pso_pointer frame_pointer,
struct pso_pointer args,
struct pso_pointer body, char *tag);
#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG))
struct pso_pointer make_lambda_like_thing( struct pso_pointer frame_pointer,
struct pso_pointer args,
struct pso_pointer body,
char *tag );
#define make_lambda(f,a,b) (make_lambda_like_thing( f, a, b, LAMBDATAG))
#endif

2
src/c/payloads/psse_string.h
View file

@ -35,7 +35,7 @@ struct string_payload {
struct pso_pointer make_string( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer destroy_string( struct pso_pointer fp );
#endif

19
src/c/payloads/special.c
View file

@ -12,14 +12,17 @@
#include "memory/pso2.h"
#include "memory/tags.h"
struct pso_pointer make_special(
struct pso_pointer frame_pointer, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer)) {
struct pso_pointer result = allocate(frame_pointer, SPECIALTAG, 2);
struct pso2 *object = pointer_to_object(result);
struct pso_pointer make_special( struct pso_pointer frame_pointer,
struct pso_pointer meta,
struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) )
{
struct pso_pointer result = allocate( frame_pointer, SPECIALTAG, 2 );
struct pso2 *object = pointer_to_object( result );
object->payload.special.meta = meta;
object->payload.special.executable = executable;
object->payload.special.meta = meta;
object->payload.special.executable = executable;
return result;
return result;
}

8
src/c/payloads/special.h
View file

@ -22,8 +22,10 @@
* \see NLAMBDATAG.
*/
struct pso_pointer make_special(
struct pso_pointer frame_pointer, struct pso_pointer meta,
struct pso_pointer (*executable)(struct pso_pointer frame_pointer));
struct pso_pointer make_special( struct pso_pointer frame_pointer,
struct pso_pointer meta,
struct pso_pointer ( *executable ) ( struct
pso_pointer
frame_pointer ) );
#endif

52
src/c/payloads/stack.c
View file

@ -100,22 +100,28 @@ struct pso_pointer push_local( struct pso_pointer frame_pointer,
*
* @return `nil` on success; potentially an exception on failure.
*/
struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer) {
struct pso4* frame = pointer_to_pso4( frame_pointer);
struct pso_pointer add_arg( struct pso_pointer frame_pointer,
struct pso_pointer arg_pointer ) {
struct pso4 *frame = pointer_to_pso4( frame_pointer );
struct pso_pointer result = nil;
if (frame->payload.stack_frame.args < args_in_frame) {
frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] = push_local(frame_pointer, arg_pointer);
if ( frame->payload.stack_frame.args < args_in_frame ) {
frame->payload.stack_frame.arg[frame->payload.stack_frame.args++] =
push_local( frame_pointer, arg_pointer );
} else {
struct pso_pointer new_more = c_reverse( frame_pointer,
make_cons( frame_pointer,
arg_pointer,
c_reverse( frame_pointer, frame->payload.stack_frame.more)));
if (exceptionp(new_more)) {
make_cons( frame_pointer,
arg_pointer,
c_reverse
( frame_pointer,
frame->payload.
stack_frame.
more ) ) );
if ( exceptionp( new_more ) ) {
result = new_more;
} else {
frame->payload.stack_frame.more =
push_local( frame_pointer, new_more);
push_local( frame_pointer, new_more );
}
}
@ -127,7 +133,7 @@ struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer
* `env` pointer of the new frame -- callers are responsible for doing so.
*/
struct pso_pointer in_make_frame( int arg_count, struct pso_pointer previous,
va_list args ) {
va_list args ) {
/* NOTE! It is really important not to `push_local` the new_pointer here,
* since that would stop stack frames and all the temporary objects they
* curate ever being garbage collected! */
@ -205,13 +211,14 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
va_list args;
va_start( args, previous );
struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args);
struct pso4* new_frame = pointer_to_pso4(new_pointer);
struct pso_pointer new_pointer =
in_make_frame( arg_count, previous, args );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
new_frame->payload.stack_frame.env = stackp(previous) ?
inc_ref(pointer_to_pso4(previous)->payload.stack_frame.env) : nil;
new_frame->payload.stack_frame.env = stackp( previous ) ?
inc_ref( pointer_to_pso4( previous )->payload.stack_frame.env ) : nil;
va_end(args);
va_end( args );
return new_pointer;
}
@ -238,10 +245,11 @@ struct pso_pointer make_frame_with_env( int arg_count,
va_list args;
va_start( args, env );
struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args);
pointer_to_pso4(new_pointer)->payload.stack_frame.env = inc_ref( env);
struct pso_pointer new_pointer =
in_make_frame( arg_count, previous, args );
pointer_to_pso4( new_pointer )->payload.stack_frame.env = inc_ref( env );
va_end(args);
va_end( args );
return new_pointer;
}
@ -270,8 +278,8 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
struct pso_pointer arg_length =
count( push_local( previous, make_frame( 1, previous, argvalues ) ) );
int arg_count =
integerp( arg_length ) ? pointer_to_object( arg_length )->
payload.integer.value : 0;
integerp( arg_length ) ? pointer_to_object( arg_length )->payload.
integer.value : 0;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, "
@ -330,8 +338,8 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer argvalues ) {
return make_frame_with_arglist_and_env( previous, argvalues,
pointer_to_pso4
( previous )->payload.stack_frame.
env );
( previous )->payload.
stack_frame.env );
}

3
src/c/payloads/stack.h
View file

@ -54,6 +54,7 @@ struct pso_pointer make_frame_with_arglist( struct pso_pointer previous,
struct pso_pointer destroy_stack_frame( struct pso_pointer fp,
struct pso_pointer env );
struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer arg_pointer);
struct pso_pointer add_arg( struct pso_pointer frame_pointer,
struct pso_pointer arg_pointer );
#endif

2
src/c/payloads/stack_payload.h
View file

@ -42,4 +42,4 @@ struct stack_frame_payload {
uint32_t depth;
};
#endif
#endif

6
src/c/payloads/symbol.c
View file

@ -24,6 +24,6 @@
* @param tail the symbol which is being built.
*/
struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG );
}
struct pso_pointer tail ) {
return make_string_like_thing( frame_pointer, c, tail, SYMBOLTAG );
}

6
src/c/payloads/symbol.h
View file

@ -27,8 +27,8 @@
/* TODO: for now, Symbol shares a payload with String, but this may change.
* Strings are of indefinite length, but symbols are really not, and might
* fit into any size class. */
struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail );
struct pso_pointer make_symbol( struct pso_pointer frame_pointer, wint_t c,
struct pso_pointer tail );
#endif