Add support for immutable vectors, byte-strings, and structures.

The interpreter now requires its input to be immutable.
The reader marks values read after '#@' as immutable, e.g. #@#(...).

builtin.c

@@ -17,6 +17,8 @@ static void register_template(void);
 static void register_lambda(void);
 
 static void bi_string_to_number(interp_state_t *state);
+static void bi_freeze(interp_state_t *state);
+static void bi_immutable_p(interp_state_t *state);
 
 void builtin_init(void)
 {
@@ -26,6 +28,8 @@ void builtin_init(void)
 
   register_builtin(BI_UNDEFINED,         UNDEFINED);
   register_builtin(BI_STRING_TO_NUMBER,  make_builtin_fn(bi_string_to_number));
+  register_builtin(BI_FREEZE,            make_builtin_fn(bi_freeze));
+  register_builtin(BI_IMMUTABLE_P,       make_builtin_fn(bi_immutable_p));
 
 #ifdef NAN
   register_builtin(BI_POS_NAN, make_float(NAN));
@@ -98,6 +102,8 @@ static void register_template(void)
   /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
   _get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
 
+  _get_struct(template_type_root.value)->immutable = true;
+
   register_builtin(BI_TEMPLATE, template_type_root.value);
 }
 
@@ -113,6 +119,8 @@ static void register_lambda(void)
   /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
   _get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
 
+  _get_struct(lambda_type_root.value)->immutable = true;
+
   register_builtin(BI_LAMBDA, lambda_type_root.value);
 }
 
@@ -137,4 +145,52 @@ static void bi_string_to_number(interp_state_t *state)
   interp_return_values(state, cons(rval, NIL));
 }
 
+static void bi_freeze(interp_state_t *state)
+{
+  value_t val = CAR(state->argv.value);
+
+  if (is_vector(val))
+  {
+    _get_vector(val)->immutable = true;
+  }
+  else if (is_byte_string(val))
+  {
+    _get_byte_string(val)->immutable = true;
+  }
+  else if (is_struct(val))
+  {
+    _get_struct(val)->immutable = true;
+  }
+
+  interp_return_values(state, cons(val, NIL));
+}
+
+static void bi_immutable_p(interp_state_t *state)
+{
+  value_t val;
+  bool frozen;
+
+  val = CAR(state->argv.value);
+
+  if (is_vector(val))
+  {
+    frozen = _get_vector(val)->immutable;
+  }
+  else if (is_byte_string(val))
+  {
+    frozen = _get_byte_string(val)->immutable;
+  }
+  else if (is_struct(val))
+  {
+    frozen = _get_struct(val)->immutable;
+  }
+  else
+  {
+    /* These values can't be changed, and thus can be considered frozen: */
+    frozen = !is_object(val) || is_float(val) || is_builtin_fn(val);
+  }
+
+  interp_return_values(state, cons(boolean_value(frozen), NIL));
+}
+
 /* vim:set sw=2 expandtab: */

builtin.h

@@ -17,8 +17,10 @@
 #define BI_POS_INFINITY  "+infinity"
 #define BI_NEG_INFINITY  "-infinity"
 
-/* Name of builtin function */
+/* Names of builtin functions */
 #define BI_STRING_TO_NUMBER "string->number"
+#define BI_FREEZE           "freeze!"
+#define BI_IMMUTABLE_P      "immutable?"
 
 #define TEMPLATE_SLOT_GLOBAL_VARS   0
 #define TEMPLATE_SLOT_INSTANCE_VARS 1

gc.c

@@ -166,6 +166,7 @@ value_t make_vector(size_t nelem, value_t initial_value)
   vec->tag = TYPE_TAG_VECTOR;
   vec->size = nelem;
   vec->hash = make_hash_value();
+  vec->immutable = false;
 
   for (int i = 0; i < nelem; ++i)
     vec->elements[i] = iv_root.value;
@@ -189,6 +190,7 @@ value_t make_byte_string(size_t size, int default_value)
   str = (byte_string_t*)gc_alloc(nbytes);
   str->tag = TYPE_TAG_BYTESTR;
   str->size = size;
+  str->immutable = false;
 
   memset(str->bytes, default_value, size);
 
