fpc/packages/base/pasjpeg/jmemdos.pas
2005-02-14 17:13:06 +00:00

781 lines
25 KiB
ObjectPascal

Unit JmemDos;
{ This file provides an MS-DOS-compatible implementation of the system-
dependent portion of the JPEG memory manager. Temporary data can be
stored in extended or expanded memory as well as in regular DOS files.
If you use this file, you must be sure that NEED_FAR_POINTERS is defined
if you compile in a small-data memory model; it should NOT be defined if
you use a large-data memory model. This file is not recommended if you
are using a flat-memory-space 386 environment such as DJGCC or Watcom C.
Also, this code will NOT work if struct fields are aligned on greater than
2-byte boundaries.
Based on code contributed by Ge' Weijers. }
{ Original: jmemdos.c; Copyright (C) 1992-1996, Thomas G. Lane. }
interface
{$I jconfig.inc}
uses
jmorecfg,
jpeglib;
{ If you have both extended and expanded memory, you may want to change the
order in which they are tried in jopen_backing_store. On a 286 machine
expanded memory is usually faster, since extended memory access involves
an expensive protected-mode-and-back switch. On 386 and better, extended
memory is usually faster. As distributed, the code tries extended memory
first (what? not everyone has a 386? :-).
You can disable use of extended/expanded memory entirely by altering these
definitions or overriding them from the Makefile (eg, -DEMS_SUPPORTED=0).}
{GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long);
{ These routines take care of any system-dependent initialization and
cleanup required. }
{GLOBAL}
function jpeg_mem_init (cinfo : j_common_ptr) : long;
{GLOBAL}
procedure jpeg_mem_term (cinfo : j_common_ptr);
{ These two functions are used to allocate and release small chunks of
memory. (Typically the total amount requested through jpeg_get_small is
no more than 20K or so; this will be requested in chunks of a few K each.)
Behavior should be the same as for the standard library functions malloc
and free; in particular, jpeg_get_small must return NIL on failure.
On most systems, these ARE malloc and free. jpeg_free_small is passed the
size of the object being freed, just in case it's needed.
On an 80x86 machine using small-data memory model, these manage near heap. }
{ Near-memory allocation and freeing are controlled by the regular library
routines malloc() and free(). }
{GLOBAL}
function jpeg_get_small (cinfo : j_common_ptr;
sizeofobject : size_t) : pointer;
{GLOBAL}
{object is a reserved word in Borland Pascal }
procedure jpeg_free_small (cinfo : j_common_ptr;
an_object : pointer;
sizeofobject : size_t);
{ These two functions are used to allocate and release large chunks of
memory (up to the total free space designated by jpeg_mem_available).
The interface is the same as above, except that on an 80x86 machine,
far pointers are used. On most other machines these are identical to
the jpeg_get/free_small routines; but we keep them separate anyway,
in case a different allocation strategy is desirable for large chunks. }
{ "Large" objects are allocated in far memory, if possible }
{GLOBAL}
function jpeg_get_large (cinfo : j_common_ptr;
sizeofobject : size_t) : voidp; {far}
{GLOBAL}
procedure jpeg_free_large (cinfo : j_common_ptr;
{var?} an_object : voidp; {FAR}
sizeofobject : size_t);
{ This routine computes the total memory space available for allocation.
It's impossible to do this in a portable way; our current solution is
to make the user tell us (with a default value set at compile time).
If you can actually get the available space, it's a good idea to subtract
a slop factor of 5% or so. }
{GLOBAL}
function jpeg_mem_available (cinfo : j_common_ptr;
min_bytes_needed : long;
max_bytes_needed : long;
already_allocated : long) : long;
{ The macro MAX_ALLOC_CHUNK designates the maximum number of bytes that may
be requested in a single call to jpeg_get_large (and jpeg_get_small for that
matter, but that case should never come into play). This macro is needed
to model the 64Kb-segment-size limit of far addressing on 80x86 machines.
On those machines, we expect that jconfig.h will provide a proper value.
On machines with 32-bit flat address spaces, any large constant may be used.
NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type
size_t and will be a multiple of sizeof(align_type). }
{$ifdef USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c }
const
MAX_ALLOC_CHUNK = long(32752); {65520} { Maximum request to malloc() }
{ MAX_ALLOC_CHUNK should be less than 64K. }
{$else}
const
MAX_ALLOC_CHUNK = long(1000000000);
{$endif}
implementation
uses
dos,
jmemdosa,
jdeferr,
jerror;
{ Selection of a file name for a temporary file.
This is highly system-dependent, and you may want to customize it. }
var
next_file_num : int; { to distinguish among several temp files }
{LOCAL}
procedure select_file_name (var fname : TEMP_STRING);
var
env : string;
suffix,
prefix : TEMP_STRING;
tfile : FILE;
l : byte;
begin
{ Keep generating file names till we find one that's not in use }
while TRUE do
begin
{ Get temp directory name from environment TMP or TEMP variable;
if none, use "." }
env := getenv('TMP');
if (env = '') then
begin
env := getenv('TEMP');
if (env = '') then { null string means "." }
env := '.';
end;
prefix := env; { copy name to fname }
{ length(fname) > 0 !! }
if (prefix[length(prefix)] <> '\')
and (prefix[length(prefix)] <> '/') then
prefix := prefix + '\'; { append backslash if not in env variable }
{ Append a suitable file name }
Inc(next_file_num); { advance counter }
Str(next_file_num, suffix);
for l := Length(suffix)+1 to 3 do
suffix := '0' + suffix;
fname := prefix + 'JPG' + suffix + '.TMP';
{ Probe to see if file name is already in use }
system.assign(tfile, fname);
{$ifdef IoCheck} {$I-} {$endif}
system.reset(tfile, 1);
{$ifdef IoCheck} {$I+} {$endif}
if (IOresult <> 0) then
begin
fname := fname + #0;
break;
end;
system.close(tfile); { oops, it's there; close tfile & try again }
end;
end;
{ These two functions are used to allocate and release small chunks of
memory. (Typically the total amount requested through jpeg_get_small is
no more than 20K or so; this will be requested in chunks of a few K each.)
Behavior should be the same as for the standard library functions malloc
and free; in particular, jpeg_get_small must return NIL on failure.
On most systems, these ARE malloc and free. jpeg_free_small is passed the
size of the object being freed, just in case it's needed.
On an 80x86 machine using small-data memory model, these manage near heap. }
{ Near-memory allocation and freeing are controlled by the regular library
routines malloc() and free(). }
{GLOBAL}
function jpeg_get_small (cinfo : j_common_ptr;
sizeofobject : size_t) : pointer;
var
p : pointer;
begin
getmem(p, sizeofobject);
jpeg_get_small := p;
end;
{GLOBAL}
{object is a reserved word in Borland Pascal }
procedure jpeg_free_small (cinfo : j_common_ptr;
an_object : pointer;
sizeofobject : size_t);
begin
freemem(an_object, sizeofobject);
end;
{ These two functions are used to allocate and release large chunks of
memory (up to the total free space designated by jpeg_mem_available).
The interface is the same as above, except that on an 80x86 machine,
far pointers are used. On most other machines these are identical to
the jpeg_get/free_small routines; but we keep them separate anyway,
in case a different allocation strategy is desirable for large chunks. }
{GLOBAL}
function jpeg_get_large (cinfo : j_common_ptr;
sizeofobject : size_t) : voidp; {far}
var
p : voidp; {FAR}
begin
{far_malloc;}
getmem(p, sizeofobject);
jpeg_get_large := p;
end;
{GLOBAL}
procedure jpeg_free_large (cinfo : j_common_ptr;
{var?} an_object : voidp; {FAR}
sizeofobject : size_t);
begin
{far_free(an_object);}
FreeMem(an_object, sizeofobject);
end;
{ This routine computes the total space still available for allocation by
jpeg_get_large. If more space than this is needed, backing store will be
used. NOTE: any memory already allocated must not be counted.
There is a minimum space requirement, corresponding to the minimum
feasible buffer sizes; jmemmgr.c will request that much space even if
jpeg_mem_available returns zero. The maximum space needed, enough to hold
all working storage in memory, is also passed in case it is useful.
Finally, the total space already allocated is passed. If no better
method is available, cinfo->mem->max_memory_to_use - already_allocated
is often a suitable calculation.
It is OK for jpeg_mem_available to underestimate the space available
(that'll just lead to more backing-store access than is really necessary).
However, an overestimate will lead to failure. Hence it's wise to subtract
a slop factor from the true available space. 5% should be enough.
On machines with lots of virtual memory, any large constant may be returned.
Conversely, zero may be returned to always use the minimum amount of memory.}
{ This routine computes the total memory space available for allocation.
It's impossible to do this in a portable way; our current solution is
to make the user tell us (with a default value set at compile time).
If you can actually get the available space, it's a good idea to subtract
a slop factor of 5% or so. }
const
DEFAULT_MAX_MEM = long(300000); { for total usage about 450K }
{GLOBAL}
function jpeg_mem_available (cinfo : j_common_ptr;
min_bytes_needed : long;
max_bytes_needed : long;
already_allocated : long) : long;
begin
{jpeg_mem_available := cinfo^.mem^.max_memory_to_use - already_allocated;}
jpeg_mem_available := MaxAvail*95 div 100; { 95% }
{ Nomssi: limit the available memory for test purpose }
{jpeg_mem_available := 30000;}
end;
{ Backing store (temporary file) management.
Backing store objects are only used when the value returned by
jpeg_mem_available is less than the total space needed. You can dispense
with these routines if you have plenty of virtual memory; see jmemnobs.c. }
{ For MS-DOS we support three types of backing storage:
1. Conventional DOS files. We access these by direct DOS calls rather
than via the stdio package. This provides a bit better performance,
but the real reason is that the buffers to be read or written are FAR.
The stdio library for small-data memory models can't cope with that.
2. Extended memory, accessed per the XMS V2.0 specification.
3. Expanded memory, accessed per the LIM/EMS 4.0 specification.
You'll need copies of those specs to make sense of the related code.
The specs are available by Internet FTP from the SIMTEL archives
(oak.oakland.edu and its various mirror sites). See files
pub/msdos/microsoft/xms20.arc and pub/msdos/info/limems41.zip. }
{ Access methods for a DOS file. }
{METHODDEF}
procedure read_file_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
begin
if jdos_seek(info^.handle.file_handle, file_offset) <> 0 then
ERREXIT(cinfo, JERR_TFILE_SEEK);
{ Since MAX_ALLOC_CHUNK is less than 64K, byte_count will be too. }
if (byte_count > long(65535)) then { safety check }
ERREXIT(cinfo, JERR_BAD_ALLOC_CHUNK);
if jdos_read(info^.handle.file_handle, buffer_address,
ushort(byte_count)) <> 0 then
ERREXIT(cinfo, JERR_TFILE_READ);
end;
{METHODDEF}
procedure write_file_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
begin
if (jdos_seek(info^.handle.file_handle, file_offset)) <> 0 then
ERREXIT(cinfo, JERR_TFILE_SEEK);
{ Since MAX_ALLOC_CHUNK is less than 64K, byte_count will be too. }
if (byte_count > long(65535)) then { safety check }
ERREXIT(cinfo, JERR_BAD_ALLOC_CHUNK);
if jdos_write(info^.handle.file_handle, buffer_address,
ushort(byte_count)) <> 0 then
ERREXIT(cinfo, JERR_TFILE_WRITE);
end;
{METHODDEF}
procedure close_file_store (cinfo : j_common_ptr;
info : backing_store_ptr); far;
var
f : FILE;
begin
jdos_close(info^.handle.file_handle); { close the file }
system.assign(f, info^.temp_name);
system.erase(f); { delete the file }
{ If your system doesn't have remove(), try unlink() instead.
remove() is the ANSI-standard name for this function, but
unlink() was more common in pre-ANSI systems. }
TRACEMSS(cinfo, 1, JTRC_TFILE_CLOSE, info^.temp_name);
end;
{LOCAL}
function open_file_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long): boolean; far;
var
handle : short;
begin
select_file_name(info^.temp_name);
if jdos_open(handle, info^.temp_name[1]) <> 0 then
begin
{ might as well exit since jpeg_open_backing_store will fail anyway }
ERREXITS(cinfo, JERR_TFILE_CREATE, info^.temp_name);
open_file_store := FALSE;
exit;
end;
info^.handle.file_handle := handle;
info^.read_backing_store := read_file_store;
info^.write_backing_store := write_file_store;
info^.close_backing_store := close_file_store;
TRACEMSS(cinfo, 1, JTRC_TFILE_OPEN, info^.temp_name);
open_file_store := TRUE; { succeeded }
end;
{ Access methods for extended memory. }
{$ifdef XMS_SUPPORTED}
var
xms_driver : XMSDRIVER; { saved address of XMS driver }
type
XMSPTR = record { either long offset or real-mode pointer }
case byte of
0:(offset : long);
1:(ptr : pointer {FAR});
end;
type
XMSspec = record { XMS move specification structure }
length : long;
src_handle : XMSH;
src : XMSPTR;
dst_handle : XMSH;
dst : XMSPTR;
end;
type
TByteArray = Array[0..MAX_ALLOC_CHUNK-1] of byte;
{METHODDEF}
procedure read_xms_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
var
ctx : XMScontext;
spec : XMSspec;
endbuffer : packed array[0..1] of byte;
begin
{ The XMS driver can't cope with an odd length, so handle the last byte
specially if byte_count is odd. We don't expect this to be common. }
spec.length := byte_count and (not long(1));
spec.src_handle := info^.handle.xms_handle;
spec.src.offset := file_offset;
spec.dst_handle := 0;
spec.dst.ptr := buffer_address;
ctx.ds_si := addr(spec);
ctx.ax := $0b00; { EMB move }
jxms_calldriver(xms_driver, ctx);
if (ctx.ax <> 1) then
ERREXIT(cinfo, JERR_XMS_READ);
if odd(byte_count) then
begin
read_xms_store(cinfo, info, pointer(@endbuffer) {FAR},
file_offset + byte_count - long(1), long(2));
TByteArray(buffer_address^)[byte_count - long(1)] := endbuffer[0];
end;
end;
{METHODDEF}
procedure write_xms_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
var
ctx : XMScontext;
spec : XMSspec;
endbuffer : packed array[0..1] of byte;
begin
{ The XMS driver can't cope with an odd length, so handle the last byte
specially if byte_count is odd. We don't expect this to be common. }
spec.length := byte_count and (not long(1));
spec.src_handle := 0;
spec.src.ptr := buffer_address;
spec.dst_handle := info^.handle.xms_handle;
spec.dst.offset := file_offset;
ctx.ds_si := addr(spec);
ctx.ax := $0b00; { EMB move }
jxms_calldriver(xms_driver, ctx);
if (ctx.ax <> 1) then
ERREXIT(cinfo, JERR_XMS_WRITE);
if odd(byte_count) then
begin
read_xms_store(cinfo, info, pointer(@endbuffer) {FAR},
file_offset + byte_count - long(1), long(2));
endbuffer[0] := TByteArray(buffer_address^)[byte_count - long(1)];
write_xms_store(cinfo, info, pointer(@endbuffer) {FAR},
file_offset + byte_count - long(1), long(2));
end;
end;
{METHODDEF}
procedure close_xms_store (cinfo : j_common_ptr;
info : backing_store_ptr); far;
var
ctx : XMScontext;
begin
ctx.dx := info^.handle.xms_handle;
ctx.ax := $0a00;
jxms_calldriver(xms_driver, ctx);
TRACEMS1(cinfo, 1, JTRC_XMS_CLOSE, info^.handle.xms_handle);
{ we ignore any error return from the driver }
end;
{LOCAL}
function open_xms_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long) : boolean;
var
ctx : XMScontext;
begin
{ Get address of XMS driver }
jxms_getdriver(xms_driver);
if (xms_driver = NIL) then
begin
open_xms_store := FALSE; { no driver to be had }
exit;
end;
{ Get version number, must be >= 2.00 }
ctx.ax := $0000;
jxms_calldriver(xms_driver, ctx);
if (ctx.ax < ushort($0200)) then
begin
open_xms_store := FALSE;
exit;
end;
{ Try to get space (expressed in kilobytes) }
ctx.dx := ushort ((total_bytes_needed + long(1023)) shr 10);
ctx.ax := $0900;
jxms_calldriver(xms_driver, ctx);
if (ctx.ax <> 1) then
begin
open_xms_store := FALSE;
exit;
end;
{ Succeeded, save the handle and away we go }
info^.handle.xms_handle := ctx.dx;
info^.read_backing_store := read_xms_store;
info^.write_backing_store := write_xms_store;
info^.close_backing_store := close_xms_store;
TRACEMS1(cinfo, 1, JTRC_XMS_OPEN, ctx.dx);
open_xms_store := TRUE; { succeeded }
end;
{$endif} { XMS_SUPPORTED }
{ Access methods for expanded memory. }
{$ifdef EMS_SUPPORTED}
{ The EMS move specification structure requires word and long fields aligned
at odd byte boundaries. Some compilers will align struct fields at even
byte boundaries. While it's usually possible to force byte alignment,
that causes an overall performance penalty and may pose problems in merging
JPEG into a larger application. Instead we accept some rather dirty code
here. Note this code would fail if the hardware did not allow odd-byte
word & long accesses, but all 80x86 CPUs do. }
type
EMSPTR = pointer; {FAR}
{ types for accessing misaligned fields }
type
EMSAddrStruct = packed record {Size }
MemType : byte; { emsConventional, emsExpanded } { 1 }
Handle : word; { TEMSHandle; } { 2 }
case integer of {union}
0 : (Offs : word; { 2 }
Page : word); { 2 }
1 : (Ptr : pointer); {or 4 }
end;
{ EMS move specification structure }
EMSspec = packed record
length : longint; { 4 }
src : EMSAddrStruct; { 7 }
dst : EMSAddrStruct; { 7 }
end;
const
EMSPAGESIZE = long(16384); { gospel, see the EMS specs }
{METHODDEF}
procedure read_ems_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
var
ctx : EMScontext;
spec : EMSspec;
begin
spec.length := byte_count;
spec.src.memtype := 1;
spec.src.handle := info^.handle.ems_handle;
spec.src.page := ushort (file_offset div EMSPAGESIZE);
spec.src.offs := ushort (file_offset mod EMSPAGESIZE);
spec.dst.memtype := 0;
spec.dst.handle := 0;
spec.dst.ptr := buffer_address;
ctx.ds_si := addr(spec);
ctx.ax := $5700; { move memory region }
jems_calldriver(ctx);
if (hi(ctx.ax) <> 0) then
ERREXIT(cinfo, JERR_EMS_READ);
end;
{METHODDEF}
procedure write_ems_store (cinfo : j_common_ptr;
info : backing_store_ptr;
buffer_address : pointer; {FAR}
file_offset : long;
byte_count : long); far;
var
ctx : EMScontext;
spec : EMSspec;
begin
spec.length := byte_count;
spec.src.memtype := 0;
spec.src.handle := 0;
spec.src.ptr := buffer_address;
spec.dst.memtype := 1;
spec.dst.handle := info^.handle.ems_handle;
spec.dst.page := ushort (file_offset div EMSPAGESIZE);
spec.dst.offs := ushort (file_offset mod EMSPAGESIZE);
ctx.ds_si := addr(spec);
ctx.ax := $5700; { move memory region }
jems_calldriver(ctx);
if (hi(ctx.ax) <> 0) then
ERREXIT(cinfo, JERR_EMS_WRITE);
end;
{METHODDEF}
procedure close_ems_store (cinfo : j_common_ptr;
info : backing_store_ptr); far;
var
ctx : EMScontext;
begin
ctx.ax := $4500;
ctx.dx := info^.handle.ems_handle;
jems_calldriver(ctx);
TRACEMS1(cinfo, 1, JTRC_EMS_CLOSE, info^.handle.ems_handle);
{ we ignore any error return from the driver }
end;
{LOCAL}
function open_ems_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long) : boolean;
var
ctx : EMScontext;
begin
{ Is EMS driver there? }
if (jems_available = 0) then
begin
open_ems_store := FALSE;
exit;
end;
{ Get status, make sure EMS is OK }
ctx.ax := $4000;
jems_calldriver(ctx);
if (hi(ctx.ax) <> 0) then
begin
open_ems_store := FALSE;
exit;
end;
{ Get version, must be >= 4.0 }
ctx.ax := $4600;
jems_calldriver(ctx);
if (hi(ctx.ax) <> 0) or (lo(ctx.ax) < $40) then
begin
open_ems_store := FALSE;
exit;
end;
{ Try to allocate requested space }
ctx.ax := $4300;
ctx.bx := ushort ((total_bytes_needed +
EMSPAGESIZE-long(1)) div EMSPAGESIZE);
jems_calldriver(ctx);
if (hi(ctx.ax) <> 0) then
begin
open_ems_store := FALSE;
exit;
end;
{ Succeeded, save the handle and away we go }
info^.handle.ems_handle := ctx.dx;
info^.read_backing_store := read_ems_store;
info^.write_backing_store := write_ems_store;
info^.close_backing_store := close_ems_store;
TRACEMS1(cinfo, 1, JTRC_EMS_OPEN, ctx.dx);
open_ems_store := TRUE; { succeeded }
end;
{$endif} { EMS_SUPPORTED }
{ Initial opening of a backing-store object. This must fill in the
read/write/close pointers in the object. The read/write routines
may take an error exit if the specified maximum file size is exceeded.
(If jpeg_mem_available always returns a large value, this routine can
just take an error exit.) }
{ Initial opening of a backing-store object. }
{GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long);
begin
{ Try extended memory, then expanded memory, then regular file. }
{$ifdef XMS_SUPPORTED}
if (open_xms_store(cinfo, info, total_bytes_needed)) then
exit;
{$endif}
{$ifdef EMS_SUPPORTED}
if (open_ems_store(cinfo, info, total_bytes_needed)) then
exit;
{$endif}
if (open_file_store(cinfo, info, total_bytes_needed)) then
exit;
ERREXITS(cinfo, JERR_TFILE_CREATE, '');
end;
{ These routines take care of any system-dependent initialization and
cleanup required. jpeg_mem_init will be called before anything is
allocated (and, therefore, nothing in cinfo is of use except the error
manager pointer). It should return a suitable default value for
max_memory_to_use; this may subsequently be overridden by the surrounding
application. (Note that max_memory_to_use is only important if
jpeg_mem_available chooses to consult it ... no one else will.)
jpeg_mem_term may assume that all requested memory has been freed and that
all opened backing-store objects have been closed. }
{ These routines take care of any system-dependent initialization and
cleanup required. }
{GLOBAL}
function jpeg_mem_init (cinfo : j_common_ptr) : long;
begin
next_file_num := 0; { initialize temp file name generator }
jpeg_mem_init := DEFAULT_MAX_MEM; { default for max_memory_to_use }
end;
{GLOBAL}
procedure jpeg_mem_term (cinfo : j_common_ptr);
begin
{ Microsoft C, at least in v6.00A, will not successfully reclaim freed
blocks of size > 32Kbytes unless we give it a kick in the rear,
like so: }
{$ifdef NEED_FHEAPMIN}
_fheapmin();
{$endif}
end;
end.