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_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

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

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

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