Changeset 152

Timestamp:

05/14/06 02:10:45 (3 years ago)

Author:

krobillard

Message:

Thune -
'do now dispatches function!, call!, & code!
'as handles all word types.
'index? returns atom if TOS is a word.
Started implementing 'foreach.
true & false are now infused.
Fixed unitialized word.wordBlk and leak in ur_tokenize().

Location:

trunk/thune

Files:

• boot.c (modified) (3 diffs)
• context.c (modified) (3 diffs)
• debugger/ThuneDebugger.cpp (modified) (1 diff)
• doc/UserManual (modified) (3 diffs)
• eval.c (modified) (12 diffs)
• gc.c (modified) (2 diffs)
• internal.h (modified) (2 diffs)
• make.c (modified) (1 diff)
• print.c (modified) (1 diff)
• series.c (modified) (1 diff)
• tests/working/control.t (modified) (1 diff)
• tokenize.c (modified) (1 diff)

trunk/thune/boot.c

@@ -2 +2 @@
 static char _bootScript[] =
   "context! [\n"
+  "  logic! 1 make :true\n"
+  "  logic! 0 make :false\n"
   "  opcode!  0 'nop     make :nop\n"
   "  opcode!  3 'drop    make :drop\n"
@@ -29 +31 @@
   "  opcode! 27 'verify.2  make :verify.2\n"
   "  opcode! 28 'verify.3  make :verify.3\n"
+  "  opcode! 30 'foreach   make :foreach\n"
   "] make :urlan-ops\n"
 ;
 
 static char _envScript[] =
-  "logic! 1 make dup dup :true :yes :on\n"
-  "logic! 0 make dup dup :false :no :off\n"
+  "logic! 1 make dup :yes :on\n"
+  "logic! 0 make dup :no :off\n"
   "char! 10 make :eol\n"
   "[quit] proc :q\n"
@@ -42 +45 @@
   "[read to-block urlan-ops infuse] proc :load\n"
   "[select do] proc :case\n"
-  ";(block cond -- )\n"
   "[\n"
   "  dup do iff (drop drop return)\n"
   "  over do recurse\n"
   "]\n"
-  "proc :while\n"
+  "proc :while  ;(block cond -- )\n"
+  "[\n"
+  "  dup zero? ift (drop drop return)\n"
+  "  over do 1 sub recurse\n"
+  "]\n"
+  "proc :loop   ;(block count -- )\n"
   "[error! swap make throw] proc :error\n"
-  "; (env body -- proc)\n"
-  "[swap context bind proc] proc :proc.env\n"
-  "; (data rules -- pos)\n"
-  "[[some none] 2 poke parse] proc :parse.some\n"
+  "[swap context bind proc] proc :proc.env      ;(env body -- proc)\n"
+  "[[some none] 2 poke parse] proc :parse.some  ;(data rules -- pos)\n"
   "3.14159265358979323846 :pi\n"
   "[\n"

trunk/thune/context.c

@@ -168 +168 @@
 
     ur_setType( it, UT_WORD );
-    //it->word.wordBlk = ctx->ctx.wordBlk;
+    it->word.wordBlk = 0;       //ctx->ctx.wordBlk;
     it->word.valBlk  = ctx->ctx.valBlk;
     it->word.index   = wrdN;
