Many new things, plus some minor bug removed
1. Print is faster now.
2. While and For Next loop are faster now
3. New While End While, and Do Until (or Repeat Until) and Do Always (or Repeat Always), without { }
4. We can exit from these non block structures, restoring the return stack correctly. Also Continue and Exit works in new If End If
5. Color Syntax changed to show Case >Alfa, <Beta in Select Case.
here is the library for json, with the new statements without blocks: (If End If, Do Until, While End While). Previous edition: http://georgekarras.blogspot.com/2017/06/11-88.html
New version for revision 19, version 9.6
In a module Lib1 we copy this
Class ParserClass {
Private:
Class bStream {
Private:
cnt, Buffer A
Public:
Value (&c) {Try { c=eval(.A, .cnt) : .cnt++:=true}}
Class:
Module final bStream (a$){
Buffer .A as Integer*Len(a$)
Return .A, 0:=a$
}
}
Func=Lambda->false
char=0
' using obj as pointer to Stack
obj=Stack
Function final IsId {
If .char=34 Then =.IsString(false)
}
Function final IsTrue {
' U+0074 U+0072 U+0075 U+0065
If .char=0x74 Then If .func() Then If .char=0x72 Then If .func() Then If .char=0x75 Then If .func() Then If .char=0x65 Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Boolean(True)
}
End Sub
}
Function final IsFalse {
' U+0066 U+0061 U+006c U+0073 U+0065
If .char=0x66 Then If .func() Then If .char=0x61 Then If .func() Then If .char=0x6c Then If .func() Then If .char=0x73 Then If .func() Then If .char=0x65 Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Boolean(False)
}
End Sub
}
Function final IsNull {
' U+006E U+0075 U+006C U+006C
If .char=0x6e Then If .func() Then If .char=0x75 Then If .func() Then If .char=0x6c Then If .func() Then If .char=0x6c Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Null()
}
End Sub
}
Function final IsSemiCol {
If .char=0x3a Then =true
}
Function final IsComma {
If .char=0x2c Then =true
}
Function final IsObject {
If .char=123 Else exit
inventory objinv
' we push object with a pointer to objinv
Stack .obj { Push .Object(objinv)}
.Trim
While .IsId()
.Trim
If .IsSemiCol() Then
.Trim
If .IsValue() Then
Stack .obj {
Shift 2 ' move top as second
' letter$ is ok If top is string, and throw it
Append objinv, Letter$:=Group
}
End If
Else
Exit
End If
.Trim
If not .IsComma() Then exit
.Trim
End While
If .char=125 Then =true Else .obj<=Stack : .func<=lambda->0
}
Function final IsValue {
If .IsString(True) Then
=True
Else.if .IsNumber() Then
=True
Else.if .IsTrue() Then
=True
Else.if .IsFalse() Then
=True
Else.if .IsNull() Then
=True
Else.if .IsArray() Then
=True
Else.if .IsObject() Then
=True
Else
? "what", .char
Stack .obj { Stack}
.func<=lambda->0
End If
}
Function final Digits (private_stack){
While .func()
Select Case .char
Case 48 to 57
{
=true
Stack private_stack { Data .char}
}
Else Case
break
End Select
End While
}
Function final IsNumber {
a=Stack
Select Case .char
Case 45 ' -
{
oldfunc=.func
Stack a { Data .char}
If .Func() Then
Select Case .char
Case 48
{
Stack a { Data .char}
If .func() Then
If .char=46 Then
Fraction()
Exponent()
End If
End If
}
Case 49 to 57
{
Stack a { Data .char}
If .Digits(a) Then {}
Fraction()
Exponent()
}
Else Case
a=stack
End Select
End If
}
Case 48 ' 0
{
oldfunc=.func
Stack a { Data .char}
If .func() Then
If .char=46 Then
Fraction()
Exponent()
End If
End If
}
Case 49 to 57
{
oldfunc=.func
Stack a { Data .char}
If .Digits(a) Then {}
Fraction()
Exponent()
}
End Select
If len(a)>0 Then {
b=each(a)
Document D$
While b
D$=chrcode$(StackItem(b))
End While
.func<=oldfunc
If len(D$)>1 Then For i=2 to len(D$) { .Trim}
Stack .obj { Push .Numeric(D$) }
=True
}
' here is an auto exit from function. Sub as command is an exit
Sub Fraction()
If .char=46 Then Stack a { Data .char}
If .Digits(a) Then { }
End Sub
Sub Exponent()
If .char=101 or .char=61 Then
Stack a { Data .char}
If .func() Then
If .char=43 or .char=45 Then
Stack a { Data .char }
If .Digits(a) Else
a=Stack ' cleat by point to new Stack
End if
Else.if .char>47 and .char<58 Then
Stack a { Data .char}
If .Digits(a) Then {}
Else
a=Stack
End If
End If
End If
End Sub
}
Function final IsString (as_object){
If .char=34 Else exit
Document D$
While .func()
If .char=34 Then 2000
If .char=92 Then
' special care
If .func() Then
Select Case .Char
Case 117 'u
GetHex()
Case 114 ' r
.char<=0x0d
Case 110 ' n
.char<=0x0a
Case 116 ' t
.char<=0x09
Case 98 ' b
.char<=0x08
Case 102 ' f
.char<=0x0c
Case 0x22, 0x2f , 0x5c
Else
Exit ' not normal
End Select
End If
End If
D$=chrcode$(.char)
End While
Exit
2000 Stack .obj {
If as_object Then Push .JString$(D$) Else Push D$
} : =True
Sub GetHex()
Local D$
Document D$="0x"
For i=1 to 4
If .func() Then End If
If Chrcode(.char) ~ "[0123456789ABCDEFabcdef]" Then
D$=Chrcode(.char)
Else
Goto 3000
End If
End If
Next I
If i<>5 Then 3000
.Char=Eval(D$)
3000 End Sub
}
Function final IsArray {
If .char=91 Else exit
Dim Gr()
' We place a pointer ro Array
.Trim
If .char=93 Then =true : Stack .obj { Push .Arr(Gr())} : exit
While .IsValue()
Stack .obj {
Dim Gr(Len(Gr())+1)
Gr(len(Gr())-1)=Group
}
.Trim
If not .IsComma() Then exit
.Trim
End While
' Push later pointer to array (maybe altered in redimension)
If .char=93 Then =true : Stack .obj { Push .Arr(Gr())} Else .Func<=lambda->false
}
Module final Trim {
While .func()
If .char<33 or .char=160 Else exit
End While
}
Function final IsContainer {
.Trim
Select Case chrcode$(.char)
Case "{"
=.IsObject()
Case "["
=.IsArray()
end select
}
' merge a foreign group here
Module final ReadArrayItem (temp, object){
Select Case temp.type$
Case "String","Boolean","Number", "Null"
{
If object Then Error "No object "+quote$(temp.type$)
Push temp.str$
}
Case "Object"
{
If not Empty Then
Call .ReadObject temp, object, letter$
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
Case "Array"
{
If not Empty Then
' recursion only with Call statement for modules
Call .ReadArrayItem, Array(temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
End Select
}
Module final ReadObject (json, object){
If type$(json)="Inventory" Then
If exist(json, Letter$) Then
temp=eval(json)
Else
push "none"
Break ' exit Module final (Break do something Else in Select End Select)
End If
Else
temp=json
End If
Select Case temp.type$
Case "String","Boolean","Number", "Null"
{
If object Then Error "No object "+quote$(temp.type$)
Push temp.str$
}
Case "Object"
{
If not Empty Then
Call .ReadObject temp, object ', letter$
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
Case "Array"
{
If not Empty Then
Call .ReadArrayItem array(temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
End Select
}
Module final Worker (object){
If match("IN") Or match("IS") Then ' inventory & number or inventory and string
' maybe we have more items in Stack
Push object : ShiftBack 2
.ReadObject
Else
read Temp ' get a group which returns Iventoty or an mArray
If Type$(Temp)="mArray" Then
If not Empty Then
Call .ReadArrayItem, Array(Temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(Temp,0)
End If
Else
If not Empty Then
Call .ReadObject Temp, object
Else
If not Empty Then
Call .ReadObject Temp, object
Else
If object Then Push Temp : exit
If Type$(Temp)="Inventory" Then
Push .ser$(.Object(Temp),0)
Else
Push .ser$(group(Temp),0)
End If
End if
End If
End If
End If
}
Public:
\\ This is the Public part
\\ First we set Public some class for later use
\\ Using Pointer to Array in Class Arr
Class Arr {
Private:
MyValue
Public:
Property Type$ {Value} ="Array"
Value {
=.MyValue
}
Class:
Module final Arr (.MyValue) {}
}
Class Null {
Property Type$ {Value} ="Null"
Property Str$ {Value}="null"
Value { =0}
}
Class JString$ {
Private:
MyValue$=""
Public:
Property Type$ {Value} ="String"
Property Str$ {
Value{
Link parent MyValue$ to MyValue$
value$=quote$(string$(MyValue$ as json))
}
}
Value {
=.MyValue$
}
Class:
Module final JString (.MyValue$) {}
}
Class Numeric {
Private:
MyValue$=""
Public:
Property Type$ {Value} ="Number"
Property Str$ {
Value{
Link parent MyValue$ to MyValue$
value$=MyValue$
}
}
Value {
=Val(.MyValue$)
}
Class:
Module final Numeric {
If match("S") Then
Read .MyValue$
Else
value$=trim$(str$(Number))
' M2000 return -.3 for -0.35
' using ? str$(MyValue, "0.#############")
' we get locale decimal char - maybe is comma
' so using str$(MyValue) we get integer or float with char "." for decimal always
' so we have to add 0
If left$(value$, 1)="." Then
value$="0"+value$
Else
If value$ ~ "-.*" Then value$=replace$("-.","-0.", value$)
End If
.Myvalue$<=value$
End If
}
}
Class Boolean {
Private:
MyValue=false
Public:
Property Type$ {Value} ="Boolean"
Property Str$ {
Value{
Link parent MyValue to MyValue
If MyValue Then {
value$="true"
} Else value$="false"
}
}
Value {
=.MyValue
}
Class:
Module final Boolean (.MyValue) {}
}
Class Object {
Private:
Inventory MyValue
Public:
Property Type$ {Value} ="Object"
Value {
=.MyValue
}
Class:
Module final Object (.MyValue) {}
}
\\ Empty group, with $, so we get two vars, Ser and Ser$ ( Ser$ we want to return a value type String)
Group Ser$
Module final SetSpace (.ser.space) { ' set space for values - 6 by default
}
Function final UseDecimalPoint$ {
' use this to change standard decimal point to local decimal point character
=str$(val(letter$),"")
}
Function final ReadNumber$ {
.Worker false 'modules get caller Stack
=.UseDecimalPoint$( Letter$)
}
Function final ReadAnyString$ {
\\ read an inventory
.Worker false
=Letter$
}
Function final ReadAny {
\\ read an inventory
.Worker true
Read A
=A
}
Function final Eval {
' Letter$ pop a string ftom Stack Else give error
.func<=Lambda z=.bStream(Letter$) -> {
link .char to c
' we can't pass reference in a private member
=z(&c)
}
' In this Parser we use a dedicated Stack
' for use from recuirsive memberts
' .obj is a pointer to Stack
' we can delete it simply setting a new Stack
' .obj<=Stack
' or we can flush all elements Using a command Flush
' .obj, char and .func() are visible from group members
' test
Stack .obj { Flush}
.char<=0
If .IsContainer() Then
' we get the pointer
=StackItem(.obj)
.obj<=Stack
Else
' return an Empty object
inventory emptinv
=.Object(emptinv)
End If
}
Group StringValue$ {
Add=false
Del=false
' from revision 12 we can place temp in parameter block
Set (temp) {
' always first read is for the assigned value to Group
Read temp1
If type$(temp)<>"Group" Then error "Need a group"
If not valid(temp.type$="") Then error "not a proper group"
If not valid(temp1.type$="") Then error "not a proper group for value"
' because Null() is out of this scope we have to link
Link parent Null() to MyNull()
Null=MyNull()
' or we can hard code the Null object
' Group Null {
' Property Type$ {Value} ="Null"
' Property Str$ {Value}="null"
' Value { =0}
' }
Dim Base 1, A(1)
\\ now we get the second interface for arrays
\\ bb() has a reference to b (one reference allowed)
\\ but b is pointer to array and can change to point to other arrrays
\\ we need ths to perform some tasks which belong to standard arrray interface
b=(,) : Link b to bb()
A(1)=Group(temp)
Do
again=false
Select Case A(1).type$
Case "Array"
{
If match("N") Then
Read where
If len(A(1))<=where and Empty Then
' only the last array we can redimension
If .add and not .del Then
cursize=Len(A(1))
b=A(1) ' A(1) has a pointer so now b has the same pointer
' dim preserve values
Dim bb(where+1) ' need one more because all "automatic arrays" have base 0
Stock bb(cursize) sweep Len(b)-cursize, Group(Null)
Else
Error "Index out of limits"+str$(where)
End If
Else
If where<0 Then Error "Index out of limits "+str$(where)
End If
If Empty Then
If .del Then
cursize=Len(A(1))
b=A(1) ' A(1) has a pointer so now b has the same pointer
If where<cursize-1 Then
Stock bb(where+1) Keep cursize-where, bb(where)
End If
Dim bb(cursize-1) ' bb(0) is an empty array
Else
Return A(1), where:=Group(temp1)
End If
Else
A(1)=Array(A(1),where)
again=True
End If
Else
Error "No Index Found"
End If
}
Case "Object"
{
If match("S") Then
Read k$
If Exist(A(1), k$) Then
If Empty Then
If .del Then
Delete A(1) , k$
Else
Return A(1), k$:=Group(temp1)
End If
Else
A(1)=Eval(A(1)) ' Eval(inventory_pointer) return object pointer
again=True
End If
Else.if .add and not .del Then
If Empty Then
Append A(1), k$:=Group(temp1)
Else
Error "No such Tag "+k$
End If
Else
Error "No such Tag "+k$
End If
Else
Error "No Tag Found"
End If
}
End Select
until not again
}
Value (temp) {
If type$(temp)<>"Group" Then error "Need a group"
If not valid(temp.type$="") Then error "not a proper group"
Dim Base 1, A(1)
A(1)=Group(temp)
Do
again=false
Select Case A(1).type$
Case "String", "Number", "Null", "Boolean"
Exit
Case "Array"
{
If match("N") Then
A(1)=Array(A(1), Number)
Else
Error "No Index Found"
End If
again=True
}
Case "Object"
{
If match("S") Then
If Exist(A(1), Letter$) Then
A(1)=Eval(A(1)) ' Eval(inventory_pointer) return object pointer
Else
Error "No such Tag"
End If
Else
Error "No Tag Found"
End If
again=True
}
End Select
until not again
=A(1).str$
}
}
Class:
\ one time definitions
Class CreatSerialize$ {
Private:
usen=0
n=0
nl1$={
}
Function final Jarray$ (json1, n){
\\ json1 is group type Array
A=json1
\\ A is mArray (pointer to Array)
nl$=.nl1$
If .usen>0 Then
nl$=nl$+string$(" ", n+.space)
End If
document a$
a$="["
If Len(A)>0 Then
If .usen>0 Then a$=nl$
k=each(A)
M=len(A)-1
while k
For This {
\\ temporary group
Temp=array(k)
select Case temp.type$
Case "Number", "Null","Boolean", "String"
a$=temp.str$
Case "Array"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jarray$(Temp, nn, "")
}
Case "Object"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jobject$(Temp, nn,"")
}
Else Case
a$=" "+temp.type$
end select
If k^<M Then
a$=", "
If .usen>0 Then a$=nl$
Else
If .usen>0 Then a$=.nl1$
End If
}
End While
Else
If .usen>0 Then a$=.nl1$
End If
If .usen>0 Then a$=string$(" ", n)
a$="]"
=a$+letter$
}
Function final Jobject$ (json1, n){
json=json1
\\ json has to be an object inventory
nl$=.nl1$
If .usen>0 Then
nl$=nl$+string$(" ", n+.space)
End If
document a$
a$="{"
If .usen>0 Then a$=nl$
k=each(json)
M=len(json)-1
while k
a$=quote$(eval$(json, k^)) +" : "
select Case json(k^!).type$
Case "Array"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jarray$(eval(k), nn, "")
}
Case "Boolean", "Null", "Number", "String"
a$=json(k^!).str$
Case "Object"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jobject$(eval(k), nn, "")
}
Else Case
a$=" "+json( k^!).type$
end select
If k^<M Then
a$=", "
If .usen>0 Then a$=nl$
Else
If .usen>0 Then a$=.nl1$
End If
End While
If .usen>0 Then a$=string$(" ", n)
a$="}"
=a$+letter$
}
Class Object {
Private:
Inventory MyValue
Public:
Property Type$ {Value} ="Object"
Value {
=.MyValue
}
Class:
Module final Object (.MyValue) {}
}
Public:
space=10
Value (json, n) {
a$=.nl1$
b$=""
.usen<=n
n--
If n<=0 Then a$="" : n=0 Else b$=string$(" ", n)
If type$(json)<>"Group" Then
If type$(json)="Inventory" Then
=b$+.Jobject$(.Object(json),n, a$)
Else.if type$(json)="mArray" Then
=b$+.Jarray$(json, n, a$)
End If
Else
If json.type$="Object" Then
=b$+.Jobject$(json, n,a$)
Else.if json.type$="Array" Then
=b$+.Jarray$(json, n, a$)
End If
End If
}
}
Module final ParserClass {
\ constructor
\ Let work as Push .CreatSerialize$() : Read .Ser
\ So now Group Ser loaded from CreatSerialize$()
\ Class CreatSerialize$ is a Function final, and because it is after Class:
\ Deleted before ParserClass return Group
Let .Ser=.CreatSerialize$()
}
}
1. Print is faster now.
2. While and For Next loop are faster now
3. New While End While, and Do Until (or Repeat Until) and Do Always (or Repeat Always), without { }
4. We can exit from these non block structures, restoring the return stack correctly. Also Continue and Exit works in new If End If
5. Color Syntax changed to show Case >Alfa, <Beta in Select Case.
here is the library for json, with the new statements without blocks: (If End If, Do Until, While End While). Previous edition: http://georgekarras.blogspot.com/2017/06/11-88.html
New version for revision 19, version 9.6
In a module Lib1 we copy this
Class ParserClass {
Private:
Class bStream {
Private:
cnt, Buffer A
Public:
Value (&c) {Try { c=eval(.A, .cnt) : .cnt++:=true}}
Class:
Module final bStream (a$){
Buffer .A as Integer*Len(a$)
Return .A, 0:=a$
}
}
Func=Lambda->false
char=0
' using obj as pointer to Stack
obj=Stack
Function final IsId {
If .char=34 Then =.IsString(false)
}
Function final IsTrue {
' U+0074 U+0072 U+0075 U+0065
If .char=0x74 Then If .func() Then If .char=0x72 Then If .func() Then If .char=0x75 Then If .func() Then If .char=0x65 Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Boolean(True)
}
End Sub
}
Function final IsFalse {
' U+0066 U+0061 U+006c U+0073 U+0065
If .char=0x66 Then If .func() Then If .char=0x61 Then If .func() Then If .char=0x6c Then If .func() Then If .char=0x73 Then If .func() Then If .char=0x65 Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Boolean(False)
}
End Sub
}
Function final IsNull {
' U+006E U+0075 U+006C U+006C
If .char=0x6e Then If .func() Then If .char=0x75 Then If .func() Then If .char=0x6c Then If .func() Then If .char=0x6c Then PushIt() : =True
Sub PushIt()
Stack .obj {
Push .Null()
}
End Sub
}
Function final IsSemiCol {
If .char=0x3a Then =true
}
Function final IsComma {
If .char=0x2c Then =true
}
Function final IsObject {
If .char=123 Else exit
inventory objinv
' we push object with a pointer to objinv
Stack .obj { Push .Object(objinv)}
.Trim
While .IsId()
.Trim
If .IsSemiCol() Then
.Trim
If .IsValue() Then
Stack .obj {
Shift 2 ' move top as second
' letter$ is ok If top is string, and throw it
Append objinv, Letter$:=Group
}
End If
Else
Exit
End If
.Trim
If not .IsComma() Then exit
.Trim
End While
If .char=125 Then =true Else .obj<=Stack : .func<=lambda->0
}
Function final IsValue {
If .IsString(True) Then
=True
Else.if .IsNumber() Then
=True
Else.if .IsTrue() Then
=True
Else.if .IsFalse() Then
=True
Else.if .IsNull() Then
=True
Else.if .IsArray() Then
=True
Else.if .IsObject() Then
=True
Else
? "what", .char
Stack .obj { Stack}
.func<=lambda->0
End If
}
Function final Digits (private_stack){
While .func()
Select Case .char
Case 48 to 57
{
=true
Stack private_stack { Data .char}
}
Else Case
break
End Select
End While
}
Function final IsNumber {
a=Stack
Select Case .char
Case 45 ' -
{
oldfunc=.func
Stack a { Data .char}
If .Func() Then
Select Case .char
Case 48
{
Stack a { Data .char}
If .func() Then
If .char=46 Then
Fraction()
Exponent()
End If
End If
}
Case 49 to 57
{
Stack a { Data .char}
If .Digits(a) Then {}
Fraction()
Exponent()
}
Else Case
a=stack
End Select
End If
}
Case 48 ' 0
{
oldfunc=.func
Stack a { Data .char}
If .func() Then
If .char=46 Then
Fraction()
Exponent()
End If
End If
}
Case 49 to 57
{
oldfunc=.func
Stack a { Data .char}
If .Digits(a) Then {}
Fraction()
Exponent()
}
End Select
If len(a)>0 Then {
b=each(a)
Document D$
While b
D$=chrcode$(StackItem(b))
End While
.func<=oldfunc
If len(D$)>1 Then For i=2 to len(D$) { .Trim}
Stack .obj { Push .Numeric(D$) }
=True
}
' here is an auto exit from function. Sub as command is an exit
Sub Fraction()
If .char=46 Then Stack a { Data .char}
If .Digits(a) Then { }
End Sub
Sub Exponent()
If .char=101 or .char=61 Then
Stack a { Data .char}
If .func() Then
If .char=43 or .char=45 Then
Stack a { Data .char }
If .Digits(a) Else
a=Stack ' cleat by point to new Stack
End if
Else.if .char>47 and .char<58 Then
Stack a { Data .char}
If .Digits(a) Then {}
Else
a=Stack
End If
End If
End If
End Sub
}
Function final IsString (as_object){
If .char=34 Else exit
Document D$
While .func()
If .char=34 Then 2000
If .char=92 Then
' special care
If .func() Then
Select Case .Char
Case 117 'u
GetHex()
Case 114 ' r
.char<=0x0d
Case 110 ' n
.char<=0x0a
Case 116 ' t
.char<=0x09
Case 98 ' b
.char<=0x08
Case 102 ' f
.char<=0x0c
Case 0x22, 0x2f , 0x5c
Else
Exit ' not normal
End Select
End If
End If
D$=chrcode$(.char)
End While
Exit
2000 Stack .obj {
If as_object Then Push .JString$(D$) Else Push D$
} : =True
Sub GetHex()
Local D$
Document D$="0x"
For i=1 to 4
If .func() Then End If
If Chrcode(.char) ~ "[0123456789ABCDEFabcdef]" Then
D$=Chrcode(.char)
Else
Goto 3000
End If
End If
Next I
If i<>5 Then 3000
.Char=Eval(D$)
3000 End Sub
}
Function final IsArray {
If .char=91 Else exit
Dim Gr()
' We place a pointer ro Array
.Trim
If .char=93 Then =true : Stack .obj { Push .Arr(Gr())} : exit
While .IsValue()
Stack .obj {
Dim Gr(Len(Gr())+1)
Gr(len(Gr())-1)=Group
}
.Trim
If not .IsComma() Then exit
.Trim
End While
' Push later pointer to array (maybe altered in redimension)
If .char=93 Then =true : Stack .obj { Push .Arr(Gr())} Else .Func<=lambda->false
}
Module final Trim {
While .func()
If .char<33 or .char=160 Else exit
End While
}
Function final IsContainer {
.Trim
Select Case chrcode$(.char)
Case "{"
=.IsObject()
Case "["
=.IsArray()
end select
}
' merge a foreign group here
Module final ReadArrayItem (temp, object){
Select Case temp.type$
Case "String","Boolean","Number", "Null"
{
If object Then Error "No object "+quote$(temp.type$)
Push temp.str$
}
Case "Object"
{
If not Empty Then
Call .ReadObject temp, object, letter$
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
Case "Array"
{
If not Empty Then
' recursion only with Call statement for modules
Call .ReadArrayItem, Array(temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
End Select
}
Module final ReadObject (json, object){
If type$(json)="Inventory" Then
If exist(json, Letter$) Then
temp=eval(json)
Else
push "none"
Break ' exit Module final (Break do something Else in Select End Select)
End If
Else
temp=json
End If
Select Case temp.type$
Case "String","Boolean","Number", "Null"
{
If object Then Error "No object "+quote$(temp.type$)
Push temp.str$
}
Case "Object"
{
If not Empty Then
Call .ReadObject temp, object ', letter$
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
Case "Array"
{
If not Empty Then
Call .ReadArrayItem array(temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(group(temp),0)
End If
}
End Select
}
Module final Worker (object){
If match("IN") Or match("IS") Then ' inventory & number or inventory and string
' maybe we have more items in Stack
Push object : ShiftBack 2
.ReadObject
Else
read Temp ' get a group which returns Iventoty or an mArray
If Type$(Temp)="mArray" Then
If not Empty Then
Call .ReadArrayItem, Array(Temp, number), object
Else
If object Then Push Temp : exit
Push .ser$(Temp,0)
End If
Else
If not Empty Then
Call .ReadObject Temp, object
Else
If not Empty Then
Call .ReadObject Temp, object
Else
If object Then Push Temp : exit
If Type$(Temp)="Inventory" Then
Push .ser$(.Object(Temp),0)
Else
Push .ser$(group(Temp),0)
End If
End if
End If
End If
End If
}
Public:
\\ This is the Public part
\\ First we set Public some class for later use
\\ Using Pointer to Array in Class Arr
Class Arr {
Private:
MyValue
Public:
Property Type$ {Value} ="Array"
Value {
=.MyValue
}
Class:
Module final Arr (.MyValue) {}
}
Class Null {
Property Type$ {Value} ="Null"
Property Str$ {Value}="null"
Value { =0}
}
Class JString$ {
Private:
MyValue$=""
Public:
Property Type$ {Value} ="String"
Property Str$ {
Value{
Link parent MyValue$ to MyValue$
value$=quote$(string$(MyValue$ as json))
}
}
Value {
=.MyValue$
}
Class:
Module final JString (.MyValue$) {}
}
Class Numeric {
Private:
MyValue$=""
Public:
Property Type$ {Value} ="Number"
Property Str$ {
Value{
Link parent MyValue$ to MyValue$
value$=MyValue$
}
}
Value {
=Val(.MyValue$)
}
Class:
Module final Numeric {
If match("S") Then
Read .MyValue$
Else
value$=trim$(str$(Number))
' M2000 return -.3 for -0.35
' using ? str$(MyValue, "0.#############")
' we get locale decimal char - maybe is comma
' so using str$(MyValue) we get integer or float with char "." for decimal always
' so we have to add 0
If left$(value$, 1)="." Then
value$="0"+value$
Else
If value$ ~ "-.*" Then value$=replace$("-.","-0.", value$)
End If
.Myvalue$<=value$
End If
}
}
Class Boolean {
Private:
MyValue=false
Public:
Property Type$ {Value} ="Boolean"
Property Str$ {
Value{
Link parent MyValue to MyValue
If MyValue Then {
value$="true"
} Else value$="false"
}
}
Value {
=.MyValue
}
Class:
Module final Boolean (.MyValue) {}
}
Class Object {
Private:
Inventory MyValue
Public:
Property Type$ {Value} ="Object"
Value {
=.MyValue
}
Class:
Module final Object (.MyValue) {}
}
\\ Empty group, with $, so we get two vars, Ser and Ser$ ( Ser$ we want to return a value type String)
Group Ser$
Module final SetSpace (.ser.space) { ' set space for values - 6 by default
}
Function final UseDecimalPoint$ {
' use this to change standard decimal point to local decimal point character
=str$(val(letter$),"")
}
Function final ReadNumber$ {
.Worker false 'modules get caller Stack
=.UseDecimalPoint$( Letter$)
}
Function final ReadAnyString$ {
\\ read an inventory
.Worker false
=Letter$
}
Function final ReadAny {
\\ read an inventory
.Worker true
Read A
=A
}
Function final Eval {
' Letter$ pop a string ftom Stack Else give error
.func<=Lambda z=.bStream(Letter$) -> {
link .char to c
' we can't pass reference in a private member
=z(&c)
}
' In this Parser we use a dedicated Stack
' for use from recuirsive memberts
' .obj is a pointer to Stack
' we can delete it simply setting a new Stack
' .obj<=Stack
' or we can flush all elements Using a command Flush
' .obj, char and .func() are visible from group members
' test
Stack .obj { Flush}
.char<=0
If .IsContainer() Then
' we get the pointer
=StackItem(.obj)
.obj<=Stack
Else
' return an Empty object
inventory emptinv
=.Object(emptinv)
End If
}
Group StringValue$ {
Add=false
Del=false
' from revision 12 we can place temp in parameter block
Set (temp) {
' always first read is for the assigned value to Group
Read temp1
If type$(temp)<>"Group" Then error "Need a group"
If not valid(temp.type$="") Then error "not a proper group"
If not valid(temp1.type$="") Then error "not a proper group for value"
' because Null() is out of this scope we have to link
Link parent Null() to MyNull()
Null=MyNull()
' or we can hard code the Null object
' Group Null {
' Property Type$ {Value} ="Null"
' Property Str$ {Value}="null"
' Value { =0}
' }
Dim Base 1, A(1)
\\ now we get the second interface for arrays
\\ bb() has a reference to b (one reference allowed)
\\ but b is pointer to array and can change to point to other arrrays
\\ we need ths to perform some tasks which belong to standard arrray interface
b=(,) : Link b to bb()
A(1)=Group(temp)
Do
again=false
Select Case A(1).type$
Case "Array"
{
If match("N") Then
Read where
If len(A(1))<=where and Empty Then
' only the last array we can redimension
If .add and not .del Then
cursize=Len(A(1))
b=A(1) ' A(1) has a pointer so now b has the same pointer
' dim preserve values
Dim bb(where+1) ' need one more because all "automatic arrays" have base 0
Stock bb(cursize) sweep Len(b)-cursize, Group(Null)
Else
Error "Index out of limits"+str$(where)
End If
Else
If where<0 Then Error "Index out of limits "+str$(where)
End If
If Empty Then
If .del Then
cursize=Len(A(1))
b=A(1) ' A(1) has a pointer so now b has the same pointer
If where<cursize-1 Then
Stock bb(where+1) Keep cursize-where, bb(where)
End If
Dim bb(cursize-1) ' bb(0) is an empty array
Else
Return A(1), where:=Group(temp1)
End If
Else
A(1)=Array(A(1),where)
again=True
End If
Else
Error "No Index Found"
End If
}
Case "Object"
{
If match("S") Then
Read k$
If Exist(A(1), k$) Then
If Empty Then
If .del Then
Delete A(1) , k$
Else
Return A(1), k$:=Group(temp1)
End If
Else
A(1)=Eval(A(1)) ' Eval(inventory_pointer) return object pointer
again=True
End If
Else.if .add and not .del Then
If Empty Then
Append A(1), k$:=Group(temp1)
Else
Error "No such Tag "+k$
End If
Else
Error "No such Tag "+k$
End If
Else
Error "No Tag Found"
End If
}
End Select
until not again
}
Value (temp) {
If type$(temp)<>"Group" Then error "Need a group"
If not valid(temp.type$="") Then error "not a proper group"
Dim Base 1, A(1)
A(1)=Group(temp)
Do
again=false
Select Case A(1).type$
Case "String", "Number", "Null", "Boolean"
Exit
Case "Array"
{
If match("N") Then
A(1)=Array(A(1), Number)
Else
Error "No Index Found"
End If
again=True
}
Case "Object"
{
If match("S") Then
If Exist(A(1), Letter$) Then
A(1)=Eval(A(1)) ' Eval(inventory_pointer) return object pointer
Else
Error "No such Tag"
End If
Else
Error "No Tag Found"
End If
again=True
}
End Select
until not again
=A(1).str$
}
}
Class:
\ one time definitions
Class CreatSerialize$ {
Private:
usen=0
n=0
nl1$={
}
Function final Jarray$ (json1, n){
\\ json1 is group type Array
A=json1
\\ A is mArray (pointer to Array)
nl$=.nl1$
If .usen>0 Then
nl$=nl$+string$(" ", n+.space)
End If
document a$
a$="["
If Len(A)>0 Then
If .usen>0 Then a$=nl$
k=each(A)
M=len(A)-1
while k
For This {
\\ temporary group
Temp=array(k)
select Case temp.type$
Case "Number", "Null","Boolean", "String"
a$=temp.str$
Case "Array"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jarray$(Temp, nn, "")
}
Case "Object"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jobject$(Temp, nn,"")
}
Else Case
a$=" "+temp.type$
end select
If k^<M Then
a$=", "
If .usen>0 Then a$=nl$
Else
If .usen>0 Then a$=.nl1$
End If
}
End While
Else
If .usen>0 Then a$=.nl1$
End If
If .usen>0 Then a$=string$(" ", n)
a$="]"
=a$+letter$
}
Function final Jobject$ (json1, n){
json=json1
\\ json has to be an object inventory
nl$=.nl1$
If .usen>0 Then
nl$=nl$+string$(" ", n+.space)
End If
document a$
a$="{"
If .usen>0 Then a$=nl$
k=each(json)
M=len(json)-1
while k
a$=quote$(eval$(json, k^)) +" : "
select Case json(k^!).type$
Case "Array"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jarray$(eval(k), nn, "")
}
Case "Boolean", "Null", "Number", "String"
a$=json(k^!).str$
Case "Object"
{
nn=0
If .usen>0 Then
nn=n +.space
End If
a$=.Jobject$(eval(k), nn, "")
}
Else Case
a$=" "+json( k^!).type$
end select
If k^<M Then
a$=", "
If .usen>0 Then a$=nl$
Else
If .usen>0 Then a$=.nl1$
End If
End While
If .usen>0 Then a$=string$(" ", n)
a$="}"
=a$+letter$
}
Class Object {
Private:
Inventory MyValue
Public:
Property Type$ {Value} ="Object"
Value {
=.MyValue
}
Class:
Module final Object (.MyValue) {}
}
Public:
space=10
Value (json, n) {
a$=.nl1$
b$=""
.usen<=n
n--
If n<=0 Then a$="" : n=0 Else b$=string$(" ", n)
If type$(json)<>"Group" Then
If type$(json)="Inventory" Then
=b$+.Jobject$(.Object(json),n, a$)
Else.if type$(json)="mArray" Then
=b$+.Jarray$(json, n, a$)
End If
Else
If json.type$="Object" Then
=b$+.Jobject$(json, n,a$)
Else.if json.type$="Array" Then
=b$+.Jarray$(json, n, a$)
End If
End If
}
}
Module final ParserClass {
\ constructor
\ Let work as Push .CreatSerialize$() : Read .Ser
\ So now Group Ser loaded from CreatSerialize$()
\ Class CreatSerialize$ is a Function final, and because it is after Class:
\ Deleted before ParserClass return Group
Let .Ser=.CreatSerialize$()
}
}
Δεν υπάρχουν σχόλια:
Δημοσίευση σχολίου
You can feel free to write any suggestion, or idea on the subject.