Add lib/random.ab .

Rename from_XXX to to_YYY.
Fixed a bug of alpha-conversion.

lib/amber/syntax.ab

@@ -2,7 +2,7 @@ Assign{Qualified{Syntax,comment}, Qualified{Syntax,shell_style_comment}}
 
 # Copyright (C) 2010 nineties
 #
-# $Id: syntax.ab 2013-03-16 16:55:27 nineties $
+# $Id: syntax.ab 2013-03-17 06:42:53 nineties $
 
 # Syntax definition of the Amber language.
 # This file will be loaded first.
@@ -152,9 +152,6 @@ primary_block
     ::= <<multiline>> "{" block_body "}" { node1 }
         # Block with module imports
 
-      | <<multiline>> "seq" "{" aligned(located(statement)) "}"
-        { MakeObject{Quote{Seq}, List{node2}} }
-
 block ::= primary_block
         | block_body
 
@@ -374,7 +371,7 @@ statement
 ### Reserved Keywords
 ReserveSymbol{not, and, or, when, open, if, else, case, of,
     while, for, reverse_for, in, continue, break, return,
-    throw, try, catch, seq, scope
+    throw, try, catch, scope
 }
 
 ## Syntax Sugars
@@ -404,8 +401,6 @@ x == y  => `equal(!x, !y)
 x != y  => `(not equal(!x, !y))
 x is y  => `identical(!x, !y)
 x is not y => `(not identical(!x, !y))
