diff --git a/Makefile b/Makefile index 63f4c28..76dbe6e 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ CC=gcc CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\ -D_POSIX_C_SOURCE=200112L LD=gcc -LDFLAGS=$(LLVM_SAN_FLAGS) +LDFLAGS=-lm $(LLVM_SAN_FLAGS) SRCS:=$(wildcard src/*.c) OBJS:=$(SRCS:src/%.c=bin/%.o) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index 0807424..b431249 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,11 +1,4 @@ ;; -*- mode: lisp-data -*- -(fset 'test (lambda () (print print-circular))) - -(print print-circular) - -(let ((print-circular nil) - (b t)) - (test)) - -(print print-circular) +(prin1 1.0) +(write-byte 10) diff --git a/src/base.h b/src/base.h index 9d9c053..c176262 100644 --- a/src/base.h +++ b/src/base.h @@ -6,6 +6,7 @@ #include "memory.h" #include +#include #include // ################### @@ -17,12 +18,29 @@ typedef void LispVal; // # Fixnum and float stuff # // ########################## typedef intptr_t fixnum_t; +#define LISP_FIXNUM_PRINTF(code) PRI##code##PTR #if LISP_WORD_BITS == 32 -# define LISP_FLOAT_SCANF "f" +# define LISP_FLOAT_SCANF "f" +# define LISP_FLOAT_PRINTF "f" typedef lisp_float32_t lisp_float_t; +typedef lisp_float32_parts lisp_float_parts_t; +# define LISP_FLOAT_MIN_EXP FLOAT32_MIN_EXP +# define LISP_FLOAT_MAX_EXP FLOAT32_MAX_EXP +# define LISP_FLOAT_MAX_PRECISION FLOAT32_MAX_PRECISION +# define LISP_FLOAT_NAN LISP_FLOAT32_NAN() +# define LISP_FLOAT_POS_INF LISP_FLOAT32_INF(false) +# define LISP_FLOAT_NEG_INF LISP_FLOAT32_INF(true) #else -# define LISP_FLOAT_SCANF "lf" +# define LISP_FLOAT_SCANF "lf" +# define LISP_FLOAT_PRINTF "f" typedef lisp_float64_t lisp_float_t; +typedef lisp_float64_parts lisp_float_parts_t; +# define LISP_FLOAT_MIN_EXP FLOAT64_MIN_EXP +# define LISP_FLOAT_MAX_EXP FLOAT64_MAX_EXP +# define LISP_FLOAT_MAX_PRECISION FLOAT64_MAX_PRECISION +# define LISP_FLOAT_NAN LISP_FLOAT64_NAN() +# define LISP_FLOAT_POS_INF LISP_FLOAT64_INF(false) +# define LISP_FLOAT_NEG_INF LISP_FLOAT64_INF(true) #endif #define MOST_POSITIVE_FIXNUM ((intptr_t) ((INTPTR_MAX & ~(intptr_t) 3) >> 2)) @@ -73,6 +91,10 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) { return (LispVal *) ((bits & ~(uintptr_t) 3) | LISP_FLOAT_TAG); } +#define LISP_NAN MAKE_LISP_FLOAT(LISP_FLOAT_NAN) +#define LISP_POS_INF MAKE_LISP_FLOAT(LISP_FLOAT_POS_INF) +#define LISP_NEG_INF MAKE_LISP_FLOAT(LISP_FLOAT_NEG_INF) + // ############### // # Other types # // ############### diff --git a/src/lisp.c b/src/lisp.c index 64e1bc3..d986f53 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -4,6 +4,8 @@ #include "init_globals.h" #include "lisp_string.h" +#include + LispVal *obarray; static void construct_manual_symbols(void) { @@ -131,6 +133,22 @@ DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { return rval; } +DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") { + size_t nbindings = list_length(bindings); + if (nbindings < 2 || (nbindings & 1) != 0) { + // TODO error + abort(); + } + LispVal *value = Qnil; + for (LispVal *rest = bindings; !NILP(bindings); + bindings = XCDR(XCDR(bindings))) { + LispVal *name = FIRST(rest); + value = Feval(SECOND(rest), Vlexical_environment); + set_lexical_variable(name, value); + } + return value; +} + DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), "(bindings &rest body)", "") { CHECK_LISTP(bindings); diff --git a/src/lisp.h b/src/lisp.h index b8b2912..79a250f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -17,6 +17,7 @@ void lisp_shutdown(void); DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(progn, (LispVal * forms)); +DECLARE_FUNCTION(setq, (LispVal * bindings)); DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body)); DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise)); DECLARE_FUNCTION(and, (LispVal * forms)); diff --git a/src/memory.h b/src/memory.h index fb1e020..5516fc0 100644 --- a/src/memory.h +++ b/src/memory.h @@ -2,6 +2,7 @@ #define INCLUDED_MEMORY_H #include +#include #include #include #include @@ -10,7 +11,7 @@ // Geneal macros #ifndef __has_attribute -# define __has_attribute(attr) 0 +# define __has_attribute(x) 0 #endif #if __has_attribute(always_inline) && defined(_NDEBUG) @@ -98,6 +99,142 @@ static ALWAYS_INLINE lisp_float64_t INT_TO_FLOAT64_BITS(uint64_t i) { uint32_t: INT_TO_FLOAT32_BITS(i), \ uint64_t: INT_TO_FLOAT64_BITS(i)) +#define FLOAT_POSITIVE 0 +#define FLOAT_NEGATIVE 1 +typedef struct +#if __has_attribute(packed) + __attribute__((packed)) +#endif +{ + uint32_t sign : 1; + int32_t exp : 8; + uint32_t mantissa : 23; +} lisp_float32_parts; +#define FLOAT32_MIN_EXP -127 +#define FLOAT32_MAX_EXP 127 +#define FLOAT32_MAX_PRECISION 6 +#define FLOAT32_MAX_MANTISSA 0x7fffff + +typedef struct +#if __has_attribute(packed) + __attribute__((packed)) +#endif +{ + uint64_t sign : 1; + int64_t exp : 11; + uint64_t mantissa : 52; +} lisp_float64_parts; +#define FLOAT64_MIN_EXP -1023 +#define FLOAT64_MAX_EXP 1023 +#define FLOAT64_MAX_PRECISION 15 +#define FLOAT64_MAX_MANTISSA 0xfffffffffffff + +static ALWAYS_INLINE lisp_float32_parts FLOAT32_TO_PARTS(lisp_float32_t flt) { +#if __has_attribute(packed) + union { + lisp_float32_parts parts; + lisp_float32_t flt_val; + } conv = {.flt_val = flt}; + conv.parts.exp -= 127; + return conv.parts; +#else + uint32_t bits = FLOAT_TO_INT_BITS(flt); + return (lisp_float32_parts) { + .sign = bits >> 31, + .exp = (bits >> 23) - 127, + .mantissa = bits & 0x7fffff, + }; +#endif +} + +static ALWAYS_INLINE lisp_float64_parts FLOAT64_TO_PARTS(lisp_float64_t flt) { +#if __has_attribute(packed) + union { + lisp_float64_parts parts; + lisp_float64_t flt_val; + } conv = {.flt_val = flt}; + conv.parts.exp -= 1023; + return conv.parts; +#else + uint64_t bits = FLOAT_TO_INT_BITS(flt); + return (lisp_float64_parts) { + .sign = bits >> 63, + .exp = (bits >> 52) - 1023, + .mantissa = bits & 0xfffffffffffff, + }; +#endif +} + +#define FLOAT_TO_PARTS(flt) \ + _Generic((flt), \ + lisp_float32_t: FLOAT32_TO_PARTS(flt), \ + lisp_float64_t: FLOAT64_TO_PARTS(flt)) + +static ALWAYS_INLINE lisp_float64_t PARTS_TO_FLOAT64(lisp_float64_parts parts) { +#if __has_attribute(packed) + parts.exp += 1023; + union { + lisp_float64_parts parts; + lisp_float64_t flt_val; + } conv = {.parts = parts}; + return conv.flt_val; +#else + return INT_TO_FLOAT64_BITS(parts.sign << 63 | (parts.exp + 1023) << 52 + | parts.mantissa); +#endif +} + +static ALWAYS_INLINE lisp_float32_t PARTS_TO_FLOAT32(lisp_float32_parts parts) { +#if __has_attribute(packed) + parts.exp += 127; + union { + lisp_float32_parts parts; + lisp_float32_t flt_val; + } conv = {.parts = parts}; + return conv.flt_val; +#else + return INT_TO_FLOAT32_BITS(parts.sign << 31 | (parts.exp + 127) << 23 + | parts.mantissa); +#endif +} + +#define PARTS_TO_FLOAT(parts) \ + _Generic((parts), \ + lisp_float32_parts: PARTS_TO_FLOAT32(parts), \ + lisp_float64_parts: PARTS_TO_FLOAT64(parts)) + +static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_NAN(void) { + return PARTS_TO_FLOAT32((lisp_float32_parts) { + .sign = FLOAT_POSITIVE, + .exp = FLOAT32_MAX_EXP, + .mantissa = FLOAT32_MAX_MANTISSA, + }); +} + +static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_INF(bool negative) { + return PARTS_TO_FLOAT32((lisp_float32_parts) { + .sign = negative ? FLOAT_NEGATIVE : FLOAT_POSITIVE, + .exp = FLOAT32_MAX_EXP, + .mantissa = 0, + }); +} + +static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_NAN(void) { + return PARTS_TO_FLOAT64((lisp_float64_parts) { + .sign = FLOAT_POSITIVE, + .exp = FLOAT64_MAX_EXP, + .mantissa = FLOAT64_MAX_MANTISSA, + }); +} + +static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(bool negative) { + return PARTS_TO_FLOAT64((lisp_float64_parts) { + .sign = negative ? FLOAT_NEGATIVE : FLOAT_POSITIVE, + .exp = FLOAT64_MAX_EXP, + .mantissa = 0, + }); +} + // Allocator void *lisp_realloc(void *oldptr, size_t size); void *lisp_malloc(size_t size); @@ -130,6 +267,25 @@ static ALWAYS_INLINE void add_timespecs(const struct timespec *t1, out->tv_nsec = nsec; } +static ALWAYS_INLINE size_t signed_number_length(intmax_t n) { + if (!n) { + return 1; + } + size_t sign_part = 0; + if (n < 0) { + n = -n; + sign_part = 1; + } + return sign_part + floor(log10(n)) + 1; +} + +static ALWAYS_INLINE size_t unsigned_number_length(uintmax_t n) { + if (!n) { + return 1; + } + return floor(log10(n)) + 1; +} + typedef struct { // this is actually size + 1 bytes for the null byte char *buffer; diff --git a/src/print.c b/src/print.c index a41109e..c088ede 100644 --- a/src/print.c +++ b/src/print.c @@ -2,24 +2,197 @@ #include "lisp.h" +#include + DEFVAR(print_circular, "print-circular", "", Qt); DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100)); DEFVAR(print_level, "print-level", "", Qnil); +DEFVAR(print_base, "print-base", "", MAKE_FIXNUM(10)); +DEFVAR(print_base_upper, "print-base-upper", "", Qt); +DEFVAR(print_precision, "print-precision", "", MAKE_FIXNUM(6)); -struct PrintContext { +DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") { + if (NILP(ch)) { + fflush(stdout); + } + CHECK_TYPE(ch, TYPE_FIXNUM); + fixnum_t f = XFIXNUM(ch); + if (f < 0 || f > 255) { + // TODO error + abort(); + } + fputc(f, stdout); + return Qnil; +} + +struct PrintOptions { + bool readable; bool circle; - bool length; + fixnum_t length; + fixnum_t level; + fixnum_t base; + bool base_upper; + fixnum_t precision; }; -static void init_print_context(struct PrintContext *restrict pc) { - pc->circle = true; - pc->length = 80; +struct PrintContext { + struct PrintOptions opts; + LispVal *print_char_fun; + LispHashTable *seen_objects; + LispVal *length_stack; +}; + +static void init_print_options(struct PrintOptions *opts, bool readable) { + opts->readable = readable; + opts->circle = !NILP(Vprint_circular); + if (NILP(Vprint_length)) { + opts->length = SIZE_MAX; + } else { + CHECK_TYPE(Vprint_length, TYPE_FIXNUM); + opts->length = XFIXNUM(Vprint_length); + } + if (NILP(Vprint_level)) { + opts->level = SIZE_MAX; + } else { + CHECK_TYPE(Vprint_level, TYPE_FIXNUM); + opts->level = XFIXNUM(Vprint_level); + } + CHECK_TYPE(Vprint_base, TYPE_FIXNUM); + opts->base = XFIXNUM(Vprint_base); + if (opts->base < 2 || opts->base > 16) { + opts->base = 10; + } + opts->base_upper = !NILP(Vprint_base_upper); + CHECK_TYPE(Vprint_precision, TYPE_FIXNUM); + opts->precision = XFIXNUM(Vprint_precision); + if (opts->precision < 0) { + opts->precision = 0; + } else if (opts->precision > LISP_FLOAT_MAX_PRECISION) { + opts->precision = LISP_FLOAT_MAX_PRECISION; + } +} + +static void init_print_context(struct PrintContext *restrict pc, bool readable, + LispVal *print_char_fun) { + init_print_options(&pc->opts, readable); + if (NILP(print_char_fun)) { + pc->print_char_fun = Qwrite_byte; + } else { + pc->print_char_fun = print_char_fun; + } + pc->seen_objects = Fmake_hash_table(Qnil, Qnil); + pc->length_stack = Qnil; +} + +static void print_char(struct PrintContext *restrict pc, char c) { + CALL(pc->print_char_fun, MAKE_FIXNUM(c)); +} + +static void print_buffer(struct PrintContext *restrict pc, + const char *restrict buf, size_t len) { + for (size_t i = 0; i < len; ++i) { + print_char(pc, buf[i]); + } +} +#define PRINT_STATIC_BUFFER(pc, buf) print_buffer(pc, buf, sizeof(buf) - 1) + +static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) { + switch (pc->opts.base) { + case 2: + print_char(pc, '2'); + break; + case 8: + print_char(pc, '8'); + break; + case 10: + print_char(pc, '1'); + print_char(pc, '0'); + break; + case 16: + print_char(pc, '1'); + print_char(pc, '6'); + break; + default: + // TODO error + abort(); + } + print_char(pc, '#'); +} + +static void print_fixnum(struct PrintContext *restrict pc, LispVal *val) { + fixnum_t fn = XFIXNUM(val); + if (fn == 0) { + Ffuncall(pc->print_char_fun, MAKE_FIXNUM('0')); + } else { + if (pc->opts.base != 10 && pc->opts.readable) { + print_fixnum_base(pc, val); + } + if (fn < 0) { + fn = -fn; + print_char(pc, '-'); + } + // smallest base is 2 + fixnum_t base = pc->opts.base; + char buf[64]; + size_t num_len = 0; + while (fn) { + fixnum_t digit = fn % base; + fn /= base; + char to_print; + if (digit >= 0 && digit <= 9) { + to_print = '0' + digit; + } else if (digit >= 10 && digit <= 15) { + to_print = (pc->opts.base_upper ? 'A' : 'a') + digit - 10; + } else { + abort(); + } + buf[63 - (num_len++)] = to_print; + } + print_buffer(pc, &buf[64 - num_len], num_len); + } +} + +static void print_float(struct PrintContext *restrict pc, LispVal *val) { + lisp_float_t fv = XLISP_FLOAT(val); + switch (fpclassify(fv)) { + case FP_ZERO: + PRINT_STATIC_BUFFER(pc, "0.0"); + break; + case FP_NAN: + PRINT_STATIC_BUFFER(pc, "0.0eNaN"); + break; + case FP_INFINITE: + if (fv < 0.0) { + PRINT_STATIC_BUFFER(pc, "0.0eInf"); + } else { + PRINT_STATIC_BUFFER(pc, "-0.0eInf"); + } + break; + case FP_SUBNORMAL: + case FP_NORMAL: { + char fmt[16]; + int written = + snprintf(fmt, sizeof(fmt), "%%%" LISP_FIXNUM_PRINTF(d) "g", + pc->opts.precision); + assert(written < sizeof(fmt)); + char buffer[32]; + written = snprintf(buffer, sizeof(buffer), fmt, buffer); + assert(written < sizeof(buffer)); + print_buffer(pc, buffer, written); + } break; + default: + abort(); + } } static void print_driver(struct PrintContext *restrict pc, LispVal *val) { switch (TYPE_OF(val)) { case TYPE_FIXNUM: + print_fixnum(pc, val); + break; case TYPE_FLOAT: + print_float(pc, val); + break; case TYPE_CONS: case TYPE_STRING: case TYPE_SYMBOL: @@ -32,16 +205,20 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) { } } -DEFUN(princ, "princ", (LispVal * val), "(val)", "") { +// Not readable +DEFUN(princ, "princ", (LispVal * val, LispVal *print_char_fun), + "(val &optional print-char-fun)", "") { struct PrintContext pc; - init_print_context(&pc); + init_print_context(&pc, false, print_char_fun); print_driver(&pc, val); return Qnil; } -DEFUN(prin1, "prin1", (LispVal * val), "(val)", "") { +// Readable +DEFUN(prin1, "prin1", (LispVal * val, LispVal *print_char_fun), + "(val &optional print-char-fun)", "") { struct PrintContext pc; - init_print_context(&pc); + init_print_context(&pc, true, print_char_fun); print_driver(&pc, val); return Qnil; } diff --git a/src/print.h b/src/print.h index 36bfcc6..13007f1 100644 --- a/src/print.h +++ b/src/print.h @@ -8,11 +8,17 @@ DECLARE_VARIABLE(print_circular); DECLARE_VARIABLE(print_length); DECLARE_VARIABLE(print_level); +DECLARE_VARIABLE(print_base); +DECLARE_VARIABLE(print_base_upper); +DECLARE_VARIABLE(print_precision); + +// For now, a print character function takes nil to mean flush +DECLARE_FUNCTION(write_byte, (LispVal * ch)); // Pretty print -DECLARE_FUNCTION(princ, (LispVal * val)); +DECLARE_FUNCTION(princ, (LispVal * val, LispVal *print_char_fun)); // Quoted print -DECLARE_FUNCTION(prin1, (LispVal * val)); +DECLARE_FUNCTION(prin1, (LispVal * val, LispVal *print_char_fun)); __attribute__((no_sanitize("address"))) void debug_print(FILE *file, LispVal *obj); diff --git a/src/read.c b/src/read.c index 0eb5a6f..88774f7 100644 --- a/src/read.c +++ b/src/read.c @@ -315,6 +315,7 @@ LispVal *next_number_or_symbol(ReadStream *stream, int base) { size_t number_start = stream->off; size_t exp_start = 0; bool had_number = false; + bool negative = false; int c; while (!SYMBOL_END_P(peek_char(stream))) { c = pop_char(stream); @@ -339,7 +340,32 @@ LispVal *next_number_or_symbol(ReadStream *stream, int base) { && stream->off - 1 != exp_start) { goto change_to_symbol; } - // fallthrough + // for inf + if (c == '-' && stream->off - 1 == number_start) { + negative = true; + } + } else if (exp_start == stream->off - 1 && base == ANY_BASE + && (c == 'n' || c == 'N')) { + // attempt to read "nan" or fallback to symbol + if (tolower(pop_char(stream)) != 'a' + || tolower(pop_char(stream)) != 'n') { + goto change_to_symbol; + } + if (SYMBOL_END_P(peek_char(stream))) { + return LISP_NAN; + } + goto change_to_symbol; + } else if (exp_start == stream->off - 1 && base == ANY_BASE + && (c == 'i' || c == 'I')) { + // same for "inf" + if (tolower(pop_char(stream)) != 'n' + || tolower(pop_char(stream)) != 'f') { + goto change_to_symbol; + } + if (SYMBOL_END_P(peek_char(stream))) { + return negative ? LISP_NEG_INF : LISP_POS_INF; + } + goto change_to_symbol; } else if (!is_base_char(base, c)) { if ((c == 'e' || c == 'E') && !exp_start && base == ANY_BASE && had_number) { diff --git a/src/stack.c b/src/stack.c index f592668..18d334b 100644 --- a/src/stack.c +++ b/src/stack.c @@ -252,7 +252,7 @@ void set_lexical_variable(LispVal *name, LispVal *value) { abort(); } if (DYNAMIC_SYMBOL_P(name)) { - push_dynamic_binding(name, value); + SET_SYMBOL_VALUE(name, value); } else { Vlexical_environment = Fplist_put(Vlexical_environment, name, value); } diff --git a/src/stack.h b/src/stack.h index 797f9a0..c3b71f6 100644 --- a/src/stack.h +++ b/src/stack.h @@ -153,4 +153,17 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, } noreturn void continue_unwinding(void); +#define UNWIND_PROTECT(body, cleanup) \ + { \ + jmp_buf _internal_jb; \ + if (setjmp(_internal_jb) == 0) { \ + push_unwind_protect_frame(&_internal_jb); \ + StackFrame *_internal_target = LISP_STACK_REF(); \ + {body}; \ + unwind_to(_internal_target); \ + } else { \ + cleanup \ + } \ + }; + #endif