(FILECREATED " 8-JUL-83 00:22:12" {INDIGO}<LOOPS>SOURCES>LOOPSUID.;3 6348
changes to: (FNS DB-InitUI DB-PackUI DB-UnpackUI)
(VARS UIFNS)
previous date: "22-JUN-83 11:26:07" {INDIGO}<LOOPS>SOURCES>LOOPSUID.;2)
(PRETTYCOMPRINT LOOPSUIDCOMS)
(RPAQQ LOOPSUIDCOMS ((* Copyright (c)
1983 by Xerox Corporation)
(* Creates unique identifiers for instances)
(RECORDS UIREC)
(VARS * UIVARS)
(FNS * UIFNS)
(P (DB-InitUI))))
(* Copyright (c) 1983 by Xerox Corporation)
(* Creates unique identifiers for instances)
[DECLARE: EVAL@COMPILE
(RECORD UIREC (NetNumber HostNumber PartitionNumber Day Month Year UICount))
]
(RPAQQ UIVARS ((DB.PRINTDESTINATION PROMPTWINDOW)
[DB.UIFILENAME (COND ((FMEMB (SYSTEMTYPE)
(QUOTE (ALTO D)))
(QUOTE {DSK}Lore-UI.SAVE))
(T (QUOTE Lore-UI.SAVE]
(DB.UIREC NIL)
(DB.FRONTUI NIL)
(DB.UICOUNT 0)
(DB.UIDUMPINCR 1000)
(DB.NEXTUIDUMP NIL)
(DB.ENVIRONMENT NIL)
(UIDPRINTFLG)
(NETNUMBER 0)))
(RPAQ DB.PRINTDESTINATION PROMPTWINDOW)
(RPAQ DB.UIFILENAME (COND ((FMEMB (SYSTEMTYPE)
(QUOTE (ALTO D)))
(QUOTE {DSK}Lore-UI.SAVE))
(T (QUOTE Lore-UI.SAVE))))
(RPAQQ DB.UIREC NIL)
(RPAQQ DB.FRONTUI NIL)
(RPAQQ DB.UICOUNT 0)
(RPAQQ DB.UIDUMPINCR 1000)
(RPAQQ DB.NEXTUIDUMP NIL)
(RPAQQ DB.ENVIRONMENT NIL)
(RPAQQ UIDPRINTFLG NIL)
(RPAQQ NETNUMBER 0)
(RPAQQ UIFNS (DB-InitUI DB-PackUI DB-UnpackUI UID))
(DEFINEQ
(DB-InitUI
[LAMBDA NIL (* dgb: " 7-JUL-83 23:47")
(* DECLARATIONS: INTEGER)
(* Initializes the UniqueIdentifer Generation System in
DB. Sets the global variables DB.FRONTUI and and
DB.UICOUNT)
(PROG (date year month day monthCode dateCode startIndex temp nsHostNumber)
(* Compute DB.FRONTUI and DB.UIREC for today.)
(AND [NLISTP (SETQ nsHostNumber (EVALV (QUOTE \MY.NSHOSTNUMBER]
(SETQ nsHostNumber (LIST (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)
(SETQ date (DATE)) (* Compute dateCode which encodes the date in 16 bits.)
(SETQ year (SUBATOM date 8 9))
(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 10)
"00:00:00"]
(* start index is seconds today.
Wait a second to be sure no one can use this index
again)
(WAITMS 1000)
(SETQ monthCode (SELECTQ month
(JAN (QUOTE J))
(FEB (QUOTE F))
(MAR (QUOTE M))
(APR (QUOTE A))
(MAY (QUOTE Y))
(JUN (QUOTE U))
(JUL (QUOTE L))
(AUG (QUOTE G))
(SEP (QUOTE S))
(OCT (QUOTE O))
(NOV (QUOTE N))
(DEC (QUOTE 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 DB.UICOUNT 0)
(RETURN (SETQ DB.FRONTUI (CONCAT monthCode (CHARACTER (IPLUS 64 day))
(CHARACTER year)
(QUOTE %.)
(CADR nsHostNumber)
(QUOTE %.)
(CADDR nsHostNumber)
(QUOTE %.)
(CADDDR nsHostNumber)
(QUOTE %.)
startIndex
(QUOTE %.])
(DB-PackUI
[LAMBDA NIL (* dgb: " 7-JUL-83 23:54")
(* Creates and returns a unique identifier.)
(PACK* DB.FRONTUI (SETQ DB.UICOUNT (ADD1 DB.UICOUNT])
(DB-UnpackUI
[LAMBDA (UI) (* dgb: " 7-JUL-83 23:57")
(* DECLARATIONS: INTEGER)
(* Given a unique identifier, returns a UIREC record
that unpacks and decodes the bits.)
(PROG (netNumber hostNumber partiton day month year uiCount charCodes dateCode)
(SETQ charCodes (CHCON UI)) (* Decode the ethernet number and host number.)
(SETQ dateCode (IPLUS (CADDR charCodes)
(LSH (CADDDR charCodes)
8)))
(SETQ year (CAR (NTH charCodes 3)))
(SETQ day (IDIFFERENCE (CAR (NTH charCodes 2))
64))
(SETQ month (SELECTQ (CHARACTER (CAR charCodes))
(J (QUOTE JAN))
(F (QUOTE FEB))
(M (QUOTE MAR))
(A (QUOTE APR))
(Y (QUOTE MAY))
(U (QUOTE JUN))
(L (QUOTE JUL))
(G (QUOTE AUG))
(S (QUOTE SEP))
(O (QUOTE OCT))
(N (QUOTE NOV))
(D (QUOTE DEC))
(ERROR month "IS NOT A MONTH")))
(RETURN (LIST "Created" day month year])
(UID
[LAMBDA (OBJ nameFlg) (* dgb: "19-JAN-83 12:24")
(* * creates the form of UID that is to be stored on a file. Currently we have atom as UID in entityRecord, so
must convert it to string for printout on file. If nameFlg is T returns the atom)
(PROG (entity uid)
LP [SETQ uid (COND
((type? Entity OBJ)
(fetch UID of OBJ))
[(OR (type? instance OBJ)
(type? class OBJ))
(OR (fetch OBJUID of OBJ)
(AND (NewEntity OBJ)
(fetch OBJUID of OBJ]
(T (ERROR OBJ "cannot have UID"]
(RETURN (COND
(nameFlg uid)
(T (MKSTRING uid])
)
(DB-InitUI)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1575 6314 (DB-InitUI 1585 . 4096) (DB-PackUI 4098 . 4372) (DB-UnpackUI 4374 . 5611) (
UID 5613 . 6312)))))
STOP