Red/System [

Title: "PARSE dialect interpreter"

Author: "Nenad Rakocevic"

File: %parse.reds

Tabs: 4

Rights: "Copyright (C) 2011-2018 Red Foundation. All rights reserved."

License: {

]

parser: context [

verbose: 0

series: as red-block! 0

rules: as red-block! 0

#define PARSE_MAX_DEPTH 10'000

#define PARSE_SAVE_SERIES [ ;-- protect series stack from recursive calls

len: block/rs-length? series

series/head: series/head + len

]

#define PARSE_RESTORE_SERIES [

series/head: series/head - len

]

#define PARSE_PUSH_INPUTPOS [

in: as input! ALLOC_TAIL(rules)

in/header: TYPE_TRIPLE

in/node: input/node

;in/size: input/head

]

#define PARSE_PUSH_POSITIONS [

p: as positions! ALLOC_TAIL(rules)

p/header: TYPE_TRIPLE

p/rule: (as-integer cmd - block/rs-head rule) >> 4 ;-- save cmd position

p/input: input/head ;-- save input position

p/sub: len ;-- default value for sub-rule type

]

#define PARSE_SET_INPUT_LENGTH(word) [

word: _series/get-length as red-series! input no

]

#define PARSE_CHECK_INPUT_EMPTY? [

end?: any [

_series/rs-tail? as red-series! input

all [positive? part input/head >= part]

]

]

#define PARSE_COPY_INPUT(slot) [

min: p/input

new: as red-series! slot

copy-cell as red-value! input as red-value! new

copy-cell as red-value! input base ;@@ remove once OPTION? fixed

new/head: min

actions/copy new as red-value! new base no null

]

#define PARSE_PICK_INPUT [

value: base

switch TYPE_OF(input) [

TYPE_BINARY [

int2: as red-integer! base

int2/header: TYPE_INTEGER

int2/value: binary/rs-abs-at as red-binary! input offset

]

TYPE_ANY_STRING [

char: as red-char! base

char/header: TYPE_CHAR

char/value: string/rs-abs-at as red-string! input offset

]

default [value: block/rs-abs-at input offset]

]

]

#define PARSE_TRACE(event) [

#if red-tracing? = yes [

if OPTION?(fun) [

head: (as-integer cmd - block/rs-head rule) >> 4

if negative? head [head: 0]

unless fire-event fun words/event match? rule input fun-locs head saved? [

return as red-value! logic/push match?

]

]

]

]

#define PARSE_ERROR [

reset saved?

fire

]

#enum states! [

ST_PUSH_BLOCK

ST_POP_BLOCK

ST_PUSH_RULE

ST_POP_RULE

ST_CHECK_PENDING

ST_DO_ACTION

ST_NEXT_INPUT

ST_NEXT_ACTION

ST_MATCH

ST_MATCH_RULE

ST_FIND_ALTERN

ST_WORD

ST_END

ST_EXIT

]

#enum rule-flags! [ ;-- negative values to not collide with t/state counter

R_NONE: -1

R_TO: -2

R_THRU: -3

R_COPY: -4

R_SET: -5

R_NOT: -6

R_INTO: -7

R_REMOVE: -9

R_INSERT: -10

R_WHILE: -11

R_COLLECT: -12

R_KEEP: -13

R_KEEP_PAREN: -14

R_AHEAD: -16

R_CHANGE: -17

R_CHANGE_ONLY: -18

R_CASE: -19

R_PICK_FLAG: 1

]

triple!: alias struct! [

header [integer!]

min [integer!]

max [integer!]

state [integer!]

]

positions!: alias struct! [

header [integer!]

rule [integer!]

input [integer!]

sub [integer!]

]

input!: alias struct! [

header [integer!]

head [integer!]

node [node!]

pos [integer!]

]

#if debug? = yes [

