home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
drdobbs
/
1991
/
06
/
fastsort.asc
< prev
next >
Wrap
Text File
|
1991-05-02
|
38KB
|
600 lines
_FAST SORTING USING LARGE STRING BUFFERS_
by Dale Thorn
[LISTING ONE]
'==============================================================================
'NSORT.BAS Sort/retrieve/index data; ascending/descending; mixed data types
' By: Dale Thorn
' Rev. 03/26/91
'==============================================================================
main:
defint a-w
deflng x
defsng y
defdbl z
declare function midchar(i$, i) 'use Basic function (listed) if PDQ not avail.
dim ibeg(10), ilen(10), iptx(100, 1), iseq(10), char$(255)
common shared compln, ddunit, grpptr, grptot, maxrcd, memndx, ndunit
common shared ndxgrp, ndxlen, nosegs, nvflag, offset, opcode, opinit
common shared outptr, outtot, rcdptr, rcdtot, recptr, sdunit, sortln
common shared sortsq, subtot, ibeg(), ilen(), iptx(), iseq(), char$()
compln = 0 'comparison length in sort data (sdat$); may be less than sortln
ddunit = 0 'file channel/unit number for index-building (opcode = -3)
grpptr = 0 'sort group record pointer/sort buffer pointer
grptot = 0 'internal sort group size
maxrcd = 0 'internal maximum sort group size
memndx = 0 'internal index-load flag
ndunit = 0 'file channel/unit number for sort index files
ndxgrp = 0 'internal index file group record counter
ndxlen = 0 'internal index file record size
nosegs = 0 'no. of sort segments in sdat$; total length of segments = compln
nvflag = 0 'internal optimization for least ascending/descending inversions
offset = 0 'internal group-to-record offset counter
opcode = 0 'sort operation (0 to -3)
opinit = 0 'internal sort operation data initialization flag
outptr = 0 'internal data output record pointer
outtot = 0 'internal data output record counter
rcdptr = 0 'internal sort data record counter (all records)
rcdtot = 0 'internal sort data record total (final count)
recptr = 0 'internal sort data record counter (group records)
sdunit = 0 'file channel/unit number for sort data file (.sdx)
sortln = 0 'length of sort data buffer (sdat$); may be greater than compln
sortsq = 0 'internal sort sequence (ascending/descending) flag
subtot = 0 'internal partial group data record total (final count)
drcd$ = "" 'temp. sort data record buffer
nrcd$ = "" 'sort index file buffer
sbuf$ = "" 'main sort group memory buffer
sdat$ = "" 'main sort data record buffer
smsk$ = "" 'sort data mask (must be uppercased) [BBXXXBBXXXXXBB.....]
sndx$ = "" 'sort index-pointer memory buffer
'// NOTE: Any lines below with an asterisk (*) on the extreme /////
' right will require a modification or replacement. /////
'/////// Modification applies to DATA statements as well. /////
sortln = 40 'total sort buffer length*
pfmt$ = space$(5) 'output format buffer for integer strings
sdat$ = space$(sortln) 'sort data record buffer
restore sortdata1 'first tablespec to sort from
read sdunit, ndunit, ddunit 'file channel/unit numbers used by NSORT.SUB
read ibeg(0), ilen(0), iseq(0) 'test values from table sortdata1
nosegs = 0 'initialize total no. of sort segments
while ibeg(0) 'begin loop to load segment pointers and flags
nosegs = nosegs + 1 'increment total sort segments
ibeg(nosegs) = ibeg(0) 'segment begin pointer for sdat$ buffer
ilen(nosegs) = ilen(0) 'segment length
iseq(nosegs) = iseq(0) 'segment sort sequence (ascending/descending)
compln = compln + ilen(0) 'total sort compare length
read ibeg(0), ilen(0), iseq(0) 'read next set of test values
wend
smsk$ = string$(compln, "X") 'allocate masking buffer (default type=character)
mid$(smsk$, 21) = "BB" '"binary" position specified*
mid$(smsk$, 33) = "BB" '"binary" position specified*
restore sortdata2 'sample sort data table
opcode = 0 'set flag to add records to sort (initial operation)
nrcds = 0 'number of records added to the sort
do 'begin loop to read data and add to sort
segptr = 1 'set segment position pointer for sdat$
lset sdat$ = "" 'clear the sort data buffer prior to loading
for segno = 1 to nosegs 'begin loop to load each data segment
read segdata$ 'read data segment from table sortdata2
if len(segdata$) = 0 then exit do 'exit read-data loop at end-of-data
if midchar(smsk$, segptr) = 66 then '16-bit integer <BB> segment
mid$(sdat$, segptr) = mki$(val(segdata$)) 'convert data to integer
else 'character <XX....> segment
mid$(sdat$, segptr) = segdata$ 'put character segment to sort buffer
end if
segptr = segptr + ilen(segno) 'increment segment position pointer
next
call nsort(drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) 'add record to sort
nrcds = nrcds + 1 'total records added to the sort
loop
opcode = -3 'set flag to build an external index to the sortdata file
call nsort(drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) 'build the index file
open "sortdata.ddx" for binary as #ddunit 'open the external index file
ddxrcd$ = space$(2) 'allocate the index buffer
for rcdno = 1 to nrcds 'begin loop to retrieve and display indexed data
call fileio(ddunit, 2, clng(rcdno), ddxrcd$, 0) 'retrieve an index record
call fileio(sdunit, sortln, clng(cvi(ddxrcd$)), sdat$, 0) 'retrieve data
for segno = 1 to nosegs 'begin loop to display sort segments
if midchar(smsk$, ibeg(segno)) = 66 then '16-bit integer <BB> segment
rset pfmt$ = right$(str$(cvi(mid$(sdat$, ibeg(segno), 2))), 5)
print pfmt$; " "; 'print integer data
else 'character segment
print mid$(sdat$, ibeg(segno), ilen(segno)); " "; 'print char. data
end if
next
print 'terminate print line
next
call killfile("sortdata.ddx", ddunit) 'index file closed and removed
restore sortdata3 'next tablespec to sort from
read ibeg(0), ilen(0), iseq(0) 'test values from table sortdata3
compln = 0 'comparison length in sort data (sdat$)
nosegs = 0 'initialize total no. of sort segments
while ibeg(0) 'begin loop to load segment pointers and flags
nosegs = nosegs + 1 'increment total sort segments
ibeg(nosegs) = ibeg(0) 'segment begin pointer for sdat$ buffer
ilen(nosegs) = ilen(0) 'segment length
iseq(nosegs) = iseq(0) 'segment sort sequence (ascending/descending)
compln = compln + ilen(0) 'total sort compare length
read ibeg(0), ilen(0), iseq(0) 'read next set of test values
wend
opcode = -1 'set flag to resort data from existing sort file
call nsort(drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) 'resort the data
opcode = -2 'set flag to retrieve records from sort (final operation)
call nsort(drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) 'retrieve 1st data record
while len(sdat$) 'begin loop to display sort data
for segno = 1 to nosegs 'begin loop to display sort segments
if midchar(smsk$, ibeg(segno)) = 66 then '16-bit integer <BB> segment
rset pfmt$ = right$(str$(cvi(mid$(sdat$, ibeg(segno), 2))), 5)
print pfmt$; " "; 'print integer data
else 'character segment
print mid$(sdat$, ibeg(segno), ilen(segno)); " "; 'print char. data
end if
next
print 'terminate print line
call nsort(drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) 'retrieve next record
wend
close 'close all files
system 'return to DOS
'------------------------------------------------------------------------------
sortdata1: 'initial sort specifications
'------------------------------------------------------------------------------
'_____datafile____indexfile____buildfile :'File channel/unit numbers;
data 1, 2, 3 :'may be found using FREEFILE
'_____segbegin____seglength____segsequence :'Segment begin pointers, lengths
data 1, 20, 1 :'and sort sequences for sort
data 21, 2, -1 :'data buffer (sdat$).
data 23, 10, 1 :' sequence = 1; ascending
data 33, 2, -1 :' sequence = -1; descending
data 35, 6, 1 :'
data 0, 0, 0 :'end-of-data markers
'------------------------------------------------------------------------------
sortdata2: 'example sort data
'------------------------------------------------------------------------------
'_______Alpha data, len=20______Num.(2)______Alpha (10)____Num.(2)____Alpha (6)
data "Petrol Chemicals Ltd", "3576", "London SW3", "588", "A23456"
data "Associated Factories", "112", "Richmond", "1313", "XNA"
data "Dale's Containers", "12343", "Devonshire", "55", "DALE"
data "", "", "", "", ""
'------------------------------------------------------------------------------
sortdata3: 'specifications for alternate sorting order
'------------------------------------------------------------------------------
'_____segbegin____seglength____segsequence :'Segment begin pointers, lengths
data 33, 2, 1 :'and sort sequences for sort
data 1, 10, 1 :'data buffer (sdat$).
data 0, 0, 0 :'end-of-data markers
function midchar (i$, i) static 'find ASCII value of a single character in i$
midchar = asc(mid$(i$, i, 1)) 'set midchar value
end function 'return to calling program
rem $include: 'nsort.sub'
[LISTING TWO]
'==============================================================================
'NSORT.SUB Sort/retrieve/index data; ascending/descending; mixed data types
' By: Dale Thorn
' Rev. 03/24/91
'------------------------------------------------------------------------------
' compln - comparison length in sort data (sdat$); may be less than sortln
' ddunit - file channel/unit number for index-building (opcode = -3)
' grpptr - sort group record pointer/sort buffer pointer
' grptot - internal sort group size
' maxrcd - internal maximum sort group size
' memndx - internal index-load flag
' ndunit - file channel/unit number for sort index files
' ndxgrp - internal index file group record counter
' ndxlen - internal index file record size
' nosegs - no. of sort segments in sdat$; total length of segments = compln
' nvflag - internal optimization for least ascending/descending data inversions
' offset - internal group-to-record offset counter
' opcode - sort operation (0 to -3)
' opinit - internal sort operation data initialization flag
' outptr - internal data output record pointer
' outtot - internal data output record counter
' rcdptr - internal sort data record counter (all records)
' rcdtot - internal sort data record total (final count)
' recptr - internal sort data record counter (group records)
' sdunit - file channel/unit number for sort data file (.sdx)
' sortln - length of sort data buffer (sdat$); may be greater than compln
' sortsq - internal sort sequence (ascending/descending) flag
' subtot - internal partial group data record total (final count)
'
' ibeg() - segment begin pointers for sort data buffer (sdat$)
' ilen() - segment length pointers for sort data buffer (sdat$)
' iptx() - pointers used if merge-sort req'd. (set internally)
' iseq() - segment sequence pointers for sort data buffer (sdat$)
' 1 = ascending; -1 = descending
' char$() - high-performance substitute for Basic chr$() function
'
' drcd$ - temp. sort data record buffer (set to "" on first call)
' nrcd$ - sort index file buffer (set to "" on first call)
' sbuf$ - main sort group memory buffer (set to "" on first call)
' sdat$ - main sort data record buffer (set to actual value on first call)
' smsk$ - sort data mask (must be uppercased)
' BB = integer string; XXX.... all other bytes
' sndx$ - sort index-pointer memory buffer (set to "" on first call)
'
'
' set opcode = 0 on first call to add records to sort.
' set opcode = -1 to resort data from existing sort work file (sortdata.sdx).
' set opcode = -2 on first call to retrieve records from sort.
' set opcode = -3 to build index file (sortdata.ddx).
'
' *** Notes: opcode = 0 is always the first process (add records).
' opcode = -1 may be set to resort data, but only following
' the creation of an index with opcode set to -3.
' opcode = -2 may be set to retrieve records once all records
' have been added with opcode set to 0, or after
' a resort with opcode set to -1. Once opcode is
' set to -2 and all records are retrieved, the
' sort routine is terminated and all sort memory
' is returned to the calling program. If further
' sorting is required, begin anew with opcode = 0.
' opcode = -3 may be set to build an index file following an
' initial sort with opcode set to 0, or a resort
' with opcode set to -1. If more than 2 sorting
' sequences are required, where 2 or more index
' files are needed, rename each .ddx file to save it.
' The final sort sequence may be obtained using
' opcode = -2, and thus eliminate the need for a
' corresponding index file. Each 2 bytes in the index
' file are a pointer to a record in the .sdx file.
'
' For the first sort (opcode = 0), place all sort segments of sdat$
' into the left part of sdat$ in sequential order (1, 2, 3, etc.).
' When re-sorting using opcode = -1, segments may be in any order.
' All data stored in sortdata.sdx will be in the original sequence.
'
' ***** Important: Minimum sort length is 2 bytes.
' ***** If free memory is minimal, more sort groups may
' ***** be needed, and dim iptx(nnn) may be too small.
' ***** Each opcode process must be completed for all
' ***** records before switching to another process.
' ***** Use named common block if chaining programs.
'------------------------------------------------------------------------------
sub nsort (drcd$, nrcd$, sbuf$, sdat$, smsk$, sndx$) static
if opcode > -2 then 'insert a record <add to the sort>
if opinit mod 2 = 0 then 'first-sort-record initialization
opinit = opinit - 1 'adjust initialization flag
sortsq = iseq(1) 'primary output sequence
nvflag = 0 'data inversion flag
for segno = 1 to nosegs 'build data inversion spec
nvflag = nvflag + ilen(segno) * iseq(segno) 'bytes above/below 0
next
if nvflag < 0 then 'data inversion optimization
nvflag = 1 'set inversion flag plus
else
nvflag = -1 'set inversion flag minus
end if '[see fillproc & writeproc subroutines]
if nvflag = sortsq then sortsq = -sortsq 'primary output sequence
call killfile("sortdata.ndx", ndunit) 'kill work index file
open "sortdata.ndx" for binary as #ndunit 'open work index file
if opcode = 0 then 'initial (add records) operation
call killfile("sortdata.sdx", sdunit) 'kill work data file
open "sortdata.sdx" for binary as #sdunit 'open work data file
drcd$ = space$(sortln) 'temporary sort data buffer
for ichr = 0 to 255 'create substitute character set
char$(ichr) = chr$(ichr) 'substitute for Basic chr$() function
next
end if
call memfree(clng(4096), clng(195840), xfree) 'reserve 4 kb memory
maxrcd = xfree \ (sortln + 4) 'maximum records per memory group
if maxrcd > 32640 \ sortln then maxrcd = 32640 \ sortln 'buffer size
sbuf$ = space$(maxrcd * sortln) 'main sort data buffer
sndx$ = space$(maxrcd * 2 + 2) 'reorderable/shiftable index buffer
rcdptr = 1 'used to count total records
recptr = 1 'used to count records within a sort group
grpptr = 1 'sort buffer pointer
end if
if opcode = -1 then 'resort from existing workfile (.sdx)
ndxgrp = 0 'total number of sort groups
offset = 0 'internal group-to-record offset counter
while rcdptr <= rcdtot 'loop until all records are read
call fileio(sdunit, sortln, clng(rcdptr), sdat$, 0) 'get sort data
gosub putproc 'add records in new sort sequence
wend
else 'original (insert) sequence
gosub putproc 'add records to sort
end if
else 'retrieve a record or build an index
offset = 0 'group-to-record offset counter
if opinit mod 2 then 'first retrieval record initialization
opinit = opinit - 1 'adjust initialization flag
if opinit = -2 then 'first operation after original sort
rcdtot = rcdptr - 1 'total records from original sort
subtot = recptr - 1 'partial-group subtotal from original sort
end if
outptr = 1 'beginning pointer for data output
outtot = rcdtot 'total records to output
if ndxgrp then 'sorting was done in groups
gosub writeproc 'save data left over from previous operation
else 'all sorting was done in memory
maxrcd = rcdtot 'reset maximum records for file write
ndxlen = maxrcd * 2 'length of index data to write
gosub writeproc 'save sort data
ndxgrp = 0 'reset index group count to zero
end if
sbuf$ = "" 'erase buffer to reclaim memory
sndx$ = "" 'erase buffer to reclaim memory
if ndxgrp then 'merge-sort required
grplen = ndxlen 'group size * 2
sbuf$ = space$(ndxgrp * sortln) 'buffer holds 1 record per group
sndx$ = space$(ndxgrp * 2 + 2) 'buffer holds 1 record per group
end if
if opcode = -3 then 'build index from sorted data
call memfree(clng(6144), clng(32640), xfree) 'reserve 2kb for .ddx
else 'normal retrieval [return each record to calling program]
call memfree(clng(4096), clng(32640), xfree) 'reserve normal 4 kb
end if
xsize = clng(outtot) * 2 'total records * 2
memndx = (xsize <= 32640 and xsize <= xfree) 'index-in-memory flag
if memndx then 'retrieval index fits entirely in memory
ndxlen = xsize 'buffer length is index file length
else 'retrieval index does not fit in memory
ndxlen = 2 'buffer length is 16-bit integer length
end if
nrcd$ = space$(ndxlen) 'allocate index file buffer
if memndx then call fileio(ndunit, ndxlen, clng(1), nrcd$, 0)'fill it
if ndxgrp then 'merge-sort initialization
ixx1 = (sortsq > 0) 'used locally to shorten line
ixx2 = (sortsq < 0) 'used locally to shorten line
ixx3 = (memndx and ixx1) 'used locally to shorten line
ixx4 = (memndx and ixx2) 'used locally to shorten line
iyy1 = 1 - memndx 'used locally to shorten line
iyy2 = grplen \ (1 - not memndx) 'used locally to shorten line
for recptr = 1 to ndxgrp 'loop thru each index group
grpptr = recptr 'sort group record pointer
iyy3 = (grptot - subtot) * (ixx2 and (recptr = ndxgrp))
iyy4 = (grptot - subtot) * (ixx1 and (recptr = ndxgrp))
ircd = (recptr + ixx1) * iyy2 + iyy3 * iyy1 + ixx4 - ixx1
ircx = (recptr + ixx2) * iyy2 + iyy4 * iyy1 + ixx3 - ixx2
if memndx then 'get index pointer from memory buffer
ichr = midchar(nrcd$, ircd + 1) * 256 'high byte of index
rcdptr = midchar(nrcd$, ircd) + ichr 'same as cvi(mid$(...
else 'get index pointer from file
call fileio(ndunit, ndxlen, clng(ircd), nrcd$, 0)
rcdptr = cvi(nrcd$) 'set pointer to retrieve data
end if
call fileio(sdunit, sortln, clng(rcdptr), sdat$, 0) 'get data
gosub fillproc 'add 1 record from each sort group to buffer
iptx(recptr, 0) = ircd 'begin ptr.to load ndx.rcd. from group
iptx(recptr, 1) = ircx 'end ptr.to load ndx.rcd. from group
next
recptr = ndxgrp 'reset groups-pointer to begin output
if sortsq < 0 then outptr = recptr 'begin output in reverse order
else 'non-merge; all output from memory
if sortsq < 0 then outptr = outtot 'begin output in reverse order
end if
end if
if opcode = -3 then 'build index from sorted data
call killfile("sortdata.ddx", ddunit) 'kill user index file
open "sortdata.ddx" for binary as #ddunit 'open user index file
ddxrcd$ = space$(2048) 'collection buffer for index-build
filptr = 0 'record pointer for writing .ddx buffer to file
ddxptr = 1 'buffer pointer for adding index values to ddxrcd$
gosub getproc 'get first index record
while not closed 'retrieve index pointers and save to .ddx file
mid$(ddxrcd$, ddxptr) = mki$(rcdptr) 'copy index to .ddx buffer
ddxptr = ddxptr + 2 'increment buffer pointer
if ddxptr > 2048 then 'write a group of data to file
filptr = filptr + 1 'increment file pointer
call fileio(ddunit, 2048, clng(filptr), ddxrcd$, -1) 'put data
ddxptr = 1 'reset buffer pointer to beginning of buffer
end if
gosub getproc 'get next index records
wend
if ddxptr > 1 then 'save leftover index pointers
call fileio(ddunit, 2048, clng(filptr + 1), ddxrcd$, -1) 'put data
end if
close #ddunit 'close the .ddx file
ddxrcd$ = "" 'reclaim memory from .ddx buffer
else 'retrieve a single sort record and return to calling program
gosub getproc 'get a record pointer
if not closed then 'retrieval OK as long as more records available
call fileio(sdunit, sortln, clng(rcdptr), sdat$, 0) 'retrieve data
end if
end if
if closed then 'retrieval/index completed
if opcode = -2 then 'final (single-record retrieval) sequence
call killfile("sortdata.ndx", ndunit) 'kill sort index workfile
call killfile("sortdata.sdx", sdunit) 'kill sort data file
sdat$ = "" 'kill sort data buffer
end if
nrcd$ = "" 'kill index file buffer
sbuf$ = "" 'kill main sort group buffer
sndx$ = "" 'kill sort index buffer
end if
end if
exit sub 'return to calling program
'--------------------------------------------------------------------------
fillproc: 'put sort data into sbuf$, sndx$
'--------------------------------------------------------------------------
if opcode = 0 then lset drcd$ = sdat$ 'load all segments at once
iptr = 1 'initialize work buffer pointer
for segno = 1 to nosegs 'load segments into work buffer and/or do invert
if midchar(smsk$, ibeg(segno)) = 66 then 'invert 16-bit integer strings
ichr = midchar(sdat$, ibeg(segno)) 'save first byte, then swap
mid$(drcd$, iptr) = char$(midchar(sdat$, ibeg(segno) + 1)) '2nd byte
mid$(drcd$, iptr + 1) = char$(ichr) 'put 1st byte in 2nd position
else 'non-integer (character) sort segment
if opcode then 'segments not in original (contiguous) sequence
mid$(drcd$, iptr) = mid$(sdat$, ibeg(segno), ilen(segno))
end if 'insert each sort segment into temp. buffer [above]
end if
if iseq(segno) = nvflag then 'invert data for ascend/descend sequence
for ichr = iptr to iptr + ilen(segno) - 1 'do each byte in segment
mid$(drcd$, ichr) = char$(255 - midchar(drcd$, ichr))
next 'data will be re-inverted before writing to file
end if
iptr = iptr + ilen(segno) 'increment work buffer segment pointer
next 'begin binary search for sort compare [below]
topptr = recptr 'set top end of binary search
lowptr = 0 'set low end of binary search
while topptr - lowptr > 1 'search work data buffer using work index buffer
midptr = lowptr + (topptr - lowptr) \ 2 'set mid point for compare
ichx = midptr * 2 'mid-position incorporating 16-bit index width
ichr = midchar(sndx$, ichx) * 256 'same as cvi(mid$(.....))
iptr = (midchar(sndx$, ichx - 1) + ichr - offset - 1) * sortln 'mid-
if left$(drcd$, compln) <= mid$(sbuf$, iptr + 1, compln) then '-buff.pos
topptr = midptr 'move search lower
else 'sort record value > compare value in sort memory buffer
lowptr = midptr 'move search higher
end if
wend
iptr = topptr * 2 - 1 'current index-"stack" insert position
mid$(sbuf$, (grpptr - 1) * sortln + 1) = drcd$ 'write sort data to buffer
mid$(sndx$, iptr + 2) = mid$(sndx$, iptr, (recptr - topptr) * 2) 'shift ndx
mid$(sndx$, iptr) = mki$(grpptr + offset) 'write current pointer to index
return 'return to calling routine
'--------------------------------------------------------------------------
getproc: 'retrieve a record from the sort
'--------------------------------------------------------------------------
if ndxgrp then 'merge-retrieval from sort groups
if recptr then 'sort records are still available
ichr = outptr * 2 'mid-position based on 16-bit index width
grpptr = midchar(sndx$, ichr - 1) + midchar(sndx$, ichr) * 256
if memndx then 'get group pointer from work index [above]
ichr = midchar(nrcd$, iptx(grpptr, 0) + 1) * 256 'get record ptr
rcdptr = midchar(nrcd$, iptx(grpptr, 0)) + ichr 'from memory-index
else 'get record pointer from index file
call fileio(ndunit, ndxlen, clng(iptx(grpptr, 0)), nrcd$, 0)
rcdptr = cvi(nrcd$) 'nrcd$ is a 16-bit integer record
end if
if sortsq > 0 then mid$(sndx$, 1) = mid$(sndx$, 3) 'shift work index
if iptx(grpptr, 0) = iptx(grpptr, 1) then 'end of group reached
recptr = recptr - 1 'decrement group stack pointer
if sortsq < 0 then outptr = recptr 'set output pointer if appl.
else 'end of group not yet reached
iptx(grpptr, 0) = iptx(grpptr, 0) + (1 - memndx) * sortsq'move ptr
if memndx then 'get a data record using a pointer from memory
ichr = midchar(nrcd$, iptx(grpptr, 0)) 'get the record pointer
ichx = midchar(nrcd$, iptx(grpptr, 0) + 1) * 256 '..from memory
call fileio(sdunit, sortln, clng(ichr + ichx), sdat$, 0)
else 'get a data record using a pointer from the index file
call fileio(ndunit, ndxlen, clng(iptx(grpptr, 0)), nrcd$, 0)
call fileio(sdunit, sortln, clng(cvi(nrcd$)), sdat$, 0)
end if
gosub fillproc 'add the data record to the merge-sort
end if
closed = 0 'retrieval process not closed
else 'no more records available
closed = not 0 'retrieval process closed
end if
else 'non-merge sort retrieval; all data is in memory
if outtot then 'sort records are still available
ichr = outptr * 2 'mid-position based on 16-bit index width
rcdptr = midchar(nrcd$, ichr - 1) + midchar(nrcd$, ichr) * 256
outptr = outptr + sortsq 'increment or decrement index pointer
outtot = outtot - 1 'decrement remaining records
closed = 0 'retrieval process not closed
else 'no more records available
closed = not 0 'retrieval process closed
end if
end if
return 'return to calling routine
'--------------------------------------------------------------------------
putproc: 'add a record to the sort
'--------------------------------------------------------------------------
if recptr > maxrcd then 'too many records to fit in memory
if ndxgrp = 0 then 'first group; initialize index group variables
grptot = recptr - 1 'number of records per group
ndxlen = grptot * 2 'size of index file buffer
end if
gosub writeproc 'save data group and index group
offset = rcdptr - 1 'group-to-record offset counter
recptr = 1 'reset group record counter
grpptr = 1 'sort buffer pointer
end if
gosub fillproc 'add current record to sort
rcdptr = rcdptr + 1 'increment total records counter
recptr = recptr + 1 'increment group record counter
grpptr = recptr 'sort buffer pointer
return 'return to calling routine
'--------------------------------------------------------------------------
writeproc: 'write index and sort data to files
'--------------------------------------------------------------------------
ndxgrp = ndxgrp + 1 'increment the index group number
call fileio(ndunit, ndxlen, clng(ndxgrp), left$(sndx$, ndxlen), -1)
if opinit > -3 then 'initial sequences; save sort data to .sdx file
for iptr = 0 to (maxrcd - 1) * sortln step sortln 'loop thru mem.buffer
for segno = 1 to nosegs 're-invert data as appropriate
iptz = iptr + ibeg(segno) 'sort group memory buffer pointer
if midchar(smsk$, ibeg(segno)) = 66 then 'invert integer string
ichr = midchar(sbuf$, iptz) 'save first byte, then swap
mid$(sbuf$, iptz) = char$(midchar(sbuf$, iptz + 1)) '2nd byte
mid$(sbuf$, iptz + 1) = char$(ichr) 'put 1st byte in 2nd pos.
end if
if iseq(segno) = nvflag then 'invert data for ascend/descend seq
for ichr = iptz to iptz + ilen(segno) - 1 'invert each byte
mid$(sbuf$, ichr) = char$(255 - midchar(sbuf$, ichr))
next
end if
next
next
sdxlen = maxrcd * sortln 'size of group memory buffer
xflptr = lof(sdunit) \ sdxlen + 1 'current data "record"
call fileio(sdunit, sdxlen, xflptr, sbuf$, -1) 'put data group to file
end if
return
end sub 'return to calling program
sub fileio (fcno, flen, xrec, fbuf$, fopr) static 'read/write file data
'int fcno 'file unit/channel no.
'int flen '"record" length used for positioning only
'int fopr '0 = read; non-0 = write
'long xrec 'logical "record" number
'char fbuf$ 'read/write data buffer
xpos = (xrec - 1) * flen + 1 'absolute byte position in file
if fopr then 'operation = write
put #fcno, xpos, fbuf$ 'write data to file
else 'operation = read
get #fcno, xpos, fbuf$ 'read data from file
end if
end sub 'return to calling program
sub killfile (ffil$, fcno) static 'kill a DOS file
'int fcno 'file unit/channel no.
'char ffil$ 'file name
close #fcno 'close file if open
open ffil$ for binary as #fcno 'open file in binary mode
close #fcno 'close the file
kill ffil$ 'kill the file
end sub 'return to calling program
sub memfree (xexc, xmax, xfree) static 'get max. free memory less exclusion
'long xexc 'amount of memory to reserve/exclude
'long xmax 'upper limit for xfree (or zero)
xfree = fre("") - xexc 'total free memory less exclusion
if xmax > 0 and xfree > xmax then xfree = xmax 'set maximum if applicable
end sub 'return to calling program
