-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathLOOPSUID
428 lines (321 loc) · 17.4 KB
/
LOOPSUID
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Aug-2022 14:47:13" {DSK}<home>larry>loops>system>LOOPSUID.;2 17366
:CHANGES-TO (VARS LOOPSUIDCOMS)
:PREVIOUS-DATE " 2-Jun-2022 13:44:04" {DSK}<home>larry>loops>system>LOOPSUID.;1)
(* ; "
Copyright (c) 1984-1988, 1990, 2022 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LOOPSUIDCOMS)
(RPAQQ LOOPSUIDCOMS
(
(* ;;; "Patches a problem in Lyric. Fixed in Medley. IDATE and DATE were declared non-side effecting & non-effected thus compile-time constant. This could cause non-unique UIDs to be generated.")
(DECLARE%: EVAL@COMPILE DONTCOPY (COMPILER::COMPILER-DATA (
"Side-effects data for IRM, Chapter 12: Miscellaneous"
:NONE :ANY)))
(* ;;; "Creates unique identifiers for instances")
(FNS HasUID? Make-UID UID UIDP)
(INITVARS (*UID-SESSION* NIL)
(*UID-COUNT* 0))
(GLOBALVARS *UID-SESSION* *UID-COUNT*)
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS UID))
DONTEVAL@COMPILE DOCOPY (INITRECORDS UID))
(* ;;; "Packing together a unique ID that specifies the current login")
(FNS InitializeUIDs RADIX64NUM)
(* ;;; "Unpacking UIDs for human consumption")
(FNS Unpack-UID ConvertFromRadix64)
(* ;;; "Access UID/instance relation")
(FNS GetObjFromUID PutObjectUID DeleteObjectUID MapObjectUID UIDHashBits UIDEqual)
[INITVARS (*UID-Table* (HASHARRAY 8000 NIL 'UIDHashBits 'UIDEqual]
(GLOBALVARS *UID-Table*)
(ADDVARS (GLOBALVARS *UID-Table*))
(* ;;; "Make sure that cache of front part of UID is invalidated whenever system is restarted.")
(FNS \Loops.AroundExit)
(ADDVARS (AROUNDEXITFNS \Loops.AroundExit))))
(* ;;;
"Patches a problem in Lyric. Fixed in Medley. IDATE and DATE were declared non-side effecting & non-effected thus compile-time constant. This could cause non-unique UIDs to be generated."
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(COMPILER::DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :NONE :ANY
DATE
GDATE
IDATE
CLOCK
MACHINETYPE)
)
(* ;;; "Creates unique identifiers for instances")
(DEFINEQ
(HasUID?
[LAMBDA (obj) (* ; "Edited 15-Aug-90 13:13 by jds")
(* * Return the object's UID if it has one, otherwise return NIL)
(if (Object? obj)
then (fetch (OBJECT OBJUID) of obj)
else (ERROR "ARG NOT OBJECT" obj])
(Make-UID
[LAMBDA NIL (* smL "20-May-86 13:34")
(* * Creates and returns a unique identifier.)
(COND
((NULL *UID-SESSION*) (* Here if needed to reinitialize
UIDs.)
(InitializeUIDs)))
(UNINTERRUPTABLY
(create UID
sessionID _ *UID-SESSION*
uidNumber _ (SETQ *UID-COUNT* (ADD1 *UID-COUNT*))))])
(UID
[LAMBDA (obj) (* ; "Edited 15-Aug-90 13:13 by jds")
(* * Return the UID of the object, creating the UID if the object doesn't
already have one.)
(if (Object? obj)
then (OR (fetch (OBJECT OBJUID) of obj)
(CreateEntity obj))
else (ERROR "ARG NOT OBJECT" obj])
(UIDP
[LAMBDA (x) (* smL "19-May-86 17:11")
(* * Is x of the form of a UID?)
(AND (LISTP x)
(LITATOM (CAR x))
(FIXP (CDR x])
)
(RPAQ? *UID-SESSION* NIL)
(RPAQ? *UID-COUNT* 0)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *UID-SESSION* *UID-COUNT*)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(RECORD UID (sessionID . uidNumber)
(SYSTEM))
)
(* "END EXPORTED DEFINITIONS")
DONTEVAL@COMPILE DOCOPY
)
(* ;;; "Packing together a unique ID that specifies the current login")
(DEFINEQ
(InitializeUIDs
[LAMBDA NIL (* ; "Edited 2-Jun-2022 13:43 by briggs")
(* ; "Edited 11-Mar-2022 18:41 by briggs")
(* ; "Edited 21-Apr-88 11:38 by jrb:")
(* ;;; "Initializes the UniqueIdentifer Generation System in DB. Sets the global variables *UID-SESSION* and and *UID-COUNT*")
(* ;
"Make sure that we have a valid time!")
(DECLARE (GLOBALVARS \RCLKMILLISECOND \MY.NSHOSTNUMBER))
(while (IGREATERP (IDATE MAKESYSDATE)
(IDATE)) do (ERROR "Time is not set! Call"
"(SETTIME %"dd-mmm-yy hh:mm:ss%") and type RETURN"))
(* ;
"Compute *UID-SESSION* and DB.UIREC for today.")
(LET (date separator year month day monthCode startIndex nsHostNumber)
(SETQ nsHostNumber (OR (LISTP \MY.NSHOSTNUMBER)
(LIST 'NSHOSTNUMBER (DAYTIME)
0 0)))
(* ;; "Set up hostNumbe from \MY.NSHOSTNUMBER which should always be set in Interlisp-D -- else compute a random one which should not be used by any one")
(* ;; "Compensate for DATE post Y2K producing 4-digit year")
(SETQ date (DATE))
(SETQ separator (STRPOS " " date 2)) (* ; "may start with a space")
(SETQ year (IMOD (SUBATOM date 8 (SUB1 separator))
100))
(SETQ month (SUBATOM date 4 6))
(SETQ day (OR (NUMBERP (SUBATOM date 1 2))
(SUBATOM date 2 2)))
[SETQ startIndex (IDIFFERENCE (IDATE date)
(IDATE (CONCAT (SUBSTRING date 1 separator)
"00:00:00"] (* ;
"start index is seconds today. Wait a second to be sure no one can use this index again")
(forDuration 1 timerUnits 'SECONDS do NIL)
(SETQ monthCode (SELECTQ month
((Jan JAN)
'J)
((Feb FEB)
'F)
((Mar MAR)
'M)
((Apr APR)
'A)
((May MAY)
'Y)
((Jun JUN)
'U)
((Jul JUL)
'L)
((Aug AUG)
'G)
((Sep SEP)
'S)
((Oct OCT)
'O)
((Nov NOV)
'N)
((Dec DEC)
'D)
(ERROR month "IS NOT A MONTH")))
(* ;; "An unique ID consists of a front followed by a count. The front is set up any time one enters -- It is unique because it contains the machine ID, the date, time of day in seconds, and has waited a second. It then creates all of the UIDS in order from there.")
(SETQ *UID-COUNT* 0)
(SETQ *UID-SESSION* (PACK* monthCode (CHARACTER (IPLUS 64 day))
(CHARACTER year)
(RADIX64NUM (CADR nsHostNumber))
'%.
(RADIX64NUM (CADDR nsHostNumber))
'%.
(RADIX64NUM (CADDDR nsHostNumber))
'%.
(RADIX64NUM startIndex])
(RADIX64NUM
[LAMBDA (inputNum) (* smL "19-May-86 15:10")
(* * Computes a string which uses 64 printing characters to represent a number)
(PROG (rem (chars (CONS))
(num inputNum))
LP (SETQ rem (SELECTQ (SETQ rem (IPLUS 48 (LOGAND 63 num)))
(96 (* change non printing character to a
printing one)
122)
rem))
(TCONC chars (CHARACTER rem))
[COND
((EQ 0 (SETQ num (LRSH num 6)))
(RETURN (CONCATLIST (CAR chars]
(GO LP])
)
(* ;;; "Unpacking UIDs for human consumption")
(DEFINEQ
(Unpack-UID
[LAMBDA (uid) (* smL "19-May-86 16:24")
(* * Given a unique identifier, returns a list that unpacks and decodes the
bits.)
(LET ((sepr (CONSTANT (CHCON1 ".")))
month day year hostNumber1 hostNumber2 hostNumber3 hostNumber seconds)
(if (match (CHCON (CAR uid))
with
(month_ & day_ & year_ & hostNumber1_ $ =sepr hostNumber2_ $ =sepr hostNumber3_ $
=sepr seconds_ $))
then (LIST "LoginTime" (GDATE (PLUS (IDATE (CONCAT (PACK* (IDIFFERENCE day 64))
(SELECTQ (CHARACTER month)
(J '"-Jan-")
(F '"-Feb-")
(M '"-Mar-")
(A '"-Apr-")
(Y '"-May-")
(U '"-Jun-")
(L '"-Jul-")
(G '"-Aug-")
(S '"-Sep-")
(O '"-Oct-")
(N '"-Nov-")
(D '"-Dec-")
"-Jan-")
(PACK* year)
" 00:00:00"))
(ConvertFromRadix64 seconds)))
"NSHost"
(ConvertFromRadix64 hostNumber1)
(ConvertFromRadix64 hostNumber2)
(ConvertFromRadix64 hostNumber3)
"UIDNumber"
(CDR uid))
elseif (match (CHCON (CAR uid))
with
(month_ & day_ & year_ & hostNumber1_ $ =sepr hostNumber_ $ =sepr seconds_ $
))
then (* Old style UID with smashed
NSHOSTNUMBER)
(LIST "LoginTime" (GDATE (PLUS (IDATE (CONCAT (PACK* (IDIFFERENCE day 64))
(SELECTQ (CHARACTER month)
(J '"-Jan-")
(F '"-Feb-")
(M '"-Mar-")
(A '"-Apr-")
(Y '"-May-")
(U '"-Jun-")
(L '"-Jul-")
(G '"-Aug-")
(S '"-Sep-")
(O '"-Oct-")
(N '"-Nov-")
(D '"-Dec-")
"-Jan-")
(PACK* year)
" 00:00:00"))
(ConvertFromRadix64 seconds)))
"NSHost"
(ConvertFromRadix64 hostNumber1)
(ConvertFromRadix64 hostNumber)
"UIDNumber"
(CDR uid])
(ConvertFromRadix64
[LAMBDA (charCodes) (* smL "19-May-86 14:02")
(* * Return the number that generated the given Radix64 representation)
(for c in (REVERSE charCodes) bind (number _ 0)
do (change number (PLUS (LLSH DATUM 6)
(DIFFERENCE (SELECTQ c
(122 96)
c)
48))) finally (RETURN number])
)
(* ;;; "Access UID/instance relation")
(DEFINEQ
(GetObjFromUID
[LAMBDA (uid) (* smL "20-May-86 13:37")
(* * Given a UID string, return the object with that UID)
(COND
((UIDP uid)
(GETHASH uid *UID-Table*))
(T NIL])
(PutObjectUID
[LAMBDA (uid entry) (* smL "20-May-86 13:37")
(* * Puts a new uid for object in current uidTable)
(* By copying, we keep the reference count down -
This keeps us from overflowing the GC hash table so soon)
(PUTHASH (create UID using uid)
entry *UID-Table*])
(DeleteObjectUID
[LAMBDA (obj) (* ; "Edited 15-Aug-90 13:14 by jds")
(* * Deletes object UID and removes entry from uid table)
(LET ((uid (HasUID? obj)))
(COND
(uid (replace (OBJECT OBJUID) of obj with NIL)
(PUTHASH uid NIL *UID-Table*)
obj])
(MapObjectUID
[LAMBDA (fn) (* smL "20-May-86 13:37")
(* * Apply the fn to each known object and uid)
(MAPHASH *UID-Table* fn])
(UIDHashBits
[LAMBDA (uid) (* smL "20-May-86 11:05")
(* * The hash-bits function used in the UID hash array)
(LOGXOR (\HILOC (fetch (UID sessionID) of uid))
(\LOLOC (fetch (UID sessionID) of uid))
(fetch (UID uidNumber) of uid])
(UIDEqual
[LAMBDA (uid1 uid2) (* smL "19-May-86 16:59")
(* * Are the two UIDs equal?)
(AND (EQ (fetch (UID sessionID) of uid1)
(fetch (UID sessionID) of uid2))
(EQP (fetch (UID uidNumber) of uid1)
(fetch (UID uidNumber) of uid2])
)
(RPAQ? *UID-Table* (HASHARRAY 8000 NIL 'UIDHashBits 'UIDEqual))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *UID-Table*)
)
(ADDTOVAR GLOBALVARS *UID-Table*)
(* ;;; "Make sure that cache of front part of UID is invalidated whenever system is restarted.")
(DEFINEQ
(\Loops.AroundExit
[LAMBDA (EVENT) (* smL " 9-Apr-87 18:56")
(SELECTQ EVENT
((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM)
(InitializeUIDs))
((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM)
NIL)
((AFTERDOSYSOUT AFTERDOMAKESYS AFTERDOSAVEVM)
NIL)
NIL])
)
(ADDTOVAR AROUNDEXITFNS \Loops.AroundExit)
(PUTPROPS LOOPSUID COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 2022))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2399 3925 (HasUID? 2409 . 2732) (Make-UID 2734 . 3283) (UID 3285 . 3688) (UIDP 3690 .
3923)) (4360 9334 (InitializeUIDs 4370 . 8574) (RADIX64NUM 8576 . 9332)) (9390 14372 (Unpack-UID 9400
. 13801) (ConvertFromRadix64 13803 . 14370)) (14420 16509 (GetObjFromUID 14430 . 14711) (PutObjectUID
14713 . 15125) (DeleteObjectUID 15127 . 15514) (MapObjectUID 15516 . 15732) (UIDHashBits 15734 .
16109) (UIDEqual 16111 . 16507)) (16786 17200 (\Loops.AroundExit 16796 . 17198)))))
STOP