(*******************************************************************
 *
 *  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, TTLists;

type
  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                   *)

implementation

uses TTMemory;

(*******************************************************************
 *
 *  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;
  begin
    (* now destroy all active and idle listed objects *)

    destroy := cache.clazz^.done;

    (* active list *)

    current := List_Extract( cache.active );
    while current <> nil do
    begin
      destroy( current^.data );
      Free( current^.data );
      Element_Done( current );
      current := List_Extract( cache.active );
    end;

    (* idle list *)

    current := List_Extract( cache.idle );
    while current <> nil do
    begin
      destroy( current^.data );
      Free( current^.data );
      Element_Done( current );
      current := List_Extract( cache.idle );
    end;

    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
    Fin, Fail, Memory_Fail;
  begin
    current := List_Extract( cache.idle );
    if current <> nil then
      dec( cache.idle_count )
    else
      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;

    List_Add( cache.active, current );
    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;
  label
    Fin;
  begin
    Cache_Done := failure;

    element := List_Find( cache.active, obj );
    if element = nil then exit;

    List_Remove( cache.active, element );

    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 );
      end
    else
      begin
        (* simply add the object to the idle list *)
        List_Add( cache.idle, element );
        inc( cache.idle_count );
      end;

    Cache_Done := Success;
  end;


end.
