github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-03 15:33:13 +00:00
Code Issues Projects Releases Wiki Activity

Remove derived PDFs from repo; now in 'src' repo, comstructed by HCFILES and MAKE-INDEX-HTMLS (#1657)

Browse Source 
* Remove derived PDFs from branch other than gh-pages

* only the gh-pages branch should have the pdfs

* make pdfs and listings

* Update HCFILES and MAKE-INDEX-HTMLS, add preliminary documentation

* add a slashit to avoid angle brackets
This commit is contained in:
Larry Masinter
2024-04-29 16:28:22 -07:00
committed by GitHub
parent 14b102f143
commit d79d5b397b
117 changed files with 473 additions and 468967 deletions
Download Patch File Download Diff File Expand all files Collapse all files

621
internal/MEDLEY-UTILS
View File

@@ -1,44 +1,49 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Nov-2023 21:59:19" |{DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;2| 18962
(FILECREATED "29-Apr-2024 16:25:20" {DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;9 28903
: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|)
:PREVIOUS-DATE "26-Apr-2024 16:34:08" {DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;8)
(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))))
(RPAQQ MEDLEY-UTILSCOMS
[(FNS GATHER-INFO MAKE-FULLER-DB MAKE-INDEX-HTMLS MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
(VARS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH MAKE-WHEREIS-LOOPS)
(FNS HCFILES MAKE-INDEX-HTMLS)
(PROP FILETYPE MEDLEY-UTILS)
(ADVISE TEDIT.PROMPTPRINT)
(FNS RECOMPILE-ONE RECMPL COMPILE-SETUP REMAKEFILES)
(P (READVISE TEDIT.PROMPTPRINT))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(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")
[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)))
(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)))
(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))))
[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)
(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))
@@ -47,67 +52,65 @@
LOADEDFILES)
T))
(2 (SETQ DEFINEDFNS (LET ((DEFD NIL))
(MAPATOMS (FUNCTION (CL:LAMBDA (X)
[MAPATOMS (FUNCTION (CL:LAMBDA (X)
(CL:WHEN (GETD X)
(CL:SETQ DEFD (CONS X DEFD))))))
(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)))))))
[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))))))
[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")
(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)))))
[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)))
(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)))))
(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))))
(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")
[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"))
@@ -118,17 +121,77 @@
(DUMPDATABASE NIL (MKATOM (OR DBFILE "fuller.database")))
(DRIBBLE)
(MAKESYS (OR SYSOUTFILE "fuller.sysout")
"Welcome to Fuller sysout")))
"Welcome to Fuller sysout"])
(MAKE-INDEX-HTMLS
[LAMBDA (BASE TOP) (* ; "Edited 29-Apr-2024 14:18 by lmm")
(* ; "Edited 26-Apr-2024 16:15 by lmm")
(* ; "Edited 20-Apr-2024 12:34 by lmm")
(* ; "Edited 13-Apr-2024 21:18 by lmm")
[OR BASE (SETQ BASE (PSEUDOFILENAME (MEDLEYDIR]
(OR (DIRECTORYNAMEP BASE)
(ERROR BASE "not a directory name"))
(LET* ((SUBDIRS NIL)
(DEST (PACKFILENAME 'NAME "index" 'EXTENSION "html" 'VERSION NIL 'BODY BASE))
(PSEUDOHOST (EQ (NTHCHAR BASE (CL:1- 0))
'}))
SLASHED SHORTNAME)
(CL:WITH-OPEN-FILE
(S DEST :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE)
(CL:FORMAT S "<HTML><HEAD><TITLE>Index page for ~a</TITLE></HEAD>~%%" (SETQ SLASHED
(SLASHIT BASE)))
(CL:FORMAT S "<BODY><H1>Index page for ~a</H1>~%%" SLASHED)
(CL:FORMAT S "<P>This is an index of the files just to link them in.~%%<UL>~%%")
(FOR FULLNAME IN (DIRECTORY (CONCAT BASE "*.*;"))
DO (IF (EQ (NTHCHAR FULLNAME -1)
'>)
THEN
(* ;; "A directory")
(IF (NOT (DIRECTORYNAMEP FULLNAME))
THEN (HELP "NOT DIRNAME"))
(SETQ SHORTNAME (MKATOM (SUBSTRING FULLNAME
(+ (NCHARS BASE)
(IF PSEUDOHOST
THEN 2
ELSE 1))
-2)))
(CL:UNLESS (OR (MEMB SHORTNAME '(.git))
(STRPOS ".git" FULLNAME)
(INFILEP (CONCAT FULLNAME ".skip")))
(* ;; ".skip in the directory itself -- don't index any of it")
(SETQ SUBDIRS (NCONC1 SUBDIRS FULLNAME))
(CL:FORMAT S "<LI><A HREF=%"~a/%">~a/</A></LI>~%%" SHORTNAME SHORTNAME))
ELSEIF (MEMB [SETQ SHORTNAME (MKATOM (SUBSTRING FULLNAME (ADD1 (NCHARS BASE))
(SUB1 (OR (STRPOS ".;" FULLNAME)
(STRPOS ";" FULLNAME)
(HELP
"No ; in non-directory"
]
'(index.html .skip))
THEN
(* ;; "dont index the index")
ELSEIF (MEMB (FILENAMEFIELD SHORTNAME 'EXTENSION)
'(IMPTR SKIP skip imptr))
THEN
(* ;; " don't enuerate ANY.SKIP ANY.IMPTR etc")
ELSE (CL:FORMAT S "<LI><A HREF=%"~a%">~a</A></LI>~%%" SHORTNAME SHORTNAME)))
(CL:FORMAT S "</UL></BODY></HTML>~%%"))
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE])
(MEDLEY-FIX-LINKS
(LAMBDA (UNIXPATH) (* \; "Edited 18-Jan-2021 12:01 by larry")
[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"))))
(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))))))
[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"))
@@ -153,8 +216,8 @@
(DEFINEQ
(MAKE-EXPORTS-ALL
(LAMBDA (OUTFILE) (* \; "Edited 3-Aug-2023 18:34 by frank")
(* \; "Edited 9-Mar-2021 16:11 by larry")
[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.")
@@ -164,184 +227,284 @@
 "Edited September 29, 1986 by van Melle")
(CNDIR (MEDLEYDIR "sources"))
(LOAD 'FILESETS)
(GATHEREXPORTS EXPORTFILES (OR OUTFILE "exports.all"))))
(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)
[LAMBDA (DRIBBLEFILE TMPFILE WHEREISFILE DEPTH SUBDIRS) (* ; "Edited 4-Feb-2024 21:57 by lmm")
(* ; "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 (OR 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)
"*.;"))
(for X in (OR SUBDIRS MEDLEY-FIX-DIRS)
collect (CONCAT (IF SUBDIRS
THEN X
ELSE (MEDLEYDIR X))
"*.;"))
:HASH-FILE-SIZE 60000 :NEW T))
(RENAMEFILE HASHFILE (OR WHEREISFILE "whereis.hash"))
(DRIBBLE))))
(DRIBBLE])
(MAKE-WHEREIS-LOOPS
[LAMBDA NIL (* ; "Edited 3-Apr-2024 12:12 by lmm")
(* ; "Edited 4-Feb-2024 22:29 by lmm")
(MAKE-WHEREIS-HASH "whereis-loops.dribble" NIL "whereis-loops.hash" 4 (LIST (GIT-GET-PROJECT
'LOOPS
'CLONEPATH])
)
(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*)
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 23-Apr-2024 23:15 by lmm")
(* ; "Edited 22-Apr-2024 13:22 by lmm")
(* ; "Edited 5-Feb-2024 12:16 by lmm")
(* ; "Edited 4-Nov-2023 11:14 by lmm")
(* ; "Edited 20-Oct-2022 16:11 by lmm")
(* |;;| "canonicalize")
(* ;;;; "BASE is the root directory. Doesn't replace PDF files except when REDO")
(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)))
(* ;;; " SUBSETS is some combinsyion og (:YRDY :HYML :PRETTY and INDEX")
(* |;;| "first deal with files in this directory")
(LET
[[DIRLIST (LIST (OR BASE (PSEUDOFILENAME (MEDLEYDIR]
(PHASES (OR SUBSETS '(TEDIT PRETTY INDEX HRULE]
(FILESLOAD PDFSTREAM SKETCH)
(FONTSET 'STANDARD)
(WHILE DIRLIST
DO
(SETQ BASE (POP DIRLIST))
(FOR SRCPATH IN (DIRECTORY (CONCAT BASE "*.*;"))
DO (PROG* [(SRC (UNPACKFILENAME SRCPATH))
[EXT (U-CASE (LISTGET SRC 'EXTENSION]
(DIR (LISTGET SRC 'DIRECTORY))
FRDY LDGP DEST (NOV (PACKFILENAME `(VERSION NIL ,@SRC]
(CL:FORMAT T "Starting on ~a :~%%" SRCPATH)
(CL:WHEN (DIRECTORYNAMEP SRCPATH)
(|for| EXT |in| '("TED*" "SKETCH")
|do| (|for| X |in| (DIRECTORY (CONCAT *FILE* "*." EXT ";*"))
|do| (HCFILES X DEST REDOFLG TOPDIRLEN)))
(* ;; "any directory names, push them off and do them in another phase")
(* |;;| " then deal with subdirs ")
(CL:UNLESS (OR (STRPOS ">." NOV)
(INFILEP (CONCAT NOV ".skip")))
(SETQ DIRLIST (NCONC1 DIRLIST SRCPATH)))
(RETURN))
(CL:WHEN
(MEMB EXT
'(PDF SKIP HTML LCOM DFASL SH SYSOUT DRIBBLE IMPTR DISPLAYFONT ALL
DATABASE))
(|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)))))
(* ;; "ignore any of these extensions")
(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*)
(RETURN))
(* |;;| "canonicalize")
(* ;;
 " doesnt (yet) implement / to - translattion. .readme should show up as -.readme.")
(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)))
(SETQ DEST (PACKFILENAME 'EXTENSION 'pdf 'NAME
(IF EXT
THEN (LISTGET SRC 'NAME)
ELSE (PACK* (LISTGET SRC 'NAME)
'-src))
'BODY NOV))
(CL:WHEN (AND (NOT REDO)
(INFILEP DEST))
(CL:FORMAT T "~a already there~%%" DEST)
(RETURN))
(CL:WHEN (INFILEP (CONCAT DEST ".skip"))
(PRINTOUT T "Explicit .skip " DEST T)
(RETURN))
(IF (MEMB 'TEDIT PHASES)
THEN (CL:WHEN [OR (MEMB EXT '(TEDIT TED SKETCH BRAVO))
(CAR (NLSETQ (TEDIT.FORMATTEDFILEP SRCPATH]
(IF (EQ REDO 'TEST)
THEN (CL:FORMAT T "Testing open ~a..." SRCPATH)
(CLOSEF? (OPENTEXTSTREAM SRCPATH))
ELSE (OR [NLSETQ (CL:WITH-OPEN-STREAM (S (OPENTEXTSTREAM SRCPATH)
)
(TEDIT.FORMAT.HARDCOPY S DEST T NIL NIL
NIL 'PDF]
(PRINT 'FAIL T)))
(CL:FORMAT T "DONE")))
(CL:WHEN (AND (MEMB 'PRETTY PHASES)
(MEMB EXT '(NIL IL))
[SETQ LSFP (CAR (NLSETQ (LISPSOURCEFILEP SRCPATH]
(NEQ LSFP *COMMON-LISP-READ-ENVIRONMENT*))
(PRINTOUT T "PDF printing " " to " DEST "...")
(OR (NLSETQ (CL:WITH-OPEN-STREAM (STR (OPEN-PDF-STREAM DEST))
(PRETTYFILEINDEX SRCPATH NIL STR)))
(PRINT 'FAIL T))
(PRINTOUT T "DONE" T))])
(* |;;| "first deal with files in this directory; ignore files with extensions for now\"*.LISP\" \"*.ILISP\"")
(MAKE-INDEX-HTMLS
[LAMBDA (BASE TOP) (* ; "Edited 29-Apr-2024 14:18 by lmm")
(* ; "Edited 26-Apr-2024 16:15 by lmm")
(* ; "Edited 20-Apr-2024 12:34 by lmm")
(* ; "Edited 13-Apr-2024 21:18 by lmm")
[OR BASE (SETQ BASE (PSEUDOFILENAME (MEDLEYDIR]
(OR (DIRECTORYNAMEP BASE)
(ERROR BASE "not a directory name"))
(LET* ((SUBDIRS NIL)
(DEST (PACKFILENAME 'NAME "index" 'EXTENSION "html" 'VERSION NIL 'BODY BASE))
(PSEUDOHOST (EQ (NTHCHAR BASE (CL:1- 0))
'}))
SLASHED SHORTNAME)
(CL:WITH-OPEN-FILE
(S DEST :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE)
(CL:FORMAT S "<HTML><HEAD><TITLE>Index page for ~a</TITLE></HEAD>~%%" (SETQ SLASHED
(SLASHIT BASE)))
(CL:FORMAT S "<BODY><H1>Index page for ~a</H1>~%%" SLASHED)
(CL:FORMAT S "<P>This is an index of the files just to link them in.~%%<UL>~%%")
(FOR FULLNAME IN (DIRECTORY (CONCAT BASE "*.*;"))
DO (IF (EQ (NTHCHAR FULLNAME -1)
'>)
THEN
(* ;; "A directory")
(|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)))
(IF (NOT (DIRECTORYNAMEP FULLNAME))
THEN (HELP "NOT DIRNAME"))
(SETQ SHORTNAME (MKATOM (SUBSTRING FULLNAME
(+ (NCHARS BASE)
(IF PSEUDOHOST
THEN 2
ELSE 1))
-2)))
(CL:UNLESS (OR (MEMB SHORTNAME '(.git))
(STRPOS ".git" FULLNAME)
(INFILEP (CONCAT FULLNAME ".skip")))
(* |;;| " then deal with subdirs ")
(* ;; ".skip in the directory itself -- don't index any of it")
(|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)))))
(SETQ SUBDIRS (NCONC1 SUBDIRS FULLNAME))
(CL:FORMAT S "<LI><A HREF=%"~a/%">~a/</A></LI>~%%" SHORTNAME SHORTNAME))
ELSEIF (MEMB [SETQ SHORTNAME (MKATOM (SUBSTRING FULLNAME (ADD1 (NCHARS BASE))
(SUB1 (OR (STRPOS ".;" FULLNAME)
(STRPOS ";" FULLNAME)
(HELP
"No ; in non-directory"
]
'(index.html .skip))
THEN
(* ;; "dont index the index")
ELSEIF (MEMB (FILENAMEFIELD SHORTNAME 'EXTENSION)
'(IMPTR SKIP skip imptr))
THEN
(* ;; " don't enuerate ANY.SKIP ANY.IMPTR etc")
ELSE (CL:FORMAT S "<LI><A HREF=%"~a%">~a</A></LI>~%%" SHORTNAME SHORTNAME)))
(CL:FORMAT S "</UL></BODY></HTML>~%%"))
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE])
)
(RPAQ? HCFILES )
(PUTPROPS MEDLEY-UTILS FILETYPE :COMPILE-FILE)
(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)))))
[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '((:LAST (PRIN1 MSG T)))
:AFTER
'((:LAST (AND (STRPOS "GETFN" MSG)
(HELP MSG]
(READVISE TEDIT.PROMPTPRINT)
(DEFINEQ
(RECOMPILE-ONE
[LAMBDA (FILES) (* ; "Edited 3-Apr-2024 08:12 by lmm")
(* ; "Edited 10-Feb-2024 13:31 by LMM")
(* ;; " Still working on this -- the idea is to run a sysout for compiling which has been set up to compile one file, and then logout(T) and restart.")
(* ;; " it will continue until there are no more files to compile")
(CL:WITH-OPEN-STREAM (S (OPENSTREAM (OR (INFILEP "COMPILE.DRIBBLE")
"COMPILE.DRIBBLE")
'BOTH))
(DRIBBLE S)
(BKSYSBUF " ")
(PRINTOUT T "------------------" T "SEARCHING...")
(for X in (OR FILES SYSFILES) when (MEMB (GET X 'FILETYPE)
'(CL:COMPILE-FILE :COMPILE-FILE))
when [NOT (INFILEP (CONCAT X '.DFASL] do (PRINTOUT T "Compiling " X T "")
(DOFILESLOAD (LIST X))
(LOAD X 'PROP)
(COPYFILE (FINDFILE X)
X)
(FOR V IN (CL:VALUES-LIST (CL:COMPILE-FILE
X))
DO (PRINT V))
(CL:FORCE-OUTPUT (DRIBBLEFILE)
T)
(DRIBBLE)
(RETURN) FINALLY (HELP "NO MORE"])
(RECMPL
[LAMBDA (FILES) (* ; "Edited 17-Feb-2024 15:39 by lmm")
(* ; "Edited 8-Feb-2024 19:24 by lmm")
(LET ((*PRINT-CASE* :DOWNCASE)
SRC DESTPREV (PRETTYFLG T)
(*PRINT-BASE* 10))
(CNDIR)
(for X in (OR FILES SYSFILES) do (IF (SETQ SRC (INFILEP (CONCAT SRCDIR X ".ilsp")))
THEN (APPLY* (COMPILE-FILE? SRC)
SRC])
(COMPILE-SETUP
[LAMBDA NIL (* ; "Edited 17-Feb-2024 08:23 by lmm")
(* ; "Edited 9-Feb-2024 16:15 by larry")
(* ;; "first set up compile environment")
(FILESLOAD SYSEDIT)
(* ;; " load in necessary packages")
(FILESLOAD MEDLEY-UTILS)
(CLRHASH CLISPARRAY) (* ;
 "clear out cache of file package translations")
(FILESLOAD WHERE-IS MEDLEY-UTILS GITFNS FILEBROWSER])
(REMAKEFILES
[LAMBDA (FILES) (* ; "Edited 8-Feb-2024 07:47 by lmm")
(LET ((*PRINT-CASE* :DOWNCASE)
WIN DIFF (PRETTYFLG T)
(*PRINT-BASE* 10))
(for X in (OR FILES 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))
(MAKEFILE (MKATOM (SETQ DESTFILE (CONCAT (L-CASE X)
".ilsp")))
'(NEW))
(SETQ DIFF (COMPARESOURCES X DESTFILE NIL))
(TERPRI])
)
(READVISE TEDIT.PROMPTPRINT)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1064 11630 (GATHER-INFO 1074 . 6456) (MAKE-FULLER-DB 6458 . 7235) (MAKE-INDEX-HTMLS
7237 . 10999) (MEDLEY-FIX-LINKS 11001 . 11394) (MEDLEY-FIX-DATES 11396 . 11628)) (12809 15597 (
MAKE-EXPORTS-ALL 12819 . 13878) (MAKE-WHEREIS-HASH 13880 . 15069) (MAKE-WHEREIS-LOOPS 15071 . 15595))
(15598 23855 (HCFILES 15608 . 20089) (MAKE-INDEX-HTMLS 20091 . 23853)) (24105 28717 (RECOMPILE-ONE
24115 . 26012) (RECMPL 26014 . 26617) (COMPILE-SETUP 26619 . 27243) (REMAKEFILES 27245 . 28715)))))
STOP

BIN
internal/MEDLEY-UTILS.DFASL Normal file
View File

Binary file not shown.

BIN
internal/MEDLEY-UTILS.LCOM
View File

Binary file not shown.