Work on dynamic variable

lisp/kernel.gl

@@ -1,3 +1,10 @@
 ;; -*- mode: lisp-data -*-
 
-(test a)
+(fset 'test (lambda () (print print-circular)))
+
+(print print-circular)
+
+(let ((print-circular nil))
+  (test))
+
+(print print-circular)

src/base.c

@@ -74,9 +74,7 @@ noreturn void signal_type_error(LispVal *obj, LispVal *typespec) {
 DEFINE_SYMBOL(nil, "nil");
 DEFINE_SYMBOL(t, "t");
 DEFINE_SYMBOL(unbound, "unbound");
-DEFINE_SYMBOL(lexical_environment, "lexical-environment");
+DEFVAR(lexical_environment, "lexical-environment", "", Qnil);
-
-LispVal *Vlexical_environment;
 
 DEFUN(id, "id", (LispVal * obj), "(id)", "") {
     // TODO not all values are handled here
@@ -112,10 +110,12 @@ DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
     obj->name = name;
     obj->function = Qnil;
     obj->plist = Qnil;
+    obj->value_type = SYMBOL_NORMAL;
     if (KEYWORDP(obj)) {
-        obj->value = obj;
+        obj->value.normal = obj;
+        obj->flags |= SYMBOL_CONST_VALUE;
     } else {
-        obj->value = Qunbound;
+        obj->value.normal = Qunbound;
     }
     return obj;
 }
@@ -161,6 +161,10 @@ DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") {
 
 DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") {
     CHECK_TYPE(sym, TYPE_SYMBOL);
+    if (CONST_FUNCTION_P(sym)) {
+        // TODO throw
+        abort();
+    }
     ((LispSymbol *) sym)->function = value;
     return value;
 }

src/base.h

@@ -162,7 +162,6 @@ static ALWAYS_INLINE void internal_CHECK_TYPE(LispVal *obj, size_t count,
     // Failed
     internal_CHECK_TYPE_signal_type_error(obj, count, types);
 }
-#define internal_CHECK_TYPE1(obj, type) internal_CHECK_TYPE(obj, v1, )
 #define internal_CHECK_TYPE_SUB(obj, count, a1, a2, a3, a4, a5, a6, ...) \
     internal_CHECK_TYPE((obj), count, a1, a2, a3, a4, a5, a6)
 #define CHECK_TYPE(obj, ...)                                             \
@@ -188,10 +187,26 @@ DEFOBJTYPE(String, STRING, STRINGP, {
     bool owned;
 });
 
+enum SymbolValueType {
+    SYMBOL_NORMAL,
+    SYMBOL_NATIVE,
+};
+
+enum SymbolFlags {
+    SYMBOL_DYNAMIC = 1,
+    SYMBOL_CONST_VALUE = 2,
+    SYMBOL_CONST_FUNCTION = 4,
+};
+
 DEFOBJTYPE(Symbol, SYMBOL, SYMBOLP, {
     LispVal *name; // string
+    enum SymbolValueType value_type : 1;
+    enum SymbolFlags flags : 7;
     LispVal *function;
-    LispVal *value;
+    union {
+        LispVal *normal;
+        LispVal **native;
+    } value;
     LispVal *plist;
 });
 
@@ -215,6 +230,11 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     extern const size_t internal_Q##cname##_name_len; \
     extern LispVal *Q##cname
 
+#define DECLARE_VARIABLE(cname)                     \
+    DECLARE_SYMBOL(cname);                          \
+    extern LispVal *internal_V##cname##_init(void); \
+    extern LispVal *V##cname
+
 #define DECLARE_FUNCTION(cname, cargs)                  \
     DECLARE_SYMBOL(cname);                              \
     extern const char *internal_F##cname##_argstr;      \
@@ -228,6 +248,13 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     const size_t internal_Q##cname##_name_len = sizeof(lisp_name) - 1; \
     LispVal *Q##cname
 
+#define DEFVAR(cname, lisp_name, doc, init_val) \
+    DEFINE_SYMBOL(cname, lisp_name);            \
+    LispVal *internal_V##cname##_init(void) {   \
+        return (init_val);                      \
+    }                                           \
+    LispVal *V##cname
+
 #define DEFUN(cname, lisp_name, cargs, lisp_args, doc)                   \
     DEFINE_SYMBOL(cname, lisp_name);                                     \
     const char *internal_F##cname##_argstr = lisp_args;                  \
