mirror of
https://github.com/PDP-10/its.git
synced 2026-01-19 17:39:17 +00:00
136 lines
4.1 KiB
Common Lisp
136 lines
4.1 KiB
Common Lisp
;;; -*- LISP -*-
|
|
;;;
|
|
;;; Functions defined
|
|
;;;
|
|
;;; (OPEN-INQUIR-FILE)
|
|
;;; Must be done before these other things can happen
|
|
;;;
|
|
;;; (LOOKUP-INQUIR-INFO <evaluable-uname> <un-eval'd tag>)
|
|
;;; Macro to look up a certain tag in the INQUIR database
|
|
;;;
|
|
;;; (GET-USER-NAME <evaluable-uname>)
|
|
;;;
|
|
;;; SUBR returns something of the form
|
|
;;; ((last-name first-name middle-name) title lineage alias? nickname)
|
|
;;; or NIL if no such user.
|
|
;;;
|
|
;;; TITLE is one a word like [MR, MRS, ... DR, ...] (see code
|
|
;;; for currently used list)
|
|
;;;
|
|
;;; LINEAGE is one of II, III, or JR
|
|
;;;
|
|
;;; NIL is returned for unspecified elements. Alias's are tried to be
|
|
;;; traced through. If something was an alias, the ALIAS? flag is non-NIL
|
|
;;; all other info is as if it had been info about who it is an alias for.
|
|
;;; Multiple aliases should be traced through correctly.
|
|
;;;
|
|
;;; (CLOSE-INQUIR-FILE)
|
|
;;; Should be done after all LOOKUP-INQUIR-INFO's are done to
|
|
;;; close our INQUIR disk channel.
|
|
;;;
|
|
|
|
(DEFPROP LSRMAP ((DSK inquir) LSRRTN FASL) AUTOLOAD)
|
|
|
|
(DECLARE (SPECIAL *INQUIR-FILE-OBJECT*)
|
|
(*EXPR LSRMAP LSRITM LSRUNM))
|
|
|
|
(DEFUN OPEN-INQUIR-FILE () ; Allocate 15 pages for this map
|
|
(SETQ *INQUIR-FILE-OBJECT* (LSRMAP 15.))
|
|
T)
|
|
|
|
(DEFUN CLOSE-INQUIR-FILE ()
|
|
(CLOSE *INQUIR-FILE-OBJECT*)
|
|
T)
|
|
|
|
(DEFUN LOOKUP-INQUIR-INFO MACRO (FORM)
|
|
(LET (((UNAME DATA) (CDR FORM)))
|
|
`(LSRITM ',(OR (CDR (ASSQ DATA '((UNAME . 0.)
|
|
(FULL-NAME . 1.)
|
|
(NICKNAME . 2.)
|
|
(SOCIAL-SECURITY-NUMBER . 3.)
|
|
(MIT-ADDRESS . 4.)
|
|
(MIT-TELEPHONE-NUMBER . 5.)
|
|
(HOME-ADDRESS . 6.)
|
|
(HOME-TELEPHONE-NUMBER . 7.)
|
|
(SUPERVISOR . 8.)
|
|
(PROJECT . 9.)
|
|
(FILE-DIRECTORY-NAMES . 10.)
|
|
(AUTHORIZATION . 11.)
|
|
(GROUP-AFFILIATION . 12.)
|
|
(RELATION TO GROUP . 13.)
|
|
(BIRTHDAY . 14.)
|
|
(REMARKS . 15.)
|
|
(NETWORK-ADDRESS . 16.)
|
|
(LAST-ALTERATION . 17.)
|
|
(MACHINES-KNOWN-ON . 18.))))
|
|
(ERROR '|Unknown INQUIR Keyword| DATA))
|
|
(LSRUNM *INQUIR-FILE-OBJECT* ,UNAME))))
|
|
|
|
(DEFUN UNAME? (X) (AND (SYMBOLP X)
|
|
(PLUSP (LSRUNM *INQUIR-FILE-OBJECT* X))))
|
|
|
|
(DECLARE (*EXPR PARSE$MAKE-WORDS))
|
|
|
|
(DEFPROP PARSE$MAKE-WORDS ((games) PARSE FASL) AUTOLOAD)
|
|
|
|
(DEFUN GET-USER-NAME (WHO)
|
|
(COND ((NOT (UNAME? WHO)) NIL)
|
|
(T
|
|
(LET* ((DATA (LOOKUP-INQUIR-INFO WHO FULL-NAME))
|
|
(TOKENS (PARSE$MAKE-WORDS (EXPLODEC DATA)))
|
|
(LAST-NAME) (FIRST-NAME) (MIDDLE) (TITLE-ETC) (LINEAGE)
|
|
(ALIAS ()))
|
|
(DO ()
|
|
((NOT
|
|
(AND (EQ (CADR TOKENS) '/,)
|
|
(EQ (CAR (LAST TOKENS)) 'FOR)
|
|
(MEMQ (LOOKUP-INQUIR-INFO WHO GROUP-AFFILIATION)
|
|
'(/@ /O)))))
|
|
(SETQ ALIAS T)
|
|
(SETQ WHO (CAR TOKENS))
|
|
(SETQ TOKENS
|
|
(PARSE$MAKE-WORDS
|
|
(EXPLODEC
|
|
(SETQ DATA
|
|
(LOOKUP-INQUIR-INFO WHO FULL-NAME))))))
|
|
(SETQ TOKENS (DELETE '/. TOKENS))
|
|
(COND ((SETQ TITLE-ETC (CAR (OR (MEMQ 'MR TOKENS)
|
|
(MEMQ 'MRS TOKENS)
|
|
(MEMQ 'MISS TOKENS)
|
|
(MEMQ 'MS TOKENS)
|
|
(MEMQ 'DR TOKENS))))
|
|
(SETQ TOKENS (DELETE TITLE-ETC TOKENS))))
|
|
(COND ((SETQ LINEAGE (CAR (OR (MEMQ 'II TOKENS)
|
|
(MEMQ 'III TOKENS)
|
|
(MEMQ 'JR TOKENS))))
|
|
(SETQ TOKENS (DELETE LINEAGE TOKENS))))
|
|
(COND ((NOT (MEMQ '/, TOKENS)) ; What a loser...
|
|
(POP TOKENS FIRST-NAME)
|
|
(COND ((CDR TOKENS)
|
|
(POP TOKENS MIDDLE)
|
|
(POP TOKENS LAST-NAME))
|
|
(T
|
|
(POP TOKENS LAST-NAME))))
|
|
((EQ (CADR TOKENS) '/,)
|
|
(SETQ TOKENS (DELETE '/, TOKENS))
|
|
(POP TOKENS LAST-NAME)
|
|
(POP TOKENS FIRST-NAME)
|
|
(POP TOKENS MIDDLE))
|
|
(T
|
|
(SETQ FIRST-NAME (CADR (MEMQ '/, TOKENS)))
|
|
(SETQ LAST-NAME (DO ((L () (CONS (CAR TOKS) L))
|
|
(TOKS TOKENS (CDR TOKS)))
|
|
((EQ (CAR TOKS) '/,)
|
|
(IMPLODE
|
|
(MAPCAN 'EXPLODEC
|
|
(NREVERSE L))))))))
|
|
`( (,LAST-NAME
|
|
,FIRST-NAME
|
|
,@(COND (MIDDLE (NCONS MIDDLE))))
|
|
,TITLE-ETC
|
|
,LINEAGE
|
|
,ALIAS
|
|
,(LET ((NICKNAME (LOOKUP-INQUIR-INFO WHO NICKNAME)))
|
|
(COND ((EQ NICKNAME '||) NIL)
|
|
(T NICKNAME))))))))
|