@@ -242,6 +244,7 @@ value_t make_struct(value_t type)
   register_gc_root(&type_root, type);
 
   release_assert(struct_is_a(type_root.value, get_structure_type()));
+  release_assert(_get_struct(type_root.value)->immutable);
   nslots = get_fixnum(_SLOT_VALUE(STRUCTURE, type_root.value, NSLOTS));
 
   s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots));
@@ -249,6 +252,7 @@ value_t make_struct(value_t type)
   s->type = type_root.value;
   s->nslots = nslots;
   s->hash = make_hash_value();
+  s->immutable = false;
 
   for (int i = 0; i < nslots; ++i)
     s->slots[i] = UNDEFINED;
@@ -281,6 +285,8 @@ static void structure_init(void)
   /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */
   _get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
 #undef SS
+
+  _get_struct(structure_type_root.value)->immutable = true;
 }
 
 bool struct_is_a(value_t value, value_t type)
@@ -1540,6 +1546,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
   }
   else if (is_vector(v))
   {
+    if (_get_vector(v)->immutable)
+      fputs("#@", f);
+
     fputs("#(", f);
 
     for (size_t i = 0; i < _get_vector(v)->size; ++i)
@@ -1555,6 +1564,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
     byte_string_t *str = _get_byte_string(v);
     size_t written = 0;
 
+    if (str->immutable)
+      fputs("#@", f);
+
     fputc('"', f);
 
     for (size_t i = 0; i < str->size; ++i)
@@ -1585,6 +1597,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
   {
     value_t meta = _get_struct(v)->type;
 
+    if (_get_struct(v)->immutable)
+      fputs("#@", f);
+
     fputs("#S(", f);
 
     if (meta == get_structure_type())

gc.h

@@ -61,6 +61,7 @@ typedef void (builtin_fn_t)(struct interp_state *state);
 #define UNDEFINED         SPECIAL_VALUE(3)
 #define GC_GEN0_POISON    SPECIAL_VALUE(4)
 #define GC_GEN1_POISON    SPECIAL_VALUE(5)
+#define END_PROGRAM       SPECIAL_VALUE(6)
 
 #define TYPE_TAG_BOX      TYPE_TAG(0)
 #define TYPE_TAG_VECTOR   TYPE_TAG(1)
@@ -118,6 +119,7 @@ typedef struct vector
   value_t tag;         /* TYPE_TAG_VECTOR */
   size_t  size;
   value_t hash;
+  bool immutable;
   value_t elements[0];
 } vector_t;
 
@@ -125,6 +127,7 @@ typedef struct byte_string
 {
   value_t tag;      /* TYPE_TAG_BYTESTR */
   size_t  size;
+  bool immutable;
   uint8_t bytes[0];
 } byte_string_t;
 
@@ -135,6 +138,7 @@ typedef struct structure
   value_t type;
   size_t  nslots;
   value_t hash;
+  bool immutable;
   value_t slots[0];
 } struct_t;
 

interp.c

@@ -66,8 +66,8 @@ value_t run_interpreter(value_t lambda, value_t argv)
 
   register_state(&state, lambda, argv);
 
-  /* Keep going until something attempts to tail-call FALSE_VALUE, the original 'k', indicating completion. */
+  /* Keep going until something attempts to tail-call END_PROGRAM, the original 'k', indicating completion. */
-  while (state.lambda.value != FALSE_VALUE)
+  while (state.lambda.value != END_PROGRAM)
   {
     /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */
     translate_callable(&state);
@@ -95,13 +95,14 @@ value_t run_interpreter(value_t lambda, value_t argv)
     }
     else
     {
+      release_assert(get_struct(state.lambda.value)->immutable);
       state.nframe = get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS));
       release_assert((0 <= state.nframe) && (state.nframe <= 120));
 
       state.globals.value = _LAMBDA_SLOT(state.lambda.value, GLOBAL_VARS);
       state.instances.value = _LAMBDA_SLOT(state.lambda.value, INSTANCE_VARS);
