'===========================================================================
' Subject: SUPER EMS                         Date: 12/30/92 (00:00)       
' Author:  Quinn Tyler Jackson               Code: PDS, VBDOS             
' Keys:    SUPER,EMS                       Packet: MEMORY.ABC
'===========================================================================
' JackMack SuperArray Management Kit v1.0
' Released into the public domain on 30 December 1992
' Written by Quinn Tyler Jackson, JackMack Consulting & Development

' This array management tool is programmed for VBDOS 1.0, but may
' be fully compatible with BASIC PDS 7.x.  It uses advanced features
' not found in QuickBASIC 4.5, but these features MAY be worked out
' by enterprising programmers.  Words to look for in the source code
' include: PRESERVE.

' Features of this application:

' INTEGER and LONG numeric arrays can be stored in EMS memory, leaving
' space free for bigger and better things.  Arrays are referenced not by
' obscure numbers and handles, but by user assigned names that may include
' ANY character.  That means that an array COULD conceivably be called
' "This is my array."

' STRING arrays are stored to a to virtual memory file, and are variable
' length.  Only their pointers are stored in RAM, and even these are stored
' safely out of the way in EMS.  In short, as long as disk space allows,
' one could have a 300,000 element string array, each element being between
' one and 32000 some odd characters long, and it wouldn't take up any more
' of DGROUP or far string space than any other STRING JmArray.
' Also note that STRING arrays are compressed onto the virtual disk file
' if they do not contain high-ASCII characters, to conserve disk space.

' Some academic points illustrated by this program:

'   1) Pointer referencing,
'   2) End user modifiable array names,
'   3) "Handle-based" arrays,
'   4) Virtual memory.

' NOTE: To allow for INTEGER and LONG values to be passed back from the
'       same function that returns STRING values, all values are passed
'       back as STRING.  They must be converted thus:
'
'       ErrorCode = JmSET ("My array", 10, "100")
'       IntegerValue = VAL(JmGet ("My array",10))
'
'       This is unfortunate, but allows one function to return ALL types
'       of data, not just one per function.

' These seven routines are from Hanlin's PBCLONE 1.9 library.  Earlier
' versions of PBCLONE might work, too.

DECLARE FUNCTION IsASCII% (Ch$)
DECLARE FUNCTION StrSqu$ (St$)
DECLARE FUNCTION StrUnSq$ (St$)
DECLARE SUB EMSClose (BYVAL ArrayHandle%)
DECLARE SUB EMSOpen (Elements&, ElementType%, ArrayHandle%, ErrCode%)
DECLARE SUB EMSGet (BYVAL ArrayHandle%, ElementNr&, Value AS ANY)
DECLARE SUB EMSPut (BYVAL ArrayHandle%, ElementNr&, Value AS ANY)

' These routines are local to this particular program.
DECLARE FUNCTION IsAllASCII (Txt$) AS INTEGER
DECLARE FUNCTION JmDIM% (ArrayName$, Elements AS LONG, ArrayType%)
DECLARE FUNCTION JmWORD (InExpression$, Index%) AS STRING
DECLARE FUNCTION JmSET% (ArrayName$, Element AS LONG, Vlue AS STRING)
DECLARE FUNCTION JmERASE% (ArrayName$)

OPTION BASE 1 ' I prefer things to start at one.  Humans tend to count that
              ' way, don't you agree?

'Some system constants.
CONST BUFFER_MAX = 10           ' How many previously read strings to
buffer.
CONST VirtualFile = "JMVSA.$$$" ' Virtual string memory file.
CONST StartSize = 10            ' Initial size of pointer array.

'Ye olde tradional Boolean logic constants
CONST TRUE = (1 = 1)            ' I prefer (1=1) since it is compiler
                                ' independent, whereas -1 is specific to
                                ' MS BASICS.
CONST FALSE = NOT TRUE

' Array Types
CONST Array_Integer = 1
CONST Array_Long = 2
CONST Array_String = 3

' Errors that might happen
CONST Err_EMS_Allocation = -1
CONST Err_Bad_Subscript = -2
CONST Err_Array_Not_Dimensioned = -3
CONST Err_Overflow = -4
CONST Err_DOS_Error = -5

' PointerType for the array cross-reference table.
TYPE PointerType  Elements AS LONG  ' How many array elements array has.

    Handle AS INTEGER               ' EMS handle of either data or ptr table
                                    ' (String arrays use an EMS ptr table).

    ArrayType AS INTEGER            ' What type of array we're dealing with.

    Accesses AS LONG                ' How many times this array is accessed.
END TYPE

DEFINT A-Z
'$DYNAMIC arrays are going to be used so they can be redimensioned.

