datastore-progn function.

diff --git a/modules/ml-store.cc b/modules/ml-store.cc
index 12b665a..80fd39f 100644 (file)
--- a/modules/ml-store.cc
+++ b/modules/ml-store.cc
@@ -712,6 +712,61 @@ MNode*  ml_datastore (MNode* cell, MlEnv* mlenv) {
 }
 
 /*DOC:
+===datastore-progn===
+ (datastore-progn NAME BODY...) -> NIL
+
+NAME must be less than 32 bytes.
+
+*/
+//#AFUNC       datastore-progn ml_datastore_progn
+MNode*  ml_datastore_progn (MNode* cell, MlEnv* mlenv) {
+    MNode*  arg = cell->cdr ();
+    ustring  name;
+    ustring  oname;
+    MNodePtr  ans;
+    MNodePtr  errfn;
+    std::vector<MNode*>  params;
+    std::vector<MNode*>  keywords;
+    MNode*  rest;
+    static paramList  kwlist[] = {
+       {CharConst ("on-error"), false},
+       {NULL, 0, 0}
+    };
+
+    setParams (arg, 1, &params, kwlist, &keywords, &rest);
+    name = eval_str (params[0], mlenv);
+    if (keywords[0])
+       errfn = eval (keywords[0], mlenv);
+
+    try {
+       oname = mlenv->env->datastore;
+       mlenv->env->setDatastore (name);
+       mlenv->execDatastoreFunc ();
+       ans =  progn (rest, mlenv);
+       mlenv->env->setDatastore (oname);
+       mlenv->execDatastoreFunc ();
+    } catch (ustring& msg) {
+       mlenv->env->setDatastore (oname);
+       mlenv->execDatastoreFunc ();
+       if (errfn ()) {
+           MNodePtr  v;
+           MNodePtr  ag;
+           ag = new MNode;
+           ag ()->set_car (mlenv->currentCell ());
+           v = execDefun (mlenv, errfn (), ag (), uEmpty);
+       } else {
+           throw (msg);
+       }
+    }
+    if (mlenv->breaksym ()
+       && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))) {
+       mlenv->setBreaksym (NULL);
+    }
+
+    return ans.release ();
+}
+
+/*DOC:
 ===new-storage===
  (new-storage NAME) -> NIL
 

diff --git a/modules/ml-store.h b/modules/ml-store.h
index 6490625..0fdb11d 100644 (file)
--- a/modules/ml-store.h
+++ b/modules/ml-store.h
@@ -13,6 +13,7 @@ MNode*  ml_write_file (MNode* cell, MlEnv* mlenv);
 MNode*  ml_delete_store (MNode* cell, MlEnv* mlenv);
 MNode*  ml_clean_store (MNode* cell, MlEnv* mlenv);
 MNode*  ml_datastore (MNode* cell, MlEnv* mlenv);
+MNode*  ml_datastore_progn (MNode* cell, MlEnv* mlenv);
 MNode*  ml_new_storage (MNode* cell, MlEnv* mlenv);
 MNode*  ml_set_storage (MNode* cell, MlEnv* mlenv);
 MNode*  ml_delete_storage (MNode* cell, MlEnv* mlenv);