Add a select structure.

diff --git a/lib/expr.cc b/lib/expr.cc
index 4ee6b07..8a01bae 100644 (file)
--- a/lib/expr.cc
+++ b/lib/expr.cc
@@ -180,7 +180,6 @@ ustring  eval_file (MNode* cell, MlEnv* mlenv) {
     return ans;
 }
 
-//MNode*  progn (MNode* arg, MlEnv* mlenv, MNode* sym) {
 MNode*  progn (MNode* arg, MlEnv* mlenv) {
     MNodePtr  ans;
 

diff --git a/modules/ml-db.cc b/modules/ml-db.cc
index 7025254..aacb451 100644 (file)
--- a/modules/ml-db.cc
+++ b/modules/ml-db.cc
@@ -410,12 +410,12 @@ MNode*  ml_db_x_write_array (MNode* cell, MlEnv* mlenv) {
 }
 
 /*DOC:
-====select====
- (select LAMBDA ARRAYVARIABLE...) -> BOOL
+====read-select====
+ (read-select LAMBDA ARRAYVARIABLE...) -> BOOL
 
 */
-//#SFUNC       select  ml_db_x_select  $db-read
-//#SFUNC       select  ml_db_x_select  $db-rw
+//#SFUNC       read-select     ml_db_x_select  $db-read
+//#SFUNC       read-select     ml_db_x_select  $db-rw
 MNode*  ml_db_x_select (MNode* cell, MlEnv* mlenv) {
     MNode*  arg = cell->cdr ();
     MLDb*  obj = objref (mlenv);

diff --git a/modules/ml-struct.cc b/modules/ml-struct.cc
index 9aec7f7..174443b 100644 (file)
--- a/modules/ml-struct.cc
+++ b/modules/ml-struct.cc
@@ -79,12 +79,10 @@ MNode*  ml_if (MNode* cell, MlEnv* mlenv) {
        } else {
            nextNode (arg);
            if (arg) {
-//             ans = progn (arg, mlenv, cell->car ());
                ans = progn (arg, mlenv);
                if (mlenv->breaksym ()
-                   && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))) {
+                   && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ())))
                    mlenv->breaksym = NULL;
-               }
            }
        }
     }
@@ -110,12 +108,10 @@ MNode*  ml_cond (MNode* cell, MlEnv* mlenv) {
        if (! a->isCons ())
            throw (a->dump_string () + uErrorBadType);
        if (eval_bool (a->car (), mlenv)) {
-//         ans = progn (a->cdr (), mlenv, cell->car ());
            ans = progn (a->cdr (), mlenv);
            if (mlenv->breaksym ()
-               && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))) {
+               && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ())))
                mlenv->breaksym = NULL;
-           }
            break;
        }
        nextNode (arg);
@@ -135,7 +131,6 @@ MNode*  ml_progn (MNode* cell, MlEnv* mlenv) {
     MNode*  arg = cell->cdr ();
     MNodePtr  ans;
 
-//    ans =  progn (arg, mlenv, cell->car ());
     ans =  progn (arg, mlenv);
     if (mlenv->breaksym ()
        && (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))) {
@@ -145,6 +140,82 @@ MNode*  ml_progn (MNode* cell, MlEnv* mlenv) {
 }
 
 /*DOC:
+===select===
+===case===
+===otherwise===
+ (select
+       (case BOOL1 BLOCK1)
+       (case BOOL2 BLOCK2)
+       ...
+       (otherwise BLOCKn))
+*/
+//#AFUNC       select  ml_select
+//#WIKIFUNC    select  ml_select
+//#AFUNC       case    ml_case
+//#WIKIFUNC    case    ml_case
+//#AFUNC       otherwise       ml_otherwise
+//#WIKIFUNC    otherwise       ml_otherwise
+MNode*  ml_select (MNode* cell, MlEnv* mlenv) {
+    MNode*  arg = cell->cdr ();
+    MNodePtr  ans;
+
+    while (arg && ! mlenv->noprog) {
+#ifdef DEBUG
+       mlenv->logSexp (arg->car ());
+#endif /* DEBUG */
+       ans = eval (arg->car (), mlenv);
+       nextNode (arg);
+       if (ans ()) {
+           if (ans ()->isCons () && to_bool (ans ()->car ())) {
+               ans = ans ()->cdr ();
+               return ans.release ();
+           }
+       } else {
+           return NULL;
+       }
+    }
+    return NULL;
+}
+
+MNode*  ml_case (MNode* cell, MlEnv* mlenv) {
+    MNode*  arg = cell->cdr ();
+    MNodePtr  ans;
+    bool  r;
+
+    if (! arg)
+       throw (uErrorWrongNumber);
+
+    r = eval_bool (arg->car (), mlenv);
+    nextNode (arg);
+    ans = new MNode;
+    if (r) {
+       ans ()->set_car (newMNode_bool (true));
+       ans ()->set_cdr (progn (arg, mlenv));
+       if (mlenv->breaksym ()) {
+           if (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))
+               mlenv->breaksym = NULL;
+       }
+    }
+
+    return ans.release ();
+}
+
+MNode*  ml_otherwise (MNode* cell, MlEnv* mlenv) {
+    MNode*  arg = cell->cdr ();
+    MNodePtr  ans;
+
+    ans = new MNode;
+    ans ()->set_car (newMNode_bool (true));
+    ans ()->set_cdr (progn (arg, mlenv));
+    if (mlenv->breaksym ()) {
+       if (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))
+           mlenv->breaksym = NULL;
+    }
+
+    return ans.release ();
+}
+
+/*DOC:
 ===repeat===
  (repeat VARIABLE FROM TO [:step ADD] [:array VARLIST] BODY...) -> LAST VALUE
 
@@ -435,7 +506,6 @@ MNode*  ml_while (MNode* cell, MlEnv* mlenv) {
        exp = arg->car ();
        nextNode (arg);
        while (eval_bool (exp, mlenv)) {
-//         ans = progn (arg, mlenv, cell->car ());
            ans = progn (arg, mlenv);
            if (mlenv->breaksym ()) {
                if (mlenv->breaksym ()->isNil () || eq (mlenv->breaksym (), cell->car ()))

diff --git a/modules/ml-struct.h b/modules/ml-struct.h
index 6e16c47..600bc0e 100644 (file)
--- a/modules/ml-struct.h
+++ b/modules/ml-struct.h
@@ -8,6 +8,9 @@ MNode*  ml_quote (MNode* cell, MlEnv* mlenv);
 MNode*  ml_list (MNode* cell, MlEnv* mlenv);
 MNode*  ml_if (MNode* cell, MlEnv* mlenv);
 MNode*  ml_cond (MNode* cell, MlEnv* mlenv);
+MNode*  ml_select (MNode* cell, MlEnv* mlenv);
+MNode*  ml_case (MNode* cell, MlEnv* mlenv);
+MNode*  ml_otherwise (MNode* cell, MlEnv* mlenv);
 MNode*  ml_progn (MNode* cell, MlEnv* mlenv);
 MNode*  ml_repeat (MNode* cell, MlEnv* mlenv);
 MNode*  ml_doarray (MNode* cell, MlEnv* mlenv);