REBOL [
    Title: "REBOL Rebcode Assembler"
]

context [
    words: system/internal/rebcodes
    ; I'd like to autogenerate it, but currently system/internal/rebcodes is not
    ; accurate enough.
    ;opcode-rule: [ ]
    ;arg: none
    ;foreach word next first words [
    ;    insert tail opcode-rule to lit-word! word
    ;    parse get in words word [
    ;        some [
    ;            string! ; just docs
    ;            |
    ;            copy arg [word! some ['| word!]] (insert/only tail opcode-rule arg)
    ;            |
    ;            set arg word! (insert tail opcode-rule arg)
    ;        ]
    ;    ]
    ;    insert tail opcode-rule '|
    ;]
    ;remove back tail opcode-rule
    opcode-rule: [
        'set word! any-type!  |
        'seti word! [word! | integer!] |
        'setd word! [word! | decimal!] |
        'flag? word!  |
        'add word! [word! | integer!] |
        'sub word! [word! | integer!] |
        'mul word! [word! | integer!] |
        'div word! [word! | integer!] |
        'rem word! [word! | integer!] |
        'neg word! |
        'abs word! |
        'min word! [word! | integer!] |
        'max word! [word! | integer!] | 
        'eq word! [word! | integer!] | 
        'neq word! [word! | integer!] | 
        'gt word! [word! | integer!] | 
        'lt word! [word! | integer!] | 
        'gteq word! [word! | integer!] |
        'lteq word! [word! | integer!] |
        'addd word! [word! | decimal!] |
        'subd word! [word! | decimal!] |
        'muld word! [word! | decimal!] |
        'divd word! [word! | decimal!] |
        'negd word! |
        'absd word! |
        'mind word! [word! | decimal!] |
        'maxd word! [word! | decimal!] |
        'eqd word! [word! | decimal!] |
        'neqd word! [word! | decimal!] |
        'gtd word! [word! | decimal!] |
        'ltd word! [word! | decimal!] |
        'gteqd word! [word! | decimal!] |
        'lteqd word! [word! | decimal!] |
        'and word! [word! | integer!] |
        'or word! [word! | integer!] |
        'xor word! [word! | integer!] |
        'lsl word! [word! | integer!] |
        'lsr word! [word! | integer!] |
        'cmpl word! |
        'to-int word! word! |
        'to-dec word! word! |
        'randz word! |
        'sqrt word! |
        'exp word! |
        'log-10 word! |
        'log-e word! |
        'cos word! |
        'sin word! |
        'tan word! |
        'acos word! |
        'asin word! |
        'atan word! |
        'length? word! word! |
        'index? word! word! |
        'pick word! word! integer! |
        'poke word! integer! any-type! |
        'insert word! any-type! |
        'change word! any-type! |
        'remove word! integer! |
        'clear word! |
        'skip word! integer! |
        'next word! |
        'back word! |
        'head word! |
        'tail word! |
        'head? word! |
        'tail? word! |
        'past? word! |
        'do word! block! |
        'return any-type! |
        'exit |
        'break any-type! |
        'ift block! |
        'iff block! |
        'either block! block! |
        'loop integer! block! |
        'repeat word! integer! block! |
        'repeatz word! integer! block! |
        'until block! |
        'while block! block! |
        'value? word! |
        'type? word! word! |
        'bra [word! | integer!] |
        'braw word! |
        'brat [word! | integer!] |
        'braf [word! | integer!] |
        'label word! |
        'probe any-type! |
        '?? word! |
        'print any-type! |
        'escape?
    ]
    
    userdef-rule: [ ]
    
    set 'rebcode-define func [
        "Define rebcode macros (iterative rewriting assembler)"
        definitions [block!]
        /local pattern prod here start end
    ] [
        parse definitions [
            some [
                copy pattern to #==> skip copy prod to '. skip
                (insert insert insert/only insert insert insert tail userdef-rule 
                    [start:] pattern [end:] to paren! compose/only [end: change/part start compose/deep (prod) end] [:end] '|)
                | here: skip (make error! reform ["Syntax error:" mold here])
            ]
        ]
    ]
    
    ; example: set w set-word! set v skip #==> set (to word! w) (:v) .
    
    rewrite: func [block /local flag val here] [
        ; rewrite outer block
        if empty? userdef-rule [exit] ; nothing to rewrite
        remove back tail userdef-rule
        until [
            flag: true
            parse block [
                some [
                    userdef-rule (flag: false)
                    |
                    opcode-rule
                    |
                    here: skip (make error! reform ["Syntax error (rewriting):" mold here])
                ]
            ]
            flag
        ]
        ; rewrite inner blocks
        parse block [
            some [
                ; special
                'ift set val block! (rewrite val) |
                'iff set val block! (rewrite val) |
                'either set val block! (rewrite val) set val block! (rewrite val) |
                'loop integer! set val block! (rewrite val) |
                'repeat word! integer! set val block! (rewrite val) |
                'repeatz word! integer! set val block! (rewrite val) |
                'until set val block! (rewrite val) |
                'while set val block! (rewrite val) set val block! (rewrite val)
                |
                opcode-rule
                |
                here: skip (make error! reform ["Syntax error (rewriting):" mold here])
            ]
        ]
        insert tail userdef-rule '|
    ]
    
    fix-bl: func [block /local labels here label] [
        labels: make block! 16
        parse block [
            some [
                here:
                ; special
                'ift set val block! (here/1: bind here/1 words fix-bl val) |
                'iff set val block! (here/1: bind here/1 words fix-bl val) |
                'either set val block! (here/1: bind here/1 words fix-bl val) set val block! (fix-bl val) |
                'loop integer! set val block! (here/1: bind here/1 words fix-bl val) |
                'repeat word! integer! set val block! (here/1: bind here/1 words fix-bl val) |
                'repeatz word! integer! set val block! (here/1: bind here/1 words fix-bl val) |
                'until set val block! (here/1: bind here/1 words fix-bl val) |
                'while set val block! (here/1: bind here/1 words fix-bl val) set val block! (here/1: bind here/1 words fix-bl val)
                |
                'label word! (here/1: bind here/1 words insert insert tail labels here/2 index? here)
                |
                opcode-rule (here/1: bind here/1 words)
                |
                ;skip (make error! reform ["Syntax error (fixing binding and labels 1):" mold here])
                skip (make error! reform ["Syntax error (fixing binding and labels 1):" mold here])
            ]
        ]
        parse block [
            some [
                here:
                ; fix labels
                ['bra word! | 'brat word! | 'braf word!] (
                    if not label: select labels here/2 [
                        make error! reform ["Missing label:" mold here]
                    ]
                    here/2: label - index? here
                )
                |
                opcode-rule
                |
                skip (make error! reform ["Syntax error (fixing binding and labels 2):" mold here])
            ]
        ]
    ]
    
    system/internal/assemble: func [
        "REBCODE Assembler"
        body 
        /local frame here do-blks labels tmp rule
    ] [
        body: second :body
        ; -- Iterative rewriting assembler
        rewrite body
        ; -- fix binding and labels
        fix-bl body
    ]
]