From c0b18cda5ae41c8972d37ebf9c0b446abb9f9a73 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sun, 18 Jan 2026 03:11:17 -0800 Subject: [PATCH] Global generation --- Makefile | 21 ++++- src/base.c | 46 ++++++---- src/base.h | 55 +++++++----- src/function.c | 183 +++++++++++++++++++++++++++++++++++++++ src/function.h | 43 ++++++++- src/gen-init-globals.awk | 86 ++++++++++++++++++ src/hashtable.c | 12 ++- src/init_globals.h | 23 +++++ src/lisp.c | 46 +++++++++- src/lisp.h | 3 + src/lisp_string.c | 43 +++++++++ src/lisp_string.h | 20 +++++ src/list.c | 26 ++++++ src/list.h | 4 + src/main.c | 8 +- src/read.c | 9 +- 16 files changed, 571 insertions(+), 57 deletions(-) create mode 100644 src/gen-init-globals.awk create mode 100644 src/init_globals.h create mode 100644 src/lisp_string.c create mode 100644 src/lisp_string.h diff --git a/Makefile b/Makefile index 258f802..429ab88 100644 --- a/Makefile +++ b/Makefile @@ -3,17 +3,32 @@ CFLAGS=-g -std=c11 -Wall -Wpedantic LD=gcc LDFLAGS=-g -SRCS=$(wildcard src/*.c) -OBJS=$(SRCS:src/%.c=bin/%.o) -DEPS=$(SRCS:src/%.c=bin/deps/%.d) +SRCS:=$(wildcard src/*.c) +OBJS:=$(SRCS:src/%.c=bin/%.o) +DEPS:=$(SRCS:src/%.c=bin/deps/%.d) + +SRCS += bin/init_globals.c +OBJS += bin/init_globals.o +DEPS += bin/deps/init_globals.o + +HEADERS=$(wildcard src/*.h) +SRCS_WITH_HEADERS=$(filter $(HEADERS:src/%.h=src/%.c),$(SRCS)) glisp: $(OBJS) $(LD) $(LDFLAGS) -o $@ $^ +bin/init_globals.c: $(filter-out bin/init_globals.c,$(SRCS_WITH_HEADERS)) src/gen-init-globals.awk + @mkdir -p bin/ + awk -f src/gen-init-globals.awk $(filter-out src/gen-init-globals.awk,$^) >$@ + bin/%.o: src/%.c @mkdir -p bin/deps $(CC) $(CFLAGS) -c -MMD -MF $(<:src/%.c=bin/deps/%.d) -o $@ $< +bin/init_globals.o: bin/init_globals.c + @mkdir -p bin/deps + $(CC) $(CFLAGS) -Isrc/ -c -MMD -MF bin/deps/init_globals.d -o $@ $< + clean: rm -rf glisp bin/ diff --git a/src/base.c b/src/base.c index 1d6ac07..f279c46 100644 --- a/src/base.c +++ b/src/base.c @@ -1,5 +1,8 @@ #include "base.h" +#include "hashtable.h" +#include "lisp.h" + #include const char *LISP_TYPE_NAMES[N_LISP_TYPES] = { @@ -16,11 +19,11 @@ const char *LISP_TYPE_NAMES[N_LISP_TYPES] = { void *lisp_alloc_object(size_t size, LispValType type) { assert(size >= sizeof(LispObject)); LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size); + obj->type = type; obj->gc.immortal = false; obj->gc.mark = false; // TODO set the below obj->gc.entry = NULL; - obj->type = type; return obj; } @@ -28,24 +31,23 @@ DEFINE_SYMBOL(nil, "nil"); DEFINE_SYMBOL(t, "t"); DEFINE_SYMBOL(unbound, "unbound"); +DEFINE_SYMBOL(quote, "quote"); +DEFINE_SYMBOL(backquote, "`"); +DEFINE_SYMBOL(comma, ","); +DEFINE_SYMBOL(comma_at, ",@"); + +DEFUN(id, "id", (LispVal * obj), "(id)", "") { + // TODO not all values are handled here + return MAKE_FIXNUM((uintptr_t) obj); +} + +DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") { + return obj1 == obj2 ? Qt : Qnil; +} + // ################ // # Constructors # // ################ -LispVal *make_lisp_string(const char *data, size_t length, bool take, - bool copy) { - LispString *obj = lisp_alloc_object(sizeof(LispString), TYPE_STRING); - obj->owned = take; - obj->length = length; - if (copy) { - obj->data = lisp_malloc(length + 1); - memcpy(obj->data, data, length); - obj->data[length] = '\0'; - } else { - obj->data = (char *) data; - } - return obj; -} - LispVal *make_vector(LispVal **data, size_t length, bool take) { LispVector *obj = lisp_alloc_object(sizeof(LispVector), TYPE_VECTOR); obj->length = length; @@ -63,12 +65,18 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)", LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL); obj->name = name; obj->function = Qnil; - obj->value = Qnil; + obj->value = Qunbound; obj->plist = Qnil; return obj; } DEFUN(intern, "intern", (LispVal * name), "(name)", "") { - // TODO implement - return Fmake_symbol(name); + // TODO type checking + LispVal *res = Fgethash(obarray, name, Qunbound); + if (res != Qunbound) { + return res; + } + LispVal *newsym = Fmake_symbol(name); + Fputhash(obarray, name, newsym); + return newsym; } diff --git a/src/base.h b/src/base.h index 9688824..096ed06 100644 --- a/src/base.h +++ b/src/base.h @@ -95,6 +95,10 @@ typedef struct { ObjectGCInfo gc; } LispObject; +static ALWAYS_INLINE void MAKE_OBJ_IMMORTAL(LispVal *obj) { + ((LispObject *) obj)->gc.immortal = true; +} + static ALWAYS_INLINE LispValType TYPE_OF(LispVal *val) { if (FIXNUMP(val)) { return TYPE_FIXNUM; @@ -125,12 +129,6 @@ static ALWAYS_INLINE bool LISP_TYPEP(LispVal *val, LispValType type) { } \ struct __ignored -DEFOBJTYPE(String, STRING, STRINGP, { - size_t length; - char *data; - bool owned; -}); - DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, { LispVal *name; // string LispVal *function; @@ -143,22 +141,33 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { LispVal **data; }); -#define DECLARE_SYMBOL(cname) \ - extern const char *Q##cname##_name; \ +// Defined here instead of in function.h so that headers don't have to include +// it just to define functions +#define DECLARE_SYMBOL(cname) \ + extern const char *internal_Q##cname##_name; \ + extern const size_t internal_Q##cname##_name_len; \ extern LispVal *Q##cname -#define DECLARE_FUNCTION(cname, cargs) \ - DECLARE_SYMBOL(cname); \ - extern const char F##cname_name; \ +#define DECLARE_FUNCTION(cname, cargs) \ + DECLARE_SYMBOL(cname); \ + extern const char *internal_F##cname##_argstr; \ + extern const size_t internal_F##cname##_argstr_len; \ + extern const char *internal_F##cname##_docstr; \ + extern const size_t internal_F##cname##_docstr_len; \ LispVal *F##cname cargs -#define DEFINE_SYMBOL(cname, lisp_name) \ - const char *Q##cname##_name = lisp_name; \ +#define DEFINE_SYMBOL(cname, lisp_name) \ + const char *internal_Q##cname##_name = lisp_name; \ + const size_t internal_Q##cname##_name_len = sizeof(lisp_name) - 1; \ LispVal *Q##cname -#define DEFUN(cname, lisp_name, cargs, lisp_args, doc) \ - DEFINE_SYMBOL(cname, lisp_name); \ - LispVal *Q##cname; \ +#define DEFUN(cname, lisp_name, cargs, lisp_args, doc) \ + DEFINE_SYMBOL(cname, lisp_name); \ + const char *internal_F##cname##_argstr = lisp_args; \ + const size_t internal_F##cname##_argstr_len = sizeof(lisp_args) - 1; \ + const char *internal_F##cname##_docstr = doc; \ + const size_t internal_F##cname##_docstr_len = sizeof(doc) - 1; \ + LispVal *Q##cname; \ LispVal *F##cname cargs DECLARE_SYMBOL(nil); @@ -169,13 +178,19 @@ static ALWAYS_INLINE bool NILP(LispVal *val) { return val == Qnil; } +// Some core functions +DECLARE_FUNCTION(id, (LispVal * obj)); +DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2)); + // TODO probably move these to another file -LispVal *make_lisp_string(const char *data, size_t length, bool take, - bool copy); LispVal *make_vector(LispVal **data, size_t length, bool take); -#define LISP_LITSTR(litstr) \ - (make_lisp_string(litstr, sizeof(litstr) - 1, false, false)) DECLARE_FUNCTION(make_symbol, (LispVal * name)); DECLARE_FUNCTION(intern, (LispVal * name)); +// TODO these are actually special-forms +DECLARE_SYMBOL(quote); +DECLARE_SYMBOL(backquote); +DECLARE_SYMBOL(comma); +DECLARE_SYMBOL(comma_at); + #endif diff --git a/src/function.c b/src/function.c index d4b693e..c58beab 100644 --- a/src/function.c +++ b/src/function.c @@ -1 +1,184 @@ #include "function.h" + +#include "lisp.h" +#include "list.h" +#include "read.h" + +#include +#include + +const char *llps_strerror(LambdaListParseStatus status) { + static const char *MSGS[LLPS_N_ERROS] = { + [LLPS_OK] = "No error", + [LLPS_DOTTED] = "Dotted list", + [LLPS_REPEAT_SECTION] = "Repeated section", + [LLPS_REPEAT_NAME] = "Repeated name", + [LLPS_SYNTAX] = "Syntax error", + [LLPS_BAD_NAME] = "Invalid variable name", + }; + return MSGS[status]; +} + +DEFINE_SYMBOL(and_optional, "&optional"); +DEFINE_SYMBOL(and_rest, "&rest"); +DEFINE_SYMBOL(and_key, "&key"); +DEFINE_SYMBOL(and_allow_other_keys, "&allow-other-keys"); + +static bool is_valid_variable_name(LispVal *val) { + return SYMBOLP(val) && !NILP(val) && val != Qt && val != Qunbound; +} + +// on error, put the object that caused the problem in entry +static LambdaListParseStatus parse_optional_arg_spec(LispVal **out, + LispVal *entry) { + // single symbol + if (SYMBOLP(entry)) { + if (!is_valid_variable_name(entry)) { + *out = entry; + return LLPS_BAD_NAME; + } + *out = LIST(entry, Qnil, Qnil); + return LLPS_OK; + } else if (!CONSP(entry)) { + *out = entry; + return LLPS_BAD_NAME; + } + // list + LispVal *name = XCAR(entry); + if (!is_valid_variable_name(name)) { + *out = name; + return LLPS_BAD_NAME; + } + if (list_length_eq(entry, 1)) { + *out = LIST(XCAR(entry), Qnil, Qnil); + return LLPS_OK; + } else if (list_length_eq(entry, 2)) { + *out = LIST(name, XCAR(XCDR(entry)), Qnil); + return LLPS_OK; + } else if (list_length_eq(entry, 3)) { + LispVal *pvar = XCAR(XCDR(XCDR(entry))); + if (!is_valid_variable_name(pvar)) { + return LLPS_BAD_NAME; + } + *out = LIST(XCAR(entry), XCAR(XCDR(entry)), pvar); + return LLPS_OK; + } else { + *out = entry; + return LLPS_SYNTAX; + } +} + +#define RETURN_ERROR(err, obj) \ + { \ + result->status = err; \ + result->err_obj = (obj); \ + return; \ + } +void parse_lambda_list(LambdaListParseResult *result, LispVal *list) { + enum { REQ = 0, OPT = 1, KEY = 2, REST, MUST_CHANGE } mode = REQ; + unsigned int seen = 0; + result->err_obj = Qnil; + result->status = LLPS_OK; + struct LambdaList *out = &result->lambda_list; + // TODO check for repeat names + out->n_req = 0; + out->n_opt = 0; + out->n_kw = 0; + out->allow_other_keys = false; + out->req = Qnil; + out->opt = Qnil; + out->kw = Qnil; + out->rest = Qnil; + FOREACH_TAIL(list, tail) { + if (!LISTP(tail)) { + RETURN_ERROR(LLPS_DOTTED, list); + } + LispVal *cur = XCAR(tail); + if (cur == Qand_allow_other_keys) { + if (out->allow_other_keys) { + RETURN_ERROR(LLPS_REPEAT_SECTION, list); + } + out->allow_other_keys = true; + mode = MUST_CHANGE; + } else if (cur == Qand_rest) { + if (!NILP(out->rest) || mode == REST) { + RETURN_ERROR(LLPS_REPEAT_SECTION, list) + } + mode = REST; + } else if (cur == Qand_optional) { + if (seen & OPT) { + RETURN_ERROR(LLPS_REPEAT_SECTION, list) + } + seen |= OPT; + mode = OPT; + } else if (cur == Qand_key) { + if (seen & KEY) { + RETURN_ERROR(LLPS_REPEAT_SECTION, list) + } + seen |= KEY; + mode = KEY; + } else if (mode == MUST_CHANGE) { + // &rest without a variable + RETURN_ERROR(LLPS_SYNTAX, list) + } else if (mode == REST) { + if (!is_valid_variable_name(cur)) { + RETURN_ERROR(LLPS_BAD_NAME, cur) + } + out->rest = cur; + mode = MUST_CHANGE; + } else if (mode == OPT || mode == KEY) { + LispVal *entry; + LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur); + if (status != LLPS_OK) { + RETURN_ERROR(status, entry) + } + if (mode == OPT) { + out->opt = CONS(entry, out->opt); + ++out->n_opt; + } else { + out->kw = CONS(entry, out->kw); + ++out->n_kw; + } + } else if (!is_valid_variable_name(cur)) { + RETURN_ERROR(LLPS_BAD_NAME, cur); + } else { + out->req = CONS(cur, out->req); + ++out->n_req; + } + } + out->req = Fnreverse(out->req); + out->opt = Fnreverse(out->opt); + out->kw = Fnreverse(out->kw); +} +#undef RETURN_ERROR + +LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(), + const char *lisp_args, size_t args_len, + LispVal *docstr) { + LispFunction *obj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION); + obj->name = name; + obj->is_native = true; + obj->docstr = docstr; + obj->impl.native.zero = cfunc; + ReadStream stream; + read_stream_init(&stream, lisp_args, args_len); + LispVal *args_form = read(&stream); + if (!args_form) { + fprintf(stderr, "Builtin function lambda list had a syntax error\n"); + fprintf(stderr, "Name: "); + debug_print(stderr, name); + fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args); + exit(1); + } + LambdaListParseResult result; + parse_lambda_list(&result, args_form); + if (result.status != LLPS_OK) { + fprintf(stderr, "Error parsing builtin lambda list: %s\n", + llps_strerror(result.status)); + fprintf(stderr, "Name: "); + debug_print(stderr, name); + fprintf(stderr, "\nLambda list: \"%s\"\n", lisp_args); + exit(1); + } + return obj; +} diff --git a/src/function.h b/src/function.h index 6d80c3e..8439f34 100644 --- a/src/function.h +++ b/src/function.h @@ -2,15 +2,22 @@ #define INCLUDED_FUNCTION_H #include "base.h" +#include "lisp_string.h" + +DECLARE_SYMBOL(and_optional); +DECLARE_SYMBOL(and_rest); +DECLARE_SYMBOL(and_key); +DECLARE_SYMBOL(and_allow_other_keys); struct LambdaList { size_t n_req; size_t n_opt; size_t n_kw; + bool allow_other_keys; LispVal *req; // list of symbols LispVal *opt; // list of lists of (name default has-p-name) LispVal *kw; // ditto opt - LispVal *rest; // symbom (non-nil if we have a rest arg) + LispVal *rest; // symbol (non-nil if we have a rest arg) }; union native_function { @@ -23,11 +30,45 @@ union native_function { }; DEFOBJTYPE(Function, FUNCTION, FUNCTIONP, { + LispVal *name; // symbol (or nil for a lambda) bool is_native; struct LambdaList args; + LispVal *docstr; union { union native_function native; } impl; }); +typedef enum { + LLPS_OK, + LLPS_DOTTED, + LLPS_REPEAT_SECTION, + LLPS_REPEAT_NAME, + LLPS_SYNTAX, + LLPS_BAD_NAME, + LLPS_N_ERROS, +} LambdaListParseStatus; + +const char *llps_strerror(LambdaListParseStatus status); + +typedef struct { + struct LambdaList lambda_list; + LambdaListParseStatus status; + LispVal *err_obj; // the object the caused the above status +} LambdaListParseResult; + +void parse_lambda_list(LambdaListParseResult *out, LispVal *list); + +// This will cause the program to exit if an error occurs while parsing +// LISP_ARGS! +LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(), + const char *lisp_args, size_t args_len, + LispVal *docstr); +#define BUILTIN_FUNCTION_OBJ(cname) \ + make_builtin_function( \ + Q##cname, (LispVal * (*) ()) F##cname, internal_F##cname##_argstr, \ + internal_F##cname##_argstr_len, \ + make_lisp_string(internal_F##cname##_docstr, \ + internal_F##cname##_docstr_len, false, false)) + #endif diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk new file mode 100644 index 0000000..c18ce3f --- /dev/null +++ b/src/gen-init-globals.awk @@ -0,0 +1,86 @@ +# This script is designed to be run from the root of the project +BEGIN { + # Special symbols registered manually + special_syms["t"] = 1 + special_syms["nil"] = 1 + special_syms["unbound"] = 1 + special_syms["hash_string"] = 1 + special_syms["strings_equal"] = 1 + + FS = "[,(]" + + print "// This file was automatically generated by src/gen-init-globals.awk" + print "// DO NOT MODIFY THIS FILE MANUALLY!" + print "" + print "#include \"init_globals.h\"" + print "" + + for (i = 1; i < ARGC; i += 1) { + name = ARGV[i] + sub(/\.c$/, ".h", name) + sub(/^(.+\/)?src\//, "", name) + print "#include \"" name "\"" + } + + print "" + print "void register_globals() {" + first_header = 1 +} + +function maybe_print_file_header() { + if (!seen_files[FILENAME]) { + if (!first_header) { + print "" + } + first_header = 0 + seen_files[FILENAME] = 1 + name = FILENAME + sub(/^(.+\/)?src\//, "", name) + print " // " name + } +} + +function get_next_symbol() { + out = "" + if (!$2) { + while (1) { + old_rs = RS + RS = FS + getline line + RS = old_rs + if (line ~ /\s/) { + out = line + break + } + } + } else { + out = $2 + } + if (out && !special_syms[out]) { + gsub(/\s/, "", out) + return out + } else { + return "" + } +} + +function maybe_emit_next_symbol(entity) { + name = get_next_symbol() + if (name) { + print " REGISTER_GLOBAL_" entity "(" get_next_symbol() ");"; + } +} + +/DEFUN\(/ { + maybe_print_file_header() + maybe_emit_next_symbol("FUNCTION") +} + +/DEFINE_SYMBOL\(/ { + maybe_print_file_header() + maybe_emit_next_symbol("SYMBOL") +} + +END { + print "}" +} diff --git a/src/hashtable.c b/src/hashtable.c index 8d6462f..08b0129 100644 --- a/src/hashtable.c +++ b/src/hashtable.c @@ -1,5 +1,7 @@ #include "hashtable.h" +#include "lisp_string.h" + #define INITIAL_SIZE 32 #define GROWTH_THRESHOLD 0.5 #define GROWTH_FACTOR 2 @@ -25,16 +27,20 @@ DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn), } static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) { - if (NILP(ht->hash_fn)) { + if (NILP(ht->hash_fn) || ht->hash_fn == Qid) { return (uintptr_t) key; + } else if (ht->hash_fn == Qhash_string) { // needed for initialization + return XFIXNUM(Fhash_string(key)); } // TODO change abort(); } static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) { - if (NILP(ht->eq_fn)) { + if (NILP(ht->eq_fn) || ht->eq_fn == Qeq) { return key1 == key2; + } else if (ht->eq_fn == Qstrings_equal) { // needed for initialization + return !NILP(Fstrings_equal(key1, key2)); } // TODO change abort(); @@ -70,7 +76,7 @@ static void rehash(LispHashTable *ht, size_t new_size) { } static void maybe_rehash(LispHashTable *ht) { - if (TABLE_LOAD(ht) > GROWTH_THRESHOLD) { + if (TABLE_LOAD(ht) >= GROWTH_THRESHOLD) { rehash(ht, ht->size * GROWTH_FACTOR); } } diff --git a/src/init_globals.h b/src/init_globals.h new file mode 100644 index 0000000..b5b2b91 --- /dev/null +++ b/src/init_globals.h @@ -0,0 +1,23 @@ +#ifndef INCLUDED_INIT_GLOBALS_H +#define INCLUDED_INIT_GLOBALS_H + +#include "base.h" + +// defined in a generated file +void register_globals(void); + +#include + +#define REGISTER_GLOBAL_SYMBOL(cname) \ + { \ + Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name, \ + internal_Q##cname##_name_len, \ + false, false)); \ + } +#define REGISTER_GLOBAL_FUNCTION(cname) \ + { \ + REGISTER_GLOBAL_SYMBOL(cname); \ + ((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \ + } + +#endif diff --git a/src/lisp.c b/src/lisp.c index cf77557..aa7e7a6 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -1,9 +1,53 @@ #include "lisp.h" -void lisp_init() { +#include "hashtable.h" +#include "init_globals.h" +#include "lisp_string.h" + +LispVal *obarray; + +static void construct_manual_symbols() { + // IMPORTANT: the symbols listed here need to also be set as special in + // gen-init-globals.awk Qnil = Fmake_symbol(LISP_LITSTR("nil")); + MAKE_OBJ_IMMORTAL(Qnil); + ((LispSymbol *) Qnil)->function = Qnil; + ((LispSymbol *) Qnil)->plist = Qnil; Qt = Fmake_symbol(LISP_LITSTR("t")); + MAKE_OBJ_IMMORTAL(Qt); + ((LispSymbol *) Qt)->value = Qt; Qunbound = Fmake_symbol(LISP_LITSTR("unbound")); + MAKE_OBJ_IMMORTAL(Qunbound); + ((LispSymbol *) Qunbound)->value = Qunbound; + ((LispSymbol *) Qnil)->value = Qunbound; + + Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); + MAKE_OBJ_IMMORTAL(Qhash_string); + Qstrings_equal = Fmake_symbol(LISP_LITSTR("strings-equal")); + MAKE_OBJ_IMMORTAL(Qstrings_equal); +} + +static void register_manual_symbols() { +#define INTERN(cname) \ + Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname); + INTERN(nil); + INTERN(t); + INTERN(unbound); + INTERN(hash_string); + INTERN(strings_equal); +#undef INTERN +} + +void lisp_init() { + construct_manual_symbols(); + obarray = Fmake_hash_table(Qhash_string, Qstrings_equal); + // these call Fintern, so they need to have obarray constructed + ((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string); + ((LispSymbol *) Qstrings_equal)->function = + BUILTIN_FUNCTION_OBJ(hash_string); + + register_manual_symbols(); + register_globals(); } void lisp_shutdown() {} diff --git a/src/lisp.h b/src/lisp.h index 521073e..ab3b57b 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4,10 +4,13 @@ #include "base.h" #include "function.h" #include "hashtable.h" +#include "lisp_string.h" #include "list.h" #include +extern LispVal *obarray; + void lisp_init(void); void lisp_shutdown(void); diff --git a/src/lisp_string.c b/src/lisp_string.c new file mode 100644 index 0000000..49cef4e --- /dev/null +++ b/src/lisp_string.c @@ -0,0 +1,43 @@ +#include "lisp_string.h" + +#include + +LispVal *make_lisp_string(const char *data, size_t length, bool take, + bool copy) { + LispString *obj = lisp_alloc_object(sizeof(LispString), TYPE_STRING); + obj->owned = take; + obj->length = length; + if (copy) { + obj->data = lisp_malloc(length + 1); + memcpy(obj->data, data, length); + obj->data[length] = '\0'; + } else { + obj->data = (char *) data; + } + return obj; +} + +DEFUN(strings_equal, "strings-equal", (LispVal * string1, LispVal *string2), + "(string1 string2)", "") { + // TODO type checking + if (((LispString *) string1)->length != ((LispString *) string2)->length) { + return Qnil; + } + return memcmp(((LispString *) string1)->data, + ((LispString *) string2)->data, + ((LispString *) string1)->length) + == 0 + ? Qt + : Qnil; +} + +DEFUN(hash_string, "hash-string", (LispVal * string), "(string)", "") { + // TODO type checking + size_t len = ((LispString *) string)->length; + const char *str = ((LispString *) string)->data; + uintptr_t hash = 5381; + for (size_t i = 0; i < len; ++i) { + hash = ((hash << 5) + hash) + str[i]; + } + return MAKE_FIXNUM(hash); +} diff --git a/src/lisp_string.h b/src/lisp_string.h new file mode 100644 index 0000000..dccf3c0 --- /dev/null +++ b/src/lisp_string.h @@ -0,0 +1,20 @@ +#ifndef INCLUDED_LISP_STRING_H +#define INCLUDED_LISP_STRING_H + +#include "base.h" + +DEFOBJTYPE(String, STRING, STRINGP, { + size_t length; + char *data; + bool owned; +}); + +LispVal *make_lisp_string(const char *data, size_t length, bool take, + bool copy); +#define LISP_LITSTR(litstr) \ + (make_lisp_string(litstr, sizeof(litstr) - 1, false, false)) + +DECLARE_FUNCTION(strings_equal, (LispVal * string1, LispVal *string2)); +DECLARE_FUNCTION(hash_string, (LispVal * string)); + +#endif diff --git a/src/list.c b/src/list.c index 93d0949..a62b659 100644 --- a/src/list.c +++ b/src/list.c @@ -16,6 +16,14 @@ intptr_t list_length(LispVal *list) { return length; } +bool list_length_eq(LispVal *list, intptr_t size) { + assert(LISTP(list)); + while (size-- && CONSP(list)) { + list = XCDR(list); + } + return size == 0; +} + DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)", "Construct a new cons object from CAR and CDR.") { return CONS(car, cdr); @@ -25,3 +33,21 @@ DEFUN(length, "length", (LispVal * list), "(list)", "") { // TODO type check return MAKE_FIXNUM(list_length(list)); } + +DEFUN(length_eq, "length=", (LispVal * list, LispVal *length), "(list length)", + "Return non-nil if LIST's length is LENGTH.") { + // TODO type check + return list_length_eq(list, XFIXNUM(length)) ? Qt : Qnil; +} + +DEFUN(nreverse, "nreverse", (LispVal * list), "(list)", "") { + // TODO type checking + LispVal *rev = Qnil; + while (!NILP(list)) { + LispVal *next = XCDR(list); + RPLACD(list, rev); + rev = list; + list = next; + } + return rev; +} diff --git a/src/list.h b/src/list.h index 823be13..f990d11 100644 --- a/src/list.h +++ b/src/list.h @@ -98,8 +98,12 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) { #define FOREACH_TAIL(l, v) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v)) intptr_t list_length(LispVal *list); +// Return true if the length of LIST == SIZE +bool list_length_eq(LispVal *list, intptr_t size); DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr)); DECLARE_FUNCTION(length, (LispVal * list)); +DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length)); +DECLARE_FUNCTION(nreverse, (LispVal * list)); #endif diff --git a/src/main.c b/src/main.c index 929c2ce..d74c24b 100644 --- a/src/main.c +++ b/src/main.c @@ -6,14 +6,10 @@ int main(int argc, const char **argv) { lisp_init(); ReadStream s; - const char BUF[] = "`(1 . ,2)"; + const char BUF[] = "t"; read_stream_init(&s, BUF, sizeof(BUF) - 1); LispVal *l = read(&s); - if (!l) { - printf("EOF\n"); - } else { - debug_obj_info(stdout, l); - } + printf("%d\n", l == Qt); lisp_shutdown(); return 0; } diff --git a/src/read.c b/src/read.c index 9688668..0eb5a6f 100644 --- a/src/read.c +++ b/src/read.c @@ -1,5 +1,6 @@ #include "read.h" +#include "lisp_string.h" #include "list.h" #include @@ -406,7 +407,7 @@ LispVal *read(ReadStream *stream) { if (EOSP(stream)) { read_error(stream, 0, "quote not quoting anything"); } - return LIST(Fintern(LISP_LITSTR("quote")), read(stream)); + return LIST(Qquote, read(stream)); } case '`': { ++stream->backquote_level; @@ -415,7 +416,7 @@ LispVal *read(ReadStream *stream) { if (EOSP(stream)) { read_error(stream, 0, "backquote not quoting anything"); } - LispVal *to_return = LIST(Fintern(LISP_LITSTR("`")), read(stream)); + LispVal *to_return = LIST(Qbackquote, read(stream)); --stream->backquote_level; return to_return; } @@ -426,9 +427,9 @@ LispVal *read(ReadStream *stream) { pop_char(stream); LispVal *car; if (peek_char(stream) == '@') { - car = Fintern(LISP_LITSTR(",")); + car = Qcomma_at; } else { - car = Fintern(LISP_LITSTR(",@")); + car = Qcomma; } skip_whitespace(stream); if (EOSP(stream)) {