From: visor <visor@users.sourceforge.jp>
Date: Sun, 15 Nov 2009 04:28:32 +0000 (+0900)
Subject: Add a select structure.
X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=83dc00c39942a94469e2432450bfe7d1da24a0bd;p=hmh%2Fhhml.git

Add a select structure.
---

diff --git a/lib/expr.cc b/lib/expr.cc
index 4ee6b07..8a01bae 100644
--- 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
--- 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
--- 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
--- 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);