Patch title: Release 94 bulk changes
Abstract:
File: /pliant/language/data/cache.pli
Key:
    Removed line
    Added line
   
module "/pliant/install/ring2.pli"
module "/pliant/language/context/memory.pli"
module "/pliant/install/ring2.pli"
module "/pliant/language/context/memory.pli"
module "/pliant/language/stream/stream.pli"


constant flag_init 100h


constant flag_init 100h
constant flag_drop 200h
constant flag_dropped 400h
constant flag_update 200h
constant flag_drop 400h
constant flag_dropped 800h






method p update stream -> status
  oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status
  generic
  status := failure "not implemented"

method p dump stream -> status
  oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status
  generic
  status := failure "not implemented"

method p sleep
  oarg_rw CachePrototype p
  generic

method p drop
  oarg_rw CachePrototype p
  generic

method p drop
  oarg_rw CachePrototype p
  generic

# update accordingly:
# /pliant/graphic/color/gamut.pli
# /pliant/storage/database/prototype.pli



gvar Dictionary cache
gvar (Array List_ class_count) lru
gvar Sem sem


gvar Dictionary cache
gvar (Array List_ class_count) lru
gvar Sem sem


method cp update_begin
  arg_rw CachePrototype cp
  cp flags := cp:flags .or. flag_update

method cp update_end
  arg_rw CachePrototype cp
  cp flags := cp:flags .and. .not. (cast flag_update Int)

method cp is_update -> c
  arg CachePrototype cp ; arg CBool c
  c := (cp:flags .and. flag_update)<>0


function cache_shrink mem class -> status
  arg Int mem class ; arg Status status
  part shrink
    if memory_current_used<mem
      return success
    sem request
    var Int c := 0
    part scan
      var Link:CachePrototype obj :> (addressof lru:c:first)
function cache_shrink mem class -> status
  arg Int mem class ; arg Status status
  part shrink
    if memory_current_used<mem
      return success
    sem request
    var Int c := 0
    part scan
      var Link:CachePrototype obj :> (addressof lru:c:first)
      while exists:obj and ((addressof:obj translate Int -2)
      while exists:obj and (addressof:obj map Int -2)<>2
        obj :> (addressof obj:list_node:next) map CacheProto
      if not exists:obj and c<class
        c += 1
        restart scan
    if exists:obj
      obj:list remove obj:list_node
      obj flags += flag_drop
    sem release
    if exists:obj
      check (obj:flags .and. flag_init)=0 # there is no link
      obj drop
      sem request
      cache remove obj:id addressof:obj
      obj flags := flag_dropped
      sem release
      obj :> null map CachePrototype
      restart shrink
  status := failure


        obj :> (addressof obj:list_node:next) map CacheProto
      if not exists:obj and c<class
        c += 1
        restart scan
    if exists:obj
      obj:list remove obj:list_node
      obj flags += flag_drop
    sem release
    if exists:obj
      check (obj:flags .and. flag_init)=0 # there is no link
      obj drop
      sem request
      cache remove obj:id addressof:obj
      obj flags := flag_dropped
      sem release
      obj :> null map CachePrototype
      restart shrink
  status := failure


function broadcast_prototype object param fun
  oarg_rw CachePrototype object ; arg_rw Universal param ; arg Function fun
  indirect

function cache_broadcast fun param
  arg Function fun ; arg_rw Universal param
  sem request
  for (var Int i) 0 lru:size-1
    var Link:CachePrototype obj :> (addressof lru:i:first) map CachePrototype
    while exists:obj
      broadcast_prototype obj param fun
      obj :> (addressof obj:list_node:next) map CachePrototype
  sem release


function cache_open id type obj -> newone
  arg Str id ; arg Type type ; arg_w Link:CachePrototype obj
  part fetch
    cache_shrink
    sem request
    obj :> (cache first id) map CachePrototype
    if exists:obj
      if (obj:flags .and. flag_drop)=0
        var Pointer:List_ l :> obj list
        l remove obj:list_node
        l append obj:list_node
      newone := false
    else
      obj :> (entry_new type) map CachePrototype
      obj id := id
      obj flags := flag_init+cache_class_standard
      cache insert id true addressof:obj
      obj:list append obj:list_node
      newone := true
    sem release
    if not newone
      while (obj:flags .and. flag_init+flag_drop)<>0
        os_yield
      if (obj:flags .and. flag_dropped)<>0
        restart fetch


function cache_open id type obj -> newone
  arg Str id ; arg Type type ; arg_w Link:CachePrototype obj
  part fetch
    cache_shrink
    sem request
    obj :> (cache first id) map CachePrototype
    if exists:obj
      if (obj:flags .and. flag_drop)=0
        var Pointer:List_ l :> obj list
        l remove obj:list_node
        l append obj:list_node
      newone := false
    else
      obj :> (entry_new type) map CachePrototype
      obj id := id
      obj flags := flag_init+cache_class_standard
      cache insert id true addressof:obj
      obj:list append obj:list_node
      newone := true
    sem release
    if not newone
      while (obj:flags .and. flag_init+flag_drop)<>0
        os_yield
      if (obj:flags .and. flag_dropped)<>0
        restart fetch


export CachePrototype '. drop' 
export CachePrototype '. id' '. update' '. dump' '. sleep' '. drop'
export '. update_begin' '. update_end' '. is_update'
export cache_shrink
export cache_shrink
export cache_broadcast
export cache_open cache_setup cache_ready cache_cancel
export cache_search
export cache_delete



export cache_open cache_setup cache_ready cache_cancel
export cache_search
export cache_delete