print-state: func [s [states!]][

print "state: "

print-line switch s [

ST_PUSH_BLOCK ["ST_PUSH_BLOCK"]

ST_POP_BLOCK ["ST_POP_BLOCK"]

ST_PUSH_RULE ["ST_PUSH_RULE"]

ST_POP_RULE ["ST_POP_RULE"]

ST_CHECK_PENDING ["ST_CHECK_PENDING"]

ST_DO_ACTION ["ST_DO_ACTION"]

ST_NEXT_INPUT ["ST_NEXT_INPUT"]

ST_NEXT_ACTION ["ST_NEXT_ACTION"]

ST_MATCH ["ST_MATCH"]

ST_MATCH_RULE ["ST_MATCH_RULE"]

ST_FIND_ALTERN ["ST_FIND_ALTERN"]

ST_WORD ["ST_WORD"]

ST_END ["ST_END"]

ST_EXIT ["ST_EXIT"]

]

]

]

transfer: func [

src [red-series!]

h2 [integer!]

out [red-series!]

append? [logic!]

return: [logic!] ;-- FALSE if fast-path is not taken

/local

s1 [series!]

s2 [series!]

unit [integer!]

size [integer!]

size1 [integer!]

len1 [integer!]

tail [byte-ptr!]

p [byte-ptr!]

h1 [integer!]

extra [integer!]

][

s1: GET_BUFFER(out) ;-- destination

s2: GET_BUFFER(src) ;-- source

unit: GET_UNIT(s1)

if any [unit > 4 unit <> GET_UNIT(s2)][return false] ;-- block! values require an /only mode

h1: out/head << (log-b unit)

extra: src/head - h2

size: extra * unit

assert size > 0

len1: (as-integer s1/tail - s1/offset) << 4

size1: len1 + size

if (as byte-ptr! s1/size) < (as byte-ptr! size1) [ ;-- force an unsigned comparison

s1: expand-series s1 size1 * 2

]

append?: any [append? len1 = 0]

unless append? [

move-memory ;-- make space

(as byte-ptr! s1/offset) + h1 + size

(as byte-ptr! s1/offset) + h1

len1 - h1

]

tail: as byte-ptr! s1/tail

p: either append? [tail][(as byte-ptr! s1/offset) + h1]

copy-memory p (as byte-ptr! s2/offset) + (h2 * unit) size

p: p + size

unless append? [p: tail + size]

s1/tail: as cell! p

out/head: out/head + extra

true

]

compare-values: func [

value2 [red-value!]

value [red-value!]

comp-op [integer!]

return: [logic!]

/local

type [integer!]

][

type: TYPE_OF(value)

if any [type = TYPE_LIT_WORD type = TYPE_LIT_PATH][

comp-op: COMP_STRICT_EQUAL_WORD

]

actions/compare value2 value comp-op

]

match-datatype?: func [

input [red-binary!]

dt [red-datatype!]

dt-type [integer!]

return: [logic!]

/local

len type size [integer!]

s [series!]

buf pos [byte-ptr!]

match? [logic!]

][

len: 0

s: GET_BUFFER(input)

buf: (as byte-ptr! s/offset) + input/head

size: as-integer (as byte-ptr! s/tail) - buf

type: lexer/scan null buf size yes yes no no :len null null null

match?: either dt-type = TYPE_TYPESET [BS_TEST_BIT_ALT(dt type)][type = dt/value]

if match? [_series/rs-skip as red-series! input len - 1] ;-- -1 to account for later rs-skip

match?

]

advance: func [

str [red-string!]

value [red-value!] ;-- char! or string! value

return: [logic!]

/local

type [integer!]

len [integer!]

][

type: TYPE_OF(value)

len: either any [type = TYPE_CHAR type = TYPE_BITSET][1][

assert any [

ANY_STRING?(type)

type = TYPE_BINARY

]

string/rs-length? as red-string! value

]

if type = TYPE_TAG [len: len + 2]

_series/rs-skip as red-series! str len

]

find-altern: func [ ;-- search for next '| symbol

rule [red-block!]

pos [red-value!]

return: [integer!] ;-- >= 0 found, -1 not found

/local

head [red-value!]

tail [red-value!]

value [red-value!]

w [red-word!]

s [series!]

][

s: GET_BUFFER(rule)

head: s/offset + ((as-integer pos - s/offset) >> 4)

tail: s/tail

value: head

while [value < tail][

if TYPE_OF(value) = TYPE_WORD [

w: as red-word! value

if w/symbol = words/pipe [

return ((as-integer value - head) >> 4)

]

]

value: value + 1

]

-1

]

