Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: nineties/amber
base: 5740160fbc
...
head fork: nineties/amber
compare: b5573d6426
Checking mergeability… Don't worry, you can still create the pull request.
  • 4 commits
  • 44 files changed
  • 0 commit comments
  • 1 contributor
Commits on Feb 20, 2013
nineties Fixed a bug of find_module() 128fc3e
Commits on Mar 04, 2013
nineties Working snapshot (Refinment of module system) 6f6531d
Commits on Mar 06, 2013
nineties Fixed refinement of module system. 4ea56a8
Commits on Mar 07, 2013
nineties Fixed bugs. b5573d6
Showing with 1,669 additions and 1,465 deletions.
  1. +4 −3 demo/lang/hyperlisp.ab
  2. +19 −12 demo/lang/hyperlisp/lib/lambda.ab
  3. +3 −1 demo/lang/hyperlisp/lib/literal.ab
  4. +5 −3 demo/lang/hyperlisp/lib/syntax.ab
  5. +1 −1  demo/nbody/nbody-lib.ab
  6. +58 −55 lib/amber/syntax.ab
  7. +1 −1  lib/data/array.ab
  8. +3 −3 lib/data/bitable.ab
  9. +1 −1  lib/data/list.ab
  10. +1 −1  lib/data/set.ab
  11. +1 −1  lib/data/string.ab
  12. +8 −6 lib/data/table.ab
  13. +1 −1  lib/dev/HIL.ab
  14. +1 −1  lib/dev/HIL/vector.ab
  15. +6 −6 lib/dev/binio.ab
  16. +1 −1  lib/io.ab
  17. +11 −9 lib/oop.ab
  18. +33 −30 lib/printf.ab
  19. +8 −7 lib/unittest.ab
  20. +2 −2 rowl1/rlvm-compile.rlc
  21. +3 −3 rowl1/rowl1-array.rlc
  22. +2 −1  rowl1/rowl1-assemble.rlc
  23. +2 −2 rowl1/rowl1-bigint.rlc
  24. +197 −165 rowl1/rowl1-compile.rlc
  25. +2 −2 rowl1/rowl1-error.rlc
  26. +2 −2 rowl1/rowl1-function.rlc
  27. +2 −2 rowl1/rowl1-gc.rlc
  28. +25 −54 rowl1/rowl1-interp.rlc
  29. +2 −2 rowl1/rowl1-io.rlc
  30. +2 −2 rowl1/rowl1-list.rlc
  31. +131 −36 rowl1/rowl1-matching.rlc
  32. +299 −238 rowl1/rowl1-module.rlc
  33. +19 −9 rowl1/rowl1-node.rlc
  34. +4 −1 rowl1/rowl1-numeric.rlc
  35. +772 −769 rowl1/rowl1-packrat.rlc
  36. +3 −3 rowl1/rowl1-pprint.rlc
  37. +3 −3 rowl1/rowl1-string.rlc
  38. +3 −3 rowl1/rowl1-table.rlc
  39. +11 −10 rowl1/rowl1-types.rlc
  40. +2 −2 rowl1/vm-insn.rlc
  41. +2 −0  sample/module.ab
  42. +3 −3 test/bigint.ab
  43. +8 −6 test/matching.ab
  44. +2 −2 test/string.ab
