Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

369 lines (262 sloc) 7.834 kb
use("core")
use("define")
use("cosmetics")
use("control-flow")
use("meta")
use("init")
Atomy Patterns open:
-- redefine these in atomy so we can have some base cases
Pattern <=> x := precision <=> x precision
Pattern <=> (x: Default) := <=> x pattern
Pattern <=> (x: Named) := <=> x pattern
Pattern <=> (x: BlockPass) := <=> x pattern
Pattern <=> (x: Splat) := <=> x pattern
Pattern <=> Predicate := -1
With = Pattern class:
children(.pattern, .sub-pattern)
attributes(.expression)
construct(g, mod) := do:
get(g)
@pattern construct(g, mod)
@sub-pattern construct(g, mod)
@expression construct(g, mod)
g send(.new, 3)
g push-cpath-top
g find-const(.Atomy)
g send(.current_module, 0)
g send(.in_context, 1)
target(g, mod) := @pattern target(g, mod)
matches(g, mod)? := do:
mismatch = g new-label
done = g new-label
@result = g new-stack-local
g dup
@pattern matches(g, mod)?
g gif(mismatch)
`{ ~@expression } bytecode(g, mod)
g send(.block, 0)
g swap
g push-scope
g send(.call-under, 2)
g set-stack-local(@result)
@sub-pattern matches(g, mod)?
g dup
g git(done)
mismatch set!
g pop
g push-false
done set!
matches-self(g, mod)? := do:
mismatch = g new-label
done = g new-label
@result = g new-stack-local
@pattern matches-self(g, mod)?
g gif(mismatch)
mod compile(g, @expression)
g set-stack-local(@result)
@sub-pattern matches(g, mod)?
g dup
g git(done)
g pop
mismatch set!
g push-false
done set!
deconstruct(g, mod, locals = Hash new) := do:
unless(@result):
g dup
@pattern deconstruct(g, mod, locals)
if(@result)
then: g push-stack-local(@result)
else:
`{ ~@expression } bytecode(g, mod)
g send(.block, 0)
g swap
g push-scope
g send(.call-under, 2)
@sub-pattern deconstruct(g, mod, locals)
And = Pattern class:
children(.a, .b)
target(g, mod) := @a target(g, mod)
matches(g, mod)? :=
condition:
@a wildcard? ->
@b matches(g, mod)?
@b wildcard? ->
@a matches(g, mod)?
otherwise:
mismatch = g new-label
done = g new-label
g dup
@a matches(g, mod)?
g gif(mismatch)
@b matches(g, mod)?
g dup
g git(done)
mismatch set!
g pop
g push-false
done set!
deconstruct(g, mod, locals = Hash new) := do:
g dup
@a deconstruct(g, mod, locals)
@b deconstruct(g, mod, locals)
Or = Pattern class:
children(.a, .b)
target(g, mod) := @a target(g, mod)
matches(g, mod)? := do:
matched = g new-label
done = g new-label
g dup
@a matches(g, mod)?
g git(matched)
@b matches(g, mod)?
g dup
g gif(done)
matched set!
g pop
g push-true
done set!
deconstruct(g, mod, locals = Hash new) := do:
b = g new-label
done = g new-label
g dup
g dup
@a matches(g, mod)?
g gif(b)
@a deconstruct(g, mod, locals)
g pop
g goto(done)
b set!
g pop
@b deconstruct(g, mod, locals)
done set!
Pattern <=> (a: And) := -(a <=> self)
Pattern <=> (o: Or) := -(o <=> self)
Pattern <=> (w: With) := <=> w pattern
-- an And precedes x if either precede it
And <=> x :=
if(@a <=> x == 1)
then: 1
else: @b <=> x
-- an Or precedes x if neither are preceded by
Or <=> x :=
if(@a <=> x == -1)
then: -1
else: @b <=> x
With <=> x := @pattern <=> x
(a: And) <=> (b: And) :=
((a a <=> b a) + (a b <=> b a) + (a a <=> b b) + (a b <=> b b)) <=> 0
(a: Or) <=> (b: Or) :=
((a a <=> b a) + (a b <=> b a) + (a a <=> b b) + (a b <=> b b)) <=> 0
(a: With) <=> (b: With) := do:
main = a pattern <=> b pattern
if(main == 0)
then: a sub-pattern <=> b sub-pattern
else: main
-- pattern definition
macro(pattern(~pat): ~*body):
names [mod]:
patdef =
init(LetMacro):
line: node line
body: `(do: ~*body)
macros:
[`(pattern(~init(Unquote, expression -> 'x)) =
`(~'~mod make-pattern(~x)))]
init(DefinePattern):
pattern: pat
body: patdef
module-name: mod
-- base patterns
pattern(? to-word):
Atomy Patterns Named new(Atomy Patterns Any new, node to-word text)
pattern(`(~(x ? to-word): ~y)):
Atomy Patterns Named new(pattern(y), x to-word text)
pattern(Primitive):
Atomy Patterns Match new(node value)
pattern(Literal):
Atomy Patterns Literal new(node value)
pattern(`[~*ps]):
Atomy Patterns List new(node elements collect [e]: pattern(e))
pattern(Constant):
Atomy Patterns Constant new(node)
pattern(`(//~(y: Constant))):
Atomy Patterns Constant new(init(ToplevelConstant, name -> y name))
pattern(`(/~(y: Constant))):
Atomy Patterns Constant new(
init(ScopedConstant, parent -> 'Self, name -> y name))
pattern(`(~x ~(y: Constant))):
Atomy Patterns Constant new(
init(ScopedConstant, parent -> x, name -> y name))
pattern(Quote):
Atomy Patterns Quote new(node expression)
pattern(QuasiQuote):
Atomy Patterns QuasiQuote new(
node through-quotes([_]: true) [e]:
pattern(e) to-node)
pattern(Block):
Atomy Patterns SingletonClass new(node body)
pattern(`(? ~t)):
Atomy Patterns Predicate new(Atomy Patterns Any new, t)
pattern(`(~p ? ~t)):
Atomy Patterns Predicate new(pattern(p), t)
pattern(`@@~(n ? to-word)):
Atomy Patterns NamedClass new(n to-word text)
pattern(`(~x ~(y ? to-word))):
Atomy Patterns Attribute new(x, y to-word text, [])
pattern(`(~x (~(y ? to-word))(~*as))):
Atomy Patterns Attribute new(x, y to-word text, as)
pattern(`(~x (~(y: Word))(~*as)?)):
Atomy Patterns Attribute new(x, `((~y)?) to-word text, as)
pattern(`(~x (~(y: Word))(~*as)!)):
Atomy Patterns Attribute new(x, `((~y)!) to-word text, as)
pattern(`(~x [~*as])):
Atomy Patterns Attribute new(x, ."[]", as)
pattern('_):
Atomy Patterns Any new
pattern(`(~h . ~t)):
Atomy Patterns HeadTail new(pattern(h), pattern(t))
pattern(`(~p = ~d)):
Atomy Patterns Default new(pattern(p), d)
pattern(`$0):
Atomy Patterns NamedGlobal new("0")
pattern(`$exception):
Atomy Patterns NamedGlobal new("!")
pattern(`$path):
Atomy Patterns NamedGlobal new(":")
pattern(`$separator):
Atomy Patterns NamedGlobal new("/")
pattern(`$~(n: Constant)):
Atomy Patterns NamedGlobal new(n name)
pattern(`$~(n: StringLiteral)):
Atomy Patterns NamedGlobal new(n value)
pattern(`$~(n ? to-word)):
Atomy Patterns NamedGlobal new(n to-word text)
pattern(`@~(n ? to-word)):
Atomy Patterns NamedInstance new(n to-word text)
pattern(`&~x):
Atomy Patterns BlockPass new(pattern(x))
pattern(`*~x):
Atomy Patterns Splat new(pattern(x))
pattern('self):
Atomy Patterns Match new(.self)
pattern('true):
Atomy Patterns Match new(.true)
pattern('false):
Atomy Patterns Match new(.false)
pattern('nil):
Atomy Patterns Match new(.nil)
pattern(`.~(x ? to-word)):
Atomy Patterns Literal new(x to-word text)
pattern(`.~(x: Constant)):
Atomy Patterns Literal new(x name)
pattern(`.~(x: StringLiteral)):
Atomy Patterns Literal new(x value to-sym)
pattern(`(~a & ~b)):
Atomy Patterns And new(pattern(a), pattern(b))
pattern(`(~a | ~b)):
Atomy Patterns Or new(pattern(a), pattern(b))
pattern(`(~x with(~e, ~y))):
Atomy Patterns With new(pattern(x), pattern(y), e)
pattern(`(with(~e, ~y))):
Atomy Patterns With new(Atomy Patterns Any new, pattern(y), e)
Jump to Line
Something went wrong with that request. Please try again.