The Dying PARSE3-BASED FUNC Wrapper
Here's a snapshot of the code that was written to PARSE the spec, and produce a new one...creating any necessary objects for <static> etc.
As a shortcut, it first did a search with FIND to see if the spec contained any TAG!. If it did not, it would fall through to the normal func. (Though this did mean that any <local> tags would trigger the longer version, even though that was supplied by FUNC.)
It used PARSE3 because UPARSE was built on top of it, and because it would of course be way too slow at this time.
As I often say about these things... as grotesque as they may seem, they exercise the system asking if we can do certain things in usermode. And it shows a good bet for not having written this as tailored native code, because that would all be getting thrown out right now!
And it's not getting completely thrown out... because it's shifting to be part of the test code (and I'm making it use UPARSE, since the performance no longer matters).
/function: func [
"Augment action with <static>, <in>, <with> features"
return: [action?]
spec "Help string (opt) followed by arg words (and opt type and string)"
[block!]
body "The body block of the function"
[<const> block!]
<local>
new-spec var loc other
new-body defaulters statics
][
; The lower-level FUNC is implemented as a native, and this wrapper
; does a fast shortcut to check to see if the spec has no tags...and if
; not, it quickly falls through to that fast implementation.
;
all [
not find spec tag?/
return func spec body
]
; Rather than MAKE BLOCK! LENGTH OF SPEC here, we copy the spec and clear
; it. This costs slightly more, but it means we inherit the file and line
; number of the original spec...so when we pass NEW-SPEC to FUNC or PROC
; it uses that to give the FILE OF and LINE OF the function itself.
;
; !!! General API control to set the file and line on blocks is another
; possibility, but since it's so new, we'd rather get experience first.
;
new-spec: clear copy spec ; also inherits binding
new-body: null
statics: null
defaulters: null
var: #dummy ; enter PARSE with truthy state (gets overwritten)
loc: null
parse3 spec [opt some [
:(if var '[ ; so long as we haven't reached any <local> or <with> etc.
var: [
&set-word? | &get-word? | &any-word? | &refinement?
| quoted!
| the-group! ; new soft-literal format
] (
append new-spec var
)
|
other: block! (
append new-spec other ; data type blocks
)
|
other: across some text! (
append new-spec spaced other ; spec notes
)
] else [
'bypass
])
|
other: group! (
if not var [
fail [
; <where> spec
; <near> other
"Default value not paired with argument:" (mold other)
]
]
defaulters: default [inside body copy '[]]
append defaulters spread compose [
(var): default (meta eval inside spec other)
]
)
|
(var: null) ; everything below this line resets var
bypass ; failing here means rolling over to next rule
|
'<local> (append new-spec <local>)
opt some [var: word! other: opt group! (
append new-spec var
if other [
defaulters: default [inside body copy '[]]
append defaulters spread compose [ ; always sets
(var): (meta eval inside spec other)
]
]
)]
(var: null) ; don't consider further GROUP!s or variables
|
'<in> (
new-body: default [
copy:deep body
]
)
opt some [
other: [object! | word! | tuple!] (
if not object? other [
other: ensure [any-context?] get inside spec other
]
new-body: bind other new-body
)
]
|
'<with> opt some [
other: [word! | path!] ; !!! Check if bound?
|
text! ; skip over as commentary
]
|
; For static variables to see each other, the GROUP!s can't have an
; hardened context. We ignore their binding here for now.
;
; https://rebol.metaeducation.com/t/2132
;
'<static> (
statics: default [copy inside spec '[]]
new-body: default [
copy:deep body
]
)
opt some [
var: word!, other: opt group! (
append statics setify var
append statics any [
bindable maybe other ; !!! ignore binding on group
'~
]
)
]
(var: null)
|
<end> accept (~)
|
other: <here> (
fail [
; <where> spec
; <near> other
"Invalid spec item:" @(other.1)
"in spec" @spec
]
)
]]
if statics [
statics: make object! statics
new-body: bind statics new-body
]
; The constness of the body parameter influences whether FUNC will allow
; mutations of the created function body or not. It's disallowed by
; default, but TWEAK can be used to create variations e.g. a compatible
; implementation with Rebol2's FUNC.
;
if const? body [new-body: const new-body]
return func new-spec either defaulters [
append defaulters as group! bindable any [new-body body]
][
any [new-body body]
]
]