Listing: 1 (* Release 3.10 *) 2 (*-------------------------------------------------------------------------* 3 * * 4 * SHTHEAP.MOD - Short heaps * 5 * * 6 * COPYRIGHT (C) 1987..1992 Clarion Software Corporation. * 7 * All Rights Reserved * 8 * * 9 *--------------------------------------------------------------------------*) 10 11 (*# call(o_a_copy => on, 12 o_a_size => on) *) 13 (*%F _fdata *) 14 (*# call(seg_name => null) *) 15 (*# data(seg_name => null) *) 16 (*%E *) 17 (*# module(implementation=>off) *) 18 (*# check(stack=>off, 19 index=>off, 20 range=>off, 21 overflow=>off, 22 nil_ptr=>off) *) 23 24 IMPLEMENTATION MODULE ShtHeap ; 25 26 IMPORT Lib, SYSTEM, CoreSig; 27 28 TYPE Offset = CARDINAL; 29 Block = RECORD 30 Siz: Size; ***** ^ undeclared identifier 31 Nxt: Pointer; ***** ^ undeclared identifier 32 END; ***** ^ not supported yet 33 34 35 PROCEDURE Initialize ( H: Segment; Z: Size ); ***** ^ undeclared identifier ***** ^ undeclared identifier 36 VAR B,F: POINTER H TO Block; ***** ^ 'FORWARD' expected 37 BEGIN 38 Z := (Z DIV Align) * Align; 39 IF Z < 10 THEN 40 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9AH, 'ShtHeap.Initialize : Size Too Small'); 41 END; 42 B := Pointer ( 0 ); 43 F := Pointer ( Align ); 44 B^.Siz := Z; 45 B^.Nxt := F; 46 F^.Siz := Z - Align; 47 F^.Nxt := Nil; 48 END Initialize; 49 50 51 PROCEDURE Increase ( H: Segment; Z: Size ); 52 VAR B,L,I: POINTER H TO Block; 53 BEGIN 54 IF Debug THEN 55 Test ( H ); 56 END; 57 Z := (Z DIV Align) * Align; 58 B := Pointer ( 0 ); 59 IF Z > MAX(Size) - B^.Siz THEN 60 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9BH, 'ShtHeap.Increase : Size Too Large'); 61 END; 62 I := B; 63 REPEAT 64 L := I; 65 I := I^.Nxt; 66 UNTIL I = Nil; 67 IF (L # B) AND (Offset ( L ) + L^.Siz = B^.Siz) THEN 68 INC ( L^.Siz , Z ); 69 ELSE 70 I := Pointer ( B^.Siz ); 71 L^.Nxt := I; 72 I^.Siz := Z; 73 I^.Nxt := Nil; 74 END; 75 INC ( B^.Siz , Z ); 76 END Increase; 77 78 79 PROCEDURE Allocate ( H: Segment; VAR P: Pointer; Z: Size ); 80 VAR B,F,G,N: POINTER H TO Block; 81 BEGIN 82 IF Debug THEN 83 Test ( H ); 84 END; 85 Z := ( (Z+Align-1) DIV Align) * Align; 86 IF Z = 0 THEN 87 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9CH, 'ShtHeap.Allocate : Size Too Small'); 88 END; 89 B := Pointer ( 0 ); 90 G := B; 91 LOOP 92 F := G^.Nxt; 93 IF F = Nil THEN 94 IF Check THEN 95 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9DH, 'ShtHeap.Allocate : Out Of Memory'); 96 ELSE 97 P := Nil; 98 RETURN; 99 END; 100 ELSIF F^.Siz >= Z THEN 101 EXIT; 102 END; 103 G := F; 104 END; 105 IF F^.Siz = Z THEN 106 G^.Nxt := F^.Nxt; 107 ELSE 108 N := Pointer ( Offset ( F ) + Z ); 109 G^.Nxt := N; 110 N^.Siz := F^.Siz - Z; 111 N^.Nxt := F^.Nxt; 112 END; 113 IF Clear THEN 114 Lib.WordFill ( ADR(F^) , Z DIV 2 , 0 ); 115 END; 116 P := F; 117 END Allocate; 118 119 120 PROCEDURE Free ( H: Segment; VAR P: Pointer; Z: Size ); 121 VAR B,F,G,Q: POINTER H TO Block; 122 BEGIN 123 IF Debug THEN 124 Test ( H ); 125 END; 126 Z := ( (Z+Align-1) DIV Align) * Align; 127 Q := P; 128 P := Nil; 129 IF Q = Nil THEN 130 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9EH, 'ShtHeap.Free : Invalid Argument'); 131 END; 132 B := Pointer ( 0 ); 133 G := B; 134 LOOP 135 F := G^.Nxt; 136 IF (F = Nil) OR (Offset ( Q ) < Offset ( F )) THEN EXIT; END; 137 G := F; 138 END; 139 IF Offset ( G ) + G^.Siz = Offset ( Q ) THEN 140 INC ( G^.Siz , Z ); 141 Q := G; 142 ELSE 143 G^.Nxt := Q; 144 Q^.Nxt := F; 145 Q^.Siz := Z; 146 END; 147 IF Offset ( Q ) + Q^.Siz = Offset ( F ) THEN 148 INC ( Q^.Siz , F^.Siz ); 149 Q^.Nxt := F^.Nxt; 150 END; 151 END Free; 152 153 154 PROCEDURE Largest ( H: Segment ): Size; 155 VAR P: POINTER H TO Block; 156 Z: Size; 157 BEGIN 158 IF Debug THEN 159 Test ( H ); 160 END; 161 P := Pointer ( 0 ); 162 P := P^.Nxt; 163 Z := 0; 164 WHILE P # Nil DO 165 IF Z < P^.Siz THEN 166 Z := P^.Siz; 167 END; 168 P := P^.Nxt; 169 END; 170 RETURN Z; 171 END Largest; 172 173 174 PROCEDURE Total ( H: Segment ): Size; 175 VAR P: POINTER H TO Block; 176 Z: Size; 177 BEGIN 178 IF Debug THEN 179 Test ( H ); 180 END; 181 P := Pointer ( 0 ); 182 P := P^.Nxt; 183 Z := 0; 184 WHILE P # Nil DO 185 INC ( Z , P^.Siz ); 186 P := P^.Nxt; 187 END; 188 RETURN Z; 189 END Total; 190 191 192 PROCEDURE Test ( H: Segment ); 193 VAR B,F,G: POINTER H TO Block; 194 BEGIN 195 B := Pointer ( 0 ); 196 IF B^.Siz MOD Align # 0 THEN 197 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, 'ShtHeap.Test : Non-aligned heap size.'); 198 END; 199 G := B; 200 LOOP 201 F := G^.Nxt; 202 IF F = Nil THEN EXIT; END; 203 IF Offset ( F ) >= B^.Siz THEN 204 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Free block out of range" ); 205 ELSIF Offset ( F ) MOD Align # 0 THEN 206 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Non-aligned free block" ); 207 ELSIF F^.Siz MOD Align # 0 THEN 208 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Non-aligned free block size" ); 209 ELSIF Offset ( F ) < Offset ( G ) THEN 210 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Unordered free list" ); 211 ELSIF (G # B) AND (Offset ( G ) + G^.Siz = Offset ( F )) THEN 212 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Unjoined free list" ); 213 ELSIF (G # B) AND (Offset ( G ) + G^.Siz > Offset ( F )) THEN 214 Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Overlapping free list" ); 215 END; 216 G := F; 217 END; 218 END Test; 219 220 221 BEGIN 222 IF SIZE ( Block ) > Align THEN 223 Lib.FatalError ( "ShtHeap: Alignment too small" ); 224 END; 225 Clear := FALSE; 226 Check := TRUE; 227 Debug := FALSE; 228 END ShtHeap. 6 errors