DSL Example

dsl-example.r2

Rebol [
    Title: "DSL Example"
    Author: "Christopher Ross-Gill"
    Date: 29-Jan-2023
    Home: https://gist.github.com/rgchris/2a227b6fa3fc9d2ae7fe729ccb09f016
]

reduce-only: func [
    "Evaluates a block of expressions excepting SET-WORD! values"

    block [block!]
    "Block to evaluate"

    /local value
][
    collect [
        while [
            not tail? block
        ][
            either set-word? first block [
                keep first block
                block: next block
            ][
                set [value block] do/next block
                keep/only :value
            ]
        ]
    ]
]

do-with: func [
    "Evaluate a block with a collection of context-sensitive functions"

    body [block!]
    "Block to evaluate"

    context [block!]
    "Specification for the context-sensitive functions"

    /local
    args
][
    context: reduce-only context

    args: collect [
        foreach [name value] context [
            keep to get-word! name
        ]
    ]

    do collect [
        keep func args copy/deep body

        foreach [name value] context [
            keep/only :value
        ] 
    ]
]

collect-deep: func [
    "Evaluates a block, storing values via KEEP function, and returns block of collected values."

    body [block!]
    "Block to evaluate"

    /into
    "Insert into a buffer instead (returns position after insert)"

    output [block!]
    "The buffer series (modified)"

    /local stack
][
    stack: reduce [
        any [
            output
            make block! 16
        ]
    ]

    do-with body [
        keep: func [
            value /only
        ][
            stack/1: either only [
                insert/only stack/1 :value
            ][
                insert stack/1 :value
            ]
        ]

        push: func [
            /group
        ][
            insert/only stack make either group [paren!] [block!] 16
            stack/2: insert/only stack/2 stack/1
            stack/1
        ]

        pop: func [
            [catch]
        ][
            either tail? next stack [
                throw make error! "Cannot POP"
            ][
                stack/1: head stack/1
                take stack
            ]
        ]
    ]

    if not tail? next stack [
        throw make error! "POPs do not match PUSHes"
    ]

    either into [take stack] [head take stack]
]

probe collect-deep [
    keep 1
    push
    keep 2
    push
    keep 3
    keep 4
    pop
    keep 5
    pop
]