adjust-input-index: func [

input [red-series!]

pos [positions!]

base [integer!]

offset [integer!]

return: [logic!]

][

input/head: input/head + base + offset

pos/input: either zero? input/head [0][input/head - base]

yes

]

find-token?: func [ ;-- optimized fast token lookup

rules [red-block!] ;-- (could be optimized even further)

input [red-series!]

token [red-value!]

comp-op [integer!]

part [integer!]

saved? [logic!]

return: [logic!]

/local

pos* [positions!]

head [red-value!]

tail [red-value!]

value [red-value!]

char [red-char!]

bits [red-bitset!]

s [series!]

p [byte-ptr!]

phead [byte-ptr!]

ptail [byte-ptr!]

pbits [byte-ptr!]

pos [byte-ptr!] ;-- required by BS_TEST_BIT

p4 [int-ptr!]

cp [integer!]

size [integer!]

unit [integer!]

type [integer!]

res [integer!]

set? [logic!] ;-- required by BS_TEST_BIT

not? [logic!]

bin? [logic!]

match? [logic!]

][

s: GET_BUFFER(rules)

assert s/offset <= (s/tail - 2)

pos*: as positions! s/tail - 2

s: GET_BUFFER(input)

type: TYPE_OF(input)

either any [

ANY_STRING?(type)

type = TYPE_BINARY

][

unit: GET_UNIT(s)

phead: (as byte-ptr! s/offset) + (input/head << (log-b unit))

ptail: as byte-ptr! s/tail

if positive? part [

p: (as byte-ptr! s/offset) + (part << (log-b unit))

if p < ptail [ptail: p]

]

p: phead

switch TYPE_OF(token) [

TYPE_BITSET [

bits: as red-bitset! token

s: GET_BUFFER(bits)

pbits: as byte-ptr! s/offset

not?: FLAG_NOT?(s)

size: (as-integer s/tail - s/offset) << 3

until [

cp: switch unit [

Latin1 [as-integer p/value]

UCS-2 [(as-integer p/2) << 8 + p/1]

UCS-4 [p4: as int-ptr! p p4/value]

]

either size < cp [

match?: not? ;-- virtual bit

][

BS_TEST_BIT(pbits cp match?)

]

if match? [

return adjust-input-index input pos* 1 ((as-integer p - phead) >> (log-b unit))

]

p: p + unit

p >= ptail

]

]

TYPE_ANY_STRING

TYPE_BINARY [

bin?: type = TYPE_BINARY

type: TYPE_OF(token)

if all [bin? type <> TYPE_BINARY not ANY_STRING?(type)][

PARSE_ERROR [TO_ERROR(script parse-rule) token]

]

size: string/rs-length? as red-string! token

if type = TYPE_TAG [size: size + 2]

if (string/rs-length? as red-string! input) < size [return no]

phead: as byte-ptr! s/offset

unit: log-b unit

until [

res: switch type [

TYPE_BINARY [

binary/equal? as red-binary! input as red-binary! token comp-op yes

]

TYPE_TAG [

either string/match-tag? as red-string! input token comp-op [

input/head: input/head + 1

res: string/equal? as red-string! input as red-string! token comp-op yes

input/head: input/head - 1

res

][1] ;-- force failure

]

default [

string/equal? as red-string! input as red-string! token comp-op yes

]

]

if zero? res [return adjust-input-index input pos* size 0]

input/head: input/head + 1

phead + (input/head + size << unit) > ptail

]

]

TYPE_CHAR [

char: as red-char! token

cp: char/value

switch unit [

Latin1 [

while [p < ptail][

if p/value = as-byte cp [

return adjust-input-index input pos* 1 (as-integer p - phead)

]

p: p + 1

]

]

UCS-2 [

while [p < ptail][

if (as-integer p/2) << 8 + p/1 = cp [

return adjust-input-index input pos* 1 ((as-integer p - phead) >> 1)

]

p: p + 2

]

]

UCS-4 [

p4: as int-ptr! p

while [p4 < as int-ptr! ptail][

if p4/value = cp [

return adjust-input-index input pos* 1 ((as-integer p4 - phead) >> 2)

]

p4: p4 + 1

]

]

]

]

default [

PARSE_ERROR [TO_ERROR(script parse-rule) token]

]

]

][

head: s/offset + input/head

tail: s/tail

if positive? part [

value: s/offset + part

if value < tail [tail: value]

]

value: head

while [value < tail][

if compare-values value token comp-op [

return adjust-input-index input pos* 1 ((as-integer value - head) >> 4)

]

value: value + 1

]

]

no

]

