(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "22-Feb-2021 15:32:34" {DSK}<home>larry>medley>sources>ADIR.;11
 61717  

      changes to%:  (FNS INTERPRET.REM.CM)

      previous date%: "21-Feb-2021 21:49:20" {DSK}<home>larry>medley>sources>ADIR.;10)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT ADIRCOMS)

(RPAQQ ADIRCOMS

       [[COMS                                                (* ; "user-level i/o routines")

              (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP 
                   RENAMEFILE SIMPLE.FINDFILE)
              (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
              (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P 

                                       (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")


                                                 (MOVD? 'NILL 'CL:PATHNAMEP]
        (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP 
                   FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING)
              (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY 
                                         PACKFILENAME.ASSEMBLE UNPACKFILE1))
              (VARS \FILENAME.SYNTAX)
              (GLOBALVARS \FILENAME.SYNTAX))
        (COMS                                                (* ; 

                                                           "saving and restoring system state")

              (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT)
              (ADDVARS (AROUNDEXITFNS))
              (INITVARS (HERALDSTRING "")
                     (\USERNAME))
              (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
              (FNS USERNAME SETUSERNAME))
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                                FILEIO))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                  PACKFILENAME.STRING
                                                                                   PACKFILENAME])



(* ; "user-level i/o routines")


(DEFINEQ

(DELFILE

  [LAMBDA (FILE)
                                         (* bvm%: "23-Oct-85 11:20")

    (AND FILE (NEQ FILE T)
         (\DELETEFILE FILE])

(FULLNAME

  [LAMBDA (X RECOG)
                                      (* rmk%: "22-AUG-83 13:33")

    (COND
       ((type?
 STREAM X)
        (fetch
 (STREAM FULLNAME) of
 X))
       (T (SELECTQ RECOG
              (NIL (SETQQ RECOG OLD))
              ((OLD OLD/NEW NEW OLDEST))
              (\ILLEGAL.ARG RECOG))
          (\GETFILENAME X RECOG])

(INFILE

  [LAMBDA (FILE)
                                         (* rmk%: " 3-OCT-79 14:23")

    (INPUT (OPENFILE
 FILE 'INPUT 'OLD])

(INFILEP

  [LAMBDA (FILE)
                                         (* rmk%: " 9-OCT-79 22:39")

    (\GETFILENAME FILE 'OLD])

(IOFILE

  [LAMBDA (FILE)
                                         (* rmk%: " 5-SEP-81 13:54")

    (OPENFILE
 FILE 'BOTH 'OLD])

(OPENFILE

  [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL)
        (* ; "Edited 23-May-91 19:12 by jds")

    (if
 MULTIPLE.STREAMS.PER.FILE.ALLOWED
        then
 (OPENSTREAM
 FILE ACCESS RECOG PARAMETERS OPTIONAL)
      else
 (fetch
 (STREAM FULLNAME) of
 (OPENSTREAM
 FILE ACCESS RECOG PARAMETERS 
                                                          OPTIONAL])

(OPENSTREAM

  [LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE)
        (* hdj "28-Aug-86 14:50")

    (PROG (REC OLDSTREAM STREAM)
          (SELECTQ ACCESS
              ((INPUT OUTPUT BOTH APPEND))
              (\ILLEGAL.ARG ACCESS))
          (SETQ REC (SELECTQ RECOG
                        ((EXACT NEW OLD OLD/NEW OLDEST) 
                             RECOG)
                        (NIL (SELECTQ ACCESS
                                 (INPUT 'OLD)
                                 (OUTPUT 'NEW)
                                 'OLD/NEW))
                        (\ILLEGAL.ARG RECOG)))
          (if
 (OR (LISTP OBSOLETE)
                      (AND PARAMETERS (NLISTP PARAMETERS)))
              then
 

                    (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS.  Now it will take PARAMETERS, and generally ignore the BYTESIZE")


                    (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS
                                                 (7 '((TYPE TEXT)))
                                                 (8 '((TYPE BINARY)))
                                                 NIL)
                                            OBSOLETE)))
          (COND
             ((OR (EQ FILE T)
                  (NULL FILE))

              (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.")


              (SETQ STREAM (\GETSTREAM FILE ACCESS))
              (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS)
              (RETURN STREAM)))

     (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything")


     (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.")


     (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.")


          (if
 (TYPEP FILE 'PATHNAME)
              then
 (SETQ FILE (\CONVERT-PATHNAME FILE)))

     (* ;; "We open the file before looking to see whether it is already open.  This guarantees that we acquire the opening rights at the time we lookup the name.  We then check to see if it is currently open in Lisp.  If it is, we return the previous stream, which has the file's current state.  ")


     (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES.  Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.")


          (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS))
          (COND
             [[AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
                   (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch
 FULLNAME of
 STREAM]

              (* ;; "There is already a stream open on the file.  Check that there is no conflict.  Eventually all this registration belongs in the device, so that we can have multiple streams open per file")


              (COND
                 ((AND (EQ ACCESS 'INPUT)
                       (EQ (fetch
 ACCESS of
 OLDSTREAM)
                           'INPUT))                          (* ; 

    "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares")

                  (OR (EQ STREAM OLDSTREAM)
                      (\CLOSEFILE STREAM))
                  (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS)
                                                             (* ; "Do parameters on the old stream")

                  (RETURN OLDSTREAM))
                 (T (LISPERROR "FILE WON'T OPEN" FILE]
             (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
                     (\ADDOFD STREAM))                       (* ; 

                                                       "Parameters done on new stream by \OPENFILE")

                (RETURN STREAM])

(OUTFILE

  [LAMBDA (FILE)
                                         (* rmk%: " 3-OCT-79 14:24")

    (OUTPUT (OPENFILE
 FILE 'OUTPUT 'NEW])

(OUTFILEP

  [LAMBDA (FILE)
                                         (* rmk%: " 9-OCT-79 22:39")

    (\GETFILENAME FILE 'NEW])

(RENAMEFILE

  [LAMBDA (OLDFILE NEWFILE)
                              (* hdj " 4-Sep-86 16:56")

    (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE))
    (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE))
    (AND OLDFILE NEWFILE (NEQ OLDFILE T)
         (NEQ NEWFILE T)
         (\RENAMEFILE OLDFILE NEWFILE])

(SIMPLE.FINDFILE

  [LAMBDA (FILE DUMMY DIRLST)
                            (* bvm%: "23-Oct-85 11:22")

    (OR (for
 DIR in
 DIRLST when
 (SETQ $$VAL (INFILEP
 (PACKFILENAME.STRING

                                                                      'DIRECTORY DIR 'BODY FILE)))
           do
 (RETURN $$VAL))
        (AND (NOT (MEMB NIL DIRLST))
             (INFILEP
 FILE])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED
 T)


(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
)

(MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)
(DECLARE%: DONTEVAL@LOAD DOCOPY 


(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")



(MOVD? 'NILL 'CL:PATHNAMEP)
)
(DEFINEQ

(UNPACKFILENAME

  [LAMBDA (FILE ONEFIELDFLG OSTYPE)
                      (* ; "Edited  6-Jan-88 13:13 by bvm:")

    (UNPACKFILENAME.STRING
 FILE ONEFIELDFLG NIL OSTYPE T])

(UNPACKFILENAME.STRING

  [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG)
 (* ; "Edited 30-Mar-90 22:37 by nm")


(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")


    (PROG ((POS 1)
           (LEN (NCHARS FILE))
           TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
          (COND
             ((NULL FILE)
              (RETURN NIL))
             ((OR (LITATOM FILE)
                  (STRINGP FILE)
                  (NUMBERP FILE)))
             ((TYPEP FILE 'PATHNAME)
              (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
             [(STREAMP FILE)                                 (* ; 

                                               "For streams, use full name.  If anonymous, fake it")

              (SETQ FILE (OR (ffetch
 FULLFILENAME of
 FILE)
                             (RETURN (COND
                                        (ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
                                                          FILE))
                                        (T (LIST 'NAME FILE]
             (T (\ILLEGAL.ARG FILE)))
          (COND
             ((SELCHARQ (NTHCHARCODE FILE 1)
                   ({                                        (* ; "normal use in Interlisp-D")

                      (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS
 (CHARCODE })
                                                 FILE 2)
                                          0))))
                   (%[                                       (* ; 

                                                  "some Xerox and Arpanet systems use '[' for host")

                       (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS
 (CHARCODE "]")
                                                  FILE 2)
                                           0))))
                   (%(                                       (* ; 

                                                "this is the 'proposed standard' for Xerox servers")

                       (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS
 (CHARCODE ")")
                                                  FILE 2)
                                           0))))
                   NIL)
              (UNPACKFILE1 'HOST 2 TEM)
              [COND
                 ((EQ TEM -1)                                (* ; 

    "Started with the host field delimiter, but there was no corresponding terminating delimiter .")

                                                             (* ; 

                                           "I'm not sure why the name is dealt with the host name.")

                  (RETURN (DREVERSE VAL]
              (SETQ POS (IPLUS TEM 2))
              [if
 (EQ OSTYPE T)
                  then
                                   (* ; 

                                                           "Use actual host to determine os type")

                        (SETQ OSTYPE (GETHOSTINFO (CAR VAL)
                                            'OSTYPE]
              (SETQ HOSTP T)))
          (COND
             ((SETQ TEM (LASTCHPOS
 (CHARCODE %:)
                               FILE POS))                    (* ; 

                                 "all device returned have DEVICE.END on it so that NIL: will work")

              (UNPACKFILE1 'DEVICE POS (if
 CLFLG
                                           then
 (SUB1 TEM)
                                         else
 TEM))
              (SETQ POS (ADD1 TEM))
              (SETQ HOSTP T)))
          (COND
             ((EQ DIRFLG 'RETURN)                            (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter.  If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention.  In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")

              (LET ((TYPE 'DIRECTORY)
                    (START (SELCHARQ (NTHCHARCODE FILE POS)
                                (NIL                         (* ; "just host, return")

                                     (RETURN (DREVERSE VAL)))
                                ((/ <)                       (* ; 

                                                    "Started with the initial directory delimiter.")

                                     (ADD1 POS))
                                POS))
                    END)
                   (SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
                                  ((/ >) 
                                       [COND
                                          ((EQ START POS)    (* ; 

                                                         "Didn't start with a directory delimiter,")

                                           (COND
                                              ((NOT HOSTP)   (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory")

                                               (SETQ TYPE 'SUBDIRECTORY))
                                              (T             (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.")

                                                 (SETQ TYPE 'RELATIVEDIRECTORY]
                                       (COND
                                          ((EQ LEN POS)      (* ; 

                                       "Only the initial directory is specified (i.e. %"{DSK}/%").")

                                           (SETQ START POS)
                                           -1)
                                          (T -2)))
                                  (PROGN [COND
                                            [(EQ START POS)  (* ; 

                                            "Both of the initial and trail delimiters are omitted.")

                                             (COND
                                                ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory")

                                                 (SETQ TYPE 'SUBDIRECTORY))
                                                (T           (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.")

                                                   (SETQ TYPE 'RELATIVEDIRECTORY]
                                            (T (COND
                                                  ((EQ LEN POS)
                                                             (* ; 

                                       "Only the initial directory is specified (i.e. %"{DSK}<%").")

                                                   (SETQ START POS]
                                         -1)))
                   (UNPACKFILE1.DIRECTORY TYPE START END))
              (RETURN (DREVERSE VAL)))
             ((SELCHARQ (NTHCHARCODE FILE POS)
                   (/                                        (* ; 

                                                "unix and the 'xerox standard' use / for delimiter")

                                                             (* ; 

                       "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")

                      (SETQ TEM (LASTCHPOS
 (CHARCODE (/ >))
                                       FILE
                                       (ADD1 POS)))
                      T)
                   ((< >)                                    (* ; 

             "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>.  Jericho uses >>")

                                                             (* ; 

                       "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")

                        (SETQ TEM (LASTCHPOS
 (CHARCODE (> /))
                                         FILE
                                         (ADD1 POS)))
                        T)
                   NIL)

              (* ;; "allow {DSK}/etc   to be a directory specification.")


              (if
 TEM
                  then
 (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
                                  (SUB1 TEM))
                        (SETQ POS (ADD1 TEM))
                else
 

                      (* ;; "{DSK}/foo: the directory is /, the name is foo")


                      (UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
                      (SETQ POS (ADD1 POS)))
              (SETQ HOSTP T))
             ((SETQ TEM (LASTCHPOS
 (CHARCODE (/ >))
                               FILE POS))                    (* ; " {eris}abc>  relative")


              (* ;; 

        " This is the true %"relative pathname%".  Returns RELATIVEDIRECTORY instead of DIRECTORY.")


              [COND
                 ((NOT HOSTP)                                (* ; "%"Incomplete file names%" case.")

                  (UNPACKFILE1.DIRECTORY (if
 (EQ DIRFLG 'FIELD)
                                             then
 'DIRECTORY
                                           else
 'SUBDIRECTORY)
                         POS
                         (SUB1 TEM)))
                 (T                                          (* ; "True %"relative pathname%".")

                    (UNPACKFILE1.DIRECTORY (if
 (EQ DIRFLG 'FIELD)
                                               then
 'DIRECTORY
                                             else
 'RELATIVEDIRECTORY)
                           POS
                           (SUB1 TEM]
              (SETQ POS (ADD1 TEM))
              (SETQ HOSTP T)))
          (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
              (RETURN (DREVERSE VAL)))
          (if
 (EQ OSTYPE T)
              then
                                       (* ; 

                                        "There wasn't a host field in the name, so we have no clue")

                    (SETQ OSTYPE NIL))
      NAMELP
          

     (* ;; "At this point, CODE is the TEM'th char of file name.  POS is the first character of the field we are currently working on.")


          (SELCHARQ CODE
               (%.                                           (* ; 

                          "Note position for later--we only want to deal with the last set of dots")

                   (if
 BEYONDNAME
                       then
                              (* ; 

                                                 "no longer of interest (probably a bad name, too)")

                     elseif
 FIRSTDOT
                       then
                              (* ; "We're recording the second dot")

                             (if
 SECONDDOT
                                 then
                    (* ; 

                                                           "Note only the two most recent dots")

                                       (SETQ FIRSTDOT SECONDDOT))
                             (SETQ SECONDDOT TEM)
                     else
 (SETQ FIRSTDOT TEM)))
               ((! ; NIL)                                    (* ; 

                             "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")

                    (if
 (SELCHARQ CODE
                                 (!                          (* ; 

               "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")

                                    (AND OSTYPE (NEQ OSTYPE 'IFS)))
                                 (;                          (* ; "If we've already parsed the extension, then we have a semi in the middle of the version.  Skip it unless it's ;T or ;S")

                                    [AND BEYONDEXT (NOT (\UPF.TEMPFILEP
 FILE (ADD1 TEM])
                                 NIL)
                        then
 (GO NEXTCHAR))
                    (if
 FIRSTDOT
                        then
                             (* ; 

                                                        "Have a name and/or extension to parse now")

                        (if

                         [AND SECONDDOT
                              (NOT (if
 OSTYPE
                                       then
              (* ; 

                                      "Known OS type must be Tops20 for second dot to mean version")

                                             (EQ OSTYPE 'TOPS20)
                                     else
                (* ; 

                                "Unknown OS type, so check that %"version%" is numeric or wildcard")

                                           (AND [for
 I from
 (ADD1 SECONDDOT)
                                                   to
 (SUB1 TEM) bind
 CH
                                                   always
 (OR (DIGITCHARP (SETQ CH
                                                                               (NTHCHARCODE FILE I)))
                                                                  (EQ CH (CHARCODE *
]
                                                (SELCHARQ CODE
                                                     (NIL    (* ; "end of file name, ok")

                                                          T)
                                                     (;      (* ; 

                                              "This semi-colon better not be introducing a version")

                                                        (\UPF.TEMPFILEP
 FILE (ADD1 TEM)))
                                                     NIL]
                            then
                         (* ; 

                                                           "Second dot is not intoducing a version")

                                  (SETQ FIRSTDOT SECONDDOT)
                                  (SETQ SECONDDOT NIL))
                        (UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
                        (SETQ POS (ADD1 (if
 SECONDDOT
                                            then
 (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
                                                            (SUB1 SECONDDOT))
                                                  (SETQ BEYONDEXT T)
                                                  SECONDDOT
                                          else
 FIRSTDOT)))
                        (SETQ BEYONDNAME T)
                        (SETQ FIRSTDOT NIL))
                    (UNPACKFILE1 (COND
                                    ((NOT BEYONDNAME)
                                     (SETQQ BEYONDNAME NAME))
                                    ((NOT BEYONDEXT)
                                     'EXTENSION)
                                    ((AND (EQ BEYONDEXT (CHARCODE ";"))
                                          (\UPF.TEMPFILEP
 FILE POS)))
                                    (T                       (* ; 

                                                           "Everything after the semi was version")

                                       'VERSION))
                           POS
                           (SUB1 TEM))
                    (if
 (NULL CODE)
                        then
                             (* ; "End of string")

                              (RETURN (DREVERSE VAL)))
                    (SETQ BEYONDEXT CODE)                    (* ; 

                                                  "Note the character that terminated the name/ext")

                    (SETQ POS (ADD1 TEM)))
               (%'                                           (* ; "Quoter")

                   (add
 TEM 1))
               NIL)
      NEXTCHAR
          (SETQ CODE (NTHCHARCODE FILE (add
 TEM 1)))
          (GO NAMELP])

(LASTCHPOS

  [LAMBDA (CH STR START)
                              (* ; "Edited 17-May-88 13:43 by MASINTER")

    (PROG (RESULT NC)
          (OR START (SETQ START 1))
          (while
 (SETQ NC (NTHCHARCODE STR START)) do
 (COND
                                                                 ((EQMEMB NC CH)
                                                                  (SETQ RESULT START))
                                                                 ((EQ NC (CHARCODE %'))
                                                                  (add
 START 1)))
                                                             (add
 START 1))
          (RETURN RESULT])

(\UPF.NEXTPOS

  [LAMBDA (CHAR STRING POS)
                              (* lmm " 5-Oct-84 18:41")

    (bind
 NCH while
 (SETQ NCH (NTHCHARCODE STRING POS)) do
 (COND
                                                                          ((EQMEMB NCH CHAR)
                                                                           (RETURN POS))
                                                                          ((EQ NCH (CHARCODE %'))
                                                                           (add
 POS 1)))
                                                                      (add
 POS 1])

(\UPF.TEMPFILEP

  [LAMBDA (FILENAME START)
                               (* ; "Edited  6-Jan-88 13:12 by bvm:")


    (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START.  Returns the appropriate field name if so.  Not sure we should parse this junk any more, but this at least localizes it.")


    (SELCHARQ (NTHCHARCODE FILENAME START)
         ((T S)                                              (* ; "Funny temp stuff")

              (AND (EQ START (NCHARS FILENAME))
                   'TEMPORARY))
         NIL])

(FILENAMEFIELD

  [LAMBDA (FILE FIELDNAME)
                               (* ; "Edited  6-Mar-90 19:38 by nm")

    (UNPACKFILENAME.STRING
 FILE (SELECTQ FIELDNAME
                                        ((VERSION GENERATION) 
                                             'VERSION)
                                        ((DEVICE STRUCTURE) 
                                             'DEVICE)
                                        FIELDNAME)
           'FIELD NIL T])

(PACKFILENAME

  [LAMBDA N
                                              (* bvm%: " 5-Jul-85 15:40")

    (COND
       ((AND (EQ N 1)
             (LISTP (ARG N 1)))                              (* ; "spread argument list")

        (APPLY (FUNCTION PACKFILENAME)
               (ARG N 1)))
       (T (PACK (PACKFILENAME.ASSEMBLE])

(PACKFILENAME.STRING

  [LAMBDA N
                                              (* bvm%: " 5-Jul-85 15:41")

    (COND
       ((AND (EQ N 1)
             (LISTP (ARG N 1)))                              (* ; "spread argument list")

        (APPLY (FUNCTION PACKFILENAME.STRING)
               (ARG N 1)))
       (T (CONCATLIST (PACKFILENAME.ASSEMBLE])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS CANONICAL.DIRECTORY
 MACRO

          [OPENLAMBDA (SRCSTRING)
            (AND
             SRCSTRING
             (LET
              ((LEN (NCHARS SRCSTRING)))
              (COND
                 ((EQ LEN 1)
                  (if
 (STREQUAL SRCSTRING "/")
                      then
 "<"
                    else
 SRCSTRING))
                 (T
                  (LET*
                   ((FATP (ffetch
 (STRINGP FATSTRINGP) of
 SRCSTRING))
                    (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
                    (DSTBASE (ffetch
 (STRINGP BASE) of
 DSTSTRING))
                    (DSTPOS 0)
                    (NEXTPOS -1))
                   (if
 (NOT FATP)
                       then

                       [for
 SRCPOS from
 1 to
 LEN bind
 CODE
                          first
 (while
 (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                      (CHARCODE (< / >)))
                                       do
 (add
 SRCPOS 1))
                                (if
 (> SRCPOS LEN)
                                    then
 (RETURN "<"))
                          do
 (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                      ((> /) 
                                           (if
 (> DSTPOS NEXTPOS)
                                               then
 (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
                                                     (SETQ NEXTPOS (add
 DSTPOS 1))))
                                      (%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                          (add
 DSTPOS 1)
                                          (if
 (NEQ SRCPOS LEN)
                                              then
 (\PUTBASETHIN DSTBASE DSTPOS
                                                              (NTHCHARCODE SRCSTRING (add
 SRCPOS
                                                                                            1)))
                                                    (add
 DSTPOS 1)))
                                      (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                             (add
 DSTPOS 1)))
                          finally
 (RETURN (if
 (EQ DSTPOS LEN)
                                                  then
 (if
 (EQMEMB (NTHCHARCODE DSTSTRING -1)
                                                                          (CHARCODE (> /)))
                                                               then
 (SUBSTRING DSTSTRING 1 -2)
                                                             else
 DSTSTRING)
                                                elseif
 (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                                  (CHARCODE (> /)))
                                                  then
 (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                                else
 (SUBSTRING DSTSTRING 1 DSTPOS]
                     else

                     (for
 SRCPOS from
 1 to
 LEN bind
 CODE
                        first
 (while
 (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                    (CHARCODE (< / >))) do
 (add
 SRCPOS 1))
                        do
 (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                    ((> /) 
                                         (if
 (> DSTPOS NEXTPOS)
                                             then
 (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
                                                   (SETQ NEXTPOS (add
 DSTPOS 1))))
                                    (%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                        (add
 DSTPOS 1)
                                        (if
 (NEQ SRCPOS LEN)
                                            then
 (\PUTBASEFAT DSTBASE DSTPOS
                                                            (NTHCHARCODE SRCSTRING (add
 SRCPOS 1)
                                                                   ))
                                                  (add
 DSTPOS 1)))
                                    (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                           (add
 DSTPOS 1)))
                        finally
 (RETURN (if
 (EQ DSTPOS LEN)
                                                then
 (if
 (EQMEMB (NTHCHARCODE DSTSTRING -1)
                                                                        (CHARCODE (> /)))
                                                             then
 (SUBSTRING DSTSTRING 1 -2)
                                                           else
 DSTSTRING)
                                              elseif
 (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                                (CHARCODE (> /)))
                                                then
 (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                              else
 (SUBSTRING DSTSTRING 1 DSTPOS])

(PUTPROPS UNPACKFILE1.DIRECTORY
 MACRO
 [OPENLAMBDA (NAM ST END)
                                                (LET* ((OLDDIR (SUBSTRING FILE ST END))
                                                       (NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
                                                      (COND
                                                         [(NOT ONEFIELDFLG)
                                                          (SETQ VAL
                                                           (CONS (COND
                                                                    (PACKFLG (AND NEWDIR (MKATOM
                                                                                          NEWDIR)))
                                                                    (T (OR NEWDIR "")))
                                                                 (CONS NAM VAL]
                                                         ((EQMEMB NAM ONEFIELDFLG)
                                                          (RETURN (COND
                                                                     (PACKFLG (AND NEWDIR
                                                                                   (MKATOM NEWDIR)))
                                                                     (T (OR NEWDIR ""])

(PUTPROPS PACKFILENAME.ASSEMBLE
 MACRO

          [NIL
           (PROG ((BLIP "")
                  (I 1)
                  HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION 
                  VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
                 (DECLARE
 (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION 
                                     VERSION TEMPORARY PROTECTION ACCOUNT))
             LP  (COND
                    ((<= I N)

                     (* ;; "Grab the next field-name / value pair and fold it into the filename:")


                     (COND
                        ((LISTP (SETQ VAR (ARG N I)))
                         (SETQ VAL (CDR VAR))
                         (SETQ VAR (CAR VAR)))
                        ((<= (SETQ I (ADD1 I))
                             N)
                         (SETQ VAL (ARG N I)))
                        (T (SETQ VAL)))
                     (OR (STRINGP VAL)
                         (ATOM VAL)
                         (EQ VAR 'BODY)
                         (\ILLEGAL.ARG VAL))
                     (SELECTQ VAR
                         (BODY (MAP (UNPACKFILENAME.STRING
 (COND
                                                                  ((LISTP VAL)
                                                                   (PACKFILENAME.STRING
 VAL))
                                                                  (T VAL))
                                           NIL
                                           'OK)
                                    [FUNCTION (LAMBDA (X)
                                                (SELECTQ (CAR X)
                                                    (HOST (OR HOST (SETQ HOST (OR (CADR X)
                                                                                  BLIP))))
                                                    (DEVICE (OR DEVICE (SETQ DEVICE
                                                                        (OR (CADR X)
                                                                            BLIP))))
                                                    (DIRECTORY [OR DIRECTORY
                                                                   (COND
                                                                      (RELATIVEDIRECTORY (SETQ 
                                                                                          DIRECTORY 
                                                                                          BLIP))
                                                                      (T (SETQ DIRECTORY
                                                                          (OR (CADR X)
                                                                              BLIP])
                                                    (SUBDIRECTORY (OR SUBDIRECTORY
                                                                      (SETQ SUBDIRECTORY
                                                                       (OR (CADR X)
                                                                           BLIP))))
                                                    (RELATIVEDIRECTORY 
                                                         [OR RELATIVEDIRECTORY
                                                             (COND
                                                                (DIRECTORY (SETQ RELATIVEDIRECTORY 
                                                                            BLIP))
                                                                (T (SETQ RELATIVEDIRECTORY
                                                                    (OR (CADR X)
                                                                        BLIP])
                                                    (NAME (OR NAME (SETQ NAME (OR (CADR X)
                                                                                  BLIP))))
                                                    (EXTENSION (OR EXTENSION (SETQ EXTENSION
                                                                              (OR (CADR X)
                                                                                  BLIP))))
                                                    (VERSION (OR VERSION (SETQ VERSION
                                                                          (OR (CADR X)
                                                                              BLIP))))
                                                    (SHOULDNT]
                                    (FUNCTION CDDR)))
                         (HOST [OR HOST (SETQ HOST (COND
                                                      (VAL (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL))
                                                      (T BLIP])
                         ((PATHNAME DIRECTORY) 
                              [COND
                                 (VAL
                                  (for
 X on
 (SETQ VAL (UNPACKFILENAME.STRING
 VAL NIL
                                                                     'RETURN))
                                     by
 (CDDR X)
                                     do
 (SELECTQ (CAR X)
                                                (HOST [COND
                                                         ((NOT HOST)
                                                          (SETQ HOST (OR (CADR X)
                                                                         BLIP])
                                                (DEVICE [COND
                                                           ((NOT DEVICE)
                                                            (SETQ DEVICE (OR (CADR X)
                                                                             BLIP])
                                                (SUBDIRECTORY [OR DIRECTORY
                                                                  (COND
                                                                     (RELATIVEDIRECTORY (SETQ 
                                                                                         DIRECTORY 
                                                                                         BLIP))
                                                                     (T (SETQ DIRECTORY
                                                                         (OR (CADR X)
                                                                             BLIP])
                                                (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")


                                                     (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                                            (OR (CADR X)
                                                                                BLIP))))
                                                (DIRECTORY [OR DIRECTORY
                                                               (COND
                                                                  (RELATIVEDIRECTORY (SETQ DIRECTORY
                                                                                      BLIP))
                                                                  (T (SETQ DIRECTORY
                                                                      (OR (CADR X)
                                                                          BLIP])
                                                (ERROR "Illegal field in DIRECTORY slot" VAL)))
                                  (for
 X on
 VAL by
 (CDDR X)
                                     do
 (SELECTQ (CAR X)
                                                (HOST (OR DEVICE (SETQ DEVICE BLIP))
                                                      (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                                (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                                NIL)))
                                 (T (OR DIRECTORY (SETQ DIRECTORY BLIP])
                         (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP))))
                         (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")


                              (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP))))
                         (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP))))
                         (NAME (OR NAME (SETQ NAME (OR VAL BLIP))))
                         (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP))))
                         (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP))))
                         (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP))))
                         (\ILLEGAL.ARG VAR))
                     (SETQ I (ADD1 I))
                     (GO LP)))
                 (COND
                    ((EQ HOST BLIP)
                     (SETQ HOST NIL)))
                 (COND
                    ((EQ DEVICE BLIP)
                     (SETQ DEVICE NIL)))
                 (COND
                    ((EQ DIRECTORY BLIP)
                     (SETQ DIRECTORY NIL)))
                 [COND
                    ((EQ SUBDIRECTORY BLIP)
                     (SETQ SUBDIRECTORY NIL))
                    ((AND NIL SUBDIRECTORY)
                     (COND
                        ((AND (NULL DIRECTORY)
                              (OR HOST DEVICE))
                         (SETQ DIRECTORY SUBDIRECTORY)
                         (SETQ SUBDIRECTORY NIL]
                 (COND
                    ((EQ RELATIVEDIRECTORY BLIP)
                     (SETQ RELATIVEDIRECTORY NIL)))
                 (RETURN (NCONC (AND HOST (LIST "{" HOST "}"))
                                [AND DEVICE (COND
                                               ((AND (SETQ TEMP (LASTCHPOS
 (CHARCODE %:)
                                                                       DEVICE 1))
                                                     (EQ TEMP (NCHARS DEVICE)))
                                                (LIST DEVICE))
                                               (T (LIST DEVICE ":"]
                                [COND
                                   (DIRECTORY (COND
                                                 [[OR (STREQUAL DIRECTORY "<")
                                                      (AND (SETQ TEMP (LASTCHPOS

                                                                       (CHARCODE (> /))
                                                                       DIRECTORY 1))
                                                           (EQ TEMP (NCHARS DIRECTORY]
                                                  (COND
                                                     ((EQMEMB (NTHCHARCODE DIRECTORY 1)
                                                             (CHARCODE (< /)))
                                                      (LIST DIRECTORY))
                                                     (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                              DIRECTORY]
                                                 (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                          DIRECTORY
                                                          (CL:SECOND \FILENAME.SYNTAX]
                                [COND
                                   (RELATIVEDIRECTORY (COND
                                                         ((AND (SETQ TEMP (LASTCHPOS

                                                                           (CHARCODE (> /))
                                                                           RELATIVEDIRECTORY 1))
                                                               (EQ TEMP (NCHARS RELATIVEDIRECTORY)))
                                                          (LIST RELATIVEDIRECTORY))
                                                         (T (LIST RELATIVEDIRECTORY (CL:SECOND 
                                                                                     \FILENAME.SYNTAX
                                                                                           ]
                                [COND
                                   (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX]
                                (AND NAME (NEQ NAME BLIP)
                                     (LIST NAME))
                                (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                         (AND VERSION (NEQ VERSION BLIP)))
                                     (LIST (COND
                                              ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                  (CHARCODE %.)))
                                               BLIP)
                                              (T '%.))
                                           (OR EXTENSION BLIP)))
                                (AND VERSION (NEQ VERSION BLIP)
                                     (LIST (CL:THIRD \FILENAME.SYNTAX)
                                           (COND
                                              ((FIXP VERSION)
                                               VERSION)
                                              (T (SELCHARQ (CHCON1 VERSION)
                                                      ((%. ! ;) 
                                                           (SUBSTRING VERSION 2 -1))
                                                      VERSION])

(PUTPROPS UNPACKFILE1
 MACRO
 [OPENLAMBDA (NAM ST END)

                                                             (* lmm "22-APR-81 22:21")

                                      (COND
                                         [(NOT ONEFIELDFLG)
                                          (SETQ VAL (CONS (COND
                                                             (PACKFLG (SUBATOM FILE ST END))
                                                             (T (OR (SUBSTRING FILE ST END)
                                                                    "")))
                                                          (CONS NAM VAL]
                                         ((EQMEMB NAM ONEFIELDFLG)
                                          (RETURN (COND
                                                     (PACKFLG (SUBATOM FILE ST END))
                                                     (T (OR (SUBSTRING FILE ST END)
                                                            ""])
)
)

(RPAQQ \FILENAME.SYNTAX
 ("<" ">" ";"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \FILENAME.SYNTAX)
)



(* ; "saving and restoring system state")


(DEFINEQ

(LOGOUT

  [LAMBDA (FAST)
                                         (* hdj "23-May-86 16:20")

    (\USEREVENT
 'BEFORELOGOUT)
    (COND
       ((OR (EQ FAST T)
            (\FLUSHVMOK? 'LOGOUT))                           (* ; 

                                            "Check that we have a vmem file before allowing LOGOUT")

        (\PROCESS.BEFORE.LOGOUT)
        (\DEVICEEVENT 'BEFORELOGOUT)
        (\SETTOTALTIME)                                      (* ; 

                                         "update the total time that this sysout has been running.")

        (\LOGOUT0 FAST)

        (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.")


        (\RESETKEYBOARD)
        (\DEVICEEVENT 'AFTERLOGOUT)
        (\OPENLINEBUF)
        (\PROCESS.AFTER.EXIT 'AFTERLOGOUT)
        (\USEREVENT
 'AFTERLOGOUT)
        (INTERPRET.REM.CM
)
        NIL])

(MAKESYS

  [LAMBDA (FILE NAME)
    (DECLARE
 (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE NAME))
                        (* ; "Edited 13-Oct-2020 22:51 by rmk:")


                                                             (* ; "Edited 28-Jul-88 18:16 by drc:")

    (\FLUSHVMOK? 'MAKESYS)
    (\USEREVENT
 'BEFOREMAKESYS)
    (HERALD
 (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME))
                       " "
                       (SUBSTRING (SETQ MAKESYSDATE (DATE))
                              1 11)
                       " ..."))
    (\DEVICEEVENT 'BEFOREMAKESYS)

    (* ;; "RMK:  make sysout on a temp file, then rename it in order to get version numbers")


    (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME
 'VERSION NIL 'BODY (OUTFILEP
 FILE))
                                    "-TEMP"]
         (COND
            ((NLISTP NEWFILE)                                (* ; 

                               "Coming back from doing the MAKESYS, so just set up to keep going.,")

             (\DEVICEEVENT 'AFTERDOMAKESYS)
             (\USEREVENT
 'AFTERDOMAKESYS)
             (RENAMEFILE
 NEWFILE (SETQ FILE (OUTFILEP
 FILE)))
             FILE)
            (T                                               (* ; 

                                       "Coming back in the MAKESYS'd sysout, so restart the world.")

               (\DEVICEEVENT 'AFTERMAKESYS)
               (\PROCESS.AFTER.EXIT 'AFTERMAKESYS)
               (PRIN1 HERALDSTRING T)
               (\USEREVENT
 'AFTERMAKESYS)
               (INTERPRET.REM.CM
)                        (* ; 

                                                           "Run the commands in the file REM.CM")

               (RESET])

(SYSOUT

  [LAMBDA (FILE)
                                        (* ; "Edited 14-Oct-2020 11:13 by rmk:")


                                                             (* hdj "29-Sep-86 12:14")

    (DECLARE
 (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE))                                  (* ; 

                                           "FILE is special so that BEFORESYSOUTFORMS can alter it")

    (\FLUSHVMOK? 'SYSOUT)
    (\USEREVENT
 'BEFORESYSOUT)
    (\DEVICEEVENT 'BEFORESYSOUT)

    (* ;; 

  "RMK:  Fix it so that sysouts are versioned.  Temp file goes to same place as eventual sysout.")


    (LET ((TOTALTIMESAVE (fetch
 TOTALTIME of
 \MISCSTATS))
          NEWFILE)                                           (* ; 

                    "update the total time field so that the run time in the sysout will be right.")

         (\SETTOTALTIME)
         (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME
 'VERSION NIL 'BODY (OUTFILEP
 FILE))
                                        "-TEMP")))
         (RENAMEFILE
 NEWFILE (SETQ FILE (OUTFILEP
 FILE)))
         [COND
            ((NLISTP NEWFILE)

             (* ;; "Continuing in same sysout;  reset TOTALTIME in misc stats page to not include the time before the sysout.")


             (replace
 TOTALTIME of
 \MISCSTATS with
 TOTALTIMESAVE)
             (\DEVICEEVENT 'AFTERDOSYSOUT)
             (\USEREVENT
 'AFTERDOSYSOUT))
            (T                                               (* ; "restarting")

               (\DEVICEEVENT 'AFTERSYSOUT)
               (\PROCESS.AFTER.EXIT 'AFTERSYSOUT)
               (INTERPRET.REM.CM
)
               (\USEREVENT
 'AFTERSYSOUT]
         FILE])

(SAVEVM

  [LAMBDA (RELEASEFLG)
                                   (* hdj "23-May-86 16:20")


    (* ;; "Save the virtual memory.  This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages.  Conceptually, this is like doing a sysout to Lisp.virtualmem")


    (\FLUSHVMOK? 'SAVEVM)
    (\USEREVENT
 'BEFORESAVEVM)
    (\DEVICEEVENT 'BEFORESAVEVM)
    (COND
       ((\FLUSHVM)
        (\RESETKEYBOARD)                                     (* ; 

                                                           "Returns T when starting up fresh")

        (\DEVICEEVENT 'AFTERSAVEVM)
        (\PROCESS.AFTER.EXIT 'AFTERSAVEVM)
        (\USEREVENT
 'AFTERSAVEVM)
        T)
       (T (\DEVICEEVENT 'AFTERDOSAVEVM)
          (\USEREVENT
 'AFTERDOSAVEVM])

(HERALD

  [LAMBDA (STR)
                                          (* wt%: " 2-MAY-79 15:38")

    (AND STR (SETQ HERALDSTRING STR))
    HERALDSTRING])

(INTERPRET.REM.CM

  [LAMBDA (RETFLG)
                                     (* ; "Edited 22-Feb-2021 15:31 by larry")

    (DECLARE
 (GLOBALVARS STARTUPFORM))

(* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote.  If it's a string, it will be unread,, else the form will be evaluated at the next prompt.  For use in INIT.LISP, among others.  If RETFLG is true, the expression read is simply returned")


    (PROG ((FILE (UNIX-GETENV "LDEINIT"))
           COM)
          (OR FILE (RETURN))
          (SETQ FILE (OPENSTREAM
 FILE 'INPUT))
          [COND
             ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
                          0)
                   (EQ (SKIPSEPRS FILE T)
                       '%")
                   (SETQ COM (CAR (NLSETQ (READ FILE T]
              (CLOSEF FILE)
              (COND
                 (RETFLG                                     (* ; "Save it to return")
)
                 (T                                          (* ; "Unread a string")

                                                             (* ; 

                                   "RMK: Replace CR and LF by space to avoid EOL convention issues")

                    (for
 I from
 1 to
 (NCHARS COM)
                       when
 (FMEMB (NTHCHARCODE COM I)
                                       (CHARCODE (CR LF EOL))) do
 (RPLCHARCODE COM I (CHARCODE
                                                                                          EOL)))
                    (BKSYSBUF COM]
          (RETURN (COND
                     (RETFLG COM)
                     (COM T])

(\USEREVENT

  [LAMBDA (EVENT)
    (DECLARE
 (GLOBALVARS AROUNDEXITFNS))
             (* bvm%: "16-Dec-83 15:27")

    (for
 FN in
 (SELECTQ EVENT
                           ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) 
                                AROUNDEXITFNS)
                           (REVERSE AROUNDEXITFNS)) do
 (APPLY* FN EVENT])
)

(ADDTOVAR AROUNDEXITFNS
 )

(RPAQ? HERALDSTRING
 "")

(RPAQ? \USERNAME
 )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
)
(DEFINEQ

(USERNAME

  [LAMBDA (FLG STRPTR PRESERVECASE)
                      (* lmm "28-MAR-82 14:10")

                                                             (* ; 

                                                    "On 10, USERNAME can take a user number as arg")

    (PROG (ADDR NAME)
          (SETQ NAME (COND
                        (FLG NIL)
                        ((NEQ 0 (SETQ ADDR (fetch
 (IFPAGE UserNameAddr) of
 \InterfacePage)))
                         (GetBcplString (\ADDBASE (EMADDRESS 0)
                                               ADDR)
                                (EQ STRPTR T)))
                        (T \USERNAME)))
          (OR PRESERVECASE (NULL NAME)
              (SETQ NAME (U-CASE NAME)))
          (RETURN (COND
                     ((NULL NAME)
                      NIL)
                     ((STRINGP STRPTR)
                      (SUBSTRING NAME 1 -1 STRPTR))
                     (T NAME])

(SETUSERNAME

  [LAMBDA (NAME)
                                         (* lmm "28-MAR-82 14:11")

                                                             (* ; 

                                                           "Changed interpretation of UserName0")

    (COND
       (NAME (PROG ((ADDR (fetch
 (IFPAGE UserNameAddr) of
 \InterfacePage)))
                   (RETURN (COND
                              ((NEQ ADDR 0)
                               (SetBcplString (\ADDBASE (EMADDRESS 0)
                                                     ADDR)
                                      NAME)
                               (SETQ USERNAME (USERNAME
 NIL T)))
                              (T (SETQ \USERNAME (CONCAT NAME])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       FILEIO)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 PACKFILENAME.STRING PACKFILENAME)
)
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
1991 1992 1920 2017 2020 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2705 9399 (DELFILE 2715 . 2876) (FULLNAME 2878 . 3245) (INFILE 3247 . 3395) (INFILEP 
3397 . 3532) (IOFILE 3534 . 3674) (OPENFILE 3676 . 4076) (OPENSTREAM 4078 . 8386) (OUTFILE 8388 . 8539
) (OUTFILEP 8541 . 8677) (RENAMEFILE 8679 . 8985) (SIMPLE.FINDFILE 8987 . 9397)) (9771 29362 (
UNPACKFILENAME 9781 . 9967) (UNPACKFILENAME.STRING 9969 . 26241) (LASTCHPOS 26243 . 26937) (
\UPF.NEXTPOS 26939 . 27584) (\UPF.TEMPFILEP 27586 . 28163) (FILENAMEFIELD 28165 . 28650) (PACKFILENAME
 28652 . 28995) (PACKFILENAME.STRING 28997 . 29360)) (51803 59344 (LOGOUT 51813 . 52774) (MAKESYS 
52776 . 54547) (SYSOUT 54549 . 56296) (SAVEVM 56298 . 57110) (HERALD 57112 . 57272) (INTERPRET.REM.CM 
57274 . 58967) (\USEREVENT 58969 . 59342)) (59526 61253 (USERNAME 59536 . 60492) (SETUSERNAME 60494 . 
61251)))))
STOP