Commit: master - sapphire_lisp (git)

Baremetal Lisp interpreter and compiler for low-resource devices

Commit MetaInfo

• Revisão: c57088232b60ef6f3c8c88a9d246d2987e01cd35 (tree)
• Hora: 2020-09-21 09:51:46
• Autor: AlaskanEmily <emily@alas...>
• Commiter: AlaskanEmily

Mensagem de Log

Add some very basic typechecking for SL_I_Execute

Mudança Sumário

• modified: sl_i.c
• modified: sl_i.h
• modified: sl_x.c
• modified: sl_x.h

Diff

--- a/sl_i.c
+++ b/sl_i.c
@@ -508,6 +508,13 @@ static void sl_i_defproto(struct SL_I_Runtime *rt,
     void *old;
     sl_s_len_t num_methods, i, e;
     
+    /* Do not allow re-defining protocols. */
+    for(i = 0; i < rt->num_protocols; i++){
+        if(SL_S_COMPARE_ATOMS(rt->protocols[i].name, name)){
+            rt->pending_error = "Duplicate name for defproto";
+            return;
+        }
+    }
     num_methods = SL_S_Length(methods);
     method_array =
         SL_S_Malloc(num_methods * sizeof(struct SL_X_ProtocolMethod));
@@ -619,7 +626,7 @@ SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code){
                 sl_i_defproto(rt, name, body);
             }
             else{
-                SL_I_Execute(rt, code->head);
+                SL_I_Execute(rt, code->head, SL_S_NIL);
             }
         }
         if(rt->pending_error)
@@ -636,12 +643,15 @@ static const unsigned char sl_i_if_flags[SL_I_IF_ARITY] = {
     SL_S_OUT_ANY,
     SL_S_OUT_ANY
 };
