Commits

Armin Rigo  committed 9c414e6

Add a simpler type than lists, "container".

  • Participants
  • Parent commits 4bdb916

Comments (0)

Files changed (5)

File containerobject.c

+#include "duhton.h"
+
+typedef struct {
+    DuOBJECT_HEAD
+    DuObject *ob_reference;
+} DuContainerObject;
+
+void container_free(DuContainerObject *ob)
+{
+    DuObject *x = ob->ob_reference;
+#ifdef Du_DEBUG
+    ob->ob_reference = (DuObject *)0xDD;
+#endif
+    free(ob);
+    Du_DECREF(x);
+}
+
+void container_print(DuContainerObject *ob)
+{
+    printf("<container ");
+    Du_Print(ob->ob_reference, 0);
+    printf(">");
+}
+
+DuObject *DuContainer_GetRef(DuObject *ob)
+{
+    DuObject *result;
+    DuContainer_Ensure("DuContainer_GetRef", ob);
+
+    Du_AME_READ_START(ob)
+    result = ((DuContainerObject *)ob)->ob_reference;
+    Du_AME_READ_STOP
+
+    Du_INCREF(result);
+    return result;
+}
+
+void DuContainer_SetRef(DuObject *ob, DuObject *x)
+{
+    DuContainer_Ensure("DuContainer_SetRef", ob);
+
+    Du_AME_WRITE(ob);
+    DuObject *prev = ((DuContainerObject *)ob)->ob_reference;
+    Du_INCREF(x);
+    ((DuContainerObject *)ob)->ob_reference = x;
+    Du_DECREF(prev);
+}
+
+DuTypeObject DuContainer_Type = {
+    DuOBJECT_HEAD_INIT(&DuType_Type),
+    "container",
+    sizeof(DuContainerObject),
+    (destructor_fn)container_free,
+    (print_fn)container_print,
+};
+
+DuObject *DuContainer_New()
+{
+    DuContainerObject *ob =                                     \
+        (DuContainerObject *)DuObject_New(&DuContainer_Type);
+    Du_INCREF(Du_None);
+    ob->ob_reference = Du_None;
+    return (DuObject *)ob;
+}
+
+void DuContainer_Ensure(char *where, DuObject *ob)
+{
+    if (!DuContainer_Check(ob))
+        Du_FatalError("%s: expected 'container' argument, got '%s'",
+                      where, ob->ob_type->dt_name);
+}

File demo/container_transaction.duh

+
+(setq c (container 0))
+(defun f (n)
+    (set c (+ (get c) 1))
+    (if (< n 1000)
+        (transaction f (+ n 1))
+      (if (< (get c) 2000)
+          (print (quote not-enough))
+        (print (quote ok)))))
+(transaction f 0)
+(transaction f 0)
 extern DuTypeObject DuType_Type;
 extern DuTypeObject DuInt_Type;
 extern DuTypeObject DuList_Type;
+extern DuTypeObject DuContainer_Type;
 extern DuTypeObject DuCons_Type;
 extern DuTypeObject DuSymbol_Type;
 extern DuTypeObject DuFrame_Type;
 #define DuType_Check(ob)      (((DuObject*)(ob))->ob_type == &DuType_Type)
 #define DuInt_Check(ob)       (((DuObject*)(ob))->ob_type == &DuInt_Type)
 #define DuList_Check(ob)      (((DuObject*)(ob))->ob_type == &DuList_Type)
+#define DuContainer_Check(ob) (((DuObject*)(ob))->ob_type == &DuContainer_Type)
 #define DuCons_Check(ob)      (((DuObject*)(ob))->ob_type == &DuCons_Type)
 #define DuSymbol_Check(ob)    (((DuObject*)(ob))->ob_type == &DuSymbol_Type)
 #define DuFrame_Check(ob)     (((DuObject*)(ob))->ob_type == &DuFrame_Type)
 void DuType_Ensure(char *where, DuObject *ob);
 void DuInt_Ensure(char *where, DuObject *ob);
 void DuList_Ensure(char *where, DuObject *ob);
+void DuContainer_Ensure(char *where, DuObject *ob);
 void DuCons_Ensure(char *where, DuObject *ob);
 void DuSymbol_Ensure(char *where, DuObject *ob);
 void DuFrame_Ensure(char *where, DuObject *ob);
 void DuList_SetItem(DuObject *list, int index, DuObject *newobj);
 DuObject *DuList_Pop(DuObject *list, int index);
 
+DuObject *DuContainer_New(void);
+DuObject *DuContainer_GetRef(DuObject *container);
+void DuContainer_SetRef(DuObject *container, DuObject *newobj);
+
 DuObject *DuSymbol_FromString(char *name);
 char *DuSymbol_AsString(DuObject *ob);
 
     return list;
 }
 
