TOPAZ-PARSE compiled rules

compiled-rules.red

make object! [
    collection: #[none]
    _result: #[none]
    _stack: []
    _push-state: func [][
        append/only _stack collection
    ]
    _pop-state: func [][
        collection: take/last _stack
    ]
    _set: func [word][either map? collection [
        put collection word :_result
    ] [
        set word :_result
    ]]
    _get-collection: func [/local coll][
        coll: either map? collection [
            unless find collection 'children [
                collection/children: make block! 0
            ] 
            collection/children
        ] [
            collection
        ] 
        unless block? :coll [
            cause-error 'script 'parse-rule ["KEEP outside of COLLECT or OBJECT"]
        ] 
        coll
    ]
    _keep: func [][append _get-collection :_result]
    _keep-only: func [][append/only _get-collection :_result]
    _apply: func [word args /local rule-func rule-arg value][rule-func: select _functions word 
        append/only rule-func/stack values-of rule-func/context 
        set rule-func/context args 
        foreach rule-arg rule-func/parsed-spec [
            value: select rule-func/context rule-arg/word 
            switch type?/word :value [
                word! [put rule-func/context rule-arg/word value: get value] paren! [put rule-func/context rule-arg/word value: do value]
            ] if rule-arg/type [
                unless find rule-arg/type type? :value [
                    cause-error 'script 'expect-arg [
                        word 
                        type? :value 
                        rule-arg/word
                    ]
                ]
            ]
        ]
    ]
    _return: func [word /local rule-func][rule-func: select _functions word 
        set rule-func/context take/last rule-func/stack
    ]
    _reset: func [/local rule-func][collection: _result: none 
        clear _stack 
        if value? '_functions [
            foreach rule-func values-of _functions [
                set rule-func/context none 
                clear rule-func/stack
            ]
        ]
    ]
    alternatives: [[(
        _push-state 
        collection: make map! []
    ) [[[(_result: ('alternatives))] (_set 'name) [[(_push-state) sequence (_pop-state) | (_pop-state) fail]] (_keep) any [[[set _result [ahead word! '|] [[(_push-state) sequence (_pop-state) | (_pop-state) fail]] (_keep)]] | (_result: none) fail] end (_result: none)]] (
        _result: collection 
        _pop-state
    ) | (_pop-state) fail]]
    sequence: [[(
        _push-state 
        collection: make map! []
    ) [[[(_result: ('sequence))] (_set 'name) any [[[not [[ahead word! '|]] [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep)]] | (_result: none) fail]]] (
        _result: collection 
        _pop-state
    ) | (_pop-state) fail]]
    top-level: [[(
        _push-state 
        collection: make map! []
    ) [[[[set _result [ahead word! 'collect] | set _result [ahead word! 'copy] | set _result [ahead word! 'object]]] (_set 'name) [[(_push-state) element (_pop-state) | (_pop-state) fail]] (_keep) | [[set _result [ahead word! 'keep]] (_set 'name) [(_result: (false))] (_set 'only?) | set _result keep/only [(_result: ('keep))] (_set 'name) [(_result: (true))] (_set 'only?)] [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep) | [set _result [ahead word! 'if]] (_set 'name) [set _result paren!] (_keep-only) | [set _result set-word!] (_keep) [(_result: ('set))] (_set 'name) [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep) | [set _result [ahead word! 'also]] (_set 'name) [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep) [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep)]] (
        _result: collection 
        _pop-state
    ) | (_pop-state) fail] | [(_push-state) 
        element (_pop-state) | (_pop-state) fail
    ]]
    element: [ahead block! into [[(_push-state) alternatives (_pop-state) | (_pop-state) fail]] | [(
        _push-state 
        collection: make map! []
    ) [[[[set _result [ahead word! 'opt] | set _result [ahead word! 'any] | set _result [ahead word! 'some] | set _result [ahead word! 'not] | set _result [ahead word! 'to] | set _result [ahead word! 'thru]]] (_set 'name) [[(_push-state) element (_pop-state) | (_pop-state) fail]] (_keep) | [[set _result integer! | set _result word! if (integer! = type? get/any _result)]] (_keep) [(_result: ('loop))] (_set 'name) [[(_push-state) element (_pop-state) | (_pop-state) fail]] (_keep) | [set _result [ahead word! 'literal] | set _result [ahead word! 'quote]] [(_result: ('literal))] (_set 'name) [set _result skip] (_keep) | [set _result [ahead word! 'skip] | set _result [ahead word! '*]] [(_result: ('skip))] (_set 'name) | [[set _result [ahead word! 'end] | set _result [ahead word! 'here]]] (_set 'name) | [set _result [ahead word! 'into]] (_set 'name) [[[[set _result datatype|typeset | set _result word! if (find datatype|typeset type? get/any _result)]] | (_result: none)]] (_set 'type) [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep) | [set _result [ahead word! 'get]] (_set 'name) [[set _result datatype|typeset | set _result word! if (find datatype|typeset type? get/any _result)]] (_keep) | [[set _result datatype|typeset | set _result word! if (find datatype|typeset type? get/any _result)]] (_keep) [(_result: ('match-type))] (_set 'name) | [[set _result block! | set _result word! if (block! = type? get/any _result)]] (_keep) [(_result: ('rule))] (_set 'name) | [[set _result map! | set _result word! if (map! = type? get/any _result)]] (_keep) (_result: (handle-map collection)) [if (collection/name = 'rule-function) (_result: (nargs: collection/nargs)) nargs [[set _result skip] (_keep-only)] | if (collection/name = 'rule-function-argument) [if (collection/mode = 'loop) [[(_push-state) element (_pop-state) | (_pop-state) fail]] (_keep) | if (collection/mode = 'match-value)] | if (collection/name = 'match-value)] | [set _result paren!] (_keep-only) [(_result: ('paren))] (_set 'name) | [[set _result any-function! | set _result word! if (find any-function! type? get/any _result)]] (_keep) [(_result: ('filter))] (_set 'name) [[(_push-state) top-level (_pop-state) | (_pop-state) fail]] (_keep)]] (
        _result: collection 
        _pop-state
    ) | (_pop-state) fail] | [(
        _push-state 
        collection: make map! []
    ) [[[(_result: ('match-value))] (_set 'name) [set _result skip] (_keep-only)]] (
        _result: collection 
        _pop-state
    ) | (_pop-state) fail]]
    datatype|typeset: make typeset! [datatype! typeset!]
    nargs: 0
    any-function!: make typeset! [native! action! op! function! routine!]
    handle-map: func [node [map!] /local rule-func][rule-func: node/children/1 
        if word? rule-func [rule-func: get rule-func] switch/default rule-func/name [
            rule-function [
                node/name: 'rule-function 
                node/nargs: length? rule-func/parsed-spec
            ] 
            rule-function-argument [
                node/name: 'rule-function-argument 
                node/mode: either rule-func/type = make typeset! [integer!] ['loop] ['match-value]
            ]
        ] [node/name: 'match-value]
    ]
    _parse: func [input][_reset 
        if parse input [alternatives to end] [:_result]
    ]
]