github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-05-06 08:02:36 +00:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into rmk175--Offline-font-construction

Browse Source
This commit is contained in:
rmkaplan
2026-04-29 23:05:35 -07:00
parent bfbaeed7ee 4e761298ea
commit e589a8b75a
5 changed files with 186 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

233
internal/MEDLEY-UTILS
View File

@@ -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}<Users>larry>il>medley>internal>MEDLEY-UTILS.;3 26880
(FILECREATED "16-Apr-2026 22:42:51" {DSK}<home>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}<Users>larry>il>medley>internal>MEDLEY-UTILS.;1)
:PREVIOUS-DATE "16-Apr-2026 22:27:40" {DSK}<home>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")
(* ;;; " SUBSETS is some combination of (: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)
(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))
(* ;; "any directory names, push them off and do them in another phase")
(* ;; "Breadth-first processing")
(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 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)
(* ;; "ignore any of these extensions")
(* ;;
 "any directory names, push them off and do them in another phase")
(RETURN))
(if [NOT (OR (STRPOS "<." NOV)
(CL:SEARCH "<LOADUPS>" 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))
(* ;;
 " doesnt (yet) implement / to - translattion. .readme should show up as -.readme.")
(* ;; "Fixup files that start with . and have no other extension")
(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))])
(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

BIN
internal/MEDLEY-UTILS.DFASL
View File

Binary file not shown.

BIN
lispusers/BITMAP-GALLERY.TEDIT
View File

Binary file not shown.

7
scripts/do_hcfiles.sh
View File

@@ -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

31
scripts/getFails.pl Normal file
View File

@@ -0,0 +1,31 @@
#!/usr/bin/env perl
use strict;
use warnings;
die "Usage: $0 <pattern1> <pattern2> [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;
}
}