loop-bitset: func [ ;-- optimized bitset matching loop

input [red-series!]

bits [red-bitset!]

min [integer!]

max [integer!]

counter [int-ptr!]

part [integer!]

return: [logic!]

/local

s [series!]

unit [integer!]

p [byte-ptr!]

phead [byte-ptr!]

ptail [byte-ptr!]

pbits [byte-ptr!]

pos [byte-ptr!] ;-- required by BS_TEST_BIT

p4 [int-ptr!]

cp [integer!]

cnt [integer!]

size [integer!]

set? [logic!] ;-- required by BS_TEST_BIT

not? [logic!]

max? [logic!]

match? [logic!]

][

s: GET_BUFFER(input)

unit: GET_UNIT(s)

phead: (as byte-ptr! s/offset) + (input/head << (log-b unit))

ptail: as byte-ptr! s/tail

if positive? part [

p: (as byte-ptr! s/offset) + (part << (log-b unit))

if p < ptail [ptail: p]

]

p: phead

s: GET_BUFFER(bits)

pbits: as byte-ptr! s/offset

not?: FLAG_NOT?(s)

size: (as-integer s/tail - s/offset) << 3

cnt: 0

match?: yes

max?: max <> R_NONE

until [

cp: switch unit [

Latin1 [as-integer p/value]

UCS-2 [(as-integer p/2) << 8 + p/1]

UCS-4 [p4: as int-ptr! p p4/value]

]

either size < cp [ ;-- virtual bit

match?: not?

][

BS_TEST_BIT(pbits cp match?)

]

if match? [

p: p + unit

cnt: cnt + 1

]

any [

not match?

p = ptail

all [max? cnt >= max]

]

]

input/head: input/head + ((as-integer p - phead) >> (log-b unit))

counter/value: cnt

either not max? [min <= cnt][all [min <= cnt cnt <= max]]

]

loop-char: func [ ;-- optimized bitset matching loop

input [red-series!]

char [red-char!]

comp-op [integer!]

min [integer!]

max [integer!]

counter [int-ptr!]

part [integer!]

return: [logic!]

/local

s [series!]

unit [integer!]

c c0 u [integer!]

p [byte-ptr!]

phead [byte-ptr!]

ptail [byte-ptr!]

p4 [int-ptr!]

table [int-ptr!]

cp [integer!]

cnt [integer!]

size [integer!]

max? [logic!]

match? [logic!]

][

s: GET_BUFFER(input)

unit: GET_UNIT(s)

phead: (as byte-ptr! s/offset) + (input/head << (log-b unit))

ptail: as byte-ptr! s/tail

if positive? part [

p: (as byte-ptr! s/offset) + (part << (log-b unit))

if p < ptail [ptail: p]

]

p: phead

c: char/value

cnt: 0

match?: yes

max?: max <> R_NONE

either comp-op = COMP_STRICT_EQUAL [

switch unit [

Latin1 [

until [

cp: as-integer p/value

if cp <> c [break]

cnt: cnt + 1

p: p + 1

if max? [if cnt >= max [break]]

p = ptail

]

]

UCS-2 [

until [

cp: (as-integer p/2) << 8 + p/1

if cp <> c [break]

cnt: cnt + 1

p: p + 2

if max? [if cnt >= max [break]]

p = ptail

]

]

UCS-4 [

p4: as int-ptr! p

until [

cp: p4/value

if cp <> c [break]

cnt: cnt + 1

p4: p4 + 1

if max? [if cnt >= max [break]]

p4 = as int-ptr! ptail

]

]

]

][

table: case-folding/upper-table

either c <= FFFFh [ ;-- uppercase C before entering the search loop

u: table/c

if u <> 0 [c: u]

][

c: case-folding/change-char c yes

]

switch unit [

Latin1 [

until [

cp: as-integer p/value

u: table/cp

if u <> 0 [cp: u]

if cp <> c [break]

cnt: cnt + 1

p: p + 1

if max? [if cnt >= max [break]]

p = ptail

]

]

UCS-2 [

until [

cp: (as-integer p/2) << 8 + p/1

u: table/cp

if u <> 0 [cp: u]

if cp <> c [break]

cnt: cnt + 1

p: p + 2

if max? [if cnt >= max [break]]

p = ptail

]

]

UCS-4 [

p4: as int-ptr! p

until [

cp: p4/value

either cp <= FFFFh [

u: table/cp

if u <> 0 [cp: u]

][

cp: case-folding/change-char cp yes

]

if cp <> c [break]

cnt: cnt + 1

p4: p4 + 1

if max? [if cnt >= max [break]]

p4 = as int-ptr! ptail

]

]

]

]

input/head: input/head + ((as-integer p - phead) >> (log-b unit))

counter/value: cnt

either not max? [min <= cnt][all [min <= cnt cnt <= max]]

]

