Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Global generation

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-01-18 03:11:17 -08:00
parent 94d5749d31
commit c0b18cda5a
16 changed files with 571 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
Makefile
View File

@ -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/

46
src/base.c
View File

@ -1,5 +1,8 @@
#include "base.h"
#include "hashtable.h"
#include "lisp.h"
#include <string.h>
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;
}

41
src/base.h
View File

@ -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,21 +141,32 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
LispVal **data;
});
// 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 *Q##cname##_name; \
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; \
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; \
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); \
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
@ -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

183
src/function.c
View File

@ -1 +1,184 @@
#include "function.h"
#include "lisp.h"
#include "list.h"
#include "read.h"
#include <stdio.h>
#include <stdlib.h>
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;
}

43
src/function.h
View File

@ -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

86
src/gen-init-globals.awk Normal file
View File

@ -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 "}"
}

12
src/hashtable.c
View File

@ -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);
}
}

23
src/init_globals.h Normal file
View File

@ -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 <stdio.h>
#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

46
src/lisp.c
View File

@ -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() {}

3
src/lisp.h
View File

@ -4,10 +4,13 @@
#include "base.h"
#include "function.h"
#include "hashtable.h"
#include "lisp_string.h"
#include "list.h"
#include <stdio.h>
extern LispVal *obarray;
void lisp_init(void);
void lisp_shutdown(void);

43
src/lisp_string.c Normal file
View File

@ -0,0 +1,43 @@
#include "lisp_string.h"
#include <string.h>
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);
}

20
src/lisp_string.h Normal file
View File

@ -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

26
src/list.c
View File

@ -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;
}

4
src/list.h
View File

@ -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

8
src/main.c
View File

@ -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;
}

9
src/read.c
View File

@ -1,5 +1,6 @@
#include "read.h"
#include "lisp_string.h"
#include "list.h"
#include <ctype.h>
@ -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)) {