Changeset 168

Timestamp:

06/05/06 03:23:01 (3 years ago)

Author:

krobillard

Message:

Thune -

'set can now assign a block of words from a series.
Implemented 'foreach as a function.
Boot.c is now built from mkboot.t script.

Location:

trunk/thune

Files:

• boot.c (modified) (4 diffs)
• doc/UserManual (modified) (2 diffs)
• eval.c (modified) (8 diffs)
• gc.c (modified) (1 diff)
• internal.h (modified) (3 diffs)
• mkboot.t (added)
• print.c (modified) (3 diffs)
• series.c (modified) (2 diffs)
• tests/Makefile (modified) (1 diff)
• tests/grind (added)
• tests/working/control.good (modified) (2 diffs)
• tests/working/control.t (modified) (1 diff)

trunk/thune/boot.c

@@ +1 @@
+/* Generated by mkboot.t */
 
 static char _bootScript[] =
@@ -29 +30 @@
   "  opcode! 25 'dec     make :dec\n"
   "  opcode! 26 'verify  make :verify\n"
-  "  opcode! 30 'foreach make :foreach\n"
   "] make :urlan-ops\n"
 ;
@@ -54 +54 @@
   "]\n"
   "proc :loop   ;(block count -- )\n"
+  "[| body words len-1]\n"
+  "[\n"
+  "   block! block! verify/2\n"
+  "   :body :words\n"
+  "   words [first word! verify drop] iter\n"
+  "   words length?\n"
+  "   dup dec :len-1\n"
+  "   [\n"
+  "     1  [words set            body do]\n"
+  "     2  [words set next       body do]\n"
+  "        [words set len-1 skip body do]\n"
+  "   ] select\n"
+  "   iter\n"
+  "]\n"
+  "func :foreach       ; (ser words body -- )\n"
   "[error! swap make throw] proc :error\n"
   "[swap context bind proc] proc :proc.env      ;(env body -- proc)\n"
@@ -59 +74 @@
   "3.14159265358979323846 :pi\n"
   "[\n"
-  "  {0.0.1} :version\n"
+  "  \"0.0.1\" :version\n"
   "  none :os\n"
   "] context :env\n"
   "[now swap do now swap sub] proc :time-blk\n"
 ;
-
-
-/*
-  "quit: :q\n"
-  "none!  0 make :none\n"
-  "logic! 1 make [true yes on] set\n"
-  "logic! 0 make [false no off] set\n"
-  "[\n"
-*/

trunk/thune/doc/UserManual

@@ -189 +189 @@
 while     (body cond -- )            Evaluate body while cond is true.
 loop      (block n -- )              Repeat block **n** times.
-iter      (ser block -- )            Iterate over series.
+iter      (ser body -- )             Iterate over series.
+foreach   (ser words body -- )       Iterate over series and assign elements.
 proc      (body -- )                 Create procedure.
 func      (sig body -- )             Create function with local values.
@@ -285 +286 @@
 prev        (ser -- ser)            Decrement start of series.
 next        (ser -- ser)            Increment start of series.
+skip        (ser n -- ser)          Increment start of series by **n**.
 slice.prev  (slice -- slice)        Decrement end of slice.
 slice.next  (slice -- slice)        Increment end of slice.

trunk/thune/eval.c

@@ -89 +89 @@
 
 #define RESET_ITER(a,b) \
-    b = UR_TOC->cp.cell; \
-    a = UR_TOC[-1].cp.cell; \
-    UR_C_GROW
-
-
-#define PUSHC_FOREACH(si,a,b) \
-    UR_TOC->cp.cell = a; \
-    UR_C_GROW; \
-    UR_TOC->cp.code = CC_FOREACH; \
-    UR_TOC->cp.n    = si; \
-    UR_TOC->cp.cell = b; \
-    UR_C_GROW
-
-#define RESET_FOREACH(a,b) \
     b = UR_TOC->cp.cell; \
     a = UR_TOC[-1].cp.cell; \
@@ -506 +492 @@
 
             case CC_ITER:
-            case CC_FOREACH:
                  toc -= CC_LEN_ITER;
                  break;
@@ -665 +650 @@
                         }
                         break;
-
-                    case OP_FOREACH:        // (blk series ['words] -- )
-                        ++pc;
-                        val = UR_TOS;
-                        while( ur_is(val, UT_LITWORD) )
-                            ++val;
-                        PUSHC_EVAL( blkN, start, pc );
-                        SET_BLK_PC( val[1].series.n,
-                                    val[1].series.it );
-                        PUSHC_FOREACH( UR_BOS - val, pc, end );
-                        goto control;
 
                     case OP_RECURSE:
