Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add lib/random.ab .

Rename from_XXX to to_YYY.
Fixed a bug of alpha-conversion.
  • Loading branch information...
commit 981302e68562a3c08e4ddbd227ac007b52aa9f8d 1 parent 10de8ad
nineties authored
9 lib/amber/syntax.ab
View
@@ -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
6 lib/data/bitable.ab
View
@@ -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) }
}
6 lib/data/set.ab
View
@@ -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)
}
4 lib/data/table.ab
View
@@ -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) }
47 lib/random.ab
View
@@ -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)
+ }
+}
6 rowl1/rowl1-array.rlc
View
@@ -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)
83 rowl1/rowl1-compile.rlc
View
@@ -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)
10 rowl1/rowl1-list.rlc
View
@@ -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)
68 rowl1/rowl1-node.rlc
View
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-node.rlc 2013-03-16 17:23:29 nineties $
+; $Id: rowl1-node.rlc 2013-03-17 11:56:31 nineties $
;
(import "rlvm-compile")
@@ -480,54 +480,54 @@
))
(export fun make_object0 (head) (
- (var e (allocate_expr 0))
- (field_set e 0 head)
- (return e)
+ (var obj (allocate_expr 0))
+ (field_set obj 0 head)
+ (return obj)
))
(export fun make_object1 (head a) (
- (var e (allocate_expr 1))
- (field_set e 0 head)
- (field_set e 1 a)
- (return e)
+ (var obj (allocate_expr 1))
+ (field_set obj 0 head)
+ (field_set obj 1 a)
+ (return obj)
))
(export fun make_object2 (head a b) (
- (var e (allocate_expr 2))
- (field_set e 0 head)
- (field_set e 1 a)
- (field_set e 2 b)
- (return e)
+ (var obj (allocate_expr 2))
+ (field_set obj 0 head)
+ (field_set obj 1 a)
+ (field_set obj 2 b)
+ (return obj)
))
(export fun make_object3 (head a b c) (
- (var e (allocate_expr 3))
- (field_set e 0 head)
- (field_set e 1 a)
- (field_set e 2 b)
- (field_set e 3 c)
- (return e)
+ (var obj (allocate_expr 3))
+ (field_set obj 0 head)
+ (field_set obj 1 a)
+ (field_set obj 2 b)
+ (field_set obj 3 c)
+ (return obj)
))
(export fun make_object4 (head a b c d) (
- (var e (allocate_expr 4))
- (field_set e 0 head)
- (field_set e 1 a)
- (field_set e 2 b)
- (field_set e 3 c)
- (field_set e 4 d)
- (return e)
+ (var obj (allocate_expr 4))
+ (field_set obj 0 head)
+ (field_set obj 1 a)
+ (field_set obj 2 b)
+ (field_set obj 3 c)
+ (field_set obj 4 d)
+ (return obj)
))
(export fun make_object5 (head a b c d e) (
- (var e (allocate_expr 5))
- (field_set e 0 head)
- (field_set e 1 a)
- (field_set e 2 b)
- (field_set e 3 c)
- (field_set e 4 d)
- (field_set e 5 e)
- (return e)
+ (var obj (allocate_expr 5))
+ (field_set obj 0 head)
+ (field_set obj 1 a)
+ (field_set obj 2 b)
+ (field_set obj 3 c)
+ (field_set obj 4 d)
+ (field_set obj 5 e)
+ (return obj)
))
(extern fun list_to_tuple)
4 rowl1/rowl1-numeric.rlc
View
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-numeric.rlc 2013-03-16 17:27:50 nineties $
+; $Id: rowl1-numeric.rlc 2013-03-17 14:15:00 nineties $
;
(import "rlvm-compile")
@@ -36,7 +36,7 @@
(var r (do_coerce a b))
(if (== r @C_UNDEF)
(throw (make_object5 Exception current_loc
- (string "Binary operation is not supported")
+ (string "Unknown binary operation")
(make_object1 (to_sym "method") sym)
(make_object1 (to_sym "lhs") a)
(make_object1 (to_sym "rhs") b)
6 rowl1/rowl1-table.rlc
View
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-table.rlc 2013-02-23 14:39:32 nineties $
+; $Id: rowl1-table.rlc 2013-03-17 11:50:51 nineties $
;
(import "rlvm-compile")
@@ -221,12 +221,12 @@
(var ModList (create_module std (to_sym "List")))
(add_function0 ModTbl (to_sym "new") table_new 0)
(add_function2 ModTbl (to_sym "new") funT funT table_new2 0)
- (add_function1 ModTbl (to_sym "from_list") listT list_to_table 0)
+ (add_function1 std (to_sym "to_table") listT list_to_table 0)
(add_function2 std (to_sym "at") tableT DontCare table_at 0)
(add_function3 std (to_sym "store") tableT DontCare DontCare table_store 0)
(add_function1 std (to_sym "size") tableT table_size 0)
- (add_function1 ModList (to_sym "from_table") tableT table_to_list 0)
+ (add_function1 std (to_sym "to_list") tableT table_to_list 0)
(add_function1 std (to_sym "keys") tableT table_keys 0)
(add_function1 std (to_sym "values") tableT table_values 0)
Please sign in to comment.
Something went wrong with that request. Please try again.