-x[args...]     => `Apply{at, !Std::cons(x, args)}
-x[args...] = e => `Apply{store, !Std::cons(x, Std::append(args, [e]))}
 
 module Syntax {
     ### Extend primary_expr so as to enable use $... to refer nodes

lib/data/bitable.ab

@@ -1,6 +1,6 @@
 # Copyright (C) 2012 nineties
 #
-# $Id: table.ab 2013-03-05 04:45:03 nineties $
+# $Id: table.ab 2013-03-17 11:51:33 nineties $
 
 module Std {
     module BiTable {
@@ -24,7 +24,7 @@ module Std {
                 !Table::new(hash2, equal2, kill2)
             }
 
-        from_list(pairs@List): {
+        to_bitable(pairs@List): {
             tbl: BiTable::new()
             for ((a,b) in pairs) {
                 tbl[0][a] = b
@@ -50,5 +50,5 @@ module Std {
     bitable_entry ::= expr "<=>" expr { ($0, $2) }
     postfix_expr
         ::= <<multiline>> "BiTable" "{" delimited(bitable_entry, ",") "}"
-            { `BiTable::from_list(!$2) }
+            { `to_bitable(!$2) }
 }

lib/data/set.ab

@@ -1,6 +1,6 @@
 # Copyright (C) 2012 nineties
 #
-# $Id: set.ab 2012-11-23 13:24:17 nineties $
+# $Id: set.ab 2013-03-17 11:52:21 nineties $
 
 # XXX: Temporary implementation (not fast)
 
@@ -11,7 +11,7 @@ module Std {
 
     module Set {
         new(): Set{}
-        from_list(ls@List): {
+        to_set(ls@List): {
             s: new()
             for (v: ls) s.push(v)
             s
@@ -47,5 +47,5 @@ module Std {
     }
 
     # Macro
-    Set{elems...} => `Set::from_list(!elems)
+    Set{elems...} => `to_set(!elems)
 }

lib/data/table.ab

@@ -1,6 +1,6 @@
 # Copyright (C) 2012 nineties
 #
-# $Id: table.ab 2013-03-14 20:38:14 nineties $
+# $Id: table.ab 2013-03-17 11:52:02 nineties $
 
 module Std {
     each(tbl@Table): tbl.entries.each
@@ -10,4 +10,4 @@ module Std {
 table_entry ::= expr "=>" expr { ($0, $2) }
 postfix_expr
     ::= <<multiline>> "Table" "{" delimited(table_entry, ",") "}"
-        { `Table::from_list(!$2) }
+        { `to_table(!$2) }

lib/random.ab

@@ -0,0 +1,47 @@
+# Copyright (C) 2012 nineties
+#
+# $Id: random.ab 2013-03-17 16:51:44 nineties $
+
+module Std {
+    # Choose one element randomly
+    choose(seq): seq[rand(seq.size)]
+
+    # Choose `n' element from `seq' randomly
+    choose(seq, n@Int) when n >= 0: {
+        seq = to_array(seq)
+        result: []
+        len: seq.size
+        if (n > len)
+            throw `Error{!LOCATION, "The sequence doesn't have " + n + " elements", seq}
+        reverse_for(i in len-n..len-1) {
+            j: rand(i+1)
+            (seq[i], seq[j]) = (seq[j], seq[i]) 
+            result = cons(seq[i], result)
+        }
+        result
+    }
+
+    # Choose `n' element from `seq' randomly
+    choose(seq, n@Int, \repeat) when n >= 0:
+        List::new(n, _ -> choose(seq))
+
+    # Shuffle `seq' randomly by Fisher-Yates's algorithm.
+    shuffle(seq): {
+        seq = copy(seq)
+        reverse_for (i in 1..(seq.size-1)) {
+            j: rand(i+1)
+            (seq[i], seq[j]) = (seq[j], seq[i]) 
+        }
+        seq
+    }
+
+    # Shuffle `seq'.
+    shuffle(seq@List): {
+        seq = to_array(seq)
+        reverse_for (i in 1..(seq.size-1)) {
+            j: rand(i+1)
+            (seq[i], seq[j]) = (seq[j], seq[i]) 
+        }
+        to_list(seq)
+    }
+}

rowl1/rowl1-array.rlc

@@ -2,7 +2,7 @@
 ; rowl - 1st generation
 ; Copyright (C) 2012 nineties
 ;
-; $Id: rowl1-array.rlc 2013-02-23 14:38:05 nineties $
+; $Id: rowl1-array.rlc 2013-03-17 11:51:03 nineties $
 ;
 
 (import "rlvm-compile")
@@ -160,8 +160,8 @@
     (add_function0 ModArray (to_sym "new") ary_new 0)
     (add_function1 ModArray (to_sym "new") intT ary_new2 0)
     (add_function2 ModArray (to_sym "new") intT DontCare ary_new3 0)
-    (add_function1 ModArray (to_sym "from_list") listT list_to_ary 0)
-    (add_function1 ModList  (to_sym "from_array") arrayT ary_to_list 0)
+    (add_function1 std (to_sym "to_array") listT list_to_ary 0)
+    (add_function1 std  (to_sym "to_list") arrayT ary_to_list 0)
 
     (add_function1 std (to_sym "length") arrayT ary_size 0)
     (add_function1 std (to_sym "size") arrayT ary_size 0)

rowl1/rowl1-compile.rlc

@@ -2,7 +2,7 @@
 ; rowl - 1st generation
 ; Copyright (C) 2010 nineties
 ;
-; $Id: rowl1-compile.rlc 2013-03-16 17:36:32 nineties $
+; $Id: rowl1-compile.rlc 2013-03-17 16:46:41 nineties $
 ;
 
 (import "rlvm-compile")
@@ -263,8 +263,8 @@
         )
     (if (|| (== hd DefVariable) (== hd DefFunction)) (do
         (= expr (_copy expr))
-        (node_arg_set expr 0 (alpha_args tbl (node_arg expr 0)))
         (node_arg_set expr 1 (alpha tbl (node_arg expr 1)))
+        (node_arg_set expr 0 (alpha_args tbl (node_arg expr 0)))
         (return expr)
         ))
     (if (|| (== hd Block) (== hd Breakable)) (do
@@ -343,7 +343,7 @@
         ))
     (var hd (node_bhead expr))
     (if (== hd Quote) (return expr))
-    (if (== hd Qualified) (do
+    (if (|| (== hd Qualified) (== hd Subscript)) (do
         (var v (unique_sym))
         (field_set ret 1 (cons v (field_get ret 1)))
         (field_set ret 2 (cons expr (field_get ret 2)))
@@ -964,9 +964,15 @@
     (set_label asm lbl)
     (while rvars (do
         (var def @C_NIL)
+        (var v (car rvars))
+        (if (== (node_head v) Array)
+            (throw (make_object3 Exception current_loc
+                (string "Invalid lhs-operand")
+                v))
+            )
         (if (== overwrite @C_TRUE)
-            (= def (make_object3 DefVariable (car rvars) Decons (to_sym "overwrite")))
-            (= def (make_object2 DefVariable (car rvars) Decons))
+            (= def (make_object3 DefVariable v Decons (to_sym "overwrite")))
+            (= def (make_object2 DefVariable v Decons))
             )
         (compile_define_variable asm mod def)
         (put_drop asm)
@@ -1593,7 +1599,7 @@
             (make_object2 While
                 (make_object1 Not (apply (to_sym "equal") (list2
                 (assign v (apply iter 0)) @C_UNDEF)))
-                (seq (list2
+                (block (list2
                     (defvar i v)
                     body
                     )))
@@ -1612,8 +1618,8 @@
             (defvar v @C_NIL)
             (make_object2 While
                 (make_object1 Not (apply (to_sym "equal") (list2
-                (assign v (apply iter 0)) @C_UNDEF)))
-                (seq (list2
+                    (assign v (apply iter 0)) @C_UNDEF)))
+                (block (list2
                     (defvar i v)
                     body
                     )))
@@ -1645,7 +1651,7 @@
             (defvar n b)
             (make_object3 While
                 (apply (to_sym "le") (list2 j n))
-                (seq (list2
+                (block (list2
                     (defvar i j)
                     body
                     ))
@@ -1676,9 +1682,9 @@
         (block (list3
             (defvar j b)
             (defvar n a)
-            (make_object2 While
-                (apply (to_sym "ge") (list2 i n))
-                (seq (list2
+            (make_object3 While
+                (apply (to_sym "ge") (list2 j n))
+                (block (list2
                     (defvar i j)
                     body))
                 (assign j (apply (to_sym "sub") (list2 j (box 1)))))
@@ -1730,6 +1736,52 @@
     (throw (bug (string "compile_assign")))
     ))
 
+(fun compile_subscript (asm mod expr) (
+    (var opd (node_arg expr 0))
+    (var args (node_arg_list expr 1))
+
+    (= args (list_reverse args))
+    (var arity 0)
+    (while args (do
+        (compile asm mod (car args))
+        (= args (cdr args))
+        (incr arity)
+        ))
+    (compile asm mod opd)
+    (incr arity)
+
+    (compile asm mod (to_sym "at"))
+    (put_push asm (to_sym "at"))
+    (put_push asm current_loc)
+    (compile_simple_call asm 3 compile_matching)
+    (put_jcall asm (* 4 arity))
+    ))
+
+(fun compile_subscript_assign (asm mod expr) (
+    (var lhs (node_arg expr 0))
+    (var rhs (node_arg expr 1))
+    (var opd (node_arg lhs 0))
+    (var args (node_arg_list lhs 1))
+
+    (compile asm mod rhs)
+
+    (= args (list_reverse args))
+    (var arity 1)
+    (while args (do
+        (compile asm mod (car args))
+        (= args (cdr args))
+        (incr arity)
+        ))
+    (compile asm mod opd)
+    (incr arity)
+
+    (compile asm mod (to_sym "store"))
+    (put_push asm (to_sym "store"))
+    (put_push asm current_loc)
+    (compile_simple_call asm 3 compile_matching)
+    (put_jcall asm (* 4 arity))
+    ))
+
 ; translate
 ;
 ; Foo{x, y, Bar{z}} = e
@@ -1763,7 +1815,7 @@
     (set_label asm lbl)
 
     (while rvars (do
-        (compile_assign asm mod (assign (car rvars) Decons))
+        (compile asm mod (assign (car rvars) Decons))
         (put_drop asm)
         (= rvars (cdr rvars))
         ))
@@ -2141,6 +2193,11 @@
     (add_compiler global (make_object2 Lambda DontCare DontCare) compile_lambda)
     (add_compiler global (make_object2 Fusion DontCare DontCare) compile_fusion)
 
+    (add_compiler global (make_object2 Subscript DontCare DontCare) compile_subscript)
+    (add_compiler global (make_object2 Assign
+        (make_object2 Subscript DontCare DontCare) DontCare)
+        compile_subscript_assign)
+
     (add_compiler global (make_object2 Slot DontCare symT) compile_slot)
     (add_compiler global (make_object3 Slot DontCare symT listT) compile_slot2)
     (add_compiler global (assign (make_object2 Slot DontCare symT) DontCare)

rowl1/rowl1-list.rlc

@@ -2,7 +2,7 @@
 ; rowl - 1st generation
 ; Copyright (C) 2010 nineties
 ;
-; $Id: rowl1-list.rlc 2013-02-23 14:39:04 nineties $
+; $Id: rowl1-list.rlc 2013-03-17 16:53:16 nineties $
 ;
 
 (import "rlvm-compile")
@@ -24,6 +24,13 @@
     (throw (out_of_range current_loc list (box idx)))
     ))
 
+(fun ls_new (n f) (
+    (var new_ls 0)
+    (var code (get_bytecode f))
+    (for i 0 n (= new_ls (cons (byterun code (box i)) new_ls)))
+    (return (list_reverse new_ls))
+    ))
+
 (export fun list_at_check (ls i) (
     (var orig ls)
     (var j i)
@@ -197,6 +204,7 @@
 
 (export fun setup_list (std) (
     (var mod (create_module std (to_sym "List")))
+    (add_function2 mod (to_sym "new") intT funT ls_new 0)
     (add_function1 std (to_sym "length") listT ls_length 0)
     (add_function1 std (to_sym "size") listT ls_length 0)
     (add_function2 std (to_sym "cons") DontCare listT ls_cons 0)