' PtrArray changes size and must be preserved when it does so. Therefore,
' QuickBASIC users might have to rethink the logic I have used throughout.
DIM SHARED PtrArray(StartSize) AS PointerType

REDIM SHARED AName$(StartSize)          ' Names of arrays.
DIM SHARED VirtualHandle AS INTEGER     ' Handle of virtual memory file.

' The simple sample application to show syntax follows here.  Normally, your
' program would go here....


CLS
' A 300,000 element string array!  Requires lots of EMS for pointers! A
' one million element array would require 4 Megs of free EMS, but wouldn't
' take up any more DGROUP or conventional memory than a two element array!

INPUT "This array can have any name you'd like: ", Array$
' Arrays can be named at the end-user level.  This is good for database
' applications and is a powerful feature.  The user is not forced to refer
' to his specific data by any contrived name other than the one he or she
' assigns!

nul = JmDIM(Array$, 1000, Array_String)
IF nul < 0 THEN PRINT "ERROR": END
PRINT nul
PRINT "Getting data from array '" + Array$ + "'."
nul = JmSET(Array$, 1000, "This is a test.  The test seems to have worked.")

PRINT JmGET(Array$, 1000, ErrCode)

nul = JmERASE("*") 'Be sure to do this to free EMS handles and memory!

FUNCTION IsAllASCII (Txt$) AS INTEGER
FOR scan = 1 TO LEN(Txt$)
    IF NOT IsASCII(MID$(Txt$, scan, 1)) THEN
        IsAllASCII = FALSE
        EXIT FUNCTION
    END IF
NEXT
IsAllASCII = TRUE
END FUNCTION

FUNCTION JmDIM (ArrayName$, Elements AS LONG, ArrayType) AS INTEGER
STATIC ArrayPtr AS INTEGER

' Get First Available spot in list.
FOR scan = 1 TO UBOUND(PtrArray)
    IF AName$(scan) = "" THEN
        ArrayPtr = scan
        Flag = TRUE
        EXIT FOR
    END IF
NEXT scan

IF NOT Flag THEN ' We have to make room for a new array, since no spots left.
    ArrayPtr = UBOUND(PtrArray) + 1
    REDIM PRESERVE PtrArray(ArrayPtr) AS PointerType
    REDIM PRESERVE AName$(ArrayPtr)
END IF


SELECT CASE ArrayType
    CASE Array_Integer, Array_Long
        AName$(ArrayPtr) = ArrayName$
        PtrArray(ArrayPtr).Elements = Elements
        PtrArray(ArrayPtr).ArrayType = ArrayType
        EMSOpen Elements, Array_Type, Handle, ErrCode
        PtrArray(ArrayPtr).Handle = Handle
        IF ErrCode THEN
            JmDIM = -1
            EXIT FUNCTION
        ELSE
            JmDIM = Handle
            EXIT FUNCTION
        END IF

    CASE Array_String, Array_Compressed
        AName$(ArrayPtr) = ArrayName$
        PtrArray(ArrayPtr).Elements = Elements
        PtrArray(ArrayPtr).ArrayType = ArrayType
        IF NOT VirtualHandle THEN 'we haven't opened the virtual file yet.
            VirtualHandle = FREEFILE
            OPEN VirtualFile FOR BINARY AS VirtualHandle
        END IF
        ' This EMS array is an array of POINTERS to file offsets.
        EMSOpen Elements, Array_Long, Handle, ErrCode
        PtrArray(ArrayPtr).Handle = Handle
        IF ErrCode THEN
            JmDIM = -1
            EXIT FUNCTION
        ELSE
            JmDIM = Handle
            EXIT FUNCTION
        END IF
END SELECT

END FUNCTION

FUNCTION JmERASE (ArrayName$)

IF ArrayName$ <> "*" THEN ' The asterix is intended to erase ALL JmArrays!!
    FOR scan = 1 TO UBOUND(PtrArray)
        IF ArrayName$ = AName$(scan) THEN
                'Release EMS being used by array.
                EMSClose PtrArray(scan).Handle
                'Show the name as blank so that it is freed for future use.
                AName$(scan) = ""
                Flag = TRUE
                EXIT FOR
        END IF
    NEXT scan
    IF NOT Flag THEN
        ' We tried to ERASE an array that didn't exist.  Names ARE
        ' case sensitive, so "Quinn" and "quinn" are different.
        JmERASE = Err_Array_Not_Dimensioned
        EXIT FUNCTION
    END IF
ELSE
    CLOSE VirtualHandle ' Close the virtual string file and
