RosaryImpl:
CEDAR PROGRAM
IMPORTS AMBridge, IO, PrintTV, RopePrivate
EXPORTS Rosary ~ BEGIN OPEN Rosary;
Malformed:
PUBLIC
ERROR ~
CODE;
NonNeg:
PROC [x:
INT]
RETURNS [
INT] ~ RopePrivate.NonNeg;
Size:
PUBLIC PROC [r: Ref]
RETURNS [
INT] ~ {
RETURN [IF r = NIL THEN 0 ELSE r.size]
};
InlineSize:
PROC [r: Ref]
RETURNS [
INT] ~
INLINE {
RETURN [IF r = NIL THEN 0 ELSE r.size]
};
BoundsCheck:
PROC [i:
INT, max:
INT] ~
INLINE {
boundsCheck: [0..0] ~ MIN[max-i, 0];
};
Fetch:
PUBLIC
PROC [base: Ref, index:
INT]
RETURNS [Item] ~ {
BoundsCheck[index, InlineSize[base]-1];
DO
WITH base
SELECT
FROM
f: REF Rep.leaf => {RETURN [f.item]};
c:
REF Rep.concat => {
pos: INT ~ c.base.size;
IF index < pos THEN base ← c.base
ELSE {base ← c.rest; index ← index-pos};
};
ENDCASE => ERROR Malformed;
ENDLOOP;
};
FetchRun:
PUBLIC
PROC [base: Ref, index:
INT]
RETURNS [Run] ~ {
BoundsCheck[index, InlineSize[base]-1];
DO
WITH base
SELECT
FROM
f: REF Rep.leaf => {RETURN [[f.item, f.size-index]]};
c:
REF Rep.concat => {
pos: INT ~ c.base.size;
IF index < pos THEN base ← c.base
ELSE {base ← c.rest; index ← index-pos};
};
ENDCASE => ERROR Malformed;
ENDLOOP;
};
FromItem:
PUBLIC PROC [item: Item, repeat:
INT]
RETURNS [Ref] ~ {
r: REF Rep.leaf ← NEW[Rep.leaf];
r.size ← repeat;
r.height ← 1;
r.item ← item;
RETURN [r];
};
Substr:
PUBLIC PROC [base: Ref, start:
INT, len:
INT]
RETURNS [Ref] ~ {
[[base, start, len]] ← FixSegment[[base, start, len]];
IF base = NIL OR (start = 0 AND len = base.size) THEN RETURN [base];
RETURN [CatSegments[[base, start, len], nullSegment, nullSegment]];
};
LazyConcat:
PROC [base, rest: Ref]
RETURNS [Ref] ~ {
Never trys to rebalance.
IF base=
NIL
THEN
RETURN [rest]
ELSE
IF rest=
NIL
THEN
RETURN [base]
ELSE {
r: REF Rep.concat ← NEW[Rep.concat];
r.size ← base.size + rest.size;
r.height ← 1+MAX[base.height, rest.height];
r.base ← base;
r.rest ← rest;
RETURN [r];
};
};
Concat:
PUBLIC PROC [base, rest: Ref]
RETURNS [Ref] ~ {
IF base=NIL THEN RETURN [rest];
IF rest=NIL THEN RETURN [base];
IF base.height >= maxHeight-1
OR rest.height >= maxHeight-1
THEN {
RETURN [CatSegments[[base], [rest], nullSegment]];
}
ELSE RETURN [LazyConcat[base, rest]];
};
Cat:
PUBLIC PROC [r0, r1, r2, r3, r4: Ref]
RETURNS [Ref] ~ {
RETURN [Concat[Concat[r0,r1], Concat[Concat[r2, r3], r4]]];
};
CatSegments:
PUBLIC PROC [s0, s1, s2: Segment]
RETURNS [Ref] ~ {
a: ARep; -- An extensible array that is very cheap if it is small.
aN: INT ← 0;
AElement:
TYPE ~ Ref;
d: NAT ~ 40;
ARep:
TYPE
~ RECORD[index: INT𡤀, sub: ARRAY [0..d) OF AElement, rest: REF ARep←NIL];
accel: REF ARep ← NIL;
StoreA:
PROC [i:
INT, e: AElement] ~ {
IF i-a.index < d THEN a.sub[i-a.index] ← e
ELSE {
IF a.rest = NIL THEN {a.rest ← accel ← NEW[ARep]; accel.index ← d};
IF i < accel.index THEN accel ← a.rest;
WHILE i-accel.index >= d
DO
IF accel.rest = NIL THEN {accel.rest ← NEW[ARep]; accel.rest.index�l.index+d};
accel ← accel.rest;
ENDLOOP;
accel.sub[i-accel.index] ← e;
};
};
ASub:
PROC [i:
INT]
RETURNS [e: AElement] ~ {
IF i-a.index < d THEN e ← a.sub[i-a.index]
ELSE {
IF i < accel.index THEN accel ← a.rest;
WHILE i-accel.index >= d DO accel ← accel.rest ENDLOOP;
e ← accel.sub[i-accel.index];
};
};
nb: NAT ← 0;
b: Item ← NIL;
Flush:
PROC ~ {
IF nb > 0
THEN {
f: REF Rep.leaf ← NEW[Rep.leaf];
f.size ← nb;
f.height ← 1;
f.item ← b;
nb ← 0;
b ← NIL;
StoreA[aN, f];
aN ← aN + 1;
};
};
CheckItem:
PROC[new: Item] ~ {
Tries to pull the last item back into b, if it will coalese with the new one.
IF nb = 0
AND aN > 0
THEN {
WITH ASub[aN-1]
SELECT
FROM
f:
REF Rep.leaf => {
IF f.item = new
THEN {
b ← new;
nb ← f.size;
aN ← aN - 1;
};
};
ENDCASE => NULL;
};
};
SaveSegment:
PROC [segment: Segment] ~ {
IF segment.base #
NIL
THEN
WITH segment.base
SELECT
FROM
f:
REF Rep.leaf => {
CheckItem[f.item];
IF nb > 0 AND b = f.item THEN nb ← nb + segment.size
ELSE {
Flush[];
IF segment.start = 0 AND segment.size = f.size
THEN {StoreA[aN, f]; aN ← aN + 1}
ELSE {b ← f.item; nb ← segment.size};
};
};
ENDCASE => {
IF segment.start = 0 AND segment.size = segment.base.size THEN NULL ELSE ERROR;
Flush[]; StoreA[aN, segment.base]; aN ← aN + 1;
};
};
BalanceRange:
PROC [first:
INT, end:
INT, size:
INT]
RETURNS [Ref] ~ {
Balances pieces [first..end), whose sizes must sum to size.
Dbl:
PROC [int:
INT]
RETURNS [
INT] ~
INLINE {
IF int > LAST[INT]/2 THEN RETURN [LAST[INT]]
ELSE RETURN [int+int];
};
IF first = end THEN RETURN[NIL]
ELSE IF end-first = 1 THEN RETURN[ASub[first]]
ELSE {
i: INT ← first+1;
sizetoi: INT ← ASub[first].size;
FOR sizei: INT ← ASub[i].size, ASub[i].size
WHILE i < end-1
AND ((sizetoi+sizei)*2 < size
OR
ABS[sizetoi*2-size] >
ABS[(sizetoi+sizei)*2-size])
DO
sizetoi ← sizetoi + sizei;
i ← i + 1;
ENDLOOP;
RETURN[LazyConcat[BalanceRange[first, i, sizetoi], BalanceRange[i, end, size-sizetoi]]];
};
};
s0 ← FixSegment[s0];
s1 ← FixSegment[s1];
s2 ← FixSegment[s2];
MapSegments[s0, SaveSegment, SegmentIsBalanced];
MapSegments[s1, SaveSegment, SegmentIsBalanced];
MapSegments[s2, SaveSegment, SegmentIsBalanced];
Flush[];
RETURN [BalanceRange[0, aN, s0.size+s1.size+s2.size]]
};
FixSegment:
PROC [s: Segment]
RETURNS [Segment] ~ {
[] ← NonNeg[s.start];
[] ← NonNeg[s.size];
IF s.base = NIL THEN {[] ← NonNeg[-s.start]; s.size ← 0}
ELSE {s.size ← NonNeg[MIN[s.size, s.base.size-s.start]]};
RETURN [s];
};
BadSegment:
SIGNAL ~
CODE;
SegmentIsBalanced:
PROC [segment: Segment]
RETURNS [
BOOL] ~ {
Examines only the root.
IF segment.base = NIL THEN RETURN [TRUE]
ELSE {
size: INT ~ segment.base.size;
height: INT ~ segment.base.height;
IF segment.start # 0
OR segment.size # size
OR height > maxHeight
OR size < minSizeForHeight[height]
THEN RETURN [FALSE]
ELSE RETURN [TRUE]
};
};
minSizeForHeight: ARRAY [0..maxHeight) OF INT ~ InitMinSizeForHeight[];
InitMinSizeForHeight:
PROC
RETURNS [h:
ARRAY [0..maxHeight)
OF
INT] ~ {
h[0] ← 0; -- NIL has height 0, size 0.
h[1] ← 1; -- Must have at least one element to warrant any allocation.
h[2] ← 2; -- Must be at least this big to warrant any concat nodes.
FOR i:
NAT
IN [3..maxHeight)
DO
Use Fibonacci recurrence to compute rest.
Be careful about overflow here...
IF INT.LAST - h[i-1] < h[i-2] THEN h[i] ← INT.LAST
ELSE h[i] ← h[i-1] + h[i-2];
ENDLOOP;
};
MapSegments:
PROC[segment: Segment, action:
PROC[Segment], stopDescent:
PROC[Segment]
RETURNS[
BOOL]←
NIL] ~{
IF stopDescent#NIL AND stopDescent[segment] THEN action[segment]
ELSE {
size: INT ~ InlineSize[segment.base];
end: INT ~ segment.start+segment.size;
IF segment.start < 0 OR end NOT IN [segment.start..segment.start+size] THEN ERROR BadSegment;
WITH segment.base
SELECT
FROM
concat:
REF Rep.concat => {
pos: INT ~ concat.base.size;
IF segment.start < pos
THEN {
MapSegments[[concat.base, segment.start, MIN[end, pos]-segment.start], action, stopDescent];
};
IF end > pos
THEN {
newStart: INT ← MAX[segment.start-pos, 0];
newEnd: INT ← end-pos;
MapSegments[[concat.rest, newStart, newEnd-newStart], action, stopDescent];
};
};
ENDCASE => action[segment];
};
};
FromProc:
PUBLIC PROC [size:
INT, proc:
PUBLIC PROC
RETURNS[Item]]
RETURNS [Ref] ~ {
p:
PROC[q:
PROC[item: Item, repeat:
INT ← 1]] ~ {
FOR i:
INT
IN [0..size)
DO
q[proc[], 1];
ENDLOOP;
};
RETURN [FromProcProc[p]];
};
FromProcProc:
PUBLIC
PROC [p:
PROC[q:
PROC[item: Item, repeat:
INT]]]
RETURNS [Ref ←
NIL] ~ {
a:
ARRAY [0..maxHeight]
OF Ref;
The contents of the current node is represented by the concatenation of ropes in order by decreasing index, together with the contents of b. The size of a[i] is either 0 or approximately flatMax*2**i; building the Ref this way yields a balanced Ref.
nb: NAT ← 0;
b: Item ← NIL;
Fold:
PROC [new: Ref] ~ {
i: NAT ← 0;
DO
IF a[i] = NIL THEN {a[i] ← new; EXIT};
new ← LazyConcat[a[i], new];
a[i] ← NIL;
IF i < maxHeight THEN i ← i + 1;
ENDLOOP;
};
Flush:
PROC ~ {
IF nb > 0
THEN {
f: REF Rep.leaf ← NEW[Rep.leaf];
f.size ← nb;
f.height ← 1;
f.item ← b;
nb ← 0;
Fold[f];
};
};
q:
PROC[item: Item, repeat:
INT] ~ {
IF nb > 0 AND item = b THEN {nb ← nb + repeat}
ELSE {Flush[]; b ← item; nb ← repeat};
};
ref: Ref ← NIL;
p[q];
Flush[];
FOR i:
NAT
IN [0..maxHeight]
DO
IF a[i] #
NIL
THEN {
ref ← LazyConcat[a[i], ref];
};
ENDLOOP;
RETURN [ref];
};
Map:
PUBLIC
PROC [s: Segment, action: ActionType]
RETURNS [quit:
BOOLEAN] ~ {
stack: ARRAY [0..maxHeight) OF Ref;
stackSize: [0..maxHeight] ← 0;
s ← FixSegment[s];
DO
-- exit by RETURN
WITH s.base
SELECT
FROM
c:
REF Rep.concat => {
pos: INT ~ c.base.size;
IF s.start < pos THEN {stack[stackSize]𡤌.rest; stackSize←stackSize+1; s.base𡤌.base}
ELSE {s.start ← s.start - pos; s.base ← c.rest};
};
t:
REF Rep.leaf => {
WHILE s.start < t.size
DO
IF action[t.item] THEN RETURN [TRUE];
s.start ← s.start + 1;
s.size ← s.size - 1;
ENDLOOP;
IF stackSize = 0 THEN RETURN [FALSE];
stackSize ← stackSize - 1;
s.base ← stack[stackSize];
s.start ← 0;
};
ENDCASE => RETURN [FALSE];
ENDLOOP;
};
MapRuns:
PUBLIC
PROC [s: Segment, action: RunActionType]
RETURNS [quit:
BOOLEAN] ~ {
IF s.base #
NIL
THEN {
s.size ← NonNeg[MIN[s.size, s.base.size-s.start]];
DO
WITH s.base
SELECT
FROM
f:
REF Rep.leaf => {
start: INT ~ s.start;
end: INT ~ start+s.size;
item: Item ~ f.item;
IF action[item, s.size] THEN RETURN [TRUE];
EXIT;
};
c:
REF Rep.concat => {
IF s.start < c.base.size
THEN {
IF MapRuns[[c.base, s.start, s.size], action].quit THEN RETURN [TRUE];
};
s.start ← s.start - c.base.size;
IF s.start < 0
THEN {
s.size ← s.size + s.start;
s.start ← 0;
};
s.base ← c.rest;
IF s.size <= 0 THEN EXIT;
};
ENDCASE => ERROR Malformed;
ENDLOOP;
};
RETURN [FALSE];
};
FetchBuffer:
PUBLIC
PROC [base: Ref, index:
INT, maxCount: [0..bufferSize]]
RETURNS [b: Buffer] ~ {
stack: ARRAY [0..maxHeight) OF Ref;
stackSize: [0..maxHeight] ← 0;
b.count ← 0;
DO
-- exit by RETURN
WITH base
SELECT
FROM
c:
REF Rep.concat => {
pos: INT ~ c.base.size;
IF index < pos THEN {stack[stackSize]𡤌.rest; stackSize←stackSize + 1; base𡤌.base}
ELSE {index ← index - pos; base ← c.rest};
};
t:
REF Rep.leaf => {
WHILE index < t.size
DO
IF b.count = maxCount THEN RETURN;
b.a[b.count] ← t.item;
index ← index + 1;
b.count ← b.count + 1;
ENDLOOP;
IF stackSize = 0 THEN RETURN;
stackSize ← stackSize - 1;
base ← stack[stackSize];
index ← 0;
};
ENDCASE => RETURN;
ENDLOOP;
};
FromList:
PUBLIC
PROC [list:
LIST
OF
REF]
RETURNS [Ref] ~ {
p:
PROC[q:
PROC[item:
REF, repeat:
INT ← 1]] ~ {
FOR l:
LIST
OF
REF ← list, l.rest
UNTIL l =
NIL
DO
q[l.first];
ENDLOOP;
};
RETURN [FromProcProc[p]]
};
ToList:
PUBLIC
PROC [r: Ref]
RETURNS [
LIST
OF
REF] ~ {
head: LIST OF REF ~ LIST[NIL];
tail: LIST OF REF ← head;
action: ActionType ~ {
tail.rest ← LIST[item];
tail ← tail.rest;
};
RETURN [head.rest];
};
TVPrint: PrintTV.TVPrintProc ~
TRUSTED {
IF NOT AMBridge.IsRemote[tv] THEN RETURN [RefPrint[AMBridge.ReadOnlyRefFromTV[tv], NIL, stream, depth, width, verbose]];
};
RefPrint: PrintTV.RefPrintProc ~
TRUSTED {
WITH
LOOPHOLE[ref,
REF]
SELECT
FROM
r: Ref => {
size: INT ~ Size[r];
i: INT ← 0;
action: ActionType ~
TRUSTED {
itemTV: AMTypes.TV;
WITH item
SELECT
FROM
atom: ATOM => itemTV ← AMBridge.TVForATOM[atom];
rope: ROPE => itemTV ← AMBridge.TVForROPE[rope];
ENDCASE => {
itemTV ← AMBridge.TVForReadOnlyReferent[item];
IF item # NIL THEN IO.PutRope[stream, "^"];
};
PrintTV.Print[tv: itemTV, put: stream, depth: depth, width: width, verbose: verbose];
i ← i + 1;
IF i # size THEN IO.PutRope[stream, ", "];
quit ← (i >= width);
};
IO.PutRope[stream, "ROSARY["];
IF Map[[r],action].quit THEN IO.PutRope[stream, "..."];
IO.PutRope[stream, "]"];
RETURN [useOld: FALSE];
};
ENDCASE => NULL;
RETURN [useOld: TRUE];
};
PrintTV.RegisterTVPrintProc[[CODE[Rep]], TVPrint];
END.