-      release_assert(is_vector(state.globals.value));
+      release_assert(get_vector(state.globals.value)->immutable);
-      release_assert(is_vector(state.instances.value));
+      release_assert(get_vector(state.instances.value)->immutable);
 
       run_byte_code(&state);
       perform_tail_call(&state);
@@ -169,6 +170,7 @@ static value_t struct_ref(value_t v, fixnum_t idx)
 static void vector_set(value_t v, fixnum_t idx, value_t newval)
 {
   vector_t *vec = get_vector(v);
+  release_assert(!vec->immutable);
   release_assert((idx >= 0) && (idx < vec->size));
   vec->elements[idx] = newval;
   WRITE_BARRIER(v);
@@ -177,6 +179,7 @@ static void vector_set(value_t v, fixnum_t idx, value_t newval)
 static void byte_string_set(value_t v, fixnum_t idx, char newval)
 {
   byte_string_t *str = get_byte_string(v);
+  release_assert(!str->immutable);
   release_assert((idx >= 0) && (idx < str->size));
   str->bytes[idx] = newval;
 }
@@ -184,9 +187,8 @@ static void byte_string_set(value_t v, fixnum_t idx, char newval)
 static void struct_set(value_t v, fixnum_t idx, value_t newval)
 {
   struct_t *s = get_struct(v);
-
+  release_assert(!s->immutable);
   release_assert((idx >= 0) && (idx < s->nslots));
-
   s->slots[idx] = newval;
   WRITE_BARRIER(v);
 }
@@ -232,6 +234,7 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
   ls->slots[LAMBDA_SLOT_FRAME_VARS]   = ts->slots[TEMPLATE_SLOT_FRAME_VARS];
   ls->slots[LAMBDA_SLOT_BYTE_CODE]    = ts->slots[TEMPLATE_SLOT_BYTE_CODE];
   ls->slots[LAMBDA_SLOT_TAIL_CALL]    = ts->slots[TEMPLATE_SLOT_TAIL_CALL];
+  ls->immutable = true;
   WRITE_BARRIER(lambda_root.value);
 
   l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
@@ -241,6 +244,7 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
   {
     l_inst->elements[i] = get_input(state, t_inst->bytes[i]);
   }
+  l_inst->immutable = true;
   WRITE_BARRIER(object_value(l_inst));
 
   unregister_gc_root(&templ_root);
@@ -270,13 +274,15 @@ static void run_byte_code(interp_state_t *state)
 
   if (bc_root.value != FALSE_VALUE)
   {
-    release_assert((get_byte_string(bc_root.value)->size % 4) == 0);
+    release_assert(get_byte_string(bc_root.value)->immutable);
+    release_assert((_get_byte_string(bc_root.value)->size % 4) == 0);
 
     for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4)
     {
-      uint8_t bytes[4];
+      uint32_t word;
+      uint8_t *bytes = (uint8_t*)&word;
       
-      memcpy(bytes, _get_byte_string(bc_root.value)->bytes + offset, 4);
+      word = *(uint32_t*)(_get_byte_string(bc_root.value)->bytes + offset);
 
       switch (bytes[0])
       {
@@ -312,7 +318,8 @@ static void perform_tail_call(interp_state_t *state)
   gc_root_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k;
   value_t tail_call = _LAMBDA_SLOT(state->lambda.value, TAIL_CALL);
 
-  release_assert(get_byte_string(tail_call)->size == 6);
+  release_assert(get_byte_string(tail_call)->immutable);
+  release_assert(_get_byte_string(tail_call)->size == 6);
 
   register_gc_root(&new_lambda,  get_input(state, _get_byte_string(tail_call)->bytes[0]));
   register_gc_root(&new_argv,    get_input(state, _get_byte_string(tail_call)->bytes[1]));
@@ -593,14 +600,14 @@ static void register_state(interp_state_t *state, value_t lambda, value_t argv)
   register_gc_root(&state->kw_args,   NIL);
   register_gc_root(&state->kw_vals,   NIL);
   register_gc_root(&state->ctx,       FALSE_VALUE);
-  register_gc_root(&state->k,         FALSE_VALUE);
+  register_gc_root(&state->k,         END_PROGRAM);
 
   register_gc_root(&state->globals,   UNDEFINED);
   register_gc_root(&state->instances, UNDEFINED);
   register_gc_root(&state->frame,     make_vector(120, UNDEFINED));
-  register_gc_root(&state->in1,       FALSE_VALUE);
+  register_gc_root(&state->in1,       UNDEFINED);
-  register_gc_root(&state->in2,       FALSE_VALUE);
+  register_gc_root(&state->in2,       UNDEFINED);
-  register_gc_root(&state->in3,       FALSE_VALUE);
+  register_gc_root(&state->in3,       UNDEFINED);
 }
 
 static void unregister_state(interp_state_t *state)

libcompiler/writer.scm

@@ -52,7 +52,7 @@
   (write-char #\" port))
 
 (define (write-instance-string inst-vars port)
-  (write-char #\" port)
+  (write-string "#@\"" port)
   (for ([var (in-list inst-vars)])
     (write-hex-char (variable->code var) port))
   (write-char #\" port))
@@ -60,7 +60,7 @@
 (define (write-rla-bytecode+tail-call forms port)
   (define (write-tail-call tc-form)
     (req-new-line port)
-    (write-char #\" port)
+    (write-string "#@\"" port)
     (for ([var (in-list (cdr tc-form))])
       (write-hex-char (variable->code var) port))
     (write-char #\" port)
@@ -72,7 +72,7 @@
 
   (let-values ([(line col pos) (port-next-location port)])
     (parameterize ([current-indent col])
-      (write-char #\" port)
+      (write-string "#@\"" port)
       (if (eq? (first (first forms)) '#%tail-call)
           (begin
             (write-char #\" port)
@@ -100,13 +100,13 @@
   (define template? (eq? (first value) '#%template))
   (let-values ([(line col pos) (port-next-location port)])
     (parameterize ([current-indent col])
-      (write-string "#S(" port)
+      (write-string "#@#S(" port)
       (if (eq? (first value) '#%template)
           (write-string "#=\"template\"" port)
           (write-string "#=\"lambda\"" port))
       (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
         (req-new-line port)
-        (write-string "#(" port)
+        (write-string "#@#(" port)
         (unless (null? (second value))
           (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
             (opt-new-line port)
@@ -120,7 +120,7 @@
         (if template?
             (write-instance-string (third value) port)
             (begin
-              (write-string "#(" port)
+              (write-string "#@#(" port)
               (unless (null? (third value))
                 (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
                   (opt-new-line port)

reader.c

@@ -45,6 +45,8 @@ static value_t read_placeholder(reader_state_t *state);
 
 static value_t read_indirect(value_t path);
 
+static value_t freeze(value_t val);
+
 static void next_char(reader_state_t *state);
 static void skip_whitespace(reader_state_t *state);
 
@@ -220,6 +222,9 @@ static value_t read_special(reader_state_t *state)
   case 'i':
     next_char(state);
     return read_indirect(read_string(state));
+  case '@':
+    next_char(state);
+    return freeze(read_one_value(state));
   default:
     release_assert(NOTREACHED("Invalid character in special value."));
     return UNDEFINED;
@@ -751,6 +756,29 @@ static value_t read_indirect(value_t path)
   return v;
 }
 
+static value_t freeze(value_t val)
+{
+  if (is_vector(val))
+  {
+    _get_vector(val)->immutable = true;
+  }
+  else if (is_byte_string(val))
+  {
+    _get_byte_string(val)->immutable = true;
+  }
+  else if (is_struct(val))
+  {
+    _get_struct(val)->immutable = true;
+  }
+  else
+  {
+    /* Error if value cannot be made immutable */
+    release_assert(!is_object(val) || is_float(val) || is_builtin_fn(val));
+  }
+
+  return val;
+}
+
 static bool is_placeholder(reader_state_t *state, value_t value)
 {
   for (value_t item = state->ref_alist.value; !is_nil(item); item = _CDDR(item))

src/reader.rls

@@ -123,6 +123,9 @@
           [(memq? current-char '(#\B #\b))
              (next-char)
              (read-fixnum 2)]
+          [(eq? current-char #\@)
+             (next-char)
+             (freeze! (read-one-value))]
           [else (unexpected-char)]))
       
       (define (read-list)