@@ -975 +949 @@
             goto control;
 
-        case CC_FOREACH:
-            val = UR_BOS - UR_TOC->cp.n;
-            if( ur_itLen(val) > 0 )
-            {
-                UR_TOS->series.it++;
-                RESET_FOREACH( pc, end );
-                UR_S_DUP;
-                goto execute;
-            }
-            UR_C_DEC;
-            UR_S_DROPN( UR_TOC->cp.n );     // Pop iterator values.
-            goto control;
-
         case CC_CATCH:
             UR_C_DECN( 2 );
@@ -1044 +1005 @@
 
             case CC_ITER:
-            case CC_FOREACH:
                 UR_C_DECN( CC_LEN_ITER );
                 break;
@@ -1312 +1272 @@
             break;
 
+        case UT_CHAR:
         case UT_INT:
-            if( ur_is(b, UT_INT) )
+            if( ur_is(b, UT_INT) || ur_is(b, UT_CHAR) )
             {
                 if( ur_int(a) == ur_int(b) )
@@ -1541 +1502 @@
 
 
-// (val word -- )
+/*
+  (val word -- )
+
+  If val is a series and word is a block then the words are set to the
+  first N elements of the series (where N is the number of words in word).
+*/
 UR_CALL( uc_set )
 {
+    UBlock* blk;
+    UCell* cell;
+    UCell* val;
+
+    val = ur_s_prev( tos );
+
     if( ur_isAWord(tos) )
     {
-        UBlock* blk;
-        UCell* cell;
-        UCell* val;
-
         if( ur_wordIsUnbound(tos) )
         {
@@ -1563 +1531 @@
         }
 
-        val = ur_s_prev( tos );
         ur_wordCell( tos, blk, cell );
         ur_copyCell( cell, *val );
+    }
+    else if( ur_is(tos, UT_BLOCK) )
+    {
+        UCell* it;
+        UCell* end;
+
+        blk = ur_block(tos);
+        UR_ITER_BLOCK( it, end, blk, tos );
+
+        if( ur_isASeries(val) )
+        {
+            int n = 0;
+            while( it != end )
+            {
+                if( ur_isAWord(it) )
+                {
+                    ur_wordCell( it, blk, cell );
+                    ur_pick( val, n++, cell );
+                }
+                ++it;
+            }
+        }
+        else
+        {
+            while( it != end )
+            {
+                if( ur_isAWord(it) )
+                {
+                    ur_wordCell( it, blk, cell );
+                    ur_copyCell( cell, *val );
+                }
+                ++it;
+            }
+        }
     }
     UR_S_DROPN(2);

trunk/thune/gc.c

@@ -404 +404 @@
 
             case CC_ITER:
-            case CC_FOREACH:
                 SET_BIT_BLOCK( it->cp.n );
                 it -= CC_LEN_ITER;

trunk/thune/internal.h

@@ -117 +117 @@
 #define CC_EVAL_RUNNING     2
 #define CC_ITER             3
-#define CC_FOREACH          4
-#define CC_CATCH            5
-#define CC_END              6
+#define CC_CATCH            4
+#define CC_END              5
 #define CC_COUNT            (CC_END+1)
 
@@ -126 +125 @@
 #define CC_LEN_EVAL         1
 #define CC_LEN_ITER         2
-#define CC_LEN_FOREACH      2
 #define CC_LEN_CATCH        3
 #define CC_LEN_END          1
@@ -186 +184 @@
 #define OP_28               28
 #define OP_DO_FUNC          29
-#define OP_FOREACH          30
 //#define OP_END              255
 

trunk/thune/print.c

@@ -49 +49 @@
         EXPAND( str, len );
     str->used += copyUtf16ToAscii( str->ptr.c + str->used, cp, len );
+}
+
+
+/*
+   c2 must be a string! or string slice!.
+*/
+void ur_strCatCell( UString* out, int encoding, const UCell* c2 )
+{
+    UString* str2;
+    int si;
+    int used;
+
+    str2 = ur_bin( c2 );
+    si = c2->series.it;
+
+    used = str2->used;
+    if( ur_is(c2, UT_SLICE) )
+    {
+        if( used > c2->slice.end )
+            used = c2->slice.end;
+    }
+    used -= si;
+
+    if( used > 0 )
+    {
+        if( encoding == UR_ENC_ASCII )
+        {
+            switch( ur_encoding(c2) )
+            {
+                case UR_ENC_ASCII:
+                case UR_ENC_UTF8:
+                    ur_strCat( out, str2->ptr.c + si, used );
+                    break;
+
+                case UR_ENC_UTF16:
+                    ur_strCatUtf16( out, str2->ptr.u16 + si, used );
+                    break;
+            }
+        }
+        else
+        {
+            assert( "encoding not handled" && 0 );
+        }
+    }
 }
 
@@ -609 +653 @@
 
         case UT_STRING:
-        {
-            UString* str = ur_bin( val );
-            int si = val->series.it;
-            int used = str->used - si;
-            if( used > 0 )
-            {
-                switch( ur_encoding(val) )
-                {
-                    case UR_ENC_ASCII:
-                    case UR_ENC_UTF8:
-                        append( out, str->ptr.c + si, used );
-                        break;
-
-                    case UR_ENC_UTF16:
-                        EXPAND( out, used );
-                        out->used += copyUtf16ToAscii( out->ptr.c,
-                                                       str->ptr.u16, used );
-                        break;
-                }
-            }
-        }
+            ur_strCatCell( out, UR_ENC_ASCII, val );
             break;
 #if 0
@@ -702 +726 @@
         }
             break;