loop-token: func [ ;-- fast literal matching loop

input [red-series!]

token [red-value!]

min [integer!]

max [integer!]

counter [int-ptr!]

comp-op [integer!]

part [integer!]

return: [logic!]

/local

len [integer!]

cnt [integer!]

type [integer!]

type2 [integer!]

match? [logic!]

end? [logic!]

s [series!]

][

PARSE_SET_INPUT_LENGTH(len)

if any [zero? len len < min][return no] ;-- input too short

cnt: 0

match?: yes

type: TYPE_OF(input)

type2: TYPE_OF(token)

either any [

ANY_STRING?(type)

type = TYPE_BINARY

][

switch type2 [

TYPE_BITSET [

match?: loop-bitset input as red-bitset! token min max counter part

cnt: counter/value

]

TYPE_CHAR [

match?: loop-char input as red-char! token comp-op min max counter part

cnt: counter/value

]

default [

unless any [ANY_STRING?(type2) type2 = TYPE_BINARY][return no]

len: string/rs-length? as red-string! token

if zero? len [return yes]

if type2 = TYPE_TAG [len: len + 2]

until [ ;-- ANY-STRING input matching

match?: either type = TYPE_BINARY [

binary/match? as red-binary! input token comp-op

][

string/match? as red-string! input token comp-op

]

end?: any [

all [match? _series/rs-skip input len] ;-- consume matched input

all [positive? part input/head >= part]

]

cnt: cnt + 1

any [

not match?

end?

all [max <> R_NONE cnt >= max]

]

]

]

]

][

until [ ;-- ANY-BLOCK input matching

match?: compare-values block/rs-head input token comp-op ;@@ sub-optimal!!

end?: any [

all [match? block/rs-next input] ;-- consume matched input

all [positive? part input/head >= part]

]

cnt: cnt + 1

any [

not match?

end?

all [max <> R_NONE cnt >= max]

]

]

]

either match? [

if all [max <> R_NONE any [min > cnt cnt > max]][match?: no]

][

cnt: cnt - 1

match?: either max = R_NONE [min <= cnt][all [min <= cnt cnt <= max]]

]

counter/value: cnt

match?

]

check-infinite-loop: func [

input [red-series!]

rules [red-block!]

rule [red-block!]

saved? [logic!]

/local

value [red-value!]

tail [red-value!]

blk [red-block!]

p [positions!]

in [input!]

node [node!]

s [series!]

][

s: GET_BUFFER(rules)

value: s/offset + rules/head

tail: s/tail

node: rule/node

while [value < tail][

if TYPE_OF(value) = TYPE_BLOCK [

blk: as red-block! value

if all [node = blk/node rule/head = blk/head value + 1 < tail][

p: as positions! value - 1

in: as input! value - 2

if all [

p/input = input/head

in/node = input/node

][

PARSE_ERROR [TO_ERROR(script parse-infinite) rule]

]

]

]

value: value + 1

]

]

