Skip to content
Browse files

Implemented RNG for given intervals.

  • Loading branch information...
1 parent d592c1b commit 10de8ad0c025609d3367831cbf9eb77764080c42 nineties committed Mar 16, 2013
Showing with 175 additions and 37 deletions.
  1. +9 −1 lib/amber/syntax.ab
  2. +3 −3 rowl1/Makefile
  3. +19 −5 rowl1/rowl1-bigint.rlc
  4. +19 −5 rowl1/rowl1-compile.rlc
  5. +3 −17 rowl1/rowl1-float.rlc
  6. +12 −1 rowl1/rowl1-node.rlc
  7. +35 −4 rowl1/rowl1-numeric.rlc
  8. +75 −1 rowl1/rowl1-random.rlc
View
10 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-14 20:36:48 nineties $
+# $Id: syntax.ab 2013-03-16 16:55:27 nineties $
# Syntax definition of the Amber language.
# This file will be loaded first.
@@ -248,6 +248,14 @@ shift_expr
range_expr
::= shift_expr ".." shift_expr { `Range{!node0, !node2} }
+ | "range" "[" shift_expr "," shift_expr "]"
+ { `Range{!node2, !node4} }
+ | "range" "(" shift_expr "," shift_expr ")"
+ { `Range{!node2, !node4, \Open} }
+ | "range" "(" shift_expr "," shift_expr "]"
+ { `Range{!node2, !node4, \LeftOpen} }
+ | "range" "[" shift_expr "," shift_expr ")"
+ { `Range{!node2, !node4, \RightOpen} }
| shift_expr
rel_expr
View
6 rowl1/Makefile
@@ -3,7 +3,7 @@
# Copyright (C) 2010 nineties
#
-# $Id: Makefile 2013-03-16 13:09:52 nineties $
+# $Id: Makefile 2013-03-16 17:27:33 nineties $
TOPDIR = ..
ROWL0DIR = $(TOPDIR)/rowl0
@@ -133,10 +133,10 @@ rowl1-matching.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.r
rowl1-error.rlo: $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo
rowl1-base.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo rowl1-error.rlo
rowl1-symbol.rlo: $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo
-rowl1-numeric.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo rowl1-error.rlo rowl1-module.rlo
+rowl1-numeric.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo rowl1-error.rlo rowl1-module.rlo rowl1-bigint.rlo rowl1-float.rlo
rowl1-bigint.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-compile.rlo
rowl1-float.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
-rowl1-random.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo rowl1-bigint.rlo rowl1-float.rlo
+rowl1-random.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo rowl1-numeric.rlo rowl1-bigint.rlo rowl1-float.rlo
rowl1-math.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-float.rlo rowl1-numeric.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
rowl1-string.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-error.rlo
rowl1-list.rlo : $(RLVMCOMPILER) rowl1-types.rlc rowl1-util.rlo rowl1-node.rlo rowl1-module.rlo rowl1-compile.rlo rowl1-assemble.rlo rowl1-error.rlo
View
24 rowl1/rowl1-bigint.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-bigint.rlc 2013-03-16 13:04:16 nineties $
+; $Id: rowl1-bigint.rlc 2013-03-16 22:29:35 nineties $
;
(import "rlvm-compile")
@@ -656,10 +656,24 @@
)
))
-(fun ib_coerce (a b) ((return (list2 (int_to_bint (unbox a)) b))))
-(fun bi_coerce (a b) ((return (list2 a (int_to_bint (unbox b))))))
-(fun fb_coerce (a b) ((return (list2 a (bint_to_f b)))))
-(fun bf_coerce (a b) ((return (list2 (bint_to_f a) b))))
+(export fun ib_coerce (a b) ((return (list2 (int_to_bint (unbox a)) b))))
+(export fun bi_coerce (a b) ((return (list2 a (int_to_bint (unbox b))))))
+(export fun fb_coerce (a b) ((return (list2 a (bint_to_f b)))))
+(export fun bf_coerce (a b) ((return (list2 (bint_to_f a) b))))
+
+; ==== utilities ===
+(export fun add (x y) (
+ (if (&& (& x 1) (& y 1)) (return (int_add2 x y)))
+ (return (bint_add x y))
+ ))
+(export fun sub (x y) (
+ (if (&& (& x 1) (& y 1)) (return (int_sub2 x y)))
+ (return (bint_sub x y))
+ ))
+(export fun mul (x y) (
+ (if (&& (& x 1) (& y 1)) (return (int_mul2 x y)))
+ (return (bint_mul x y))
+ ))
(extern fun float_infinity)
(extern fun float_uminus)
View
24 rowl1/rowl1-compile.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-compile.rlc 2013-03-13 23:08:17 nineties $
+; $Id: rowl1-compile.rlc 2013-03-16 17:36:32 nineties $
;
(import "rlvm-compile")
@@ -1319,10 +1319,24 @@
))
(fun compile_range (asm mod expr) (
- (compile asm mod (node_arg expr 1))
- (compile asm mod (node_arg expr 0))
- (put_push asm Range)
- (compile_simple_call asm 3 make_object2)
+ (var size (node_size expr))
+ (if (== size 2)
+ (do
+ (compile asm mod (node_arg expr 1))
+ (compile asm mod (node_arg expr 0))
+ (put_push asm Range)
+ (compile_simple_call asm 3 make_object2)
+ )
+ (if (== size 3)
+ (do
+ (compile asm mod (node_arg expr 2))
+ (compile asm mod (node_arg expr 1))
+ (compile asm mod (node_arg expr 0))
+ (put_push asm Range)
+ (compile_simple_call asm 4 make_object3)
+ )
+ (throw (unknown_expression current_loc expr))
+ ))
))
(fun compile_block_body (asm mod exprs) (
View
20 rowl1/rowl1-float.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-float.rlc 2013-03-16 15:29:13 nineties $
+; $Id: rowl1-float.rlc 2013-03-16 17:26:28 nineties $
;
(import "rlvm-compile")
@@ -27,20 +27,6 @@
(output_string ochan (float_to_s f))
))
-; ==== utilities ===
-(fun add (x y) (
- (if (&& (& x 1) (& y 1)) (return (int_add2 x y)))
- (return (bint_add x y))
- ))
-(fun sub (x y) (
- (if (&& (& x 1) (& y 1)) (return (int_sub2 x y)))
- (return (bint_sub x y))
- ))
-(fun mul (x y) (
- (if (&& (& x 1) (& y 1)) (return (int_mul2 x y)))
- (return (bint_mul x y))
- ))
-
(export fun float_sign (f) (
(if (< (field_get f 0) 0)
(return @TRUE)
@@ -514,8 +500,8 @@
(return v)
))
-(fun if_coerce (a b) ((return (list2 (itof (unbox a)) b))))
-(fun fi_coerce (a b) ((return (list2 a (itof (unbox b))))))
+(export fun if_coerce (a b) ((return (list2 (itof (unbox a)) b))))
+(export fun fi_coerce (a b) ((return (list2 a (itof (unbox b))))))
(export fun setup_float (std) (
(add_module_variable std (to_sym "infinity") @C_FALSE (float_infinity))
View
13 rowl1/rowl1-node.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-node.rlc 2013-03-13 01:38:08 nineties $
+; $Id: rowl1-node.rlc 2013-03-16 17:23:29 nineties $
;
(import "rlvm-compile")
@@ -519,6 +519,17 @@
(return e)
))
+(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)
+ ))
+
(extern fun list_to_tuple)
(extern fun list_to_ary)
(export fun make_object (head args) (
View
39 rowl1/rowl1-numeric.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-numeric.rlc 2013-03-05 01:34:37 nineties $
+; $Id: rowl1-numeric.rlc 2013-03-16 17:27:50 nineties $
;
(import "rlvm-compile")
@@ -15,27 +15,58 @@
(import "rowl1-util")
(import "rowl1-error")
(import "rowl1-module")
+(import "rowl1-bigint")
+(import "rowl1-float")
(extern object current_loc)
(extern object current_mod)
(var coerce (to_sym "coerce"))
(export fun do_coerce (a b) (
(var r (byterun (lookup_func current_mod coerce) a b))
- (if (== r @C_UNDEF) (do
- (throw (make_object4 Exception current_loc (string "Type coerce-rule is not found") a b))
- ))
+ (if (== r @C_UNDEF) (return r))
(if (|| (!= (node_type r) @ListE) (!= (list_len r) 2)) (do
(throw (exception current_loc (string "coerce must returns [a, b]")))
))
(return r)
))
+
(export fun binary_coerce (sym a b) (
(var r (do_coerce a b))
+ (if (== r @C_UNDEF)
+ (throw (make_object5 Exception current_loc
+ (string "Binary operation is not supported")
+ (make_object1 (to_sym "method") sym)
+ (make_object1 (to_sym "lhs") a)
+ (make_object1 (to_sym "rhs") b)
+ ))
+ )
(return (byterun (lookup_func current_mod sym) (car r) (cadr r)))
))
+(export fun do_coerce_internal (a b) (
+ (var lty (node_type a))
+ (var rty (node_type b))
+ (if (== lty rty) (return (list2 a b)))
+ (if (== lty @IntE)
+ (if (== rty @BigIntE) (return (ib_coerce a b))
+ (if (== rty @FloatE) (return (if_coerce a b))
+ (return @C_UNDEF)
+ ))
+ (if (== lty @BigIntE)
+ (if (== rty @IntE) (return (bi_coerce a b))
+ (if (== rty @FloatE) (return (bf_coerce a b))
+ (return @C_UNDEF)
+ ))
+ (if (== lty @FloatE)
+ (if (== rty @IntE) (return (fi_coerce a b))
+ (if (== rty @BigIntE) (return (fb_coerce a b))
+ (return @C_UNDEF)
+ )))))
+ (return @C_UNDEF)
+ ))
+
(fun num_add (a b) ((return (binary_coerce (to_sym "add") a b))))
(fun num_sub (a b) ((return (binary_coerce (to_sym "sub") a b))))
(fun num_mul (a b) ((return (binary_coerce (to_sym "mul") a b))))
View
76 rowl1/rowl1-random.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-random.rlc 2013-03-16 16:08:21 nineties $
+; $Id: rowl1-random.rlc 2013-03-16 23:09:10 nineties $
;
(import "rlvm-compile")
@@ -15,6 +15,7 @@
(import "rowl1-util")
(import "rowl1-error")
(import "rowl1-module")
+(import "rowl1-numeric")
(import "rowl1-bigint")
(import "rowl1-float")
@@ -43,9 +44,14 @@
seed))
))
+(var inv4294967295
+ (float_from_s "2.32830643708079738e-10")) ; 1.0/4294967295.0
(var inv4294967296
(float_from_s "2.32830643653869629e-10")) ; 1.0/4294967296.0
+(var half (float_from_s "0.5"))
+(var one (float_from_s "1.0"))
+; generate random number in [0,1)
(fun randf () (
(return (fmul (uitof (randui)) inv4294967296))
))
@@ -84,13 +90,81 @@
(return x)
))
+(fun randr_int (lopen ropen min max) (do
+ (if lopen (= min (add min (box 1))))
+ (if ropen (= max (sub max (box 1))))
+ (var width (add (sub max min) (box 1)))
+ (var v (call1 (to_sym "rand") width))
+ (return (add v min))
+ ))
+
+(fun randr_float (lopen ropen min max) (do
+ (var v (uitof (randui)))
+ (fsub max min)
+ (fmul v max)
+ (if lopen
+ (do
+ (if ropen
+ (fadd v half)
+ (fadd v one)
+ )
+ (fmul v inv4294967296)
+ (fadd v min)
+ )
+ (do
+ (if ropen
+ (fmul v inv4294967296)
+ (fmul v inv4294967295)
+ )
+ (fadd v min)
+ ))
+ (return v)
+ ))
+
+(fun randr (rng) (
+ (var size (node_size rng))
+ (if (|| (<= size 1) (<= 4 size)) (goto range_error))
+ (var min (node_arg rng 0))
+ (var max (node_arg rng 1))
+ (var lopen 0)
+ (var ropen 0)
+ (if (== size 3) (do
+ (var option (node_arg rng 2))
+ (if (== option (to_sym "Open")) (do (= lopen 1) (= ropen 1))
+ (if (== option (to_sym "LeftOpen")) (= lopen 1)
+ (if (== option (to_sym "RightOpen")) (= ropen 1)
+ (goto range_error)
+ )))
+ ))
+
+ (if (!= (node_bhead min) (node_bhead max)) (do
+ (var r (do_coerce_internal min max))
+ (if (== r @C_UNDEF) (goto range_error))
+ (= min (car r))
+ (= max (cadr r))
+ ))
+
+ (var ty (node_type min))
+ (if (|| (== ty @IntE) (== ty @BigIntE))
+ (return (randr_int lopen ropen min max))
+ (if (== ty @FloatE)
+ (return (randr_float lopen ropen min max))
+ ))
+
+ (label range_error)
+ (throw (invalid_argument current_loc
+ (string "Invalid range")
+ rng))
+ ))
+
(export fun setup_random (std) (
(srand0)
(add_function0 std (to_sym "srand") srand0 0)
(add_function1 std (to_sym "srand") (domainP Int) srandi 0)
(add_function0 std (to_sym "rand") randf 0)
(add_function1 std (to_sym "rand") intT randi 0)
(add_function1 std (to_sym "rand") bintT randbi 0)
+ (add_function1 std (to_sym "rand") (domainP Range) randr 0)
))
))

0 comments on commit 10de8ad

Please sign in to comment.
Something went wrong with that request. Please try again.