View
7 demo/lang/hyperlisp.ab
@@ -1,7 +1,7 @@
#!/usr/bin/amber -m
# Copyright (C) 2012 nineties
#
-# $Id: hyperlisp.ab 2012-12-11 14:49:55 nineties $
+# $Id: hyperlisp.ab 2013-03-06 22:56:40 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -18,5 +18,6 @@ PROMPT = "hyperlisp"
open HyperLisp
# Switch to the HyperLisp interpreter.
-(eval, parse_statement, parse_comment)
- = (hl_eval, parse_hl_expr, parse_hl_comment)
+
+(eval, Parser::statement, Parser::comment)
+ = (HyperLisp::hl_eval, HyperLisp::Parser::hl_expr, HyperLisp::Parser::hl_comment)
View
31 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-07 00:42:59 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -10,6 +10,7 @@
import core
module HyperLisp {
+ module Parser {
# Metaliteral
hl_metaliteral ::= nospace( ([A-Z][A-Za-z0-9]*) )
{ `Meta{!$input.to_sym} }
@@ -21,6 +22,7 @@ module HyperLisp {
{ `Eq{!$0, !$2} }
| "." hl_expr
{ `Whole{!$1} }
+ }
# Rename variables to avoid name conflict.
rename(sym): ("hyperlisp_" + sym).to_sym
@@ -191,7 +193,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,40 +216,45 @@ 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
+ module Parser {
# The symbol '#' is used for start symbol of comments in
# Amber's default syntax.
- hl_comment ::= C_style_comment
+ 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])]) }
+ }
# Extend eval and apply
eval_define(x): {
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)
eval_(x@Meta): throw `UndefinedMetaLiteral{!x}
- # lambda-abstraction and label-expression is just a syntax sugar.
- # Therefore, they should be translated to sexp before evaluation.
- parse_old_hl_expr: parse_hl_expr
- hl_expr_macro ::= old_hl_expr { macro($0) }
- ReplaceSyntax{hl_expr, hl_expr_macro}
-
macro: x@Cons when x.car == \Meta{Lambda} -> compile_lambda(x)
| x@Cons when x.car == \Meta{Label} -> compile_label(x)
| x when x == zero -> zero
| x@Cons -> cons(macro(x.car), macro(x.cdr))
| x@Snoc -> snoc(macro(x.car), macro(x.cdr))
| x -> x
+
+ module Parser {
+ # lambda-abstraction and label-expression is just a syntax sugar.
+ # Therefore, they should be translated to sexp before evaluation.
+ hl_expr_old: hl_expr
+ hl_expr_macro ::= hl_expr_old { macro($0) }
+ hl_expr = hl_expr_macro
+ }
+
}
View
4 demo/lang/hyperlisp/lib/literal.ab
@@ -1,6 +1,6 @@
# Copyright (C) 2012 nineties
#
-# $Id: hyperlisp/symbol.ab 2013-02-06 13:47:42 nineties $
+# $Id: hyperlisp/symbol.ab 2013-03-06 00:00:29 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -46,11 +46,13 @@ module HyperLisp {
(s.size == 1) ? zero : s[1..-1].to_sym
}
+ module Parser {
# Extend Syntax
#
# A literal is a nonempty sequence of lowercase letters
hl_literal ::= nospace( [a-z]+ ) { $input.to_sym }
hl_simple_expr ::= hl_literal
+ }
# Use Amber's default pretty-printer
}
View
8 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 23:10:26 nineties $
# Reference
# Masahiko Sato and Masami Hagiya: HyperLisp, Algorithmic Languages
@@ -10,6 +10,7 @@
import core
module HyperLisp {
+ module Parser {
# Basic syntax
hl_simple_expr
::= "(" hl_expr "." hl_expr ")" { cons($1, $3) }
@@ -27,15 +28,16 @@ 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
::= hl_secondary_expr ":" hl_secondary_expr
{ cons_list([$0, $2]) }
| hl_secondary_expr
+ }
# Pretty printing
is_cons_list
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{Qualified{Std, 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-06 22:50:53 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,18 +82,12 @@ 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}
}
}
@@ -101,29 +95,20 @@ DefineSyntax{
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,10 +354,10 @@ 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} }
@@ -380,12 +365,14 @@ statement
| 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{} # Std::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 Std::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
3  rowl1/rowl1-assemble.rlc
@@ -2,7 +2,7 @@
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
-; $Id: rowl1-assemble.rlc 2013-01-27 22:38:45 nineties $
+; $Id: rowl1-assemble.rlc 2013-03-08 02:32:37 nineties $
;
; -- Just in time assembler
@@ -308,6 +308,7 @@
(var addr (ivector_at labels label))
(if (< addr 0) (error "undefined label"))
(-= addr offs)
+ (if (|| (>= addr 32767) (<= addr -32768)) (error "address overflow"))
(cvector_put vec pos (& addr 0xff))
(cvector_put vec (+ pos 1) (>> addr 8))
(= repls (field_get repls 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
362 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-07 00:34:34 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)
@@ -163,7 +152,7 @@
; f(... x ... x ...) : body
; to
; f(... x ... y ...) when x==y : body
-(extern fun list_to_table)
+(extern fun _copy)
(fun alpha_args_iter (tbl chk rep expr level) (
(if (is_symbol expr) (do
(if (== expr DontCare) (return expr))
@@ -197,6 +186,7 @@
(return expr)
))
(var hd (node_bhead expr))
+ (if (== hd Qualified) (return expr))
(if (== hd Quote) (return expr))
(if (== hd Domain)
(if (== level 0) (do
@@ -261,48 +251,51 @@
))
(if (is_atom expr) (return expr))
(if (is_list expr) (do
- (var ls expr)
- (while ls (do
- (setcar ls (alpha tbl (car ls)))
- (= ls (cdr ls))
+ (var new 0)
+ (while expr (do
+ (= new (cons (alpha tbl (car expr)) new))
+ (= expr (cdr expr))
))
- (return expr)
+ (return (list_reverse new))
))
(var hd (node_bhead expr))
- (if (== hd Located) (do
- (node_arg_set expr 1 (alpha tbl (node_arg expr 1)))
- (return expr)
- ))
+ (if (== hd Located)
+ (return (make_object2 Located
+ (node_arg expr 0)
+ (alpha tbl (node_arg expr 1))))
+ )
(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)))
(return expr)
))
(if (|| (== hd Block) (== hd Breakable)) (do
- (var exprs (node_arg_list expr 0))
(symtable_push tbl)
+ (var exprs (node_arg_list expr 0))
+ (var new_exprs 0)
(while exprs (do
- (setcar exprs (alpha tbl (car exprs)))
+ (= new_exprs (cons (alpha tbl (car exprs)) new_exprs))
(= exprs (cdr exprs))
))
(symtable_pop tbl)
- (return expr)
+ (return (make_object1 hd (list_reverse new_exprs)))
))
(if (== hd Lambda) (do
(symtable_push tbl)
+ (= 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)))
(symtable_pop tbl)
(return expr)
))
(if (== hd Quote) (return expr))
- (if (== hd QuasiQuote) (do
- (node_arg_set expr 0 (alpha_qquote tbl (node_arg expr 0) 0))
- (return expr)
- ))
- (if (== hd Dynamic)
- (return expr)
+ (if (== hd QuasiQuote)
+ (return (make_object1 QuasiQuote
+ (alpha_qquote tbl (node_arg expr 0) 0)))
)
+
+ (= expr (_copy expr))
(for i 0 (node_size expr)
(node_arg_set expr i (alpha tbl (node_arg expr i)))
)
@@ -312,30 +305,79 @@
(fun alpha_qquote (tbl expr level) (
(if (is_atom expr) (return expr))
(if (is_list expr) (do
- (var ls expr)
- (while ls (do
- (setcar ls (alpha_qquote tbl (car ls) level))
- (= ls (cdr ls))
+ (var ret 0)
+ (while expr (do
+ (= ret (cons (alpha_qquote tbl (car expr) level) ret))
+ (= expr (cdr expr))
))
- (return expr)
+ (return (list_reverse ret))
))
(var hd (node_bhead expr))
(if (== hd Unquote) (do
- (if (== level 0) (do
- (node_arg_set expr 0 (alpha tbl (node_arg expr 0)))
- (return expr)
- ))
+ (if (== level 0)
+ (return (make_object1 Unquote (alpha tbl (node_arg expr 0))))
+ )
(-= level 1)
)
(if (== hd QuasiQuote)
(+= level 1)
))
+ (= expr (_copy expr))
(for i 0 (node_size expr)
(node_arg_set expr i (alpha_qquote tbl (node_arg expr i) level))
)
(return expr)
))
+(fun unqualified_args_iter (expr ret level) (
+ (if (is_symbol expr) (do
+ (field_set ret 1 (cons expr (field_get ret 1)))
+ (field_set ret 2 (cons expr (field_get ret 2)))
+ (return expr)
+ ))
+ (if (is_atom expr) (return expr))
+ (if (is_list expr) (do
+ (var ls expr)
+ (while ls (do
+ (setcar ls (unqualified_args_iter (car ls) ret level))
+ (= ls (cdr ls))
+ ))
+ (return expr)
+ ))
+ (var hd (node_bhead expr))
+ (if (== hd Quote) (return expr))
+ (if (== hd Qualified) (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)))
+ (return v)
+ ))
+ (if (== hd Domain)
+ (if (== level 0) (do
+ (node_arg_set expr 0
+ (unqualified_args_iter (node_arg expr 0) ret 0))
+ (var dom (node_arg expr 1))
+ (if (! (is_symbol dom))
+ (node_arg_set expr 1 (unqualified_args_iter dom ret 0))
+ )
+ (return expr)
+ ))
+ (if (== hd QuasiQuote) (+= level 1)
+ (if (== hd Unquote) (-= level 1))))
+
+ (for i 0 (node_size expr)
+ (node_arg_set expr i
+ (unqualified_args_iter (node_arg expr i) ret level))
+ )
+ (return expr)
+ ))
+
+(fun unqualified_args (args) (
+ (var ret (struct 3 0 0 0))
+ (field_set ret 0 (unqualified_args_iter args ret 0))
+ (return ret)
+ ))
+
(fun alloc_function (args code guard) (
(return (variant @FunctionE 4 0 args code guard))
))
@@ -346,14 +388,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 +458,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 +558,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 +586,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 +668,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 +777,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,13 +901,6 @@
))
(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")))
@@ -863,10 +908,18 @@
)
(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))
)
@@ -891,11 +944,14 @@
; car(tmp)
(fun compile_define_multi_variable (asm mod lhs rhs overwrite) (
(var lbl (fresh_label asm))
- (var vars (collect_args lhs))
+ (var tup (unqualified_args lhs))
+ (var pattern (field_get tup 0))
+ (var tvars (field_get tup 1))
+ (var rvars (field_get tup 2))
(var t (unique_sym))
(compile asm mod (apply (lambda
- (list1 (make_object2 Domain t lhs))
- (list_append vars (list1 t))) (list1 rhs)))
+ (list1 (make_object2 Domain t pattern))
+ (list_append tvars (list1 t))) (list1 rhs)))
(put_dup asm)
(put_undef asm)
@@ -905,16 +961,16 @@
(put_throw asm)
(set_label asm lbl)
- (while vars (do
+ (while rvars (do
(var def @C_NIL)
(if (== overwrite @C_TRUE)
- (= def (make_object3 DefVariable (car vars) Decons (to_sym "overwrite")))
- (= def (make_object2 DefVariable (car vars) Decons))
+ (= def (make_object3 DefVariable (car rvars) Decons (to_sym "overwrite")))
+ (= def (make_object2 DefVariable (car rvars) Decons))
)
(compile_define_variable asm mod def)
(put_drop asm)
- (= vars (cdr vars))
+ (= rvars (cdr rvars))
))
(put_car asm)
))
@@ -937,7 +993,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 +1015,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 +1034,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 +1108,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 +1365,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 +1698,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))
)
@@ -1691,11 +1733,16 @@
; car(tmp)
(fun compile_multi_assign (asm mod lhs rhs) (
(var lbl (fresh_label asm))
- (var vars (collect_args lhs))
+
+ (var tup (unqualified_args lhs))
+ (var pattern (field_get tup 0))
+ (var tvars (field_get tup 1))
+ (var rvars (field_get tup 2))
+
(var t (unique_sym))
(compile asm mod (apply (lambda
- (list1 (make_object2 Domain t lhs))
- (list_append vars (list1 t))) (list1 rhs)))
+ (list1 (make_object2 Domain t pattern))
+ (list_append tvars (list1 t))) (list1 rhs)))
(put_dup asm)
(put_undef asm)
@@ -1705,10 +1752,10 @@
(put_throw asm)
(set_label asm lbl)
- (while vars (do
- (compile_assign asm mod (assign (car vars) Decons))
+ (while rvars (do
+ (compile_assign asm mod (assign (car rvars) Decons))
(put_drop asm)
- (= vars (cdr vars))
+ (= rvars (cdr rvars))
))
(put_car asm)
))
@@ -1807,7 +1854,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 +1940,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 +2072,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 +2094,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,7 +476,7 @@
(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)))
@@ -511,7 +484,10 @@
))
(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-14 03:04:27 nineties $
+; $Id: rowl1-module.rlc 2013-03-06 19:18:46 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)