Commit: 7e066dd0aa943dd48b88e8fd7db88ab543b4adb4 - sapphire_lisp (git)

Baremetal Lisp interpreter and compiler for low-resource devices

Commit MetaInfo

• Revision: 7e066dd0aa943dd48b88e8fd7db88ab543b4adb4 (tree)
• Zeit: 2020-09-21 08:15:38
• Autor: AlaskanEmily <emily@alas...>
• Commiter: AlaskanEmily

Log Message

Add basic protocol parsing

Ändern Zusammenfassung

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

Diff

--- a/sl_i.c
+++ b/sl_i.c
@@ -26,6 +26,7 @@
 
 #define SL_I_BIND_CAP_GROWTH 64
 #define SL_I_REC_CAP_GROWTH 32
+#define SL_I_PROTO_CAP_GROWTH 32
 #define SL_I_DEF_CAP_INIT 16
 #define SL_I_DEF_CAP_DOUBLE_MAX 256
 
@@ -236,7 +237,7 @@ type_hint_ok:
             SL_S_Free(old);
         }
         bind = rt->binds + i;
-        bind->args = SL_S_Malloc(sizeof(struct SL_I_FuncArg) * arity);
+        bind->args = SL_S_Malloc(sizeof(struct SL_X_FuncArg) * arity);
         rt->num_binds++;
     }
     else{
@@ -256,7 +257,7 @@ type_hint_ok:
         /* Reuse the original args allocation, if possible. */
         if(bind->arity < arity || bind->args == SL_S_NIL){
             SL_S_Free(rt->binds[i].args);
-            bind->args = SL_S_Malloc(sizeof(struct SL_I_FuncArg) * arity);
+            bind->args = SL_S_Malloc(sizeof(struct SL_X_FuncArg) * arity);
             if(SL_I_UNLIKELY(bind->args == SL_S_NIL)){
                 rt->pending_error = "Out of memory";
                 /* The only error recover we can do is to remove this bind, as
@@ -401,6 +402,173 @@ static void sl_i_defrec(struct SL_I_Runtime *rt,
 
 /*****************************************************************************/
 
+static int sl_i_defproto_method(const struct SL_S_List *list,
+    struct SL_X_ProtocolMethod *to){
+    
+    struct SL_S_Atom *name, *hint, *tmp, **target;
+    const struct SL_S_List *args;
+    int tag;
+    SL_S_PTR_TAG_DATA(list->head, name, tag);
+    if(SL_I_UNLIKELY(tag != SL_S_ATOM_TAG))
+        return -1;
+    if((list = list->tail) == SL_S_NIL)
+        return -1;
+    if(name->len > 1 && name->text[0] == '^'){
+        hint = name;
+        SL_S_PTR_TAG_DATA(list->head, name, tag);
+        if(SL_I_UNLIKELY(tag != SL_S_ATOM_TAG))
+            return -1;
+        if(SL_I_UNLIKELY((list = list->tail) == SL_S_NIL))
+            return -1;
+    }
+    else{
+        hint = SL_S_NIL;
+    }
+    if(!SL_I_LIKELY(SL_S_IS_LIST(list->head)))
+        return -1;
+    args = list = SL_S_PTR_FROM_TAG(list->head);
+    
+    to->name = name;
+    to->hint = hint;
+    
+    /* Compute the arity. */
+    name = SL_S_NIL;
+    hint = SL_S_NIL;
+    to->arity = 0;
+    while(list != SL_S_NIL){
+        SL_S_PTR_TAG_DATA(list->head, tmp, tag);
+        if(SL_I_UNLIKELY(tag != SL_S_ATOM_TAG))
+            return -1;
+
+        if(tmp->len > 1 && tmp->text[0] == '^')
+            target = &hint;
+        else
+            target = &name;
+        if(!SL_S_IS_NIL(*target)){
+            to->arity++;
+            name = SL_S_NIL;
+            hint = SL_S_NIL;
+        }
+        *target = tmp;
+        list = list->tail;
+    }
+    if(!SL_S_IS_NIL(name) || !SL_S_IS_NIL(hint))
+        to->arity++;
+    
+    /* Validated, allocate and then fill. */
+    if(to->arity == 0){
+        to->args = SL_S_NIL;
+        goto finished_args;
+    }
+    
+    to->args = SL_S_Malloc(to->arity * sizeof(struct SL_X_FuncArg));
+    if(SL_I_UNLIKELY(to->args == SL_S_NIL))
+        return -1;
+    
+    /* Fill the args. */
+    name = SL_S_NIL;
+    hint = SL_S_NIL;
+    to->arity = 0;
+    list = args;
+    while(list != SL_S_NIL){
+        tmp = SL_S_PTR_FROM_TAG(list->head);
+
+        if(tmp->len > 1 && tmp->text[0] == '^')
+            target = &hint;
+        else
+            target = &name;
+        
+        if(!SL_S_IS_NIL(*target)){
+            to->args[to->arity].hint = hint;
+            to->args[to->arity].name = name;
+            to->arity++;
+            name = SL_S_NIL;
+            hint = SL_S_NIL;
+        }
+        SL_S_INCREF(*target);
+        *target = tmp;
+        list = list->tail;
+    }
+    if(!SL_S_IS_NIL(name) || !SL_S_IS_NIL(hint)){
+        to->args[to->arity].hint = hint;
+        to->args[to->arity].name = name;
+        to->arity++;
+    }
+finished_args:
+    SL_S_INCREF(to->name);
+    SL_S_INCREF(to->hint);
+    return 0;
+}
+
+static void sl_i_defproto(struct SL_I_Runtime *rt,
+    const struct SL_S_Atom *name,
+    const struct SL_S_List *methods){
+    
+    struct SL_X_ProtocolMethod *method_array;
+    void *old;
+    sl_s_len_t num_methods, i, e;
+    
+    num_methods = SL_S_Length(methods);
+    method_array =
+        SL_S_Malloc(num_methods * sizeof(struct SL_X_ProtocolMethod));
+    if(SL_I_UNLIKELY(SL_S_IS_NIL(methods))){
+        rt->pending_error = "Out of memory";
+        return;
+    }
+    i = 0;
+    
+    if(rt->num_protocols == rt->cap_protocols){
+        old = rt->protocols;
+        rt->cap_protocols += SL_I_PROTO_CAP_GROWTH;
+        rt->protocols =
+            SL_S_Malloc(rt->cap_protocols * sizeof(struct SL_X_ProtocolType));
+        if(SL_I_UNLIKELY(rt->protocols == SL_S_NIL)){
+            rt->protocols = old;
+            rt->pending_error = "Out of memory";
+            SL_S_Free(method_array);
+            return;
+        }
+        SL_S_MemCopy(rt->protocols,
+            old,
+            sizeof(struct SL_X_ProtocolType) * rt->num_protocols);
+    }
+    
+    while(!SL_S_IS_NIL(methods)){
+        if(SL_I_UNLIKELY(!SL_S_IS_LIST(methods->head)) ||
+            SL_I_UNLIKELY(
+            sl_i_defproto_method(
+                SL_S_PTR_FROM_TAG(methods->head),
+                method_array + i) != 0)){
+            
+            goto fail_in_methods;
+            methods = methods->tail;
+        }
+        i++;
+        methods = methods->tail;
+    }
+    
+    SL_S_INCREF(name);
+    rt->protocols[rt->num_protocols].name = name;
+    rt->protocols[rt->num_protocols].methods = method_array;
+    rt->protocols[rt->num_protocols].num_methods = num_methods;
+    rt->num_protocols++;
+    return;
+    
+fail_in_methods:
+    while(i--){
+        for(e = 0; e < method_array[i].arity; e++){
+            SL_S_DECREF(method_array[i].args[e].hint);
+            SL_S_DECREF(method_array[i].args[e].name);
+        }
+        SL_S_Free(method_array[i].args);
+    }
+    SL_S_Free(method_array);
+    rt->pending_error = "Invalid protocol method declaration";
+    return;
+}
+
+/*****************************************************************************/
+
 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;
@@ -410,7 +578,7 @@ SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code){
         if(SL_S_IS_LIST(code->head)){
             data = SL_S_PTR_FROM_TAG(code->head);
             if(SL_X_IsDefun(data) == 0){
-                if(SL_I_UNLIKELY(
+                if(SL_I_LIKELY(
                     SL_X_ParseDefun(data, &name, &args, &body) == 0)){
                     
                     data = SL_X_ParseArgs(args);
@@ -426,20 +594,30 @@ SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code){
                 }
             }
             else if(SL_X_IsDef(data) == 0){
-                if(SL_X_ParseDef(data, &hint, &name, &value) != 0){
+                if(SL_I_UNLIKELY(
+                    SL_X_ParseDef(data, &hint, &name, &value) != 0)){
+                    
                     rt->pending_error = "Error in def";
                     return 1;
                 }
                 sl_i_def(rt, hint, name, value);
             }
             else if(SL_X_IsDefrec(data) == 0){
-                if(SL_X_ParseDefrec(data, &name, &body) != 0){
+                if(SL_I_UNLIKELY(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 if(SL_X_IsDefproto(data) == 0){
+                if(SL_I_UNLIKELY(SL_X_ParseDefproto(data, &name, &body) != 0)){
+                    rt->pending_error = "Error in defproto";
+                    return 1;
+                }
+                SL_S_INCREF(name);
+                sl_i_defproto(rt, name, body);
+            }
             else{
                 SL_I_Execute(rt, code->head);
             }

--- a/sl_i.h
+++ b/sl_i.h
@@ -32,8 +32,6 @@ extern "C"{
 /*****************************************************************************/
 
 struct SL_I_Runtime;
-struct SL_X_FuncArg;
-struct SL_X_FileOps;
 
 /*****************************************************************************/
 
@@ -41,13 +39,6 @@ struct SL_X_FileOps;
 
 /*****************************************************************************/
 
-struct SL_I_FuncArg{
-    const struct SL_S_Atom *hint;
-    const struct SL_S_Atom *name;
-};
-
-/*****************************************************************************/
-
 struct SL_I_Bind{
     const struct SL_S_Atom *name;
     union {
@@ -57,7 +48,7 @@ struct SL_I_Bind{
         const struct SL_S_List *lisp;
     } bind;
     sl_s_len_t arity;
-    struct SL_I_FuncArg *args; /* Unused (for now) on native binds. */
+    struct SL_X_FuncArg *args; /* Unused (for now) on native binds. */
     unsigned char is_native;
 };
 
@@ -70,7 +61,6 @@ struct SL_I_Frame{
     struct SL_I_Frame *next;
 };
 
-
 /*****************************************************************************/
 
 struct SL_I_Runtime{
@@ -82,6 +72,9 @@ struct SL_I_Runtime{
     struct SL_X_Record *recs;
     sl_s_len_t num_recs;
     sl_s_len_t cap_recs;
+    struct SL_X_ProtocolType *protocols;
+    sl_s_len_t num_protocols;
+    sl_s_len_t cap_protocols;
     struct SL_I_Frame global, *frames;
     const char *pending_error;
     void *error_free_ptr;

--- a/sl_x.c
+++ b/sl_x.c
@@ -67,6 +67,7 @@ SL_X_INTEGRAL_TYPES(SL_X_PTR_HINT_END)
 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_defproto,"defproto");
 SL_X_ATOM(sl_x_if,      "if");
 SL_X_ATOM(sl_x_let,     "let");
 SL_X_ATOM(sl_x_plus,    "+");
@@ -416,6 +417,21 @@ SL_S_PURE_FUNC(int) SL_X_IsDefrec(const struct SL_S_List *code){
 
 /*****************************************************************************/
 
+SL_S_PURE_FUNC(int) SL_X_IsDefproto(const struct SL_S_List *code){
+    if(!SL_S_IS_NIL(code) &&
+        SL_S_IS_ATOM(code->head) &&
+        !SL_S_IS_NIL(code->tail) &&
+        SL_S_IS_ATOM(code->tail->head) &&
+        SL_S_COMPARE_ATOMS(&sl_x_defproto,
+            (struct SL_S_Atom*)SL_S_PTR_FROM_TAG(code->head))){
+        
+        return 0;
+    }
+    return -1;
+}
+
+/*****************************************************************************/
+
 SL_S_FUNC(int) SL_X_ParseDefun(const struct SL_S_List *code,
     const struct SL_S_Atom **out_name,
     const struct SL_S_List **out_args,
@@ -540,6 +556,24 @@ SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
 }
 
 /*****************************************************************************/
+/* Returns 0 on success.
+ * This DOES incref the methods, unlike most other parsers.
+ * This does no incref the name.
+ */
+SL_S_FUNC(int) SL_X_ParseDefproto(const struct SL_S_List *code,
+    const struct SL_S_Atom **out_name,
+    const struct SL_S_List **out_methods){
+    
+    if(SL_X_IsDefproto(code) != 0)
+        return -1;
+    
+    *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
+    *out_methods = SL_S_PTR_FROM_TAG(code->tail->tail);
+    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
@@ -73,6 +73,7 @@ const extern struct SL_S_Atom
     sl_x_defun,
     sl_x_def,
     sl_x_defrec,
+    sl_x_defproto,
     sl_x_if,
     sl_x_let,
     sl_x_comment, sl_x_dot, sl_x_tick,
@@ -117,6 +118,30 @@ struct SL_X_Record{
 
 /*****************************************************************************/
 
+struct SL_X_FuncArg{
+    const struct SL_S_Atom *hint;
+    const struct SL_S_Atom *name;
+};
+
+/*****************************************************************************/
+
+struct SL_X_ProtocolMethod{
+    struct SL_S_Atom *name;
+    struct SL_S_Atom *hint;
+    struct SL_X_FuncArg *args;
+    sl_s_len_t arity;
+};
+
+/*****************************************************************************/
+
+struct SL_X_ProtocolType{
+    const struct SL_S_Atom *name;
+    struct SL_X_ProtocolMethod *methods;
+    sl_s_len_t num_methods;
+};
+
+/*****************************************************************************/
+
 SL_S_PURE_FUNC(int) SL_X_IsRuntimeConstant(const void *value);
 
 /*****************************************************************************/
@@ -145,6 +170,10 @@ 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_IsDefproto(const struct SL_S_List *code);
+
+/*****************************************************************************/
+/* Returns 0 on success. */
 SL_S_PURE_FUNC(int) SL_X_IsImport(const struct SL_S_List *code);
 
 /*****************************************************************************/
@@ -167,7 +196,7 @@ 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 incref the fields, unlike most other parsers.
  * This does no incref the name.
  */
 SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
@@ -175,6 +204,12 @@ SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
     const struct SL_S_List **out_fields);
 
 /*****************************************************************************/
+/* Returns 0 on success. */
+SL_S_FUNC(int) SL_X_ParseDefproto(const struct SL_S_List *code,
+    const struct SL_S_Atom **out_name,
+    const struct SL_S_List **out_methods);
+
+/*****************************************************************************/
 /* Returns 0 on success.
  * The args is a list of lists, of the structure ((hint name) (hint name) ...)
  */

--- /dev/null
+++ b/tests/proto1.lsp
@@ -0,0 +1,7 @@
+; Any copyright is dedicated to the Public Domain.
+; https://creativecommons.org/publicdomain/zero/1.0/
+
+(defproto foo
+  (bar (a b c))
+  (baz ()))
+