-static void *sl_i_if(struct SL_I_Runtime *rt, const struct SL_S_List *in){
+static void *sl_i_if(struct SL_I_Runtime *rt,
+    const struct SL_S_List *in,
+    const struct SL_S_Atom **opt_out_hint){
+    
     const void *values[SL_I_IF_ARITY], *result;
     struct SL_S_List rebuild;
     register int i;
     
-    rebuild.head = SL_I_Execute(rt, in->head);
+    rebuild.head = SL_I_Execute(rt, in->head, SL_S_NIL);
     if(rt->pending_error)
         return SL_S_NIL;
     
@@ -668,8 +678,8 @@ static void *sl_i_if(struct SL_I_Runtime *rt, const struct SL_S_List *in){
         rt->pending_error = "First arg to if must be true or false.";
         return SL_S_NIL;
     }
-    
-    result = SL_I_Execute(rt, (void*)result);
+    /* TODO: We should check the type hint of the un-evaluated side, too. */
+    result = SL_I_Execute(rt, (void*)result, opt_out_hint);
     SL_S_INCREF(result);
     return (void*)result;
 }
@@ -707,7 +717,7 @@ SL_S_FUNC(void) *sl_i_to_int(const void *value, void *arg){
         return (void*)value;
     }
     
-    value = SL_I_Execute(data->rt, (void*)value);
+    value = SL_I_Execute(data->rt, (void*)value, SL_S_NIL);
     
     if(SL_S_IS_ATOM(value) &&
         SL_X_IsInt(SL_S_PTR_FROM_TAG(value)) == 0){
@@ -810,10 +820,10 @@ static const void * sl_i_ ## NAME (struct SL_I_Runtime *rt, \
         rt->pending_error = "Wrong number of args in " #SYMBOL; \
         return SL_S_NIL; \
     } \
-    a = SL_I_Execute(rt, in->head); \
+    a = SL_I_Execute(rt, in->head, SL_S_NIL); \
     if(rt->pending_error) \
         return SL_S_NIL; \
-    b = SL_I_Execute(rt, in->tail->head); \
+    b = SL_I_Execute(rt, in->tail->head, SL_S_NIL); \
     if(rt->pending_error){ \
         SL_S_DECREF(a); \
         return SL_S_NIL; \
@@ -849,11 +859,11 @@ static void *sl_i_compare(struct SL_I_Runtime *rt,
     
     const void *exe_a, *exe_b;
     int i;
-    
-    exe_a = SL_I_Execute(rt, a);
+
+    exe_a = SL_I_Execute(rt, a, SL_S_NIL);
     if(rt->pending_error)
         return SL_S_NIL;
-    exe_b = SL_I_Execute(rt, b);
+    exe_b = SL_I_Execute(rt, b, SL_S_NIL);
     if(rt->pending_error){
         SL_S_DECREF(exe_a);
         return SL_S_NIL;
@@ -867,24 +877,37 @@ static void *sl_i_compare(struct SL_I_Runtime *rt,
 
 /*****************************************************************************/
 
-SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value){
+SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt,
+    const void *value,
+    const struct SL_S_Atom **opt_out_hint){
+    
     struct SL_S_Atom *atom;
     struct SL_S_List *list, *ret_list;
     struct SL_X_MeasureResult measure_result;
     struct SL_I_Frame *frame;
     sl_s_len_t i;
+
+#define SL_I_OUT_HINT(WHAT) do{ \
+    if(opt_out_hint) \
+        *opt_out_hint = (WHAT); \
+}while(0)
     
-    if(SL_S_IS_NIL(value))
+    if(SL_S_IS_NIL(value)){
+        SL_I_OUT_HINT(SL_S_NIL);
         return SL_S_NIL;
+    }
     if(SL_S_IS_ATOM(value)){
         atom = SL_S_PTR_FROM_TAG(value);
         if(SL_S_COMPARE_ATOMS(&sl_x_nil, atom)){
+            SL_I_OUT_HINT(SL_S_NIL);
             return SL_S_NIL;
         }
         else if(SL_S_COMPARE_ATOMS(&sl_x_true, atom)){
+            SL_I_OUT_HINT(&sl_x_atom_hint);
             return SL_S_MK_ATOM(&sl_x_true);
         }
         else if(SL_S_COMPARE_ATOMS(&sl_x_false, atom)){
+            SL_I_OUT_HINT(&sl_x_atom_hint);
             return SL_S_MK_ATOM(&sl_x_false);
         }
         else{
@@ -895,16 +918,20 @@ SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value){
                     if(SL_S_COMPARE_ATOMS(atom, frame->defs[i].name)){
                         value = frame->defs[i].value;
                         SL_S_INCREF(value);
-                        return (void*)value;;
+                        SL_S_INCREF(frame->defs[i].hint);
+                        SL_I_OUT_HINT(frame->defs[i].hint);
+                        return (void*)value;
                     }
                 }
             }while((frame = frame->next) != SL_S_NIL);
             
             SL_S_INCREF(value);
+            SL_I_OUT_HINT(SL_S_NIL);
             return (void*)value;
         }
     }
     else if(!SL_S_IS_LIST(value)){
+        SL_I_OUT_HINT(SL_S_NIL);
         SL_S_INCREF(value);
         return (void*)value;
     }
@@ -919,8 +946,10 @@ SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value){
             atom = SL_S_PTR_FROM_TAG(list->head);
             
             /* Comment */
-            if(SL_S_COMPARE_ATOMS(&sl_x_comment, atom))
+            if(SL_S_COMPARE_ATOMS(&sl_x_comment, atom)){
+                SL_I_OUT_HINT(SL_S_NIL);
                 return SL_S_NIL;
+            }
             
             /* Tick escape */
             if(!SL_S_IS_NIL(list->tail) &&
@@ -933,6 +962,7 @@ SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value){
                 }
                 
                 SL_S_INCREF(list->tail->head);
+                SL_I_OUT_HINT(SL_S_NIL);
                 return list->tail->head;
             }
             
@@ -944,12 +974,13 @@ SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value){
                 }
                 /* All this is safe for nil. */
                 SL_S_INCREF(list->tail);
+                SL_I_OUT_HINT(&sl_x_list_hint);
                 return SL_S_MK_LIST(list->tail);
             }
             
             /* if */
             if(SL_S_COMPARE_ATOMS(&sl_x_if, atom)){
-                return sl_i_if(rt, list->tail);
+                return sl_i_if(rt, list->tail, opt_out_hint);
             }
             
 #define SL_I_TEST_ARITHMETIC(NAME, SYMBOL) \
@@ -966,10 +997,12 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
             rt->pending_error = "Invalid arity in " #NAME "?"; \
             return SL_S_NIL; \
         } \
-        value = SL_I_Execute(rt, list->tail->head); \
+        value = SL_I_Execute(rt, list->tail->head, SL_S_NIL); \
         if(rt->pending_error) \
             return SL_S_NIL; \
+        SL_I_OUT_HINT(&sl_x_atom_hint); \
         if(TESTER(value)){ \
+            SL_S_DECREF(value); \
             return SL_S_MK_ATOM(&sl_x_true); \
         } \
         else{ \
@@ -982,6 +1015,7 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
             SL_I_TEST(list, SL_S_IS_LIST)
 #define SL_I_TEST_INT(X) \
     (SL_S_IS_ATOM(X) && SL_X_IsInt(SL_S_PTR_FROM_TAG(X)) == 0)
+            
             SL_I_TEST(int, SL_I_TEST_INT)
             
 #undef SL_I_TEST_INT
@@ -1009,7 +1043,9 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                 SL_S_ForEach(SL_X_ConcatAtomsCB, ret_list, atom);
                 atom->text[measure_result.len] = '\0';
                 SL_S_DECREF(ret_list);
-                return atom;
+                
+                SL_I_OUT_HINT(&sl_x_atom_hint);
+                return SL_S_MK_ATOM(atom);
             }
             
             /* cons */
