Skip to content

Instantly share code, notes, and snippets.

@ifgem
Last active January 14, 2017 16:17
Show Gist options
  • Save ifgem/12110ddfb0091d33798a957b09a2f964 to your computer and use it in GitHub Desktop.
Save ifgem/12110ddfb0091d33798a957b09a2f964 to your computer and use it in GitHub Desktop.
Red [
Author: "ifgem"
]
#do [
macro: context [
make-object-spec: function [words] [
spec: copy []
foreach word words [
append spec reduce [
to set-word! word
none
]
]
spec
]
copy-or-set: func [pattern] [
either any [
pattern/1 = 'any
pattern/1 = 'some
integer? pattern/1
] ['copy] ['set]
]
make-rule: func [rule words name pattern] [
either name [
append rule reduce [
copy-or-set pattern
name
pattern
]
append words name
] [
append/only rule pattern
]
]
to-rule: function [spec body] [
rule: copy []
words: copy []
parse spec [
any [
set name opt word!
set pattern block!
(make-rule rule words name pattern)
]
]
; hide words used in the rule:)
hidden-context: make object! make-object-spec words
bind rule hidden-context
bind body hidden-context
rule
]
to-debug-rule: func [
spec body
/local
rule words
hidden-context
] [
rule: copy []
words: copy []
parse spec [
any [
set name opt word!
set pattern block!
(make-rule rule words name pattern)
]
]
rule: compose/only [
copy macro-match (rule)
]
hidden-context: make object! make-object-spec words
bind rule hidden-context
bind body hidden-context
reduce [rule hidden-context]
]
local: function [body [block!]] [
local-words: copy []
parse body [
any [
remove ['local set val [word! | block!]]
(append local-words val)
| change ['local set val set-word!]
(append local-words to word! val
val)
| skip
]
]
local-words
]
replacement: []
quote: func [
block [block!]
/local val
] [
block: copy block
parse block [
any [
change only ['unquote set val [word! | block!]] (
either block? val [
do val
] [
get val
]
)
| skip
]
]
append replacement block
]
writer: func [recursive? name? spec body] [
bind body 'quote
either name? [
name?: to lit-word! name?
] [
name?: 'none
]
compose/deep [
#macro [
(name?)
(to-rule spec body)
] func [
[manual] start end
/local
macro-end
(local body)
] [
macro/replacement: copy []
(body)
macro-end: change/part start
macro/replacement
end
(either recursive? [
'start
] [
'macro-end
])
]
]
]
debugger: func [
recursive? name? spec body
/local rule-context
] [
rule-context: to-debug-rule spec body
;probe rule-context/1
bind body 'quote
either name? [
name?: to lit-word! name?
] [
name?: 'none
]
compose/deep [
#macro [
(name?)
(rule-context/1)
] func [
[manual] start end
/local
macro-end
(macro/local body)
] [
macro/replacement: copy []
(body)
macro-end: change/part start
macro/replacement
end
print "MATCH RESULT"
print "HIDDEN CONTEXT"
probe (rule-context/2)
print "BEFORE"
probe macro-match
print "AFTER"
probe macro/replacement
;print "MATCH END"
(either recursive? [
'start
] [
'macro-end
])
]
]
]
]
]
#macro [
set template-debug? opt 'debug
set template-recursive? opt 'recursive
'template
set template-name opt word!
set template-spec block!
set template-body block!
] func [[manual] start end /local name? template] [
if template-debug? [
template: macro/writer
template-recursive?
template-name
copy template-spec
copy template-body
]
change/part start
either template-debug? [
macro/debugger
template-recursive?
template-name
template-spec
template-body
] [
macro/writer
template-recursive?
template-name
template-spec
template-body
]
end
if template-debug? [
print "TEMPLATE"
probe template
;print "TEMPLATE END"
]
start ; process generated macro
]
debug recursive template [times [integer!] ['times] body [block!]] [
quote [
loop unquote times unquote body
]
]
5 times [
print "hello"
2 times [
print "world"
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment