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


(FILECREATED "29-Mar-2022 10:53:16" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;15
 28665  

      :CHANGES-TO (FNS DIRECTORY)

      :PREVIOUS-DATE "29-Mar-2022 08:29:33" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;14)


(* ; "
Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT DIRECTORYCOMS)

(RPAQQ DIRECTORYCOMS

       ((* DIRECTORY)
        (LISPXMACROS DIR NDIR)
        (FNS DODIR FILDIR DIRECTORY DIRECTORY.PARSE DIRECTORY.FILL.PATTERN DIRCONJ DIRECTORY.NEXTFILE
             DMATCH DIRECTORY.MATCH.SETUP DIRECTORY.MATCH DIRECTORY.MATCH1 DODIRCOMMANDS DIRPRINTNAME
             DPRIN1 DIRFILENAME DIRGETFILEINFO DREAD)
        (INITVARS (*UPPER-CASE-FILE-NAMES* T))
        [P (CL:PROCLAIM '(CL:SPECIAL *UPPER-CASE-FILE-NAMES*]
        (VARS DIRCOMMANDS FILEINFOTYPES)
        (DECLARE%: DONTCOPY (RECORDS FILEGROUP)
               (MACROS DTAB)
               (GLOBALVARS DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES))))



(* DIRECTORY)



(ADDTOVAR LISPXMACROS
 (DIR (DODIR (NLAMBDA.ARGS LISPXLINE)))
                      (NDIR (DODIR (NLAMBDA.ARGS LISPXLINE)
                                   '(P COLUMNS 20)
                                   '* "")))
(DEFINEQ

(DODIR

(LAMBDA (LISPXLINE EXTRACOMS DEFAULTEXT DEFAULTVERS NOP) (* rmk%: "29-OCT-81 17:01") (PROG ((FILE (CAR LISPXLINE)) (TAIL (CDR LISPXLINE)) CONJ) LP (COND ((SETQ CONJ (DIRCONJ (CAR TAIL))) (* ; "The files can be strung out in the line separated by conjunctions.") (SETQ FILE (LIST FILE CONJ (CADR TAIL))) (SETQ TAIL (CDDR TAIL)) (GO LP))) (AND EXTRACOMS (SETQ TAIL (APPEND TAIL EXTRACOMS))) (OR NOP (FMEMB (QUOTE P) TAIL) (FMEMB (QUOTE PP) TAIL) (SETQ TAIL (CONS (QUOTE P) TAIL))) (RETURN (DIRECTORY FILE TAIL DEFAULTEXT DEFAULTVERS))))
)

(FILDIR

  [LAMBDA (FILEGROUP DEPTH)
                                  (* ; "Edited  5-Mar-2022 09:03 by rmk")

                                                             (* lmm " 4-OCT-83 03:27")

    (DIRECTORY
 FILEGROUP (AND DEPTH `(COLLECT
 DEPTH ,DEPTH])

(DIRECTORY

  [LAMBDA (FILES COMMANDS DEFAULTEXT DEFAULTVERS)
    (DECLARE
 (SPECVARS COMMANDS DEFAULTEXT DEFAULTVERS))
     (* ; "Edited 29-Mar-2022 10:53 by rmk")


                                                             (* ; "Edited 26-Mar-2022 09:41 by rmk")


                                                             (* ; "Edited  4-Mar-2022 23:17 by rmk")


                                                             (* ; "Edited 30-Apr-92 14:55 by jds")

    (CL:UNLESS DEFAULTEXT
        (SETQ DEFAULTEXT '*))
    (CL:UNLESS DEFAULTVERS
        (SETQ DEFAULTVERS '*))
    (PROG (VALUE COLUMNS NAMEFLG DELETEDONLY FILEGROUP PRINTFLG OUTFILE PROMPTFLG LASTHOST&DIR 
                 DESIREDPROPS PFLG HEADINGS VALUES-WANTED (FILING.ENUMERATION.DEPTH 
                                                                 FILING.ENUMERATION.DEPTH))
          (DECLARE
 (SPECVARS VALUE COLUMNS NAMEFLG FILEGROUP DESIREDPROPS LASTHOST&DIR 
                          FILING.ENUMERATION.DEPTH))
          (PROG ([COMTAIL (SETQ COMMANDS (COND
                                            ((LISTP COMMANDS)
                                             (APPEND COMMANDS))
                                            (T (SETQ COMMANDS (LIST (OR COMMANDS 'COLLECT]
                 COM TEM)
            COMLP
                [SELECTQ (SETQ COM (CAR COMTAIL))
                    ((PAUSE P PP) 
                         (SETQ PFLG (SETQ PRINTFLG COMTAIL)))
                    (OLDVERSIONS [OR (FIXP (CADR COMTAIL))
                                     (RPLACD COMTAIL (CONS 1 (CDR COMTAIL]
                                 (pop
 COMTAIL))
                    (BY (RPLACA (SETQ COMTAIL (CDR COMTAIL))
                               (MKSTRING (CAR COMTAIL)))
                        (push
 DESIREDPROPS 'AUTHOR))
                    (COLLECT (SETQ VALUES-WANTED T))
                    (DELETE)
                    (COUNTSIZE (SETQ VALUE 0)
                               (push
 DESIREDPROPS 'SIZE))
                    ((PROMPT PRINT) 
                         (SETQ COMTAIL (CDR COMTAIL))
                         [push
 HEADINGS (LIST NIL (NCHARS (CAR COMTAIL]
                         (if
 (EQ COM 'PROMPT)
                             then
 (SETQ PROMPTFLG T)
                           else
 (SETQ PRINTFLG T)))
                    (@ (SETQ COMTAIL (CDR COMTAIL))
                       (if
 (FNTYP (SETQ COM (CAR COMTAIL)))
                           then
 [RPLACA COMTAIL (CONS COM '(FILENAME]
                                (SETQ NAMEFLG T)
                         elseif
 (FMEMB 'FILENAME (FREEVARS COM))
                           then
 (SETQ NAMEFLG T)))
                    (COLUMNS (SETQ COLUMNS (CADR COMTAIL))
                             (SETQ PRINTFLG T)
                             (RPLNODE COMTAIL 'NOP (CDDR COMTAIL)))
                    (OUT (SETQ OUTFILE (CADR COMTAIL))
                         (RPLNODE COMTAIL 'NOP (CDDR COMTAIL)))
                    ((DELETED UNDELETE) 
                         (ERROR "DELETED/UNDELETE directory commands are not supported")
                         (SETQ DELETEDONLY T))
                    ((OLDERTHAN NEWERTHAN) 
                         (push
 DESIREDPROPS 'ICREATIONDATE 'IWRITEDATE)
                         (if
 (EQ COM 'OLDERTHAN)
                             then
 (push
 DESIREDPROPS 'IREADDATE))
                         (RPLACA (SETQ COMTAIL (CDR COMTAIL))
                                (if
 (NUMBERP (SETQ COM (CAR COMTAIL)))
                                    then
                     (* ; "A number of days")

                                         [IDIFFERENCE (IDATE)
                                                (TIMES COM (DEFERREDCONSTANT (IDIFFERENCE
                                                                              (IDATE "2-JAN-77 00:00"
                                                                                     )
                                                                              (IDATE "1-JAN-77 00:00"
                                                                                     ]
                                  elseif
 (IDATE COM)
                                  else
 (\ILLEGAL.ARG COM))))
                    (DEPTH [SETQ FILING.ENUMERATION.DEPTH (IF
 (AND (SMALLP (CADR COMTAIL))
                                                                   (IGEQ (CADR COMTAIL)
                                                                         0))
                                                              THEN
 (CADR COMTAIL)
                                                            ELSEIF
 (MEMB (U-CASE (CADR COMTAIL))
                                                                         '(T ALL))
                                                              THEN
 MAX.SMALLP
                                                            ELSE
 (\ILLEGAL.ARG (CADR COMTAIL]

                           (* ;; "We remove the depth number from the list, leaving just the DEPTH, to be removed below. Otherwise we have to have a trailing pointer.")


                           (RPLACD COMTAIL (CDDR COMTAIL)))
                    (COND
                       ((STRINGP COM)
                        (RPLNODE COMTAIL 'PRINT (CONS (MKSTRING COM)
                                                      (CDR COMTAIL)))
                        (GO COMLP))
                       ((SETQ TEM (FASSOC COM FILEINFOTYPES))
                        (push
 DESIREDPROPS COM)
                        (push
 HEADINGS (LIST COM (CADR TEM)))
                        (SETQ PRINTFLG T))
                       ((LISTP COM)
                        (FRPLNODE2 COMTAIL (APPEND COM (CDR COMTAIL)))
                        (GO COMLP))
                       ((FIXSPELL COM NIL (NCONC (MAPCAR FILEINFOTYPES (FUNCTION CAR))
                                                 DIRCOMMANDS)
                               NIL COMTAIL NIL NIL T NIL 'MUSTAPPROVE)

                        (* ;; "User MUST approve any spelling corrections, to prevent accidental correction of DELVER to DELETE.  Yucko!")


                        (GO COMLP))
                       (T (ERROR "invalid DIRECTORY command" COM]
                (AND (SETQ COMTAIL (CDR COMTAIL))
                     (GO COMLP)))
          (SETQ COMMANDS (DREMOVE 'DEPTH COMMANDS))
          (RESETLST

              (* ;; "RESETLST is here, among other reasons, to clean up after any file generators that worry about the DIR being aborted")


              (SETQ FILEGROUP (create
 FILEGROUP
                                     PATTERN _ (DIRECTORY.PARSE
 FILES)
                                     FILEGENERATORS _ FILEGROUP))
                                                             (* ; 

       "DIRECTORY.PARSE smashes generators on FILEGROUP for each atomic file specification it finds.")

              [COND
                 ((EQL \MACHINETYPE \MAIKO)
                  (RESETSAVE NIL '(AND RESETSTATE (\UFS.ABORT.DIRECTORY]
                                                             (* ; 

                                       "Make sure all instances of UFSGENFILESTATE will be released.")

              (COND
                 ((OR PRINTFLG OUTFILE PROMPTFLG)
                  [COND
                     (PROMPTFLG (RESETSAVE (SETTERMTABLE ASKUSERTTBL]
                  [RESETSAVE (OUTPUT (COND
                                        ((NULL OUTFILE)      (* ; "Default output is to terminal")

                                         T)
                                        ((GETSTREAM OUTFILE T T))
                                        (T [RESETSAVE NIL (LIST 'CLOSEF? (SETQ OUTFILE
                                                                          (OPENSTREAM OUTFILE
                                                                                 'OUTPUT]
                                           OUTFILE]
                  [COND
                     ((AND PFLG (NEQ (CAR PFLG)
                                     'PAUSE))                (* ; 

                                             "Postpone print commands until after predicate commands")

                      (SETQ COMTAIL COMMANDS)
                      (bind
 SEENP PREVTAIL do
 (SELECTQ (CAR COMTAIL)
                                                  ((P PP) 
                                                       (SETQ SEENP (OR PREVTAIL T)))
                                                  ((BY COLUMNS @ OUT OLDERTHAN NEWERTHAN) 
                                                       (pop
 COMTAIL))
                                                  (PROGN [COND
                                                            ((AND SEENP (NEQ COMTAIL (CDR PFLG)))
                                                             (* ; 

                                                             "Move the P or PP to before COMTAIL")

                                                             (RPLACD PREVTAIL (CONS (CAR PFLG)
                                                                                    COMTAIL))
                                                             (COND
                                                                ((NEQ SEENP T)
                                                                 (RPLACD SEENP (CDDR SEENP)))
                                                                (T (pop
 COMMANDS]
                                                         (RETURN)))
                                              (SETQ COMTAIL (CDR (SETQ PREVTAIL COMTAIL]
                  [COND
                     ((AND HEADINGS (for
 X in
 HEADINGS thereis
 (CAR X)))
                      (TERPRI)
                      (for
 X in
 (REVERSE HEADINGS) bind
 (I _ 22) do
 (TAB I)
                                                                    [COND
                                                                       ((CAR X)
                                                                        (PRIN1 (CAR X]
                                                                    (add
 I (CADR X]
                  (SETQ PRINTFLG T)
                  (TAB 0 0)))
              (while
 (DIRECTORY.NEXTFILE
 FILEGROUP) do
 (DODIRCOMMANDS
 COMMANDS FILEGROUP))
              (COND
                 (PRINTFLG (TAB 0 0))))

     (* ;; "DREVERSE because files are pushed.")


          (RETURN (OR (DREVERSE VALUE)
                      (CL:UNLESS VALUES-WANTED (CL:VALUES])

(DIRECTORY.PARSE

  [LAMBDA (FG)
                                               (* ; "Edited 26-Mar-2022 18:49 by rmk")

                                                             (* bvm%: "14-May-84 12:55")


    (* ;; 

    "This pushes file generators on FILEGROUP for each of the atomic filespecifications it comes to.")


    (DECLARE
 (USEDFREE FILEGROUP DESIREDPROPS DEFAULTEXT DEFAULTVERS))
    (LET (TEMP)
         (COND
            ((NLISTP FG)
             [push
 FILEGROUP (\GENERATEFILES (SETQ FG (DIRECTORY.FILL.PATTERN
 FG DEFAULTEXT 
                                                             DEFAULTVERS))
                                    DESIREDPROPS
                                    '(SORT RESETLST]
             (DIRECTORY.MATCH.SETUP
 FG))
            [(SETQ TEMP (DIRCONJ
 (CADR FG)))                 (* ; "Infix operator")

             (CONS TEMP (CONS (DIRECTORY.PARSE
 (CAR FG))
                              (DIRECTORY.PARSE
 (CADDR FG]
            [(SETQ TEMP (DIRCONJ
 (CAR FG)))                  (* ; "Prefix operator")

             (CONS TEMP (CONS (DIRECTORY.PARSE
 (CADR FG))
                              (DIRECTORY.PARSE
 (CADDR FG]
            (T (ERROR "Bad file-group conjunction" (CADR FG])

(DIRECTORY.FILL.PATTERN

  [LAMBDA (PATTERN DEFAULTEXT DEFAULTVERS)
                   (* ; "Edited 26-Mar-2022 17:54 by rmk")

                                                             (* bvm%: " 6-Feb-85 14:16")

    (DECLARE
 (GLOBALVARS \CONNECTED.DIRECTORY))
    (PACKFILENAME.STRING 'BODY PATTERN 'NAME '* 'VERSION (OR DEFAULTVERS '*)
           'EXTENSION
           (OR DEFAULTEXT '*)
           'DIRECTORY
           (AND (NOT (FILENAMEFIELD.STRING PATTERN 'HOST))
                \CONNECTED.DIRECTORY])

(DIRCONJ

(LAMBDA (CONJ) (* rmk%: "29-OCT-81 11:01") (* ;; "Returns canonical form of directory conjunction, NIL if invalid") (SELECTQ CONJ ((OR +) (QUOTE OR)) ((AND *) (QUOTE AND)) ((- ANDNOT) (QUOTE ANDNOT)) NIL))
)

(DIRECTORY.NEXTFILE

(LAMBDA (FG) (* bvm%: " 8-Jul-85 19:32") (PROG (TEM) LP (COND ((SETQ TEM (\GENERATENEXTFILE (CAR (fetch FILEGENERATORS of FG)) NIL)) (COND ((LISTP TEM) (* ; "Old style enumerator returns charlist") (SETQ TEM (CONCATCODES TEM)))) (COND ((STRINGP TEM) (replace STRINGNAME of FG with TEM) (replace LITERALNAME of FG with NIL)) (T (replace LITERALNAME of FG with (AND (LITATOM TEM) (U-CASEP TEM) TEM)) (replace STRINGNAME of FG with (SETQ TEM (MKSTRING TEM))))) (RETURN FG)) ((replace FILEGENERATORS of FG with (CDR (fetch FILEGENERATORS of FG))) (GO LP)) (T (RETURN)))))
)

(DMATCH

(LAMBDA (PAT TESTNAME) (* bvm%: " 4-May-84 13:16") (COND ((OR (EQ PAT T) (NULL PAT)) T) (T (SELECTQ (CAR PAT) (OR (OR (DMATCH (CADR PAT) TESTNAME) (DMATCH (CDDR PAT) TESTNAME))) (AND (AND (DMATCH (CADR PAT) TESTNAME) (DMATCH (CDDR PAT) TESTNAME))) (ANDNOT (AND (NOT (DMATCH (CDDR PAT) TESTNAME)) (DMATCH (CADR PAT) TESTNAME))) (DIRECTORY.MATCH PAT TESTNAME)))))
)

(DIRECTORY.MATCH.SETUP

(LAMBDA (FILENAME) (* bvm%: " 6-May-86 14:35") (SELCHARQ (CAR (SETQ FILENAME (CHCON FILENAME))) ({ (do (* ;; "Throw out hostname/device part, because the canonical name might be different from the one in the pattern") (SELCHARQ (pop FILENAME) (} (RETURN)) NIL))) NIL) (for TAIL on FILENAME bind (BASE _ (UPPERCASEARRAY)) do (* ; "Coerce to uppercase") (RPLACA TAIL (SELCHARQ (CAR TAIL) (ESCAPE (CHARCODE *)) (COND ((LEQ (CAR TAIL) \MAXTHINCHAR) (GETCASEARRAY BASE (CAR TAIL))) (T (CAR TAIL)))))) FILENAME)
)

(DIRECTORY.MATCH

(LAMBDA (PATTERN TESTNAME) (* bvm%: " 4-May-84 13:01") (PROG ((FIRSTCHAR 1)) (SELCHARQ (NTHCHARCODE TESTNAME 1) (({ %[) (do (* ;; "Throw out hostname/device part, because the canonical name might be different from the one in the pattern") (SELCHARQ (NTHCHARCODE TESTNAME (add FIRSTCHAR 1)) ((} %]) (RETURN (add FIRSTCHAR 1))) NIL))) NIL) (RETURN (DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR))))
)

(DIRECTORY.MATCH1

(LAMBDA (PATTERN TESTNAME FIRSTCHAR) (* ; "Edited 11-Mar-88 14:50 by bvm") (PROG ((CASEBASE (ffetch (ARRAYP BASE) of (\DTEST UPPERCASEARRAY (QUOTE ARRAYP)))) (NAMELIMIT (NCHARS TESTNAME)) PATCHAR TESTCHAR) LP (COND ((IGREATERP FIRSTCHAR NAMELIMIT) (* ; "Run out of name, so rest of pattern better be 'null', i.e., something like *.*;*") (RETURN (bind (OKCHARS _ (CHARCODE (%. ;))) do (if (NULL PATTERN) then (RETURN T) elseif (EQ (CAR PATTERN) (CHARCODE *)) then (SETQ PATTERN (CDR PATTERN)) elseif (MEMB (pop PATTERN) OKCHARS) then (SETQ OKCHARS (CDR OKCHARS)) else (RETURN NIL))))) ((NULL PATTERN) (* ;; "Name left, but no pattern.  This is always a mismatch unless last matched pattern character was ';' in which case what follows is the version.  Have to hope that the device generated only the newest version") (RETURN (EQ PATCHAR (CHARCODE ;)))) (T (COND ((EQ (SETQ PATCHAR (CAR PATTERN)) (CHARCODE *)) (* ;; "Matches any number of characters.  Thus, see if we have a match ANYWHERE on remainder of TESTNAME.  Also succeed if the pattern is just some tail of *.*;* now.") (RETURN (OR (NULL (SETQ PATTERN (CDR PATTERN))) (LET ((PAT PATTERN)) (* ;; "OK if pattern is *.*;*, *;*, or *.;* and TESTNAME has no extension") (AND (OR (NEQ (CAR PAT) (CHARCODE ".")) (if (EQ (CAR (SETQ PAT (CDR PAT))) (CHARCODE *)) then (* ; "Wildcard extension always ok") (SETQ PAT (CDR PAT))) (PROGN (* ; "Make sure we don't spuriously match a file with extension against extensionless pattern") (NOT (STRPOS "." TESTNAME FIRSTCHAR)))) (EQ (CAR PAT) (CHARCODE ";")) (OR (NULL (SETQ PAT (CDR PAT))) (EQ (CAR PAT) (CHARCODE *))))) (do (COND ((DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR) (RETURN T))) (add FIRSTCHAR 1) repeatuntil (IGREATERP FIRSTCHAR NAMELIMIT))))) ((OR (EQ PATCHAR (COND ((LEQ (SETQ TESTCHAR (NTHCHARCODE TESTNAME FIRSTCHAR)) \MAXTHINCHAR) (\GETBASEBYTE CASEBASE TESTCHAR)) (T TESTCHAR))) (SELCHARQ PATCHAR (%# (* ; "Matches anything") T) (; (* ; "Would match except for different delimiter") (EQ TESTCHAR (CHARCODE !))) NIL)) (pop PATTERN) (add FIRSTCHAR 1) (GO LP)) (T (RETURN NIL)))))))
)

(DODIRCOMMANDS

  [LAMBDA (COMMANDS FILEGROUP)
                               (* ; "Edited 29-Mar-2022 08:16 by rmk")


                                                             (* ; "Edited 30-Apr-92 15:03 by jds")

    (PROG ((COMTAIL COMMANDS)
           (I 0)
           (FILENAME (fetch
 LITERALNAME of
 FILEGROUP))
           COM FILE NAMEPRINTED ATTRVALUE)
          (DECLARE
 (SPECVARS FILENAME FILE NAMEPRINTED I)
                 (USEDFREE VALUE))
          (COND
             ([AND COLUMNS (NOT (ILESSP (SETQ I (ITIMES (IQUOTIENT (IPLUS (POSITION)
                                                                          COLUMNS -1)
                                                               COLUMNS)
                                                       COLUMNS))
                                       (IDIFFERENCE (LINELENGTH)
                                              30]
              (SETQ I 0)))
          (while
 COMTAIL
             do
 (SELECTQ (SETQ COM (pop
 COMTAIL))
                    (P (DIRPRINTNAME
 FILEGROUP))
                    (PP (DIRPRINTNAME
 FILEGROUP T))
                    (COUNTSIZE (add
 VALUE (DIRGETFILEINFO
 FILEGROUP 'SIZE)))
                    (PAUSE (READC T)
                           (SETQ I (IPLUS I 2)))
                    (@                                       (* ; 

                                                          "Arbitrary predicate -- next thing is form")

                       (AND NAMEFLG (DIRFILENAME
 FILEGROUP))
                       (COND
                          ((NOT (EVAL (pop
 COMTAIL)))
                           (RETURN))))
                    ((OLDERTHAN NEWERTHAN) 
                         [LET ((COMDATE (pop
 COMTAIL))
                               DT)
                              (COND
                                 ([OR [EQ (EQ COM 'OLDERTHAN)
                                          (OR (AND (SETQ DT (DIRGETFILEINFO
 FILEGROUP 'ICREATIONDATE)
                                                    )
                                                   (IGEQ DT COMDATE))
                                              (AND (SETQ DT (DIRGETFILEINFO
 FILEGROUP 'IWRITEDATE))
                                                   (IGEQ DT COMDATE]
                                      (AND (EQ COM 'OLDERTHAN)
                                           (AND (SETQ DT (DIRGETFILEINFO
 FILEGROUP 'IREADDATE))
                                                (IGEQ DT COMDATE]

                                 (* ;; "Only check Read date for the OLDERTHAN case, where it is useful for archiving.  NEWERTHAN is only interested in files actually created recently")


                                  (RETURN])
                    (BY (SETQ COM (pop
 COMTAIL))
                        (COND
                           ((AND (SETQ ATTRVALUE (DIRGETFILEINFO
 FILEGROUP 'AUTHOR))
                                 (NOT (STRPOS COM ATTRVALUE NIL NIL NIL NIL UPPERCASEARRAY)))
                            (RETURN))))
                    (DELETE (DTAB 12)
                            (PRIN1 (COND
                                      ((DELFILE (DIRFILENAME
 FILEGROUP))
                                       "deleted")
                                      (T "can't delete"))))
                    (PROMPT (OR (DREAD
 (pop
 COMTAIL))
                                (RETURN)))
                    (PRINT (DPRIN1
 (pop
 COMTAIL)))
                    (COLLECT (PUSH
 VALUE (DIRFILENAME
 FILEGROUP)))
                    (OLDVERSIONS                             (* ; 

                                   "Not implemented, but user might continue from error in DIRECTORY")

                                 (COND
                                    ((NEQ (CAR COMTAIL)
                                          1)
                                     (ERROR "can't count more than 1 version")))
                                 (COND
                                    ((STRING.EQUAL (INFILEP (DIRFILENAME
 FILEGROUP))
                                            (INFILEP (PACKFILENAME 'VERSION NIL 'BODY FILENAME)))

                                     (* ;; "Used to be EQ, but that fails for dsk files?")


                                     (RETURN)))
                                 (pop
 COMTAIL))
                    ((DELETED UNDELETE)                      (* ; "Not implemented")

                         )
                    (NOP)
                    (LET ((TYPE (FASSOC COM FILEINFOTYPES)))
                         (COND
                            [TYPE (DTAB (CADR TYPE))
                                  (COND
                                     ((SETQ ATTRVALUE (DIRGETFILEINFO
 FILEGROUP COM))
                                      (COND
                                         ((FIXP ATTRVALUE)
                                          (PRINTNUM (OR (CDDR TYPE)
                                                        (LIST 'FIX (CADR TYPE)))
                                                 ATTRVALUE))
                                         ((AND (LISTP ATTRVALUE)
                                               (LISTP (CAR ATTRVALUE)))
                                          (PRINTDEF ATTRVALUE (POSITION)))
                                         (T (PRIN1 ATTRVALUE]
                            (T (SHOULDNT])

(DIRPRINTNAME

(LAMBDA (FILEGROUP FLG) (DECLARE (USEDFREE LASTHOST&DIR NAMEPRINTED)) (* ; "Edited 27-Apr-90 10:07 by nm") (COND ((NOT NAMEPRINTED) (PROG ((STREAM (GETSTREAM NIL (QUOTE OUTPUT))) (FULLNAME (fetch STRINGNAME of FILEGROUP)) (LASTNAME (CAR LASTHOST&DIR)) DIFFERENT DIRECTORYEND) (for I from 1 bind THISCHAR LASTCHAR do (* ; "Scan for end of directory name, and notice whether it matches previously printed directory") (SELCHARQ (SETQ THISCHAR (NTHCHARCODE FULLNAME I)) (NIL (RETURN)) ((} < > / %)) (SETQ DIRECTORYEND I)) NIL) (COND ((AND (NOT DIFFERENT) (COND ((NULL (SETQ LASTCHAR (NTHCHARCODE LASTNAME I)))) ((> LASTCHAR \MAXTHINCHAR) (* ; "Fat chars don't go thru casearray") (NEQ LASTCHAR THISCHAR)) ((> THISCHAR \MAXTHINCHAR)) (T (* ; "Two thin chars, are they really different?") (NEQ (GETCASEARRAY UPPERCASEARRAY LASTCHAR) (GETCASEARRAY UPPERCASEARRAY THISCHAR))))) (SETQ DIFFERENT I)))) (COND ((AND DIFFERENT DIRECTORYEND (OR (NEQ DIRECTORYEND (CADR LASTHOST&DIR)) (<= DIFFERENT DIRECTORYEND))) (TAB 0 0) (* ; "New directory") (TERPRI) (SPACES 3) (for I from 1 to DIRECTORYEND do (\OUTCHAR STREAM (NTHCHARCODE FULLNAME I))) (SETQ LASTHOST&DIR (LIST FULLNAME DIRECTORYEND)))) (DTAB 20) (for I from (ADD1 (OR DIRECTORYEND 0)) do (COND ((AND FLG (EQ (NTHCHARCODE FULLNAME I) (CHARCODE ;))) (RETURN))) (\OUTCHAR STREAM (OR (NTHCHARCODE FULLNAME I) (RETURN)))) (SPACES 1) (SETQ NAMEPRINTED T)))))
)

(DPRIN1

(LAMBDA (STR) (* lmm "20-OCT-78 02:53") (DTAB (NCHARS STR)) (PRIN1 STR)))

(DIRFILENAME

  [LAMBDA (FILEGROUP)

    (* ;; "Edited 28-Mar-2022 11:08 by rmk: Don't convert to atoms, always return strings")


    (* ;; "Edited 28-Jul-87 14:55 by bvm:")


    (DECLARE
 (USEDFREE FILE FILENAME))                       (* ; 

                                     "These might be used freely by user predicates, with @ commands")

    (IF
 (fetch
 LITERALNAME of
 FILEGROUP)
      ELSE
 (SETQ FILENAME (fetch
 STRINGNAME of
 FILEGROUP))
           (CL:WHEN (AND *UPPER-CASE-FILE-NAMES* (NOT (U-CASEP FILENAME)))
               (SETQ FILENAME (U-CASE FILENAME)))
           (SETQ FILE FILENAME)
           (replace
 LITERALNAME of
 FILEGROUP with
 FILENAME])

(DIRGETFILEINFO

(LAMBDA (FILEGROUP ATTRIBUTE) (* bvm%: " 5-May-84 15:19") (\GENERATEFILEINFO (CAR (fetch FILEGENERATORS of FILEGROUP)) ATTRIBUTE))
)

(DREAD

(LAMBDA (PROMPT) (* lmm "21-OCT-78 01:28") (PROG1 (PROG NIL LP (PROGN (TAB I 0) (PRIN1 PROMPT)) (SELECTQ (READC T) ((Y y) (PRIN1 (QUOTE "Yes") T) (RETURN T)) ((N n) (PRIN1 (QUOTE "No") T) (RETURN)) (? (PRIN1 (QUOTE "Y or N: ") T) (GO LP)) (PROGN (PRIN1 "" T) (GO LP)))) (add I (NCHARS PROMPT) 5)))
)
)

(RPAQ? *UPPER-CASE-FILE-NAMES*
 T)

(CL:PROCLAIM '(CL:SPECIAL *UPPER-CASE-FILE-NAMES*))

(RPAQQ DIRCOMMANDS

       ((- . PAUSE)
        (AU . AUTHOR)
        BY COLLECT (COLLECT? PROMPT " ? " COLLECT)
        COUNTSIZE
        (DA . CREATIONDATE)
        (DATE . CREATIONDATE)
        (DEL . DELETE)
        (DEL? . DELETE?)
        DELETE
        (DELETE? PROMPT " delete? " DELETE)
        DELETED
        (LE LENGTH "(" BYTESIZE ")")
        NEWERTHAN OLDVERSIONS (OLD OLDERTHAN 90)
        OLDERTHAN
        (OU . OUT)
        OUT P PAUSE (PR . PROTECTION)
        PROMPT
        (SI . SIZE)
        (TI . WRITEDATE)
        UNDELETE
        (VERBOSE AUTHOR CREATIONDATE SIZE READDATE WRITEDATE)
        TRIMTO
        (DELVER OLDVERSIONS DELETE)
        DEPTH))

(RPAQQ FILEINFOTYPES

       ((WRITEDATE 22)
        (READDATE 22)
        (CREATIONDATE 22)
        (LENGTH 9)
        (BYTESIZE 2)
        (PROTECTION 6 FIX 6 8)
        (SIZE 5)
        (AUTHOR 11)
        (READER 11)
        (TYPE 7)
        (FILETYPE 6 FIX 6 8)))
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD FILEGROUP
 (STRINGNAME LITERALNAME PATTERN . FILEGENERATORS))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS DTAB
 DMACRO
 ((N)
                       (TAB (PROG1 I (add
 I N 1))
                            0)))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)
)
)
(PUTPROPS DIRECTORY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1325 27144 (DODIR 1335 . 1882) (FILDIR 1884 . 2164) (DIRECTORY 2166 . 12883) (
DIRECTORY.PARSE 12885 . 14179) (DIRECTORY.FILL.PATTERN 14181 . 14711) (DIRCONJ 14713 . 14933) (
DIRECTORY.NEXTFILE 14935 . 15528) (DMATCH 15530 . 15905) (DIRECTORY.MATCH.SETUP 15907 . 16441) (
DIRECTORY.MATCH 16443 . 16860) (DIRECTORY.MATCH1 16862 . 18975) (DODIRCOMMANDS 18977 . 24447) (
DIRPRINTNAME 24449 . 25865) (DPRIN1 25867 . 25952) (DIRFILENAME 25954 . 26675) (DIRGETFILEINFO 26677
 . 26829) (DREAD 26831 . 27142)))))
STOP