mnerv/freetype
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FreeType 1.31.1

Browse Source
This commit is contained in:
mnerv
2023-08-27 18:03:45 +02:00
commit 5edbb7a80a
454 changed files with 173977 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

433
pascal/lib/ttcache.pas Normal file
View File

@@ -0,0 +1,433 @@
(*******************************************************************
*
* ttcache.pas 1.0
*
* Generic object cache
*
* Copyright 1996, 1997 by
* David Turner, Robert Wilhelm, and Werner Lemberg.
*
* This file is part of the FreeType project, and may only be used
* modified and distributed under the terms of the FreeType project
* license, LICENSE.TXT. By continuing to use, modify or distribute
* this file you indicate that you have read the license and
* understand and accept it fully.
*
*
* This component defines and implement object caches.
*
* An object class is a structure layout that encapsulate one
* given type of data used by the FreeType engine. Each object
* class is completely described by :
*
* - a 'root' or 'leading' structure containing the first
* important fields of the class. The root structure is
* always of fixed size.
*
* It is implemented as a simple C structure, and may
* contain several pointers to sub-tables that can be
* sized and allocated dynamically.
*
* examples : TFace, TInstance, TGlyph & TExecution_Context
* ( defined in 'ttobjs.h' )
*
* - we make a difference between 'child' pointers and 'peer'
* pointers. A 'child' pointer points to a sub-table that is
* owned by the object, while a 'peer' pointer points to any
* other kind of data the object isn't responsible for.
*
* An object class is thus usually a 'tree' of 'child' tables.
*
* - each object class needs a constructor and a destructor.
*
* A constructor is a function which receives the address of
* freshly allocated and zeroed object root structure and
* 'builds' all the valid child data that must be associated
* to the object before it becomes 'valid'.
*
* A destructor does the inverse job : given the address of
* a valid object, it must discards all its child data and
* zero its main fields (essentially the pointers and array
* sizes found in the root fields).
*
*
*
*
*
*
*
*
*
*
*
*
******************************************************************)
unit TTCache;
interface
uses TTError, TTTypes;
type
(* Simple list node record. A List element is said to be 'unlinked' *)
(* when it doesn't belong to any list *)
(* *)
PList_Element = ^TList_Element;
TList_Element = record
next : PList_Element; (* Pointer to next element of list *)
data : Pointer; (* Pointer to the listed object *)
end;
(* Simple singly-linked list record *)
(* LIFO - style, no tail field *)
TSingle_List = PList_Element;
TConstructor = function( _object : Pointer;
_parent : Pointer ) : TError;
TDestructor = function( _object : Pointer ) : TError;
PCache_Class = ^TCache_Class;
TCache_Class = record
Object_Size : Int;
Idle_Limit : Int;
Init : TConstructor;
Done : TDestructor;
end;
(* A Cache class record holds the data necessary to define *)
(* a cache kind. *)
PCache = ^TCache;
TCache = record
clazz : PCache_Class; (* 'class' reserved in VP & Delphi *)
active : TSingle_List;
idle : TSingle_List;
idle_count : Int;
end;
(* An object cache holds two lists tracking the active and *)
(* idle objects that are currently created and used by the *)
(* engine. It can also be 'protected' by a mutex *)
function Cache_Create( var clazz : TCache_Class;
var cache : TCache ) : TError;
(* Initialize a new cache named 'cache', of class 'clazz', and *)
(* protected by the 'lock' mutex. Note that the mutex is ignored *)
(* as the pascal version isn't thread-safe *)
function Cache_Destroy( var cache : TCache ) : TError;
(* Destroys a cache and all its listed objects *)
function Cache_New( var cache : TCache;
var new_object : Pointer;
parent_data : Pointer ) : TError;
(* Extracts a new object from the cache. *)
function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
(* returns an object to the cache, or discards it depending *)
(* on the cache class' "idle_limit" field *)
(********************************************************)
(* *)
(* Two functions used to manage list elements *)
(* *)
(* Note that they're thread-safe in multi-threaded *)
(* builds. *)
(* *)
function Element_New : PList_Element;
(* Returns a new list element, either fresh or recycled *)
(* Note : the returned element is unlinked *)
procedure Element_Done( element : PList_Element );
(* Recycles or discards an element. *)
(* Note : The element must be unlinked !! *)
function TTCache_Init : TError;
function TTCache_Done : TError;
implementation
uses TTMemory;
const
Null_Single_List = nil;
var
Free_Elements : PList_Element;
(*******************************************************************
*
* Function : Element_New
*
* Description : Gets a new ( either fresh or recycled ) list
* element. The element is unlisted.
*
* Notes : returns nil if out of memory
*
*****************************************************************)
function Element_New : PList_Element;
var
element : PList_Element;
begin
(* LOCK *)
if Free_Elements <> nil then
begin
element := Free_Elements;
Free_Elements := element^.next;
end
else
begin
Alloc( element, sizeof(TList_Element) );
(* by convention, an allocated block is always zeroed *)
(* the fields of element need not be set to NULL then *)
end;
(* UNLOCK *)
Element_New := element;
end;
(*******************************************************************
*
* Function : Element_Done
*
* Description : recycles an unlisted list element
*
* Notes : Doesn't check that the element is unlisted
*
*****************************************************************)
procedure Element_Done( element : PList_Element );
begin
(* LOCK *)
element^.next := Free_Elements;
Free_Elements := element;
(* UNLOCK *)
end;
(*******************************************************************
*
* Function : Cache_Create
*
* Description : Create a new cache object
*
*****************************************************************)
function Cache_Create( var clazz : TCache_Class;
var cache : TCache ) : TError;
begin
cache.clazz := @clazz;
cache.idle_count := 0;
cache.active := Null_Single_List;
cache.idle := Null_Single_List;
Cache_Create := Success;
end;
(*******************************************************************
*
* Function : Cache_Destroy
*
* Description : Destroy a given cache object
*
*****************************************************************)
function Cache_Destroy( var cache : TCache ) : TError;
var
destroy : TDestructor;
current : PList_Element;
next : PList_Element;
begin
(* now destroy all active and idle listed objects *)
destroy := cache.clazz^.done;
(* active list *)
current := cache.active;
while current <> nil do
begin
next := current^.next;
destroy( current^.data );
Free( current^.data );
Element_Done( current );
current := next;
end;
cache.active := Null_SIngle_List;
(* idle list *)
current := cache.idle;
while current <> nil do
begin
next := current^.next;
destroy( current^.data );
Free( current^.data );
Element_Done( current );
current := next;
end;
cache.idle := Null_Single_List;
cache.clazz := nil;
cache.idle_count := 0;
Cache_Destroy := Success;
end;
(*******************************************************************
*
* Function : Cache_New
*
* Description : Extracts one 'new' object from a cache
*
* Notes : The 'parent_data' pointer is passed to the object's
* initialiser when the new object is created from
* scratch. Recycled objects do not use this pointer
*
*****************************************************************)
function Cache_New( var cache : TCache;
var new_object : Pointer;
parent_data : Pointer ) : TError;
var
error : TError;
current : PList_Element;
obj : Pointer;
label
Fail;
begin
(* LOCK *)
current := cache.idle;
if current <> nil then
begin
cache.idle := current^.next;
dec( cache.idle_count )
end;
(* UNLOCK *)
if current = nil then
begin
(* if no object was found in the cache, create a new one *)
if Alloc( obj, cache.clazz^.object_size ) then exit;
current := Element_New;
if current = nil then goto Fail;
current^.data := obj;
error := cache.clazz^.init( obj, parent_data );
if error then goto Fail;
end;
(* LOCK *)
current^.next := cache.active;
cache.active := current;
(* UNLOCK *)
new_object := current^.data;
Cache_New := Success;
exit;
Fail:
Free( obj );
Cache_New := Failure;
end;
(*******************************************************************
*
* Function : Cache_Done
*
* Description : Discards an object intro a cache
*
*****************************************************************)
function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
var
error : TError;
element : PList_Element;
parent : ^PList_Element;
label
Suite;
begin
Cache_Done := failure;
(* find element in list *)
(* LOCK *)
parent := @cache.active;
element := parent^;
while element <> nil do
begin
if element^.data = obj then
begin
parent^ := element^.next;
(* UNLOCK *)
goto Suite;
end;
parent := @element^.next;
element := parent^;
end;
(* UNLOCK *)
(* Element wasn't found !! *)
{$IFDEF DEBUG}
{$ENDIF}
exit;
Suite:
if ( cache.idle_count >= cache.clazz^.idle_limit ) then
begin
(* destroy the object when the cache is full *)
cache.clazz^.done( element^.data );
Free( element^.data );
Element_Done( element );
end
else
begin
(* simply add the object to the idle list *)
(* LOCK *)
element^.next := cache.idle;
cache.idle := element;
inc( cache.idle_count );
(* UNLOCK *)
end;
Cache_Done := Success;
end;
function TTCache_Init : TError;
begin
Free_Elements := nil;
TTCache_Init := Success;
end;
function TTCache_Done : TError;
var
current, next : PList_ELement;
begin
current := free_elements;
while current <> nil do
begin
next := current^.next;
Free( current );
current := next;
end;
TTCache_Done := success;
end;
end.