Commit: 0c8ad559cb691b8b6df62006cf5d429262639e8b - sapphire_lisp (git)

Baremetal Lisp interpreter and compiler for low-resource devices

Commit MetaInfo

• Revision: 0c8ad559cb691b8b6df62006cf5d429262639e8b (tree)
• Time: 2020-09-08 07:58:00
• Author: AlaskanEmily <emily@alas...>
• Commiter: AlaskanEmily

Log Message

Add defrec

Change Summary

• modified: sl_i.c
• modified: sl_i.h
• modified: sl_x.c
• modified: sl_x.h
• add: tests/rec1.lsp

Incremental Difference

--- a/sl_i.c
+++ b/sl_i.c
@@ -21,6 +21,7 @@
 #include "sl_x.h"
 
 #define SL_I_BIND_CAP_GROWTH 64
+#define SL_I_REC_CAP_GROWTH 32
 #define SL_I_DEF_CAP_INIT 16
 #define SL_I_DEF_CAP_DOUBLE_MAX 256
 
@@ -110,6 +111,20 @@ static sl_s_len_t sl_i_find_def(const struct SL_I_Runtime *rt,
 
 /*****************************************************************************/
 
+static sl_s_len_t sl_i_find_rec(const struct SL_I_Runtime *rt,
+    const struct SL_S_Atom *name){
+    
+    register sl_s_len_t i, n;
+    n = rt->num_recs;
+    for(i = 0; i < n; i++){
+        if(SL_S_COMPARE_ATOMS(rt->recs[i].name, name))
+            return i;
+    }
+    return n;
+}
+
+/*****************************************************************************/
+
 static void sl_i_defun(struct SL_I_Runtime *rt,
     const struct SL_S_Atom *name,
     const struct SL_S_List *args,
@@ -265,6 +280,55 @@ static void sl_i_def(struct SL_I_Runtime *rt,
 
 /*****************************************************************************/
 
+static void sl_i_defrec(struct SL_I_Runtime *rt,
+    const struct SL_S_Atom *name,
+    const struct SL_S_List *fields){
+    
+    void *old;
+    register sl_s_len_t i;
+    struct SL_X_Record *rec;
+    
+    /* Search for an existing function of this name. */
+    i = sl_i_find_rec(rt, name);
+    
+    /* Check if we found a matching bind or not. */
+    if(i == rt->num_recs){
+        /* Check if we need more room. */
+        if(rt->cap_recs == i){
+            /* Round up if the number of recs isn't a multiple of 32. */
+            if(SL_I_UNLIKELY(rt->cap_recs & (SL_I_REC_CAP_GROWTH-1)))
+                rt->cap_recs +=
+                    SL_I_REC_CAP_GROWTH + SL_I_REC_CAP_GROWTH -
+                    (rt->cap_recs & (SL_I_REC_CAP_GROWTH-1));
+            else
+                rt->cap_recs += SL_I_REC_CAP_GROWTH;
+            /* Try to realloc */
+            old = rt->recs;
+            rt->recs = SL_S_Malloc(sizeof(struct SL_X_Record) * rt->cap_recs);
+            if(SL_I_UNLIKELY(rt->recs == SL_S_NIL)){
+                rt->pending_error = "Out of memory";
+                rt->cap_recs = i;
+                rt->recs = old;
+                return;
+            }
+            SL_S_MemCopy(rt->recs, old, i * sizeof(struct SL_X_Record));
+            SL_S_Free(old);
+        }
+        rt->num_recs++;
+        rec = rt->recs + i;
+    }
+    else{
+        rec = rt->recs + i;
+        SL_S_DECREF(rec->name);
+        SL_S_DECREF(rec->fields);
+    }
+    
+    rec->name = name;
+    rec->fields = fields;
+}
+
+/*****************************************************************************/
+
 SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code){
     
     const struct SL_S_Atom *name, *hint;
@@ -296,6 +360,14 @@ SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code){
                 }
                 sl_i_def(rt, hint, name, value);
             }
+            else if(SL_X_IsDefrec(data) == 0){
+                if(SL_X_ParseDefrec(data, &name, &body) != 0){
+                    rt->pending_error = "Error in defrec";
+                    return 1;
+                }
+                SL_S_INCREF(name);
+                sl_i_defrec(rt, name, body);
+            }
             else{
                 SL_I_Execute(rt, code->head);
             }

--- a/sl_i.h
+++ b/sl_i.h
@@ -79,6 +79,9 @@ struct SL_I_Runtime{
     struct SL_I_Bind *binds;
     sl_s_len_t num_binds;
     sl_s_len_t cap_binds;
+    struct SL_X_Record *recs;
+    sl_s_len_t num_recs;
+    sl_s_len_t cap_recs;
     struct SL_I_Frame global, *frames;
     const char *pending_error;
     void *error_free_ptr;

--- a/sl_x.c
+++ b/sl_x.c
@@ -49,6 +49,7 @@ SL_X_ATOM(sl_x_true,    "true");
 SL_X_ATOM(sl_x_false,   "false");
 SL_X_ATOM(sl_x_defun,   "defun");
 SL_X_ATOM(sl_x_def,     "def");
+SL_X_ATOM(sl_x_defrec,  "defrec");
 SL_X_ATOM(sl_x_if,      "if");
 SL_X_ATOM(sl_x_let,     "let");
 SL_X_ATOM(sl_x_plus,    "+");
@@ -361,6 +362,42 @@ SL_S_PURE_FUNC(int) SL_X_IsDef(const struct SL_S_List *code){
 }
 
 /*****************************************************************************/
+#define SL_X_DEFREC_MIN_ARITY 2
+static const unsigned char sl_x_defrec_flags[SL_X_DEFREC_MIN_ARITY] = {
+    SL_S_IN_ATOM,
+    SL_S_OUT_ATOM
+};
+
+SL_S_PURE_FUNC(int) SL_X_IsDefrec(const struct SL_S_List *code){
+    const void *args[SL_X_DEFREC_MIN_ARITY];
+    int arity;
+    
+    args[0] = SL_S_MK_ATOM(&sl_x_defrec);
+    
+    arity = SL_S_Match(code,
+        args,
+        sl_x_defrec_flags,
+        SL_X_DEFREC_MIN_ARITY,
+        SL_X_DEFREC_MIN_ARITY);
+    
+    if(arity == SL_X_DEFREC_MIN_ARITY){
+        return 0;
+    }
+    else if(arity < 0 && (arity = -arity) > SL_X_DEFREC_MIN_ARITY){
+        /* Test for the correct form in the fields. */
+        code = code->tail->tail;
+        do{
+            if(!SL_S_IS_ATOM(code->head))
+                return 1;
+        }while((code = code->tail) != SL_S_NIL);
+        return 0;
+    }
+    else{
+        return 1;
+    }
+}
+
+/*****************************************************************************/
 
 SL_S_FUNC(int) SL_X_ParseDefun(const struct SL_S_List *code,
     const struct SL_S_Atom **out_name,
@@ -375,6 +412,7 @@ SL_S_FUNC(int) SL_X_ParseDefun(const struct SL_S_List *code,
     *out_body = SL_S_PTR_FROM_TAG(code->tail->tail->tail);
     return 0;
 }
+
 /*****************************************************************************/
 
 SL_S_FUNC(int) SL_X_ParseDef(const struct SL_S_List *code,
@@ -421,6 +459,71 @@ SL_S_FUNC(int) SL_X_ParseDef(const struct SL_S_List *code,
 
 /*****************************************************************************/
 
+static struct SL_S_List *sl_x_add_rec_field(
+    const struct SL_S_Atom *name,
+    const struct SL_S_Atom *hint){
+    
+    struct SL_S_List *arg_pair, *to;
+    
+    arg_pair = SL_S_Malloc(sizeof(struct SL_S_List));
+    arg_pair->ref = 1;
+    arg_pair->tail = SL_S_Malloc(sizeof(struct SL_S_List));
+    arg_pair->tail->ref = 1;
+    arg_pair->tail->tail = SL_S_NIL;
+    
+    arg_pair->head = SL_S_MK_ATOM(hint);
+    arg_pair->tail->head = SL_S_MK_ATOM(name);
+    
+    to = SL_S_Malloc(sizeof(struct SL_S_List));
+    to->ref = 1;
+    to->head = SL_S_MK_LIST(arg_pair);
+    return to;
+}
+
+SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
+    const struct SL_S_Atom **out_name,
+    const struct SL_S_List **out_fields){
+    
+    const struct SL_S_Atom *name, *hint;
+    struct SL_S_List *ret, **dest;
+    register const struct SL_S_Atom *atom;
+    register const struct SL_S_Atom **target;
+    
+    *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
+    code = code->tail->tail;
+    if(code == SL_S_NIL){
+        *out_fields = SL_S_NIL;
+        return 0;
+    }
+    
+    dest = &ret;
+    do{
+        atom = SL_S_PTR_FROM_TAG(code->head);
+        SL_S_INCREF(atom);
+        if(atom->len > 1 && atom->text[0] == '^')
+            target = &hint;
+        else
+            target = &name;
+        if(*target != SL_S_NIL){
+            *dest = sl_x_add_rec_field(hint, name);
+            dest = &((*dest)->tail);
+        }
+        *target = atom;
+    }while((code = code->tail) != SL_S_NIL);
+    
+    if(hint != SL_S_NIL || name != SL_S_NIL){
+        *dest = sl_x_add_rec_field(hint, name);
+        (*dest)->tail = SL_S_NIL;
+    }
+    else{
+        *dest = SL_S_NIL;
+    }
+    *out_fields = ret;
+    return 0;
+}
+
+/*****************************************************************************/
+
 static struct SL_S_List *sl_x_create_args(const struct SL_S_Atom *hint,
     const struct SL_S_Atom *name){
     

--- a/sl_x.h
+++ b/sl_x.h
@@ -41,6 +41,7 @@ const extern struct SL_S_Atom
     sl_x_nil, sl_x_true, sl_x_false,
     sl_x_defun,
     sl_x_def,
+    sl_x_defrec,
     sl_x_if,
     sl_x_let,
     sl_x_comment, sl_x_dot, sl_x_tick,
@@ -77,6 +78,14 @@ struct SL_X_Def{
 
 /*****************************************************************************/
 
+struct SL_X_Record{
+    const struct SL_S_Atom *name;
+    /* Each field is structured as (hint name) where hint or name may be nil */
+    const struct SL_S_List *fields;
+};
+
+/*****************************************************************************/
+
 SL_S_PURE_FUNC(int) SL_X_IsRuntimeConstant(const void *value);
 
 /*****************************************************************************/
@@ -101,8 +110,13 @@ SL_S_PURE_FUNC(int) SL_X_IsDef(const struct SL_S_List *code);
 
 /*****************************************************************************/
 /* Returns 0 on success. */
+SL_S_PURE_FUNC(int) SL_X_IsDefrec(const struct SL_S_List *code);
+
+/*****************************************************************************/
+/* Returns 0 on success. */
 SL_S_PURE_FUNC(int) SL_X_IsImport(const struct SL_S_List *code);
 
+/*****************************************************************************/
 /* Returns 0 on success.
  * Does not do increfs, so you've been warned.
  */
@@ -122,6 +136,15 @@ SL_S_FUNC(int) SL_X_ParseDef(const struct SL_S_List *code,
 
 /*****************************************************************************/
 /* Returns 0 on success.
+ * This DOES incref the fields, unlike the other parsers.
+ * This does no incref the name.
+ */
+SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
+    const struct SL_S_Atom **out_name,
+    const struct SL_S_List **out_fields);
+
+/*****************************************************************************/
+/* Returns 0 on success.
  * The args is a list of lists, of the structure ((hint name) (hint name) ...)
  */
 SL_S_FUNC(struct SL_S_List) *SL_X_ParseArgs(const struct SL_S_List *args);

--- /dev/null
+++ b/tests/rec1.lsp
@@ -0,0 +1,6 @@
+; Any copyright is dedicated to the Public Domain.
+; https://creativecommons.org/publicdomain/zero/1.0/
+
+(defrec foo
+  ^int i
+  x)