+
+        case UT_SLICE:
+            switch( ur_sliceDT(val) )
+            {
+                case UT_STRING:
+                    ur_strCatCell( out, UR_ENC_ASCII, val );
+                    break;
+            }
+            break;
+
 #if 0
         case OT_OBJECT:

trunk/thune/series.c

@@ -23 +23 @@
 #include "charset.h"
 #include "internal.h"
+
+
+extern void ur_strCatCell( UString* out, int encoding, const UCell* c2 );
 
 
@@ -885 +888 @@
     switch( ur_type(ser) )
     {
-#if 0
-        case UT_BINARY:
+        //case UT_BINARY:
+
         case UT_STRING:
-            if( ur_isAString(tos) )
-            {
-                UBinary* s1 = ur_bin(ser);
-                UBinary* s2 = ur_bin(tos);
-                int used = s1->used;
-                int srcLen = s2->used - tos->series.it;
-
-                ur_arrayReserve( s1, sizeof(char), used + srcLen );
-
-                memCpy( s1->ptr.cells + s1->used,
-                        s2->ptr.cells + tos->series.it, srcLen );
-                s1->used += srcLen;
-            }
-            break;
-#endif
+            if( ur_is(tos, UT_STRING) ||
+                (ur_is(tos, UT_SLICE) && (ur_sliceDT(tos) == UT_STRING)) )
+            {
+                ur_strCatCell( ur_bin(ser), ur_encoding(ser), tos );
+            }
+            break;
+
         case UT_BLOCK:
         case UT_PAREN:

trunk/thune/tests/Makefile

@@ -1 +1 @@
 # Makefile 
+
+.PHONY: grind clean
 
 test:
         @./run_test working/*.t
 
+grind:
+        @./grind working/*.t
+
 clean:
         @rm -f working/*.out

trunk/thune/tests/working/control.good

@@ +1 @@
+--- while 0 ---
 0
 1
 2
-done
+--- loop 0 ---
 0
 1
@@ -13 +14 @@
 8
 9
-done
+--- foreach 0 ---
+--- foreach 1 ---
+ 1
+ 2
+ a
+ b
+ one
+ two
+ tree
+--- foreach 2 ---
+ 1 2
+ a b
+ one two
+ tree none
+--- foreach 3 ---
+ 1 2 a
+ b one two
+ tree none none
+--- foreach 8 ---
+ 1 2 a b one two tree none
+Tests done

trunk/thune/tests/working/control.t

@@ -1 +1 @@
 ; Control flow test
 
+
+"--- while 0 ---" print
 0 :n
 [n dup . 1 add :n] [n 3 lt?] while
-"done" print
 
 
+"--- loop 0 ---" print
 0 :n
 [n dup . 1 add :n] 10 loop
-"done" print
 
+
+[[" " prin first reduce prin] iter eol prin] proc :rprint     ; (block -- )
+
+[1 2 'a 'b "one" "two" "tree"] :data
+
+"--- foreach 0 ---" print
+data tail [a] [[a] rprint] foreach
+
+"--- foreach 1 ---" print
+data [a] [[a] rprint] foreach
+
+"--- foreach 2 ---" print
+data [a b] [[a b] rprint] foreach
+
+"--- foreach 3 ---" print
+data [a b c] [[a b c] rprint] foreach
+
+"--- foreach 8 ---" print
+data [a b c d e f g h] [[a b c d e f g h] rprint] foreach
+
+
+"Tests done" print