@@ -495 +495 @@
     while( it != end )
     {
-        if( ur_is(it, UT_WORD) ||
-            ur_is(it, UT_SETWORD) ||
-            ur_is(it, UT_GETWORD) ||
-            ur_is(it, UT_LITWORD) ||
-            ur_is(it, UT_OPCODE) )
+        if( ur_isAWord(it) || ur_is(it, UT_OPCODE) || ur_is(it, UT_SELECTOR) )
         {
             _bindWord( it );
@@ -506 +502 @@
         {
             UCell* path1 = ur_blockPtr( it->series.n )->ptr.cells;
-            if( ur_is(path1, UT_WORD) ||
-                ur_is(path1, UT_SETWORD) ||
-                ur_is(path1, UT_GETWORD) )
+            if( ur_isAWord(path1) )
             {
                 _bindWord( path1 );

trunk/thune/debugger/ThuneDebugger.cpp

@@ -31 +31 @@
 
     _editor = new QTextEdit;
-    _editor->setTabStopWidth( 4 );
+    _editor->setTabStopWidth( 8 * 4 /*_editor->fontMetrics().height() * 3*/ );
     new ThuneHighlight(_editor->document());
     setCentralWidget(_editor);

trunk/thune/doc/UserManual

@@ -17 +17 @@
 
    * Small binary & run-time enviroment.
-   * Written in C to work well with existing systems.
+   * Written in C to work well as an embedded scripting language.
    * Stack based evaluator.
    * Garbage collected datatype system with prototype based objects.
@@ -69 +69 @@
 string!     "hello"  {hello}
 binary!     #{01afed}  #{00 33 ff a0}
+selector!   obj/x my-array/2
 slice!
 context!
@@ -212 +213 @@
 ========  =========================  ============================
 proc.env  (env body -- proc)         Create procedure with context.
+========  =========================  ============================
+
+
+Contexts
+--------
+
+==========  ========================  =================
+Word        Stack Usage               Function
+==========  ========================  =================
+set         (val word -- )            Assign value to word.
+get         (word -- val)             Retrieve value referenced by word.
+==========  ========================  =================
+
+
+Context Helpers
+~~~~~~~~~~~~~~~
+
+========  =========================  ============================
+Word      Stack Usage                Function
+========  =========================  ============================
+context   (def -- context)           Create context.
 ========  =========================  ============================
 

trunk/thune/eval.c

@@ -86 +86 @@
     UR_C_GROW
 
-#define POPC_ITER(a,b) \
+#define RESET_ITER(a,b) \
     b = UR_TOC->cp.cell; \
-    UR_C_DEC; \
-    a = UR_TOC->cp.cell
-
-#define RESET_ITER(a,b) \
+    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; \
@@ -247 +256 @@
         case UT_VEC3:
         {
-            int n;
-
+            unsigned int n;
             n = ur_selector(sel) - (ur_selIsAtom(sel) ? UR_ATOM_X : 1);
-
-            ur_setType( res, UT_DECIMAL );
-            ur_decimal(res) = (double) val->vec3.xyz[ n & 3 ];
+            if( n < 3 )
+            {
+                ur_setType( res, UT_DECIMAL );
+                ur_decimal(res) = (double) val->vec3.xyz[ n ];
+            }
+            else
+            {
+                ur_setNone( res );
+            }
             return 1;
         }
@@ -283 +297 @@
 
             ur_wordCell( tos, blk, val );
-            ur_copyCell(tos, *val );
+
+            switch( ur_type(val) )
+            {
+                case UT_WORD:
+                case UT_LITWORD:
+                    ur_wordCell( val, blk, val );
+                    ur_copyCell( tos, *val );
+                    break;
+
+                case UT_FUNCTION:
+                    ur_copyCell( tos, *val );
+                    UR_CALL_OP = OP_DO_FUNC;
+                    break;
+
+                case UT_CALL:
+                    UR_S_DROP;
+                    val->call.addr( ur_thread, UR_TOS );
+                    break;
+
+                case UT_CODE:
+                    ur_copyCell( tos, *val );
+                    ur_language(val)->run( ur_thread, tos );
+                    break;
+
+                default:
+                    ur_copyCell( tos, *val );
+                    break;
+            }
         }
             break;
@@ -321 +362 @@
             break;
 
+        case UT_CALL:
+            UR_S_DROP;
+            tos->call.addr( ur_thread, UR_TOS );
+            break;
+
         case UT_CODE:
             ur_language(tos)->run( ur_thread, tos );
             break;
-    }
-    // else leave tos unchanged...
+
+        // default: leave tos unchanged...
+    }
 }
 
@@ -349 +396 @@
 
         ur_wordCell( tos, blk, val );
-        ur_copyCell(tos, *val );
+        ur_copyCell( tos, *val );
     }
     // else leave tos unchanged...
@@ -555 +602 @@
                         }
                         break;
+
+                    case OP_FOREACH:        // (blk series ['words] -- )
+                        val = UR_TOS;
+                        while( ur_is(val, UT_LITWORD) )
+                            ++val;
+                        PUSHC_EVAL( blkN, start, pc + 1 );
+                        SET_BLK_PC( val[1].series.n,
+                                    val[1].series.it );
+                        PUSHC_FOREACH( UR_BOS - val, pc, end );
+                        goto control;
 
                     case OP_RECURSE:
@@ -851 +908 @@
                 goto execute;
             }
-            POPC_ITER( pc, end );
+            UR_C_DEC;
             UR_S_DROP;           // Pop iterator value.
