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