Сейчас делаю библиотеку для интерпретации JSON . В итоге получается дерево по которому можно будет пройтись и стыбрить нужные данные.
изменения 28.05.2018
Библиотека может транслировать текст сплошняком. Для этого добавлены новые слова для парсинга. Ввиду того, что эти операции изначально могут быть заточены под многобайтные кодировки, то некоторые вещи делаются с помощью множеств.
Поддерживаемые типы: ничего, флаги, числа влез. в ячейку, строки, объекты, массивы, float.
Шизы на этот раз меньше. Наверно.
Код:
REQUIRE STRUCT: ~ER\STRUCT\STRUCT-SUGAR.F
REQUIRE FLAG: ~ER\STRUCT\BIT-FLAG.F
REQUIRE REVERSE ~ER\OTHER\REVERSE.F
: NDROP
1+ CELLS SP@ + SP!
;
USER-VECT SIZE-CHAR \ addr -- size
USER-VECT CHAR@ \ addr -- zn
\ пропустить всё, что меньше или равно символу
: CHAR-FENCE \ char --
ParseBuff >IN @ + >R
BEGIN
BEGIN
ParseBuff.simb >IN @ XOR WHILE
R@ CHAR@ OVER > IF DROP RDROP EXIT THEN
R@ SIZE-CHAR DUP RP@ +! >IN +!
REPEAT
REFILL 0= IF -2002 THROW THEN
ParseBuff >IN @ + RP@ !
AGAIN
;
: GET-CHAR \ -- char
ParseBuff >IN @ +
DUP SIZE-CHAR >IN +!
CHAR@
;
: CHAR-WORD \ C1 C2 .. CN N -- pos err|0
DUP >R \ for DROP
0 >R \ pos
REVERSE
BEGIN
ParseBuff.simb >IN @ XOR WHILE
1 RPICK 0= IF R> RDROP 0 EXIT THEN
GET-CHAR <> IF 1 RPICK NDROP R> RDROP 0 EXIT THEN
-1 RP@ CELL+ +!
RP@ 1+!
REPEAT
1 RPICK NDROP
R> RDROP
-2002
;
\ пропустить символы
\ если один из символов совпадает, то дать на него указатель
\ и выйти
: SKIP-TO-CHARS \ char1 char2 ... charN n -- addr err|0
BEGIN
>IN @ ParseBuff.simb XOR WHILE
ParseBuff >IN @ +
CHAR@
SSET?
IF
NDROP
ParseBuff >IN @ +
DUP SIZE-CHAR >IN +!
0
EXIT
THEN
ParseBuff >IN @ + SIZE-CHAR
>IN +!
REPEAT
NDROP
-2002 \ буфер закончился
;
: SIZE1 DROP 1 ;
' C@ TO CHAR@
' SIZE1 TO SIZE-CHAR
\ вычленить строку, состоящую из символов,
\ которые входят в множество
: PARSE-SET \ char1 char2 ... charN n -- addr byte err|0
ParseBuff >IN @ + >R
0 >R
BEGIN
ParseBuff.simb >IN @ XOR WHILE
ParseBuff >IN @ +
CHAR@
SSET?
0= IF
NDROP
2R>
0
EXIT
THEN
ParseBuff >IN @ +
SIZE-CHAR
DUP RP@ +! >IN +!
REPEAT
NDROP
2R>
-2002
;
: CHAR-SET"
'"' PARSE
DUP 2>R >R
BEGIN
1 RPICK WHILE
R@ C@ ?LIT
RP@ 1+!
-1 RP@ CELL+ +!
REPEAT
RDROP RDROP
R> ?LIT
; IMMEDIATE
CURRENT KEEP
VOCABULARY JSON
ALSO JSON DEFINITIONS ' PREVIOUS >R
\ содержание элемента в объекте
STRUCT: elem
CELL -- key
CELL -- flag
CELL -- value
STRUCT;
\ служебная информация вначале объекта/массива и стека объектов
STRUCT: serv-line
CELL -- mem
CELL -- count
CELL -- data \ тут элементы всего остального. просто смещение
STRUCT;
STRUCT: arr-zn
CELL -- arr-flag
CELL -- arr-value
STRUCT;
: +>>new \ дать смещение для нового элемента объекта/массива
OVER count @ *
data +
;
0 CONSTANT null
FLAG:
flag-type
num
num-str
float
float-str
str
obj
array
FLAG;
: str-heap \ a u -- H-addr
>R
R@ CELL+ ALLOCATE THROW >R
2R@ !
R@ CELL+ 1 RPICK MOVE
R>
RDROP
;
: CHAR-VOC-SFIND \ char lfa -- xt -1| char 0
>R SP@ 1 R> SFIND-IN-VOC
\ char a u lfa -- char ffa xt flag
IF
NIP NIP -1
ELSE
NIP NIP 0
THEN
;
VARIABLE MAX-CHAR-NUM
10 MAX-CHAR-NUM !
: NUMBER \ -- zn flag
'.'
CHAR-SET" -.x0123456789ABCDEF"
PARSE-SET THROW
2DUP 2>R LAST-CHAR
NIP
IF
2R> str-heap float-str
ELSE
DUP MAX-CHAR-NUM > \ заглушка
IF
2R> str-heap num-str
ELSE
\ STR>NUM заменить. т.к. работает с 1-байтной кодировкой
2R> STR>NUM THROW num
THEN
THEN
;
: mem? \ h-addr -- h-addr?
DUP >R
R@ mem @
R@ count @
= IF
R@ @ 10 + elem * RESIZE THROW
10 OVER +!
THEN
RDROP
;
: >json-line \ h-addr flag --
STATE @
>R
R@ count @
R@ mem @
= IF ." JSON DEPTH" -4001 THROW THEN
R@ count @ arr-zn *
R@ data +
>R
R@ arr-flag !
R@ arr-value !
RDROP
R> count 1+!
;
: json-line@ \ -- h-addr flag
STATE @ >R
R@ count @ 1- arr-zn *
R> data +
>R
R@ arr-value @
R@ arr-flag @
RDROP
;
: json-line> \ -- h-addr flag
json-line@
-1 STATE @ count +!
;
VOCABULARY JSON-WORDS
LAST-LFA CURRENT !
\ шиза пришла
: t
CHAR-SET" rue" CHAR-WORD THROW
3 =
IF 1 flag-type EXIT THEN
-2003 THROW
;
: f
CHAR-SET" alse" CHAR-WORD THROW
4 =
IF 0 flag-type EXIT THEN
-2003 THROW
;
: n
CHAR-SET" ull" CHAR-WORD THROW
3 =
IF 0 JSON::null EXIT THEN
-2003 THROW
;
: }
RDROP
json-line>
DUP obj <> IF >json-line -4000 THROW THEN
;
: '
ParseBuff >IN @ +
''' 1 SKIP-TO-CHARS
THROW
OVER -
str-heap str
;
: "
ParseBuff >IN @ +
'"' 1 SKIP-TO-CHARS
THROW
OVER -
str-heap str
;
: { \ -- H-addr obj
30 elem * 2 CELLS + ALLOCATE THROW >R
30 R@ !
R> obj >json-line
BEGIN
BEGIN
ParseBuff.simb >IN @ XOR WHILE
BL CHAR-FENCE
GET-CHAR
['] JSON-WORDS >param @ CHAR-VOC-SFIND
IF EXECUTE
ELSE ." INCORRECT JSON" -4000 CR THROW
THEN
REPEAT
REFILL 0= IF -2002 THROW THEN
AGAIN
;
: , ; \ сахар
: [
30 arr-zn * 2 CELLS + ALLOCATE THROW >R
30 R@ !
R> array >json-line
SP@ >R
BEGIN
BEGIN
ParseBuff.simb >IN @ XOR WHILE
BL CHAR-FENCE
>IN @ >R
GET-CHAR
['] JSON-WORDS >param @ CHAR-VOC-SFIND
IF RDROP EXECUTE
ELSE DROP R> >IN ! NUMBER
THEN
\ проверка на левые данные. это на будущее
SP@ R@ - ABS 2 CELLS > >R
SP@ 1 RPICK - ABS CELL =
R> OR
IF ." INCORRECT array data" -4002 THROW THEN
\ если всё хорошо
SP@ R@ - ABS 2 CELLS =
IF
json-line@ DROP >R
R@ arr-zn +>>new arr-flag !
R@ arr-zn +>>new arr-value !
R> count 1+!
THEN
REPEAT
REFILL 0= IF -2002 THROW THEN
AGAIN
;
: ]
json-line>
DUP array <> IF >json-line -4000 THROW THEN
\ удаляем транслятор массивов
RDROP \ call
RDROP \ sp@
;
: : \ addr str
str <> IF ." is NOT STR" CR -4001 THROW THEN
json-line@ DROP
>R
R@ elem +>>new
R@ count 1+!
RP@ !
R@ key !
BL CHAR-FENCE
>IN @ >R
GET-CHAR ['] JSON-WORDS >param @ CHAR-VOC-SFIND
IF RDROP EXECUTE
ELSE DROP R> >IN ! NUMBER
THEN
R@ flag !
R> value !
;
: \
GET-CHAR
'\' = IF
10 13 2 SKIP-TO-CHARS THROW ( 10 и 13 перевод строки и каретка )
DROP
ELSE -2003 THROW
THEN
;
DEFINITIONS
: { \ интерпретатор
STATE KEEP \ всегда интерпретация, поэтому кошмарим.
100 arr-zn *
2 CELLS +
ALLOCATE THROW >R \ стек объектов
R@ STATE !
100 R@ !
JSON-WORDS::{
DROP \ flag
R> FREE THROW \ стек
;
\ для автотрансляции при встрече JSON
: JSON(voc-notf) \ a u -- ?? flag
OVER CHAR@
'{' =
IF
NEGATE >IN +!
DROP
{
-1
ELSE
2DROP
0
THEN
;
' JSON(voc-notf) CURRENT @ NOTFOUND!
Хаки и недоделки.
Всё опять же завязано на словарь.
Если после
: идёт
, (запятая), то в кач-ве значения слово : потребует что-то не из JSON, а из форта. С комментарием аналогично. Мне уже лень было вводить в
: ещё и проверку глубины стека.
Парсер вычленяет всё, что ему подходит.
Поэтому что-то вроде {'TEST':[null124false-0x34truenull]} распарсится без проблем. Но по логике должна выдаваться ошибка.