@@ -244,8 +271,17 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
         Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name,     \
                                             internal_Q##cname##_name_len, \
                                             false, false));               \
+        ((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL;            \
         lisp_gc_register_static_object(Q##cname);                         \
     }
+#define REGISTER_GLOBAL_VARIABLE(cname)                        \
+    REGISTER_GLOBAL_SYMBOL(cname);                             \
+    {                                                          \
+        V##cname = internal_V##cname##_init();                 \
+        ((LispSymbol *) Q##cname)->value_type = SYMBOL_NATIVE; \
+        ((LispSymbol *) Q##cname)->value.native = &V##cname;   \
+        ((LispSymbol *) Q##cname)->flags |= SYMBOL_DYNAMIC;    \
+    }
 #define REGISTER_GLOBAL_FUNCTION(cname)                                    \
     {                                                                      \
         REGISTER_GLOBAL_SYMBOL(cname);                                     \
@@ -263,7 +299,7 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
 DECLARE_SYMBOL(nil);
 DECLARE_SYMBOL(t);
 DECLARE_SYMBOL(unbound);
-DECLARE_SYMBOL(lexical_environment);
+DECLARE_VARIABLE(lexical_environment);
 
 extern LispVal *Vlexical_environment;
 
@@ -295,12 +331,45 @@ DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val));
 
 static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) {
     assert(SYMBOLP(sym));
-    return ((LispSymbol *) sym)->value;
+    LispSymbol *s = (LispSymbol *) sym;
+    switch (s->value_type) {
+    case SYMBOL_NORMAL:
+        return s->value.normal;
+    case SYMBOL_NATIVE:
+        return *s->value.native;
+    }
+}
+
+static ALWAYS_INLINE bool CONST_VALUE_P(LispVal *sym) {
+    assert(SYMBOLP(sym));
+    return ((LispSymbol *) sym)->flags & SYMBOL_CONST_VALUE;
+}
+
+static ALWAYS_INLINE bool CONST_FUNCTION_P(LispVal *sym) {
+    assert(SYMBOLP(sym));
+    return ((LispSymbol *) sym)->flags & SYMBOL_CONST_FUNCTION;
+}
+
+static ALWAYS_INLINE bool DYNAMIC_SYMBOL_P(LispVal *sym) {
+    assert(SYMBOLP(sym));
+    return ((LispSymbol *) sym)->flags & SYMBOL_DYNAMIC;
 }
 
 static ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) {
     assert(SYMBOLP(sym));
-    ((LispSymbol *) sym)->value = value;
+    LispSymbol *s = (LispSymbol *) sym;
+    if (CONST_VALUE_P(sym)) {
+        // TODO throw
+        abort();
+    }
+    switch (s->value_type) {
+    case SYMBOL_NORMAL:
+        s->value.normal = value;
+        break;
+    case SYMBOL_NATIVE:
+        *s->value.native = value;
+        break;
+    }
 }
 
 // condition stuff

src/gc.c

@@ -206,7 +206,7 @@ static void mark_object(LispVal *val) {
     case TYPE_SYMBOL: {
         LispSymbol *sym = val;
         make_grey_if_white(sym->name);
-        make_grey_if_white(sym->value);
+        make_grey_if_white(SYMBOL_VALUE(sym));
         make_grey_if_white(sym->function);
         make_grey_if_white(sym->plist);
         break;

src/gen-init-globals.awk

@@ -91,6 +91,11 @@ function maybe_emit_next_symbol(entity) {
     maybe_emit_next_symbol("SYMBOL")
 }
 
+/DEFVAR\(/ {
+    maybe_print_file_header()
+    maybe_emit_next_symbol("VARIABLE")
+}
+
 END {
     print "}"
 }

src/lisp.c

@@ -10,18 +10,21 @@ static void construct_manual_symbols(void) {
     // IMPORTANT: the symbols listed here need to also be set as special in
     // gen-init-globals.awk
     Qnil = Fmake_symbol(LISP_LITSTR("nil"));
-    ((LispSymbol *) Qnil)->value = Qnil;
+    ((LispSymbol *) Qnil)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION;
+    ((LispSymbol *) Qnil)->value.normal = Qnil;
     ((LispSymbol *) Qnil)->function = Qnil;
     ((LispSymbol *) Qnil)->plist = Qnil;
     lisp_gc_register_static_object(Qnil);
     Qt = Fmake_symbol(LISP_LITSTR("t"));
-    ((LispSymbol *) Qt)->value = Qt;
+    ((LispSymbol *) Qt)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION;
+    ((LispSymbol *) Qt)->value.normal = Qt;
     lisp_gc_register_static_object(Qt);
     Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
-    ((LispSymbol *) Qunbound)->value = Qunbound;
+    ((LispSymbol *) Qunbound)->value.normal = Qunbound;
     lisp_gc_register_static_object(Qunbound);
     Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment"));
-    ((LispSymbol *) Qlexical_environment)->value = Qnil;
+    ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE;
+    ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment;
     lisp_gc_register_static_object(Qlexical_environment);
 
     Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
@@ -184,78 +187,3 @@ DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") {
 DEFUN(null, "null", (LispVal * datum), "(datum)", "") {
     return NILP(datum) ? Qt : Qnil;
 }
-
-void debug_print(FILE *file, LispVal *obj) {
-    switch (TYPE_OF(obj)) {
-    case TYPE_FIXNUM:
-        fprintf(file, "%jd", (intmax_t) XFIXNUM(obj));
-        break;
-    case TYPE_FLOAT:
-        fprintf(file, "%f", (double) XLISP_FLOAT(obj));
-        break;
-    case TYPE_STRING: {
-        LispString *s = obj;
-        fputc('"', file);
-        fwrite(s->data, 1, s->length, file);
-        fputc('"', file);
-        break;
-    }
-    case TYPE_SYMBOL: {
-        LispString *name = ((LispSymbol *) obj)->name;
-        fwrite(name->data, 1, name->length, file);
-        break;
-    }
-    case TYPE_HASH_TABLE: {
-        fprintf(file, "<hash-table count=%zu at 0x%jx>",
-                ((LispHashTable *) obj)->count, (uintmax_t) obj);
-        break;
-    }
-    case TYPE_FUNCTION: {
-        LispFunction *fobj = obj;
-        if (NILP(fobj->name)) {
-            fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
-        } else {
-            fprintf(file, "<function ");
-            debug_print(file, fobj->name);
-            fprintf(file, " at 0x%jx>", (uintmax_t) obj);
-        }
-        break;
-    }
-    case TYPE_CONS: {
-        fputc('(', file);
-        DOTAILS(tail, obj) {
-            if (CONSP(tail)) {
-                debug_print(file, XCAR(tail));
-                if (!NILP(XCDR(tail))) {
-                    fputc(' ', file);
-                }
-            } else {
-                fwrite(". ", 1, 2, file);
-                debug_print(file, tail);
-            }
-        }
-        fputc(')', file);
-        break;
-    }
-    case TYPE_VECTOR: {
-        LispVector *v = obj;
-        fputc('[', file);
-        for (size_t i = 0; i < v->length; ++i) {
-            debug_print(file, v->data[i]);
-            if (i < v->length - 1) {
-                fputc(' ', file);
-            }
-        }
-        fputc(']', file);
-        break;
-    }
-    default:
-        abort();
-    }
-}
-
-void debug_obj_info(FILE *file, LispVal *obj) {
-    fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
-    debug_print(file, obj);
-    fputc('\n', file);
-}

src/lisp.h

@@ -6,10 +6,9 @@
 #include "hashtable.h" // IWYU pragma: export
 #include "lisp_string.h" // IWYU pragma: export
 #include "list.h" // IWYU pragma: export
+#include "print.h" // IWYU pragma: export
 #include "stack.h" // IWYU pragma: export
 
-#include <stdio.h>
-
 extern LispVal *obarray;
 
 void lisp_init(void);
@@ -24,10 +23,4 @@ DECLARE_FUNCTION(and, (LispVal * forms));
 DECLARE_FUNCTION(or, (LispVal * forms));
 DECLARE_FUNCTION(null, (LispVal * datum));
 
-__attribute__((no_sanitize("address"))) void debug_print(FILE *file,
-                                                         LispVal *obj);
-
-__attribute__((no_sanitize("address"))) void debug_obj_info(FILE *file,
-                                                            LispVal *obj);
-
 #endif

src/print.c

@@ -0,0 +1,122 @@
+#include "print.h"
+
+#include "lisp.h"
+
+DEFVAR(print_circular, "print-circular", "", Qt);
+DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100));
+DEFVAR(print_level, "print-level", "", Qnil);
+
+struct PrintContext {
+    bool circle;
+    bool length;
+};
+
+static void init_print_context(struct PrintContext *restrict pc) {
+    pc->circle = true;
+    pc->length = 80;
+}
+
+static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
+    switch (TYPE_OF(val)) {
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    case TYPE_CONS:
+    case TYPE_STRING:
+    case TYPE_SYMBOL:
+    case TYPE_VECTOR:
+    case TYPE_HASH_TABLE:
+    case TYPE_FUNCTION:
+        break;
+    default:
+        abort();
+    }
+}
+
+DEFUN(princ, "princ", (LispVal * val), "(val)", "") {
+    struct PrintContext pc;
+    init_print_context(&pc);
+    print_driver(&pc, val);
+    return Qnil;
+}
+
+DEFUN(prin1, "prin1", (LispVal * val), "(val)", "") {
+    struct PrintContext pc;
+    init_print_context(&pc);
+    print_driver(&pc, val);
+    return Qnil;
+}
+
+void debug_print(FILE *file, LispVal *obj) {
+    switch (TYPE_OF(obj)) {
+    case TYPE_FIXNUM:
+        fprintf(file, "%jd", (intmax_t) XFIXNUM(obj));
+        break;
+    case TYPE_FLOAT:
+        fprintf(file, "%f", (double) XLISP_FLOAT(obj));
+        break;
+    case TYPE_STRING: {
+        LispString *s = obj;
+        fputc('"', file);
+        fwrite(s->data, 1, s->length, file);
+        fputc('"', file);
+        break;
+    }
+    case TYPE_SYMBOL: {
+        LispString *name = ((LispSymbol *) obj)->name;
+        fwrite(name->data, 1, name->length, file);
+        break;
+    }
+    case TYPE_HASH_TABLE: {
+        fprintf(file, "<hash-table count=%zu at 0x%jx>",
+                ((LispHashTable *) obj)->count, (uintmax_t) obj);
+        break;
+    }
+    case TYPE_FUNCTION: {
+        LispFunction *fobj = obj;
+        if (NILP(fobj->name)) {
+            fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
+        } else {
+            fprintf(file, "<function ");
+            debug_print(file, fobj->name);
+            fprintf(file, " at 0x%jx>", (uintmax_t) obj);
+        }
+        break;
+    }
+    case TYPE_CONS: {
+        fputc('(', file);
+        DOTAILS(tail, obj) {
+            if (CONSP(tail)) {
+                debug_print(file, XCAR(tail));
+                if (!NILP(XCDR(tail))) {
+                    fputc(' ', file);
+                }
+            } else {
+                fwrite(". ", 1, 2, file);
+                debug_print(file, tail);
+            }
+        }
+        fputc(')', file);
+        break;
+    }
+    case TYPE_VECTOR: {
+        LispVector *v = obj;
+        fputc('[', file);
+        for (size_t i = 0; i < v->length; ++i) {
+            debug_print(file, v->data[i]);
+            if (i < v->length - 1) {
+                fputc(' ', file);
+            }
+        }
+        fputc(']', file);
+        break;
+    }
+    default:
+        abort();
+    }
+}
+
+void debug_obj_info(FILE *file, LispVal *obj) {
+    fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
+    debug_print(file, obj);
+    fputc('\n', file);
+}

src/print.h

@@ -0,0 +1,23 @@
+#ifndef INCLUDED_PRINT_H
+#define INCLUDED_PRINT_H
+
+#include "base.h"
+
+#include <stdio.h>
+
+DECLARE_VARIABLE(print_circular);
+DECLARE_VARIABLE(print_length);
+DECLARE_VARIABLE(print_level);
+
+// Pretty print
+DECLARE_FUNCTION(princ, (LispVal * val));
+// Quoted print
+DECLARE_FUNCTION(prin1, (LispVal * val));
+
+__attribute__((no_sanitize("address"))) void debug_print(FILE *file,
+                                                         LispVal *obj);
+
+__attribute__((no_sanitize("address"))) void debug_obj_info(FILE *file,
+                                                            LispVal *obj);
+
+#endif

src/stack.c

@@ -131,10 +131,13 @@ static void store_local_reference_in_frame(StackFrame *restrict frame,
 }
 
 void add_local_reference_no_recurse(StackFrame *restrict frame, LispVal *obj) {
+    if (!OBJECTP(obj)) {
+        return;
+    }
     frame = frame->last_references;
     assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES);
     StackFrame *current_frame = OBJECT_LOWEST_LOCAL_REFERENCE(obj);
-    if (OBJECTP(obj) && (!current_frame || current_frame > frame)) {
+    if (!current_frame || current_frame > frame) {
         store_local_reference_in_frame(frame, obj);
     }
 }
@@ -173,7 +176,8 @@ add_local_refs_for_object_sub_vals(StackFrame *restrict frame,
     case TYPE_SYMBOL: {
         LispSymbol *sym = val;
         add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->name);
-        add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->value);
+        add_local_ref_if_not_seen_no_recurse(frame, seen_objs,
+                                             SYMBOL_VALUE(sym));
         add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->function);
         add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->plist);
         break;
@@ -216,6 +220,9 @@ add_local_refs_for_object_sub_vals(StackFrame *restrict frame,
 }
 
 void add_local_reference(StackFrame *restrict frame, LispVal *obj) {
+    if (!OBJECTP(obj)) {
+        return;
+    }
     frame = frame->last_references;
     assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES);
     add_local_reference_no_recurse(frame, obj);
@@ -231,20 +238,37 @@ void add_local_reference(StackFrame *restrict frame, LispVal *obj) {
 
 void push_dynamic_binding(LispVal *name, LispVal *new_value) {
     assert(SYMBOLP(name));
+    LispVal *old_val = SYMBOL_VALUE(name);
+    SET_SYMBOL_VALUE(name, new_value); // will throw if name is const
     StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_DYNAMIC_BINDING);
     frame->dynamic_binding.symbol = name;
-    if (name == Qlexical_environment) {
+    frame->dynamic_binding.old_value = old_val;
-        frame->dynamic_binding.old_value = Vlexical_environment;
-        Vlexical_environment = new_value;
-    } else {
-        frame->dynamic_binding.old_value = SYMBOL_VALUE(name);
-        SET_SYMBOL_VALUE(name, new_value);
-    }
 }
 
 void set_lexical_variable(LispVal *name, LispVal *value) {
     assert(SYMBOLP(name));
-    Vlexical_environment = Fplist_put(Vlexical_environment, name, value);
+    if (CONST_VALUE_P(name)) {
+        // TODO throw
+        abort();
+    }
+    if (DYNAMIC_SYMBOL_P(name)) {
+        SET_SYMBOL_VALUE(name, value);
+    } else {
+        Vlexical_environment = Fplist_put(Vlexical_environment, name, value);
+    }
+}
+
+void new_lexical_variable(LispVal *name, LispVal *value) {
+    assert(SYMBOLP(name));
+    if (CONST_VALUE_P(name)) {
+        // TODO throw
+        abort();
+    }
+    if (DYNAMIC_SYMBOL_P(name)) {
+        SET_SYMBOL_VALUE(name, value);
+    } else {
+        Vlexical_environment = CONS(name, CONS(value, Vlexical_environment));
+    }
 }
 
 void unwind_to(StackFrame *frame) {

src/stack.h

@@ -142,9 +142,7 @@ static ALWAYS_INLINE void push_copy_lexenv(void) {
 
 void set_lexical_variable(LispVal *name, LispVal *value);
 // Just add a new lexical variable without any checking
-static inline void new_lexical_variable(LispVal *name, LispVal *value) {
+void new_lexical_variable(LispVal *name, LispVal *value);
-    Vlexical_environment = CONS(name, CONS(value, Vlexical_environment));
-}
 
 void unwind_to(StackFrame *frame);
 static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame,