Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fixed bugs.

  • Loading branch information...
commit 91e5a5254707f2394becb3d93e18c9a91fd61d64 1 parent 2b04a30
nineties authored
View
12 lib/std/list.ab
@@ -1,13 +1,19 @@
# Copyright (C) 2012 nineties
#
-# $Id: list.ab 2013-02-15 16:56:26 nineties $
+# $Id: list.ab 2013-03-21 22:05:09 nineties $
module Std {
add(ls1@List, ls2@List): append(ls1, ls2)
- concat(ls@List): foldl(ls, [], append)
+ concat(ls@List): foldl(append, [], ls)
- concatMap(ls@List, fun@Function): concat(map(fun, ls))
+ index(ls@List, v): {
+ loop: ([], _) -> undef
+ | ([x,...], i) when x == v -> i
+ | ([_,xs...], i) -> loop(xs, i+1)
+
+ loop(ls, 0)
+ }
delete: ([], _) -> []
| ([v, vs...], x)
View
42 rowl1/rowl1-array.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-array.rlc 2013-03-21 19:57:33 nineties $
+; $Id: rowl1-array.rlc 2013-03-21 20:36:39 nineties $
;
(import "rlvm-compile")
@@ -204,6 +204,43 @@
(return (variant @ArrayE 1 new size size))
))
+(fun ary_map2 (f ary1 ary2) (
+ (var size1 (field_get ary1 2))
+ (var buf1 (field_get ary1 1))
+ (var size2 (field_get ary2 2))
+ (var buf2 (field_get ary2 1))
+ (var size size1)
+ (if (< size2 size) (= size size2))
+ (var code (get_bytecode f))
+ (var new (allocate_array size))
+ (for i 0 size (do
+ (array_set object new i (byterun code
+ (array_get object buf1 i)
+ (array_get object buf2 i)))
+ ))
+ (return (variant @ArrayE 1 new size size))
+ ))
+
+(fun ary_foldl (f v ary) (
+ (var buf (field_get ary 1))
+ (var size (field_get ary 2))
+ (var code (get_bytecode f))
+ (for i 0 size (do
+ (= v (byterun code v (array_get object buf i)))
+ ))
+ (return v)
+ ))
+
+(fun ary_foldr (f ary v) (
+ (var buf (field_get ary 1))
+ (var size (field_get ary 2))
+ (var code (get_bytecode f))
+ (rfor i 0 size (do
+ (= v (byterun code (array_get object buf i) v))
+ ))
+ (return v)
+ ))
+
(export fun setup_array (std) (
(var ModArray (create_module std (to_sym "Array")))
(var ModList (create_module std (to_sym "List")))
@@ -223,6 +260,9 @@
(add_function1 std (to_sym "reverse") arrayT ary_reverse 0)
(add_function2 std (to_sym "append") arrayT arrayT ary_append 0)
(add_function2 std (to_sym "map") funT arrayT ary_map 0)
+ (add_function3 std (to_sym "map2") funT arrayT arrayT ary_map2 0)
+ (add_function3 std (to_sym "foldl") funT DontCare arrayT ary_foldl 0)
+ (add_function3 std (to_sym "foldr") funT arrayT DontCare ary_foldr 0)
))
View
15 rowl1/rowl1-compile.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-compile.rlc 2013-03-19 17:22:33 nineties $
+; $Id: rowl1-compile.rlc 2013-03-23 22:42:24 nineties $
;
(import "rlvm-compile")
@@ -381,14 +381,14 @@
(return ret)
))
-(fun alloc_function (args code guard) (
- (return (variant @FunctionE 4 0 args code guard))
+(fun alloc_function (args code guard clos) (
+ (return (variant @FunctionE 5 0 args code guard clos))
))
(fun make_function (args code guard) (
(var arity (list_len args))
(= args (cons (box arity) args))
- (return (alloc_function args code guard))
+ (return (alloc_function args code guard 0))
))
(export fun bind_function (fun1 fun2) (
@@ -1929,12 +1929,7 @@
(var args (field_get lam 2))
(var body (field_get lam 3))
(var guard (field_get lam 4))
- (var asm (make_assembler))
- (put_push asm clos)
- (put_store_closure asm)
- (put_push asm body)
- (put_jjump asm)
- (return (alloc_function args (get_code asm) guard))
+ (return (alloc_function args body guard clos))
))
(fun compile_closure (asm mod expr) (
View
6 rowl1/rowl1-interp.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-interp.rlc 2013-03-17 22:58:07 nineties $
+; $Id: rowl1-interp.rlc 2013-03-21 03:07:39 nineties $
;
(import "rlvm-compile")
@@ -130,12 +130,12 @@
))
(fun eval (expr) (
- (return (byterun (lookup_func global Eval) expr))
+ (return (byterun (lookup_func current_mod Eval) expr))
))
(extern fun list_to_table)
(fun rewrite (expr) (
- (var new_expr (byterun (lookup_func global Rewrite) expr))
+ (var new_expr (byterun (lookup_func current_mod Rewrite) expr))
(if (== new_expr @C_UNDEF) (= new_expr expr))
(if (!= new_expr expr) (return (rewrite new_expr)))
(= expr new_expr)
View
74 rowl1/rowl1-list.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-list.rlc 2013-03-17 20:36:32 nineties $
+; $Id: rowl1-list.rlc 2013-03-21 20:34:14 nineties $
;
(import "rlvm-compile")
@@ -97,18 +97,7 @@
(return (list_reverse new_ls))
))
-(fun ls_map2 (f ls1 ls2) (
- (var new_ls 0)
- (var code (get_bytecode f))
- (while (&& ls1 ls2) (do
- (= new_ls (cons (byterun code (car ls1) (car ls2)) new_ls))
- (= ls1 (cdr ls1))
- (= ls2 (cdr ls2))
- ))
- (return (list_reverse new_ls))
- ))
-
-(fun ls_foldl (ls v f) (
+(fun ls_foldl (f v ls) (
(if (! ls) (return v))
(var code (get_bytecode f))
(while ls (do
@@ -123,56 +112,11 @@
(return (byterun code (car ls) (foldr (cdr ls) v code)))
))
-(fun ls_foldr (ls v f) (
+(fun ls_foldr (f ls v) (
(var code (get_bytecode f))
(return (foldr ls v code))
))
-(fun ls_foldl1 (ls f) (
- (if (! ls) (throw (invalid_argument current_loc
- (string "foldl1 requires non-empty list") ls)))
- (var code (get_bytecode f))
- (var v (car ls))
- (= ls (cdr ls))
- (while ls (do
- (= v (byterun code v (car ls)))
- (= ls (cdr ls))
- ))
- (return v)
- ))
-
-(fun foldr1 (ls code) (
- (if (! (cdr ls)) (return (car ls)))
- (return (byterun code (car ls) (foldr1 (cdr ls) code)))
- ))
-
-(fun ls_foldr1 (ls f) (
- (if (! ls) (throw (invalid_argument current_loc
- (string "foldr1 requires non-empty list") ls)))
- (var code (get_bytecode f))
- (return (foldr1 ls code))
- ))
-
-(fun ls_contain (ls v) (
- (var f (lookup_func current_mod (to_sym "equal")))
- (while ls (do
- (if (== (byterun f v (car ls)) @C_TRUE) (return @C_TRUE))
- (= ls (cdr ls))
- ))
- (return @C_FALSE)
- ))
-
-(fun ls_index (ls v) (
- (var f (lookup_func current_mod (to_sym "equal")))
- (var idx 0)
- (while ls (do
- (if (== (byterun f v (car ls)) @C_TRUE) (return (box idx)))
- (= ls (cdr ls))
- (+= idx 1)
- ))
- (return @C_UNDEF)
- ))
-
(extern fun tuple2)
(extern fun tuple_at)
(fun ls_zip (a b) (
@@ -233,16 +177,8 @@
(add_function1 std (to_sym "reverse") listT ls_reverse 0)
(add_function2 std (to_sym "append") listT listT ls_append 0)
(add_function2 std (to_sym "map") funT listT ls_map 0)
- (add_function3 std (to_sym "map2") funT listT listT ls_map2 0)
- (add_function3 std (to_sym "foldl") listT DontCare funT ls_foldl 0)
- (add_function3 std (to_sym "foldr") listT DontCare funT ls_foldr 0)
- (add_function2 std (to_sym "foldl1") listT funT ls_foldl1 0)
- (add_function2 std (to_sym "foldr1") listT funT ls_foldr1 0)
- (add_function2 std (to_sym "contain") listT DontCare ls_contain 0)
- (add_function2 std (to_sym "index") listT DontCare ls_index 0)
- (add_function2 std (to_sym "zip") listT listT ls_zip 0)
- (add_function1 std (to_sym "unzip") listT ls_unzip 0)
- (add_function1 std (to_sym "flatten") listT ls_flatten 0)
+ (add_function3 std (to_sym "foldl") funT DontCare listT ls_foldl 0)
+ (add_function3 std (to_sym "foldr") funT listT DontCare ls_foldr 0)
))
))
View
18 rowl1/rowl1-matching.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-matching.rlc 2013-03-18 21:21:05 nineties $
+; $Id: rowl1-matching.rlc 2013-03-23 22:38:07 nineties $
;
(import "rlvm-compile")
@@ -148,11 +148,12 @@
))
(fun construct_row (len def) (
- (var args (field_get def 2))
- (var code (field_get def 3))
+ (var args (field_get def 2))
+ (var code (field_get def 3))
(var guard (field_get def 4))
+ (var clos (field_get def 5))
(= args (setup_args len args))
- (return (list3 args code guard))
+ (return (list4 args code guard clos))
))
(fun setup_args (len args) (
@@ -270,10 +271,15 @@
(var func (car pats))
(var code (list_at func 1))
(var guard (list_at func 2))
+ (var clos (list_at func 3))
(if guard
(do
(var guard_failed (fresh_label asm))
+ (if clos (do
+ (put_push asm clos)
+ (put_store_closure asm)
+ ))
(put_code asm guard)
(put_if_false asm guard_failed)
(put_push asm code)
@@ -285,6 +291,10 @@
))
)
(do
+ (if clos (do
+ (put_push asm clos)
+ (put_store_closure asm)
+ ))
(put_push asm code)
(put_jjump asm)
return
View
6 rowl1/rowl1-util.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-util.rlc 2013-03-19 21:43:32 nineties $
+; $Id: rowl1-util.rlc 2013-03-20 02:14:57 nineties $
;
(import "rlvm-compile")
@@ -12,6 +12,7 @@
(compile `object `(
(export fun output_char_escape (ochan t) (
+ (if (== t '"') (return (output_string ochan "\\\"")))
(if @(PRINTABLE t) (return (output_char ochan t)))
(if (== t '\\') (do (output_char ochan '\\') (output_char ochan '\\'))
(if (== t '\a') (output_string ochan "\\a")
@@ -22,12 +23,11 @@
(if (== t '\t') (output_string ochan "\\t")
(if (== t '\v') (output_string ochan "\\v")
(if (== t '\0') (output_string ochan "\\0")
- (if (== t '"') (output_string ochan "\\\"")
(do
(output_string ochan "\\x")
(output_hex ochan t 2)
)
- ))))))))))
+ )))))))))
))
(export fun output_string_escape (ochan str) (
Please sign in to comment.
Something went wrong with that request. Please try again.