'    KILL VirtualFile    ' get rid of it.

    FOR scan = 1 TO UBOUND(PtrArray)
        IF AName$(scan) <> "" THEN
            'Release EMS used by array.
            EMSClose PtrArray(scan).Handle
        END IF
    NEXT scan

    REDIM PtrArray(1) AS PointerType
    REDIM AName$(1)
    VirtualHandle = 0
END IF
END FUNCTION

FUNCTION JmGET (ArrayName$, Element AS LONG, ErrCode AS INTEGER) AS STRING
STATIC BufferPtr

FOR scan = 1 TO UBOUND(PtrArray)
    IF ArrayName$ = AName$(scan) THEN
        IF Element > PtrArray(scan).Elements THEN
            ErrCode = Err_Bad_Subscript
            EXIT FUNCTION
        END IF
        SELECT CASE PtrArray(scan).ArrayType
            CASE Array_Integer
                EMSGet PtrArray(scan).Handle, Element, TempInt%
                JmGET = STR$(TempInt%)
                Flag = TRUE
                EXIT FOR

            CASE Array_Long
                EMSGet PtrArray(scan).Handle, Element, TempLong&
                JmGET = STR$(TempLong&)
                Flag = TRUE
                EXIT FOR

            CASE Array_String
                EMSGet PtrArray(scan).Handle, Element, EndPtr&

                ON LOCAL ERROR GOTO DOSErrorGet
                    ' First find the right spot in virtual file.
                    SEEK VirtualHandle, EndPtr&
                    ' Then find out how much data to read from file.
                    GET VirtualHandle, , Leng%
                    ' Then prepare an adequate buffer.
                    Buffer$ = SPACE$(ABS(Leng%))
                    ' And finally suck it in through the straw.
                    GET VirtualHandle, , Buffer$
                ON LOCAL ERROR GOTO 0

                ' Negative lengths indicate previous compression.
                IF Leng% < 0 THEN Buffer$ = StrUnSq(Buffer$)
                JmGET = Buffer$
                Flag = TRUE
                EXIT FOR
        END SELECT
    END IF
NEXT scan

IF NOT Flag THEN
    ErrCode = Err_Array_Not_Dimensioned
    EXIT FUNCTION
END IF

EXIT FUNCTION

DOSErrorGet:
' Something happened that had to be trapped.
ErrCode = Err_DOS_Error
EXIT FUNCTION

END FUNCTION

FUNCTION JmSET (ArrayName$, Element AS LONG, Vlue AS STRING)
FOR scan = 1 TO UBOUND(PtrArray)
    IF ArrayName$ = AName$(scan) THEN
        IF Element > PtrArray(scan).Elements THEN
            JmSET = Err_Bad_Subscript
            EXIT FUNCTION
        END IF
        SELECT CASE PtrArray(scan).ArrayType

            CASE Array_Integer
                TempInt& = VAL(Vlue)
                IF TempInt& > 32768 OR TempInt& < -32768 THEN
                    ' Someone forgot his BASIC basics.
                    JmSET = Err_Overflow
                    EXIT FUNCTION
                END IF
                TempInt% = TempInt&
                ' Stuff it up there in EMS land.
                EMSPut PtrArray(scan).Handle, Element, TempInt%
                Flag = TRUE
                EXIT FOR

            CASE Array_Long
                TempLong& = VAL(Vlue)
                EMSPut PtrArray(scan).Handle, Element, TempLong&
                Flag = TRUE
                EXIT FOR

            CASE Array_String

                ' New string assignments added to end of virtual file.
                EndPtr& = LOF(VirtualHandle) + 1
                EMSPut PtrArray(scan).Handle, Element, EndPtr&
                ON LOCAL ERROR GOTO DOSErrorSet
                    SEEK VirtualHandle, EndPtr&
                    ' Add the string length to the string for later use.
                    SELECT CASE IsAllASCII(Vlue)
                        CASE TRUE
                            'Compress string.
                            Vlue = StrSqu(Vlue)
                            ' Make it < 0 if compressed.
                            Vlue = MKI$(-LEN(Vlue)) + Vlue
                        CASE ELSE
                            Vlue = MKI$(LEN(Vlue)) + Vlue
                    END SELECT
                    PUT VirtualHandle, , Vlue
                ON LOCAL ERROR GOTO 0
                Flag = TRUE
                EXIT FOR

        END SELECT
    END IF
NEXT scan

IF NOT Flag THEN
    JmSET = Err_Bad_Array_Name
    EXIT FUNCTION
END IF

EXIT FUNCTION
DOSErrorSet:
    JmSET = Err_DOS_Error
    EXIT FUNCTION

END FUNCTION