+            goto control;
+
+        case CC_FOREACH:
+            val = UR_BOS - UR_TOC->cp.n;
+            if( ! ur_atTail( val ) )
+            {
+                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;
 
@@ -911 +981 @@
 
             case CC_ITER:
+            case CC_FOREACH:
                 UR_C_DECN( CC_LEN_ITER);
                 break;
@@ -950 +1021 @@
             case CC_EVAL_RUNNING:
                             UR_C_DECN( CC_LEN_EVAL );  break;
-            case CC_ITER:   UR_C_DECN( CC_LEN_ITER );  break;
+            case CC_ITER:
+            case CC_FOREACH:
+                            UR_C_DECN( CC_LEN_ITER );  break;
             case CC_CATCH:  UR_C_DECN( CC_LEN_CATCH ); break;
 
@@ -973 +1046 @@
             case CC_EVAL_RUNNING:
                             UR_C_DECN( CC_LEN_EVAL );  break;
-            case CC_ITER:   UR_C_DECN( CC_LEN_ITER );  break;
+            case CC_ITER:
+            case CC_FOREACH:
+                            UR_C_DECN( CC_LEN_ITER );  break;
             case CC_CATCH:  UR_C_DECN( CC_LEN_CATCH ); break;
 
@@ -1396 +1471 @@
 UR_CALL( uc_set )
 {
-    if( ur_is(tos, UT_LITWORD) )
+    if( ur_isAWord(tos) )
     {
         UBlock* blk;
@@ -1452 +1527 @@
     {
         case UT_WORD:
-            if( ur_is(val, UT_LITWORD) )
-                ur_type(val) = UT_WORD;
-            break;
-
+        case UT_SETWORD:
+        case UT_GETWORD:
         case UT_LITWORD:
-            if( ur_is(val, UT_WORD) )
-                ur_type(val) = UT_LITWORD;
+            if( ur_isAWord(val) )
+                ur_type(val) = ur_datatype(tos);
             break;
 

trunk/thune/gc.c

@@ -217 +217 @@
             case UT_SETWORD:
             //case UT_LITWORD:      // Only atom is used in lit-words?
-                SET_BIT_BLOCK( it->word.wordBlk );
+                if( it->word.wordBlk )
+                {
+                    SET_BIT_BLOCK( it->word.wordBlk );
+                }
                 SET_BIT_BLOCK( it->word.valBlk );
                 break;
@@ -401 +404 @@
 
             case CC_ITER:
+            case CC_FOREACH:
                 it -= CC_LEN_ITER;
                 break;

trunk/thune/internal.h

@@ -111 +111 @@
 #define CC_EVAL_RUNNING     2
 #define CC_ITER             3
-#define CC_CATCH            4
-#define CC_END              5
+#define CC_FOREACH          4
+#define CC_CATCH            5
+#define CC_END              6
 
 //#define CC_LEN_FUNC         1  // + argc
 #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
@@ -176 +178 @@
 #define OP_VERIFY_3         28
 #define OP_DO_FUNC          29
+#define OP_FOREACH          30
 //#define OP_END              255
 

trunk/thune/make.c

@@ -605 +605 @@
     cell = ur_appendCell( blk, type );
 
-    //cell->word.wordBlk = GLOBAL_WORD_BLKN;
+    cell->word.wordBlk = 0;     //GLOBAL_WORD_BLKN;
     cell->word.valBlk  = GLOBAL_VAL_BLKN;
     //cell->word.index   = -1;

trunk/thune/print.c

@@ -1001 +1001 @@
             break;
 
-#ifdef LANG_ORCA
-        case UT_NATIVE:
-        {
-            UCell bval;
-            append(out, "native ", 7);
-
-            bval.type      = UT_BLOCK;
-            bval.flags     = 0;
-            bval.series.n  = val->func.specBlk;
-            bval.series.it = 0;
-            ur_toStr( &bval, out, depth );
-        }
-            break;
-#endif
+        case UT_CALL:
+            append(out, "*call*", 6);
+            break;
 
         case UT_FUNCTION:

trunk/thune/series.c

@@ -309 +309 @@
         ur_setType(tos, UT_INT);
         ur_int(tos) = tos->series.it + 1;
+    }
+    else if( ur_isAWord(tos) )
+    {
+        ur_setType(tos, UT_INT);
+        ur_int(tos) = ur_atom(tos);
     }
     else

trunk/thune/tests/working/control.t

@@ -2 +2 @@
 
 0 :n
-[n dup . 1 add :n]
-[n 3 lt?] while
+[n dup . 1 add :n] [n 3 lt?] while
 "done" print
 
 
-; (block count -- )
-[
-    dup zero? ift (drop drop return)
-    over do 1 sub recurse
-]
-proc :loop
-
 0 :n
-[n dup . 1 add :n]
-10 loop
+[n dup . 1 add :n] 10 loop
 "done" print
 

trunk/thune/tokenize.c

@@ -533 +533 @@
 
     ur_release( hold );
-    return STACK[0];
+    hold = STACK[0];
+    ur_arrayFree( &stack );
+    return hold;
 }