[dbfcdx] Revert previous assert, conditionally disable version checks (related to #711)

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
USING System
USING System.Globalization
USING System.Collections.Generic
USING XSharp.RDD.Enums
USING XSharp.RDD.Support
USING System.Text
USING System.IO
USING System.Linq
USING System.Diagnostics
//#define CHECKVERSIONS

BEGIN NAMESPACE XSharp.RDD.CDX
    /// <summary>
    /// Orderbag = CDX file. Contains one or more orders = Tags
    /// </summary>
    INTERNAL SEALED CLASS CdxOrderBag INHERIT BaseIndex
#region constants
    INTERNAL CONST CDX_EXTENSION := ".CDX" AS STRING

#endregion
        INTERNAL _hFile     AS IntPtr
        INTERNAL _stream    AS FileStream
        INTERNAL _OpenInfo	AS DbOpenInfo
        INTERNAL _Encoding  AS Encoding
        INTERNAL _PageList  AS CdxPageList
        INTERNAL PROPERTY Shared    AS LOGIC GET _OpenInfo:Shared
        INTERNAL PROPERTY ReadOnly  AS LOGIC GET _OpenInfo:ReadOnly
        INTERNAL _oRdd              AS DBFCDX
        INTERNAL _root              AS CdxFileHeader
        INTERNAL _tagList           AS CdxTagList
        INTERNAL CONST CDXPAGE_SIZE := 512 AS WORD

        //INTERNAL PROPERTY FileName AS STRING AUTO
        INTERNAL PROPERTY FullPath AS STRING AUTO
        INTERNAL PROPERTY Name AS STRING GET Path.GetFileNameWithoutExtension(FullPath)
        INTERNAL PROPERTY Handle AS IntPtr GET _hFile
        INTERNAL PROPERTY Stream AS FileStream GET _stream
        INTERNAL PROPERTY Tags AS IList<CdxTag> GET IIF(_tagList == NULL, NULL, _tagList:Tags)
        INTERNAL PROPERTY TagList AS CdxTagList GET _tagList
        INTERNAL PROPERTY Structural AS LOGIC AUTO
        INTERNAL PROPERTY Root      AS CdxFileHeader GET _root
        INTERNAL PROPERTY Encoding AS System.Text.Encoding GET _oRdd:_Encoding
        INTERNAL CONSTRUCTOR(oRDD AS DBFCDX )
            SUPER( oRDD )
            SELF:_oRdd     := oRDD
            SELF:_PageList := CdxPageList{SELF}
            SELF:_OpenInfo := oRDD:_OpenInfo
            SELF:_useFoxLock := XSharp.RuntimeState.GetValue<LOGIC>(Set.FoxLock)

        #region RDD Overloads
            /// <inheritdoc />
        OVERRIDE METHOD OrderCondition(info AS DbOrderCondInfo) AS LOGIC
            THROW NotImplementedException{}

        INTERNAL STATIC METHOD GetIndexExtFromDbfExt(cDbfName AS STRING) AS STRING
            SWITCH System.IO.Path.GetExtension(cDbfName:ToLower())
            CASE ".vcx"         // Control Library
            CASE ".scx"         // Screen
            CASE ".pjx"         // Project
            CASE ".mnx"         // Menu
            CASE ".frx"         // Report
                RETURN ""
            CASE ".dbc"         // database container
                RETURN ".dcx"
            END SWITCH
            RETURN CDX_EXTENSION
            /// <inheritdoc />
        OVERRIDE METHOD OrderCreate(info AS DbOrderCreateInfo) AS LOGIC
            LOCAL cTag AS STRING
            IF info:Order IS STRING VAR strOrder .and. ! String.IsNullOrWhiteSpace(strOrder)
                cTag := strOrder
            ELSE
                cTag := Path.GetFileNameWithoutExtension(info:BagName)
                IF cTag:Length > 10
                    cTag := cTag:Substring(0, 10)
                ENDIF
                info:Order := cTag
            ENDIF
            IF String.IsNullOrEmpty(cTag)
                // Exception ?
                RETURN FALSE
            ENDIF
            VAR oTag := SELF:_FindTagByName(cTag)
            VAR lOk := TRUE
            IF oTag != NULL_OBJECT
                VAR last := SELF:_tagList:Tags:Count == 1
                SELF:Destroy(oTag)
                IF last
                    SELF:CreateBag(SELF:FullPath)
                    SELF:_oRdd:_indexList:_AddBag(SELF)
                ENDIF
            ENDIF
            oTag := CdxTag{SELF}
            lOk := oTag:Create(info)
            IF lOk
                // Read the tag from disk to get all the normal stuff
                oTag  := CdxTag{SELF,oTag:Header:PageNo, oTag:OrderName}
                SELF:AddTag(oTag)
            ENDIF
            RETURN lOk

        METHOD AddTag(oTag AS CdxTag) AS LOGIC
            _tagList:Add(oTag)
            RETURN TRUE

        METHOD Destroy(oParam AS CdxTag) AS LOGIC
            LOCAL found := FALSE AS LOGIC
            VAR aTags   := SELF:Tags:ToArray()
            FOREACH tag AS CdxTag IN aTags
                IF String.Compare(tag:OrderName, oParam:OrderName, StringComparison.OrdinalIgnoreCase) == 0
                    oParam := tag
                    found := TRUE
                    EXIT
                ENDIF
            NEXT
            IF found
                // rewrite the taglist
                SELF:_tagList:Remove(oParam)
                // We do not Delete the pages from the tag. Comix also does not do that
                IF SELF:_tagList:Tags:Count == 0
                    LOCAL cFileName := SELF:FullPath AS STRING
                    SELF:_oRdd:_indexList:_CloseBag(SELF)
                    FErase(cFileName)
                ENDIF
            ENDIF
            RETURN found

            /// <inheritdoc />
        OVERRIDE METHOD OrderDestroy(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderInfo(nOrdinal AS DWORD, info AS DbOrderInfo) AS OBJECT
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListAdd(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListDelete(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListFocus(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />

        OVERRIDE METHOD OrderListRebuild( ) AS LOGIC
            LOCAL aTags AS CdxTag[]
            LOCAL cBagName AS STRING
            LOCAL lOk AS LOGIC
            aTags := SELF:_tagList:Tags:ToArray()
            cBagName := SELF:FullPath
            lOk := TRUE
            lOk := SELF:Close()
            IF lOk
                FErase(cBagName)
                lOk := SELF:CreateBag(cBagName)
            ENDIF
            IF lOk
                FOREACH oTag AS CdxTag IN aTags
                    lOk := oTag:Rebuild()
                    IF ! lOk
                        EXIT
                    ENDIF
                    SELF:AddTag(oTag)
                NEXT
            ENDIF
            SELF:GoCold()
            RETURN lOk

            /// <inheritdoc />
        OVERRIDE METHOD Seek(info AS DbSeekInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE PROPERTY Found AS LOGIC
            GET
                THROW NotImplementedException{}
            END GET
        END PROPERTY
        #endregion

        #region Open and Close etc
        METHOD CreateBag(cBagName AS STRING) AS LOGIC
            LOCAL cPath     AS STRING
            LOCAL cFullName AS STRING
            LOCAL cDbf      AS STRING
            cFullName := cBagName
            cDbf      := SELF:_oRdd:FileName
            VAR cExt  := GetIndexExtFromDbfExt(cDbf)
            IF String.IsNullOrEmpty(cFullName)
                cFullName := Path.ChangeExtension(cDbf, cExt)
            ELSEIF String.IsNullOrEmpty(Path.GetExtension(cFullName))
                cFullName := Path.ChangeExtension(cFullName, cExt)
            ELSEIF String.Compare(cDbf, cFullName, StringComparison.OrdinalIgnoreCase) == 0
                 cFullName := Path.ChangeExtension(cFullName, cExt)
            ENDIF
            cPath := Path.GetDirectoryName(cFullName)
            IF String.IsNullOrEmpty(cPath)
                cPath := Path.GetDirectoryName(cDbf)
                cFullName := Path.Combine(cPath, cFullName)
            ENDIF
            IF File(cFullName)
                LOCAL openInfo AS DbOrderInfo
                openInfo := DbOrderInfo{}
                openInfo:BagName := FPathName()
                SELF:Open(openInfo)
                RETURN TRUE
            ENDIF
            SELF:_hFile    := FCreate(cFullName)
            SELF:_stream   := FGetStream(SELF:_hFile)
            IF File(cFullName)
                // Make sure the full name is returned and not the DOS Short Name
                SELF:FullPath :=FPathName()
            ENDIF
            // Allocate Root Page
            _root   := CdxFileHeader{SELF}
            _root:Initialize()
            _PageList:Add(_root)
            SELF:Write(_root)
            // taglist page
            VAR buffer := SELF:AllocBuffer()
            _tagList := CdxTagList{SELF,  _root:RootPage, buffer, _root:KeySize}
            _tagList:InitBlank(NULL)
            SELF:Write(_tagList)
            RETURN TRUE

        METHOD _FindTagByName(cName AS STRING) AS CdxTag
            IF SELF:Tags != NULL
                FOREACH oTag AS CdxTag IN SELF:Tags
                    IF String.Compare(oTag:OrderName, cName,StringComparison.OrdinalIgnoreCase) == 0
                        RETURN oTag
                    ENDIF
                NEXT
            ENDIF
            RETURN NULL

        METHOD Close() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN Tags
                IF ! tag:Close()
                    lOk := FALSE
                ENDIF
            NEXT
            IF ! SELF:_PageList:Flush(FALSE)
                lOk := FALSE
            ENDIF
            IF ! FClose(SELF:_hFile)
                lOk := FALSE
            ENDIF
            SELF:_stream := NULL
            SELF:_hFile  := F_ERROR
            RETURN lOk

        INTERNAL METHOD Open(info AS DbOrderInfo) AS LOGIC
            // Filename may have path or not
            // When the filename does not have a path then we look in the path of the DBF
            LOCAL cPath     AS STRING
            LOCAL cFileName AS STRING
            LOCAL cFullName AS STRING
            IF info == NULL
                RETURN FALSE
            ENDIF
            cFullName := cFileName := info:BagName
            IF String.IsNullOrEmpty(Path.GetExtension(cFullName))
                VAR cExt  := GetIndexExtFromDbfExt(cFullName)
                cFullName := Path.ChangeExtension(cFullName, cExt)
            ENDIF
            cPath := Path.GetDirectoryName(cFullName)
            IF String.IsNullOrEmpty(cPath)
                cPath := SELF:_oRdd:FileName
                cPath := Path.GetDirectoryName(cPath)
                cFullName := Path.Combine(cPath, cFileName)
            ENDIF
            IF !File(cFullName)
                RETURN FALSE
            ENDIF
            // Adjust Filename to handle 8 char DOS names
            cFullName := FPathName()
            SELF:FullPath := cFullName
            SELF:_OpenInfo := _oRdd:_OpenInfo
            SELF:_hFile    := FOpen(cFullName, _OpenInfo:FileMode)
            SELF:_stream   := FGetStream(SELF:_hFile)
            SELF:_Encoding := _oRdd:_Encoding
            IF SELF:_hFile == F_ERROR
                RETURN FALSE
            ENDIF
            _root := CdxFileHeader{SELF}
            _root:Read()
            SELF:SetPage(_root)
            VAR nTagList := SELF:_root:RootPage
            VAR page     := SELF:GetPage(nTagList, _root:KeySize, NULL)
            _tagList := CdxTagList{SELF,  page, _root:KeySize}
            SELF:SetPage(_tagList)
            _tagList:ReadTags()
            // No need to Compile expressions again. Is done in ReadTags already
            // If we do want to do it again, then remember to save the LastRddError !
            // FOREACH VAR tag IN Tags
            //    tag:EvaluateExpressions()
            // NEXT
            RETURN TRUE
        #endregion

         METHOD MatchesFileName(cFileName AS STRING) AS LOGIC
            VAR cExt := Path.GetExtension(cFileName)
            IF String.IsNullOrEmpty(cExt)
                cFileName := Path.ChangeExtension(cFileName, CDX_EXTENSION)
            ENDIF
            IF String.Compare(SELF:FullPath, cFileName, StringComparison.OrdinalIgnoreCase) == 0
                RETURN TRUE
            ENDIF
            VAR cPath := Path.GetDirectoryName(cFileName)
            IF String.IsNullOrEmpty(cPath)
                IF String.Compare(Path.GetFileName(FullPath), cFileName, StringComparison.OrdinalIgnoreCase) == 0
                    RETURN TRUE
                ENDIF
            ENDIF
            RETURN FALSE

         OVERRIDE METHOD Flush() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN SELF:Tags
                IF ! tag:Flush()
                    lOk := FALSE
                ENDIF
            NEXT
            lOk := SELF:FlushPages() .and. lOk
            //_stream:SafeSetLength(_stream:Length)
            _stream:Flush(TRUE)
            RETURN lOk

         INTERNAL METHOD FlushPages() AS LOGIC
            RETURN SELF:_PageList:Flush(FALSE)

         INTERNAL METHOD SavePages() AS LOGIC
            RETURN SELF:_PageList:Flush(TRUE)

         METHOD GoCold() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN SELF:Tags
                IF ! tag:GoCold()
                    lOk := FALSE
                ENDIF
            NEXT
            RETURN lOk

        METHOD GoHot() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH VAR tag IN SELF:Tags
                IF ! tag:GoHot()
                    lOk := FALSE
                ENDIF
            NEXT
            RETURN lOk

        METHOD FindFreePage() AS LONG
            LOCAL nPage AS LONG
            LOCAL nNext AS LONG
            IF SELF:_root:FreeList > 0
                nPage := SELF:_root:FreeList
                VAR oPage := SELF:_PageList:GetPage(nPage, 0, NULL)
                IF oPage IS CdxTreePage VAR tPage
                    nNext := tPage:LeftPtr
                    IF nNext < 0
                        nNext := 0
                    ENDIF
                    SELF:_root:FreeList := nNext
                    SELF:_root:Write()
                ENDIF
                SELF:_PageList:Delete(nPage)
            ELSE
                IF _stream:Length >= Int32.MaxValue
                    var cMessage := "Maximum file size of 2 Gb for CDX file exceeded"
                    DebOut32(cMessage)
                    throw IOException{cMessage}
                ENDIF
                nPage   := (LONG) _stream:Length
            ENDIF
            RETURN nPage

         METHOD AddFreePage(oPage AS CdxTreePage) AS LOGIC
            VAR nPage := oPage:PageNo
            oPage:Clear()
            oPage:LeftPtr   := SELF:_root:FreeList
            oPage:RightPtr  := 0
            oPage:Write()
            SELF:_root:FreeList := nPage
            SELF:_root:Write()
            SELF:_PageList:Delete(nPage)
            RETURN TRUE

        METHOD AllocBuffer(nSize := 1 AS LONG)  AS BYTE[]
            RETURN BYTE[]{CDXPAGE_SIZE *nSize}

        METHOD Read(nPage AS LONG, buffer AS BYTE[]) AS LOGIC
            RETURN SELF:_stream:SafeReadAt(nPage, buffer)

        METHOD Read(oPage AS CdxPage) AS LOGIC
            IF SELF:_root != NULL
                oPage:Generation := SELF:_root:RootVersion
            ENDIF
            RETURN SELF:_stream:SafeReadAt(oPage:PageNo, oPage:Buffer, oPage:Buffer:Length)

        METHOD Write(oPage AS CdxPage) AS LOGIC
            LOCAL isOk AS LOGIC
#ifdef CHECKVERSIONS
            SELF:_PageList:CheckVersion(SELF:Root:RootVersion)
#endif
            IF oPage:PageNo == -1
                oPage:PageNo := SELF:FindFreePage()
                oPage:IsHot  := TRUE
                SELF:_PageList:SetPage(oPage:PageNo, oPage)
            ENDIF
            if oPage:PageNo < 0
                var cMessage := i"Trying to write to negative pageno {oPage:PageNo} in CDX"
                DebOut32(cMessage)
                THROW IOException{cMessage}
            ENDIF
            IF oPage:IsHot
                isOk := SELF:_stream:SafeWriteAt(oPage:PageNo, oPage:Buffer)
            ELSE
                isOk := TRUE
            ENDIF
            RETURN isOk

        METHOD GetPage(nPage AS Int32, nKeyLen AS WORD,tag AS CdxTag) AS CdxPage
           IF nPage == -1
                RETURN NULL
           ENDIF
           VAR page := SELF:_PageList:GetPage(nPage, nKeyLen,tag)
           IF page != NULL
                SELF:SetPage( page)
           ENDIF
           RETURN page

         METHOD SetPage(page AS CdxPage) AS VOID
            SELF:_PageList:SetPage(page:PageNo, page)
#ifdef CHECKVERSIONS
            page:Generation := SELF:Root:RootVersion
#endif

        #region properties

        PROPERTY Count AS LONG GET SELF:Tags:Count
        PROPERTY BagHasChanged AS LOGIC
            GET
                LOCAL nVersion AS DWORD
                nVersion := _root:RootVersion
                SELF:Read(SELF:_root)
                RETURN nVersion != _root:RootVersion

            END GET
        END PROPERTY

        INTERNAL METHOD CheckForChangedBag() AS LOGIC
            LOCAL lChanged := FALSE AS LOGIC
            IF SELF:BagHasChanged
                lChanged := TRUE
                SELF:_PageList:Clear()
                // Add new versions of Root and Taglist to the cache
                SELF:Root:Read()
                SELF:_tagList:Read()
                SELF:_PageList:Add(SELF:Root)
                SELF:_PageList:Add(SELF:_tagList)
            ENDIF
            RETURN lChanged

        PROPERTY IsHot AS LOGIC
        GET
            // return true as soon as one tag is hot
            FOREACH oTag AS CdxTag IN SELF:Tags
                IF oTag:IsHot
                    RETURN TRUE
                ENDIF
            NEXT
            RETURN FALSE
        END GET
        END PROPERTY
        #endregion

#region Common Locking code
        PRIVATE _useFoxLock     := FALSE AS LOGIC
        PRIVATE _sharedLocks    := 0 AS LONG
        PRIVATE _exclusiveLocks := 0 AS LONG
        STATIC PRIVATE rand := Random{100} AS System.Random

        PRIVATE METHOD _LockRetry(nOffSet AS INT64, nLen AS INT64,sPrefix AS STRING) AS VOID
            LOCAL result := FALSE AS LOGIC
            // note that there is no wait here. Research showed that the VO/Vulcan drivers
            // also did not wait
            REPEAT
                result := SELF:_stream:SafeLock(nOffSet, nLen)
            UNTIL result
            //DebOut32( "Locked " +nOffSet:ToString()+" "+nLen:ToString())

        PRIVATE METHOD _Unlock(nOffSet AS INT64, nLen AS INT64) AS LOGIC
            VAR res := SELF:_stream:SafeUnlock(nOffSet, nLen)
            //IF res
            //    NOP // DebOut32( "UnLocked " +nOffSet:ToString()+" "+nLen:ToString())
            //ELSE
            //    //DebOut32( "UnLock FAILED " +nOffSet:ToString()+" "+nLen:ToString())
            //ENDIF
            RETURN res

        INTERNAL METHOD SLock() AS LOGIC
            IF !SELF:Shared
                RETURN TRUE
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                SELF:_sharedLocks += 1
                IF SELF:_exclusiveLocks == 0  .AND. SELF:_sharedLocks == 1
                    IF SELF:_useFoxLock
                        SELF:_SLockFox()
                    ELSE
                        SELF:_SLockComix()
                    ENDIF
                    SELF:CheckForChangedBag()
                ENDIF
            END LOCK
            RETURN TRUE

        INTERNAL METHOD XLock() AS LOGIC
            IF !SELF:Shared
                RETURN TRUE
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                SELF:_exclusiveLocks += 1
                IF SELF:_exclusiveLocks == 1
                    IF _useFoxLock
                        SELF:_xLockFox()
                    ELSE
                        SELF:_xLockComix()
                    ENDIF
                    IF SELF:CheckForChangedBag()
                        FOREACH VAR oTag IN SELF:Tags
                            oTag:Stack:Clear()
                        NEXT
                    ENDIF
                ENDIF
            END LOCK
            RETURN TRUE

        INTERNAL METHOD UnLock() AS VOID
            IF !SELF:Shared
                RETURN
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                IF _useFoxLock
                    SELF:_UnLockFox()
                ELSE
                    SELF:_UnLockComix()
                ENDIF
            END LOCK
            RETURN
#endregion
    #region FoxPro compatible locking
        PRIVATE CONST FoxXLockOfs		:= 0x7ffffffe AS INT64
        PRIVATE CONST FoxXLockLen		:= 1          AS INT64
        PRIVATE CONST FoxSLockOfs		:= 0x7ffffffe AS INT64
        PRIVATE CONST FoxSLockLen		:= 1 AS DWORD

        PRIVATE METHOD _SLockFox() AS VOID
            SELF:_LockRetry(FoxSLockOfs, FoxSLockLen,"S")
            RETURN

        PRIVATE METHOD _xLockFox() AS VOID
            SELF:_LockRetry(FoxXLockOfs, FoxXLockLen,"X")
            RETURN

        PRIVATE METHOD _UnLockFox() AS VOID
            IF SELF:_sharedLocks > 0
                SELF:_sharedLocks -= 1
                IF SELF:_sharedLocks == 0
                    SELF:_Unlock(FoxSLockOfs, FoxSLockLen)
                ENDIF
            ELSEIF SELF:_exclusiveLocks > 0
                SELF:_exclusiveLocks -= 1
                IF SELF:_exclusiveLocks == 0
                    SELF:_UpdateRootVersion()
                    SELF:_Unlock(FoxXLockOfs, FoxXLockLen)
                ENDIF
            ENDIF
            RETURN

    #endregion
    #region Comix Compatible locking
        PRIVATE _sLockGate      := 0 AS LONG        // For CmxLock
        PRIVATE _sLockOffSet    := 0 AS DWORD       // For CmxLock
        PRIVATE _xLockedInOne   := FALSE AS LOGIC
        INTERNAL _LockOffSet    := 0 AS LONG
        PRIVATE CONST SLockGateCount    := 10 AS LONG
        PRIVATE CONST ComixXLockOfs		:= 0xfffeffff AS INT64
        PRIVATE CONST ComixSLockOfs		:= 0xffff0000 AS INT64
        PRIVATE CONST ComixXLockLen		:= 0x00010000 AS INT64
        STATIC PRIVATE randVal := 0 AS DWORD
        STATIC PRIVATE randInc, randDec AS LONG

        PRIVATE METHOD randNum () AS DWORD
            randInc -= randDec
            IF randInc <= 0
                randInc := DateTime.Now:Millisecond
                randDec := (randInc >> 8) + (randInc & 0xFF) + 1
            ENDIF
            randVal += (DWORD) randInc
            RETURN randVal

        PRIVATE METHOD _SLockComix() AS VOID
            //Debout32("_SlockComix() ")
            IF ++_sLockGate >= SLockGateCount
                _sLockGate := 0
                SELF:_LockRetry(ComixXLockOfs, 1,"S")
                SELF:_Unlock(ComixXLockOfs, 1)
            ENDIF
            SELF:_sLockOffSet := SELF:randNum()
            SELF:_LockRetry( _OR(ComixSLockOfs, _sLockOffSet),1,"S")

        PRIVATE METHOD _xLockComix() AS VOID
            //Debout32("_xLockComix() ")
            SELF:_sLockGate := 0
            Debug.Assert(_sharedLocks == 0)
            IF ! SELF:_stream:SafeLock(ComixXLockOfs, ComixXLockLen+1)
                SELF:_xLockedInOne := FALSE
                SELF:_LockRetry(ComixXLockOfs, 1,"X")
                SELF:_LockRetry(ComixSLockOfs, ComixXLockLen,"X")
            ELSE
                SELF:_xLockedInOne := TRUE
            ENDIF

        PRIVATE METHOD _UnLockComix() AS VOID

            IF SELF:_sharedLocks > 0
                SELF:_sharedLocks -= 1
                IF SELF:_sharedLocks == 0
                    SELF:_Unlock(ComixSLockOfs| SELF:_sLockOffSet, 1)
                ENDIF
            ELSEIF SELF:_exclusiveLocks > 0
                SELF:_exclusiveLocks -= 1
                IF SELF:_exclusiveLocks == 0
                    SELF:_UpdateRootVersion()
                    IF SELF:_xLockedInOne
                        SELF:_Unlock(ComixXLockOfs, ComixXLockLen+1)
                    ELSE
                        SELF:_Unlock(ComixXLockOfs, 1)
                        SELF:_Unlock(ComixSLockOfs, ComixXLockLen)
                    ENDIF
                ENDIF
            ENDIF
            RETURN

        PRIVATE METHOD _UpdateRootVersion() AS VOID
            var version := SELF:_root:RootVersion +1
            SELF:_root:RootVersion := version
            // Update the pagelist first. otherwise writing the _root will fail.
#ifdef CHECKVERSIONS
            SELF:_PageList:SetVersion(version)
#endif
            SELF:_root:Write()

    #endregion

    END CLASS
END NAMESPACE

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
USING System
USING System.Globalization
USING System.Collections.Generic
USING XSharp.RDD.Enums
USING XSharp.RDD.Support
USING System.Text
USING System.IO
USING System.Linq
USING System.Diagnostics

BEGIN NAMESPACE XSharp.RDD.CDX
    /// <summary>
    /// Orderbag = CDX file. Contains one or more orders = Tags
    /// </summary>
    INTERNAL SEALED CLASS CdxOrderBag INHERIT BaseIndex
#region constants
    INTERNAL CONST CDX_EXTENSION := ".CDX" AS STRING

#endregion
        INTERNAL _hFile     AS IntPtr
        INTERNAL _stream    AS FileStream
        INTERNAL _OpenInfo	AS DbOpenInfo
        INTERNAL _Encoding  AS Encoding
        INTERNAL _PageList  AS CdxPageList
        INTERNAL PROPERTY Shared    AS LOGIC GET _OpenInfo:Shared
        INTERNAL PROPERTY ReadOnly  AS LOGIC GET _OpenInfo:ReadOnly
        INTERNAL _oRdd              AS DBFCDX
        INTERNAL _root              AS CdxFileHeader
        INTERNAL _tagList           AS CdxTagList
        INTERNAL CONST CDXPAGE_SIZE := 512 AS WORD

        //INTERNAL PROPERTY FileName AS STRING AUTO
        INTERNAL PROPERTY FullPath AS STRING AUTO
        INTERNAL PROPERTY Name AS STRING GET Path.GetFileNameWithoutExtension(FullPath)
        INTERNAL PROPERTY Handle AS IntPtr GET _hFile
        INTERNAL PROPERTY Stream AS FileStream GET _stream
        INTERNAL PROPERTY Tags AS IList<CdxTag> GET IIF(_tagList == NULL, NULL, _tagList:Tags)
        INTERNAL PROPERTY TagList AS CdxTagList GET _tagList
        INTERNAL PROPERTY Structural AS LOGIC AUTO
        INTERNAL PROPERTY Root      AS CdxFileHeader GET _root
        INTERNAL PROPERTY Encoding AS System.Text.Encoding GET _oRdd:_Encoding
        INTERNAL CONSTRUCTOR(oRDD AS DBFCDX )
            SUPER( oRDD )
            SELF:_oRdd     := oRDD
            SELF:_PageList := CdxPageList{SELF}
            SELF:_OpenInfo := oRDD:_OpenInfo
            SELF:_useFoxLock := XSharp.RuntimeState.GetValue<LOGIC>(Set.FoxLock)

        #region RDD Overloads
            /// <inheritdoc />
        OVERRIDE METHOD OrderCondition(info AS DbOrderCondInfo) AS LOGIC
            THROW NotImplementedException{}

        INTERNAL STATIC METHOD GetIndexExtFromDbfExt(cDbfName AS STRING) AS STRING
            SWITCH System.IO.Path.GetExtension(cDbfName:ToLower())
            CASE ".vcx"         // Control Library
            CASE ".scx"         // Screen
            CASE ".pjx"         // Project
            CASE ".mnx"         // Menu
            CASE ".frx"         // Report
                RETURN ""
            CASE ".dbc"         // database container
                RETURN ".dcx"
            END SWITCH
            RETURN CDX_EXTENSION
            /// <inheritdoc />
        OVERRIDE METHOD OrderCreate(info AS DbOrderCreateInfo) AS LOGIC
            LOCAL cTag AS STRING
            IF info:Order IS STRING VAR strOrder .and. ! String.IsNullOrWhiteSpace(strOrder)
                cTag := strOrder
            ELSE
                cTag := Path.GetFileNameWithoutExtension(info:BagName)
                IF cTag:Length > 10
                    cTag := cTag:Substring(0, 10)
                ENDIF
                info:Order := cTag
            ENDIF
            IF String.IsNullOrEmpty(cTag)
                // Exception ?
                RETURN FALSE
            ENDIF
            VAR oTag := SELF:_FindTagByName(cTag)
            VAR lOk := TRUE
            IF oTag != NULL_OBJECT
                VAR last := SELF:_tagList:Tags:Count == 1
                SELF:Destroy(oTag)
                IF last
                    SELF:CreateBag(SELF:FullPath)
                    SELF:_oRdd:_indexList:_AddBag(SELF)
                ENDIF
            ENDIF
            oTag := CdxTag{SELF}
            lOk := oTag:Create(info)
            IF lOk
                // Read the tag from disk to get all the normal stuff
                oTag  := CdxTag{SELF,oTag:Header:PageNo, oTag:OrderName}
                SELF:AddTag(oTag)
            ENDIF
            RETURN lOk

        METHOD AddTag(oTag AS CdxTag) AS LOGIC
            _tagList:Add(oTag)
            RETURN TRUE

        METHOD Destroy(oParam AS CdxTag) AS LOGIC
            LOCAL found := FALSE AS LOGIC
            VAR aTags   := SELF:Tags:ToArray()
            FOREACH tag AS CdxTag IN aTags
                IF String.Compare(tag:OrderName, oParam:OrderName, StringComparison.OrdinalIgnoreCase) == 0
                    oParam := tag
                    found := TRUE
                    EXIT
                ENDIF
            NEXT
            IF found
                // rewrite the taglist
                SELF:_tagList:Remove(oParam)
                // We do not Delete the pages from the tag. Comix also does not do that
                IF SELF:_tagList:Tags:Count == 0
                    LOCAL cFileName := SELF:FullPath AS STRING
                    SELF:_oRdd:_indexList:_CloseBag(SELF)
                    FErase(cFileName)
                ENDIF
            ENDIF
            RETURN found

            /// <inheritdoc />
        OVERRIDE METHOD OrderDestroy(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderInfo(nOrdinal AS DWORD, info AS DbOrderInfo) AS OBJECT
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListAdd(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListDelete(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE METHOD OrderListFocus(info AS DbOrderInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />

        OVERRIDE METHOD OrderListRebuild( ) AS LOGIC
            LOCAL aTags AS CdxTag[]
            LOCAL cBagName AS STRING
            LOCAL lOk AS LOGIC
            aTags := SELF:_tagList:Tags:ToArray()
            cBagName := SELF:FullPath
            lOk := TRUE
            lOk := SELF:Close()
            IF lOk
                FErase(cBagName)
                lOk := SELF:CreateBag(cBagName)
            ENDIF
            IF lOk
                FOREACH oTag AS CdxTag IN aTags
                    lOk := oTag:Rebuild()
                    IF ! lOk
                        EXIT
                    ENDIF
                    SELF:AddTag(oTag)
                NEXT
            ENDIF
            SELF:GoCold()
            RETURN lOk

            /// <inheritdoc />
        OVERRIDE METHOD Seek(info AS DbSeekInfo) AS LOGIC
            THROW NotImplementedException{}
            /// <inheritdoc />
        OVERRIDE PROPERTY Found AS LOGIC
            GET
                THROW NotImplementedException{}
            END GET
        END PROPERTY
        #endregion

        #region Open and Close etc
        METHOD CreateBag(cBagName AS STRING) AS LOGIC
            LOCAL cPath     AS STRING
            LOCAL cFullName AS STRING
            LOCAL cDbf      AS STRING
            cFullName := cBagName
            cDbf      := SELF:_oRdd:FileName
            VAR cExt  := GetIndexExtFromDbfExt(cDbf)
            IF String.IsNullOrEmpty(cFullName)
                cFullName := Path.ChangeExtension(cDbf, cExt)
            ELSEIF String.IsNullOrEmpty(Path.GetExtension(cFullName))
                cFullName := Path.ChangeExtension(cFullName, cExt)
            ELSEIF String.Compare(cDbf, cFullName, StringComparison.OrdinalIgnoreCase) == 0
                 cFullName := Path.ChangeExtension(cFullName, cExt)
            ENDIF
            cPath := Path.GetDirectoryName(cFullName)
            IF String.IsNullOrEmpty(cPath)
                cPath := Path.GetDirectoryName(cDbf)
                cFullName := Path.Combine(cPath, cFullName)
            ENDIF
            IF File(cFullName)
                LOCAL openInfo AS DbOrderInfo
                openInfo := DbOrderInfo{}
                openInfo:BagName := FPathName()
                SELF:Open(openInfo)
                RETURN TRUE
            ENDIF
            SELF:_hFile    := FCreate(cFullName)
            SELF:_stream   := FGetStream(SELF:_hFile)
            IF File(cFullName)
                // Make sure the full name is returned and not the DOS Short Name
                SELF:FullPath :=FPathName()
            ENDIF
            // Allocate Root Page
            _root   := CdxFileHeader{SELF}
            _root:Initialize()
            _PageList:Add(_root)
            SELF:Write(_root)
            // taglist page
            VAR buffer := SELF:AllocBuffer()
            _tagList := CdxTagList{SELF,  _root:RootPage, buffer, _root:KeySize}
            _tagList:InitBlank(NULL)
            SELF:Write(_tagList)
            RETURN TRUE

        METHOD _FindTagByName(cName AS STRING) AS CdxTag
            IF SELF:Tags != NULL
                FOREACH oTag AS CdxTag IN SELF:Tags
                    IF String.Compare(oTag:OrderName, cName,StringComparison.OrdinalIgnoreCase) == 0
                        RETURN oTag
                    ENDIF
                NEXT
            ENDIF
            RETURN NULL

        METHOD Close() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN Tags
                IF ! tag:Close()
                    lOk := FALSE
                ENDIF
            NEXT
            IF ! SELF:_PageList:Flush(FALSE)
                lOk := FALSE
            ENDIF
            IF ! FClose(SELF:_hFile)
                lOk := FALSE
            ENDIF
            SELF:_stream := NULL
            SELF:_hFile  := F_ERROR
            RETURN lOk

        INTERNAL METHOD Open(info AS DbOrderInfo) AS LOGIC
            // Filename may have path or not
            // When the filename does not have a path then we look in the path of the DBF
            LOCAL cPath     AS STRING
            LOCAL cFileName AS STRING
            LOCAL cFullName AS STRING
            IF info == NULL
                RETURN FALSE
            ENDIF
            cFullName := cFileName := info:BagName
            IF String.IsNullOrEmpty(Path.GetExtension(cFullName))
                VAR cExt  := GetIndexExtFromDbfExt(cFullName)
                cFullName := Path.ChangeExtension(cFullName, cExt)
            ENDIF
            cPath := Path.GetDirectoryName(cFullName)
            IF String.IsNullOrEmpty(cPath)
                cPath := SELF:_oRdd:FileName
                cPath := Path.GetDirectoryName(cPath)
                cFullName := Path.Combine(cPath, cFileName)
            ENDIF
            IF !File(cFullName)
                RETURN FALSE
            ENDIF
            // Adjust Filename to handle 8 char DOS names
            cFullName := FPathName()
            SELF:FullPath := cFullName
            SELF:_OpenInfo := _oRdd:_OpenInfo
            SELF:_hFile    := FOpen(cFullName, _OpenInfo:FileMode)
            SELF:_stream   := FGetStream(SELF:_hFile)
            SELF:_Encoding := _oRdd:_Encoding
            IF SELF:_hFile == F_ERROR
                RETURN FALSE
            ENDIF
            _root := CdxFileHeader{SELF}
            _root:Read()
            SELF:SetPage(_root)
            VAR nTagList := SELF:_root:RootPage
            VAR page     := SELF:GetPage(nTagList, _root:KeySize, NULL)
            _tagList := CdxTagList{SELF,  page, _root:KeySize}
            SELF:SetPage(_tagList)
            _tagList:ReadTags()
            // No need to Compile expressions again. Is done in ReadTags already
            // If we do want to do it again, then remember to save the LastRddError !
            // FOREACH VAR tag IN Tags
            //    tag:EvaluateExpressions()
            // NEXT
            RETURN TRUE
        #endregion

         METHOD MatchesFileName(cFileName AS STRING) AS LOGIC
            VAR cExt := Path.GetExtension(cFileName)
            IF String.IsNullOrEmpty(cExt)
                cFileName := Path.ChangeExtension(cFileName, CDX_EXTENSION)
            ENDIF
            IF String.Compare(SELF:FullPath, cFileName, StringComparison.OrdinalIgnoreCase) == 0
                RETURN TRUE
            ENDIF
            VAR cPath := Path.GetDirectoryName(cFileName)
            IF String.IsNullOrEmpty(cPath)
                IF String.Compare(Path.GetFileName(FullPath), cFileName, StringComparison.OrdinalIgnoreCase) == 0
                    RETURN TRUE
                ENDIF
            ENDIF
            RETURN FALSE

         OVERRIDE METHOD Flush() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN SELF:Tags
                IF ! tag:Flush()
                    lOk := FALSE
                ENDIF
            NEXT
            lOk := SELF:FlushPages() .and. lOk
            //_stream:SafeSetLength(_stream:Length)
            _stream:Flush(TRUE)
            RETURN lOk

         INTERNAL METHOD FlushPages() AS LOGIC
            RETURN SELF:_PageList:Flush(FALSE)

         INTERNAL METHOD SavePages() AS LOGIC
            RETURN SELF:_PageList:Flush(TRUE)

         METHOD GoCold() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH tag AS CdxTag IN SELF:Tags
                IF ! tag:GoCold()
                    lOk := FALSE
                ENDIF
            NEXT
            RETURN lOk

        METHOD GoHot() AS LOGIC
            LOCAL lOk AS LOGIC
            // Process all tags even if one fails
            lOk := TRUE
            FOREACH VAR tag IN SELF:Tags
                IF ! tag:GoHot()
                    lOk := FALSE
                ENDIF
            NEXT
            RETURN lOk

        METHOD FindFreePage() AS LONG
            LOCAL nPage AS LONG
            LOCAL nNext AS LONG
            IF SELF:_root:FreeList > 0
                nPage := SELF:_root:FreeList
                VAR oPage := SELF:_PageList:GetPage(nPage, 0, NULL)
                IF oPage IS CdxTreePage VAR tPage
                    nNext := tPage:LeftPtr
                    IF nNext < 0
                        nNext := 0
                    ENDIF
                    SELF:_root:FreeList := nNext
                    SELF:_root:Write()
                ENDIF
                SELF:_PageList:Delete(nPage)
            ELSE
                IF _stream:Length >= Int32.MaxValue
                    var cMessage := "Maximum file size of 2 Gb for CDX file exceeded"
                    DebOut32(cMessage)
                    throw IOException{cMessage}
                ENDIF
                nPage   := (LONG) _stream:Length
            ENDIF
            RETURN nPage

         METHOD AddFreePage(oPage AS CdxTreePage) AS LOGIC
            VAR nPage := oPage:PageNo
            oPage:Clear()
            oPage:LeftPtr   := SELF:_root:FreeList
            oPage:RightPtr  := 0
            oPage:Write()
            SELF:_root:FreeList := nPage
            SELF:_root:Write()
            SELF:_PageList:Delete(nPage)
            RETURN TRUE

        METHOD AllocBuffer(nSize := 1 AS LONG)  AS BYTE[]
            RETURN BYTE[]{CDXPAGE_SIZE *nSize}

        METHOD Read(nPage AS LONG, buffer AS BYTE[]) AS LOGIC
            RETURN SELF:_stream:SafeReadAt(nPage, buffer)

        METHOD Read(oPage AS CdxPage) AS LOGIC
            IF SELF:_root != NULL
                oPage:Generation := SELF:_root:RootVersion
            ENDIF
            RETURN SELF:_stream:SafeReadAt(oPage:PageNo, oPage:Buffer, oPage:Buffer:Length)

        METHOD Write(oPage AS CdxPage) AS LOGIC
            LOCAL isOk AS LOGIC
            //SELF:_PageList:CheckVersion(SELF:Root:RootVersion)
            Debug.Assert(oPage:Generation == SELF:Root:RootVersion) // only check version of current page!
            IF oPage:PageNo == -1
                oPage:PageNo := SELF:FindFreePage()
                oPage:IsHot  := TRUE
                SELF:_PageList:SetPage(oPage:PageNo, oPage)
            ENDIF
            if oPage:PageNo < 0
                var cMessage := i"Trying to write to negative pageno {oPage:PageNo} in CDX"
                DebOut32(cMessage)
                THROW IOException{cMessage}
            ENDIF
            IF oPage:IsHot
                isOk := SELF:_stream:SafeWriteAt(oPage:PageNo, oPage:Buffer)
            ELSE
                isOk := TRUE
            ENDIF
            RETURN isOk

        METHOD GetPage(nPage AS Int32, nKeyLen AS WORD,tag AS CdxTag) AS CdxPage
           IF nPage == -1
                RETURN NULL
           ENDIF
           VAR page := SELF:_PageList:GetPage(nPage, nKeyLen,tag)
           IF page != NULL
                SELF:SetPage( page)
           ENDIF
           RETURN page

         METHOD SetPage(page AS CdxPage) AS VOID
            SELF:_PageList:SetPage(page:PageNo, page)
#ifdef DEBUG
            page:Generation := SELF:Root:RootVersion
#endif

        #region properties

        PROPERTY Count AS LONG GET SELF:Tags:Count
        PROPERTY BagHasChanged AS LOGIC
            GET
                LOCAL nVersion AS DWORD
                nVersion := _root:RootVersion
                SELF:Read(SELF:_root)
                RETURN nVersion != _root:RootVersion

            END GET
        END PROPERTY

        INTERNAL METHOD CheckForChangedBag() AS LOGIC
            LOCAL lChanged := FALSE AS LOGIC
            IF SELF:BagHasChanged
                lChanged := TRUE
                SELF:_PageList:Clear()
                // Add new versions of Root and Taglist to the cache
                SELF:Root:Read()
                SELF:_tagList:Read()
                SELF:_PageList:Add(SELF:Root)
                SELF:_PageList:Add(SELF:_tagList)
            ENDIF
            RETURN lChanged

        PROPERTY IsHot AS LOGIC
        GET
            // return true as soon as one tag is hot
            FOREACH oTag AS CdxTag IN SELF:Tags
                IF oTag:IsHot
                    RETURN TRUE
                ENDIF
            NEXT
            RETURN FALSE
        END GET
        END PROPERTY
        #endregion

#region Common Locking code
        PRIVATE _useFoxLock     := FALSE AS LOGIC
        PRIVATE _sharedLocks    := 0 AS LONG
        PRIVATE _exclusiveLocks := 0 AS LONG
        STATIC PRIVATE rand := Random{100} AS System.Random

        PRIVATE METHOD _LockRetry(nOffSet AS INT64, nLen AS INT64,sPrefix AS STRING) AS VOID
            LOCAL result := FALSE AS LOGIC
            // note that there is no wait here. Research showed that the VO/Vulcan drivers
            // also did not wait
            REPEAT
                result := SELF:_stream:SafeLock(nOffSet, nLen)
            UNTIL result
            //DebOut32( "Locked " +nOffSet:ToString()+" "+nLen:ToString())

        PRIVATE METHOD _Unlock(nOffSet AS INT64, nLen AS INT64) AS LOGIC
            VAR res := SELF:_stream:SafeUnlock(nOffSet, nLen)
            //IF res
            //    NOP // DebOut32( "UnLocked " +nOffSet:ToString()+" "+nLen:ToString())
            //ELSE
            //    //DebOut32( "UnLock FAILED " +nOffSet:ToString()+" "+nLen:ToString())
            //ENDIF
            RETURN res

        INTERNAL METHOD SLock() AS LOGIC
            IF !SELF:Shared
                RETURN TRUE
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                SELF:_sharedLocks += 1
                IF SELF:_exclusiveLocks == 0  .AND. SELF:_sharedLocks == 1
                    IF SELF:_useFoxLock
                        SELF:_SLockFox()
                    ELSE
                        SELF:_SLockComix()
                    ENDIF
                    SELF:CheckForChangedBag()
                ENDIF
            END LOCK
            RETURN TRUE

        INTERNAL METHOD XLock() AS LOGIC
            IF !SELF:Shared
                RETURN TRUE
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                SELF:_exclusiveLocks += 1
                IF SELF:_exclusiveLocks == 1
                    IF _useFoxLock
                        SELF:_xLockFox()
                    ELSE
                        SELF:_xLockComix()
                    ENDIF
                    IF SELF:CheckForChangedBag()
                        FOREACH VAR oTag IN SELF:Tags
                            oTag:Stack:Clear()
                        NEXT
                    ENDIF
                ENDIF
            END LOCK
            RETURN TRUE

        INTERNAL METHOD UnLock() AS VOID
            IF !SELF:Shared
                RETURN
            ENDIF
            //DebOut32( System.Threading.Thread.CurrentThread:Name+__ENTITY__ )
            BEGIN LOCK SELF
                IF _useFoxLock
                    SELF:_UnLockFox()
                ELSE
                    SELF:_UnLockComix()
                ENDIF
            END LOCK
            RETURN
#endregion
    #region FoxPro compatible locking
        PRIVATE CONST FoxXLockOfs		:= 0x7ffffffe AS INT64
        PRIVATE CONST FoxXLockLen		:= 1          AS INT64
        PRIVATE CONST FoxSLockOfs		:= 0x7ffffffe AS INT64
        PRIVATE CONST FoxSLockLen		:= 1 AS DWORD

        PRIVATE METHOD _SLockFox() AS VOID
            SELF:_LockRetry(FoxSLockOfs, FoxSLockLen,"S")
            RETURN

        PRIVATE METHOD _xLockFox() AS VOID
            SELF:_LockRetry(FoxXLockOfs, FoxXLockLen,"X")
            RETURN

        PRIVATE METHOD _UnLockFox() AS VOID
            IF SELF:_sharedLocks > 0
                SELF:_sharedLocks -= 1
                IF SELF:_sharedLocks == 0
                    SELF:_Unlock(FoxSLockOfs, FoxSLockLen)
                ENDIF
            ELSEIF SELF:_exclusiveLocks > 0
                SELF:_exclusiveLocks -= 1
                IF SELF:_exclusiveLocks == 0
                    SELF:_UpdateRootVersion()
                    SELF:_Unlock(FoxXLockOfs, FoxXLockLen)
                ENDIF
            ENDIF
            RETURN

    #endregion
    #region Comix Compatible locking
        PRIVATE _sLockGate      := 0 AS LONG        // For CmxLock
        PRIVATE _sLockOffSet    := 0 AS DWORD       // For CmxLock
        PRIVATE _xLockedInOne   := FALSE AS LOGIC
        INTERNAL _LockOffSet    := 0 AS LONG
        PRIVATE CONST SLockGateCount    := 10 AS LONG
        PRIVATE CONST ComixXLockOfs		:= 0xfffeffff AS INT64
        PRIVATE CONST ComixSLockOfs		:= 0xffff0000 AS INT64
        PRIVATE CONST ComixXLockLen		:= 0x00010000 AS INT64
        STATIC PRIVATE randVal := 0 AS DWORD
        STATIC PRIVATE randInc, randDec AS LONG

        PRIVATE METHOD randNum () AS DWORD
            randInc -= randDec
            IF randInc <= 0
                randInc := DateTime.Now:Millisecond
                randDec := (randInc >> 8) + (randInc & 0xFF) + 1
            ENDIF
            randVal += (DWORD) randInc
            RETURN randVal

        PRIVATE METHOD _SLockComix() AS VOID
            //Debout32("_SlockComix() ")
            IF ++_sLockGate >= SLockGateCount
                _sLockGate := 0
                SELF:_LockRetry(ComixXLockOfs, 1,"S")
                SELF:_Unlock(ComixXLockOfs, 1)
            ENDIF
            SELF:_sLockOffSet := SELF:randNum()
            SELF:_LockRetry( _OR(ComixSLockOfs, _sLockOffSet),1,"S")

        PRIVATE METHOD _xLockComix() AS VOID
            //Debout32("_xLockComix() ")
            SELF:_sLockGate := 0
            Debug.Assert(_sharedLocks == 0)
            IF ! SELF:_stream:SafeLock(ComixXLockOfs, ComixXLockLen+1)
                SELF:_xLockedInOne := FALSE
                SELF:_LockRetry(ComixXLockOfs, 1,"X")
                SELF:_LockRetry(ComixSLockOfs, ComixXLockLen,"X")
            ELSE
                SELF:_xLockedInOne := TRUE
            ENDIF

        PRIVATE METHOD _UnLockComix() AS VOID

            IF SELF:_sharedLocks > 0
                SELF:_sharedLocks -= 1
                IF SELF:_sharedLocks == 0
                    SELF:_Unlock(ComixSLockOfs| SELF:_sLockOffSet, 1)
                ENDIF
            ELSEIF SELF:_exclusiveLocks > 0
                SELF:_exclusiveLocks -= 1
                IF SELF:_exclusiveLocks == 0
                    SELF:_UpdateRootVersion()
                    IF SELF:_xLockedInOne
                        SELF:_Unlock(ComixXLockOfs, ComixXLockLen+1)
                    ELSE
                        SELF:_Unlock(ComixXLockOfs, 1)
                        SELF:_Unlock(ComixSLockOfs, ComixXLockLen)
                    ENDIF
                ENDIF
            ENDIF
            RETURN

        PRIVATE METHOD _UpdateRootVersion() AS VOID
            var version := SELF:_root:RootVersion +1
            SELF:_root:RootVersion := version
            // Update the pagelist first. otherwise writing the _root will fail.
#ifdef DEBUG
            SELF:_PageList:SetVersion(version)
#endif
            SELF:_root:Write()

    #endregion

    END CLASS
END NAMESPACE


make this includable universally

make this includable universally

import "../src/LangPrelude.prg" (maybeM)
import "../tests/Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded i n -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Inventory Nat ~> Nat ~> * where
  NotInEmpty :: Excluded []i n
  NoZero :: Excluded x 0t -> Excluded [x; (1+y)t]i 0t
  NoHigher :: Excluded x (1+n)t -> Excluded [x; 0t]i (1+n)t
  ReduceToLower :: Excluded x (1+n)t -> Excluded [y]i n -> Excluded [x; (1+y)t]i (1+n)t

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: NatList i -> Nat' n -> Maybe (Excluded i n)
tryExcluded []nl n = Just NotInEmpty
tryExcluded [x; (1+_)v]nl 0v = do ev <- tryExcluded x 0v
                                  return (NoZero ev)
tryExcluded [x; 0v]nl (n@(1+_)v) = do ev <- tryExcluded x n
                                      return (NoHigher ev)
tryExcluded [x; (1+y)v]nl (1+n)v = do ev1 <- tryExcluded x (1+n)v
                                      ev2 <- tryExcluded [y]nl n
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded i n
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing

import "../src/LangPrelude.prg" (maybeM)
import "Inventory.prg"

data NatList :: Inventory Nat ~> * where
  Nope :: NatList []i
  Augment :: NatList i -> Nat' n -> NatList [i; n]i
 deriving LeftList(nl)

data LeftThrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  LNil :: LeftThrist k a a
  LCons :: LeftThrist k a b -> k b c -> LeftThrist k a c
 deriving LeftList(lt)

data Elem :: Inventory Nat ~> Inventory Nat ~> * where
  Single :: NatList nl -> Elem i {merge i nl}

monad maybeM

mergeNL :: NatList i -> NatList j -> Maybe (NatList {merge i j})
mergeNL []nl j = Just j
mergeNL (i@[as; a]nl) []nl = Just i
mergeNL [as; a]nl [bs; b]nl = arrNL as bs a b a b
mergeNL _ _ = Nothing

arrNL :: NatList i -> NatList j -> Nat' a' -> Nat' b' -> Nat' a -> Nat' b -> Maybe (NatList {arrange i j a' b' a b})
arrNL i j 0v (1+b')v a b = do { iaj <- mergeNL [i; a]nl j; return [iaj; b]nl }
arrNL i j (1+a')v 0v a b = do { ijb <- mergeNL i [j; b]nl; return [ijb; a]nl }
arrNL i j (1+a')v (1+b')v a b = arrNL i j a' b' a b
arrNL _ _ _ _ _ _ = Nothing

join :: NatList i -> LeftThrist Elem []i i -> NatList j -> Maybe (LeftThrist Elem []i {merge i j}, NatList {merge i j})
join i thr j = do { ij <- mergeNL i j
                  ; return ([thr; Single j]lt, ij) }

Just (t1, e1) = let start = [0v, 2v, 4v]nl in join start [Single start]lt [3v]nl
Just (t2, e2) = join e1 t1 [1v, 5v]nl

-- proposition for mergability
--
prop Disjoint :: Inventory Nat ~> Inventory Nat ~> * where
  WithEmpty :: Disjoint []i i
  WithLastAndRest :: Excluded i n -> Disjoint j i -> Disjoint [j; n]i i

-- exclusivity
--
prop Excluded :: Inventory Nat ~> Nat ~> * where
  NotInEmpty :: Excluded []i n
  NoZero :: Excluded x 0t -> Excluded [x; (1+y)t]i 0t
  NoHigher :: Excluded x (1+n)t -> Excluded [x; 0t]i (1+n)t
  ReduceToLower :: Excluded x (1+n)t -> Excluded [y]i n -> Excluded [x; (1+y)t]i (1+n)t

-- the total version of mergeNL
--
mergeNL' :: Disjoint i j => NatList i -> NatList j -> NatList {merge i j}
mergeNL' i j = let Just m = mergeNL i j in m

-- creating disjointness evidence
--
tryExcluded :: NatList i -> Nat' n -> Maybe (Excluded i n)
tryExcluded []nl n = Just NotInEmpty
tryExcluded [x; (1+_)v]nl 0v = do ev <- tryExcluded x 0v
                                  return (NoZero ev)
tryExcluded [x; 0v]nl (n@(1+_)v) = do ev <- tryExcluded x n
                                      return (NoHigher ev)
tryExcluded [x; (1+y)v]nl (1+n)v = do ev1 <- tryExcluded x (1+n)v
                                      ev2 <- tryExcluded [y]nl n
                                      return (ReduceToLower ev1 ev2)
tryExcluded _ _ = Nothing

tryDisjoint :: NatList i -> NatList j -> Maybe (Disjoint i j)
tryDisjoint []nl _ = Just WithEmpty
tryDisjoint [j; n]nl i = do ev1 <- tryExcluded i n
                            ev2 <- tryDisjoint j i
                            return (WithLastAndRest ev1 ev2)
tryDisjoint _ _ = Nothing


the Altenkirch paper seems to be very close

-- See: http://en.wikipedia.org/wiki/Normalisation_by_evaluation
-- and also http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.39.2361
-- almost there: http://www.cs.nott.ac.uk/~txa/publ/flops04.pdf
--
import "../src/LangPrelude.prg" (listM,Monad,compose,const)

monad listM

-- abstract syntax -------------------------------------------------------------

data Ty :: *0 ~> *0 where
   Bool :: Ty Bool
   Arr :: Ty a -> Ty b -> Ty (a -> b)

data Var :: *0 ~> *0 ~> *0 where
   ZVar :: Var (h,t) t
   SVar :: Var h t -> Var (h,s) t

data Exp :: *0 ~> *0 ~> *0 where
   Var :: Var g t -> Exp g t
   Lam :: Ty a -> Exp (g,a) b -> Exp g (a -> b)
   App :: Exp g (s -> t) -> Exp g s -> Exp g t
   If :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
   ETrue :: Exp g Bool
   EFalse :: Exp g Bool

-- smart constructors ----------------------------------------------------------
lamE :: Ty s -> (Exp (g,s) s -> Exp (g,s) t) -> Exp g (s -> t)
lamE s f = Lam s (f (Var ZVar))

ifE :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
ifE t ETrue EFalse = t
ifE t e e' = if eqE e e' then e else If t e e'

-- boring equality tests -------------------------------------------------------
eqB :: BoxExp t -> BoxExp s -> Bool
eqB (Box e) (Box e') = eqE e e'

eqE :: Exp g t -> Exp h s -> Bool
eqE (Var x) (Var y) = eqV x y
eqE (Lam s e) (Lam s' e') = eqT s s' && eqE e e'
eqE (App e1 e2) (App e1' e2') = eqE e1 e1' && eqE e2 e2'
eqE (If e1 e2 e3) (If e1' e2' e3') = eqE e1 e1' && (eqE e2 e2' && eqE e3 e3')
eqE ETrue ETrue = True
eqE EFalse EFalse = True
eqE _ _ = False

eqT :: Ty t -> Ty s -> Bool
eqT (Arr s t) (Arr s' t') = eqT s s' && eqT t t'
eqT Bool Bool = True
eqT _ _ = False

eqV :: Var g t -> Var h s -> Bool
eqV (SVar x) (SVar y) = eqV x y
eqV ZVar ZVar = True
eqV _ _ = False

-- evaluation ------------------------------------------------------------------
var :: Var g t -> g -> t
var ZVar     (_,t) = t
var (SVar x) (h,s) = var x h

exp :: Exp g t -> g -> t
exp (Var x)    g = var x g
exp (Lam _ e)  g = \a -> exp e (g,a)
exp (App e e') g = exp e g (exp e' g)
exp ETrue      g = True
exp EFalse     g = False
exp (If c t e) g = if exp c g then exp t g else exp e g

-- type inference --------------------------------------------------------------

data TyEnv :: *0 ~> *0 where
   Cons :: Ty t -> TyEnv h -> TyEnv (h,t)
   Nil :: TyEnv g

infer :: TyEnv g -> Exp g t -> Ty t
infer g (Var x)         = inferVar g x
infer g (Lam t e)       = Arr t (infer (Cons t g) e)
infer g (App e e')      = case infer g e of Arr _ t -> t
infer g ETrue           = Bool
infer g EFalse          = Bool
infer g (If _ e _)      = infer g e

inferVar :: TyEnv g -> Var g t -> Ty t
inferVar (Cons t h) (SVar x) = inferVar h x
inferVar (Cons t h) (ZVar)   = t

-- tree monad ------------------------------------------------------------------

data Tree a = Val a | Choice (Tree a) (Tree a)
-- doesn't yet force trees to be fully balanced:
--      Val :: a -> Tree a Z
--      Choice :: Tree a n -> Tree a n -> Tree a (S n)

treeM = Monad Val bind error
  where bind (Val a) f = f a
        bind (Choice l r) f = Choice (bind l f) (bind r f)

tmap f x = do a <- x; return (f a)
  where monad treeM

flatten t = fl t []
 where
   fl (Val a)      k = a:k
   fl (Choice l r) k = fl l (fl r k)

-- quote & friends -------------------------------------------------------------

-- for values --------------------------
enumV           :: Ty t -> Tree t
questionsV      :: Ty t -> [t -> Bool]

enumV Bool      = Choice (Val True) (Val False)
enumV (Arr s t) = mkEnum (questionsV s) (enumV t)
 where
   monad treeM
   mkEnum [] t = tmap const t
   mkEnum (q:qs) es = do
                   f1 <- mkEnum qs es
                   f2 <- mkEnum qs es
                   return (\d -> if q d then f1 d else f2 d)

questionsV Bool         = return (\x -> x)
questionsV (Arr s t)    = do
                          d <- flatten (enumV s)
                          q <- questionsV t
                          return (\f -> q (f d))

-- for expressions ---------------------
enumE           :: Ty t -> Tree (Exp g t)
questionsE      :: Ty t -> [Exp g t -> Exp g Bool]

enumE Bool      = Choice (Val ETrue) (Val EFalse)
enumE (Arr s t) = tmap (lamE s) (mkEnumE (questionsE s) (enumE t))
 where
   monad treeM
   mkEnumE [] t = tmap const t
   mkEnumE (q:qs) es = do
                        f1 <- mkEnumE qs es
                        f2 <- mkEnumE qs es
                        return (\d -> ifE (q d) (f1 d) (f2 d))

questionsE Bool         = return (\x -> x)
questionsE (Arr s t)    = do
                          d <- flatten (enumE s)
                          q <- questionsE t
                          return (\f -> q (App f d))

-- should be
--      find (List (Exp g Bool) n) -> Tree (Exp g a) n -> Exp g a
find :: [Exp g Bool] -> Tree (Exp g a) -> Exp g a
find []         (Val a)         = a
find (b:bs)     (Choice l r)    = ifE b (find bs l) (find bs r)
find _          _               = error "bad arguments to find"

quote :: Ty t -> t -> Exp g t
quote Bool      t = case t of True -> ETrue; False -> EFalse
quote (Arr s t) f = lamE s (\e -> find (do q <- questionsE s; return (q e))
                                        (tmap (quote t . f) (enumV s)))

-- normalization (by evaluation) -----------------------------------------------
data BoxExp t = Box (forall g. Exp g t)

normalize :: Ty t -> BoxExp t -> BoxExp t
normalize s (Box e) = Box (quote s (exp e ()))

-- examples --------------------------------------------------------------------
b2b = Arr Bool Bool
b22b = Arr b2b b2b
zero = Var ZVar
one = Var (SVar ZVar)
once   = Box (Lam b2b (Lam Bool (App one zero)))
twice  = Box (Lam b2b (Lam Bool (App one (App one zero))))
thrice = Box (Lam b2b (Lam Bool (App one (App one (App one zero)))))

test = [ eqB (nf b22b thrice) (nf b22b once)
       , eqB (nf b22b twice)  (nf b22b once)]
  where nf = normalize

-- See: http://en.wikipedia.org/wiki/Normalisation_by_evaluation
-- and also http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.39.2361
--
import "../src/LangPrelude.prg" (listM,Monad,compose,const)

monad listM

-- abstract syntax -------------------------------------------------------------

data Ty :: *0 ~> *0 where
   Bool :: Ty Bool
   Arr :: Ty a -> Ty b -> Ty (a -> b)

data Var :: *0 ~> *0 ~> *0 where
   ZVar :: Var (h,t) t
   SVar :: Var h t -> Var (h,s) t

data Exp :: *0 ~> *0 ~> *0 where
   Var :: Var g t -> Exp g t
   Lam :: Ty a -> Exp (g,a) b -> Exp g (a -> b)
   App :: Exp g (s -> t) -> Exp g s -> Exp g t
   If :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
   ETrue :: Exp g Bool
   EFalse :: Exp g Bool

-- smart constructors ----------------------------------------------------------
lamE :: Ty s -> (Exp (g,s) s -> Exp (g,s) t) -> Exp g (s -> t)
lamE s f = Lam s (f (Var ZVar))

ifE :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
ifE t ETrue EFalse = t
ifE t e e' = if eqE e e' then e else If t e e'

-- boring equality tests -------------------------------------------------------
eqB :: BoxExp t -> BoxExp s -> Bool
eqB (Box e) (Box e') = eqE e e'

eqE :: Exp g t -> Exp h s -> Bool
eqE (Var x) (Var y) = eqV x y
eqE (Lam s e) (Lam s' e') = eqT s s' && eqE e e'
eqE (App e1 e2) (App e1' e2') = eqE e1 e1' && eqE e2 e2'
eqE (If e1 e2 e3) (If e1' e2' e3') = eqE e1 e1' && (eqE e2 e2' && eqE e3 e3')
eqE ETrue ETrue = True
eqE EFalse EFalse = True
eqE _ _ = False

eqT :: Ty t -> Ty s -> Bool
eqT (Arr s t) (Arr s' t') = eqT s s' && eqT t t'
eqT Bool Bool = True
eqT _ _ = False

eqV :: Var g t -> Var h s -> Bool
eqV (SVar x) (SVar y) = eqV x y
eqV ZVar ZVar = True
eqV _ _ = False

-- evaluation ------------------------------------------------------------------
var :: Var g t -> g -> t
var ZVar     (_,t) = t
var (SVar x) (h,s) = var x h

exp :: Exp g t -> g -> t
exp (Var x)    g = var x g
exp (Lam _ e)  g = \a -> exp e (g,a)
exp (App e e') g = exp e g (exp e' g)
exp ETrue      g = True
exp EFalse     g = False
exp (If c t e) g = if exp c g then exp t g else exp e g

-- type inference --------------------------------------------------------------

data TyEnv :: *0 ~> *0 where
   Cons :: Ty t -> TyEnv h -> TyEnv (h,t)
   Nil :: TyEnv g

infer :: TyEnv g -> Exp g t -> Ty t
infer g (Var x)         = inferVar g x
infer g (Lam t e)       = Arr t (infer (Cons t g) e)
infer g (App e e')      = case infer g e of Arr _ t -> t
infer g ETrue           = Bool
infer g EFalse          = Bool
infer g (If _ e _)      = infer g e

inferVar :: TyEnv g -> Var g t -> Ty t
inferVar (Cons t h) (SVar x) = inferVar h x
inferVar (Cons t h) (ZVar)   = t

-- tree monad ------------------------------------------------------------------

data Tree a = Val a | Choice (Tree a) (Tree a)
-- doesn't yet force trees to be fully balanced:
--      Val :: a -> Tree a Z
--      Choice :: Tree a n -> Tree a n -> Tree a (S n)

treeM = Monad Val bind error
  where bind (Val a) f = f a
        bind (Choice l r) f = Choice (bind l f) (bind r f)

tmap f x = do a <- x; return (f a)
  where monad treeM

flatten t = fl t []
 where
   fl (Val a)      k = a:k
   fl (Choice l r) k = fl l (fl r k)

-- quote & friends -------------------------------------------------------------

-- for values --------------------------
enumV           :: Ty t -> Tree t
questionsV      :: Ty t -> [t -> Bool]

enumV Bool      = Choice (Val True) (Val False)
enumV (Arr s t) = mkEnum (questionsV s) (enumV t)
 where
   monad treeM
   mkEnum [] t = tmap const t
   mkEnum (q:qs) es = do
                   f1 <- mkEnum qs es
                   f2 <- mkEnum qs es
                   return (\d -> if q d then f1 d else f2 d)

questionsV Bool         = return (\x -> x)
questionsV (Arr s t)    = do
                          d <- flatten (enumV s)
                          q <- questionsV t
                          return (\f -> q (f d))

-- for expressions ---------------------
enumE           :: Ty t -> Tree (Exp g t)
questionsE      :: Ty t -> [Exp g t -> Exp g Bool]

enumE Bool      = Choice (Val ETrue) (Val EFalse)
enumE (Arr s t) = tmap (lamE s) (mkEnumE (questionsE s) (enumE t))
 where
   monad treeM
   mkEnumE [] t = tmap const t
   mkEnumE (q:qs) es = do
                        f1 <- mkEnumE qs es
                        f2 <- mkEnumE qs es
                        return (\d -> ifE (q d) (f1 d) (f2 d))

questionsE Bool         = return (\x -> x)
questionsE (Arr s t)    = do
                          d <- flatten (enumE s)
                          q <- questionsE t
                          return (\f -> q (App f d))

-- should be
--      find (List (Exp g Bool) n) -> Tree (Exp g a) n -> Exp g a
find :: [Exp g Bool] -> Tree (Exp g a) -> Exp g a
find []         (Val a)         = a
find (b:bs)     (Choice l r)    = ifE b (find bs l) (find bs r)
find _          _               = error "bad arguments to find"

quote :: Ty t -> t -> Exp g t
quote Bool      t = case t of True -> ETrue; False -> EFalse
quote (Arr s t) f = lamE s (\e -> find (do q <- questionsE s; return (q e))
                                        (tmap (quote t . f) (enumV s)))

-- normalization (by evaluation) -----------------------------------------------
data BoxExp t = Box (forall g. Exp g t)

normalize :: Ty t -> BoxExp t -> BoxExp t
normalize s (Box e) = Box (quote s (exp e ()))

-- examples --------------------------------------------------------------------
b2b = Arr Bool Bool
b22b = Arr b2b b2b
zero = Var ZVar
one = Var (SVar ZVar)
once   = Box (Lam b2b (Lam Bool (App one zero)))
twice  = Box (Lam b2b (Lam Bool (App one (App one zero))))
thrice = Box (Lam b2b (Lam Bool (App one (App one (App one zero)))))

test = [ eqB (nf b22b thrice) (nf b22b once)
       , eqB (nf b22b twice)  (nf b22b once)]
  where nf = normalize


add slides too

add slides too

-- See: http://en.wikipedia.org/wiki/Normalisation_by_evaluation
-- and also http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.39.2361
-- almost there: http://www.cs.nott.ac.uk/~txa/publ/flops04.pdf
--       slides: http://www.cs.nott.ac.uk/~txa/talks/flops-slides.pdf
--
import "../src/LangPrelude.prg" (listM,Monad,compose,const)

monad listM

-- abstract syntax -------------------------------------------------------------

data Ty :: *0 ~> *0 where
   Bool :: Ty Bool
   Arr :: Ty a -> Ty b -> Ty (a -> b)

data Var :: *0 ~> *0 ~> *0 where
   ZVar :: Var (h,t) t
   SVar :: Var h t -> Var (h,s) t

data Exp :: *0 ~> *0 ~> *0 where
   Var :: Var g t -> Exp g t
   Lam :: Ty a -> Exp (g,a) b -> Exp g (a -> b)
   App :: Exp g (s -> t) -> Exp g s -> Exp g t
   If :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
   ETrue :: Exp g Bool
   EFalse :: Exp g Bool

-- smart constructors ----------------------------------------------------------
lamE :: Ty s -> (Exp (g,s) s -> Exp (g,s) t) -> Exp g (s -> t)
lamE s f = Lam s (f (Var ZVar))

ifE :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
ifE t ETrue EFalse = t
ifE t e e' = if eqE e e' then e else If t e e'

-- boring equality tests -------------------------------------------------------
eqB :: BoxExp t -> BoxExp s -> Bool
eqB (Box e) (Box e') = eqE e e'

eqE :: Exp g t -> Exp h s -> Bool
eqE (Var x) (Var y) = eqV x y
eqE (Lam s e) (Lam s' e') = eqT s s' && eqE e e'
eqE (App e1 e2) (App e1' e2') = eqE e1 e1' && eqE e2 e2'
eqE (If e1 e2 e3) (If e1' e2' e3') = eqE e1 e1' && (eqE e2 e2' && eqE e3 e3')
eqE ETrue ETrue = True
eqE EFalse EFalse = True
eqE _ _ = False

eqT :: Ty t -> Ty s -> Bool
eqT (Arr s t) (Arr s' t') = eqT s s' && eqT t t'
eqT Bool Bool = True
eqT _ _ = False

eqV :: Var g t -> Var h s -> Bool
eqV (SVar x) (SVar y) = eqV x y
eqV ZVar ZVar = True
eqV _ _ = False

-- evaluation ------------------------------------------------------------------
var :: Var g t -> g -> t
var ZVar     (_,t) = t
var (SVar x) (h,s) = var x h

exp :: Exp g t -> g -> t
exp (Var x)    g = var x g
exp (Lam _ e)  g = \a -> exp e (g,a)
exp (App e e') g = exp e g (exp e' g)
exp ETrue      g = True
exp EFalse     g = False
exp (If c t e) g = if exp c g then exp t g else exp e g

-- type inference --------------------------------------------------------------

data TyEnv :: *0 ~> *0 where
   Cons :: Ty t -> TyEnv h -> TyEnv (h,t)
   Nil :: TyEnv g

infer :: TyEnv g -> Exp g t -> Ty t
infer g (Var x)         = inferVar g x
infer g (Lam t e)       = Arr t (infer (Cons t g) e)
infer g (App e e')      = case infer g e of Arr _ t -> t
infer g ETrue           = Bool
infer g EFalse          = Bool
infer g (If _ e _)      = infer g e

inferVar :: TyEnv g -> Var g t -> Ty t
inferVar (Cons t h) (SVar x) = inferVar h x
inferVar (Cons t h) (ZVar)   = t

-- tree monad ------------------------------------------------------------------

data Tree a = Val a | Choice (Tree a) (Tree a)
-- doesn't yet force trees to be fully balanced:
--      Val :: a -> Tree a Z
--      Choice :: Tree a n -> Tree a n -> Tree a (S n)

treeM = Monad Val bind error
  where bind (Val a) f = f a
        bind (Choice l r) f = Choice (bind l f) (bind r f)

tmap f x = do a <- x; return (f a)
  where monad treeM

flatten t = fl t []
 where
   fl (Val a)      k = a:k
   fl (Choice l r) k = fl l (fl r k)

-- quote & friends -------------------------------------------------------------

-- for values --------------------------
enumV           :: Ty t -> Tree t
questionsV      :: Ty t -> [t -> Bool]

enumV Bool      = Choice (Val True) (Val False)
enumV (Arr s t) = mkEnum (questionsV s) (enumV t)
 where
   monad treeM
   mkEnum [] t = tmap const t
   mkEnum (q:qs) es = do
                   f1 <- mkEnum qs es
                   f2 <- mkEnum qs es
                   return (\d -> if q d then f1 d else f2 d)

questionsV Bool         = return (\x -> x)
questionsV (Arr s t)    = do
                          d <- flatten (enumV s)
                          q <- questionsV t
                          return (\f -> q (f d))

-- for expressions ---------------------
enumE           :: Ty t -> Tree (Exp g t)
questionsE      :: Ty t -> [Exp g t -> Exp g Bool]

enumE Bool      = Choice (Val ETrue) (Val EFalse)
enumE (Arr s t) = tmap (lamE s) (mkEnumE (questionsE s) (enumE t))
 where
   monad treeM
   mkEnumE [] t = tmap const t
   mkEnumE (q:qs) es = do
                        f1 <- mkEnumE qs es
                        f2 <- mkEnumE qs es
                        return (\d -> ifE (q d) (f1 d) (f2 d))

questionsE Bool         = return (\x -> x)
questionsE (Arr s t)    = do
                          d <- flatten (enumE s)
                          q <- questionsE t
                          return (\f -> q (App f d))

-- should be
--      find (List (Exp g Bool) n) -> Tree (Exp g a) n -> Exp g a
find :: [Exp g Bool] -> Tree (Exp g a) -> Exp g a
find []         (Val a)         = a
find (b:bs)     (Choice l r)    = ifE b (find bs l) (find bs r)
find _          _               = error "bad arguments to find"

quote :: Ty t -> t -> Exp g t
quote Bool      t = case t of True -> ETrue; False -> EFalse
quote (Arr s t) f = lamE s (\e -> find (do q <- questionsE s; return (q e))
                                        (tmap (quote t . f) (enumV s)))

-- normalization (by evaluation) -----------------------------------------------
data BoxExp t = Box (forall g. Exp g t)

normalize :: Ty t -> BoxExp t -> BoxExp t
normalize s (Box e) = Box (quote s (exp e ()))

-- examples --------------------------------------------------------------------
b2b = Arr Bool Bool
b22b = Arr b2b b2b
zero = Var ZVar
one = Var (SVar ZVar)
once   = Box (Lam b2b (Lam Bool (App one zero)))
twice  = Box (Lam b2b (Lam Bool (App one (App one zero))))
thrice = Box (Lam b2b (Lam Bool (App one (App one (App one zero)))))

test = [ eqB (nf b22b thrice) (nf b22b once)
       , eqB (nf b22b twice)  (nf b22b once)]
  where nf = normalize

-- See: http://en.wikipedia.org/wiki/Normalisation_by_evaluation
-- and also http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.39.2361
-- almost there: http://www.cs.nott.ac.uk/~txa/publ/flops04.pdf
--
import "../src/LangPrelude.prg" (listM,Monad,compose,const)

monad listM

-- abstract syntax -------------------------------------------------------------

data Ty :: *0 ~> *0 where
   Bool :: Ty Bool
   Arr :: Ty a -> Ty b -> Ty (a -> b)

data Var :: *0 ~> *0 ~> *0 where
   ZVar :: Var (h,t) t
   SVar :: Var h t -> Var (h,s) t

data Exp :: *0 ~> *0 ~> *0 where
   Var :: Var g t -> Exp g t
   Lam :: Ty a -> Exp (g,a) b -> Exp g (a -> b)
   App :: Exp g (s -> t) -> Exp g s -> Exp g t
   If :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
   ETrue :: Exp g Bool
   EFalse :: Exp g Bool

-- smart constructors ----------------------------------------------------------
lamE :: Ty s -> (Exp (g,s) s -> Exp (g,s) t) -> Exp g (s -> t)
lamE s f = Lam s (f (Var ZVar))

ifE :: Exp g Bool -> Exp g t -> Exp g t -> Exp g t
ifE t ETrue EFalse = t
ifE t e e' = if eqE e e' then e else If t e e'

-- boring equality tests -------------------------------------------------------
eqB :: BoxExp t -> BoxExp s -> Bool
eqB (Box e) (Box e') = eqE e e'

eqE :: Exp g t -> Exp h s -> Bool
eqE (Var x) (Var y) = eqV x y
eqE (Lam s e) (Lam s' e') = eqT s s' && eqE e e'
eqE (App e1 e2) (App e1' e2') = eqE e1 e1' && eqE e2 e2'
eqE (If e1 e2 e3) (If e1' e2' e3') = eqE e1 e1' && (eqE e2 e2' && eqE e3 e3')
eqE ETrue ETrue = True
eqE EFalse EFalse = True
eqE _ _ = False

eqT :: Ty t -> Ty s -> Bool
eqT (Arr s t) (Arr s' t') = eqT s s' && eqT t t'
eqT Bool Bool = True
eqT _ _ = False

eqV :: Var g t -> Var h s -> Bool
eqV (SVar x) (SVar y) = eqV x y
eqV ZVar ZVar = True
eqV _ _ = False

-- evaluation ------------------------------------------------------------------
var :: Var g t -> g -> t
var ZVar     (_,t) = t
var (SVar x) (h,s) = var x h

exp :: Exp g t -> g -> t
exp (Var x)    g = var x g
exp (Lam _ e)  g = \a -> exp e (g,a)
exp (App e e') g = exp e g (exp e' g)
exp ETrue      g = True
exp EFalse     g = False
exp (If c t e) g = if exp c g then exp t g else exp e g

-- type inference --------------------------------------------------------------

data TyEnv :: *0 ~> *0 where
   Cons :: Ty t -> TyEnv h -> TyEnv (h,t)
   Nil :: TyEnv g

infer :: TyEnv g -> Exp g t -> Ty t
infer g (Var x)         = inferVar g x
infer g (Lam t e)       = Arr t (infer (Cons t g) e)
infer g (App e e')      = case infer g e of Arr _ t -> t
infer g ETrue           = Bool
infer g EFalse          = Bool
infer g (If _ e _)      = infer g e

inferVar :: TyEnv g -> Var g t -> Ty t
inferVar (Cons t h) (SVar x) = inferVar h x
inferVar (Cons t h) (ZVar)   = t

-- tree monad ------------------------------------------------------------------

data Tree a = Val a | Choice (Tree a) (Tree a)
-- doesn't yet force trees to be fully balanced:
--      Val :: a -> Tree a Z
--      Choice :: Tree a n -> Tree a n -> Tree a (S n)

treeM = Monad Val bind error
  where bind (Val a) f = f a
        bind (Choice l r) f = Choice (bind l f) (bind r f)

tmap f x = do a <- x; return (f a)
  where monad treeM

flatten t = fl t []
 where
   fl (Val a)      k = a:k
   fl (Choice l r) k = fl l (fl r k)

-- quote & friends -------------------------------------------------------------

-- for values --------------------------
enumV           :: Ty t -> Tree t
questionsV      :: Ty t -> [t -> Bool]

enumV Bool      = Choice (Val True) (Val False)
enumV (Arr s t) = mkEnum (questionsV s) (enumV t)
 where
   monad treeM
   mkEnum [] t = tmap const t
   mkEnum (q:qs) es = do
                   f1 <- mkEnum qs es
                   f2 <- mkEnum qs es
                   return (\d -> if q d then f1 d else f2 d)

questionsV Bool         = return (\x -> x)
questionsV (Arr s t)    = do
                          d <- flatten (enumV s)
                          q <- questionsV t
                          return (\f -> q (f d))

-- for expressions ---------------------
enumE           :: Ty t -> Tree (Exp g t)
questionsE      :: Ty t -> [Exp g t -> Exp g Bool]

enumE Bool      = Choice (Val ETrue) (Val EFalse)
enumE (Arr s t) = tmap (lamE s) (mkEnumE (questionsE s) (enumE t))
 where
   monad treeM
   mkEnumE [] t = tmap const t
   mkEnumE (q:qs) es = do
                        f1 <- mkEnumE qs es
                        f2 <- mkEnumE qs es
                        return (\d -> ifE (q d) (f1 d) (f2 d))

questionsE Bool         = return (\x -> x)
questionsE (Arr s t)    = do
                          d <- flatten (enumE s)
                          q <- questionsE t
                          return (\f -> q (App f d))

-- should be
--      find (List (Exp g Bool) n) -> Tree (Exp g a) n -> Exp g a
find :: [Exp g Bool] -> Tree (Exp g a) -> Exp g a
find []         (Val a)         = a
find (b:bs)     (Choice l r)    = ifE b (find bs l) (find bs r)
find _          _               = error "bad arguments to find"

quote :: Ty t -> t -> Exp g t
quote Bool      t = case t of True -> ETrue; False -> EFalse
quote (Arr s t) f = lamE s (\e -> find (do q <- questionsE s; return (q e))
                                        (tmap (quote t . f) (enumV s)))

-- normalization (by evaluation) -----------------------------------------------
data BoxExp t = Box (forall g. Exp g t)

normalize :: Ty t -> BoxExp t -> BoxExp t
normalize s (Box e) = Box (quote s (exp e ()))

-- examples --------------------------------------------------------------------
b2b = Arr Bool Bool
b22b = Arr b2b b2b
zero = Var ZVar
one = Var (SVar ZVar)
once   = Box (Lam b2b (Lam Bool (App one zero)))
twice  = Box (Lam b2b (Lam Bool (App one (App one zero))))
thrice = Box (Lam b2b (Lam Bool (App one (App one (App one zero)))))

test = [ eqB (nf b22b thrice) (nf b22b once)
       , eqB (nf b22b twice)  (nf b22b once)]
  where nf = normalize


moving Nat thrists around

moving Nat thrists around

import "../tests/OneHi.prg" (plus, plusS)

data Thrist :: (l ~> l ~> *) ~> l ~> l ~> * where
  Nil :: Thrist k a a
  Cons :: k a b -> Thrist k b c -> Thrist k a c
 deriving List(t)

data At :: * ~> Nat ~> Nat ~> * where
  HoldChar :: Char -> At Char n (S n)

thristLen :: Thrist (At Char) here {plus len here} -> Nat' len
thristLen Nil = 0v

move :: Nat' offs -> Nat' len -> Thrist (At Char) here {plus len here} -> Thrist (At Char) offs {plus len offs}
move _ 0v Nil = Nil
move offs (1+len)v (Cons (HoldChar c) as) = Cons (HoldChar c) $ move (1+offs)v len as
  where theorem plusS

import "../tests/OneHi.prg" (plus, plusS)

data Thrist :: (l ~> l ~> *) ~> l ~> l ~> * where
  Nil :: Thrist k a a
  Cons :: k a b -> Thrist k b c -> Thrist k a c
 deriving List(t)

data At :: * ~> Nat ~> Nat ~> * where
  HoldChar :: Char -> At Char n (S n)

move :: Nat' offs -> Nat' len -> Thrist (At Char) here {plus len here} -> Thrist (At Char) offs {plus len offs}
move _ Z Nil = Nil
move offs (1+len)v (Cons (HoldChar c) as) = Cons (HoldChar c) $ move (1+offs)v len as
  where theorem plusS


Added missing error related defines

Added missing error related defines

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

BEGIN NAMESPACE XSharp
	/// Error code Enum that matches the Visual Objecs and Vulcan Generic Error Codes
	/// <note type="tip">
	/// These enums are also available as DEFINES and can therefore also be used without the "Gencode." prefix.
	/// </note>
	ENUM Gencode AS DWORD
		MEMBER EG_UNKNOWN      := 0
		MEMBER EG_ARG          := 1
		MEMBER EG_BOUND        := 2
		MEMBER EG_STROVERFLOW  := 3
		MEMBER EG_NUMOVERFLOW  := 4
		MEMBER EG_ZERODIV      := 5
		MEMBER EG_NUMERR       := 6
		MEMBER EG_SYNTAX       := 7
		MEMBER EG_COMPLEXITY   := 8
		MEMBER EG_MEMOVERFLOW  := 9
		MEMBER EG_SEQUENCE	   := 10
		MEMBER EG_MEM          := 11
		MEMBER EG_NOFUNC       := 12
		MEMBER EG_NOMETHOD     := 13
		MEMBER EG_NOVAR        := 14
		MEMBER EG_NOALIAS      := 15
		MEMBER EG_NOVARMETHOD  := 16
		MEMBER EG_BADALIAS     := 17
		MEMBER EG_DUPALIAS     := 18
		MEMBER EG_NULLVAR      := 19
		MEMBER EG_CREATE       := 20
		MEMBER EG_OPEN         := 21
		MEMBER EG_CLOSE        := 22
		MEMBER EG_READ         := 23
		MEMBER EG_WRITE        := 24
		MEMBER EG_PRINT        := 25
		MEMBER EG_NOATOM       := 26
		MEMBER EG_NOCLASS      := 27
		MEMBER EG_WRONGCLASS   := 28
		MEMBER EG_REFERENCE    := 29
		MEMBER EG_UNSUPPORTED  := 30
		MEMBER EG_LIMIT        := 31
		MEMBER EG_CORRUPTION   := 32
		MEMBER EG_DATATYPE     := 33
		MEMBER EG_DATAWIDTH    := 34
		MEMBER EG_NOTABLE      := 35
		MEMBER EG_NOORDER      := 36
		MEMBER EG_SHARED       := 37
		MEMBER EG_UNLOCKED     := 38
		MEMBER EG_READONLY     := 39
		MEMBER EG_APPENDLOCK   := 40
		MEMBER EG_LOCK			:= 41
		// missing 42 .. 44
		MEMBER EG_LOCK_ERROR   := 45
		MEMBER EG_LOCK_TIMEOUT := 46
		MEMBER EG_STACK        := 47
		MEMBER EG_EVALSTACK    := 48
		MEMBER EG_ERRORBLOCK   := 49
		MEMBER EG_PROTECTION   := 50

		MEMBER EG_BADPTR       := 51
		MEMBER EG_BADPAGEFAULT := 52
		MEMBER EG_ERRORBUILD   := 53
		MEMBER EG_DYNPTR       := 54

		// Vulcan errors
		MEMBER EG_INACCESSIBLETYPE := 55
		MEMBER EG_AMBIGUOUSMETHOD  := 56
		MEMBER EG_SEND_MISSINGARG  := 57
		MEMBER EG_SEND_TOOMANYARGS := 58
		MEMBER EG_EXCEPTION		   := 59

		// Last Member
		MEMBER EG_MAX          := 59

	END ENUM
	/// Error code Enum that matches the Visual Objecs and Vulcan Error Severity codes
	/// <note type="tip">
	/// These enums are also available as DEFINES and can therefore also be used without the "Severity." prefix.
	/// </note>
	ENUM Severity
		MEMBER ES_WHOCARES     := 0
		MEMBER ES_WARNING      := 1
		MEMBER ES_ERROR        := 2
		MEMBER ES_CATASTROPHIC := 3
	END ENUM

	/// Error code Enum that matches the Visual Objecs and Vulcan Error Sub Codes
	/// <note type="tip">
	/// These enums are also available as DEFINES and can therefore also be used without the "Subcodes." prefix.
	/// </note>
	ENUM Subcodes
		MEMBER ENOERROR := 0
		// Database errors - HOST side

		MEMBER EDB		:= 1000
		MEMBER EDB_SEEK := EDB + 1
		MEMBER EDB_SKIP :=EDB + 2
		MEMBER EDB_GOTO := EDB + 3
		MEMBER EDB_SETRELATION := EDB + 4
		MEMBER EDB_USE := EDB + 5
		MEMBER EDB_CREATEINDEX := EDB + 6
		MEMBER EDB_SETORDER := EDB + 7
		MEMBER EDB_SETINDEX := EDB + 8
		MEMBER EDB_FIELDNAME := EDB + 9
		MEMBER EDB_BADALIAS := EDB + 10
		MEMBER EDB_DUPALIAS := EDB + 11
		MEMBER EDB_SETFILTER := EDB + 12
		MEMBER EDB_CYCLICREL := EDB + 13
		MEMBER EDB_CREATETABLE := EDB + 14
		MEMBER EDB_RDDNOTFOUND := EDB + 15
		// 16
		MEMBER EDB_FIELDINDEX := EDB + 17
		MEMBER EDB_SELECT := EDB + 18
		MEMBER EDB_SYMSELECT := EDB + 19
		MEMBER EDB_TOTAL := EDB + 20
		MEMBER EDB_RECNO := EDB + 21
		MEMBER EDB_EXPRESSION := EDB + 22
		MEMBER EDB_EXPR_WIDTH := EDB + 23
		// 24-29
		MEMBER EDB_DRIVERLOAD := EDB + 30
		MEMBER EDB_PARAM := EDB + 31
		MEMBER EDB_NOAREAS := EDB + 32
		MEMBER EDB_NOMEM := EDB + 33
		MEMBER EDB_NOFIELDS := EDB + 35
		MEMBER EDB_BAD_ERROR_INFO := EDB + 36
		MEMBER EDB_WRONGFIELDNAME := EDB + 37
		MEMBER EDB_ORDDESTROY := EDB + 38
		MEMBER EDB_NOINITFUNCTION := EDB + 39
		MEMBER EDB_ERRORINIT := EDB + 40
		MEMBER EDB_DBSTRUCT := EDB + 41
		// 42-49
		// Generic no table error
		MEMBER EDB_NOTABLE := EDB + 50
		MEMBER EDB_NOORDER := EDB + 51
		MEMBER EDB_ASSERTION := EDB + 53

		MEMBER ERDD := 1100

		MEMBER ERDD_OPEN_ORDER := ERDD + 03
		// 02
		MEMBER ERDD_CREATE_FILE := ERDD + 04
		MEMBER ERDD_CREATE_MEMO := ERDD + 05
		MEMBER ERDD_CREATE_ORDER := ERDD + 06
		// 07-09
		MEMBER ERDD_READ := ERDD + 10
		MEMBER ERDD_WRITE := ERDD + 11
		MEMBER ERDD_CORRUPT := ERDD + 12
		MEMBER ERDD_CORRUPT_HEADER := ERDD + 13
		// 14
		MEMBER ERDD_RDDVERSION := ERDD + 15
		// 16-19
		MEMBER ERDD_DATATYPE := ERDD + 20
		MEMBER ERDD_DATAWIDTH := ERDD + 21
		MEMBER ERDD_UNLOCKED := ERDD + 22
		MEMBER ERDD_SHARED := ERDD + 23
		MEMBER ERDD_APPENDLOCK := ERDD + 24
		MEMBER ERDD_READONLY := ERDD + 25
		MEMBER ERDD_NULLKEY := ERDD + 26
		MEMBER ERDD_NTXLIMIT := ERDD + 27
		MEMBER ERDD_TAGLIMIT := ERDD + 28
		// 29
		MEMBER ERDD_INIT_LOCK := ERDD + 30
		MEMBER ERDD_READ_LOCK := ERDD + 31
		MEMBER ERDD_WRITE_LOCK := ERDD + 32
		MEMBER ERDD_READ_UNLOCK := ERDD + 33
		MEMBER ERDD_WRITE_UNLOCK := ERDD + 34
		MEMBER ERDD_READ_LOCK_TIMEOUT := ERDD + 35
		MEMBER ERDD_WRITE_LOCK_TIMEOUT := ERDD + 36
		MEMBER ERDD_READ_UNLOCK_TIMEOUT := ERDD + 37
		MEMBER ERDD_WRITE_UNLOCK_TIMEOUT := ERDD + 38
		// 39
		MEMBER ERDD_CLOSE_FILE := ERDD + 40
		MEMBER ERDD_CLOSE_MEMO := ERDD + 41
		MEMBER ERDD_CLOSE_ORDER := ERDD + 42

		MEMBER ERDD_INVALID_ORDER := ERDD + 50
		MEMBER ERDD_RECNO_MISSING := ERDD + 51
		MEMBER ERDD_NOORDER := ERDD + 52
		MEMBER ERDD_UNSUPPORTED := ERDD + 53
		// 54-99
		// Following errors are known as Clipper's internal errors
		MEMBER ERDD_WRITE_NTX := ERDD + 100
		MEMBER ERDD_KEY_NOT_FOUND := ERDD + 101
		MEMBER ERDD_KEY_EVAL := ERDD + 102
		MEMBER ERDD_VAR_TYPE := ERDD + 103
		// 104-105
		MEMBER ERDD_READ_BUFFER := ERDD + 106
		MEMBER ERDD_SORT_INIT := ERDD + 107
		MEMBER ERDD_SORT_ADVANCE := ERDD + 108
		MEMBER ERDD_SORT_SORT := ERDD + 109
		MEMBER ERDD_SORT_COMPLETE := ERDD + 110
		MEMBER ERDD_SORT_END := ERDD + 111
		MEMBER ERDD_READ_TEMPFILE := ERDD + 112
		MEMBER ERDD_STREAM_NUM := ERDD + 113
		MEMBER ERDD_CREATE_TEMPFILE := ERDD + 114
		// 115
		MEMBER DISKIO_WRITE := ERDD + 116
		MEMBER ERDD_WRONG_DRIVERTYPE := ERDD + 117
		MEMBER ERDD_OUTOFMEMORY := ERDD + 118
		MEMBER ERDD_INVALIDARG := ERDD + 119
		MEMBER ERDD_NOEVENTHANDLER := ERDD + 120

		// Start of user definable errors
		MEMBER ERDD_USER := 2000

		// These were originally in the CMX code
		MEMBER ERDD_SCOPETYPEMISMATCH := 8007     // ScopeTypeMismatch
		MEMBER ERDD_NOTCUSTOM := 8008     // NotCustom
		MEMBER ERDD_INVALIDRECORDLIST := 9001      // InvalidRecordList

	END ENUM
END NAMESPACE

#region Gencode Defines

	DEFINE EG_UNKNOWN        := GenCode.EG_UNKNOWN
	DEFINE EG_ARG            := GenCode.EG_ARG
	DEFINE EG_BOUND          := GenCode.EG_BOUND
	DEFINE EG_STROVERFLOW    := GenCode.EG_STROVERFLOW
	DEFINE EG_NUMOVERFLOW    := GenCode.EG_NUMOVERFLOW
	DEFINE EG_ZERODIV        := GenCode.EG_ZERODIV
	DEFINE EG_NUMERR         := GenCode.EG_NUMERR
	DEFINE EG_SYNTAX         := GenCode.EG_SYNTAX
	DEFINE EG_COMPLEXITY     := GenCode.EG_COMPLEXITY
	DEFINE EG_MEMOVERFLOW    := GenCode.EG_MEMOVERFLOW
	DEFINE EG_SEQUENCE       := GenCode.EG_SEQUENCE
	DEFINE EG_MEM            := GenCode.EG_MEM
	DEFINE EG_NOFUNC         := GenCode.EG_NOFUNC
	DEFINE EG_NOMETHOD       := GenCode.EG_NOMETHOD
	DEFINE EG_NOVAR          := GenCode.EG_NOVAR
	DEFINE EG_NOALIAS        := GenCode.EG_NOALIAS
	DEFINE EG_NOVARMETHOD    := GenCode.EG_NOVARMETHOD
	DEFINE EG_BADALIAS       := GenCode.EG_BADALIAS
	DEFINE EG_DUPALIAS       := GenCode.EG_DUPALIAS
	DEFINE EG_NULLVAR        := GenCode.EG_NULLVAR
	DEFINE EG_CREATE         := GenCode.EG_CREATE
	DEFINE EG_OPEN           := GenCode.EG_OPEN
	DEFINE EG_CLOSE          := GenCode.EG_CLOSE
	DEFINE EG_READ           := GenCode.EG_READ
	DEFINE EG_WRITE          := GenCode.EG_WRITE
	DEFINE EG_PRINT          := GenCode.EG_PRINT
	DEFINE EG_NOATOM         := GenCode.EG_NOATOM
	DEFINE EG_NOCLASS        := GenCode.EG_NOCLASS
	DEFINE EG_WRONGCLASS     := GenCode.EG_WRONGCLASS
	DEFINE EG_REFERENCE      := GenCode.EG_REFERENCE
	DEFINE EG_UNSUPPORTED    := GenCode.EG_UNSUPPORTED
	DEFINE EG_LIMIT          := GenCode.EG_LIMIT
	DEFINE EG_CORRUPTION     := GenCode.EG_CORRUPTION
	DEFINE EG_DATATYPE       := GenCode.EG_DATATYPE
	DEFINE EG_DATAWIDTH      := GenCode.EG_DATAWIDTH
	DEFINE EG_NOTABLE        := GenCode.EG_NOTABLE
	DEFINE EG_NOORDER        := GenCode.EG_NOORDER
	DEFINE EG_SHARED         := GenCode.EG_SHARED
	DEFINE EG_UNLOCKED       := GenCode.EG_UNLOCKED
	DEFINE EG_READONLY       := GenCode.EG_READONLY
	DEFINE EG_APPENDLOCK     := GenCode.EG_APPENDLOCK
	DEFINE EG_LOCK           := GenCode.EG_LOCK
	DEFINE EG_LOCK_ERROR     := GenCode.EG_LOCK_ERROR
	DEFINE EG_LOCK_TIMEOUT   := GenCode.EG_LOCK_TIMEOUT
	DEFINE EG_STACK          := GenCode.EG_STACK
	DEFINE EG_EVALSTACK      := GenCode.EG_EVALSTACK
	DEFINE EG_ERRORBLOCK     := GenCode.EG_ERRORBLOCK
	DEFINE EG_PROTECTION     := GenCode.EG_PROTECTION
	DEFINE EG_BADPTR         := GenCode.EG_BADPTR
	DEFINE EG_BADPAGEFAULT   := GenCode.EG_BADPAGEFAULT
	DEFINE EG_ERRORBUILD     := GenCode.EG_ERRORBUILD
	DEFINE EG_DYNPTR         := GenCode.EG_DYNPTR
	DEFINE EG_INACCESSIBLETYPE	:= GenCode.EG_INACCESSIBLETYPE
	DEFINE EG_AMBIGUOUSMETHOD	:= GenCode.EG_AMBIGUOUSMETHOD
	DEFINE EG_SEND_MISSINGARG	:= GenCode.EG_SEND_MISSINGARG
	DEFINE EG_SEND_TOOMANYARGS	:= GenCode.EG_SEND_TOOMANYARGS
	DEFINE EG_EXCEPTION			:= GenCode.EG_EXCEPTION

	DEFINE EG_MAX            := GenCode.EG_MAX

#endregion

#region Severity Defines
	DEFINE ES_WHOCARES     := Severity.ES_WHOCARES
	DEFINE ES_WARNING      := Severity.ES_WARNING
	DEFINE ES_ERROR        := Severity.ES_ERROR
	DEFINE ES_CATASTROPHIC := Severity.ES_CATASTROPHIC

#endregion

#region Other error defines

DEFINE E_BREAK		            := (0xFFFF)
DEFINE E_RETRY		            := (1)
DEFINE E_DEFAULT	            := (0)
DEFINE E_EXCEPTION              := 5333L
DEFINE E_ACCESSVIOLATION        := (5333L)
DEFINE E_DATATYPE_MISALIGNMENT  := (5334L)
DEFINE E_SINGLE_STEP            := (5335L)
DEFINE E_ARRAY_BOUNDS_EXCEEDED  := (5336L)
DEFINE E_FLT_DENORMAL_OPERAND   := (5337L)
DEFINE E_FLT_DIVIDE_BY_ZERO     := (5338L)
DEFINE E_FLT_INEXACT_RESULT     := (5339L)
DEFINE E_FLT_INVALID_OPERATION  := (5340L)
DEFINE E_FLT_OVERFLOW           := (5341L)
DEFINE E_FLT_STACK_CHECK        := (5342L)
DEFINE E_FLT_UNDERFLOW          := (5343L)
DEFINE E_INT_DIVIDE_BY_ZERO     := (5344L)
DEFINE E_INT_OVERFLOW           := (5345L)
DEFINE E_PRIV_INSTRUCTION       := (5346L)
DEFINE E_ILLEGAL_INSTRUCTION    := (5347L)
DEFINE E_NONCONTINUABLE_EXCEPTION := (5348L)
DEFINE E_STACK_OVERFLOW         := (5349L)
DEFINE E_INVALID_DISPOSITION    := (5350L)
DEFINE E_GUARD_PAGE             := (5351L)
#endregion


QtScriptTools: module updated (formatting)

Modified:
source/QtScriptTools/QScriptEngineDebuggerClass.prg

/*

  Qt4xHb - bibliotecas de ligao entre Harbour/xHarbour e Qt Framework 4

  Copyright (C) 2017 Marcos Antonio Gambeta <marcosgambeta AT outlook DOT com>

*/

#include "hbclass.ch"

#ifndef QT4XHB_NO_REQUESTS
REQUEST QACTION
REQUEST QMENU
REQUEST QTOOLBAR
REQUEST QMAINWINDOW
REQUEST QWIDGET
#endif

CLASS QScriptEngineDebugger INHERIT QObject

   DATA self_destruction INIT .F.

   METHOD new
   METHOD delete
   METHOD action
   METHOD attachTo
   METHOD autoShowStandardWindow
   METHOD createStandardMenu
   METHOD createStandardToolBar
   METHOD detach
   METHOD setAutoShowStandardWindow
   METHOD standardWindow
   METHOD state
   METHOD widget
   METHOD onEvaluationResumed
   METHOD onEvaluationSuspended
   DESTRUCTOR destroyObject

END CLASS

PROCEDURE destroyObject () CLASS QScriptEngineDebugger
   IF ::self_destruction
      ::delete()
   ENDIF
RETURN

#pragma BEGINDUMP

#include <QScriptEngineDebugger>

#include "qt4xhb_common.h"
#include "qt4xhb_macros.h"
#include "qt4xhb_utils.h"

/*
QScriptEngineDebugger ( QObject * parent = 0 )
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_NEW )
{
  QScriptEngineDebugger * o = new QScriptEngineDebugger ( OPQOBJECT(1,0) );
  _qt4xhb_storePointerAndFlag ( o, false );
}

HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_DELETE )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );

  if( obj )
  {
    delete obj;
    obj = NULL;
    PHB_ITEM self = hb_stackSelfItem();
    PHB_ITEM ptr = hb_itemPutPtr( NULL, NULL );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
  }

  hb_itemReturn( hb_stackSelfItem() );
}

/*
QAction * action ( DebuggerAction action ) const
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_ACTION )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QAction * ptr = obj->action ( (QScriptEngineDebugger::DebuggerAction) hb_parni(1) );
    _qt4xhb_createReturnClass ( ptr, "QACTION" );
  }
}

/*
void attachTo ( QScriptEngine * engine )
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_ATTACHTO )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QScriptEngine * par1 = (QScriptEngine *) hb_itemGetPtr( hb_objSendMsg( hb_param(1, HB_IT_OBJECT ), "POINTER", 0 ) );
    obj->attachTo ( par1 );
  }
  hb_itemReturn( hb_stackSelfItem() );
}

/*
bool autoShowStandardWindow () const
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_AUTOSHOWSTANDARDWINDOW )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    RBOOL( obj->autoShowStandardWindow () );
  }
}

/*
QMenu * createStandardMenu ( QWidget * parent = 0 )
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_CREATESTANDARDMENU )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QMenu * ptr = obj->createStandardMenu ( OPQWIDGET(1,0) );
    _qt4xhb_createReturnClass ( ptr, "QMENU" );
  }
}

/*
QToolBar * createStandardToolBar ( QWidget * parent = 0 )
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_CREATESTANDARDTOOLBAR )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QToolBar * ptr = obj->createStandardToolBar ( OPQWIDGET(1,0) );
    _qt4xhb_createReturnClass ( ptr, "QTOOLBAR" );
  }
}

/*
void detach ()
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_DETACH )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    obj->detach ();
  }
  hb_itemReturn( hb_stackSelfItem() );
}

/*
void setAutoShowStandardWindow ( bool autoShow )
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_SETAUTOSHOWSTANDARDWINDOW )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    obj->setAutoShowStandardWindow ( PBOOL(1) );
  }
  hb_itemReturn( hb_stackSelfItem() );
}

/*
QMainWindow * standardWindow () const
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_STANDARDWINDOW )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QMainWindow * ptr = obj->standardWindow ();
    _qt4xhb_createReturnClass ( ptr, "QMAINWINDOW" );
  }
}

/*
DebuggerState state () const
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_STATE )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    hb_retni( (int) obj->state () );
  }
}

/*
QWidget * widget ( DebuggerWidget widget ) const
*/
HB_FUNC_STATIC( QSCRIPTENGINEDEBUGGER_WIDGET )
{
  QScriptEngineDebugger * obj = (QScriptEngineDebugger *) hb_itemGetPtr( hb_objSendMsg( hb_stackSelfItem(), "POINTER", 0 ) );
  if( obj )
  {
    QWidget * ptr = obj->widget ( (QScriptEngineDebugger::DebuggerWidget) hb_parni(1) );
    _qt4xhb_createReturnQWidgetClass ( ptr, "QWIDGET" );
  }
}

#pragma ENDDUMP