1(* Ulm's Oberon Library 2 Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany 3 ---------------------------------------------------------------------------- 4 Ulm's Oberon Library is free software; you can redistribute it 5 and/or modify it under the terms of the GNU Library General Public 6 License as published by the Free Software Foundation; either version 7 2 of the License, or (at your option) any later version. 8 9 Ulm's Oberon Library is distributed in the hope that it will be 10 useful, but WITHOUT ANY WARRANTY; without even the implied warranty 11 of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Library General Public License for more details. 13 14 You should have received a copy of the GNU Library General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 17 ---------------------------------------------------------------------------- 18 E-mail contact: oberon@mathematik.uni-ulm.de 19 ---------------------------------------------------------------------------- 20 $Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $ 21 ---------------------------------------------------------------------------- 22 $Log: Services.om,v $ 23 Revision 1.2 2004/09/03 09:34:24 borchert 24 cache results of LoadService to avoid further attempts 25 26 Revision 1.1 1995/03/03 09:32:15 borchert 27 Initial revision 28 29 ---------------------------------------------------------------------------- 30*) 31 32MODULE ulmServices; 33 34 IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects, Types := ulmTypes; 35 36 TYPE 37 Type* = POINTER TO TypeRec; 38 ServiceList = POINTER TO ServiceListRec; 39 Service* = POINTER TO ServiceRec; 40 Object* = POINTER TO ObjectRec; 41 ObjectRec* = 42 RECORD 43 (Disciplines.ObjectRec) 44 type: Type; 45 installed: ServiceList; (* set of installed services *) 46 END; 47 48 InstallProc = PROCEDURE (object: Object; service: Service); 49 50 ServiceRec* = 51 RECORD 52 (Disciplines.ObjectRec) 53 name: ARRAY 64 OF CHAR; 54 next: Service; 55 END; 56 57 ServiceListRec = 58 RECORD 59 service: Service; 60 type: Type; 61 install: InstallProc; 62 next: ServiceList; 63 END; 64 65 VAR 66 services: Service; 67 (* list of services -- needed to support Seek *) 68 69 TYPE 70 LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN; 71 LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN; 72 LoaderInterface* = POINTER TO LoaderInterfaceRec; 73 LoaderInterfaceRec* = 74 RECORD 75 loadModule*: LoadModuleProc; 76 loadService*: LoadServiceProc; 77 END; 78 VAR 79 loaderIF: LoaderInterface; 80 81 (* ==== name tables ================================================== *) 82 83 CONST 84 bufsize = 512; (* length of a name buffer in bytes *) 85 tabsize = 1171; 86 TYPE 87 BufferPosition = Types.Int32; 88 Length = Types.Int32; 89 HashValue = Types.Int32; 90 Buffer = ARRAY bufsize OF CHAR; 91 NameList = POINTER TO NameListRec; 92 NameListRec = 93 RECORD 94 buffer: Buffer; 95 next: NameList; 96 END; 97 VAR 98 currentBuf: NameList; currentPos: BufferPosition; 99 TYPE 100 TypeRec* = 101 RECORD 102 (Disciplines.ObjectRec) 103 baseType: Type; 104 services: ServiceList; 105 cachedservices: ServiceList; (* of base types *) 106 (* table management *) 107 hashval: HashValue; 108 length: Length; 109 begin: NameList; 110 pos: BufferPosition; 111 next: Type; (* next type with same hash value *) 112 END; 113 BucketTable = ARRAY tabsize OF Type; 114 VAR 115 bucket: BucketTable; 116 117 (* ==== name table management ======================================== *) 118 119 PROCEDURE Hash(name: ARRAY OF CHAR; length: Types.Int32) : HashValue; 120 CONST 121 shift = 4; 122 VAR 123 index: Types.Int32; 124 val: Types.Int32; 125 ch: CHAR; 126 ordval: Types.Int32; 127 BEGIN 128 index := 0; val := length; 129 WHILE index < length DO 130 ch := name[index]; 131 IF ch >= " " THEN 132 ordval := ORD(ch) - ORD(" "); 133 ELSE 134 ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch); 135 END; 136 val := ASH(val, shift) + ordval; 137 INC(index); 138 END; 139 val := val MOD tabsize; 140 RETURN SHORT(val) 141 END Hash; 142 143 PROCEDURE CreateBuf(VAR buf: NameList); 144 BEGIN 145 NEW(buf); buf.next := NIL; 146 IF currentBuf # NIL THEN 147 currentBuf.next := buf; 148 END; 149 currentBuf := buf; 150 currentPos := 0; 151 END CreateBuf; 152 153 PROCEDURE StringLength(string: ARRAY OF CHAR) : Types.Int32; 154 VAR 155 index: Types.Int32; 156 BEGIN 157 index := 0; 158 WHILE (index < LEN(string)) & (string[index] # 0X) DO 159 INC(index); 160 END; 161 RETURN index 162 END StringLength; 163 164 PROCEDURE InitName(name: Type; string: ARRAY OF CHAR); 165 VAR 166 index, length: Types.Int32; 167 firstbuf, buf: NameList; 168 startpos: BufferPosition; 169 BEGIN 170 IF currentBuf = NIL THEN 171 CreateBuf(buf); 172 ELSE 173 buf := currentBuf; 174 END; 175 176 firstbuf := buf; startpos := currentPos; 177 index := 0; 178 WHILE (index < LEN(string)) & (string[index] # 0X) DO 179 IF currentPos = bufsize THEN 180 CreateBuf(buf); 181 END; 182 buf.buffer[currentPos] := string[index]; INC(currentPos); 183 INC(index); 184 END; 185 length := index; 186 187 name.hashval := Hash(string, length); 188 name.length := length; 189 name.begin := firstbuf; 190 name.pos := startpos; 191 name.next := bucket[name.hashval]; 192 bucket[name.hashval] := name; 193 END InitName; 194 195 PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN; 196 (* precondition: both have the same length *) 197 VAR 198 index: Types.Int32; 199 buf: NameList; 200 pos: Types.Int32; 201 BEGIN 202 buf := name.begin; pos := name.pos; 203 index := 0; 204 WHILE index < name.length DO 205 IF pos = bufsize THEN 206 buf := buf.next; pos := 0; 207 END; 208 IF string[index] # buf.buffer[pos] THEN 209 RETURN FALSE 210 END; 211 INC(pos); 212 INC(index); 213 END; 214 RETURN TRUE 215 END EqualName; 216 217 PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN; 218 VAR 219 length: Types.Int32; 220 hashval: HashValue; 221 p: Type; 222 BEGIN 223 length := StringLength(string); 224 hashval := Hash(string, length); 225 p := bucket[hashval]; 226 WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO 227 p := p.next; 228 END; 229 name := p; 230 RETURN p # NIL 231 END SeekName; 232 233 PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR); 234 VAR 235 index: Types.Int32; 236 buf: NameList; 237 pos: Types.Int32; 238 BEGIN 239 buf := name.begin; pos := name.pos; 240 index := 0; 241 WHILE (index + 1 < LEN(string)) & (index < name.length) DO 242 IF pos = bufsize THEN 243 buf := buf.next; pos := 0; 244 END; 245 string[index] := buf.buffer[pos]; 246 INC(pos); 247 INC(index); 248 END; 249 string[index] := 0X; 250 END ExtractName; 251 252 PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN; 253 BEGIN 254 IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN 255 RETURN loaderIF.loadModule(module) 256 ELSE 257 RETURN FALSE 258 END; 259 END LoadModule; 260 261 PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN; 262 BEGIN 263 IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN 264 RETURN loaderIF.loadService(service, for) 265 ELSE 266 RETURN FALSE 267 END; 268 END LoadService; 269 270 PROCEDURE MemberOf(list: ServiceList; service: Service; 271 VAR member: ServiceList) : BOOLEAN; 272 VAR 273 p: ServiceList; 274 BEGIN 275 p := list; 276 WHILE (p # NIL) & (p.service # service) DO 277 p := p.next; 278 END; 279 member := p; 280 RETURN p # NIL 281 END MemberOf; 282 283 PROCEDURE SeekService(type: Type; service: Service; 284 VAR member: ServiceList; 285 VAR baseType: Type) : BOOLEAN; 286 287 VAR 288 btype: Type; 289 cachedservice: ServiceList; 290 291 PROCEDURE Seek(type: Type; service: Service; 292 VAR member: ServiceList) : BOOLEAN; 293 VAR 294 typeName: ARRAY 512 OF CHAR; 295 BEGIN 296 IF MemberOf(type.services, service, member) OR 297 MemberOf(type.cachedservices, service, member) THEN 298 RETURN TRUE 299 END; 300 ExtractName(type, typeName); 301 RETURN LoadService(service.name, typeName) & 302 MemberOf(type.services, service, member) 303 END Seek; 304 305 BEGIN (* SeekService *) 306 btype := type; 307 WHILE (btype # NIL) & ~Seek(btype, service, member) DO 308 btype := btype.baseType; 309 END; 310 IF (member # NIL) & (btype # type) THEN 311 (* cache result to avoid further tries to load 312 a more fitting variant dynamically 313 *) 314 NEW(cachedservice); 315 cachedservice.service := service; 316 cachedservice.type := member.type; 317 cachedservice.install := member.install; 318 cachedservice.next := type.cachedservices; 319 type.cachedservices := cachedservice; 320 baseType := member.type; 321 RETURN TRUE 322 END; 323 IF member = NIL THEN 324 RETURN FALSE 325 ELSE 326 baseType := member.type; 327 RETURN TRUE 328 END; 329 END SeekService; 330 331 PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); 332 (* get the name of the module where 'name' was defined *) 333 VAR 334 index: Types.Int32; 335 BEGIN 336 index := 0; 337 WHILE (name[index] # ".") & (name[index] # 0X) & 338 (index < LEN(module)-1) DO 339 module[index] := name[index]; INC(index); 340 END; 341 module[index] := 0X; 342 END GetModule; 343 344 (* ==== exported procedures ========================================== *) 345 346 PROCEDURE InitLoader*(if: LoaderInterface); 347 BEGIN 348 ASSERT((loaderIF = NIL) & (if # NIL)); 349 loaderIF := if; 350 END InitLoader; 351 352 PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR); 353 VAR 354 baseType: Type; 355 otherType: Type; 356 ok: BOOLEAN; 357 BEGIN 358 IF baseName = "" THEN 359 baseType := NIL; 360 ELSE 361 ok := SeekName(baseName, baseType); ASSERT(ok); 362 END; 363 ASSERT(~SeekName(name, otherType)); 364 InitName(type, name); 365 type.baseType := baseType; 366 type.services := NIL; 367 type.cachedservices := NIL; 368 END InitType; 369 370 PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR); 371 BEGIN 372 NEW(type); InitType(type, name, baseName); 373 END CreateType; 374 375 PROCEDURE Init*(object: Object; type: Type); 376 BEGIN 377 ASSERT(type # NIL); 378 ASSERT(object.type = NIL); 379 object.type := type; 380 object.installed := NIL; 381 END Init; 382 383 PROCEDURE GetType*(object: Object; VAR type: Type); 384 BEGIN 385 type := object.type; 386 END GetType; 387 388 PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR); 389 BEGIN 390 ExtractName(type, name); 391 END GetTypeName; 392 393 PROCEDURE GetBaseType*(type: Type; VAR baseType: Type); 394 BEGIN 395 baseType := type.baseType; 396 END GetBaseType; 397 398 PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN; 399 BEGIN 400 ASSERT(baseType # NIL); 401 WHILE (type # NIL) & (type # baseType) DO 402 type := type.baseType; 403 END; 404 RETURN type = baseType 405 END IsExtensionOf; 406 407 PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type); 408 VAR 409 module: ARRAY 64 OF CHAR; 410 BEGIN 411 IF ~SeekName(name, type) THEN 412 (* try to load the associated module *) 413 GetModule(name, module); 414 IF ~LoadModule(module) OR ~SeekName(name, type) THEN 415 type := NIL; 416 END; 417 END; 418 END SeekType; 419 420 PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service); 421 BEGIN 422 service := services; 423 WHILE (service # NIL) & (service.name # name) DO 424 service := service.next; 425 END; 426 427 (* try to load a module named after `name', if not successful *) 428 IF (service = NIL) & LoadModule(name) THEN 429 service := services; 430 WHILE (service # NIL) & (service.name # name) DO 431 service := service.next; 432 END; 433 END; 434 END Seek; 435 436 PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR); 437 438 PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN; 439 VAR 440 service: Service; 441 BEGIN 442 service := services; 443 WHILE (service # NIL) & (service.name # name) DO 444 service := service.next; 445 END; 446 RETURN service # NIL 447 END Created; 448 449 BEGIN 450 ASSERT(~Created(name)); 451 NEW(service); 452 COPY(name, service.name); 453 service.next := services; services := service; 454 END Create; 455 456 PROCEDURE Define*(type: Type; service: Service; install: InstallProc); 457 VAR 458 member: ServiceList; 459 BEGIN 460 ASSERT(service # NIL); 461 (* protect against multiple definitions: *) 462 ASSERT(~MemberOf(type.services, service, member)); 463 464 NEW(member); member.service := service; 465 member.install := install; member.type := type; 466 member.next := type.services; type.services := member; 467 END Define; 468 469 PROCEDURE Install*(object: Object; service: Service) : BOOLEAN; 470 VAR 471 member, installed: ServiceList; 472 baseType: Type; 473 BEGIN 474 IF object.type = NIL THEN RETURN FALSE END; 475 IF ~SeekService(object.type, service, member, baseType) THEN 476 (* service not supported for this object type *) 477 RETURN FALSE 478 END; 479 IF ~MemberOf(object.installed, service, installed) THEN 480 (* install services only once *) 481 IF member.install # NIL THEN 482 member.install(object, service); 483 END; 484 NEW(installed); 485 installed.service := service; 486 installed.next := object.installed; 487 object.installed := installed; 488 END; 489 RETURN TRUE 490 END Install; 491 492 PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN; 493 VAR 494 member: ServiceList; 495 baseType: Type; 496 BEGIN 497 RETURN (object.type # NIL) & 498 SeekService(object.type, service, member, baseType) 499 END Supported; 500 501 PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN; 502 VAR 503 member: ServiceList; 504 BEGIN 505 RETURN MemberOf(object.installed, service, member) 506 END Installed; 507 508 PROCEDURE GetSupportedBaseType*(object: Object; service: Service; 509 VAR baseType: Type); 510 VAR 511 member: ServiceList; 512 BEGIN 513 IF ~SeekService(object.type, service, member, baseType) THEN 514 baseType := NIL; 515 END; 516 END GetSupportedBaseType; 517 518BEGIN 519 currentBuf := NIL; currentPos := 0; loaderIF := NIL; 520END ulmServices. 521