check-limits: func [

series [red-block!]

rules [red-block!]

saved? [logic!]

/local

s [series!]

][

s: GET_BUFFER(series)

if (as-integer s/tail - s/offset) >> 4 > PARSE_MAX_DEPTH [

PARSE_ERROR [TO_ERROR(script parse-stack)]

]

s: GET_BUFFER(rules)

if (as-integer s/tail - s/offset) >> 4 > PARSE_MAX_DEPTH [

PARSE_ERROR [TO_ERROR(script parse-stack)]

]

]

fire-event: func [

fun [red-function!]

event [red-word!]

match? [logic!]

rule [red-block!]

input [red-series!]

locals [integer!]

offset [integer!]

saved? [logic!]

return: [logic!]

/local

loop? [logic!]

len [integer!]

saved [red-value!]

res [red-value!]

int [red-integer!]

more [series!]

ctx [node!]

][

PARSE_SAVE_SERIES

saved: stack/top

stack/top: stack/top + 1 ;-- keep last value from paren expression

more: as series! fun/more/value

int: as red-integer! more/offset + 4

ctx: either TYPE_OF(int) = TYPE_INTEGER [as node! int/value][global-ctx]

stack/mark-func words/_parse-cb fun/ctx

stack/push as red-value! event

logic/push match?

rule: as red-block! stack/push as red-value! rule

stack/push as red-value! input

stack/push as red-value! rules

if positive? locals [_function/init-locals locals]

rule/head: offset

assert system/thrown = 0

catch RED_THROWN_ERROR [interpreter/call fun ctx as red-value! words/_parse-cb CB_PARSE]

PARSE_RESTORE_SERIES ;-- restore localy saved series/head first

if system/thrown <> 0 [reset saved? re-throw]

loop?: logic/top-true?

stack/unwind

stack/top: saved

loop?

]

save-stack: func [

return: [logic!]

/local

cnt [integer!]

p [positions!]

saved? [logic!]

][

cnt: block/rs-length? rules

saved?: cnt <> 0

if saved? [

p: as positions! ALLOC_TAIL(rules)

p/header: TYPE_TRIPLE

p/input: series/head

p/rule: rules/head

series/head: series/head + block/rs-length? series

rules/head: rules/head + cnt + 1 ;-- account for the new position! slot

]

saved?

]

restore-stack: func [

/local

s [series!]

p [positions!]

][

if rules/head > 0 [

s: GET_BUFFER(rules)

s/tail: s/tail - 1

assert s/offset <= s/tail

p: as positions! s/tail

series/head: p/input

rules/head: p/rule

]

]

reset: func [saved? [logic!]][

_series/clear as red-series! series

_series/clear as red-series! rules

if saved? [restore-stack]

]

eval: func [

code [red-value!]

reset? [logic!]

saved? [logic!]

return: [red-value!]

/local

len [integer!]

saved [red-value!]

res [red-value!]

][

PARSE_SAVE_SERIES

saved: stack/top

assert system/thrown = 0

catch RED_THROWN_ERROR [interpreter/eval as red-block! code no]

PARSE_RESTORE_SERIES ;-- restore localy saved series/head first

if system/thrown <> 0 [reset saved? re-throw]

res: stack/get-top

if reset? [stack/top: saved]

res

]

process: func [

in-root [red-series!]

rule [red-block!]

comp-op [integer!]

;strict? [logic!]

part [integer!]

fun [red-function!]

return: [red-value!]

/local

input [red-series! value]

new [red-series!]

int [red-integer!]

int2 [red-integer!]

pair [red-pair!]

blk [red-block!]

sym* [red-symbol!]

cmd [red-value!]

tail [red-value!]

value [red-value!]

value2 [red-value!]

base [red-value!]

s-top [red-value!]

char [red-char!]

dt [red-datatype!]

bool [red-logic!]

w [red-word!]

t [triple!]

p [positions!]

in [input!]

pos [byte-ptr!] ;-- required by BS_TEST_BIT_ALT()

s [series!]

state [states!]

type [integer!]

type2 [integer!]

dt-type [integer!]

rtype [integer!]

flags [integer!]

sym [integer!]

min [integer!]

max [integer!]

cnt [integer!]

len [integer!]

offset [integer!]

head [integer!]

cnt-col [integer!]