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

Compare commits

base: Zander671/glisp:7b854c15595a475bd48f6065e1cbb480cdb51e27
Branches Tags
Zander671/glisp:main
...
compare: Zander671/glisp:main
Branches Tags
Zander671/glisp:main
2 Commits
7b854c1559 ... main
Author SHA1 Message Date
Zander671 17c11d90ea Finish printing 2026-08-13 14:10:29 -07:00
Zander671 20aed63851 Finish float printing 2026-08-13 03:51:55 -07:00
7 changed files with 207 additions and 157 deletions
Expand all files Collapse all files
lisp/kernel.gl
+5 -2
View File
@@ -1,4 +1,7 @@
;; -*- mode: lisp-data -*-
(prin1 1.0)
(write-byte 10)
(let ((print-quoted nil))
(prin1 '(quote a))
(write-byte ?\n))
(prin1 '(quote a))
(write-byte ?\n)
src/base.h
+6 -14
View File
@@ -23,24 +23,16 @@ typedef intptr_t fixnum_t;
# 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)
# define LISP_FLOAT_INF LISP_FLOAT32_INF()
# define LISP_FLOAT_MAX_PRECISION FLOAT32_MAX_PRECISION
#else
# 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)
# define LISP_FLOAT_INF LISP_FLOAT64_INF()
# define LISP_FLOAT_MAX_PRECISION FLOAT64_MAX_PRECISION
#endif
#define MOST_POSITIVE_FIXNUM ((intptr_t) ((INTPTR_MAX & ~(intptr_t) 3) >> 2))
@@ -92,8 +84,8 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
}
#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)
#define LISP_POS_INF MAKE_LISP_FLOAT(LISP_FLOAT_INF)
#define LISP_NEG_INF MAKE_LISP_FLOAT(-LISP_FLOAT_INF)
// ###############
// # Other types #
src/memory.h
+9 -127
View File
@@ -51,11 +51,13 @@ static ALWAYS_INLINE bool LITTLE_ENDIAN_P(void) {
#endif
// Check if we support this system's floating point implementation
#if FLT_RADIX != 2 || FLT_MANT_DIG != 24 || DBL_MANT_DIG != 53 \
|| FLT_MAX_EXP != 128 || DBL_MAX_EXP != 1024
|| FLT_MAX_EXP != 128 || DBL_MAX_EXP != 1024 || !defined(INFINITY)
# error "Floating point implementation not supported."
#endif
typedef float lisp_float32_t;
typedef double lisp_float64_t;
#define FLOAT32_MAX_PRECISION 6
#define FLOAT64_MAX_PRECISION 15
static ALWAYS_INLINE uint32_t FLOAT32_TO_INT_BITS(lisp_float32_t flt) {
union {
@@ -99,140 +101,20 @@ 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,
});
return INT_TO_FLOAT32_BITS(~(uint32_t) 0);
}
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_float32_t LISP_FLOAT32_INF(void) {
return INFINITY;
}
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,
});
return INT_TO_FLOAT64_BITS(~(uint64_t) 0);
}
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,
});
static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(void) {
return INFINITY;
}
// Allocator
src/print.c
+171 -2
View File
@@ -1,8 +1,11 @@
#include "print.h"
#include "lisp.h"
// for WHITESPACEP, READ_EOS, and SYMBOL_END_P
#include "read.h"
#include <limits.h>
#include <string.h>
DEFVAR(print_circular, "print-circular", "", Qt);
DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100));
@@ -10,6 +13,7 @@ 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));
DEFVAR(print_quoted, "print-quoted", "", Qt);
DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
if (NILP(ch)) {
@@ -33,6 +37,7 @@ struct PrintOptions {
fixnum_t base;
bool base_upper;
fixnum_t precision;
bool quoted;
};
struct PrintContext {
@@ -70,6 +75,7 @@ static void init_print_options(struct PrintOptions *opts, bool readable) {
} else if (opts->precision > LISP_FLOAT_MAX_PRECISION) {
opts->precision = LISP_FLOAT_MAX_PRECISION;
}
opts->quoted = !NILP(Vprint_quoted);
}
static void init_print_context(struct PrintContext *restrict pc, bool readable,
@@ -96,6 +102,8 @@ static void print_buffer(struct PrintContext *restrict pc,
}
#define PRINT_STATIC_BUFFER(pc, buf) print_buffer(pc, buf, sizeof(buf) - 1)
static void print_driver(struct PrintContext *restrict pc, LispVal *val);
static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) {
switch (pc->opts.base) {
case 2:
@@ -172,12 +180,23 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) {
case FP_NORMAL: {
char fmt[16];
int written =
snprintf(fmt, sizeof(fmt), "%%%" LISP_FIXNUM_PRINTF(d) "g",
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);
written = snprintf(buffer, sizeof(buffer), fmt, fv);
assert(written < sizeof(buffer));
size_t i;
for (i = 0; i < written && buffer[i] != 'e'; ++i) {
if (buffer[i] == '.') {
goto no_add;
}
}
memmove(buffer + i + 2, buffer + i, written - i);
buffer[i] = '.';
buffer[i + 1] = '0';
written += 2;
no_add:
print_buffer(pc, buffer, written);
} break;
default:
@@ -185,6 +204,137 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) {
}
}
static void print_cons(struct PrintContext *restrict pc, LispVal *val) {
if (pc->opts.quoted && EQ(XCAR(val), Qquote) && list_length_eq(val, 2)) {
print_char(pc, '\'');
print_driver(pc, SECOND(val));
return;
}
print_char(pc, '(');
bool first = true;
DOTAILS(rest, val) {
if (!first) {
print_char(pc, ' ');
}
first = false;
print_driver(pc, XCAR(rest));
if (!LISTP(XCDR(rest))) {
PRINT_STATIC_BUFFER(pc, " . ");
print_driver(pc, XCDR(rest));
break;
}
}
print_char(pc, ')');
}
static void print_readable_string(struct PrintContext *restrict pc,
LispVal *val) {
LispString *s = val;
print_char(pc, '"');
for (size_t i = 0; i < s->length; ++i) {
char c = s->data[i];
switch (c) {
case '"':
PRINT_STATIC_BUFFER(pc, "\\\"");
break;
case '\n':
PRINT_STATIC_BUFFER(pc, "\\n");
break;
case '\t':
PRINT_STATIC_BUFFER(pc, "\\t");
case '\0':
PRINT_STATIC_BUFFER(pc, "\\0");
break;
default:
print_char(pc, c);
break;
}
}
print_char(pc, '"');
}
static void print_pretty_string(struct PrintContext *restrict pc,
LispVal *val) {
LispString *s = val;
print_buffer(pc, s->data, s->length);
}
static void print_readable_symbol(struct PrintContext *restrict pc,
LispVal *val) {
LispSymbol *sym = val;
assert(STRINGP(sym->name));
LispString *n = sym->name;
for (size_t i = 0; i < n->length; ++i) {
char c = n->data[i];
if (c == '\n') {
PRINT_STATIC_BUFFER(pc, "\\n");
} else if (c == '\t') {
PRINT_STATIC_BUFFER(pc, "\\t");
} else if (c == '\0') {
PRINT_STATIC_BUFFER(pc, "\\0");
} else if (c == '\\' || SYMBOL_END_P(c)) {
print_char(pc, '\\');
print_char(pc, c);
} else {
print_char(pc, c);
}
}
}
static void print_pretty_symbol(struct PrintContext *restrict pc,
LispVal *val) {
LispSymbol *sym = val;
assert(STRINGP(sym->name));
print_pretty_string(pc, sym->name);
}
static void print_vector(struct PrintContext *restrict pc, LispVal *val) {
LispVector *vec = val;
print_char(pc, '[');
bool first = true;
for (size_t i = 0; i < vec->length; ++i) {
if (!first) {
print_char(pc, ' ');
}
first = false;
print_driver(pc, vec->data[i]);
}
print_char(pc, ']');
}
static void print_hash_table(struct PrintContext *restrict pc, LispVal *val) {
LispHashTable *ht = val;
PRINT_STATIC_BUFFER(pc, "<hash-table count=");
// large enough for 32 or 64 bit word size
char buffer[32];
int written = snprintf(buffer, sizeof(buffer), "%zu", ht->count);
assert(written < sizeof(buffer));
print_buffer(pc, buffer, written);
print_char(pc, '>');
}
static void print_function(struct PrintContext *restrict pc, LispVal *val) {
LispFunction *f = val;
print_char(pc, '<');
switch (f->type) {
case FUNCTION_NATIVE:
PRINT_STATIC_BUFFER(pc, "native-function");
break;
case FUNCTION_INTERP:
PRINT_STATIC_BUFFER(pc, "interp-function");
break;
default:
abort();
}
print_char(pc, ' ');
// large enough for 32 or 64 bit word size
char buffer[32];
int written = snprintf(buffer, sizeof(buffer), "0x%jx", (uintmax_t) &f);
assert(written < sizeof(buffer));
print_buffer(pc, buffer, written);
print_char(pc, '>');
}
static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
switch (TYPE_OF(val)) {
case TYPE_FIXNUM:
@@ -194,11 +344,30 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
print_float(pc, val);
break;
case TYPE_CONS:
print_cons(pc, val);
break;
case TYPE_STRING:
if (pc->opts.readable) {
print_readable_string(pc, val);
} else {
print_pretty_string(pc, val);
}
break;
case TYPE_SYMBOL:
if (pc->opts.readable) {
print_readable_symbol(pc, val);
} else {
print_pretty_symbol(pc, val);
}
break;
case TYPE_VECTOR:
print_vector(pc, val);
break;
case TYPE_HASH_TABLE:
print_hash_table(pc, val);
break;
case TYPE_FUNCTION:
print_function(pc, val);
break;
default:
abort();
src/print.h
+1
View File
@@ -11,6 +11,7 @@ DECLARE_VARIABLE(print_level);
DECLARE_VARIABLE(print_base);
DECLARE_VARIABLE(print_base_upper);
DECLARE_VARIABLE(print_precision);
DECLARE_VARIABLE(print_quoted);
// For now, a print character function takes nil to mean flush
DECLARE_FUNCTION(write_byte, (LispVal * ch));
src/read.c
+3 -12
View File
@@ -21,8 +21,6 @@ void read_stream_init(ReadStream *stream, const char *buffer, size_t length) {
stream->backquote_level = 0;
}
#define READ_EOS -1
static ALWAYS_INLINE bool EOSP(const ReadStream *stream) {
return stream->off == stream->len;
}
@@ -52,10 +50,6 @@ static int peek_char(const ReadStream *stream) {
return peek_nth_char(stream, 0);
}
static ALWAYS_INLINE bool WHITESPACEP(int c) {
return c == ' ' || c == '\t' || c == '\n';
}
static void skip_whitespace(ReadStream *stream) {
bool in_comment = false;
int c;
@@ -226,12 +220,6 @@ LispVal *next_char_literal(ReadStream *stream) {
}
}
static ALWAYS_INLINE bool SYMBOL_END_P(int c) {
return WHITESPACEP(c) || c == READ_EOS || c == '(' || c == ')' || c == '['
|| c == ']' || c == '\'' || c == '\"' || c == ',' || c == '@'
|| c == '`' || c == ';';
}
LispVal *next_symbol(ReadStream *stream) {
bool backslash = false;
char *name = lisp_malloc(1);
@@ -247,6 +235,9 @@ LispVal *next_symbol(ReadStream *stream) {
case READ_EOS:
free(name);
read_error(stream, 0, "backslash not escaping anything");
case '\\':
// nothing to do
break;
case 'n':
c = '\n';
break;
src/read.h
+12
View File
@@ -5,6 +5,18 @@
#include <stddef.h>
#define READ_EOS -1
static ALWAYS_INLINE bool WHITESPACEP(int c) {
return c == ' ' || c == '\t' || c == '\n';
}
static ALWAYS_INLINE bool SYMBOL_END_P(int c) {
return WHITESPACEP(c) || c == READ_EOS || c == '(' || c == ')' || c == '['
|| c == ']' || c == '\'' || c == '\"' || c == ',' || c == '@'
|| c == '`' || c == ';';
}
typedef struct {
const char *buffer;
size_t len;