+DuObject *du_container(DuObject *cons, DuObject *locals)
+{
+    if (cons != Du_None && _DuCons_NEXT(cons) != Du_None)
+        Du_FatalError("container: expected at most one argument");
+    DuObject *container = DuContainer_New();
+    if (cons != Du_None) {
+        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
+        DuContainer_SetRef(container, obj);
+        Du_DECREF(obj);
+    }
+    return container;
+}
+
 DuObject *du_get(DuObject *cons, DuObject *locals)
 {
-    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
-        _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
-        Du_FatalError("get: expected two arguments");
-    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
-    DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
-    DuObject *res = DuList_GetItem(lst, DuInt_AsInt(index));
-    Du_DECREF(index);
-    Du_DECREF(lst);
+    if (cons == Du_None)
+        Du_FatalError("get: expected at least one argument");
+    DuObject *res;
+    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
+
+    if (DuList_Check(obj)) {
+        if (_DuCons_NEXT(cons) == Du_None ||
+            _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
+            Du_FatalError("get with a list: expected two arguments");
+        DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
+        res = DuList_GetItem(obj, DuInt_AsInt(index));
+        Du_DECREF(index);
+    }
+    else if (DuContainer_Check(obj)) {
+        if (_DuCons_NEXT(cons) != Du_None)
+            Du_FatalError("get with a container: expected one argument");
+        res = DuContainer_GetRef(obj);
+    }
+    else
+        Du_FatalError("get: bad argument type '%s'", obj->ob_type->dt_name);
+
+    Du_DECREF(obj);
     return res;
 }
 
 DuObject *du_set(DuObject *cons, DuObject *locals)
 {
-    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
-        _DuCons_NEXT(_DuCons_NEXT(cons)) == Du_None ||
-        _DuCons_NEXT(_DuCons_NEXT(_DuCons_NEXT(cons))) != Du_None)
-        Du_FatalError("set: expected three arguments");
-    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
-    DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
-    DuObject *newobj = Du_Eval(_DuCons_CAR(_DuCons_NEXT(_DuCons_NEXT(cons))),
-                               locals);
-    DuList_SetItem(lst, DuInt_AsInt(index), newobj);
-    Du_DECREF(index);
-    Du_DECREF(lst);
-    return newobj;
+    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None)
+        Du_FatalError("set: expected at least two arguments");
+    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
+
+    if (DuList_Check(obj)) {
+        if (_DuCons_NEXT(_DuCons_NEXT(cons)) == Du_None ||
+            _DuCons_NEXT(_DuCons_NEXT(_DuCons_NEXT(cons))) != Du_None)
+            Du_FatalError("set with a list: expected three arguments");
+        DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
+        DuObject *newobj = Du_Eval(
+                    _DuCons_CAR(_DuCons_NEXT(_DuCons_NEXT(cons))), locals);
+        DuList_SetItem(obj, DuInt_AsInt(index), newobj);
+        Du_DECREF(index);
+        Du_DECREF(newobj);
+    }
+    else if (DuContainer_Check(obj)) {
+        if (_DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
+            Du_FatalError("set with a container: expected two arguments");
+        DuObject *newobj = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
+        DuContainer_SetRef(obj, newobj);
+        Du_DECREF(newobj);
+    }
+    else
+        Du_FatalError("set: bad argument type '%s'", obj->ob_type->dt_name);
+
+    Du_DECREF(obj);
+    Du_INCREF(Du_None);
+    return Du_None;
 }
 
 DuObject *du_append(DuObject *cons, DuObject *locals)
     DuFrame_SetBuiltinMacro(Du_Globals, "type", du_type);
     DuFrame_SetBuiltinMacro(Du_Globals, "quote", du_quote);
     DuFrame_SetBuiltinMacro(Du_Globals, "list", du_list);
+    DuFrame_SetBuiltinMacro(Du_Globals, "container", du_container);
     DuFrame_SetBuiltinMacro(Du_Globals, "get", du_get);
     DuFrame_SetBuiltinMacro(Du_Globals, "set", du_set);
     DuFrame_SetBuiltinMacro(Du_Globals, "append", du_append);

File test/test_container.py

+from support import run, evaluate
+
+
+def test_make_container():
+    assert run("(print (container))") == "<container None>\n"
+    assert run("(print (container 2))") == "<container 2>\n"
+    assert run("(print (container (+ 40 2)))") == "<container 42>\n"
+
+def test_get_container():
+    assert evaluate("(get (container 20))") == 20
+
+def test_set_container():
+    assert run("(setq c (container)) "
+               "(set c 50) (print c)") == "<container 50>\n"