Permalink
Browse files

Working snapshot (Refinment of module system)

  • Loading branch information...
1 parent 128fc3e commit 6f6531d61a094623ea16e8ea37c7663d076f9d61 nineties committed Mar 4, 2013
View
10 demo/lang/hyperlisp/lib/lambda.ab
@@ -1,6 +1,6 @@
# Copyright (C) 2012 nineties
#
-# $Id: hyperlisp/symbol.ab 2013-02-13 00:25:18 nineties $
+# $Id: hyperlisp/symbol.ab 2013-03-05 04:50:21 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -191,7 +191,7 @@ module HyperLisp {
# compile lambda-abstraction as a native function of Amber.
compile_lambda_jit(x):
- amber::compile(`Lambda{x, !compile_eval(params(x), body(x))})
+ Amber::compile(`Lambda{x, !compile_eval(params(x), body(x))})
# compile label-expression as a sexp.
compile_label(x):
@@ -214,15 +214,15 @@ module HyperLisp {
lam: replace_label(name, params(x), body(x))
fun : compile_eval(params(lam), body(lam))
# register compiled function to the function table.
- function[name] = amber::compile(`Lambda{x, !fun})
+ function[name] = Amber::compile(`Lambda{x, !fun})
## Function definition
# The symbol '#' is used for start symbol of comments in
# Amber's default syntax.
hl_comment ::= C_style_comment
- hl_expr ::= [multiline]
+ hl_expr ::= <<multiline>>
"#" hl_literal hl_simple_expr "=" hl_expr ";"
{ cons_list([\Meta{Delta}, $1,
cons_list([\Meta{Lambda}, $2, $4])]) }
@@ -232,7 +232,7 @@ module HyperLisp {
sym: x.cdr.car
lam: x.cdr.cdr.car
fun: compile_lambda_jit(lam)
- amber::define_global_variable(rename(sym), fun)
+ Amber::define_global_variable(rename(sym), fun)
sym
}
eval_(x) when x.car == \Meta{Delta}: eval_define(x)
View
6 demo/lang/hyperlisp/lib/syntax.ab
@@ -1,6 +1,6 @@
# Copyright (C) 2012 nineties
#
-# $Id: hyperlisp/syntax.ab 2013-02-12 17:33:06 nineties $
+# $Id: hyperlisp/syntax.ab 2013-03-05 04:49:02 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -27,9 +27,9 @@ module HyperLisp {
hl_secondary_expr
::= hl_secondary_expr "(" delimited(hl_expr, [,;]) ")"
- { cons_list(std::cons($0, $2)) }
+ { cons_list(Std::cons($0, $2)) }
| hl_secondary_expr "[" delimited(hl_expr, [,;]) "]"
- { snoc_list(std::cons($0, $2)) }
+ { snoc_list(Std::cons($0, $2)) }
| hl_primary_expr
hl_expr
View
2 demo/nbody/nbody-lib.ab
@@ -5,7 +5,7 @@ nbody_simulation_default_setting: [
("output", nil)
]
-statement ::= [multiline]
+statement ::= <<multiline>>
"Nbody_simulation" "{"
aligned(nbody_simulation_component)
"}"
View
113 lib/amber/syntax.ab
@@ -1,8 +1,10 @@
-ReplaceSyntax{comment, shell_style_comment}
+BeginModule{Parser}
+
+Assign{comment, shell_style_comment}
# Copyright (C) 2010 nineties
#
-# $Id: syntax.ab 2013-02-19 21:33:42 nineties $
+# $Id: syntax.ab 2013-03-05 05:40:41 nineties $
# Syntax definition of the Amber language.
# This file will be loaded first.
@@ -30,10 +32,8 @@ ReplaceSyntax{comment, shell_style_comment}
# delimited1(p, d) : sequence of p delimited by d (one or many)
# delimited2(p, d) : sequence of p delimited by d (two or many)
# located(p) : parse p with location
-# scoped(m, p) : parse p within module m
# parsewith(p) : do parse using p (p can refer previous tokens)
# nospace(p) : parse p without parsing spaces between tokens
-# withblank(p) : parse p with more than one banks between tokens
DefineSyntax{
character_set,
@@ -82,48 +82,33 @@ DefineSyntax{
QuasiQuote{Delimited2{Unquote{node2}, Unquote{node4}}}, multiline},
Tuple{List{"located", "(", syntax_element, ")"},
QuasiQuote{Located{Unquote{node2}}}, multiline},
- Tuple{List{"scoped", "(", expr, ",", syntax_element, ")"},
- QuasiQuote{Scoped{Unquote{node2}, Unquote{node4}}}, multiline},
Tuple{List{"parsewith", "(", symbol, ")"},
QuasiQuote{ParseWith{Unquote{node2}}}, multiline},
Tuple{List{"nospace", "(", syntax_element, ")"},
QuasiQuote{NoSpace{Unquote{node2}}}, multiline},
Tuple{List{"nospace", "(", Many1{syntax_element}, ")"},
QuasiQuote{NoSpace{Unquote{node2}}}, multiline},
- Tuple{List{"withblank", "(", syntax_element, ")"},
- QuasiQuote{WithBlank{Unquote{node2}}}, multiline},
- Tuple{List{"withblank", "(", Many1{syntax_element}, ")"},
- QuasiQuote{WithBlank{Unquote{node2}}}, multiline},
Tuple{List{primary_syntax_element}, node0}
}
}
DefineSyntax{
parser_option,
List{
- Tuple{List{"[", Many1{symbol}, "]"},
+ Tuple{List{"<<", Many1{Choice{object,symbol}}, ">>"},
node1, multiline}
}
}
-BeginModule{parser}
-EndModule{}
-
-DefineSyntax{
- parser_action_body,
- List{
- Tuple{List{"{", Aligned{statement}, "}"},
- QuasiQuote{Block{Unquote{node1}}}, multiline}
- }
-}
-
DefineSyntax{
parser_action,
- List{Tuple{List{Scoped{Quote{parser}, parser_action_body}}, node0}}
+ List{Tuple{List{"{", Aligned{statement}, "}"},
+ QuasiQuote{Block{Unquote{node1}}}, multiline}
+ }
}
DefineSyntax{
- syntax,
+ parser_entry,
List{
Tuple{List{parser_option, Many1{syntax_element}, parser_action},
QuasiQuote{Tuple{Unquote{node1}, Unquote{node2}, Unquote{node0}}}
@@ -132,7 +117,7 @@ DefineSyntax{
QuasiQuote{Tuple{Unquote{node0}, Unquote{node1}}}
},
Tuple{List{parser_option, syntax_element},
- QuasiQuote{Tuple{Unquote{List{node1}}, node0, Unquote{node0}}}
+ QuasiQuote{Tuple{Unquote{List{node1}}, node1, Unquote{node0}}}
},
Tuple{List{syntax_element},
QuasiQuote{Tuple{Unquote{List{node0}}, node0}}
@@ -143,7 +128,7 @@ DefineSyntax{
DefineSyntax{
syntax_declaration,
List{
- Tuple{List{symbol, "::=", Delimited1{syntax, "|"}},
+ Tuple{List{symbol, "::=", Delimited1{parser_entry, "|"}},
QuasiQuote{DefineSyntax{
Unquote{node0},
Unquote{node2}
@@ -157,7 +142,7 @@ DefineSyntax{
List{Tuple{List{syntax_declaration}, node0}}
}
-## Expressions
+### Expressions
qualified_symbol
::= qualified_symbol "::" symbol
{ MakeObject{Quote{Qualified}, List{node0, node2}} }
@@ -166,10 +151,10 @@ qualified_symbol
block_body ::= aligned(located(statement))
{ QuasiQuote{Block{Unquote{node0}}} }
primary_block
- ::= [multiline] "{" block_body "}" { node1 }
+ ::= <<multiline>> "{" block_body "}" { node1 }
# Block with module imports
- | [multiline] "seq" "{" aligned(located(statement)) "}"
+ | <<multiline>> "seq" "{" aligned(located(statement)) "}"
{ MakeObject{Quote{Seq}, List{node2}} }
block ::= primary_block
@@ -178,15 +163,15 @@ block ::= primary_block
primary_expr
::= primary_block
- | [multiline] "<" qualified_symbol ">" "{" parsewith(node1) "}"
+ | <<multiline>> "<" qualified_symbol ">" "{" parsewith(node1) "}"
{ node4 }
- | [multiline] "(" expr ")" { node1 }
- | [multiline] "(" statement ")" { node1 }
- | [multiline] "[" delimited(expr, ",") "]" { node1 } # List literal
+ | <<multiline>> "(" expr ")" { node1 }
+ | <<multiline>> "(" statement ")" { node1 }
+ | <<multiline>> "[" delimited(expr, ",") "]" { node1 } # List literal
# Tuple literal
- | [multiline] "(" delimited2(expr, ",") ")"
+ | <<multiline>> "(" delimited2(expr, ",") ")"
{ MakeObject{Quote{Tuple}, node1} }
| qualified_symbol
@@ -218,7 +203,7 @@ postfix_expr
| primary_expr "^" postfix_expr
{ MakeObject{Quote{Power}, List{node0, node2}} }
- | node
+ | object
| primary_expr
@@ -234,15 +219,15 @@ quote_expr
pattern ::= quote_expr
term ::= primary_expr
-# enable use of quotation expressions for following definitions.
-ReplaceSyntax{expr, quote_expr}
+## enable use of quotation expressions for following definitions.
+Assign{expr, quote_expr}
prefix_expr
::= "+" quote_expr { `UnaryPlus{!node1} }
| "-" !decimal quote_expr { `UnaryMinus{!node2} }
| "not" quote_expr { `Not{!node1} }
- | [multiline] "make" symbol "{" delimited(expr, ",") "}"
+ | <<multiline>> "make" symbol "{" delimited(expr, ",") "}"
{ `MakeObject{\!node1, !node3} }
| quote_expr
@@ -293,7 +278,7 @@ ternary_expr
guard_expr ::= ternary_expr
-arguments
+argument_list
::= "(" delimited(pattern, ",") ")" "when" guard_expr
{ `When{!node1, !node4} }
| "(" delimited(pattern, ",") ")"
@@ -304,7 +289,7 @@ arguments
{ List{node1} }
lambda_expr
- ::= arguments "->" block
+ ::= argument_list "->" block
{ `Lambda{!node0, !node2} }
| ternary_expr
@@ -325,7 +310,7 @@ assign_expr
| pattern ">>=" assign_expr { `ShiftRAssign{!node0, !node2} }
| multi_lambda_expr
-ReplaceSyntax{expr, assign_expr}
+Assign{expr, assign_expr}
### Statements
package ::= string
@@ -343,19 +328,19 @@ statement
| "import" package
{ `Import{!node1} }
- | [multiline] "if" term statement "else" statement
+ | <<multiline>> "if" term statement "else" statement
{ `IfElse{!node1, !node2, !node4} }
- | [multiline] "if" term statement
+ | <<multiline>> "if" term statement
{ `If{!node1, !node2} }
- | [multiline] "case" term "of" multi_lambda_expr
+ | <<multiline>> "case" term "of" multi_lambda_expr
{ `Apply{!node3, [!node1]} }
- | [multiline] "while" term block
+ | <<multiline>> "while" term block
{ `While{!node1, !node2} }
- | [multiline] "for" "(" pattern "in" expr ")" block
+ | <<multiline>> "for" "(" pattern "in" expr ")" block
{ `For{!node2, !node4, !node6} }
- | [multiline] "reverse_for" "(" pattern "in" expr ")" block
+ | <<multiline>> "reverse_for" "(" pattern "in" expr ")" block
{ `RevFor{!node2, !node4, !node6} }
| "continue"
{ `Continue{} }
@@ -369,23 +354,25 @@ statement
| "throw" expr
{ `Throw{!node1} }
- | [multiline] "try" block "catch" multi_lambda_expr
+ | <<multiline>> "try" block "catch" multi_lambda_expr
{ `Try{!node1, !node3} }
- | symbol arguments ":" block
+ | symbol argument_list ":" block
{ `DefineFunction{!node0, Lambda{!node1, !node3}} }
| pattern ":" expr
{ `DefineVariable{!node0, !node2} }
| expr "=>" statement
{ `DefineFunction{rewrite, Lambda{!node0, !node2}} }
-## Reserved Keywords
+### 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
}
+EndModule{} # Parser
+
## Syntax Sugars
+x => `uplus(!x)
-x => `uminus(!x)
@@ -413,15 +400,31 @@ 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]))}
+x[args...] => `Apply{at, !Std::cons(x, args)}
+x[args...] = e => `Apply{store, !Std::cons(x, Std::append(args, [e]))}
-module parser {
+module Parser {
+ ### Extend primary_expr so as to enable use $... to refer nodes
+ # of syntax-tree only in parser_action.
+ module Action {
primary_expr ::= "$" decimal { ("node" + node1).to_sym }
| "$input" { \input_text(parser,begin,end) }
-}
+ }
-module shell_syntax {
+ # FIXME: This is temporary dirty hack.
+ primary_expr_act : primary_expr | Action::primary_expr
+ parser_action_old: parser_action
+ parser_action = parser -> {
+ save_primary_expr: primary_expr
+ primary_expr = primary_expr_act
+ r: parser_action_old(parser)
+ primary_expr = save_primary_expr
+ r
+ }
+
+ ### Syntax definitions which are effective only in shell-mode.
+ module Shell {
primary_expr ::= "%" nospace(decimal) { `shell_outputs[!$1] }
| "%" { `shell_outputs[0] }
+ }
}
View
2 lib/data/array.ab
@@ -2,7 +2,7 @@
#
# $Id: array.ab 2012-12-16 01:53:20 nineties $
-module std {
+module Std {
each(ary@Array): {
i: 0
n: ary.size
View
6 lib/data/bitable.ab
@@ -1,8 +1,8 @@
# Copyright (C) 2012 nineties
#
-# $Id: table.ab 2013-01-25 03:48:37 nineties $
+# $Id: table.ab 2013-03-05 04:45:03 nineties $
-module std {
+module Std {
module BiTable {
new(): `BiTable {!Table::new(), !Table::new()}
@@ -49,6 +49,6 @@ module std {
bitable_entry ::= expr "<=>" expr { ($0, $2) }
postfix_expr
- ::= [multiline] "BiTable" "{" delimited(bitable_entry, ",") "}"
+ ::= <<multiline>> "BiTable" "{" delimited(bitable_entry, ",") "}"
{ `BiTable::from_list(!$2) }
}
View
2 lib/data/list.ab
@@ -2,7 +2,7 @@
#
# $Id: list.ab 2013-02-15 16:56:26 nineties $
-module std {
+module Std {
add(ls1@List, ls2@List): append(ls1, ls2)
concat(ls@List): foldl(ls, [], append)
View
2 lib/data/set.ab
@@ -4,7 +4,7 @@
# XXX: Temporary implementation (not fast)
-module std {
+module Std {
struct Set {
elems: []
}
View
2 lib/data/string.ab
@@ -2,7 +2,7 @@
#
# $Id: string.ab 2012-12-08 13:04:16 nineties $
-module std {
+module Std {
each(str@String): {
i: 0
n: str.size
View
14 lib/data/table.ab
@@ -1,12 +1,14 @@
# Copyright (C) 2012 nineties
#
-# $Id: table.ab 2013-01-25 05:17:04 nineties $
+# $Id: table.ab 2013-03-05 04:44:39 nineties $
-module std {
- table_entry ::= expr "=>" expr { ($0, $2) }
- postfix_expr
- ::= [multiline] "Table" "{" delimited(table_entry, ",") "}"
- { `Table::from_list(!$2) }
+module Std {
+ module Parser {
+ table_entry ::= expr "=>" expr { ($0, $2) }
+ postfix_expr
+ ::= <<multiline>> "Table" "{" delimited(table_entry, ",") "}"
+ { `Table::from_list(!$2) }
+ }
each(tbl@Table): tbl.entries.each
reverse_each(tbl@Table): tbl.entries.reverse_each
View
2 lib/dev/HIL.ab
@@ -7,7 +7,7 @@
module HIL {
# syntax definitions
- statement ::= [multiline]
+ statement ::= <<multiline>>
"compile" "(" expr "," string ")" "{"
aligned(HIL_statement)
"}"
View
2 lib/dev/HIL/vector.ab
@@ -4,7 +4,7 @@
# Vector arithmetic for HIL
module HIL {
- postfix_expr ::= [multiline] "Vector" "[" delimited(expr, ",") "]"
+ postfix_expr ::= <<multiline>> "Vector" "[" delimited(expr, ",") "]"
{ MakeObject{\Vector, $2} }
copyprop(sbst, Vector{values...}):
View
12 lib/dev/binio.ab
@@ -1,6 +1,6 @@
# Copyright (C) 2012 nineties
#
-# $Id: binio.ab 2013-02-06 13:46:39 nineties $
+# $Id: binio.ab 2013-03-05 07:00:15 nineties $
### Definition ###
#
@@ -31,7 +31,7 @@
# foo.write(io, data)
#
-open bigint
+open BigInt
module binio {
module impl {
@@ -196,13 +196,13 @@ binio_field
::= symbol ":" binio_type { ($0, $2) }
binio_fields
- ::= [multiline] "{" delimited(binio_field, ",") "}" { $1 }
- | [multiline] "{" aligned(binio_field) "}" { $1 }
+ ::= <<multiline>> "{" delimited(binio_field, ",") "}" { $1 }
+ | <<multiline>> "{" aligned(binio_field) "}" { $1 }
binio_definition
- ::= [multiline] "binio" symbol binio_fields
+ ::= <<multiline>> "binio" symbol binio_fields
{ `DefineVariable{!$1, binio::make_binio(\!$1, \!$2)} }
- | [multiline] "binio" qualified_symbol binio_fields
+ | <<multiline>> "binio" qualified_symbol binio_fields
{ `DefineVariable{!$1, binio::make_binio(\!$1[1], \!$2)} }
statement ::= binio_definition
View
2 lib/io.ab
@@ -2,7 +2,7 @@
#
# $Id: io.ab 2013-02-09 22:32:31 nineties $
-module std::IO {
+module Std::IO {
### Basic IO functions
print(obj): print(stdout, obj)
View
20 lib/oop.ab
@@ -1,19 +1,21 @@
# Copyright (C) 2013 nineties
#
-# $Id: oop.ab 2013-02-15 16:57:38 nineties $
+# $Id: oop.ab 2013-03-05 05:41:52 nineties $
# Prototype-based Object-Oriented Programming
-module std {
- object_slot ::= symbol ":" expr { ($0, $2) }
- object_slots
- ::= [multiline] "{" delimited(object_slot, ",") "}" { $1 }
- | [multiline] "{" aligned(object_slot) "}" { $1 }
+module Std {
+ module Parser {
+ object_slot ::= symbol ":" expr { ($0, $2) }
+ object_slots
+ ::= <<multiline>> "{" delimited(object_slot, ",") "}" { $1 }
+ | <<multiline>> "{" aligned(object_slot) "}" { $1 }
- object_creation
- ::= [multiline] "make" symbol object_slots { `MakeSlots{!$1, !$2} }
+ object_creation
+ ::= <<multiline>> "make" symbol object_slots { `MakeSlots{!$1, !$2} }
- prefix_expr ::= object_creation
+ prefix_expr ::= object_creation
+ }
MakeSlots{head, fields} => {
obj: gensym()
View
63 lib/printf.ab
@@ -1,37 +1,24 @@
# Copyright (C) 2010 nineties
#
-# $Id: printf.ab 2013-02-15 16:56:46 nineties $
+# $Id: printf.ab 2013-03-05 01:05:50 nineties $
-module std {
- ### Format string
- # XXX: Not good implementation (should not define new syntax)
-
- format_string_element
- ::= "%" [sSdXobpf] { $input }
- | "%" . { throw `SyntaxError{!LOCATION,
- "Invalid format string", !($0 + $1)}
- }
- | nospace( [^%\""]+ ) { $input.unescape }
-
- format_string
- ::= nospace( ('"' format_string_element* '"') ) { $0[1] }
-
- module printf {
+module Std {
+ module Printf {
compile_printf(io, fmt, args):
loop: ([], [], ls)
- -> `Block{!std::reverse(ls)}
+ -> `Block{!Std::reverse(ls)}
| (["%s", fs...], [s, ss...], ls)
- -> loop(fs, ss, std::cons(`print(!io, !s), ls))
+ -> loop(fs, ss, Std::cons(`print(!io, !s), ls))
| (["%S", fs...], [s, ss...], ls)
- -> loop(fs, ss, std::cons(`print(!io, !s), ls))
+ -> loop(fs, ss, Std::cons(`print(!io, !s), ls))
| (["%d", fs...], [s, ss...], ls)
- -> loop(fs, ss, std::cons(`print(!io, !s), ls))
+ -> loop(fs, ss, Std::cons(`print(!io, !s), ls))
| (["%f", fs...], [s, ss...], ls)
- -> loop(fs, ss, std::cons(`pprint(!io, !s), ls))
+ -> loop(fs, ss, Std::cons(`pprint(!io, !s), ls))
| (["%p", fs...], [s, ss...], ls)
- -> loop(fs, ss, std::cons(`pprint(!io, !s), ls))
+ -> loop(fs, ss, Std::cons(`pprint(!io, !s), ls))
| ([f@String, fs...], args, ls)
- -> loop(fs, args, std::cons(`print(!io, !f), ls))
+ -> loop(fs, args, Std::cons(`print(!io, !f), ls))
| ([f, ...], _, _)
-> throw `Error{!LOCATION, !("argument for " + f.to_s + " is not found")}
loop(fmt, args, [])
@@ -43,12 +30,28 @@ module std {
io.to_s
}
}
+
+ module Parser {
+ ### Format string
+ # XXX: Not good implementation (should not define new syntax)
+
+ format_string_element
+ ::= "%" [sSdXobpf] { $input }
+ | "%" . { throw `SyntaxError{!LOCATION,
+ "Invalid format string", !($0 + $1)}
+ }
+ | nospace( [^%\""]+ ) { $input.unescape }
+
+ format_string
+ ::= nospace( ('"' format_string_element* '"') ) { $0[1] }
+
+ postfix_expr
+ ::= "printf" "(" format_string ("," expr)* ")"
+ { Printf::compile_printf(\stdout, $2, map(x->x[1], $3)) }
+ | "printf" "(" expr "," format_string ("," expr)* ")"
+ { Printf::compile_printf($2, $4, map(x->x[1], $5)) }
+ | "format" "(" format_string ("," expr)* ")"
+ { Printf::compile_format($2, map(x->x[1], $3))}
+ }
- postfix_expr
- ::= "printf" "(" format_string ("," expr)* ")"
- { printf::compile_printf(\stdout, $2, map(x->x[1], $3)) }
- | "printf" "(" expr "," format_string ("," expr)* ")"
- { printf::compile_printf($2, $4, map(x->x[1], $5)) }
- | "format" "(" format_string ("," expr)* ")"
- { printf::compile_format($2, map(x->x[1], $3))}
}
View
15 lib/unittest.ab
@@ -1,6 +1,6 @@
# Copyright (C) 2012 nineties
#
-# $Id: unittest.ab 2012-12-13 22:14:09 nineties $
+# $Id: UnitTest.ab 2013-03-05 04:32:29 nineties $
#USAGE :
#
@@ -10,12 +10,13 @@
# }
# }
-statement
- ::= "test" string block { `UnitTestTarget{!$1, !$2} }
- | string ":" test_code { `UnitTestItem{!$0, !$2} }
-ReserveSymbol{test}
-
-test_code ::= expr
+module Parser {
+ statement
+ ::= "test" string block { `UnitTestTarget{!$1, !$2} }
+ | string ":" test_code { `UnitTestItem{!$0, !$2} }
+ ReserveSymbol{test}
+ test_code ::= expr
+}
UnitTestTarget{target, tests} => `{
printf("=== tests of %s ===\n\n", !target)
View
4 rowl1/rlvm-compile.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rlvm-compile.rlc 2013-02-08 10:07:53 nineties $
+; $Id: rlvm-compile.rlc 2013-02-28 21:29:27 nineties $
;
(import "stdlib")
@@ -526,7 +526,7 @@
(pop_exit_label)
))
-; rfor v high low body
+; rfor v low high body
;
; is equal to
;
View
6 rowl1/rowl1-array.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-array.rlc 2013-02-10 12:26:49 nineties $
+; $Id: rowl1-array.rlc 2013-02-23 14:38:05 nineties $
;
(import "rlvm-compile")
@@ -155,8 +155,8 @@
))
(export fun setup_array (std) (
- (var ModArray (find_module no_loc std (to_sym "Array") @TRUE))
- (var ModList (find_module no_loc std (to_sym "List") @TRUE))
+ (var ModArray (create_module std (to_sym "Array")))
+ (var ModList (create_module std (to_sym "List")))
(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)
View
4 rowl1/rowl1-bigint.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-bigint.rlc 2013-02-14 05:58:23 nineties $
+; $Id: rowl1-bigint.rlc 2013-03-05 01:12:44 nineties $
;
(import "rlvm-compile")
@@ -654,7 +654,7 @@
(extern fun float_uminus)
(export fun setup_bigint (std) (
- (var mod (find_module no_loc std (to_sym "bigint") @TRUE))
+ (var mod (create_module std (to_sym "BigInt")))
(add_module_variable mod (to_sym "INTEGER_MIN") @C_FALSE (float_uminus (float_infinity)))
(add_module_variable mod (to_sym "INTEGER_MAX") @C_FALSE (float_infinity))
View
222 rowl1/rowl1-compile.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-compile.rlc 2013-02-20 16:57:12 nineties $
+; $Id: rowl1-compile.rlc 2013-03-05 06:09:14 nineties $
;
(import "rlvm-compile")
@@ -20,7 +20,6 @@
(var AllocClsEnv (to_sym "%AllocClosureEnv"))
(var Ref (to_sym "%Ref"))
(var Decons (to_sym "%Decons"))
-(var uninitialized (to_sym "%uninitialized"))
(var noguard (to_sym "%noguard"))
(var closed (to_sym "%closed"))
@@ -49,13 +48,6 @@
(return @C_NIL)
))
-(export fun callable (expr) (
- (var ty (node_type expr))
- (if (== ty @FunctionE) (return @TRUE)
- (if (== ty @BoundFunctionE) (return @TRUE)
- (return @FALSE)))
- ))
-
(fun iter_args (f node arg level) (
(if (is_special node) (return arg))
(if (is_symbol node)
@@ -107,7 +99,7 @@
(if (is_special expr) (return fv))
(if (== expr DontCare) (return fv))
(= fv (list_delete expr fv))
- (var info (lookup_symbol mod expr))
+ (var info (lookup_symbol mod expr @FALSE))
; module-variables and special symbols are not free.
(if (== (node_bhead info) ModuleVariable) (return fv))
(return (cons expr fv))
@@ -139,9 +131,6 @@
(if (|| (== hd Block) (== hd Breakable))
(return (fv_iter_block mod (node_arg_list expr 0) fv))
)
- (if (== hd Dynamic)
- (return fv)
- )
))
(if (== hd Quote) (return fv))
(if (== hd QuasiQuote) (+= level 1)
@@ -300,9 +289,6 @@
(node_arg_set expr 0 (alpha_qquote tbl (node_arg expr 0) 0))
(return expr)
))
- (if (== hd Dynamic)
- (return expr)
- )
(for i 0 (node_size expr)
(node_arg_set expr i (alpha tbl (node_arg expr i)))
)
@@ -346,14 +332,25 @@
(return (alloc_function args code guard))
))
-(export fun fusion_function (fun1 fun2) (
- (if (! (callable fun1))
+(export fun bind_function (fun1 fun2) (
+ (if (! (is_function fun1))
(throw (type_error current_loc (string "function") fun1))
)
- (if (! (callable fun2))
+ (if (! (is_function fun2))
(throw (type_error current_loc (string "function") fun2))
)
- (return (variant @BoundFunctionE 3 0 fun1 fun2))
+
+ (if (== (node_type fun1) @DelegateFunctionE)
+ (throw (string "BUG (bind_function): Invalid argument type"))
+ )
+ (if (== (node_type fun2) @DelegateFunctionE)
+ (do
+ (field_set fun2 1 0) ; clear cache
+ (field_set fun2 2 (bind_function fun1 (field_get fun2 2)))
+ (return fun2)
+ )
+ (return (variant @BoundFunctionE 3 0 fun1 fun2))
+ )
))
(var maybe (to_sym "maybe"))
@@ -405,7 +402,6 @@
(if (== hd Closure) (return expr))
(if (== hd Ref) (return expr))
(if (== hd Quote) (return expr))
- (if (== hd Dynamic) (return expr))
(if (== hd QuasiQuote) (do
(node_arg_set expr 0
(scan_clsvars_qquote mod (node_arg expr 0) tbl 0))
@@ -506,8 +502,6 @@
(node_arg_set expr 0 (subst_clsvars_qquote tbl cls (node_arg expr 0) 0))
(return expr)
))
- ; The binding of a dynamic variable is resolved at run-time.
- (if (== hd Dynamic) (return expr))
(for i 0 (node_size expr)
(node_arg_set expr i (subst_clsvars tbl cls (node_arg expr i)))
)
@@ -536,15 +530,14 @@
(extern fun compile_matching)
(export fun lookup_func (mod sym) (
- (var def (lookup_symbol mod sym))
- (if (! def)
+ (var def (lookup_symbol mod sym @FALSE))
+ (if (! def) (do
(throw (undefined_fun current_loc sym))
- )
- (must_be_module_variable sym def)
+ ))
(check_init sym def)
(var box (node_arg def 0))
(var func (field_get box 0))
- (if (! (callable func))
+ (if (! (is_function func))
(throw (type_error current_loc (string "function") func))
)
(var loc (field_get box 1))
@@ -619,7 +612,7 @@
(fun compile_qualified (asm mod expr) (
(var modsig (node_arg expr 0))
- (var module (find_module current_loc mod modsig @FALSE))
+ (var module (find_module mod modsig))
(compile asm module (node_arg expr 1))
))
@@ -728,6 +721,9 @@
))
(fun setup_args (tbl args) (
+ (if (!= (node_bhead args) @List) (throw
+ (type_error current_loc (string "a list") args)
+ ))
(var idx 0)
(while args (do
(setup_arg tbl (make_arg idx) (car args) 0)
@@ -849,24 +845,25 @@
))
(fun compile_define_variable (asm mod expr) (
- (var rhs_head (node_bhead (node_arg expr 1)))
- (if (|| (== rhs_head Lambda) (== rhs_head Fusion))
- (compile_define_function asm mod expr)
- (compile_define_variable_ asm mod expr)
- )
- ))
-(fun compile_define_variable_ (asm mod expr) (
(var overwrite @C_FALSE)
(if (&& (== (node_size expr) 3)
(== (node_arg expr 2) (to_sym "overwrite")))
(= overwrite @C_TRUE)
)
(var lhs (node_arg expr 0))
(var rhs (node_arg expr 1))
+ (var lty (node_bhead lhs))
- (if (== (node_bhead lhs) Ref)
+ (if (== lty Ref)
(return (compile_define_clsref asm mod lhs rhs overwrite))
)
+ (if (== lty Qualified) (do
+ (node_arg_set expr 0 (node_arg lhs 1))
+ (return (compile_define_variable asm
+ (find_module mod (node_arg_symbol lhs 0))
+ expr
+ ))
+ ))
(if (! (is_symbol lhs))
(return (compile_define_multi_variable asm mod lhs rhs overwrite))
)
@@ -937,7 +934,7 @@
(var idx 0)
(if (== overwrite @C_TRUE)
(do
- (var info (lookup_symbol mod lhs))
+ (var info (lookup_symbol mod lhs @FALSE))
(= idx (node_arg_int info 0))
)
(do
@@ -959,17 +956,17 @@
))
(fun check_redefinition (mod sym) (
- (var info (lookup_symbol_local mod sym))
+ (var info (lookup_symbol_current_scope mod sym @TRUE))
(if (! info) return)
- (if (== (node_bhead info) ModuleVariable) (do
- (if (|| (== (node_arg info 1) @C_FALSE) (== (node_arg info 2) @C_TRUE))
- return
- )
- ))
(throw (redefined_var current_loc (var_loc info) sym))
))
(fun check_init (sym info) (
+ (if (!= (node_bhead info) ModuleVariable) (do
+ (throw (unexpected_error current_loc
+ (string "module variable is required")
+ sym))
+ ))
(var box (node_arg info 0))
(if (! box) (do
(var loc (node_arg info 1))
@@ -978,8 +975,10 @@
))
(fun load_module_variable (sym node) (
- (var v (field_get (field_get node 1) 0))
- (if (== v uninitialized) (throw (undefined_var current_loc sym)))
+ (var v (car (field_get node 1)))
+ (if (== v uninitialized) (do
+ (throw (undefined_var current_loc sym))
+ ))
(return v)
))
@@ -1050,32 +1049,22 @@
))
(fun compile_var (asm mod sym) (
- (var v (lookup_symbol mod sym))
+ (var v (lookup_symbol mod sym @FALSE))
(if (! v)
; `sym' is a module variable
- (= v (add_module_variable_display mod sym (struct 2 uninitialized no_loc)))
- (if (== (node_bhead v) ModuleVariable) (do
- (var u (lookup_symbol_current_module mod sym))
- (if (! u)
- (= v (add_module_variable_display mod sym (node_arg v 0)))
- )
- )))
+ (= v (add_module_variable_display mod sym))
+ (do
+ (if (== (node_bhead v) ModuleVariable) (do
+ (var u (lookup_symbol_current_module mod sym @TRUE))
+ (if (! u)
+ (= v (add_module_variable_display mod sym))
+ )
+ ))
+ )
+ )
(compile_operand asm v sym)
))
-(export fun lookup_dynamic_var (sym) (
- (var info (lookup_effective_symbol current_mod sym))
- (must_be_module_variable sym info)
- (var box (node_arg info 0))
- (return (field_get box 0))
- ))
-
-(fun compile_dynamic_var (asm mod expr) (
- (var sym (node_arg_symbol expr 0))
- (put_push asm sym)
- (compile_simple_call asm 1 lookup_dynamic_var)
- ))
-
(fun compile_apply (asm mod expr) (
(var func (node_arg expr 0))
(var args (node_arg expr 1))
@@ -1317,12 +1306,6 @@
(compile_block_body asm mod (node_arg expr 0))
))
-(fun compile_scoped (asm mod expr) (
- (var scope (node_arg expr 0))
- (set_variable_count scope (get_variable_count mod))
- (compile asm scope (node_arg expr 1))
- ))
-
(fun compile_if (asm mod expr) (
(if (in_top_scope mod)
(return (compile_function asm 0 mod 0 expr noguard @C_NIL))
@@ -1656,7 +1639,7 @@
(compile asm mod rhs)
(put_dup asm)
- (var v (lookup_symbol mod lhs))
+ (var v (lookup_symbol mod lhs @FALSE))
(if (! v)
(throw (undefined_var current_loc lhs))
)
@@ -1807,7 +1790,7 @@
(fun compile_fusion (asm mod expr) (
(compile asm mod (node_arg expr 1))
(compile asm mod (node_arg expr 0))
- (compile_simple_call asm 2 fusion_function)
+ (compile_simple_call asm 2 bind_function)
))
(fun build_closure (lam clos) (
@@ -1893,67 +1876,55 @@
))
))
-(fun append_function (mod sym newfunc) (
- (var info (lookup_symbol_local mod sym))
- (if info
- (do
- (must_be_module_variable sym info)
- (check_init sym info)
- (var box (node_arg info 0))
- (var func (field_get box 0))
- (if (callable func)
- (= newfunc (fusion_function newfunc func))
- )
- (field_set box 0 newfunc)
- return
- ))
- (= info (lookup_symbol mod sym))
- (if info
- (do
- (must_be_module_variable sym info)
- (check_init sym info)
- (var box (node_arg info 0))
- (var func (field_get box 0))
- (if (callable func)
- (= newfunc (fusion_function newfunc func))
- )
- ))
- (add_module_variable mod sym @C_FALSE newfunc)
+(fun variable_name (lhs) (
+ (if (== (node_bhead lhs) Ref)
+ (return (node_arg_symbol lhs 2))
+ )
+ (if (is_symbol lhs) (return lhs))
+ (if (== (node_bhead lhs) Qualified) (return lhs))
+ (throw (type_error current_loc (string "a symbol") lhs))
))
; DefineFunction{sym, fun} is equivalent to:
-; sym: fun (when `sym' is not defined)
-; sym: fun | sym (when `sym' is defined in outer scope)
; sym: fun | sym (overwrite) (when `sym' is defined in local scope)
+; sym: fun (other)
(fun compile_define_function (asm mod expr) (
(var lhs (node_arg expr 0))
- (var sym @C_NIL)
- (if (== (node_bhead lhs) Ref)
- (= sym (node_arg_symbol lhs 2))
- (if (is_symbol lhs)
- (= sym lhs)
- (throw (type_error current_loc (string "a symbol") lhs))
- ))
-
+ (var sym (variable_name lhs))
+ (var info (lookup_symbol_current_scope mod sym @TRUE))
(var fun (node_arg expr 1))
- (var info (lookup_symbol_local mod sym))
- (if (is_defined_locally info)
- (return (compile_define_variable_ asm mod
- (make_object3 DefVariable lhs
- (make_object2 Fusion fun lhs) (to_sym "overwrite"))))
- )
- (= info (lookup_effective_symbol mod sym))
- (if info
- (return (compile_define_variable_ asm mod
- (make_object2 DefVariable lhs (make_object Fusion (list2 fun lhs)))))
- (return (compile_define_variable_ asm mod
- (make_object2 DefVariable lhs fun)))
+
+ (if info
+ (return (compile_define_variable asm mod
+ (make_object3 DefVariable
+ lhs
+ (make_object2 Fusion fun lhs)
+ (to_sym "overwrite")
+ )))
)
+
+ (return (compile_define_variable asm mod
+ (make_object3 DefVariable
+ lhs fun (to_sym "overwrite")
+ )))
+ ))
+
+(fun append_function (mod sym newfunc) (
+ (var info (lookup_symbol_current_module mod sym @FALSE))
+ (if info
+ (do
+ (check_init sym info)
+ (var disp (get_module_variable_disp sym info))
+ (var func (car disp))
+ (setcar disp (bind_function newfunc func))
+ return
+ ))
+ (add_module_function mod sym @C_TRUE newfunc)
))
(export fun add_function0 (mod sym func guard) (
(var asm (make_assembler))
- (compile_simple_function asm 1 func)
+ (compile_simple_function asm 0 func)
(var code (get_code asm))
(append_function mod sym (make_function 0 code guard))
))
@@ -2037,7 +2008,6 @@
(add_compiler mod (make_object2 DefFunction DontCare DontCare) compile_define_function)
(add_compiler mod symT compile_var)
- (add_compiler mod (make_object1 Dynamic symT) compile_dynamic_var)
(add_compiler mod (quote @C_TRUE) compile_special)
(add_compiler mod (quote @C_FALSE) compile_special)
(add_compiler mod (quote @C_NIL) compile_special)
@@ -2060,8 +2030,6 @@
(add_compiler mod (make_object1 Block listT) compile_block)
(add_compiler mod (make_object1 Seq listT) compile_seq)
- (add_compiler mod (make_object2 Scoped (domainP Module) DontCare)
- compile_scoped)
(add_compiler mod (make_object1 Breakable listT) compile_breakable)
(add_compiler mod (mkif DontCare DontCare) compile_if)
View
4 rowl1/rowl1-error.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-node.rlc 2013-02-19 21:56:13 nineties $
+; $Id: rowl1-node.rlc 2013-02-22 22:45:01 nineties $
;
(import "rlvm-compile")
@@ -22,7 +22,7 @@
(export fun type_error (loc required actual) (
(return (make_object3 (to_sym "TypeError") loc
(make_object1 (to_sym "expected") required)
- (make_object1 (to_sym "actual_value") actual)
+ (make_object1 (to_sym "actual") actual)
))
))
View
4 rowl1/rowl1-function.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-numeric.rlc 2013-02-14 18:14:06 nineties $
+; $Id: rowl1-numeric.rlc 2013-02-28 04:03:04 nineties $
;
(import "rlvm-compile")
@@ -24,7 +24,7 @@
(add_function2 std (to_sym "mul") funT funT compose_function 0)
; horizontal composition
- (add_function2 std (to_sym "bind") funT funT fusion_function 0)
+ (add_function2 std (to_sym "bind") funT funT bind_function 0)
))
View
4 rowl1/rowl1-gc.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2012 nineties
;
-; $Id: rowl1-gc.rlc 2013-02-03 01:38:33 nineties $
+; $Id: rowl1-gc.rlc 2013-02-23 14:38:23 nineties $
;
(import "rlvm-compile")
@@ -25,7 +25,7 @@
))
(export fun setup_gc (std) (
- (var GC (find_module no_loc std (to_sym "GC") @TRUE))
+ (var GC (create_module std (to_sym "GC")))
(add_function0 GC (to_sym "start") gc_start 0)
))
View
79 rowl1/rowl1-interp.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-interp.rlc 2013-02-18 13:24:05 nineties $
+; $Id: rowl1-interp.rlc 2013-03-05 05:41:36 nineties $
;
(import "rlvm-compile")
@@ -21,7 +21,6 @@
(import "rowl1-pprint")
(export var amber_mod null)
-(export var amber_mod null)
(export var current_loc null)
(export var current_mod null)
(export fun set_loc (loc) (
@@ -69,7 +68,9 @@
(export fun eval_main (file ichan argc argv) (
;(var start (gettimeofday))
- (= amber_mod (make_module (to_sym "amber") 0))
+ (= amber_mod (make_module 0 (to_sym "amber")))
+ (add_module_variable amber_mod (to_sym "Amber") @C_TRUE amber_mod)
+
(= module_stack (cons amber_mod 0))
(= current_loc no_loc)
@@ -78,8 +79,8 @@
(setup_globals amber_mod)
(setup_builtin_compilers amber_mod)
(init_stdlib amber_mod)
- (open_module current_loc amber_mod (to_sym "std"))
- (open_module current_loc amber_mod (qualified "std" (to_sym "IO")))
+ (open_module amber_mod (to_sym "Std"))
+ (open_module amber_mod (qualified "Std" (to_sym "IO")))
(init_parser_funcs amber_mod)
@@ -88,9 +89,6 @@
(push_import_dir "/usr/lib/amber/")
(import_file "amber/syntax.ab")
- (if (in_shell_mode)
- (open_module current_loc amber_mod (to_sym "shell_syntax"))
- )
(import_file "data/string.ab")
(import_file "io.ab")
(import_file "printf.ab")
@@ -134,6 +132,7 @@
(extern fun list_to_table)
(fun rewrite (expr) (
(var new_expr (call1 Rewrite expr))
+ (if (== new_expr @C_UNDEF) (= new_expr expr))
(if (!= new_expr expr) (return (rewrite new_expr)))
(= expr new_expr)
(if (is_atom expr) (return expr))
@@ -170,14 +169,6 @@
(return expr)
))
- (if (== hd Scoped) (do
- (var save_mod current_mod)
- (set_current_module (node_arg expr 0))
- (node_arg_set expr 1 (rewrite (node_arg expr 1)))
- (set_current_module save_mod)
- (return expr)
- ))
-
(if (is_table expr) (do
(var args (node_args expr))
(var new_args 0)
@@ -236,17 +227,13 @@
(fun interpret (p) (
(while 1 (do
- (parse_statements p)
+ (var eof (parse_statements p))
(if (! (parse_success p)) (do
(output_syntax_error (get_loc p) (parser_error p))
(exit 1)
))
- (var es (parsed_token p))
- (if (! es) break)
- (while es (do
- (eval (car es))
- (= es (cdr es))
- ))
+ (if eof break)
+ (eval (parsed_token p))
))
(= current_loc no_loc)
))
@@ -256,6 +243,7 @@
(extern fun ary_push)
(fun interpret_shell (p) (
(var outputs (ary_new))
+ (enable_shell_syntax)
(add_module_variable amber_mod (to_sym "shell_outputs") @C_TRUE outputs)
(ary_push outputs @C_UNDEF)
(while 1 (do
@@ -279,7 +267,6 @@
(pprint stderr e)
(output_string stderr "\n")
(flush_parser p @TRUE)
- (ary_push outputs e)
)))))
))
@@ -298,18 +285,18 @@
(return (eval (node_arg expr 1)))
))
-(fun eval_begin_module (expr) (
+(export fun eval_begin_module (expr) (
(if (! (in_top_scope current_mod))
(throw (exception current_mod (string "module definition in sub-scope is not allowed\n")))
)
(var modsig (node_arg expr 0))
- (var module (find_module current_loc current_mod modsig @TRUE))
+ (var module (create_module current_mod modsig))
(= module_stack (cons module module_stack))
(set_current_module module)
(return module)
))
-(fun eval_end_module (expr) (
+(export fun eval_end_module (expr) (
(if (== current_mod amber_mod)
(throw (exception current_mod (string "there is no module to close")))
)
@@ -326,10 +313,6 @@
(return r)
))
-(fun default_rewrite (expr) (
- (return expr)
- ))
-
(fun rewrite_located (expr) (
(node_arg_set expr 1 (rewrite (node_arg expr 1)))
@@ -339,18 +322,8 @@
(fun eval_define_syntax (expr) (
(var sym (node_arg expr 0))
(var elm (node_arg expr 1))
- (var stmts (compile_define_syntax sym elm))
- (while stmts (do
- (eval (car stmts))
- (= stmts (cdr stmts))
- ))
- (return @C_NIL)
- ))
-
-(fun eval_replace_syntax (expr) (
- (var lhs (node_arg_symbol expr 0))
- (var rhs (node_arg_symbol expr 1))
- (eval (compile_replace_syntax lhs rhs))
+ (var stmt (compile_define_syntax sym elm))
+ (eval stmt)
(return @C_NIL)
))
@@ -482,7 +455,7 @@
))
(fun eval_open (expr) (
- (open_module current_loc current_mod (node_arg expr 0))
+ (open_module current_mod (node_arg expr 0))
(return @C_NIL)
))
@@ -503,15 +476,18 @@
(fun setup_argv (argc argv) (
(var ARGV (ary_new))
- (add_module_variable amber_mod (to_sym "ARGV") @C_TRUE ARGV)
+ (add_module_variable amber_mod (to_sym "ARGV") @C_FALSE ARGV)
(if (== argc 0) return)
(for i 1 argc (do
(ary_push ARGV (string (array_get string argv i)))
))
))
(export fun prompt_string () (
- (return (get_module_variable current_mod (to_sym "PROMPT")))
+ (var v (get_module_variable_value (to_sym "PROMPT")
+ (lookup_symbol current_mod (to_sym "PROMPT") @FALSE)
+ ))
+ (return v)
))
(fun def_global_var (sym val) (
@@ -552,17 +528,15 @@
))
(fun setup_globals (mod) (
- (add_module_variable mod (to_sym "amber") @C_FALSE mod)
(add_module_variable mod (to_sym "LOCATION") @C_FALSE current_loc)
(add_module_variable mod (to_sym "MODULE") @C_FALSE current_mod)
(add_module_variable mod (to_sym "PROMPT") @C_FALSE (string "amber"))
(if (in_shell_mode)
- (add_module_variable mod (to_sym "shell_mode") @C_TRUE @C_TRUE)
- (add_module_variable mod (to_sym "shell_mode") @C_TRUE @C_FALSE)
+ (add_module_variable mod (to_sym "shell_mode") @C_FALSE @C_TRUE)
+ (add_module_variable mod (to_sym "shell_mode") @C_FALSE @C_FALSE)
)
- (add_function1 mod Rewrite DontCare default_rewrite 0)
(add_function1 mod Rewrite (domainP Located) rewrite_located 0)
(add_function1 mod Eval DontCare default_eval 0)
(add_function1 mod Eval (domainP Located) eval_located 0)
@@ -575,7 +549,6 @@
(add_function1 mod Eval (make_object1 Seq listT) eval_seq 0)
(add_function1 mod Eval (make_object2 DefSyntax symT DontCare) eval_define_syntax 0)
- (add_function1 mod Eval (make_object2 RepSyntax symT symT) eval_replace_syntax 0)
(add_function1 mod Eval (domainP ReserveSymbol) eval_reserve_symbol 0)
(add_function1 mod Eval (quote (to_sym "exit")) eval_exit 0)
@@ -607,16 +580,14 @@
(extern fun setup_gc)
(fun init_stdlib (mod) (
- (var std (find_module no_loc mod (to_sym "std") @TRUE))
+ (var std (create_module mod (to_sym "Std")))
(setup_pprint std)
(setup_base std)
(setup_symbol std)
(setup_math std)
(setup_numeric std)
-
(setup_string std)
-
(setup_bigint std)
(setup_float std)
View
4 rowl1/rowl1-io.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-io.rlc 2013-02-13 23:31:34 nineties $
+; $Id: rowl1-io.rlc 2013-02-23 14:38:45 nineties $
;
(import "rlvm-compile")
@@ -249,7 +249,7 @@
))
(export fun setup_io (std) (
- (var IO (find_module no_loc std (to_sym "IO") @TRUE))
+ (var IO (create_module std (to_sym "IO")))
(add_module_variable IO (to_sym "stdin") @C_FALSE (make_ifstream (string "stdin") stdin))
(add_module_variable IO (to_sym "stdout") @C_FALSE (make_ofstream (string "stdout") stdout))
(add_module_variable IO (to_sym "stderr") @C_FALSE (make_ofstream (string "stderr") stderr))
View
4 rowl1/rowl1-list.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-list.rlc 2013-02-19 21:49:20 nineties $
+; $Id: rowl1-list.rlc 2013-02-23 14:39:04 nineties $
;
(import "rlvm-compile")
@@ -196,7 +196,7 @@
))
(export fun setup_list (std) (
- (var mod (find_module no_loc std (to_sym "List") @TRUE))
+ (var mod (create_module std (to_sym "List")))
(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)
View
167 rowl1/rowl1-matching.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-matching.rlc 2013-02-18 12:26:37 nineties $
+; $Id: rowl1-matching.rlc 2013-03-05 06:57:44 nineties $
;
(import "rlvm-compile")
@@ -24,16 +24,76 @@
(var domP (to_sym "%Domain"))
(extern object current_loc)
+
+(fun trace_func (msg val) (
+ (debugs msg)
+ (debugpf val)
+ (return val)
+ ))
+
+(fun trace (asm msg) (
+ (put_push asm (string msg))
+ (compile_simple_call asm 2 trace_func)
+ ))
+
+(fun compile_matching_unwrap (loc obj def) (
+ (if (== (node_type def) @DelegateFunctionE)
+ (= def (field_get def 2))
+ )
+ (return (compile_matching loc obj def))
+ ))
+
(export fun compile_matching (loc obj def) (
- (var ty (node_type def))
- (if (&& (!= ty @BoundFunctionE) (!= ty @FunctionE)) (do
+ (if (! (is_function def))
(throw (type_error loc (string "function") obj))
- ))
+ )
(var cache (field_get def 1))
(if cache (return cache))
- ; here, `def' has form of Function{ ... }
+ (var asm (make_assembler))
+
+ (if (!= (node_type def) @DelegateFunctionE)
+ (compile_matching_single_function asm loc obj def)
+ (do
+ (var fun (field_get def 2))
+ (var delegatee (field_get def 3))
+ (compile_matching_single_function asm loc obj fun)
+ (while delegatee (do
+ (var disp (car delegatee))
+ (var failed (fresh_label asm))
+
+ (put_push asm disp)
+ (put_car asm)
+ (put_push asm obj)
+ (put_push asm current_loc)
+ (compile_simple_call asm 3 compile_matching_unwrap)
+ (put_jccall asm)
+ (put_dup asm)
+ (put_undef asm)
+ (put_if_eq asm failed)
+ (put_ireturn asm)
+ (set_label asm failed)
+ (put_drop asm)
+
+ (= delegatee (cdr delegatee))
+ ))
+ ))
+
+ (put_undef asm)
+ (put_ireturn asm)
+
+ (var code (get_code asm))
+ (field_set def 1 code) ; caching
+ (return code)
+ ))
+
+(fun compile_matching_single_function (asm loc obj def) (
+ (if (! (is_function def))
+ (throw (type_error loc (string "function") obj))
+ )
+
+ ; here, `def' has form of Function{ ... } of BoundFunction{ ... }
; construct pattern matrix
(var mat (construct_pattern_matrix def))
@@ -46,15 +106,7 @@
))
(= args (cons (get_arity) args))
- (var asm (make_assembler))
(compile_matching_main asm args mat)
-
- (put_undef asm)
- (put_ireturn asm)
-
- (var code (get_code asm))
- (field_set def 1 code) ; caching
- (return code)
))
(fun construct_pattern_matrix (def) (
@@ -67,24 +119,28 @@
(if (== (node_type def) @FunctionE)
(return (cons (construct_row len def) tl))
)
- ; here `def' is a BoundFunction
- (var fun1 (field_get def 2))
- (var fun2 (field_get def 3))
- (= tl (construct_pattern_matrix_sub len fun2 tl))
- (return (construct_pattern_matrix_sub len fun1 tl))
+ (if (== (node_type def) @BoundFunctionE) (do
+ (var fun1 (field_get def 2))
+ (var fun2 (field_get def 3))
+ (= tl (construct_pattern_matrix_sub len fun2 tl))
+ (return (construct_pattern_matrix_sub len fun1 tl))
+ ))
+ (throw (string "BUG: construct_pattern_matrix_sub"))
))
(fun max_arity (def) (
(if (== (node_type def) @FunctionE)
(return (list_len (field_get def 2)))
)
- ; here `def' is a BoundFunction
- (var len1 (max_arity (field_get def 2)))
- (var len2 (max_arity (field_get def 3)))
- (if (< len1 len2)
- (return len2)
- (return len1)
- )
+ (if (== (node_type def) @BoundFunctionE) (do
+ (var len1 (max_arity (field_get def 2)))
+ (var len2 (max_arity (field_get def 3)))
+ (if (< len1 len2)
+ (return len2)
+ (return len1)
+ )
+ ))
+ (throw (string "BUG: max_arity"))
))
(fun construct_row (len def) (
@@ -392,6 +448,7 @@
))
(fun is_ellipsis_node (expr size) (
+ (if (== size 0) (return @FALSE))
(if (== (node_arg expr (- size 1)) ellipsisP)
(return @TRUE)
(return @FALSE)
@@ -674,15 +731,34 @@
(= pats (sort_list_pat pats))
(var n 1)
(var orig pats)
+ (var p (caaar pats))
(var len (list_len (caaar pats)))
(= pats (cdr pats))
- (while pats (do
- (var nd (caaar pats))
- (if (|| (!= (node_bhead nd) List) (!= (list_len nd) len)) break)
- (= pats (cdr pats))
- (incr n)
+ (if (is_ellipsis_list p)
+ (do
+ (while pats (do
+ (var nd (caaar pats))
+ (if (|| (!= (node_bhead nd) List)
+ (|| (!= (list_len nd) len)
+ (! (is_ellipsis_list nd))))
+ break)
+ (= pats (cdr pats))
+ (incr n)
+ ))
+ (return (list_split orig n))
+ )
+ (do
+ (while pats (do
+ (var nd (caaar pats))
+ (if (|| (!= (node_bhead nd) List)
+ (|| (!= (list_len nd) len)
+ (is_ellipsis_list nd)))
+ break)
+ (= pats (cdr pats))
+ (incr n)
+ ))
+ (return (list_split orig n))
))
- (return (list_split orig n))
))
(fun sort_list_pat (pats) (
@@ -716,11 +792,30 @@
(var hd (node_bhead p))
(var size (node_size p))
(= pats (cdr pats))
- (while pats (do
- (var nd (caaar pats))
- (if (|| (!= (node_bhead nd) hd) (!= (node_size nd) size)) break)
- (= pats (cdr pats))
- (incr n)
+ (if (is_ellipsis_node p size)
+ (do
+ (while pats (do
+ (var nd (caaar pats))
+ (if (|| (!= (node_bhead nd) hd)
+ (|| (!= (node_size nd) size)
+ (! (is_ellipsis_node nd size))))
+ break)
+ (= pats (cdr pats))
+ (incr n)
+ ))
+ (return (list_split orig n))
+ )
+ (do
+ (while pats (do
+ (var nd (caaar pats))
+ (if (|| (!= (node_bhead nd) hd)
+ (|| (!= (node_size nd) size)
+ (is_ellipsis_node nd size)))
+ break)
+ (= pats (cdr pats))
+ (incr n)
+ ))
+ (return (list_split orig n))
))
(return (list_split orig n))
))
View
537 rowl1/rowl1-module.rlc
@@ -2,21 +2,19 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-module.rlc 2013-02-20 21:29:15 nineties $
+; $Id: rowl1-module.rlc 2013-03-05 04:30:09 nineties $
;
-; Module can be considered as a re-entrant scope.
-; rowl (Amber) has a two kinds of modules; named module and anonymous module.
-;
+; Module
; Fields:
-; - 1:sym : name of the module (nil for anonymous module)
-; - 2:super : a link to module where this module is defined.
-; - 3:imports : list of imported modules.
-; - 4:users : list of modules which import this module
-; - 5:children : sub-modules in module hierarchy.
-; - 6:vtbl : variable table
-; - 7:count : local variable index counter
-; - 8:mark : visited mark
+; - 1:vtbl : variable table
+; - 2:delegatees : list of modules
+; - 3:delegators : list of modules
+; - 4:count : local variable index counter
+; - 5:mark : visited mark
+
+; ModuleVariable{disp, ture iff this is not a display}
+; disp = (value, location of definition)
(import "rlvm-compile")
(import "rowl1-types")
@@ -30,49 +28,31 @@
(extern object current_loc)
-(export fun make_module (sym super) (
- (var mod (variant @ModuleE 7
- sym
- super
- 0 ; list of imported modules
- 0 ; list of modules which import this module
- 0 ; children
+(export fun make_module (outer sym) (
+ (var mod (variant @ModuleE 4
(make_symtable 10) ; variable table
+ 0 ; delegatees
+ 0 ; delegators
(list1 (box 0)) ; local variable index counter
- 0 ; visited-mark
+ 0 ; visited-mark
))
- (if super (do
- (if (!= sym @C_NIL) (add_module_variable super sym @C_FALSE mod))
- (add_child super mod)
+ (if outer (do
+ (add_delegator mod outer)
+ (add_module_variable outer sym @C_FALSE mod)
))
(return mod)
))
-(export fun is_anonymous_module (mod) (
- (return (== (field_get mod 1) @C_NIL))
- ))
-
-(fun add_child (super sub) (
- (field_set super 5 (cons sub (list_delete sub (field_get super 5))))
+(export fun get_vartable (mod) (
+ (return (field_get mod 1))
))
-(export fun is_defined_locally (v) (
- (if (! v) (return @FALSE))
- (if (&& (== (node_bhead v) ModuleVariable)
- (|| (== (node_arg v 1) @C_FALSE)
- (== (node_arg v 2) @C_TRUE)
- ))
- (return @FALSE)
- )
- (return @TRUE)
+(export fun delegatees (mod) (
+ (return (field_get mod 2))
))
-(fun is_effective_variable (v) (
- (if (! v) (return @FALSE))
- (if (&& (== (node_bhead v) ModuleVariable) (== (node_arg v 1) @C_FALSE))
- (return @FALSE)
- )
- (return @TRUE)
+(fun delegators (mod) (
+ (return (field_get mod 3))
))
(var visited_mark 0)
@@ -81,272 +61,353 @@
(return visited_mark)
))
-(export fun super_module (mod) (
- (return (field_get mod 2))
+(fun get_mark (mod) (
+ (return (field_get mod 5))
))
-(export fun opened_modules (mod) (
- (return (field_get mod 3))
+(fun set_mark (mod mark) (
+ (field_set mod 5 mark)
+ ))
+
+(fun add_delegator (from to) (
+ (field_set from 2 (cons to (list_delete to (field_get from 2))))
+ (field_set to 3 (cons from (list_delete from (field_get to 3))))
+ (update_module_variables from)
))
-(export fun open_module (loc curmod sig) (
- (var mod (find_module loc curmod sig @FALSE))
- (field_set curmod 3 (cons mod (list_delete mod (field_get curmod 3))))
- (field_set mod 4 (cons curmod (list_delete curmod (field_get mod 4))))
-
- ; add all definitions in `mod' to `curmod'
- (var entries (symtable_entries (field_get mod 6)))
- (for i 0 (vector_size entries) (do
- (var ent (vector_at entries i))
- (if (! ent) continue)
- (var info (field_get ent 1))
- (if (!= (node_bhead info) ModuleVariable) continue)
- (var mark (fresh_mark))
- (update_module_variable mark curmod (field_get ent 0) (node_arg info 0))
+(fun del_delegator (from to) (
+ (field_set from 2 (list_delete to (field_get from 2)))
+ (field_set to 3 (list_delete from (field_get to 3)))
+ (update_module_variables from)
+ ))
+
+;;; ModuleVariable
+(fun is_display (v) (
+ (if (&& (== (node_bhead v) ModuleVariable)
+ (== (node_arg v 1) @C_FALSE))
+ (return @TRUE) ; display
+ )
+ (return @FALSE)
+ ))
+
+(export fun get_module_variable_disp (sym info) (
+ (if (!= (node_bhead info) ModuleVariable) (do
+ (throw (unexpected_error current_loc
+ (string "module variable is required2")
+ info))
))
+ (return (node_arg info 0))
))
-(export fun add_symbol (mod sym v) (
- (symtable_add (field_get mod 6) sym v)
+(export fun get_module_variable_value (sym info) (
+ (return (car (get_module_variable_disp sym info)))
))
-(export fun delete_symbol (mod sym) (
- (symtable_delete (field_get mod 6) sym)
+(export fun open_module (outer sig) (
+ (var inner (find_module outer sig))
+ (add_delegator outer inner)
))
-(export fun lookup_symbol (mod sig) (
- (var hd (node_bhead sig))
- (if (== hd BSymbol)
- (return (lookup_symbol_iter (fresh_mark) mod sig @FALSE))
- (if (== hd Qualified)
- (return (lookup_symbol
- (find_module current_loc mod (node_arg sig 0) @FALSE) (node_arg sig 1)))
+(export fun close_module (outer sig) (
+ (var inner (find_module outer sig))
+ (del_delegator outer inner)
+ ))
+
+(fun collect_all_delegators (mark mod list) (
+ (if (== (get_mark mod) mark) (return list))
+ (set_mark mod mark)
+
+ (= list (cons mod list))
+ (var mods (delegators mod))
+ (while mods (do
+ (= list (collect_all_delegators mark (car mods) list))
+ (= mods (cdr mods))
+ ))
+ (return list)
+ ))
+
+(fun update_module_variables (mod) (
+ (var mods (collect_all_delegators (fresh_mark) mod 0))
+ (while mods (do
+ (var delegator (car mods))
+ (var entries (symtable_entries (get_vartable delegator)))
+ (for i 0 (vector_size entries) (do
+ (var entry (vector_at entries i))
+ (var sym (field_get entry 0))
+ (var ent (field_get entry 1))
+ (var v (get_module_variable_value sym ent))
+ (if (&& (is_function v) (! (is_display ent)))
+ (update_function_entry delegator sym)
+ (update_variable_entry delegator sym ent)
+ )
+ ))
+ (= mods (cdr mods))
))
- (throw (invalid_argument current_loc
- (string "invalid identifier")
- sig))
))
-(export fun lookup_effective_symbol (mod sig) (
- (var hd (node_bhead sig))
- (if (== hd BSymbol)
- (return (lookup_symbol_iter (fresh_mark) mod sig @TRUE))
- (if (== hd Qualified)
- (return (lookup_symbol
- (find_module current_loc mod (node_arg sig 0) @FALSE) (node_arg sig 1)))
+(fun update_module_variables_single (mod sym) (
+ (var mods (collect_all_delegators (fresh_mark) mod 0))
+ (while mods (do
+ (var delegator (car mods))
+ (var ent (symtable_find (get_vartable delegator) sym))
+ (if ent (do
+ (var v (get_module_variable_value sym ent))
+ (if (&& (is_function v) (! (is_display ent)))
+ (update_function_entry delegator sym)
+ (update_variable_entry delegator sym ent)
+ )
+ ))
+ (= mods (cdr mods))
))
- (throw (invalid_argument current_loc
- (string "invalid identifier")
- sig))
))
-(fun lookup_symbol_iter (mark mod sym find_effective) (
- (while mod (do
- ; check visited-mark
- (if (== (field_get mod 8) mark) break)
- (field_set mod 8 mark)
+(fun lookup_all_funcs (mod sym) (
+ (return (list_reverse (lookup_all_funcs_sub (fresh_mark) mod sym 0)))
+ ))
+
+(fun lookup_all_funcs_sub (mark mod sym list) (
+ (if (== (get_mark mod) mark) (return list))
+ (set_mark mod mark)
- (var tbl (field_get mod 6))
- (var v (symtable_find tbl sym))
- (if find_effective
- (if (is_effective_variable v) (return v))
- (if v (return v))
+ (var vtbl (get_vartable mod))
+ (var v (symtable_find vtbl sym))
+ (if (&& v (! (is_display v))) (do
+ (var disp (get_module_variable_disp sym v))
+ (if (! (list_member disp list))
+ (= list (cons disp list))
)
+ ))
- (= mod (super_module mod))
+ (var mods (delegatees mod))
+ (while mods (do
+ (= list (lookup_all_funcs_sub mark (car mods) sym list))
+ (= mods (cdr mods))
))
- (return 0)
+ (return list)
))
-(export fun lookup_symbol_local (mod sym) (
- (var tbl (field_get mod 6))
- (return (symtable_find_local tbl sym))
+(fun update_function_entry (mod sym) (
+ (var disps (lookup_all_funcs mod sym))
+ (var disp (car disps)) ; current module
+ (var other (cdr disps)) ; delegatees
+ (var fun (car disp))
+ (if (== (node_type fun) @DelegateFunctionE) (do
+ (field_set fun 1 0) ; clear cache
+ (field_set fun 3 other)
+ )
+ (if other
+ (setcar disp (variant @DelegateFunctionE 3 0 fun other))
+ ))
))
-(export fun lookup_symbol_current_module (mod sym) (
- (var tbl (field_get mod 6))
- (return (symtable_find tbl sym))
+(fun update_variable_entry (mod sym info) (
+ (var mvar (lookup_symbol mod sym @TRUE))
+ ; If non-display variable found, update the module variable entry.
+ (if mvar
+ (node_arg_set info 0 (get_module_variable_disp sym mvar))
+ )
))
-(export fun get_variable_count (mod) (
- (return (unbox (car (field_get mod 7))))
+(export fun lookup_symbol (mod sig nodisp) (
+ (var hd (node_bhead sig))
+ (if (== hd Qualified)
+ (return (lookup_symbol
+ (find_module mod (node_arg_symbol sig 0))
+ (node_arg sig 1)
+ nodisp
+ )))
+ (if (== hd BSymbol) (do
+ (var v (lookup_symbol_iter (fresh_mark) mod sig nodisp))
+ (return v)
+ ))
+ (throw (invalid_argument current_loc
+ (string "invalid identifier")
+ sig))
))
-(export fun set_variable_count (mod cnt) (
- (setcar (field_get mod 7) (box cnt))
+(fun lookup_symbol_iter (mark mod sym nodisp) (
+ ; check visited-mark
+ (if (== (get_mark mod) mark) (return 0))
+ (set_mark mod mark)
+
+ (var vtbl (get_vartable mod))
+ (var v (symtable_find vtbl sym))
+ (if (&& v (! (&& nodisp (is_display v)))) (return v))
+
+ (var mods (delegatees mod))
+ (while mods (do
+ (= v (lookup_symbol_iter mark (car mods) sym nodisp))
+ (if (&& v (! (&& nodisp (is_display v)))) (return v))
+ (= mods (cdr mods))
+ ))
+ (return 0)
))
-(export fun reset_variable_count (mod) (
- (setcar (field_get mod 7) (box 0))
+(export fun lookup_symbol_current_module (mod sym nodisp) (
+ (if (== (node_bhead sym) Qualified)
+ (return (lookup_symbol_current_module
+ (find_module mod (node_arg_symbol sym 0))
+ (node_arg sym 1)
+ nodisp
+ ))
+ )
+ (var v (symtable_find (get_vartable mod) sym))
+ (if (&& v (! (&& nodisp (is_display v)))) (return v))
+ (return 0)
))
-(export fun incr_variable_count (mod) (
- (var counters (field_get mod 7))
- (setcar counters (+ (car counters) 2)) ; counters are boxed
+(export fun lookup_symbol_current_scope (mod sym nodisp) (
+ (if (== (node_bhead sym) Qualified)
+ (return (lookup_symbol_current_scope
+ (find_module mod (node_arg_symbol sym 0))
+ (node_arg sym 1)
+ nodisp
+ ))
+ )
+ (var v (symtable_find_local (get_vartable mod) sym))
+ (if (&& v (! (&& nodisp (is_display v)))) (return v))
+ (return 0)
))
-(export fun push_varscope (mod) (
- (symtable_push (field_get mod 6))
- (var counters (field_get mod 7))
- (field_set mod 7 (cons (car counters) counters))
+(export fun find_module (curmod sig) (
+ (var mod (lookup_symbol curmod sig @FALSE))
+ (if (! mod) (throw (not_found current_loc sig)))
+ (= mod (get_module_variable_value sig mod))
+ (if (!= (node_type mod) @ModuleE)
+ (throw (type_error current_loc (string "module") mod))
+ )
+ (return mod)
))
-(export fun pop_varscope (mod) (
- (symtable_pop (field_get mod 6))
- (field_set mod 7 (cdr (field_get mod 7)))
+(export fun create_module (curmod sig) (
+ (var mod (lookup_symbol curmod sig @FALSE))
+ (if mod (do
+ (= mod (get_module_variable_value sig mod))
+ (if (!= (node_type mod) @ModuleE)
+ (throw (type_error current_loc (string "module") mod))
+ )
+ (return mod)
+ ))
+
+ (var hd (node_bhead sig))
+ (if (== hd Qualified)
+ (return (create_module
+ (find_module curmod (node_arg sig 0))
+ (node_arg sig 1)))
+ )
+ (if (== hd BSymbol) (do
+ (return (make_module curmod sig))
+ ))
+ (throw (invalid_argument current_loc
+ (string "invalid identifier")
+ sig))
))
-; add definition of module variable `sym' to `mod'.
-; `val' is a initial value.
(export fun add_module_variable (mod sym overwrite val) (
- (var box @C_NIL)
- (var ent (lookup_symbol_local mod sym))
+ (if (== (node_bhead sym) Qualified)
+ (return (add_module_variable
+ (find_module mod (node_arg_symbol sym 0))
+ (node_arg sym 1)
+ overwrite
+ val
+ )))
+ (var disp 0)
+ (var ent (lookup_symbol_current_module mod sym @FALSE))
(if (! ent) (do
- (= box (struct 2 val current_loc))
- (= ent (make_object3 ModuleVariable box @C_TRUE @C_FALSE))
- (symtable_add_to_global (field_get mod 6) sym ent)
- (goto update_displays)
+ (= disp (struct 2 val current_loc))
+ (= ent (make_object2 ModuleVariable disp @C_TRUE))
+ (symtable_add_to_global (