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


(FILECREATED "16-Nov-2023 21:59:19" |{DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;2|
 18962  

      :EDIT-BY "lmm"

      :CHANGES-TO (VARS OKLIBRARY OKLISPUSERS)

      :PREVIOUS-DATE " 4-Nov-2023 15:23:16" |{DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;1|)


(PRETTYCOMPRINT MEDLEY-UTILSCOMS)

(RPAQQ MEDLEY-UTILSCOMS
 ((FNS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
                         (VARS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
                         (FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)
                         (FNS BADFILE HCFILES PRETTYFILES)
                         (INITVARS (HCFILES)
                                (BADFILES))))
(DEFINEQ

(GATHER-INFO

  (LAMBDA (PHASE)
                                           (* \; "Edited 22-May-2023 23:59 by lmm")


                                                          (* \; "Edited 26-Dec-2021 18:56 by larry")


                                                          (* \; "Edited 24-Oct-2021 09:43 by larry")

    (SELECTQ PHASE
        (ALL (|for|
 I |from|
 0 |to|
 4 |do|
 (GATHER-INFO
 I)))
        (0 (SETQ SYSFILES (UNION SYSFILES FILELST))
           (SETQ FILELST NIL)
           (FILESLOAD (SOURCE)
                  SYSEDIT))
        (1 (SETQ LOADEDFILES (|for|
 X |in|
 LOADEDFILELST |collect|
 (FILENAMEFIELD X 'NAME)))
           (FILESLOAD FILESETS)
           (SETQ ALLFILESETSFILES (|for|
 X |in|
 FILESETS |join|
 (APPEND (EVAL X))))
           (SETQ SOURCES (|for|
 X |in|
 (DIRECTORY (MEDLEYDIR "sources" "*.*;" T))
                            |when|
 (NOT (MEMB (FILENAMEFIELD X 'EXTENSION)
                                              '(LCOM DFASL TEDIT TXT)))
                            |collect|
 (FILENAMEFIELD X 'NAME))))
        (-1 (PRINTOUT T " loaded files not in SYSFILES or FILELST: "
                   (|for|
 X |in|
 LOADEDFILES |when|
 (NOT (OR (FMEMB X SYSFILES)
                                                             (FMEMB X FILELST))) |collect|
 X)
                   T)
            (PRINTOUT T "Sources not loaded: " (CL:SET-DIFFERENCE SOURCES (APPEND ALLFILESETSFILES 
                                                                                 LOADEDFILES))
                   T)
            (PRINTOUT T "Files in FILESETS not loaded " (CL:SET-DIFFERENCE ALLFILESETSFILES 
                                                               LOADEDFILES)
                   T))
        (2 (SETQ DEFINEDFNS (LET ((DEFD NIL))
                                 (MAPATOMS (FUNCTION (CL:LAMBDA (X)
                                                            (CL:WHEN (GETD X)
                                                                (CL:SETQ DEFD (CONS X DEFD))))))
                                 DEFD))
           (|for|
 X |in|
 DEFINEDFNS |when|
 (CCODEP X)
              |do|
 (LET ((Y (PUTPROP X 'CCC (CALLSCCODE X))))
                        (|for|
 REV |in|
 '(BLOCK-CALLED-BY CALLED-BY BOUND-BY SPECIAL-BY GLOBAL-BY)
                           |as|
 VAL |in|
 Y |do|
 (|for|
 S |in|
 VAL
                                                   |do|
 (PUTPROP S REV (CONS X (GETPROP S REV)))))))
           (SETQ CALLEDFNS NIL)
           (MAPATOMS (FUNCTION (LAMBDA (X)
                                 (|if|
 (AND (NOT (GETD X))
                                            (GETPROP X 'CALLED-BY))
                                     |then|
 (CL:PUSH X CALLEDFNS))))))
        (-2 (PRINTOUT T "Functions called and not defined" CALLEDFNS T))
        (3 (|for|
 X |in|
 SYSFILES
              |do|
 (LOAD X 'PROP)
                   (PUTPROP X 'CONTENT (READFILE X))
                   (|for|
 EXR |in|
 (GETPROP X 'CONTENT)
                      |do|
 (SELECTQ (CAR EXR)
                               (DEFINEQ (|for|
 DFN |in|
 (CDR EXR)
                                           |do|
 (|if|
 (EQUAL (CADR DFN)
                                                             (GETPROP (CAR DFN)
                                                                    'EXPR))
                                                    |then|
 (PRINTOUT T (CAR DFN)
                                                                  " ")
                                                          (PUTPROP (CAR DFN)
                                                                 'EXPR
                                                                 (CADR DFN))
                                                  |else|
 (PRINTOUT T (CAR DFN)
                                                                "* "))))
                               NIL)))
           (SETQ ALLCONTENT (|for|
 X |in|
 SYSFILES |collect|
 (CONS X (GETPROP X 'CONTENT))))
                                                             (* \; " don't edit with SEDIT")

           (LET (DUPS)
                (|for|
 X |in|
 SYSFILES
                   |do|
 (|for|
 FN |in|
 (FILEFNSLST X)
                           |do|
 (|if|
 (GETPROP FN 'WHEREIS)
                                    |then|
 (NCONC1 (GETPROP FN 'WHEREIS)
                                                  X)
                                          (OR (FMEMB FN DUPS)
                                              (SETQ DUPS (CONS FN DUPS)))
                                  |else|
 (PUTPROP FN 'WHEREIS (LIST X)))))
                (SETQ DUPFNS DUPS))
           (SETQ NO-SOURCE (|for|
 X |in|
 DEFINEDFNS |when|
 (NOT (GETPROP X 'EXPR)) |collect|
 X)))
        (-3 (PRINTOUT T "Functions compiled but no expr" NO-SOURCE T)
            (PRINTOUT T "Functions on more than one file: " DUPFNS T))
        (4 (PRINTOUT T T "STARTING MASTERSCOPE PHASE ON " (DATE)
                  T)
           (FILESLOAD (SOURCE)
                  SYSEDIT)
           (|for|
 X |in|
 SYSFILES |do|
 (MSNOTICEFILE X))
           (|for|
 X |in|
 SYSFILES |do|
 (PRINTOUT T T "Analyzing " X T)
                                       (MASTERSCOPE `(ANALYZE ON ,(KWOTE X)))))
        (-4 "No queries yet")
        (HELP))))

(MAKE-FULLER-DB

  (LAMBDA (DRIBBLEFILE DBFILE SYSOUTFILE)
                 (* \; "Edited  3-Aug-2023 18:12 by frank")


                                                          (* \; "Edited 16-Jul-2022 22:07 by larry")


                                                          (* \; "Edited 20-Jun-2022 17:23 by larry")

    (FILESLOAD (SOURCE)
           FILESETS)
    (DRIBBLE (OR DRIBBLEFILE "fuller.dribble"))
    (DOFILESLOAD (SUBSET (APPEND OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
                        'FINDFILE))
    (GATHER-INFO
 'ALL)
    (MASTERSCOPE '(WHO CALLS XYZZY))
    (DUMPDATABASE NIL (MKATOM (OR DBFILE "fuller.database")))
    (DRIBBLE)
    (MAKESYS (OR SYSOUTFILE "fuller.sysout")
           "Welcome to Fuller sysout")))

(MEDLEY-FIX-LINKS

  (LAMBDA (UNIXPATH)
                                      (* \; "Edited 18-Jan-2021 12:01 by larry")

    (OR UNIXPATH (SETQ UNIXPATH (UNIX-GETENV "MEDLEYDIR"))
        (ERROR "No Directory"))
                           (* \; "Edited 18-Jan-2021 11:45 by larry")

    (|ShellCommand| (CONCAT "cd " UNIXPATH " && /bin/sh scripts/fixlinks && /bin/sh /tmp/doit"))))

(MEDLEY-FIX-DATES

  (LAMBDA (DIRS)
                                          (* \; "Edited 28-Jan-2021 12:15 by larry")

    (|for|
 X |in|
 (OR DIRS MEDLEY-FIX-DIRS) |join|
 (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T))))))
)

(RPAQQ MEDLEY-FIX-DIRS
 ("sources" "library" "lispusers" "internal" "greetfiles" "doctools"))

(RPAQQ OKSOURCES
 (RENAMEFNS VMEM READSYS CASH-FILE HASH-FILE MEDLEYDIR MAKEINIT))

(RPAQQ OKLIBRARY

       (POSTSCRIPTSTREAM CHATTERMINAL DMCHAT CHAT PRESS READNUMBER EDITBITMAP IMAGEOBJ TEDIT HRULE 
              TABLEBROWSER FILEBROWSER GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MSCOMMON 
              MASTERSCOPE UNIXCOMM UNIXPRINT UNICODE HASH CLIPBOARD UNIXCHAT VT100KP VTCHAT SKETCH 
              SKETCHBMELT SCALEBITMAP SKETCHOBJ SKETCHEDIT SKETCHELEMENTS SKETCHOPS MATMULT SAMEDIR 
              REMOTEVMEM ETHERRECORDS UNIXUTILS CHATDECLS BROWSER))

(RPAQQ OKLISPUSERS

       (THINFILES ISO8859IO DINFO HELPSYS MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE 
              BACKGROUND-YIELD OBJECTWINDOW REGIONMANAGER COMPARETEXT EXAMINEDEFS COMPARESOURCES 
              COMPAREDIRECTORIES PSEUDOHOSTS DATEFORMAT-EDITOR DOC-OBJECTS EQUATIONS BICLOCK 
              FILEWATCH LIFE IDLEHAX GITFNS TMAX IMTOOLS EQUATIONFORMS UNBOXEDOPS TILED-SEDIT 
              IDLEDEMO WDWHACKS BUTTONS PICK PAGEHOLD UNIXYCD))

(RPAQQ OKINTERNAL
 (MEDLEY-UTILS))
(DEFINEQ

(MAKE-EXPORTS-ALL

  (LAMBDA (OUTFILE)
                                       (* \; "Edited  3-Aug-2023 18:34 by frank")


                                                          (* \; "Edited  9-Mar-2021 16:11 by larry")

                                                             (* "Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/.  Don't know why it does the CORE/RENAME")

                                                             (* 

          "Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory.")

                                                             (* 

                        "Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")

                                                             (* 

                                                             "Edited September 29, 1986 by van Melle")

    (CNDIR (MEDLEYDIR "sources"))
    (LOAD 'FILESETS)
    (GATHEREXPORTS EXPORTFILES (OR OUTFILE "exports.all"))))

(MAKE-WHEREIS-HASH

  (LAMBDA (DRIBBLEFILE TMPFILE WHEREISFILE)
               (* \; "Edited  3-Aug-2023 18:37 by frank")


                                                            (* \; "Edited 12-Mar-2022 12:46 by rmk")


                                                          (* \; "Edited 24-Mar-2021 13:26 by larry")

    (LET ((FILING.ENUMERATION.DEPTH 2)
          HASHFILE)
         (DRIBBLE (OR DRIBBLEFILE "whereis.dribble"))
         (SETQ HASHFILE (XCL::WHERE-IS-NOTICE (OR TMPFILE "whereis.hash-tmp")
                               :FILES
                               (|for|
 X |in|
 MEDLEY-FIX-DIRS |collect|
 (CONCAT (MEDLEYDIR X)
                                                                              "*.;"))
                               :HASH-FILE-SIZE 60000 :NEW T))
         (RENAMEFILE HASHFILE (OR WHEREISFILE "whereis.hash"))
         (DRIBBLE))))
)
(DEFINEQ

(BADFILE

  (LAMBDA NIL
                                               (* \; "Edited 20-Oct-2022 15:40 by lmm")


                                                          (* \; "Edited 22-Jun-2022 09:40 by larry")

    (|pushnew|
 BADFILES *FILE*)
    (LET ((STR (OPENSTREAM "BADFILES.TXT" 'APPEND)))
         (SETFILEPTR STR -1)
         (PRINT *FILE* STR)
         (CLOSEF STR))
    (RETFROM (OR (STKPOS 'PRETTYFILES)
                 'HCFILES))))

(HCFILES

  (LAMBDA (*FILE* DEST REDOFLG TOPDIRLEN)
    (DECLARE
 (SPECVARS *FILE*)
           (GLOBALVARS BADFILE))
                            (* \; "Edited  4-Nov-2023 11:14 by lmm")


                                                            (* \; "Edited 20-Oct-2022 16:11 by lmm")


                                                            (* \; "Edited  9-Aug-2022 20:44 by lmm")

    (|if|
 (NULL *FILE*)
        |then|
 (SETQ *FILE* MEDLEYDIR))
    (COND
       ((LISTP *FILE*)
        (FOR
 X IN
 *FILE* DO
 (HCFILES
 X DEST REDOFLG TOPDIRLEN)))
       ((DIRECTORYNAMEP *FILE*)

        (* |;;| "canonicalize")


        (SETQ *FILE* (DIRECTORYNAME *FILE*))
        (OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING *FILE* 'DIRECTORY))))
        (CL:UNLESS DEST
            (|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
                                   "/tmp/psfiles/"))
            (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))

        (* |;;| "first deal with files in this directory")


        (|for|
 EXT |in|
 '("TED*" "SKETCH")
           |do|
 (|for|
 X |in|
 (DIRECTORY (CONCAT *FILE* "*." EXT ";*"))
                   |do|
 (HCFILES
 X DEST REDOFLG TOPDIRLEN)))

        (* |;;| " then deal with subdirs ")


        (|for|
 X |in|
 (DIRECTORY (CONCAT *FILE* "*"))
           |when|
 (|for|
 SKIP |in|
 '(">." ">dinfo>") |always|
 (NOT (STRPOS SKIP (L-CASE X))))
           |when|
 (DIRECTORYNAMEP X) |do|
 (HCFILES
 X DEST REDOFLG TOPDIRLEN)))
       ((SETQ *FILE* (INFILEP *FILE*))
        (LET* ((TF (UNPACKFILENAME.STRING *FILE*))
               (NAME (LISTGET TF 'NAME))
               (DIR (LISTGET TF 'DIRECTORY))
               (PSFILE (PACKFILENAME.STRING
                        'EXTENSION
                        (|if|
 (EQ REDOFLG 'IP)
                            |then|
 "IP"
                          |else|
 "PS")
                        'NAME
                        (|if|
 (EQ DEST T)
                            |then|
                           (* \; "with the tedit file")

                                  NAME
                          |else|
 (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN
                                                                                          )
                                                                           -1))))
                                        "-" NAME))
                        'HOST
                        (LISTGET TF 'HOST)
                        'DIRECTORY
                        (|if|
 (EQ DEST T)
                            |then|
 DIR
                          |else|
 DEST)))
               (TEXTSTREAM))
              (|if|
 (AND (NOT REDOFLG)
                         (INFILEP PSFILE))
                  |then|
                                     (* \; " do nothing")

                        (PRINTOUT T PSFILE " already there" T)
                |elseif|
 (EQ REDOFLG 'TEST)
                  |then|
 (PRINTOUT T *FILE* "-> " PSFILE T)
                        (CLOSEF (OPENTEXTSTREAM *FILE*))
                |elseif|
 (MEMBER *FILE* BADFILES)
                  |then|
 (PRINTOUT T "Skipping " *FILE* " on BADFILES")
                |else|
 (PRINTOUT T "Converting " *FILE* " to " PSFILE "...")
                      (TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM *FILE*))
                             PSFILE T NIL NIL NIL (|if|
 (EQ REDOFLG 'IP)
                                                      |then|
 'INTERPRESS
                                                    |else|
 'POSTSCRIPT))
                      (|printout| T " DONE" T)
                      (CLOSEF? TEXTSTREAM))))
       (T (PRINTOUT T "no such file " T)))))

(PRETTYFILES

  (LAMBDA (*FILE* DEST REDOFLG TOPDIRLEN)
    (DECLARE
 (SPECVARS *FILE*)
           (GLOBALVARS BADFILES))
                           (* \; "Edited 20-Oct-2022 16:12 by lmm")


                                                            (* \; "Edited  9-Aug-2022 20:44 by lmm")

    (|if|
 (NULL *FILE*)
        |then|
 (SETQ *FILE* MEDLEYDIR))
    (COND
       ((DIRECTORYNAMEP *FILE*)

        (* |;;| "canonicalize")


        (SETQ *FILE* (DIRECTORYNAME *FILE*))
        (OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING *FILE* 'DIRECTORY))))
        (CL:UNLESS DEST
            (|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
                                   "/tmp/psfiles/"))
            (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))

        (* |;;| "first deal with files in this directory; ignore files with extensions for now\"*.LISP\" \"*.ILISP\"")


        (|for|
 PAT |in|
 '("*.;") |do|
 (|for|
 X |in|
 (DIRECTORY (CONCAT *FILE* PAT))
                                         WHEN
 (NOT (DIRECTORYNAMEP X)) WHEN
 (INFILEP X)
                                         WHEN
 (CAR (OR (NLSETQ (LISPSOURCEFILEP X))
                                                       (PROGN (PRINTOUT T "LISPSOURCEFILEP error" X)
                                                              NIL)))
                                         |do|
 (PRETTYFILES
 X DEST REDOFLG TOPDIRLEN)))

        (* |;;| " then deal with subdirs ")


        (|for|
 X |in|
 (DIRECTORY (CONCAT *FILE* "*"))
           |when|
 (|for|
 SKIP IN
 '("clos" "cltl2" "rooms>" ".>")
                     |always|
 (NOT (STRPOS SKIP (L-CASE X)))) |when|
 (DIRECTORYNAMEP X)
           |do|
 (PRETTYFILES
 X DEST REDOFLG TOPDIRLEN)))
       ((AND (SETQ *FILE* (INFILEP *FILE*))
             (LISPSOURCEFILEP *FILE*))
        (LET* ((TF (UNPACKFILENAME.STRING *FILE*))
               (NAME (LISTGET TF 'NAME))
               (DIR (LISTGET TF 'DIRECTORY))
               (PSFILE (PACKFILENAME.STRING
                        'EXTENSION "ps" 'NAME
                        (|if|
 (EQ DEST T)
                            |then|
                           (* \; "with the source file")

                                  (CONCAT NAME ".pfi")
                          |else|
 (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN
                                                                                          )
                                                                           -1))))
                                        "-" NAME))
                        'HOST
                        (LISTGET TF 'HOST)
                        'DIRECTORY
                        (|if|
 (EQ DEST T)
                            |then|
 DIR
                          |else|
 DEST))))
              (|if|
 (AND (NOT REDOFLG)
                         (INFILEP PSFILE))
                  |then|
                                     (* \; " do nothing")

                        (PRINTOUT T PSFILE " already there" T)
                |elseif|
 (MEMBER *FILE* BADFILES)
                  |then|
 (PRINTOUT T "Skipping " *FILE* " on BADFILES")
                |else|
 (PRINTOUT T "Converting " *FILE* " to " PSFILE "...")
                      (CL:WITH-OPEN-STREAM (STR (OPENPOSTSCRIPTSTREAM PSFILE))
                             (PRETTYFILEINDEX *FILE* NIL STR))
                      (|printout| T " DONE" T))))
       (T (PRINTOUT T "no such file " T)))))
)

(RPAQ? HCFILES
 )

(RPAQ? BADFILES
 )
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (781 7744 (GATHER-INFO 791 . 6319) (MAKE-FULLER-DB 6321 . 7099) (MEDLEY-FIX-LINKS 7101
 . 7498) (MEDLEY-FIX-DATES 7500 . 7742)) (8923 10914 (MAKE-EXPORTS-ALL 8933 . 9994) (MAKE-WHEREIS-HASH
 9996 . 10912)) (10915 18894 (BADFILE 10925 . 11393) (HCFILES 11395 . 15280) (PRETTYFILES 15282 . 
18892)))))
STOP