diff --git a/internal/MEDLEY-UTILS b/internal/MEDLEY-UTILS index 8f32114e2..143d15c3f 100644 --- a/internal/MEDLEY-UTILS +++ b/internal/MEDLEY-UTILS @@ -1,27 +1,29 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "28-Jan-2026 11:03:17" {DSK}larry>il>medley>internal>MEDLEY-UTILS.;3 26880 +(FILECREATED "16-Apr-2026 22:42:51" {DSK}matt>Interlisp>medley>internal>MEDLEY-UTILS.;2 30564 - :EDIT-BY "lmm" + :EDIT-BY "mth" - :CHANGES-TO (FNS MAKE-INDEX-HTMLS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES - MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH MAKE-WHEREIS-LOOPS HCFILES RECOMPILE-ONE - RECMPL COMPILE-SETUP REMAKEFILES) + :CHANGES-TO (FNS HCFILES MAKE-EXPORTS-ALL MAKE-INDEX-HTMLS) + (FUNCTIONS REPORT-AND-GO) + (VARS MEDLEY-UTILSCOMS HC-SKIP-EXTENSIONS) (ADVICE TEDIT.PROMPTPRINT) - :PREVIOUS-DATE "28-Jan-2026 10:46:02" {DSK}larry>il>medley>internal>MEDLEY-UTILS.;1) + :PREVIOUS-DATE "16-Apr-2026 22:27:40" {DSK}matt>Interlisp>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) + (VARS HC-SKIP-EXTENSIONS 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) + (FUNCTIONS REPORT-AND-GO) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) @@ -140,6 +142,12 @@ (for X in (OR DIRS MEDLEY-FIX-DIRS) join (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T]) ) +(RPAQQ HC-SKIP-EXTENSIONS + (PDF SKIP HTML LCOM DFASL SH SYSOUT DRIBBLE IMPTR DISPLAYFONT WD WIDTHS MEDLEYDISPLAYFONT + PSCFONT ALL DATABASE 1 MD GZ PRESS IP BITMAP EL ELC XFORMS BUGREPORTS SUITE LISTING AWK + DINFOGRAPH HASHFILE BLTCHAR DOC DOCPOINTERS STATUS NOTEFILE ICO ISS BMP PNG PS1 + VENUESYSOUT ACE FMC HKB LGC CMD COMMAND HTM SVG XML EXE)) + (RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal" "greetfiles" "doctools")) (RPAQQ OKSOURCES (RENAMEFNS VMEM READSYS CASH-FILE HASH-FILE MEDLEYDIR MAKEINIT)) @@ -162,15 +170,18 @@ (DEFINEQ (MAKE-EXPORTS-ALL - [LAMBDA (OUTFILE) (* ; "Edited 3-Aug-2023 18:34 by frank") + [LAMBDA (OUTFILE) (* ; "Edited 15-Apr-2026 16:42 by mth") + (* ; "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") + + (* ;; "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"]) @@ -204,7 +215,8 @@ (DEFINEQ (HCFILES - [LAMBDA (BASE REDO SUBSETS) (* ; "Edited 30-Jun-2024 08:27 by lmm") + [LAMBDA (BASE REDO SUBSETS) (* ; "Edited 16-Apr-2026 22:42 by mth") + (* ; "Edited 30-Jun-2024 08:27 by lmm") (* ; "Edited 23-Apr-2024 23:15 by lmm") (* ; "Edited 22-Apr-2024 13:22 by lmm") (* ; "Edited 5-Feb-2024 12:16 by lmm") @@ -213,74 +225,116 @@ (* ;;;; "BASE is the root directory. Doesn't replace PDF files except when REDO") -(* ;;; " SUBSETS is some combinsyion og (:YRDY :HYML :PRETTY and INDEX") - - (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) - - (* ;; "any directory names, push them off and do them in another phase") - - (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)) - - (* ;; "ignore any of these extensions") - - (RETURN)) - - (* ;; - " doesnt (yet) implement / to - translattion. .readme should show up as -.readme.") - - (SETQ DEST (CONCAT NOV ".pdf")) - (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))]) +(* ;;; " SUBSETS is some combination of (:YRDY :HYML :PRETTY and INDEX") + + (LET* ([DIRLIST (LIST (OR BASE (PSEUDOFILENAME (MEDLEYDIR] + [PHASES (OR SUBSETS '(TEDIT PRETTY INDEX HRULE] + (DOTEDIT (MEMB 'TEDIT PHASES)) + (DOPRETTY (MEMB 'PRETTY PHASES))) + (FILESLOAD PDFSTREAM SKETCH) + (FONTSET 'STANDARD) + (while DIRLIST + do (SETQ BASE (pop DIRLIST)) + + (* ;; "Breadth-first processing") + + (for SRCPATH in (DIRECTORY (CONCAT BASE "*.*;")) + do (PROG* ((SRC (UNPACKFILENAME SRCPATH)) + [EXT (U-CASE (LISTGET SRC 'EXTENSION] + (DIR (LISTGET SRC 'DIRECTORY)) + [NAME (U-CASE (LISTGET SRC 'NAME] + [NOV (PACKFILENAME.STRING `(VERSION NIL ,@SRC] + LSFP DEST) + (CL:WHEN (DIRECTORYNAMEP SRCPATH) + + (* ;; + "any directory names, push them off and do them in another phase") + + (if [NOT (OR (STRPOS "<." NOV) + (CL:SEARCH "" NOV :TEST #'CL:CHAR-EQUAL) + (STRPOS ">." NOV) + (INFILEP (CONCAT NOV ".skip"] + then (SETQ DIRLIST (NCONC1 DIRLIST SRCPATH)) + (CL:FORMAT T "~&Deferring to later ~a~%%" SRCPATH) + else (CL:FORMAT T "~&Skipping ~a~%%" SRCPATH)) + (RETURN)) + + (* ;; "Fixup files that start with . and have no other extension") + + (CL:WHEN (AND (NULL EXT) + (EQ (CHCON1 NAME) + (CHARCODE %.))) + (SETQ EXT (SUBATOM NAME 2))) + (CL:WHEN (MEMB EXT HC-SKIP-EXTENSIONS) + + (* ;; "ignore any of these extensions") + + (CL:FORMAT T "~&Ignoring (on extension): ~a~%%" SRCPATH) + (RETURN)) + + (* ;; + " doesn't (yet) implement / to - translation. .readme should show up as -.readme.") + + (SETQ DEST (CONCAT NOV ".pdf")) + (CL:WHEN (AND (NOT REDO) + (INFILEP DEST)) + (CL:FORMAT T "~a is already there~%%" DEST) + (RETURN)) + (CL:WHEN (INFILEP (CONCAT DEST ".skip")) + (CL:FORMAT T "Explicit .skip ~a~%%" DEST) + (RETURN)) + (CL:FORMAT T "~&Starting on ~a:~%%" SRCPATH) + (CL:WHEN [AND DOTEDIT (OR (MEMB EXT '(TEDIT TED SKETCH BRAVO)) + (CAR (REPORT-AND-GO (TEDIT.FORMATTEDFILEP + SRCPATH) + (CL:FORMAT NIL + "~~%%~S TEDIT.FORMATTEDFILEP of ~A -- Condition: ~~A" + 'FAIL SRCPATH] + (if (EQ REDO 'TEST) + then (CL:FORMAT T "Testing open ~a..." SRCPATH) + (CLOSEF? (OPENTEXTSTREAM SRCPATH)) + else (REPORT-AND-GO (CL:WITH-OPEN-STREAM (S (OPENTEXTSTREAM + SRCPATH)) + (TEDIT.FORMAT.HARDCOPY S DEST T NIL NIL + NIL 'PDF)) + (CL:FORMAT NIL + "~~%%~S TEDIT.FORMAT.HARDCOPY of ~A -- Condition: ~~A" + 'FAIL SRCPATH))) + (PRIN3 " DONE" T) + (TERPRI T) + (RETURN)) + (CL:WHEN (AND DOPRETTY (OR (NULL EXT) + (EQ EXT 'IL)) + [SETQ LSFP (CAR (REPORT-AND-GO (LISPSOURCEFILEP SRCPATH) + (CL:FORMAT NIL + "~~%%~S LISPSOURCEFILEP of ~A -- Condition: ~~A" + 'FAIL SRCPATH] + (NEQ LSFP *COMMON-LISP-READ-ENVIRONMENT*)) + + (* ;; "Why the check for NEQ *COMMON-LISP-READ-ENVIRONMENT* ??") + + (PRIN3 "PDF printing " T) + (PRIN3 SRCPATH T) + (PRIN3 " to " T) + (PRIN3 DEST T) + (PRIN3 " ..." T) + (REPORT-AND-GO (CL:WITH-OPEN-STREAM (STR (OPEN-PDF-STREAM DEST)) + (PRETTYFILEINDEX SRCPATH NIL STR)) + (CL:FORMAT NIL + "~~%%~S PRETTYFILEINDEX of ~A -- Condition: ~~A" + 'FAIL SRCPATH)) + (PRIN3 " DONE" T) + (TERPRI T) + (RETURN)) + + (* ;; "Everything else") + + (PRIN3 "No processing." T) + (TERPRI T]) (MAKE-INDEX-HTMLS - [LAMBDA (BASE TOP LEVEL ROOT.NAME) (* ; "Edited 28-Jan-2026 11:01 by lmm") + [LAMBDA (BASE TOP LEVEL ROOT.NAME) (* ; "Edited 15-Apr-2026 16:33 by mth") + (* ; "Edited 28-Jan-2026 11:01 by lmm") (* ; "Edited 27-Jan-2026 10:50 by lmm") (* ; "Edited 23-Jan-2026 11:59 by lmm") (* ; "Edited 29-Apr-2024 14:18 by lmm") @@ -339,8 +393,8 @@ then 2 else 1)) -2))) - (CL:UNLESS (OR (MEMB SHORTNAME '(.git)) - (MEMB SHORTNAME '(.GIT)) + (CL:UNLESS (OR (EQ SHORTNAME '.git) + (EQ SHORTNAME '.GIT) [AND (STRPOS ".git" (L-CASE FULLNAME)) (NOT (STRPOS ".github" (L-CASE FULLNAME] (INFILEP (CONCAT FULLNAME ".skip"))) @@ -372,7 +426,8 @@ (PUTPROPS MEDLEY-UTILS FILETYPE :COMPILE-FILE) -[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '((:LAST (PRIN1 MSG T))) +[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '[(:LAST (PROGN (PRIN3 " " T) + (PRIN3 MSG T] :AFTER '((:LAST (AND (STRPOS "GETFN" MSG) (HELP MSG] @@ -463,6 +518,15 @@ (SETQ DIFF (COMPARESOURCES X DESTFILE NIL)) (TERPRI]) ) + +(DEFMACRO REPORT-AND-GO (FORM REPORT-FORMAT) (* ; "Edited 16-Apr-2026 16:02 by mth") + `[CL:MULTIPLE-VALUE-BIND (FORM-RESULT ERROR-CONDITION) + (IGNORE-ERRORS (CL:VALUES ,FORM)) (* ; "Only the first value") + (COND + (ERROR-CONDITION (PRIN3 (CL:FORMAT NIL ,REPORT-FORMAT ERROR-CONDITION) + T) + NIL) + (T (LIST FORM-RESULT]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) @@ -472,9 +536,10 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1312 8246 (GATHER-INFO 1322 . 6704) (MAKE-FULLER-DB 6706 . 7615) (MEDLEY-FIX-LINKS 7617 - . 8010) (MEDLEY-FIX-DATES 8012 . 8244)) (9425 12213 (MAKE-EXPORTS-ALL 9435 . 10494) ( -MAKE-WHEREIS-HASH 10496 . 11685) (MAKE-WHEREIS-LOOPS 11687 . 12211)) (12214 21862 (HCFILES 12224 . -16487) (MAKE-INDEX-HTMLS 16489 . 21860)) (22112 26724 (RECOMPILE-ONE 22122 . 24019) (RECMPL 24021 . -24624) (COMPILE-SETUP 24626 . 25250) (REMAKEFILES 25252 . 26722))))) + (FILEMAP (NIL (1289 8223 (GATHER-INFO 1299 . 6681) (MAKE-FULLER-DB 6683 . 7592) (MEDLEY-FIX-LINKS 7594 + . 7987) (MEDLEY-FIX-DATES 7989 . 8221)) (9795 12371 (MAKE-EXPORTS-ALL 9805 . 10652) ( +MAKE-WHEREIS-HASH 10654 . 11843) (MAKE-WHEREIS-LOOPS 11845 . 12369)) (12372 24990 (HCFILES 12382 . +19514) (MAKE-INDEX-HTMLS 19516 . 24988)) (25324 29936 (RECOMPILE-ONE 25334 . 27231) (RECMPL 27233 . +27836) (COMPILE-SETUP 27838 . 28462) (REMAKEFILES 28464 . 29934)) (29938 30408 (REPORT-AND-GO 29938 . +30408))))) STOP diff --git a/internal/MEDLEY-UTILS.DFASL b/internal/MEDLEY-UTILS.DFASL index 00401e75e..d375d4f36 100644 Binary files a/internal/MEDLEY-UTILS.DFASL and b/internal/MEDLEY-UTILS.DFASL differ diff --git a/scripts/do_hcfiles.sh b/scripts/do_hcfiles.sh index 0246a0db0..f32f61dee 100755 --- a/scripts/do_hcfiles.sh +++ b/scripts/do_hcfiles.sh @@ -57,7 +57,12 @@ main() { # save dribble file to loadups; extract and save fails "${MEDLEYDIR}"/scripts/cpv ${logindir}/HCFILES.DRIBBLE "${MEDLEYDIR}"/loadups/hcfiles.dribble - grep "IL:FAIL" < "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails + if [ -f "$(command -v perl)" ] && [ -x "$(command -v perl)" ] + then + perl "${MEDLEYDIR}"/scripts/getFails.pl '^[^\n]*IL:FAIL' 'DONE' "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails + else + echo Unable to extract FAIL information from "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails + fi "${MEDLEYDIR}"/scripts/cpv ${logindir}/fails "${MEDLEYDIR}"/loadups/hcfiles-fails.txt # cleanup diff --git a/scripts/getFails.pl b/scripts/getFails.pl new file mode 100644 index 000000000..4c1fea8da --- /dev/null +++ b/scripts/getFails.pl @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +die "Usage: $0 [file...]\n" unless @ARGV >= 2; + +my $pat1 = shift; +my $pat2 = shift; +my $regex1line = qr/${pat1}.*?${pat2}/; # all on 1 line +my $regexStart = qr/${pat1}/; # the line has the start pattern +my $regexEnd = qr/${pat2}/; # the line has the end pattern + +my $flag = 0; + +while (<>) { + if ($flag) { # we're in a multi-line block + print; + if (/$regexEnd/) { # does this line end the multi-line block? + $flag = 0; + print "\n"; # separator + }; + } + elsif (/$regex1line/) { # all on 1 line + print; + print "\n"; # separator + } + elsif (/$regexStart/) { # begin a multi-line block + print; + $flag = 1; + } +} \ No newline at end of file