1. tk_mem.e bug
Hi all,
I've been trying to track down the problem with EuCOM and the memory errors.
I've tried lot's of stuff, including using Eu's allocate/free routines,
although those would cause a crash sooner than the Win32 routines used in
tk_mem.e. When I commented out the call to HeapFree, everything worked. I
further tracked down a line in release_mem that I don't understand, but once
commented out, allows everything to run.
Right before phase 3, release_mem checks sets[1] and frees it if it's not
zero. There's no comment that I can see, and I can't see why that would be
there. Maybe there's a reason, but I think this is the reason that
release_all_mem would sometimes fail in the past. Looks like the heap got
corrupted.
So, for those who emailed me with bugs when you ran EuCOM, please comment
out the following code in tk_mem.e and let me know if it works:
--if sets[1] != 0 then
-- myFree(sets[1])
--end if
I suspect that NT does a lot more checking of the heap than Win9X
(surprise!).
Derek, unless you have a reason for this being there, I'd recommend the same
for the next release of Win32Lib. :)
Matt Lewis
PS Regarding EuCOM, it looks like IDispatch::Invoke is called. I've figured
out a fix (wrote some ASM to accept the procedure call and transfer the args
from the stack to memory), and I'll get it up later today.
3. Re: tk_mem.e bug
This is a multi-part message in MIME format.
------=_NextPart_000_0044_01C0CEEE.1AB3C060
charset="iso-8859-1"
Matt,
after doing some more testing of the tk_mem.e library, I must disagree with
you. The lines you suggested to comment out are in fact needed. The reason
is that when release_mem() is called with the parameter being a 'memset' id
rather than a memory address, it is assumed that the memset id was acquired
by calling new_memset(). That routine creates a memset_id by acquiring some
memory from the heap and using that memory address as the memset id. Thus
when releasing a memset, the id value must also be freed. That's what the
lines in question are doing.
However, in the version of tk_mem.e sent out with v0.55.1 of win32lib, there
is a bug that may be relevent to the errors you are having. If release_mem()
is called using a memory address that is invalid or not acquired using
acquire_mem(), tk_mem.e still decrements the number of allocated blocks,
even though the specified memory was not actually released. And when the
block counter gets back to zero, it releases the heap. Thus any subsequent
references to previously acquired memory will cause a GPF. This bug has been
fixed in the next release.
There was another subtle bug that might have caused EuCOM to fail by not
Win32lib apps. If the abort handler was not set up, the release_mem() check
for invalid memory addresses still tried to release the memory. This also is
fixed.
I've attached to latest version of tk_mem_full.e for you (or anyone else) to
test.
------
Derek Parnell
Melbourne, Australia
"To finish a job quickly, go slower."
----- Original Message -----
From: "Matthew Lewis" <matthewwalkerlewis at YAHOO.COM>
To: "EUforum" <EUforum at topica.com>
Sent: Friday, April 27, 2001 2:55 AM
Subject: tk_mem.e bug
> >
>
> Hi all,
>
> I've been trying to track down the problem with EuCOM and the memory
errors.
> I've tried lot's of stuff, including using Eu's allocate/free routines,
> although those would cause a crash sooner than the Win32 routines used in
> tk_mem.e. When I commented out the call to HeapFree, everything worked.
I
> further tracked down a line in release_mem that I don't understand, but
once
> commented out, allows everything to run.
>
> Right before phase 3, release_mem checks sets[1] and frees it if it's not
> zero. There's no comment that I can see, and I can't see why that would
be
> there. Maybe there's a reason, but I think this is the reason that
> release_all_mem would sometimes fail in the past. Looks like the heap got
> corrupted.
>
> So, for those who emailed me with bugs when you ran EuCOM, please comment
> out the following code in tk_mem.e and let me know if it works:
>
> --if sets[1] != 0 then
> -- myFree(sets[1])
> --end if
>
> I suspect that NT does a lot more checking of the heap than Win9X
> (surprise!).
>
> Derek, unless you have a reason for this being there, I'd recommend the
same
> for the next release of Win32Lib. :)
>
> Matt Lewis
>
> PS Regarding EuCOM, it looks like IDispatch::Invoke is called. I've
figured
> out a fix (wrote some ASM to accept the procedure call and transfer the
args
> from the stack to memory), and I'll get it up later today.
>
>
> >
> >
> >
------=_NextPart_000_0044_01C0CEEE.1AB3C060
Content-Type: application/octet-stream;
name="tk_mem_full.e"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="tk_mem_full.e"
--------------------NOTICE-------------------------------
-- Software ID: tk_mem.e
-- Version: 0.56
-- Copyright: (c) 2000 David Cuny, Derek Parnell
-- All rights reserved.
-- Licence: =20
-- This software is provided 'as-is', without any express or implied =
warranty.
-- In no event will the authors be held liable for any damages arising =
from
-- the use of this software.
--
-- Permission is granted to anyone to use this software for any purpose,
-- including commercial applications, and to alter it and redistribute =
it
-- freely, subject to the following restrictictions:
-- 1. The origin of this software must not be misrepresented; you must =
not
-- claim that you wrote the original software.
-- 2. If you use this software in a product, acknowedgement in the =
product's
-- documenation and binary are required.
-- 3. Altered source versions, and works substantially derived from the =
it,
-- must...
-- a) be plainly be marked as such,
-- b) not be misrepresented as the original software,
-- c) include this notice, unaltered.
--------------------End of NOTICE------------------------
-- Last Changed on 27/04/2001 at 7:41:04 by Derek Parnell --
-- The library was originally developed by David Cuny, and over time, a=20
-- number of other people have made additions and corrections. Where
-- appropriate the work that other people have contributed is marked =
thus...
-- Begin <person's name>
-- End <person's name>
--/topic Memory Management routines
--/info
--Low-Level Memory management routines
without warning
with trace
include machine.e
include dll.e
include tk_misc.e
constant
HEAP_NO_SERIALIZE =3D #00000001,
HEAP_GROWABLE =3D #00000002,
HEAP_GENERATE_EXCEPTIONS =3D #00000004,
HEAP_ZERO_MEMORY =3D #00000008,
HEAP_REALLOC_IN_PLACE_ONLY =3D #00000010,
HEAP_TAIL_CHECKING_ENABLED =3D #00000020,
HEAP_FREE_CHECKING_ENABLED =3D #00000040,
HEAP_DISABLE_COALESCE_ON_FREE =3D #00000080,
HEAP_CREATE_ALIGN_16 =3D #00010000,
HEAP_CREATE_ENABLE_TRACING =3D #00020000,
kernel32 =3D open_dll( "kernel32.dll" ),
xHeapCreate =3D define_c_func(kernel32, "HeapCreate", {C_LONG, C_LONG, =
C_LONG}, C_LONG),
xHeapDestroy =3D define_c_func(kernel32, "HeapDestroy", {C_LONG}, =
C_LONG),
xHeapAlloc =3D define_c_func(kernel32, "HeapAlloc", {C_LONG, C_LONG, =
C_LONG}, C_LONG),
xHeapFree =3D define_c_func(kernel32, "HeapFree", {C_LONG, C_LONG, =
C_LONG}, C_LONG),
xIsBadWritePtr =3D define_c_func(kernel32, "IsBadWritePtr", {C_LONG, =
C_LONG}, C_LONG)
--CRITICAL_SECTION CriticalSection;
--// Initialize the critical section.
--InitializeCriticalSection(&CriticalSection);
--// Request ownership of the critical section.
-- EnterCriticalSection(&CriticalSection);
-- Access the shared resource.
-- Release ownership of the critical section.
--LeaveCriticalSection(&CriticalSection);
-- Release resources used by the critical section object.
--DeleteCriticalSection(&CriticalSection)
-- stores abort handler's routine id
integer vAbortRtn vAbortRtn =3D -1
-- The number of allocations on the current heap
integer vAllocations vAllocations =3D 0
-- List of memset ids
sequence vOwners vOwners =3D {}
-- List of address sets. Each set has a list of addresses.
sequence vSets vSets =3D {}
-- stores the accumulated size of a structure as it is being defined.
integer vAlloted vAlloted =3D 0
-- The heap acquired from Windows.
atom vHeap vHeap =3D 0
--/topic Memory Management Routines
--/func llSetAbort( i )
--/desc Sets the routine id of an Abort routine.
--/ret The previous value set.
--
-- Used to indicate if an error routine needs to be
-- called in the event of a catastophic error.
-- The error routine is assumed to be a procedure
-- that accepts a single sequence (typically an=20
-- message string).
--
-- Example:
--
-- /code =20
-- integer RtnID, OldID
-- RtnID =3D routine_id("abortErr")
-- OldID =3D llSetAbort(RtnID)
-- /endcode
global function llSetAbort(integer i)
-- Set the abort handler id. The routine must take two parameters,
-- a sequence (msg) and a integer (mode =3D=3D> 1=3Dwarning, 2=3Dfatal)
integer lOldRtn
=20
lOldRtn =3D vAbortRtn
=20
vAbortRtn =3D i
=20
return lOldRtn
end function
procedure myFree(atom pAddress)
object VOID
if vHeap =3D 0 then
return
end if
if c_func(xIsBadWritePtr, {pAddress, 1}) then
return
end if
=20
if c_func(xHeapFree,{ vHeap, 0, pAddress}) =3D 0 then
return
end if
vAllocations -=3D 1
if vAllocations =3D 0 then
VOID =3D c_func(xHeapDestroy,{ vHeap })
vHeap =3D 0
end if
=20
end procedure
function myAllocate(integer pSize)
atom lAddr
if vHeap =3D 0 then
vHeap =3D c_func(xHeapCreate,{0, 16000, 0})
if vHeap =3D 0 then
return 0
end if
end if
lAddr =3D c_func(xHeapAlloc,{ vHeap, HEAP_ZERO_MEMORY, pSize})
vAllocations +=3D 1
return lAddr
end function
----
-- Memory Management memory management Routines
----
global constant
Byte =3D -1,
Word =3D -2,
Integer =3D Word,
Long =3D -3,
DWord =3D Long,
UInt =3D Long,
Ptr =3D Long,
Lpsz =3D -4,
Hndl =3D -5,
HndlAddr =3D -6,
Strz =3D -7
constant vSizeNames =3D {Byte, Word, Long, Lpsz, Hndl, HndlAddr, Strz}
constant vSizeLengs =3D { 1, 2, 4, 4, 4, 4, 1}
--/topic Memory Management Routines
--/func manage_mem( atom Owner, atom Address)
--/desc Records an acquired memory for garbage collection.
-- Normally this is handled automatically by /acquire_mem() but if you
-- are expected to manage some memory acquired by another means, such as
-- a Windows call or a 'C' routine, you can use this to record the =
memory for
-- subsequent release by /release_mem().
--
-- Example:
-- /code =20
-- atom mset, pt, pstr
--
-- -- Establish a new memory set.
-- mset =3D /new_memset()
-- -- calls a routine which returns a structure address.
-- pt =3D c_func( xyz, {abc})
-- -- register this memory
-- manage_mem(mset, pt)
-- . . .
-- give all the memory area in 'mset' back
-- release_mem(mset)
-- /endcode
global procedure manage_mem( atom pOwner, atom pAddr )
-- save location for garbage collection
-- This also is used to move a block from one memset to another.
integer lOwnerSub, lAddrSub
-- Take the address out of any existing memset.
lAddrSub =3D 0
for i =3D 1 to length(vSets) do
lAddrSub =3D find(pAddr, vSets[i])
if lAddrSub !=3D 0 then
vSets[i] =3D removeIndex(lAddrSub, vSets[i])
exit
end if
end for
=20
-- Create a new memset if required.
lOwnerSub =3D find(pOwner, vOwners)
if lOwnerSub =3D 0 then
vOwners &=3D pOwner
lOwnerSub =3D length(vOwners)
vSets =3D append(vSets, {})
end if
-- Store the address into the specified memset
vSets[lOwnerSub] &=3D pAddr
end procedure
-- The memory allocated is linked to the /i Owner and all the
-- owner's memory can be released by one call. /n
-- If /i structure is a string, it is copied to the memory
-- location along with a zero byte.
--
-- If /i structure is an atom, it specifies that amount of memory
-- to acquire (a minimum of 4 bytes will always be acquired) and
-- the memory is set to all zeros.
--
--/ret Address of allocated memory.
--
-- Example:
-- /code =20
-- atom mset, pt, pstr
--
-- -- Establish a new memory set.
-- mset =3D /new_memset()
-- -- get enough memory to hold a UInt datatype
-- xy =3D acquire_mem( UInt )
-- -- allocate a point structure
-- pt =3D acquire_mem( mset, SIZEOF_POINT )
-- -- copy a Euphoria string to a 'C' string area.
-- pstr =3D /acquire_mem( mset, "My String Data" )
-- . . .
-- give all the memory area in 'mset' back
-- release_mem(mset)
-- /endcode
global function acquire_mem( atom pOwner, object pData )
-- allocate space for a structure (mininum of 4 bytes)
-- and initialize to zero
=20
atom at
if sequence(pData) then
-- place string in memory
at =3D myAllocate( 1 + length(pData) )
if at !=3D 0 then
poke(at, pData)
poke(at + length(pData) , 0)
end if
else
-- Check for special datatype "names"
if pData < 0 then
pData =3D find(pData, vSizeNames)
if pData !=3D 0 then
pData =3D vSizeLengs[pData]
end if
end if
if pData < 4 then
pData =3D 4
end if
at =3D myAllocate( pData )
if at !=3D 0 then
mem_set( at, 0, pData )
end if
end if
=20
if at =3D 0 then
if vAbortRtn >=3D 0
then
call_proc(vAbortRtn, { "Unable to allocate space.", 2 } )
end if
else
manage_mem(pOwner, at)
end if
return at
=20
end function
--/topic Memory Management Routines
--/proc release_mem( atom structure )
--/desc Returns the memory allocated by /acquire_mem() back to the =
system.
-- If /i structure is a memory set id, as returned by /new_memset(), =
then
-- all the memory owned in the memory set is returned and the memory set =
id
-- is released. That is, it cannot be reused. /n
-- If /i structure is a memory address returned by /acquire_mem(), then =
just
-- that memory is released. The memory set it belonged to is still =
usable.
--
-- Example:
-- /code =20
-- atom mset, pt, pstr
--
-- -- Establish a new memory set.
-- mset =3D /new_memset()
-- -- get enough memory to hold a UInt datatype
-- xy =3D /acquire_mem( UInt )
-- -- allocate a point structure
-- pt =3D /acquire_mem( mset, SIZEOF_POINT )
-- -- copy a Euphoria string to a 'C' string area.
-- pstr =3D /acquire_mem( mset, "My String Data" )
-- . . .
-- give all the memory area in 'mset' back
-- release_mem(mset)
-- /endcode
global procedure release_mem( atom pData )
integer lOwnerSub
integer lAddrSub, lAddrList
integer ls, ss, Phase1
sequence sets
-- Check for "special" uninitialized memset value.
if pData =3D -1 then
return
end if
-- See if this is a memset owner.
lOwnerSub =3D find(pData, vOwners)
=20
if lOwnerSub =3D 0 then
-- If not a memset, see which memset it belongs to.
lAddrSub =3D 0
for i =3D 1 to length(vSets) do
lAddrSub =3D find(pData, vSets[i])
if lAddrSub !=3D 0 then
lAddrList =3D i
exit
end if
end for
if lAddrSub =3D 0 then
-- Not in any memset!
if vAbortRtn >=3D 0 then
call_proc(vAbortRtn, {"Trying to release unacquired =
memory", 2})
end if
=20
else
-- Remove it from the memset
vSets[lAddrList] =3D removeIndex(lAddrSub,
vSets[lAddrList])
-- Give the memory back to the system
myFree(pData)
end if
return
end if
--
sets =3D {pData}
ss =3D 1
-- Phase 1: Identified the complete hierarchy of owned memory sets.
Phase1 =3D 1
while Phase1 do
ls =3D length(sets)
for i =3D ss to ls do
lOwnerSub =3D find(sets[i], vOwners)
for j =3D 1 to length(vSets[lOwnerSub]) do
lAddrSub =3D find(vSets[lOwnerSub][j],
vOwners)
if lAddrSub !=3D 0 then
sets &=3D vOwners[lAddrSub]
end if
end for
end for
ss =3D ls + 1
Phase1 =3D (ls !=3D length(sets))
end while
-- Phase 2: Free the memory addresses.
for i =3D length(sets) to 1 by -1 do
lOwnerSub =3D find(sets[i], vOwners)
for j =3D 1 to length(vSets[lOwnerSub]) do
if vSets[lOwnerSub][j] !=3D 0 then
myFree(vSets[lOwnerSub][j])
end if
end for
end for
if sets[1] !=3D 0 then
myFree(sets[1])
end if
-- Phase 3: - clean up the allocation array
for i =3D 1 to length(sets) do
lOwnerSub =3D find(sets[i], vOwners)
vSets =3D removeIndex(lOwnerSub, vSets)
vOwners =3D removeIndex(lOwnerSub, vOwners)
for j =3D 1 to length(vSets) do
lOwnerSub =3D find(sets[i], vSets[j])
if lOwnerSub !=3D 0 then
vSets[j] =3D removeIndex(lOwnerSub,
vSets[j])
exit
end if
end for
end for
end procedure
-- This gives back to the system, all the memory acquired by calling
-- /acquire_mem(). You must not use any previously acquired memory =
blocks
-- after this has been called. /n
--
-- /b"NOTE:" When using the Win32Lib library, it is /b not required to =
call
-- this function as that is done automatically when WinMain() completes.
--
-- /b"WARNING:" Calling this before WinMain() has ended will probably =
cause the
-- the /i Win32Lib routines to crash.
--
-- Example:
--
--/code
-- -- Return all the memory areas
-- release_all_mem()
--
--/endcode
global procedure release_all_mem()
atom VOID
-- Matt Lewis 3/14/01
-- changed this to avoid GPF on close
if vHeap then
VOID =3D c_func(xHeapDestroy,{ vHeap })
=20
-- reinitialize variables
vSets =3D {}
vOwners =3D {}
vHeap =3D 0
vAllocations =3D 0
vAlloted =3D 0
end if
end procedure
--/ret SEQUENCE: Definition to allotted memory.
-- /i FldDefn is either a number of bytes to allocate, one of the =
predefined
-- datatypes (listed below), or a 2-element sequence containing a repeat =
count
-- and a datatype or length.
--
-- If a number of bytes is supplied, the field is aligned to the next =
32-bit
-- boundry before allocation.
--
-- The returned allotment definition is used by /store and /fetch. It =
has the
-- following structure. /n
-- The definition has three items: /n
-- An /i offset, a /i datatype, and a /i"repeat length" /n
-- Allowable types are: /n
-- /li /b Byte: 8 bit value
-- /li /b Word: 16 bit value
-- /li /b Integer: 16 bit value, save as /b Word
-- /li /b Long: 32 bit value
-- /li /b DWord: 32 bit value, same as /b Long
-- /li /b Ptr: 32 bit value, same as /b Long
-- /li /b Hndl: 32 bit value, a pointer to a pointer
-- /li /b HndlAddr: 32 bit value,
-- /li /b Lpsz: Long pointer (32 bits) to zero delimited string
-- /li /b Strz: Fixed size buffer that holds a zero-delim string
--=20
-- Example:
--
-- /code
-- constant
-- msLeft =3D allot( Long ),
-- msTop =3D allot( Long ),
-- msRight =3D allot( Long ),
-- msBottom =3D allot( Long ),
-- msXYZ =3D allot( {4, DWord} ),
-- msReserved =3D allot( 5 ),
-- msName =3D allot( Lpsz ),
-- msBuffer =3D allot( {128, Strz} ),
-- SIZEOF_MYSTRUCT =3D /allotted_size()
-- /endcode
global function allot( object pDataType )
integer soFar, diff, size, i, lCnt
if sequence(pDataType) then
lCnt =3D pDataType[1]
i =3D pDataType[2]
else
lCnt =3D 1
i =3D pDataType
end if
=20
-- save position =20
soFar =3D vAlloted
-- if not a pre-defined type, make sure it gets a word boundary
size =3D find(i, vSizeNames)
if size =3D 0
then
if i > 0 then
diff =3D remainder( soFar, 4 )
if diff then
-- word align
soFar =3D soFar + 4 - diff
end if
-- size is actual size
size =3D i
end if
else
size =3D vSizeLengs[size]
end if
-- allot space
vAlloted +=3D (size * lCnt)
=20
-- return offset, data type and count
return { soFar, i, lCnt }
=20
end function
instructions
-- to get the address from the handle, rather than the handle itself. /n
-- An empty sequence is returned if the parameter was invalid.
--/ret SEQUENCE: Handle's "offset" into a structure.
--
-- Example:
--
-- /code =20
-- constant
-- hDemo =3D /allot( Hndl ),
-- pDemo =3D /allot_handle( hDemo ),
-- SIZEOF_DEMO =3D /allotted_size()
-- . . .
-- x =3D allocate_struct(SIZEOF_DEMO)
-- initDEMO(x)
--
-- h =3D fetch(x, hDemo)
-- a =3D fetch(x, pDemo)
-- -- 'h' will contain the handle, and 'a' the address from the =
handle.
-- /endcode
global function allotted_handle(sequence pHandle)
if length(pHandle) =3D 3
and
pHandle[2] =3D Hndl
then
return {pHandle[1], HndlAddr, pHandle[3]}
else
return {}
end if
=20
=20
end function
--/ret INTEGER: Allotted size of structure.
--
-- Example:
--
-- /code =20
-- constant
-- rectLeft =3D /allot( Long ),
-- rectTop =3D /allot( Long ),
-- rectRight =3D /allot( Long ),
-- rectBottom =3D /allot( Long ),
-- SIZEOF_RECT =3D /allotted_size()
-- /endcode
global function allotted_size()
-- returns allotted size, and clears size
integer soFar
=20
soFar =3D vAlloted
vAlloted =3D 0
=20
return soFar
=20
end function
=20
-- Type conversion is automatic. For example, if an /b Lpsz field is=20
-- used, the value is automatically converted from a sequence to a=20
-- C-style string, and the address of that string is stored in the=20
-- structure.
--
-- Example:
--
--/code
-- -- allocate RECT structure, and populate it
-- atom rect =20
--
-- -- allocate the structure
-- rect =3D /allocate_struct( SIZEOF_RECT )
--
-- -- store values into the structure
-- /store( rect, rectLeft, x1 )
-- /store( rect, rectTop, y1 )
-- /store( rect, rectRight, x2 )
-- /store( rect, rectBottom, y2 )
--/endcode
global procedure store( atom struct, sequence s, object o )
-- Store the data based on its type
integer where, datatype, lCnt
atom at
sequence bytes
=20
-- rest data type
where =3D s[1] + struct
datatype =3D s[2]
lCnt =3D s[3]
-- For sequences, make sure no more than lCnt elements are stored.
if sequence(o) then
if length(o) < lCnt then
lCnt =3D length(o)
end if
end if
=20
-- read, based on datatype
if datatype =3D Byte then
-- poke a byte
if atom(o) then
poke( where, o )
else
poke(where, o[1 .. lCnt])
end if
=20
elsif datatype =3D Word then
-- poke a word
bytes =3D int_to_bytes( o )
poke( where, bytes[1 .. 2] )
=20
elsif datatype =3D Long then
-- poke long(s)
if atom(o) then
poke4( where, o )
else
poke4(where, o[1 .. lCnt])
end if
elsif datatype =3D Lpsz then
-- if atom, treat as long =20
if atom( o ) then
poke4( where, o )
else
-- poke the address of the allotted string
poke4( where, acquire_mem( struct, o ) )
end if
=20
elsif datatype =3D Hndl then
-- poke handle(s)
if atom(o) then
poke4( where, o )
else
poke4(where, o[1 .. lCnt])
end if
elsif datatype =3D HndlAddr then
-- poke a handle's address
at =3D acquire_mem(struct, 4)
poke4( at, o)
poke4( where, at )
elsif datatype =3D Strz then
-- poke a zero-terminated string
bytes =3D o & 0
if lCnt < s[3] then
lCnt +=3D 1
end if
poke(where, bytes[1 .. lCnt])
else
-- poke a string =20
poke( where, o[1 .. lCnt] )
end if
end procedure
--/ret SEQUENCE: containing the C-style string.
-- This is typically done automatically by the /fetch
-- function.
--
-- Example:
--
--/code
-- -- get a C-string from address
-- sequence s
--
-- s =3D /peek_string( address )
--/endcode
integer pPeekStringBufSize pPeekStringBufSize =3D 256
global function peek_string(atom a)
integer i, l, sl
sequence s
-- Initialise
s =3D {}
sl =3D 0
l =3D 0
-- Only deal with non-zero addresses
if a then
-- pick up first byte
i =3D peek(a)
-- Repeat until we find a zero byte
while i do
-- increment string size so far
l +=3D 1
-- if the string buffer size is not big enough
-- then expand it.
if sl < l then
s &=3D repeat(0,pPeekStringBufSize)
sl +=3D pPeekStringBufSize
end if
-- put into the string buffer the byte
s[l] =3D i
-- Point to the next byte
a +=3D 1
=20
-- Pick up next byte
i =3D peek(a)
end while
=20
end if
-- send back all the bytes found.
return s[1 .. l]
end function
into sequences.
-- The initial buffer is 256 bytes and should be adequate. The only =
effect this
-- has is on the speed of conversion. Larger values may speed things up, =
smaller
-- values may slow things down.
--
-- If /i newsize is 0, then 1 is used. If /i newsize is less than zero, =
then 256
-- (the default) is used.
-- Example:
--
--/code
-- -- Change buffer size to 500 bytes.
-- set_peek_string( 500 )
--/endcode
global procedure set_peek_string(integer newsize)
if newsize < 1
then
if newsize =3D 0 then
newsize =3D 1
else
newsize =3D 256
end if
end if
=20
pPeekStringBufSize =3D newsize
=20
end procedure
--/ret ATOM: address.
-- This is typically done automatically by the /fetch
-- function.
--
-- Example:
--
--/code
-- -- get the address from handle
-- atom a, h
--
-- a =3D /peek_handle( h )
--/endcode
global function peek_handle(atom a)
return peek4u(a)
end function
--/ret OBJECT: Field from a structure.
-- Data conversion is automatic. For example, if the field is=20
-- an /b Lpsz, a sequence containing the string will automatically=20
-- be returned.
--
-- Example:
-- /code =20
-- -- fetch the average character width from the text metrics =
structure
-- width =3D /fetch( tm, tmAveCharWidth )
-- /endcode
global function fetch( atom struct, sequence s )
-- fetch the data based on the type
integer size, char, cnt
atom at
-- address is struct + offset
at =3D struct + s[1]
-- get data size
size =3D s[2]
-- get repeation
cnt =3D s[3]
=20
-- read, based on size =20
if size =3D Byte then =20
-- return byte
if cnt > 1 then
return (peek( {at, cnt}) )
else
return peek( at )
end if
elsif size =3D Word then
if cnt =3D 1 then
-- return word
return bytes_to_int( peek({at, 2}) & {0, 0} )
else
s =3D {}
for i =3D 1 to cnt do
s &=3D bytes_to_int( peek({at, 2}) & {0, 0} )
at +=3D 2
end for
return s
end if
=20
elsif size =3D Long then
if cnt =3D 1 then
-- return long
return peek4s( at )
else
s =3D {}
for i =3D 1 to cnt do
s &=3D peek4s(at )
at +=3D 4
end for
return s
end if
elsif size =3D Lpsz then =20
-- get the pointer
at =3D peek4u(at) =20
=20
-- return the string
return peek_string( at )
elsif size =3D Hndl then =20
if cnt =3D 1 then
-- return handle
return peek4u( at )
else
s =3D {}
for i =3D 1 to cnt do
s &=3D peek4u(at )
at +=3D 4
end for
return s
end if
elsif size =3D HndlAddr then =20
-- return a handle's address
at =3D peek4u( at )
at =3D peek_handle(at)
return at
elsif size =3D Strz then
return peek_string(at)
=20
else
-- return the string =20
return( peek( {at, size} ) )
=20
end if
end function
--/ret ATOM: Address of the field in the structure.
-- This is typically used if the structure contains an array.
--
-- In this snippet, the /b memBitmapInfo structure contains an array
-- of /b RGBQUAD colors. The array is populated with the values in=20
-- the pal:
--
-- /code=20
-- -- get the start of the rgbQuad array
-- rgbQuad =3D address( memBitmapInfo, bmiColors )
--
-- -- copy the pal to memory =20
-- for i =3D 1 to colors do
--
-- -- store values
-- /store( rgbQuad, rgbRed, pal[i][1] )
-- /store( rgbQuad, rgbGreen, pal[i][2] )
-- /store( rgbQuad, rgbBlue, pal[i][3] )
-- /store( rgbQuad, rgbReserved, 0 )
-- =20
-- -- move to next quad
-- rgbQuad +=3D SIZEOF_RGBQUAD
--
-- end for
--
-- /endcode
global function address( atom addr, object offset )
-- return address in structure =20
if atom( offset ) then
return addr + offset
elsif length(offset) =3D 3 then
return addr + offset[1]
else
return 0
end if
end function
--/topic Memory Management Routines
--/func new_memset( a )
--/desc Allocates a unique id for a memory set.
--/ret ATOM: An id for a new memory set (memset).
-- A memset id is actually a machine address of a 4-bytes location. You =
can
-- use this 4-byte area for anything you like, until you call =
/release_mem()
--
-- Example:
--
--/code
-- atom ss
--
-- ss =3D new_memset()
-- b =3D acquire_mem(ss, "All you need is love")
-- ...
-- release_mem( ss ) -- Let go of set 'ss'
--/endcode
global function new_memset()
atom ms
ms =3D acquire_mem( 0, UInt )
return ms
end function
------=_NextPart_000_0044_01C0CEEE.1AB3C060--