@@ -1018,7 +1054,7 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                     rt->pending_error = "Invalid arity in cons.";
                     return SL_S_NIL;
                 }
-                value = SL_I_Execute(rt, list->tail->tail->head);
+                value = SL_I_Execute(rt, list->tail->tail->head, SL_S_NIL);
                 if(rt->pending_error)
                     return SL_S_NIL;
                 if(!SL_S_IS_LIST(value)){
@@ -1028,22 +1064,23 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                 }
                 ret_list = SL_S_Malloc(sizeof(struct SL_S_List));
                 ret_list->ref = 1;
-                ret_list->head = SL_I_Execute(rt, list->tail->head);
+                ret_list->head = SL_I_Execute(rt, list->tail->head, SL_S_NIL);
                 ret_list->tail = SL_S_PTR_FROM_TAG(value);
                 if(rt->pending_error){
                     SL_S_FREE_LIST(ret_list);
                     return SL_S_NIL;
                 }
-                return ret_list;
+                SL_I_OUT_HINT(&sl_x_list_hint);
+                return SL_S_MK_LIST(ret_list);
             }
             
             /* head */
             if(SL_S_COMPARE_ATOMS(&sl_x_head, atom)){
-                if(SL_S_LengthCompare(list->tail, 2) != 0){
+                if(SL_S_LengthCompare(list->tail, 1) != 0){
                     rt->pending_error = "Invalid arity in head.";
                     return SL_S_NIL;
                 }
-                value = SL_I_Execute(rt, list->tail->head);
+                value = SL_I_Execute(rt, list->tail->head, SL_S_NIL);
                 if(rt->pending_error)
                     return SL_S_NIL;
                 if(!SL_S_IS_LIST(value)){
@@ -1055,27 +1092,19 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                 value = ret_list->head;
                 SL_S_INCREF(value);
                 SL_S_DECREF(ret_list);
+                SL_I_OUT_HINT(SL_S_NIL);
                 return (void*)value;
             }
             
-            /* head */
+            /* tail */
             if(SL_S_COMPARE_ATOMS(&sl_x_tail, atom)){
-                if(SL_S_LengthCompare(list->tail, 2) != 0){
+                if(SL_S_LengthCompare(list->tail, 1) != 0){
                     rt->pending_error = "Invalid arity in tail.";
                     return SL_S_NIL;
                 }
-                value = SL_I_Execute(rt, list->tail->head);
-                if(rt->pending_error)
-                    return SL_S_NIL;
-                if(!SL_S_IS_LIST(value)){
-                    SL_S_DECREF(value);
-                    rt->pending_error = "Invalid arguments to tail.";
-                    return SL_S_NIL;
-                }
-                ret_list = SL_S_PTR_FROM_TAG(value);
-                value = SL_S_MK_LIST(ret_list->tail);
+                value = SL_S_MK_LIST(list->tail->tail);
                 SL_S_INCREF(value);
-                SL_S_DECREF(ret_list);
+                SL_I_OUT_HINT(&sl_x_list_hint);
                 return (void*)value;
             }
             
@@ -1085,9 +1114,10 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                     rt->pending_error = "Invalid arity in not.";
                     return SL_S_NIL;
                 }
-                value = SL_I_Execute(rt, list->tail->head);
+                value = SL_I_Execute(rt, list->tail->head, SL_S_NIL);
                 if(rt->pending_error)
                     return SL_S_NIL;
+                SL_I_OUT_HINT(&sl_x_atom_hint);
                 /* Very minor optimization, check for address equivalence with
                  * the boolean primitives */
                 if(SL_S_PTR_FROM_TAG(value) == &sl_x_true){
@@ -1124,6 +1154,7 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                     rt->pending_error = "Invalid arith in =";
                     return SL_S_NIL;
                 }
+                SL_I_OUT_HINT(&sl_x_atom_hint);
                 return sl_i_compare(rt,
                     list->tail->head,
                     list->tail->tail->head);
@@ -1135,6 +1166,8 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
                     if(SL_S_LengthCompare(list->tail,
                         rt->binds[i].arity) == 0){
                         
+                        SL_S_INCREF(rt->binds[i].hint);
+                        SL_I_OUT_HINT(rt->binds[i].hint);
                         return SL_I_Call(rt, rt->binds + i, list->tail);
                     }
                     else{
@@ -1170,7 +1203,7 @@ SL_I_ALL_ARITHMETIC(SL_I_TEST_ARITHMETIC)
 SL_S_FUNC(void) *SL_I_Execute2(const void *value, void *rt){
     if(((struct SL_I_Runtime*)rt)->pending_error)
         return SL_S_NIL;
-    return SL_I_Execute(rt, (void*)value);
+    return SL_I_Execute(rt, (void*)value, SL_S_NIL);
 }
 
 /*****************************************************************************/
@@ -1200,7 +1233,8 @@ SL_S_FUNC(void) *SL_I_Call(struct SL_I_Runtime *rt,
         frame.num_defs = frame.cap_defs = bind->arity;
         for(i = 0; i < bind->arity; i++){
             frame.defs[i].name = bind->args[i].name;
-            value = SL_I_Execute(rt, args->head);
+            /* TODO: Use the output hint from SL_I_Execute! */
+            value = SL_I_Execute(rt, args->head, SL_S_NIL);
             hint = bind->args[i].hint;
             if(!(SL_S_IS_NIL(hint) || SL_S_COMPARE_ATOMS(hint, &sl_x_nil))){
                 /* Validate the type. */
@@ -1312,7 +1346,8 @@ type_hint_done:
             code = code->tail){
             
             SL_S_DECREF(value);
-            value = SL_I_Execute(rt, code->head);
+            /* TODO: Check that the final value matches our output hint! */
+            value = SL_I_Execute(rt, code->head, SL_S_NIL);
         }
         
         /* Clean up the stack. */

--- a/sl_i.h
+++ b/sl_i.h
@@ -41,6 +41,7 @@ struct SL_I_Runtime;
 
 struct SL_I_Bind{
     const struct SL_S_Atom *name;
+    const struct SL_S_Atom *hint;
     union {
         SL_S_FUNC_PTR(void*, native)(
             struct SL_I_Runtime *rt,
@@ -48,7 +49,7 @@ struct SL_I_Bind{
         const struct SL_S_List *lisp;
     } bind;
     sl_s_len_t arity;
-    struct SL_X_FuncArg *args; /* Unused (for now) on native binds. */
+    struct SL_X_FuncArg *args;
     unsigned char is_native;
 };
 
@@ -93,8 +94,13 @@ SL_S_FUNC(void) SL_I_InitRuntime(struct SL_I_Runtime *rt);
 SL_S_FUNC(int) SL_I_Run(struct SL_I_Runtime *rt, const struct SL_S_List *code);
 
 /*****************************************************************************/
-/* The result must be DECREF'ed */
-SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt, const void *value);
+/* The result must be DECREF'ed.
+ * If opt_out_hint is not SL_S_NIL, then the return-type hint (if one exists)
+ * will be placed into the destination.
+ */
+SL_S_FUNC(void) *SL_I_Execute(struct SL_I_Runtime *rt,
+    const void *value,
+    const struct SL_S_Atom **opt_out_hint);
 
 /*****************************************************************************/
 /* Args reversed form of SL_I_Execute. */

--- a/sl_x.c
+++ b/sl_x.c
@@ -103,6 +103,24 @@ SL_X_ATOM(sl_x_le,      "<=");
 
 /*****************************************************************************/
 
+const struct SL_S_Atom *const sl_x_all_hints[] = {
+    &sl_x_list_hint,
+    &sl_x_atom_hint,
+
+#define SL_X_HINT_REF(X) &(sl_x_ ## X ## _hint),
+SL_X_INTEGRAL_TYPES(SL_X_HINT_REF)
+#undef SL_X_HINT_REF
+
+#ifdef SL_S_ENABLE_POINTERS
+# define SL_X_PTR_HINT_REF(X) &(sl_x_ptr_ ## X ## _hint),
+SL_X_INTEGRAL_TYPES(SL_X_PTR_HINT_REF)
+# undef SL_X_PTR_HINT_REF
+#endif
+    SL_S_NIL
+};
+
+/*****************************************************************************/
+
 static int sl_x_is_builtin(const struct SL_S_Atom *arg){
     return (SL_S_IS_NIL(arg) || arg->len > 5) ? 1 : !(
         SL_S_COMPARE_ATOMS(&sl_x_if, arg) ||

--- a/sl_x.h
+++ b/sl_x.h
@@ -85,6 +85,10 @@ const extern struct SL_S_Atom
     sl_x_eq, sl_x_ne, sl_x_gt, sl_x_ge, sl_x_lt, sl_x_le;
 
 /*****************************************************************************/
+/* NULL-terminated. */
+const extern struct SL_S_Atom *const sl_x_all_hints[];
+
+/*****************************************************************************/
 
 struct SL_X_FileOps{
     void *x_stdin;