Merge branch 'master' into mth71--DATABASEFNS_another_ROOTFILENAME_vs_NAMEFIELD_error
This commit is contained in:
Matt Heffron
877
library/IMPORTFONTS
Normal file
877
library/IMPORTFONTS
Normal file
@@ -0,0 +1,877 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
|
||||
|
||||
(FILECREATED " 5-May-2026 12:21:37" {MEDLEY}<library>IMPORTFONTS.;116 58246
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS PEF)
|
||||
|
||||
:PREVIOUS-DATE " 4-May-2026 15:26:51" {MEDLEY}<library>IMPORTFONTS.;115)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IMPORTFONTSCOMS)
|
||||
|
||||
(RPAQQ IMPORTFONTSCOMS
|
||||
((FNS IMPORTFONTS FONT.TO.MCCS IMPORTFONTS.FONTSPECS IMPORTFONTS.CONTEXT IMPORTFONTS.NOCACHE
|
||||
IMPORTFONTS.DIRECTORY IMPORTFONTS.CLEAR IMPORTFONTS.SUBDIR IMPORTFONTS.DIRSIZE)
|
||||
(FNS IMPORTFONTS.AVAILABLE IMPORTFONTS.EXISTS?)
|
||||
(FNS FAKEFACE FAKEFACE.FROMFILE FAKEFACE.FROMFONT)
|
||||
(COMS (* ; "For legacy display imports")
|
||||
(FNS IMPORT.DISPLAY LEGACYDISPLAYFONT)
|
||||
(FILES ACFONT))
|
||||
(COMS (* ; "For testing")
|
||||
(FNS IPF IPFSIZES)
|
||||
(FNS PEF AEF IEF MEF CEF FEF DEF EFCLOSE)
|
||||
(FNS SHOWCHARS CSSOURCE FONTDEFFONTS)
|
||||
(FILES EDITFONT))))
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORTFONTS
|
||||
[LAMBDA (PHASE FONTSPECS DEVICE FROMDIR TODIR IMPORTFN NODRIBBLE)
|
||||
(* ; "Edited 4-May-2026 13:49 by rmk")
|
||||
(* ; "Edited 11-Apr-2026 10:55 by rmk")
|
||||
(* ; "Edited 5-Apr-2026 14:22 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 08:15 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 08:25 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 16:41 by rmk")
|
||||
(* ; "Edited 29-Mar-2026 11:33 by rmk")
|
||||
(* ; "Edited 26-Mar-2026 12:47 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 15:00 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 11:16 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 09:44 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 15:56 by rmk")
|
||||
|
||||
(* ;; "Device-dependent IMPORTFN must be provided if PHASE is IMPORT, the other phases (MCCS, COMPLETE, FAKE) operate on Medleyfont files.")
|
||||
|
||||
(* ;; "If PHASE is MCCS, recodes source FONTSPECS to MCCS without completion, otherwise coerces/completes the specified MCCS fonts.")
|
||||
|
||||
(* ;; "Unless TODIRECTORY=DONT, writes the resultiing fonts Medley fontfiles, otherwise collects and returns them in a list (which will eat up storage). ")
|
||||
|
||||
(CL:UNLESS (MEMB (SETQ PHASE (U-CASE PHASE))
|
||||
'(IMPORT MCCS COMPLETE FAKE DEPLOY))
|
||||
(\ILLEGAL.ARG PHASE))
|
||||
(CL:UNLESS DEVICE
|
||||
(SETQ DEVICE 'DISPLAY))
|
||||
(CL:WHEN (AND (EQ PHASE 'IMPORT)
|
||||
(NOT (GETD IMPORTFN)))
|
||||
(ERROR "Importing from source requires an IMPORTFN"))
|
||||
(PROG1
|
||||
(RESETLST (* ;
|
||||
"Close dribble outside of this context")
|
||||
(CL:MULTIPLE-VALUE-SETQ (FROMDIR TODIR)
|
||||
(IMPORTFONTS.CONTEXT PHASE FROMDIR TODIR DEVICE))
|
||||
(IMPORTFONTS.CLEAR PHASE FONTSPECS TODIR DEVICE)
|
||||
(SETQ FONTSPECS (IMPORTFONTS.FONTSPECS PHASE FONTSPECS FROMDIR DEVICE))
|
||||
(CL:WHEN (AND (IGEQ (LENGTH FONTSPECS)
|
||||
5)
|
||||
(NOT NODRIBBLE)) (* ;
|
||||
"Put all the dribbles together one up")
|
||||
[DRIBBLE (PSEUDOFILENAME (PACKFILENAME 'BODY
|
||||
(OR (SUBSTRING TODIR 1
|
||||
(STRPOS ">" TODIR -2 NIL NIL NIL NIL T))
|
||||
LOGINHOST/DIR)
|
||||
'NAME PHASE 'EXTENSION 'DRIBBLE]
|
||||
(PRINTOUT T "Dribbling to " (FULLNAME (DRIBBLEFILE))
|
||||
T))
|
||||
(PRINTOUT T (SELECTQ PHASE
|
||||
(IMPORT "Importing ")
|
||||
(MCCS "MCCS recoding ")
|
||||
(COMPLETE "Completing ")
|
||||
(FAKE "Faking ")
|
||||
(DEPLOY "Deploying ")
|
||||
NIL)
|
||||
(LENGTH FONTSPECS)
|
||||
" " DEVICE " font" (CL:IF (IGEQ (LENGTH FONTSPECS)
|
||||
2)
|
||||
"s"
|
||||
""))
|
||||
(if TODIR
|
||||
then (PRINTOUT T 3 "from " FROMDIR 3 "to " TODIR T)
|
||||
else (PRINTOUT T " from " FROMDIR T 3 "(but not writing)" T))
|
||||
(BKSYSBUF " ")
|
||||
(IMPORTFONTS.CLEAR PHASE FONTSPECS TODIR DEVICE)
|
||||
(for FS FONT FONT FONTSTART TOFILE FROMFILE CAPTIONS THISTIME FROMSIZE TOSIZE CHANGED
|
||||
NOTINSTANTIATED TOTALTIME TODIRSIZE (FROMDIRSIZE ← (CL:IF (EQ PHASE 'IMPORT)
|
||||
0
|
||||
(IMPORTFONTS.DIRSIZE PHASE
|
||||
DEVICE FROMDIR)))
|
||||
(NNOCHARSETS ← 0) in FONTSPECS as I from 1 first (SETQ TOTALTIME (CLOCK 0))
|
||||
eachtime (PRINTOUT T .I3 I ". " (fetch (FONTSPEC FSFAMILY) of FS)
|
||||
" " .I2 (fetch (FONTSPEC FSSIZE) of FS)
|
||||
" "
|
||||
(FONTFACETOATOM (fetch (FONTSPEC FSFACE) of FS)))
|
||||
(SETQ THISTIME (CLOCK 0))
|
||||
collect (SELECTQ PHASE
|
||||
(IMPORT (SETQ FONT (APPLY* IMPORTFN FS FROMDIR))
|
||||
(SETQ CHANGED T))
|
||||
((MCCS COMPLETE)
|
||||
(SETQ FROMFILE (INFILEP (MEDLEYFONT.FILENAME FS FROMDIR)))
|
||||
(if FROMFILE
|
||||
then (SETQ FONT (MEDLEYFONT.READ.FONT FROMFILE 'ALL))
|
||||
(SETQ FROMSIZE (GETFILEINFO FROMFILE 'LENGTH))
|
||||
else (SETQ FONT (FONTCREATE.SLUGFD FS))
|
||||
(SETQ FROMSIZE 0))
|
||||
(SETQ CHANGED (SELECTQ PHASE
|
||||
(MCCS (FONT.TO.MCCS FONT))
|
||||
(COMPLETE (COMPLETE.FONT FONT T))
|
||||
NIL)))
|
||||
(FAKE (CL:MULTIPLE-VALUE-SETQ (FONT FROMFILE)
|
||||
(FAKEFACE.FROMFONT FS FROMDIR))
|
||||
(SETQ FROMSIZE (GETFILEINFO FROMFILE 'LENGTH))
|
||||
(SETQ CHANGED (FAKEFACE FONT)))
|
||||
(DEPLOY (SETQ FROMFILE (MEDLEYFONT.FILENAME FS FROMDIR))
|
||||
(SETQ FROMSIZE (GETFILEINFO FROMFILE 'LENGTH)))
|
||||
NIL)
|
||||
(CL:WHEN [SETQ NOTINSTANTIATED (EQ 0 (FONTPROP FONT 'NINSTANTIATEDCHARSETS]
|
||||
(add NNOCHARSETS 1))
|
||||
(CL:WHEN TODIR
|
||||
(SETQ TOFILE (MEDLEYFONT.FILENAME FS TODIR))
|
||||
(SETQ TOFILE (CL:IF CHANGED
|
||||
(MEDLEYFONT.WRITE.FONT FONT TOFILE)
|
||||
(COPYFILE FROMFILE TOFILE))))
|
||||
(SETQ THISTIME (FQUOTIENT (IDIFFERENCE (CLOCK 0)
|
||||
THISTIME)
|
||||
1000))
|
||||
(if NOTINSTANTIATED
|
||||
then (PRINTOUT T 26 "No instantiated charsets" 41 .F7.2 THISTIME)
|
||||
elseif TOFILE
|
||||
then (SETQ TOSIZE (GETFILEINFO TOFILE 'LENGTH))
|
||||
(SELECTQ PHASE
|
||||
(IMPORT (PRINTOUT T 25 .I6 TOSIZE " " .F7.2 THISTIME))
|
||||
((MCCS COMPLETE FAKE DEPLOY)
|
||||
(if CHANGED
|
||||
then (PRINTOUT T 25 .I6 FROMSIZE " -> " .I6 TOSIZE " "
|
||||
.F6.2 THISTIME 50 .I5 (IDIFFERENCE TOSIZE
|
||||
FROMSIZE))
|
||||
else (PRINTOUT T 28 "Copied " .I6 TOSIZE " " .F6.2 THISTIME)
|
||||
))
|
||||
NIL))
|
||||
(TERPRI T)
|
||||
(CL:IF TODIR
|
||||
TOFILE
|
||||
FONT) finally (SETQ TOTALTIME (FIXR (FQUOTIENT (IDIFFERENCE (CLOCK 0)
|
||||
TOTALTIME)
|
||||
1000)))
|
||||
(PRINTOUT T 4 (IDIFFERENCE (LENGTH $$VAL)
|
||||
NNOCHARSETS)
|
||||
" font"
|
||||
(CL:IF (IGEQ (LENGTH $$VAL)
|
||||
2)
|
||||
"s "
|
||||
" ")
|
||||
(SELECTQ PHASE
|
||||
(IMPORT "imported")
|
||||
(MCCS "recoded to MCCS")
|
||||
(COMPLETE "completed")
|
||||
(FAKE "faked")
|
||||
(DEPLOY "deployed")
|
||||
NIL))
|
||||
(if TODIR
|
||||
then (SETQ TODIRSIZE (IMPORTFONTS.DIRSIZE PHASE DEVICE TODIR
|
||||
))
|
||||
(PRINTOUT T " and written in " TOTALTIME " seconds" 4
|
||||
"Total size is " (FIXR (FQUOTIENT TODIRSIZE 1024
|
||||
))
|
||||
" KB, grew by "
|
||||
(FIXR (FQUOTIENT (IDIFFERENCE TODIRSIZE
|
||||
FROMDIRSIZE)
|
||||
1024))
|
||||
" KB" T)
|
||||
(CL:UNLESS (EQ 0 NNOCHARSETS)
|
||||
(PRINTOUT T 4 NNOCHARSETS
|
||||
" fonts had no character sets" T))
|
||||
(CL:WHEN (AND TODIR (IGEQ (LENGTH $$VAL)
|
||||
5))
|
||||
(SETQ $$VAL TODIR))
|
||||
else (PRINTOUT T " (but not written) in " TOTALTIME " seconds"
|
||||
T))))
|
||||
(CL:WHEN (DRIBBLEFILE)
|
||||
(PRINTOUT T "Dribbled to " (FULLNAME (DRIBBLEFILE))
|
||||
T)
|
||||
[TEDIT (DRIBBLE)
|
||||
'Dribble NIL `(TITLE ,(CONCAT PHASE " font dribble" " " (DATE))
|
||||
LEAVETTY T READONLY QUIET PARABREAKCHARS NIL FONT DEFAULTFONT
|
||||
OPENWIDTH ,(fetch (REGION WIDTH) of (WINDOWPROP (WFROMDS
|
||||
T)
|
||||
'REGION))
|
||||
OPENHEIGHT
|
||||
,(fetch (REGION HEIGHT) of (WINDOWPROP (WFROMDS T)
|
||||
'REGION]))])
|
||||
|
||||
(FONT.TO.MCCS
|
||||
[LAMBDA (FONT) (* ; "Edited 11-Apr-2026 15:43 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 00:23 by rmk")
|
||||
(* ; "Edited 7-Mar-2026 12:55 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 13:43 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 17:13 by rmk")
|
||||
(* ; "Edited 6-Sep-2025 16:43 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 15:20 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 11:25 by rmk")
|
||||
(* ; "Edited 27-Aug-2025 17:36 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Move character information in font to their MCCS positions, with coercions otherwise suppressed. ")
|
||||
|
||||
(* ;; "If there are no mappings, prints a message and returns INFONT.")
|
||||
|
||||
(LET [(PAIRS (MCCSMAPPAIRS (FONTPROP FONT 'CHARENCODING]
|
||||
(CL:WHEN PAIRS
|
||||
(MOVEFONTCHARS PAIRS FONT FONT)
|
||||
(replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL)
|
||||
|
||||
(* ;; "Keep the map function even for coerced MCCS fonts--can still be used for code conversion (e.g. Tedit file updating) ")
|
||||
|
||||
[replace (FONTDESCRIPTOR FONTTOMCCSFN) of FONT with (MCCSMAPFN (FONTPROP FONT
|
||||
'CHARENCODING]
|
||||
(CL:WHEN (MEMB (FONTPROP FONT 'CHARENCODING)
|
||||
'(GACHA XCCS$ ALTOTEXT PALATINO UNICODE HIPPO CYRILLIC))
|
||||
(replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with 'MCCS)
|
||||
(* ; "These fonts made it all the way")
|
||||
(CHARSETPROP (\GETCHARSETINFO FONT 0)
|
||||
'CSCHARENCODING
|
||||
'MCCS))
|
||||
FONT)])
|
||||
|
||||
(IMPORTFONTS.FONTSPECS
|
||||
[LAMBDA (PHASE FONTSPECS FROMDIR DEVICE) (* ; "Edited 4-May-2026 08:59 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 11:41 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 00:51 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 12:50 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 23:27 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 08:58 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:50 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:53 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 10:44 by rmk")
|
||||
|
||||
(* ;; "Crucially, the fontspecs for COMPLETE and FAKEFACE must be ordered so that coercions or faces come before the fontspecs that depend on them. E.g. the order of faces has to be MRR MIR/BRR BIR. That means that the TODIR can be the source for the completion/faking of later fonts.")
|
||||
|
||||
(CL:UNLESS DEVICE
|
||||
(SETQ DEVICE 'DISPLAY))
|
||||
(SETQ FROMDIR (IMPORTFONTS.DIRECTORY DEVICE FROMDIR PHASE))
|
||||
(RESETLST
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES FROMDIR)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(LET [(EXPANDED (CL:REMOVE-DUPLICATES
|
||||
(for F inside (CL:IF (type? FONTSPEC FONTSPECS)
|
||||
(CONS FONTSPECS)
|
||||
(OR FONTSPECS '*))
|
||||
join (if (type? FONTSPEC F)
|
||||
then (for FACE in (FONTFACE.STARS (fetch (FONTSPEC FSFACE)
|
||||
of (\FONT.CHECKARGS F)))
|
||||
collect (create FONTSPEC
|
||||
using F FSFACE ← FACE FSDEVICE ← DEVICE
|
||||
FSROTATION ← 0))
|
||||
elseif (LITATOM F)
|
||||
then
|
||||
(* ;; "Looks in FROMDIR")
|
||||
|
||||
(IMPORTFONTS.AVAILABLE PHASE (MAKEFONTSPEC
|
||||
(OR F '*)
|
||||
'*
|
||||
'* 0 DEVICE)
|
||||
FROMDIR)
|
||||
else (\ILLEGAL.ARG F)))
|
||||
:TEST
|
||||
(FUNCTION EQUAL]
|
||||
(SELECTQ PHASE
|
||||
(COMPLETE
|
||||
(* ;; "Fonts have to be ordered so that a coercion target is done before the font that needs it (e.g. CLASSIC before MODERN before TERMINAL before GACHA). This is essentially a topsort")
|
||||
|
||||
(for FONTSPEC NEWFONTS in EXPANDED
|
||||
do (for F in (DREVERSE (CONS FONTSPEC (COERCEFONTSPEC FONTSPEC
|
||||
'CHARCOERCIONS T)))
|
||||
unless (MEMBER F NEWFONTS) when (IMPORTFONTS.EXISTS? 'COMPLETE F
|
||||
FROMDIR)
|
||||
do (push NEWFONTS F)) finally
|
||||
|
||||
(* ;;
|
||||
"We may have requested a font that doesn't exist at all on its own: HELVETICA 10 MIR")
|
||||
|
||||
(for F in EXPANDED
|
||||
unless (MEMBER F NEWFONTS)
|
||||
do (push NEWFONTS F))
|
||||
(RETURN (DREVERSE NEWFONTS))))
|
||||
(FAKE
|
||||
(* ;;
|
||||
"If e.g. BIR is in the list, then so should be BMR, MIR, and if those are there, then so should MRR")
|
||||
|
||||
(for ETAIL FS FACE SOURCE NEWFONTS on EXPANDED
|
||||
do (SETQ FS (CAR ETAIL))
|
||||
(SETQ FACE (fetch (FONTSPEC FSFACE) of FS))
|
||||
(CL:WHEN (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(* ;
|
||||
"BRR -> MRR, BIR ->MIR which goes to MRR")
|
||||
(for FC SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE WEIGHT ←
|
||||
'MEDIUM))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← FC))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIR)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
(CL:WHEN (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(* ; "MIR -> MRR, BIR ->BMR")
|
||||
(for F SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE SLOPE ← 'REGULAR))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← F))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIR)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
(CL:WHEN (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(* ; "MRC -> MRR")
|
||||
(for F SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE EXPANSION ←
|
||||
'REGULAR))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← F))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIR)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
finally (for F in EXPANDED unless (MEMBER F NEWFONTS)
|
||||
do (push NEWFONTS F))
|
||||
(RETURN (DREVERSE NEWFONTS))))
|
||||
(DEPLOY (* ;
|
||||
"Make sure we copy consistent versions of the indirects")
|
||||
(SORTFONTSPECS (CL:REMOVE-DUPLICATES (APPEND
|
||||
(for FS in EXPANDED
|
||||
join (MEDLEYFONT.GETFILEPROP
|
||||
(MEDLEYFONT.FILENAME FS
|
||||
FROMDIR)
|
||||
'INDIRECTS))
|
||||
EXPANDED)
|
||||
:TEST
|
||||
(FUNCTION EQUAL))))
|
||||
(SORTFONTSPECS EXPANDED))))])
|
||||
|
||||
(IMPORTFONTS.CONTEXT
|
||||
[LAMBDA (PHASE FROMDIR TODIR DEVICE) (* ; "Edited 4-May-2026 00:16 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 09:33 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 23:11 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:53 by rmk")
|
||||
(* ; "Edited 18-Mar-2026 22:36 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 09:01 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:56 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:52 by rmk")
|
||||
(* ; "Edited 3-Mar-2026 21:58 by rmk")
|
||||
|
||||
(* ;; "This sets up the FONTDEVICE props according to PHASE, using default values for the directories if they aren't specified. Returns the TODIR, or NIL if the TODIR was DONT=don't file.")
|
||||
|
||||
(SETQ FROMDIR (IMPORTFONTS.DIRECTORY DEVICE FROMDIR
|
||||
(SELECTQ PHASE
|
||||
(IMPORT 'SOURCE)
|
||||
(MCCS 'IMPORT)
|
||||
(COMPLETE 'MCCS)
|
||||
(FAKE 'COMPLETE)
|
||||
(DEPLOY (for P in '(FAKE COMPLETE MCCS IMPORT)
|
||||
suchthat (DIRECTORYNAMEP (IMPORTFONTS.DIRECTORY DEVICE
|
||||
FROMDIR P))))
|
||||
NIL)))
|
||||
(SETQ TODIR (CL:IF (EQ PHASE 'DEPLOY)
|
||||
(CONCAT [CAR (MKLIST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES]
|
||||
">")
|
||||
(IMPORTFONTS.DIRECTORY DEVICE TODIR PHASE)))
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTCOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTCOERCIONS OLDVALUE]
|
||||
(SELECTQ PHASE
|
||||
((IMPORT MCCS)
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES FROMDIR)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE])
|
||||
(COMPLETE
|
||||
(* ;; "Make FONTCREATE1 in the COMPLETE phase draw from previously import-completed fonts, not from the currently active fonts")
|
||||
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES (LIST TODIR FROMDIR))
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(* ; "Suppress face faking")
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FACECOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FACECOERCIONS OLDVALUE])
|
||||
(FAKE
|
||||
(* ;; "Make FONTCREATE1 in the FAKE phase draw from previously import-completed fonts, not from the currently active fonts")
|
||||
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES (LIST TODIR FROMDIR))
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(* ; "Completion has already been done")
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTCOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTCOERCIONS OLDVALUE])
|
||||
NIL)
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(CL:VALUES FROMDIR TODIR])
|
||||
|
||||
(IMPORTFONTS.NOCACHE
|
||||
[LAMBDA NIL (* ; "Edited 3-Mar-2026 11:54 by rmk")
|
||||
(RESETSAVE \FONTSINCORE NIL)
|
||||
(RESETSAVE \FONTEXISTS?-CACHE NIL)
|
||||
(RESETSAVE \FONTSAVAILABLEFILECACHE NIL])
|
||||
|
||||
(IMPORTFONTS.DIRECTORY
|
||||
[LAMBDA (DEVICE DIRECTORY PHASE) (* ; "Edited 4-May-2026 00:52 by rmk")
|
||||
(* ; "Edited 5-Apr-2026 14:17 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 22:59 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 22:40 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 09:35 by rmk")
|
||||
(* ; "Edited 9-Mar-2026 09:14 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:46 by rmk")
|
||||
(CL:UNLESS (MEMB DIRECTORY '(DONT DON'T))
|
||||
[PSEUDOFILENAME (OR DIRECTORY
|
||||
(SELECTQ PHASE
|
||||
(DEPLOY (CONCAT [CAR (MKLIST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES]
|
||||
">"))
|
||||
(CONCAT "{MEDLEY}<internal>fonts>"
|
||||
(L-CASE (CONCAT (OR (if (type? FONTDESCRIPTOR DEVICE)
|
||||
then (FONTPROP DEVICE 'DEVICE)
|
||||
elseif (type? FONTSPEC DEVICE)
|
||||
then (fetch (FONTSPEC FSDEVICE)
|
||||
of (\FONT.CHECKARGS DEVICE))
|
||||
elseif (NOT (LITATOM DEVICE))
|
||||
then (\ILLEGAL.ARG DEVICE)
|
||||
elseif DEVICE
|
||||
else 'DISPLAY))
|
||||
">"
|
||||
(CL:IF PHASE
|
||||
(CONCAT (IMPORTFONTS.SUBDIR PHASE)
|
||||
">")
|
||||
"")])])
|
||||
|
||||
(IMPORTFONTS.CLEAR
|
||||
[LAMBDA (PHASE FONTSPECS TODIR DEVICE) (* ; "Edited 3-May-2026 22:40 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 10:03 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 01:06 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 12:37 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 22:51 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 09:31 by rmk")
|
||||
(CL:WHEN [AND TODIR (MEMB PHASE '(COMPLETE FAKE] (* ;
|
||||
"Previous completions could serve as inputs for later ones, start fresh.")
|
||||
(LET (NDELETED)
|
||||
[SETQ NDELETED (if FONTSPECS
|
||||
then (for FS in (CL:IF (type? FONTSPEC FONTSPECS)
|
||||
(CONS FONTSPECS)
|
||||
FONTSPECS)
|
||||
sum (for FILE in (FILDIR (PACKFILENAME 'VERSION '*
|
||||
'BODY
|
||||
(MEDLEYFONT.FILENAME FS TODIR
|
||||
)))
|
||||
count (DELFILE FILE)))
|
||||
else (for FILE
|
||||
in [FILDIR (PACKFILENAME 'DIRECTORY TODIR 'NAME '* 'VERSION
|
||||
'*
|
||||
'EXTENSION
|
||||
(CAR (MKLIST (FONTDEVICEPROP DEVICE
|
||||
'FONTEXTENSIONS]
|
||||
count (DELFILE FILE]
|
||||
(CL:UNLESS (EQ 0 NDELETED)
|
||||
(PRINTOUT T (SELECTQ NDELETED
|
||||
(1 "1 font")
|
||||
(CONCAT NDELETED " fonts"))
|
||||
" deleted from "
|
||||
(PSEUDOFILENAME TODIR)
|
||||
T))))])
|
||||
|
||||
(IMPORTFONTS.SUBDIR
|
||||
[LAMBDA (PHASE) (* ; "Edited 4-May-2026 00:27 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 16:27 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:53 by rmk")
|
||||
(SELECTQ PHASE
|
||||
(SOURCE "source")
|
||||
(IMPORT "imported")
|
||||
(MCCS "mccs")
|
||||
(COMPLETE "completed")
|
||||
(FAKE "faked")
|
||||
(DEPLOY)
|
||||
(\ILLEGAL.ARG])
|
||||
|
||||
(IMPORTFONTS.DIRSIZE
|
||||
[LAMBDA (PHASE DEVICE DIRECTORY) (* ; "Edited 4-May-2026 00:26 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 16:30 by rmk")
|
||||
(DIRECTORY (PACKFILENAME 'DIRECTORY (IMPORTFONTS.DIRECTORY DEVICE DIRECTORY PHASE)
|
||||
'NAME
|
||||
'*
|
||||
'EXTENSION
|
||||
[CAR (MKLIST (FONTDEVICEPROP (OR DEVICE 'DISPLAY)
|
||||
'FONTEXTENSIONS]
|
||||
'VERSION "")
|
||||
'COUNTLENGTH])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORTFONTS.AVAILABLE
|
||||
[LAMBDA (PHASE FONTSPEC FROMDIR) (* ; "Edited 4-May-2026 00:00 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 13:36 by rmk")
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP FONTSPEC 'FONTDIRECTORIES (IMPORTFONTS.DIRECTORY FONTSPEC FROMDIR
|
||||
PHASE))
|
||||
`(PROGN (FONTDEVICEPROP ',FONTSPEC 'FONTDIRECTORIES OLDVALUE]
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(FONTSAVAILABLE FONTSPEC NIL NIL NIL NIL 'ONLY))])
|
||||
|
||||
(IMPORTFONTS.EXISTS?
|
||||
[LAMBDA (PHASE FONTSPEC FROMDIR) (* ; "Edited 4-May-2026 00:00 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 14:55 by rmk")
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP FONTSPEC 'FONTDIRECTORIES (IMPORTFONTS.DIRECTORY FONTSPEC FROMDIR
|
||||
PHASE))
|
||||
`(PROGN (FONTDEVICEPROP ',FONTSPEC 'FONTDIRECTORIES OLDVALUE]
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(FONTEXISTS? FONTSPEC NIL NIL NIL NIL T))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(FAKEFACE
|
||||
[LAMBDA (FONT) (* ; "Edited 5-Apr-2026 14:10 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 09:38 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 09:00 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 22:14 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 14:37 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:53 by rmk")
|
||||
|
||||
(* ;; "FONTSPEC describes a font that has already been completed in terms of its CHARCOERCIONS.")
|
||||
|
||||
(* ;; "Suppose FONTSPEC describes a (display) BRR font. If it has not been completed (i.e., it is still just MCCS), then all of the glyphs in all of its character sets are natively bold.")
|
||||
|
||||
(* ;; "If it has been completed without facefaking, then some of its characters may have been retrieved from other fonts, and those are mixed in with its native glyphs. But presumably, those characters are also drawn from a BRR font, on the assumption that CHARCOERCIONS tends to preserve faces.")
|
||||
|
||||
(* ;; "So: it is correct to run through all of the slugs, grab the corresponding glyphs from the already completed MRR, if it exists, and insert the bolded versions of those characters.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(LET* ((FONTSPEC (FONTPROP FONT 'DEVICESPEC))
|
||||
(FACE (fetch (FONTSPEC FSFACE) of FONTSPEC))
|
||||
SOURCEFONT CHANGED)
|
||||
(CL:UNLESS (EQ 'DISPLAY (FONTPROP FONT 'DEVICE))
|
||||
(ERROR "Only display fonts can be face-faked" FONT))
|
||||
(CL:UNLESS (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT)
|
||||
(ERROR "Fonts must be completed before face-faking" FONTSPEC))
|
||||
(CL:WHEN [AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSWEIGHT ←
|
||||
'MEDIUM]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MAKEBOLD.CHAR)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
(CL:WHEN [AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSSLOPE ←
|
||||
'REGULAR]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MAKEITALIC.CHAR)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
(CL:WHEN [AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSEXPANSION ←
|
||||
'REGULAR]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MOVEFONTCHARS)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
CHANGED])
|
||||
|
||||
(FAKEFACE.FROMFILE
|
||||
[LAMBDA (FONTSPEC FROMDIR) (* ; "Edited 3-May-2026 22:37 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 09:42 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 23:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:03 by rmk")
|
||||
(* ; "Edited 19-Mar-2026 11:53 by rmk")
|
||||
(* ;
|
||||
"Start with MRR for a face that doesn't yet exist (HELVETICA MIR).")
|
||||
(OR (INFILEP (MEDLEYFONT.FILENAME FONTSPEC FROMDIR))
|
||||
(LET ((FACE (fetch (FONTSPEC FSFACE) of FONTSPEC)))
|
||||
(OR (AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(INFILEP (MEDLEYFONT.FILENAME (create FONTSPEC using FONTSPEC FSFACE ←
|
||||
(MAKEFONTFACE 'MEDIUM NIL
|
||||
NIL FACE))
|
||||
FROMDIR)))
|
||||
(AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(FAKEFACE.FROMFILE (create FONTSPEC using FONTSPEC FSFACE ← (MAKEFONTFACE
|
||||
NIL
|
||||
'REGULAR NIL FACE)
|
||||
)
|
||||
FROMDIR))
|
||||
(AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(FAKEFACE.FROMFILE (create FONTSPEC using FONTSPEC FSFACE ← (MAKEFONTFACE
|
||||
NIL NIL
|
||||
'REGULAR FACE))
|
||||
FROMDIR))
|
||||
(ERROR "No source for face-faking" FONTSPEC])
|
||||
|
||||
(FAKEFACE.FROMFONT
|
||||
[LAMBDA (FONTSPEC FROMDIR) (* ; "Edited 3-May-2026 22:37 by rmk")
|
||||
(* ; "Edited 19-Mar-2026 20:42 by rmk")
|
||||
|
||||
(* ;; "If FONTSPEC doesn't identifyan existing font that needs to be coerced, we create an empty starting font full of slug charsets. ")
|
||||
|
||||
(LET (FROMFILE FONT)
|
||||
(SETQ FROMFILE (FAKEFACE.FROMFILE FONTSPEC FROMDIR))
|
||||
(SETQ FONT (MEDLEYFONT.READ.FONT FROMFILE 'ALL))
|
||||
(CL:UNLESS (EQUAL FONTSPEC (FONTPROP FONT 'SPEC))
|
||||
|
||||
(* ;; "We catch all the other properties of the backing font--encoding etc.")
|
||||
|
||||
(SETQ FONT (FONTCREATE.SLUGFD FONTSPEC FONT)))
|
||||
(CL:VALUES FONT FROMFILE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "For legacy display imports")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORT.DISPLAY
|
||||
[LAMBDA (FONTSPECS) (* ; "Edited 4-May-2026 15:18 by rmk")
|
||||
(* ; "Edited 28-Mar-2026 23:08 by rmk")
|
||||
(* ; "Edited 18-Mar-2026 23:54 by rmk")
|
||||
(IMPORTFONTS 'IMPORT FONTSPECS 'DISPLAY '{MEDLEY}/fonts/displayfonts/ NIL (FUNCTION
|
||||
LEGACYDISPLAYFONT])
|
||||
|
||||
(LEGACYDISPLAYFONT
|
||||
[LAMBDA (FONTSPEC FROMDIR) (* ; "Edited 3-May-2026 22:38 by rmk")
|
||||
(* ; "Edited 16-Apr-2026 22:37 by rmk")
|
||||
(* ; "Edited 12-Apr-2026 13:22 by rmk")
|
||||
(* ; "Edited 31-Mar-2026 15:01 by rmk")
|
||||
(* ; "Edited 28-Mar-2026 09:27 by rmk")
|
||||
|
||||
(* ;; "Loads legacy display fonts (ac or strike format, gacha, terminal, helevetica...) from FROMDIR. If NIL, the current directory")
|
||||
|
||||
(SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL 'DISPLAY T))
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP 'DISPLAY 'FONTDIRECTORIES FROMDIR)
|
||||
`(PROGN (FONTDEVICEPROP 'DISPLAY 'FONTDIRECTORIES OLDVALUE]
|
||||
[RESETSAVE (FONTDEVICEPROP 'DISPLAY 'FONTEXTENSIONS '(DISPLAYFONT)
|
||||
FROMDIR)
|
||||
`(PROGN (FONTDEVICEPROP 'DISPLAY 'FONTEXTENSIONS OLDVALUE]
|
||||
(for CSNO CSINFO (FONT ← (FONTSPEC.TO.FONTDESCRIPTOR FONTSPEC 255)) from 0 to 255
|
||||
do (SETQ CSINFO (\READCHARSET FONT CSNO '((AC ACFONT.FILEP ACFONT.GETCHARSET)
|
||||
(STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET))
|
||||
FROMDIR))
|
||||
|
||||
(* ;; "NIL means empty")
|
||||
|
||||
(CL:IF CSINFO
|
||||
(\INSTALLCHARSETINFO FONT CSINFO CSNO)
|
||||
(\SETCHARSETINFO FONT CSNO (SLUGCSINFO FONT))) finally (RETURN FONT)))])
|
||||
)
|
||||
|
||||
(FILESLOAD ACFONT)
|
||||
|
||||
|
||||
|
||||
(* ; "For testing")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(IPF
|
||||
[LAMBDA (PHASE FONTSPEC) (* ; "Edited 4-May-2026 00:01 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 12:44 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 22:46 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 00:54 by rmk")
|
||||
(MEDLEYFONT.READ.FONT (MEDLEYFONT.FILENAME FONTSPEC (IMPORTFONTS.DIRECTORY
|
||||
(OR (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
'DISPLAY)
|
||||
NIL PHASE))
|
||||
'ALL])
|
||||
|
||||
(IPFSIZES
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 4-May-2026 00:49 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 12:45 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 00:59 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 08:43 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:33 by rmk")
|
||||
|
||||
(* ;; "Returns the file sizes for all the phases of FONTSPEC")
|
||||
|
||||
(if (type? FONTSPEC FONTSPEC)
|
||||
then (SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL NIL T))
|
||||
else (SETQ FONTSPEC (FONTSPECFROMFILENAME FONTSPEC)))
|
||||
(for PHASE DIR FONTFILE SIZE LASTSIZE in '(IMPORT MCCS COMPLETE FAKE DEPLOY)
|
||||
eachtime (SETQ DIR (IMPORTFONTS.DIRECTORY FONTSPEC NIL PHASE))
|
||||
when (SETQ FONTFILE (INFILEP (MEDLEYFONT.FILENAME FONTSPEC DIR)))
|
||||
collect (SETQ FONTFILE (INFILEP (MEDLEYFONT.FILENAME FONTSPEC DIR)))
|
||||
[SETQ SIZE (CL:IF FONTFILE
|
||||
(GETFILEINFO FONTFILE 'LENGTH))]
|
||||
(PROG1 [LIST* PHASE SIZE (CL:IF LASTSIZE
|
||||
(CONS (IDIFFERENCE SIZE LASTSIZE)))]
|
||||
(SETQ LASTSIZE SIZE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(PEF
|
||||
[LAMBDA (PHASES FONTSPEC CHARSET) (* ; "Edited 5-May-2026 12:20 by rmk")
|
||||
(* ; "Edited 4-May-2026 08:27 by rmk")
|
||||
(* ; "Edited 12-Apr-2026 19:32 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 09:14 by rmk")
|
||||
(* ; "Edited 25-Mar-2026 00:11 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 00:19 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 08:43 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:33 by rmk")
|
||||
(if (type? FONTSPEC FONTSPEC)
|
||||
then (SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL NIL T))
|
||||
else (SETQ FONTSPEC (FONTSPECFROMFILENAME FONTSPEC)))
|
||||
(for PHASE TITLETAG CHARSETNAME DIR FONTFILE inside PHASES
|
||||
do (* ;
|
||||
"Some phases may not have some charsets")
|
||||
(SETQ CHARSET (if (EQ CHARSET T)
|
||||
then (for C in (MEDLEYFONT.GETFILEPROP FONTFILE 'CHARSET)
|
||||
unless (OR (KANJICHARSETP C)
|
||||
(UNIHANCHARSETP C)) collect C)
|
||||
elseif (CHARSET.DECODE CHARSET)
|
||||
else 0))
|
||||
(if (LISTP CHARSET)
|
||||
then (for C in CHARSET do (PEF PHASE FONTSPEC C))
|
||||
elseif (EQ PHASE 'DEPLOY)
|
||||
then (EDITFONT FONTSPEC CHARSET NIL NIL "Deployed")
|
||||
else (SETQ DIR (IMPORTFONTS.DIRECTORY FONTSPEC NIL PHASE))
|
||||
(SETQ FONTFILE (MEDLEYFONT.FILENAME FONTSPEC DIR))
|
||||
(if (NLSETQ (MEDLEYFONT.FILEP FONTFILE))
|
||||
then (SETQ TITLETAG (CL:IF (EQ PHASE 'MCCS)
|
||||
'MCCS
|
||||
(L-CASE PHASE T)))
|
||||
(SETQ CHARSETNAME (CHARSET.ENCODE CHARSET))
|
||||
(CL:UNLESS (OCTALNUM? CHARSETNAME)
|
||||
(SETQ TITLETAG (CONCAT CHARSETNAME " " TITLETAG)))
|
||||
(if [CAR (NLSETQ (RESETLST
|
||||
(IMPORTFONTS.CONTEXT PHASE DIR NIL (fetch (FONTSPEC
|
||||
FSDEVICE)
|
||||
of FONTSPEC))
|
||||
(EDITFONT (MEDLEYFONT.READ.FONT FONTFILE CHARSET)
|
||||
CHARSET NIL NIL TITLETAG))]
|
||||
else (PRINTOUT T "Charset " (OCTALSTRING CHARSET)
|
||||
" of " FONTSPEC " not found in " DIR T)
|
||||
NIL)
|
||||
else (PRINTOUT T FONTSPEC " not found in " DIR T])
|
||||
|
||||
(AEF
|
||||
[LAMBDA (FONTSPEC CHARSET CLOSE) (* ; "Edited 4-May-2026 08:22 by rmk")
|
||||
(* ; "Edited 5-Apr-2026 11:50 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 15:09 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 12:59 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 22:56 by rmk")
|
||||
|
||||
(* ;; "Show CHARSET for all phases of FONTSPEC")
|
||||
|
||||
(CL:WHEN CLOSE (EFCLOSE))
|
||||
(PEF '(IMPORT MCCS COMPLETE FAKE DEPLOY)
|
||||
FONTSPEC CHARSET])
|
||||
|
||||
(IEF
|
||||
[LAMBDA (FONTSPEC CHARSET) (* ; "Edited 4-May-2026 08:34 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:02 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 23:56 by rmk")
|
||||
(* ; "Edited 27-Feb-2026 14:24 by rmk")
|
||||
(PEF 'IMPORT FONTSPEC CHARSET])
|
||||
|
||||
(MEF
|
||||
[LAMBDA (FONTSPEC CHARSET) (* ; "Edited 4-May-2026 08:35 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:01 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 23:57 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 20:38 by rmk")
|
||||
(PEF 'MCCS FONTSPEC CHARSET])
|
||||
|
||||
(CEF
|
||||
[LAMBDA (FONTSPEC CHARSET) (* ; "Edited 4-May-2026 08:35 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:03 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 2-Mar-2026 00:00 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 22:58 by rmk")
|
||||
(PEF 'COMPLETE FONTSPEC CHARSET])
|
||||
|
||||
(FEF
|
||||
[LAMBDA (FONTSPEC CHARSET) (* ; "Edited 4-May-2026 08:35 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 19-Mar-2026 00:42 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:03 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 2-Mar-2026 00:00 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 22:58 by rmk")
|
||||
(PEF 'FAKE FONTSPEC CHARSET])
|
||||
|
||||
(DEF
|
||||
[LAMBDA (FONTSPEC CHARSET) (* ; "Edited 4-May-2026 08:34 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:02 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 23:56 by rmk")
|
||||
(* ; "Edited 27-Feb-2026 14:24 by rmk")
|
||||
(PEF 'DEPLOY FONTSPEC CHARSET])
|
||||
|
||||
(EFCLOSE
|
||||
[LAMBDA NIL (* ; "Edited 9-Oct-2025 19:48 by rmk")
|
||||
(for W in (OPENWINDOWS) when (AND (WINDOWPROP W 'FONT)
|
||||
(WINDOWPROP W 'CHARITEMS)) do (CLOSEW W])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWCHARS
|
||||
[LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 20:29 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 10:26 by rmk")
|
||||
(* ; "Edited 24-Jul-2025 11:30 by rmk")
|
||||
(* ; "Edited 8-Jun-2025 20:05 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:18 by mth")
|
||||
(* ; "Edited 1-Aug-2020 09:27 by rmk:")
|
||||
[SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12]
|
||||
(RESETLST
|
||||
[LET ((OLDFONT (DSPFONT NIL T))
|
||||
CHARS)
|
||||
(CL:UNLESS (CHARCODEP FROMCHAR)
|
||||
(SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T)
|
||||
FROMCHAR)))
|
||||
(SETQ CHARS (if (LISTP FROMCHAR)
|
||||
elseif (CHARCODEP FROMCHAR)
|
||||
then (CL:UNLESS (CHARCODEP TOCHAR)
|
||||
(SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR)
|
||||
FROMCHAR)))
|
||||
(for C from FROMCHAR to TOCHAR collect C)
|
||||
else (CHCON FROMCHAR)))
|
||||
[RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE]
|
||||
(TERPRI)
|
||||
(for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C))
|
||||
","
|
||||
(OCTALSTRING (\CHAR8CODE C)))
|
||||
10 .FONT FONT (CHARACTER C))
|
||||
(CL:UNLESS ONELINE (PRINTOUT T T])
|
||||
(TERPRI])
|
||||
|
||||
(CSSOURCE
|
||||
[LAMBDA (PHASE FONT INDIRECT) (* ; "Edited 22-Mar-2026 00:26 by rmk")
|
||||
|
||||
(* ;; "Shows the source properties of all the charsets")
|
||||
|
||||
(CL:UNLESS (FONTP FONT)
|
||||
(SETQ FONT (IPF PHASE FONT)))
|
||||
(LIST* PHASE (FONTPROP FONT 'SPEC)
|
||||
(for CS CSINFO SOURCE (FONTSPEC ← (FONTPROP FONT 'SPEC)) from 0 to (MAXCHARSET FONT)
|
||||
eachtime (SETQ CSINFO (\GETCHARSETINFO FONT CS)) when CSINFO
|
||||
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO)
|
||||
unless [AND INDIRECT (EQUAL FONTSPEC (CHARSETPROP CSINFO 'SOURCE]
|
||||
collect (LIST CS (CHARSETPROP CSINFO 'SOURCE])
|
||||
|
||||
(FONTDEFFONTS
|
||||
[LAMBDA (FACES) (* ; "Edited 22-Mar-2026 12:48 by rmk")
|
||||
(SETQ FACES (for F inside FACES collect (\FONTFACE F)))
|
||||
(for FD FONTLIST in FONTDEFS
|
||||
do (for FP in (CDR (ASSOC 'FONTPROFILE FD))
|
||||
do (for FONT in (CDDR FP) when FONT unless (MEMB (CAR FONT)
|
||||
'(PDF POSTSCRIPT))
|
||||
when (OR (NOT FACES)
|
||||
(MEMBER (\FONTFACE (fetch (FONTSPEC FSFACE) of FONT))
|
||||
FACES)) do (push FONTLIST FONT)))
|
||||
finally (RETURN (SORTFONTSPECS (CL:REMOVE-DUPLICATES FONTLIST :TEST (FUNCTION EQUAL])
|
||||
)
|
||||
|
||||
(FILESLOAD EDITFONT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1116 33853 (IMPORTFONTS 1126 . 13073) (FONT.TO.MCCS 13075 . 15325) (
|
||||
IMPORTFONTS.FONTSPECS 15327 . 23722) (IMPORTFONTS.CONTEXT 23724 . 27433) (IMPORTFONTS.NOCACHE 27435 .
|
||||
27686) (IMPORTFONTS.DIRECTORY 27688 . 30039) (IMPORTFONTS.CLEAR 30041 . 32587) (IMPORTFONTS.SUBDIR
|
||||
32589 . 33238) (IMPORTFONTS.DIRSIZE 33240 . 33851)) (33854 35077 (IMPORTFONTS.AVAILABLE 33864 . 34473)
|
||||
(IMPORTFONTS.EXISTS? 34475 . 35075)) (35078 41861 (FAKEFACE 35088 . 38825) (FAKEFACE.FROMFILE 38827
|
||||
. 41068) (FAKEFACE.FROMFONT 41070 . 41859)) (41905 44151 (IMPORT.DISPLAY 41915 . 42453) (
|
||||
LEGACYDISPLAYFONT 42455 . 44149)) (44200 46532 (IPF 44210 . 45004) (IPFSIZES 45006 . 46530)) (46533
|
||||
54653 (PEF 46543 . 49912) (AEF 49914 . 50637) (IEF 50639 . 51341) (MEF 51343 . 52043) (CEF 52045 .
|
||||
52749) (FEF 52751 . 53669) (DEF 53671 . 54373) (EFCLOSE 54375 . 54651)) (54654 58201 (SHOWCHARS 54664
|
||||
. 56694) (CSSOURCE 56696 . 57409) (FONTDEFFONTS 57411 . 58199)))))
|
||||
STOP
|
||||
BIN
library/IMPORTFONTS.LCOM
Normal file
BIN
library/IMPORTFONTS.LCOM
Normal file
Binary file not shown.
BIN
library/IMPORTFONTS.TEDIT
Normal file
BIN
library/IMPORTFONTS.TEDIT
Normal file
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "12-Feb-2026 12:19:03" {DSK}<home>matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;6 258522
|
||||
(FILECREATED "11-May-2026 10:22:21" {MEDLEY}<library>POSTSCRIPTSTREAM.;73 258415
|
||||
|
||||
:EDIT-BY "mth"
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS PSCFONT.READFONT)
|
||||
:CHANGES-TO (VARS POSTSCRIPTSTREAMCOMS)
|
||||
|
||||
:PREVIOUS-DATE "27-Jan-2026 17:57:49"
|
||||
{DSK}<home>matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;5)
|
||||
:PREVIOUS-DATE "26-Apr-2026 11:39:26" {MEDLEY}<library>POSTSCRIPTSTREAM.;71)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS)
|
||||
@@ -136,10 +135,7 @@
|
||||
(POSTSCRIPT.TEXTFILE.LANDSCAPE NIL)
|
||||
(POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800))
|
||||
(POSTSCRIPT.TEXTURE.SCALE 4)
|
||||
[POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE)
|
||||
'MAIKO)
|
||||
"{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/")
|
||||
(T "{DSK}<LISPFILES>POSTSCRIPT>"]
|
||||
(POSTSCRIPTFONTDIRECTORIES (LIST "{MEDLEY}/fonts/postscriptfonts"))
|
||||
(POSTSCRIPTFONTEXTENSIONS '(PSCFONT PF PSC))
|
||||
[POSTSCRIPTFONTCOERCIONS '((HELVETICA (HELVETICA 1))
|
||||
(HELVETICAD (HELVETICA 1))
|
||||
@@ -154,6 +150,7 @@
|
||||
(LOGO (HELVETICA 1))
|
||||
(OPTIMA (PALATINO 1))
|
||||
(TITAN (COURIER 1))
|
||||
(* CLASSIC)
|
||||
(* (* 1]
|
||||
(POSTSCRIPTCHARCOERCIONS NIL)
|
||||
(\POSTSCRIPT.MAX.WILD.FONTSIZE 72))
|
||||
@@ -878,7 +875,8 @@
|
||||
FONTID])
|
||||
|
||||
(POSTSCRIPT.FONTCREATE
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 13-Oct-2025 18:04 by rmk")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 17-Mar-2026 16:29 by rmk")
|
||||
(* ; "Edited 13-Oct-2025 18:04 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 23:44 by rmk")
|
||||
(* ; "Edited 30-Aug-2025 23:24 by rmk")
|
||||
(* ; "Edited 21-Aug-2025 18:21 by rmk")
|
||||
@@ -998,10 +996,12 @@
|
||||
|
||||
(COND
|
||||
((AND TMP (NEQ FAMILY (CAR TMP)))
|
||||
(replace FONTDEVICESPEC of FD with (LIST (CAR TMP)
|
||||
SIZE
|
||||
(COPY FACE)
|
||||
0 DEVICE]
|
||||
(replace FONTDEVICESPEC of FD with (create FONTSPEC
|
||||
FSFAMILY _ (CAR TMP)
|
||||
FSSIZE _ SIZE
|
||||
FSFACE _ (COPY FACE)
|
||||
FSROTATION _ 0
|
||||
FSDEVICE _ DEVICE]
|
||||
[LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION DEVICE)
|
||||
)
|
||||
(DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD ROTATION
|
||||
@@ -4298,10 +4298,7 @@
|
||||
|
||||
(RPAQ? POSTSCRIPT.TEXTURE.SCALE 4)
|
||||
|
||||
(RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE)
|
||||
'MAIKO)
|
||||
"{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/")
|
||||
(T "{DSK}<LISPFILES>POSTSCRIPT>"))))
|
||||
(RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST "{MEDLEY}/fonts/postscriptfonts"))
|
||||
|
||||
(RPAQ? POSTSCRIPTFONTEXTENSIONS '(PSCFONT PF PSC))
|
||||
|
||||
@@ -4319,6 +4316,7 @@
|
||||
(LOGO (HELVETICA 1))
|
||||
(OPTIMA (PALATINO 1))
|
||||
(TITAN (COURIER 1))
|
||||
(* CLASSIC)
|
||||
(* (* 1))))
|
||||
|
||||
(RPAQ? POSTSCRIPTCHARCOERCIONS NIL)
|
||||
@@ -4393,37 +4391,37 @@
|
||||
(ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (22366 32685 (POSTSCRIPT.INIT 22376 . 29291) (POSTSCRIPT.PUTRGBCOLOR 29293 . 30315) (
|
||||
\PSC.COLOR.TO.RGB 30317 . 32683)) (33671 69196 (PSCFONT.READFONT 33681 . 35692) (PSCFONT.SPELLFILE
|
||||
35694 . 36507) (PSCFONT.COERCEFILE 36509 . 38081) (PSCFONTFROMCACHE.SPELLFILE 38083 . 39068) (
|
||||
PSCFONTFROMCACHE.COERCEFILE 39070 . 40722) (PSCFONT.WRITEFONT 40724 . 41739) (READ-AFM-FILE 41741 .
|
||||
47612) (CONVERT-AFM-FILES 47614 . 48826) (POSTSCRIPT.GETFONTID 48828 . 50223) (POSTSCRIPT.FONTCREATE
|
||||
50225 . 63119) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 63121 . 65518) (POSTSCRIPT.FONTSAVAILABLE 65520
|
||||
. 67807) (POSTSCRIPT.FONTEXISTS? 67809 . 69194)) (69197 79106 (OPENPOSTSCRIPTSTREAM 69207 . 78772) (
|
||||
CLOSEPOSTSCRIPTSTREAM 78774 . 79104)) (79151 85477 (POSTSCRIPT.HARDCOPYW 79161 . 82268) (
|
||||
POSTSCRIPT.TEDIT 82270 . 82722) (POSTSCRIPTFILEP 82724 . 84212) (MAKEEPSFILE 84214 . 85475)) (85478
|
||||
129222 (POSTSCRIPT.BITMAPSCALE 85488 . 87944) (POSTSCRIPT.CLOSESTRING 87946 . 88499) (
|
||||
POSTSCRIPT.ENDPAGE 88501 . 89392) (POSTSCRIPT.OUTSTR 89394 . 90611) (POSTSCRIPT.PUTBITMAPBYTES 90613
|
||||
. 99084) (POSTSCRIPT.PUTCOMMAND 99086 . 100075) (POSTSCRIPT.SET-FAKE-LANDSCAPE 100077 . 104597) (
|
||||
POSTSCRIPT.SHOWACCUM 104599 . 106754) (POSTSCRIPT.STARTPAGE 106756 . 109458) (\POSTSCRIPTTAB 109460 .
|
||||
110257) (\PS.BOUTFIXP 110259 . 111539) (\PS.SCALEHACK 111541 . 114184) (\PS.SCALEREGION 114186 .
|
||||
114746) (\SCALEDBITBLT.PSC 114748 . 119058) (\SETPOS.PSC 119060 . 119541) (\SETXFORM.PSC 119543 .
|
||||
122127) (\STRINGWIDTH.PSC 122129 . 122602) (\SWITCHFONTS.PSC 122604 . 128096) (\TERPRI.PSC 128098 .
|
||||
129220)) (129257 183113 (\BITBLT.PSC 129267 . 129819) (\BLTSHADE.PSC 129821 . 134482) (\CHARWIDTH.PSC
|
||||
134484 . 134991) (\CREATECHARSET.PSC 134993 . 136349) (\DRAWARC.PSC 136351 . 138729) (\DRAWCIRCLE.PSC
|
||||
138731 . 140982) (\DRAWCURVE.PSC 140984 . 144828) (\DRAWELLIPSE.PSC 144830 . 147194) (\DRAWLINE.PSC
|
||||
147196 . 149936) (\DRAWPOINT.PSC 149938 . 150514) (\DRAWPOLYGON.PSC 150516 . 153645) (
|
||||
\DSPBOTTOMMARGIN.PSC 153647 . 154334) (\DSPCLIPPINGREGION.PSC 154336 . 155711) (\DSPCOLOR.PSC 155713
|
||||
. 156644) (\DSPFONT.PSC 156646 . 160283) (\DSPLEFTMARGIN.PSC 160285 . 160971) (\DSPLINEFEED.PSC
|
||||
160973 . 161563) (\DSPPUSHSTATE.PSC 161565 . 163025) (\DSPPOPSTATE.PSC 163027 . 166512) (\DSPRESET.PSC
|
||||
166514 . 167179) (\DSPRIGHTMARGIN.PSC 167181 . 167870) (\DSPROTATE.PSC 167872 . 168871) (
|
||||
\DSPSCALE.PSC 168873 . 169825) (\DSPSCALE2.PSC 169827 . 170667) (\DSPSPACEFACTOR.PSC 170669 . 171590)
|
||||
(\DSPTOPMARGIN.PSC 171592 . 172163) (\DSPTRANSLATE.PSC 172165 . 174196) (\DSPXPOSITION.PSC 174198 .
|
||||
174762) (\DSPYPOSITION.PSC 174764 . 175355) (\FILLCIRCLE.PSC 175357 . 177582) (\FILLPOLYGON.PSC 177584
|
||||
. 180821) (\FIXLINELENGTH.PSC 180823 . 182142) (\MOVETO.PSC 182144 . 182914) (\NEWPAGE.PSC 182916 .
|
||||
183111)) (183169 205315 (\POSTSCRIPT.CHANGECHARSET 183179 . 183897) (\POSTSCRIPT.OUTCHARFN 183899 .
|
||||
196169) (\POSTSCRIPT.PRINTSLUG 196171 . 197895) (\POSTSCRIPT.SPECIALOUTCHARFN 197897 . 200248) (
|
||||
\UPDATE.PSC 200250 . 201496) (\POSTSCRIPT.ACCENTFN 201498 . 202440) (\POSTSCRIPT.ACCENTPAIR 202442 .
|
||||
205313)) (205413 207058 (\PSC.SPACEDISP 205423 . 205702) (\PSC.SPACEWID 205704 . 206323) (\PSC.SYMBOLS
|
||||
206325 . 207056)) (207167 210158 (\POSTSCRIPT.NSHASH 207177 . 210156)))))
|
||||
(FILEMAP (NIL (22135 32454 (POSTSCRIPT.INIT 22145 . 29060) (POSTSCRIPT.PUTRGBCOLOR 29062 . 30084) (
|
||||
\PSC.COLOR.TO.RGB 30086 . 32452)) (33440 69285 (PSCFONT.READFONT 33450 . 35461) (PSCFONT.SPELLFILE
|
||||
35463 . 36276) (PSCFONT.COERCEFILE 36278 . 37850) (PSCFONTFROMCACHE.SPELLFILE 37852 . 38837) (
|
||||
PSCFONTFROMCACHE.COERCEFILE 38839 . 40491) (PSCFONT.WRITEFONT 40493 . 41508) (READ-AFM-FILE 41510 .
|
||||
47381) (CONVERT-AFM-FILES 47383 . 48595) (POSTSCRIPT.GETFONTID 48597 . 49992) (POSTSCRIPT.FONTCREATE
|
||||
49994 . 63208) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 63210 . 65607) (POSTSCRIPT.FONTSAVAILABLE 65609
|
||||
. 67896) (POSTSCRIPT.FONTEXISTS? 67898 . 69283)) (69286 79195 (OPENPOSTSCRIPTSTREAM 69296 . 78861) (
|
||||
CLOSEPOSTSCRIPTSTREAM 78863 . 79193)) (79240 85566 (POSTSCRIPT.HARDCOPYW 79250 . 82357) (
|
||||
POSTSCRIPT.TEDIT 82359 . 82811) (POSTSCRIPTFILEP 82813 . 84301) (MAKEEPSFILE 84303 . 85564)) (85567
|
||||
129311 (POSTSCRIPT.BITMAPSCALE 85577 . 88033) (POSTSCRIPT.CLOSESTRING 88035 . 88588) (
|
||||
POSTSCRIPT.ENDPAGE 88590 . 89481) (POSTSCRIPT.OUTSTR 89483 . 90700) (POSTSCRIPT.PUTBITMAPBYTES 90702
|
||||
. 99173) (POSTSCRIPT.PUTCOMMAND 99175 . 100164) (POSTSCRIPT.SET-FAKE-LANDSCAPE 100166 . 104686) (
|
||||
POSTSCRIPT.SHOWACCUM 104688 . 106843) (POSTSCRIPT.STARTPAGE 106845 . 109547) (\POSTSCRIPTTAB 109549 .
|
||||
110346) (\PS.BOUTFIXP 110348 . 111628) (\PS.SCALEHACK 111630 . 114273) (\PS.SCALEREGION 114275 .
|
||||
114835) (\SCALEDBITBLT.PSC 114837 . 119147) (\SETPOS.PSC 119149 . 119630) (\SETXFORM.PSC 119632 .
|
||||
122216) (\STRINGWIDTH.PSC 122218 . 122691) (\SWITCHFONTS.PSC 122693 . 128185) (\TERPRI.PSC 128187 .
|
||||
129309)) (129346 183202 (\BITBLT.PSC 129356 . 129908) (\BLTSHADE.PSC 129910 . 134571) (\CHARWIDTH.PSC
|
||||
134573 . 135080) (\CREATECHARSET.PSC 135082 . 136438) (\DRAWARC.PSC 136440 . 138818) (\DRAWCIRCLE.PSC
|
||||
138820 . 141071) (\DRAWCURVE.PSC 141073 . 144917) (\DRAWELLIPSE.PSC 144919 . 147283) (\DRAWLINE.PSC
|
||||
147285 . 150025) (\DRAWPOINT.PSC 150027 . 150603) (\DRAWPOLYGON.PSC 150605 . 153734) (
|
||||
\DSPBOTTOMMARGIN.PSC 153736 . 154423) (\DSPCLIPPINGREGION.PSC 154425 . 155800) (\DSPCOLOR.PSC 155802
|
||||
. 156733) (\DSPFONT.PSC 156735 . 160372) (\DSPLEFTMARGIN.PSC 160374 . 161060) (\DSPLINEFEED.PSC
|
||||
161062 . 161652) (\DSPPUSHSTATE.PSC 161654 . 163114) (\DSPPOPSTATE.PSC 163116 . 166601) (\DSPRESET.PSC
|
||||
166603 . 167268) (\DSPRIGHTMARGIN.PSC 167270 . 167959) (\DSPROTATE.PSC 167961 . 168960) (
|
||||
\DSPSCALE.PSC 168962 . 169914) (\DSPSCALE2.PSC 169916 . 170756) (\DSPSPACEFACTOR.PSC 170758 . 171679)
|
||||
(\DSPTOPMARGIN.PSC 171681 . 172252) (\DSPTRANSLATE.PSC 172254 . 174285) (\DSPXPOSITION.PSC 174287 .
|
||||
174851) (\DSPYPOSITION.PSC 174853 . 175444) (\FILLCIRCLE.PSC 175446 . 177671) (\FILLPOLYGON.PSC 177673
|
||||
. 180910) (\FIXLINELENGTH.PSC 180912 . 182231) (\MOVETO.PSC 182233 . 183003) (\NEWPAGE.PSC 183005 .
|
||||
183200)) (183258 205404 (\POSTSCRIPT.CHANGECHARSET 183268 . 183986) (\POSTSCRIPT.OUTCHARFN 183988 .
|
||||
196258) (\POSTSCRIPT.PRINTSLUG 196260 . 197984) (\POSTSCRIPT.SPECIALOUTCHARFN 197986 . 200337) (
|
||||
\UPDATE.PSC 200339 . 201585) (\POSTSCRIPT.ACCENTFN 201587 . 202529) (\POSTSCRIPT.ACCENTPAIR 202531 .
|
||||
205402)) (205502 207147 (\PSC.SPACEDISP 205512 . 205791) (\PSC.SPACEWID 205793 . 206412) (\PSC.SYMBOLS
|
||||
206414 . 207145)) (207256 210247 (\POSTSCRIPT.NSHASH 207266 . 210245)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "16-May-2025 12:07:44" {DSK}<home>frank>il>qmedley>library>PSEUDOHOSTS.;2 31408
|
||||
(FILECREATED "28-Apr-2026 08:31:30" {WMEDLEY}<library>PSEUDOHOSTS.;191 30987
|
||||
|
||||
:CHANGES-TO (FNS PSEUDOHOSTS)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "31-Dec-2024 11:45:23" {DSK}<home>frank>il>qmedley>library>PSEUDOHOSTS.;1)
|
||||
:CHANGES-TO (FNS PSEUDOHOST)
|
||||
|
||||
:PREVIOUS-DATE "27-Apr-2026 22:55:50" {MEDLEY}<library>PSEUDOHOSTS.;190)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
|
||||
@@ -13,22 +15,19 @@
|
||||
(
|
||||
(* ;; "Public entries")
|
||||
|
||||
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEDEVICE TRUEFILENAME PSEUDOFILENAME)
|
||||
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEDEVICE TRUEFILENAME PSEUDOFILENAME
|
||||
PSEUDOFILENAMES)
|
||||
(FNS CDPSEUDO)
|
||||
|
||||
(* ;; "Internals")
|
||||
|
||||
(FNS EXPAND.PH CONTRACT.PH UNSLASHIT GETHOSTINFO.PH)
|
||||
(FNS CDPSEUDO)
|
||||
(FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH
|
||||
OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH
|
||||
SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (PSEUDOHOST 'LI LOGINHOST/DIR)))
|
||||
GENERATEFILES.PH GETFILEINFO.PH SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH)
|
||||
(P (MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)
|
||||
(MOVD 'GETHOSTINFO.PH 'GETHOSTINFO))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE TARGETDEVICE)
|
||||
(MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)
|
||||
(FILES (FROM LOADUPS)
|
||||
EXPORTS.ALL))))
|
||||
(MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL))))
|
||||
|
||||
|
||||
|
||||
@@ -37,7 +36,15 @@
|
||||
(DEFINEQ
|
||||
|
||||
(PSEUDOHOST
|
||||
[LAMBDA (HOST PREFIX)
|
||||
[LAMBDA (HOST PREFIX CDSUFFIX NOERROR)
|
||||
|
||||
(* ;; "Edited 28-Apr-2026 08:31 by rmk")
|
||||
|
||||
(* ;; "Edited 25-Apr-2026 15:51 by rmk")
|
||||
|
||||
(* ;; "Edited 2-Feb-2025 10:05 by rmk")
|
||||
|
||||
(* ;; "Edited 30-Jan-2025 23:32 by rmk")
|
||||
|
||||
(* ;; "Edited 2-Nov-2023 10:53 by rmk")
|
||||
|
||||
@@ -58,12 +65,14 @@
|
||||
(CHARCODE }))
|
||||
(SETQ HOST (SUBSTRING HOST 1 -2)))
|
||||
(SETQ HOST (U-CASE (MKATOM HOST)))
|
||||
[if PREFIX
|
||||
then (SETQ PREFIX (TRUEFILENAME PREFIX))
|
||||
(if PREFIX
|
||||
then (CL:UNLESS (SETQ PREFIX (TRUEFILENAME PREFIX NOERROR))
|
||||
(RETFROM (FUNCTION PSEUDOHOST)
|
||||
NIL))
|
||||
(CL:WHEN (PSEUDOHOSTP HOST) (* ;
|
||||
"Redefining: first clear out the previous one")
|
||||
(PSEUDOHOST HOST NIL))
|
||||
[LET (TARGETHOST TARGETDEVICE PREFIXHOST)
|
||||
[LET (TARGETHOST TARGETDEVICE PREFIXHOST PHDEV)
|
||||
(CL:UNLESS [SETQ PREFIXHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]
|
||||
(SETQ PREFIX (UNSLASHIT (PACKFILENAME 'HOST (SETQ PREFIXHOST 'DSK)
|
||||
'BODY PREFIX))))
|
||||
@@ -86,6 +95,8 @@
|
||||
(UNIX (SETQ PREFIX (SLASHIT PREFIX)))
|
||||
NIL)
|
||||
(SETQ TARGETDEVICE (OR (\GETDEVICEFROMHOSTNAME TARGETHOST)
|
||||
(AND NOERROR (RETFROM (FUNCTION PSEUDOHOST)
|
||||
NIL))
|
||||
(ERROR "UNKNOWN TARGET HOST" TARGETHOST)))
|
||||
|
||||
(* ;; "Save the last directory marker to pack on if needed.")
|
||||
@@ -104,38 +115,52 @@
|
||||
REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM)
|
||||
GENERATEFILES _ (FUNCTION GENERATEFILES.PH)
|
||||
GETFILEINFO _ (FUNCTION GETFILEINFO.PH)
|
||||
SETFILEINFO _ (FUNCTION SETFILEINFO.PH)
|
||||
RENAMEFILE _ (FUNCTION RENAMEFILE.PH)))
|
||||
SETFILEINFO _ (FUNCTION SETFILEINFO.PH)))
|
||||
|
||||
(* ;; "The ultimate target device keeps a map of prefixes and the hostnames they map to. The longest matching prefix is chosen when a name that expands to the target device is contracted.")
|
||||
(* ;; "The ultimate target device keeps a map of prefixes and the hostnames they map to. If a PHOST preference isn't provided and two prefixes have common initial substrings, choose the one that provides the smallest file name. ")
|
||||
|
||||
(change (fetch (TARGETDEVICE PREFIXMAP) OF TARGETDEVICE)
|
||||
(SORT (CONS (LIST PREFIX HOST (CL:IF (EQ (CHARCODE /)
|
||||
(NTHCHARCODE PREFIX -1))
|
||||
'/
|
||||
'<))
|
||||
DATUM)
|
||||
(FUNCTION (LAMBDA (P1 P2)
|
||||
(IGREATERP (NCHARS (CAR P1))
|
||||
(NCHARS (CAR P2]
|
||||
elseif (SETQ PREFIX (CADR (PSEUDOHOSTP HOST)))
|
||||
(UNINTERRUPTABLY
|
||||
[change (fetch (TARGETDEVICE PREFIXMAPS) OF TARGETDEVICE)
|
||||
(SORT (CONS (LIST HOST PREFIX (CL:IF (EQ (CHARCODE /)
|
||||
(NTHCHARCODE PREFIX -1))
|
||||
'/
|
||||
'<))
|
||||
DATUM)
|
||||
(FUNCTION (LAMBDA (P1 P2)
|
||||
|
||||
(* ;; "To give smallest file names, longest prefix comes first. If same length (synonyms), the one with the smallest host comes first. So MEDLEY before WMEDLEY")
|
||||
|
||||
(if (IGREATERP (NCHARS (CADR P1))
|
||||
(NCHARS (CADR P2)))
|
||||
elseif (EQ (NCHARS (CADR P1))
|
||||
(NCHARS (CADR P2)))
|
||||
then (ILESSP (NCHARS (CAR P1))
|
||||
(NCHARS (CAR P2])]
|
||||
elseif (PSEUDOHOSTP HOST)
|
||||
then
|
||||
(* ;; "\DEFINEDEVICE removes the name-mapping but doesn't remove the device. Maybe that's on purpose for other devices, but not here.")
|
||||
|
||||
(LET* ((PHHOST (\GETDEVICEFROMNAME HOST \FILEDEVICES))
|
||||
(TARGETDEV (fetch (PHDEVICE TARGETDEV) OF PHHOST)))
|
||||
(TARGETDEV (fetch (PHDEVICE TARGETDEV) of PHHOST)))
|
||||
(UNINTERRUPTABLY
|
||||
(CL:WHEN TARGETDEV (* ;
|
||||
"Don't want to fail uninterruptably")
|
||||
(CHANGE (FETCH (TARGETDEVICE PREFIXMAP) OF TARGETDEV)
|
||||
(DREMOVE (ASSOC PREFIX DATUM)
|
||||
(CHANGE (fetch (TARGETDEVICE PREFIXMAPS) of TARGETDEV)
|
||||
(DREMOVE (ASSOC HOST DATUM)
|
||||
DATUM)))
|
||||
(SETQ \FILEDEVICES (DREMOVE PHHOST \FILEDEVICES))
|
||||
(\DEFINEDEVICE HOST NIL))]
|
||||
HOST])
|
||||
(\DEFINEDEVICE HOST NIL)))
|
||||
elseif NOERROR
|
||||
else (ERROR (CONCAT "PREFIX FOR PSEUDOHOST " HOST " NOT FOUND")))
|
||||
(CL:WHEN (AND PREFIX CDSUFFIX)
|
||||
(CDPSEUDO HOST CDSUFFIX))
|
||||
(CL:WHEN PREFIX (* ;
|
||||
"If no prefix, we didn't get a pseudohost")
|
||||
HOST)])
|
||||
|
||||
(PSEUDOHOSTP
|
||||
[LAMBDA (HOST) (* ; "Edited 16-Dec-2024 21:15 by rmk")
|
||||
[LAMBDA (HOST) (* ; "Edited 27-Apr-2026 17:27 by rmk")
|
||||
(* ; "Edited 16-Dec-2024 21:15 by rmk")
|
||||
(* ; "Edited 24-Feb-2022 23:51 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 11:29 by rmk")
|
||||
(LET [(DEV (if (type? FDEV HOST)
|
||||
@@ -144,37 +169,14 @@
|
||||
then (fetch (STREAM DEVICE) of HOST)
|
||||
else (\GETDEVICEFROMNAME HOST T T]
|
||||
(CL:WHEN (AND DEV (type? FDEV (fetch (PHDEVICE TARGETDEV) OF DEV)))
|
||||
(LIST (FETCH (FDEV DEVICENAME) OF DEV)
|
||||
(FETCH (PHDEVICE PREFIX)
|
||||
DEV)))])
|
||||
(LIST (fetch (FDEV DEVICENAME) of DEV)
|
||||
(fetch (PHDEVICE PREFIX) of DEV)))])
|
||||
|
||||
(PSEUDOHOSTS
|
||||
[LAMBDA (NEW.HOSTS) (* ; "Edited 17-Jan-2022 18:15 by rmk")
|
||||
(* ; "Edited 16-May-2025 9:16 by fgh")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " Returns existing list of PSEUDOHOST pairs. If NEW.HOSTS is T, all current pseudohosts are removed by calling (PSEUDOHOST HOST NIL) on each current pseudohost in turn. Otherwise, NEW.HOSTS should be a list of (HOST PREFIX) pairs and all current pseudohosts are r(PSEUDOHOSTSemoved (as above) and the NEW.HOSTS pairs are used to create new pseudohosts by calling (PSEUDOHOST HOST PREFIX) sequentially in reverse order of the NEW.HOSTS list. Reverse order to ensure that (PSEUDOHOSTS (PSEUDOHOSTS)) doesn't impact the ordering in the PSEUDOHOST list. This function is designed to be used cleanly with RESETSAVE.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(LET [(CURRENT.HOSTS (for DEV in \FILEDEVICES when (type? FDEV (fetch (PHDEVICE TARGETDEV)
|
||||
of DEV))
|
||||
collect (LIST (fetch (FDEV DEVICENAME) of DEV)
|
||||
(fetch (PHDEVICE PREFIX) of DEV]
|
||||
[COND
|
||||
((EQ NEW.HOSTS T)
|
||||
(for HOST in CURRENT.HOSTS do (PSEUDOHOST (CAR HOST)
|
||||
NIL)))
|
||||
[[AND (LISTP NEW.HOSTS)
|
||||
(for HOST in NEW.HOSTS always (AND (LISTP HOST)
|
||||
(NOT (CDDR HOST]
|
||||
(for HOST in CURRENT.HOSTS do (PSEUDOHOST (CAR HOST)
|
||||
NIL))
|
||||
(for HOST in (REVERSE NEW.HOSTS) do (PSEUDOHOST (CAR HOST)
|
||||
(CADR HOST]
|
||||
(NEW.HOSTS (ERROR (CONCAT "PSEUDOHOSTS: Argument not valid:" NEW.HOSTS]
|
||||
CURRENT.HOSTS])
|
||||
[LAMBDA NIL (* ; "Edited 17-Jan-2022 18:15 by rmk")
|
||||
(FOR DEV IN \FILEDEVICES WHEN (TYPE? FDEV (FETCH (PHDEVICE TARGETDEV) OF DEV))
|
||||
COLLECT (LIST (FETCH (FDEV DEVICENAME) OF DEV)
|
||||
(FETCH (PHDEVICE PREFIX) OF DEV])
|
||||
|
||||
(TARGETHOST
|
||||
[LAMBDA (HOST) (* ; "Edited 14-Dec-2024 15:26 by rmk")
|
||||
@@ -203,7 +205,8 @@
|
||||
else DEV])
|
||||
|
||||
(TRUEFILENAME
|
||||
[LAMBDA (FILE) (* ; "Edited 1-Oct-2023 20:16 by rmk")
|
||||
[LAMBDA (FILE NOERROR) (* ; "Edited 2-Feb-2025 09:12 by rmk")
|
||||
(* ; "Edited 1-Oct-2023 20:16 by rmk")
|
||||
(* ; "Edited 26-Jul-2023 07:53 by rmk")
|
||||
(* ; "Edited 26-Jan-2022 23:33 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 08:47 by rmk")
|
||||
@@ -215,22 +218,60 @@
|
||||
FILE))
|
||||
(SETQ DEVICE (FETCH (STREAM DEVICE) OF FILE))
|
||||
ELSE (SETQ FILENAME (\ADD.CONNECTED.DIR FILE))
|
||||
(SETQ DEVICE (\GETDEVICEFROMNAME FILENAME)))
|
||||
(CL:IF (TYPE? PHDEVICE DEVICE)
|
||||
(EXPAND.PH FILENAME DEVICE)
|
||||
FILENAME)])
|
||||
(SETQ DEVICE (\GETDEVICEFROMNAME FILENAME NOERROR)))
|
||||
(CL:WHEN DEVICE
|
||||
(CL:IF (TYPE? PHDEVICE DEVICE)
|
||||
(EXPAND.PH FILENAME DEVICE)
|
||||
FILENAME))])
|
||||
|
||||
(PSEUDOFILENAME
|
||||
[LAMBDA (FILE) (* ; "Edited 26-Jul-2023 12:34 by rmk")
|
||||
[LAMBDA (FILE PHOST) (* ; "Edited 27-Apr-2026 18:50 by rmk")
|
||||
(* ; "Edited 26-Apr-2026 09:00 by rmk: If PHOST is non-NIL and a pseudohost, that's the one that the caller wants.")
|
||||
(* ; "Edited 24-Apr-2026 22:52 by rmk")
|
||||
(* ; "Edited 26-Jul-2023 12:34 by rmk")
|
||||
(* ; "Edited 29-Jan-2022 23:08 by rmk")
|
||||
(* ; "Edited 28-Jan-2022 09:06 by rmk")
|
||||
(if (LISTP FILE)
|
||||
then (for F in FILE collect (PSEUDOFILENAME F))
|
||||
else (FOR D PN (FILENAME _ (IF (STREAMP FILE)
|
||||
THEN (FETCH (STREAM FULLFILENAME) OF FILE)
|
||||
ELSE (\ADD.CONNECTED.DIR FILE))) IN \FILEDEVICES
|
||||
WHEN (TYPE? PHDEVICE D) UNLESS (EQ FILENAME (SETQ PN (CONTRACT.PH FILENAME D)))
|
||||
DO (RETURN PN) FINALLY (RETURN FILENAME])
|
||||
then (for F in FILE collect (PSEUDOFILENAME F PHOST))
|
||||
else (for D PN (FILENAME _ (if (STREAMP FILE)
|
||||
then (fetch (STREAM FULLFILENAME) of FILE)
|
||||
else (\ADD.CONNECTED.DIR FILE))) in \FILEDEVICES
|
||||
when (type? PHDEVICE D) when (OR (NULL PHOST)
|
||||
(EQ PHOST (fetch (FDEV DEVICENAME) of D)))
|
||||
unless (EQ FILENAME (SETQ PN (CONTRACT.PH FILENAME D PHOST))) do (RETURN PN)
|
||||
finally (RETURN FILENAME])
|
||||
|
||||
(PSEUDOFILENAMES
|
||||
[LAMBDA (FILE) (* ; "Edited 27-Apr-2026 19:23 by rmk")
|
||||
(* ;
|
||||
"Edited 27-Apr-2026 10:00 by rmk; Edited 27-Apr-2026 09:33 by rmk")
|
||||
|
||||
(* ;; "Shows all the pseudohost synonyms for FILE (including its truename)")
|
||||
|
||||
(for D PN (TRUENAME _ (TRUEFILENAME FILE)) in \FILEDEVICES when (type? PHDEVICE D)
|
||||
unless [EQ TRUENAME (SETQ PN (PSEUDOFILENAME TRUENAME (fetch (FDEV DEVICENAME) of D]
|
||||
collect PN finally (RETURN (CONS TRUENAME $$VAL])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CDPSEUDO
|
||||
[LAMBDA (PHOST CDSUFFIX FILEPKGFLG) (* ; "Edited 27-Apr-2026 22:54 by rmk")
|
||||
(* ; "Edited 25-Apr-2026 23:53 by rmk")
|
||||
(* ; "Edited 21-Dec-2024 13:48 by rmk")
|
||||
(* ; "Edited 6-Feb-2024 15:50 by rmk")
|
||||
|
||||
(* ;; "Makes a cd command for PHOST. The command name is %"cd%" followed by the lower-case letters of CDSUFFIX (e.g. cdf for PHOST FOO and CDSUFFIX %"f%".")
|
||||
|
||||
(* ;; "Does not notify FILEPKG unless FILEPKGFLG")
|
||||
|
||||
(DECLARE (SPECVARS FILEPKGFLG))
|
||||
(CL:WHEN (AND (SETQ PHOST (CAR (PSEUDOHOSTP PHOST)))
|
||||
CDSUFFIX)
|
||||
[LET [(CNAME (CONCAT "cd" (L-CASE CDSUFFIX]
|
||||
(SETQ PHOST (CONCAT "{" PHOST "}"))
|
||||
(EVAL `(DEFCOMMAND ,CNAME (SUBDIR) (/CNDIR (CL:IF SUBDIR
|
||||
(CONCAT ,PHOST "/" SUBDIR)
|
||||
,PHOST)))])])
|
||||
)
|
||||
|
||||
|
||||
@@ -242,67 +283,76 @@
|
||||
(EXPAND.PH
|
||||
[LAMBDA (FILENAME PHDEV)
|
||||
|
||||
(* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
|
||||
(* ;; "Edited 27-Apr-2026 17:27 by rmk")
|
||||
|
||||
(* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand to its true name")
|
||||
|
||||
(* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
|
||||
|
||||
[IF (TYPE? STREAM FILENAME)
|
||||
THEN (CL:UNLESS PHDEV
|
||||
(SETQ PHDEV (FETCH (STREAM DEVICE) OF FILENAME)))
|
||||
(SETQ FILENAME (FETCH (STREAM FULLNAME) OF FILENAME))
|
||||
ELSEIF (NOT (TYPE? FDEV PHDEV))
|
||||
THEN (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME]
|
||||
(IF (TYPE? PHDEVICE PHDEV)
|
||||
THEN (LET (SUFFIX SUFFIXPOS)
|
||||
[if (type? STREAM FILENAME)
|
||||
then (CL:UNLESS PHDEV
|
||||
(SETQ PHDEV (fetch (STREAM DEVICE) of FILENAME)))
|
||||
(SETQ FILENAME (fetch (STREAM FULLNAME) of FILENAME))
|
||||
elseif (NOT (type? FDEV PHDEV))
|
||||
then (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME]
|
||||
(if (type? PHDEVICE PHDEV)
|
||||
then (LET (SUFFIX SUFFIXPOS)
|
||||
(CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME))
|
||||
(SETQ SUFFIX (OR (SUBSTRING FILENAME (ADD1 SUFFIXPOS))
|
||||
""))
|
||||
(CL:WHEN (FMEMB (CHCON1 SUFFIX)
|
||||
(CHARCODE (< > /)))
|
||||
(SETQ SUFFIX (SUBSTRING SUFFIX 2)))
|
||||
(CONCAT (FETCH (PHDEVICE PREFIX) OF PHDEV)
|
||||
(CONCAT (fetch (PHDEVICE PREFIX) of PHDEV)
|
||||
SUFFIX)))
|
||||
ELSE FILENAME])
|
||||
else FILENAME])
|
||||
|
||||
(CONTRACT.PH
|
||||
[LAMBDA (NAME PHDEV)
|
||||
[LAMBDA (TRUENAME PHDEV PHOST)
|
||||
|
||||
(* ;; "Edited 27-Apr-2026 18:43 by rmk")
|
||||
|
||||
(* ;; "Edited 26-Apr-2026 10:31 by rmk")
|
||||
|
||||
(* ;; "Edited 22-Sep-2023 14:30 by rmk")
|
||||
|
||||
(* ;; "Edited 30-Jan-2022 00:20 by rmk: the smallest pseudoname for NAME. If the NAME was constructed by expanding, then")
|
||||
(* ;; "Finds the preferred pseudoname for TRUENAME, the name on PHOST if given, else the shortest one. The PHDEV is used only to find its targetdev, that's where we scan for matching prefixes. This replaces the chosen prefix of TRUENAME with the corresponding pseudohost.")
|
||||
|
||||
(* ;; "Finds the smallest pseudoname for NAME. The PHDEV is used only to find its targetdev, that's where we scan for matching prefixes. This is so we can find the lowest matching pseudohost in the target's prefix map. If the hosts are defined as {DSK}...{H1}...{H2}, DSK knows the prefixes that lead to H1 and H2, picks the longest matching prefix and replaces it by the corresponding host.")
|
||||
(CL:WHEN TRUENAME
|
||||
(CL:UNLESS (type? FDEV PHDEV)
|
||||
(SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
|
||||
(CL:WHEN (EQ PHOST T)
|
||||
(SETQ PHOST (fetch (FDEV DEVICENAME) of PHDEV)))
|
||||
(LET ((PREFIXMAPS (fetch (TARGETDEVICE PREFIXMAPS) of (fetch (PHDEVICE TARGETDEV)
|
||||
of PHDEV)))
|
||||
PREFIXMNAP SUFFIX CONNECTOR)
|
||||
|
||||
(* ;; "If pseudohosts are defined in terms of other pseudohosts (e.g. FUM is defined in terms of FOO which is defined in terms of LI which is rooted in DSK, then the pseudodevices presumably were created in that order, so the first name we encounter will be the one with the longest prefix. So {DSK}... might collapse to {FUM}. But {FOO}... will not. ")
|
||||
(* ;;
|
||||
"PREFIXMAPs of PHDEVare sorted so that the longest one comes first, if PHOST isn't specified")
|
||||
|
||||
(CL:UNLESS (TYPE? FDEV PHDEV)
|
||||
(SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
|
||||
(CL:WHEN NAME
|
||||
(FOR PM PREFIX SUFFIX CONNECTOR IN (FETCH (TARGETDEVICE PREFIXMAP) OF (FETCH (PHDEVICE
|
||||
TARGETDEV
|
||||
)
|
||||
OF PHDEV))
|
||||
WHEN (STRPOS (SETQ PREFIX (CAR PM))
|
||||
NAME 1 NIL T NIL FILEDIRCASEARRAY)
|
||||
DO
|
||||
(* ;; "This is the lowest host. ")
|
||||
(SETQ PREFIXMAP (find PM in PREFIXMAPS when (OR (NULL PHOST)
|
||||
(EQ PHOST (CAR PM)))
|
||||
suchthat (STRPOS (CADR PM)
|
||||
TRUENAME 1 NIL T NIL FILEDIRCASEARRAY)))
|
||||
|
||||
[SETQ SUFFIX (SUBSTRING NAME (ADD1 (NCHARS PREFIX]
|
||||
(CL:WHEN (STRPOS ">" SUFFIX 1 NIL NIL NIL FILEDIRCASEARRAY)
|
||||
(* ;; "If we didn't find a prefix map, TRUENAME was not related to any pseudohost descending from the target, it is a pure target name, presumably because something like a relative .. reference took it off all paths. We return the original name.")
|
||||
|
||||
(* ;; "CONNECTOR tells us whether to use / or > depending on what the prefix has")
|
||||
(if PREFIXMAP
|
||||
then (SETQ PREFIX (CADR PREFIXMAP))
|
||||
[SETQ SUFFIX (SUBSTRING TRUENAME (ADD1 (NCHARS PREFIX]
|
||||
(CL:WHEN (STRPOS ">" SUFFIX)
|
||||
|
||||
(SETQ CONNECTOR (CADDR PM))
|
||||
[SETQ SUFFIX (CONCAT CONNECTOR (IF (EQ CONNECTOR '/)
|
||||
THEN (SLASHIT SUFFIX)
|
||||
ELSE (UNSLASHIT SUFFIX])
|
||||
(RETURN (PACK* '{ (CADR PM)
|
||||
(* ;;
|
||||
"CONNECTOR tells us whether to use / or > depending on what the prefix has")
|
||||
|
||||
(SETQ CONNECTOR (CADDR PREFIXMAP))
|
||||
[SETQ SUFFIX (CONCAT CONNECTOR (CL:IF (EQ CONNECTOR '/)
|
||||
(SLASHIT SUFFIX)
|
||||
(UNSLASHIT SUFFIX))])
|
||||
(PACK* '{ (CAR PREFIXMAP)
|
||||
"}"
|
||||
(OR SUFFIX ""))) FINALLY
|
||||
|
||||
(* ;; "If we didn't match a prefix, then this was not related to any pseudhost descending from the target, it is a pure target name, presumably because something like a relative .. reference took it off all paths. We return the original name.")
|
||||
|
||||
(RETURN NAME)))])
|
||||
(OR SUFFIX ""))
|
||||
else TRUENAME)))])
|
||||
|
||||
(UNSLASHIT
|
||||
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:09 by rmk")
|
||||
@@ -338,37 +388,23 @@
|
||||
(GETHOSTINFO.PH
|
||||
[LAMBDA (HOST ATTRIBUTE)
|
||||
|
||||
(* ;; "Edited 26-Nov-2025 17:26 by rmk")
|
||||
|
||||
(* ;; "Edited 24-Apr-2022 14:16 by rmk: the info from the true host")
|
||||
|
||||
(* ;; "Want the info from the true host")
|
||||
|
||||
(GETHOSTINFO.ORIG (OR (TARGETHOST HOST)
|
||||
HOST)
|
||||
HOST ATTRIBUTE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CDPSEUDO
|
||||
[LAMBDA (PHOST CDSUFFIX FILEPKG) (* ; "Edited 21-Dec-2024 13:48 by rmk")
|
||||
(* ; "Edited 6-Feb-2024 15:50 by rmk")
|
||||
|
||||
(* ;; "Makes a cd command for PHOST. The command name is %"cd%" followed by the lower-case letters of CDSUFFIX (e.g. cdf for PHOST FOO and CDSUFFIX %"f%".")
|
||||
|
||||
(CL:WHEN (AND (SETQ PHOST (CAR (PSEUDOHOSTP PHOST)))
|
||||
CDSUFFIX)
|
||||
[LET ((C (PACK* "cd" (L-CASE CDSUFFIX)))
|
||||
(FILEPKGFLG FILEPKG))
|
||||
(DECLARE (SPECVARS FILEPKGFLG))
|
||||
(SETQ PHOST (CONCAT "{" PHOST "}"))
|
||||
(EVAL `(DEFCOMMAND ,C (SUBDIR) (/CNDIR (CL:IF SUBDIR
|
||||
(CONCAT ,PHOST "/" SUBDIR)
|
||||
,PHOST)))])])
|
||||
ATTRIBUTE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OPENFILE.PH
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)
|
||||
|
||||
(* ;; "Edited 26-Apr-2026 10:25 by rmk")
|
||||
|
||||
(* ;; "Edited 31-Oct-2022 23:32 by rmk")
|
||||
|
||||
(* ;; "Edited 14-Jul-2022 17:53 by rmk")
|
||||
@@ -379,18 +415,19 @@
|
||||
|
||||
(* ;; "Edited 18-Jan-2022 10:29 by rmk")
|
||||
|
||||
(LET ((TARGETDEV (FETCH (PHDEVICE TARGETDEV) OF FDEV))
|
||||
(LET ((TARGETDEV (fetch (PHDEVICE TARGETDEV) of FDEV))
|
||||
(STREAM (PSEUDOHOST.TARGETVAL OPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)
|
||||
FDEV)))
|
||||
(CL:WHEN STREAM
|
||||
(FDEVOP 'UNREGISTERFILE TARGETDEV TARGETDEV STREAM)
|
||||
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
|
||||
(CONTRACT.PH DATUM FDEV))
|
||||
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV))
|
||||
(change (fetch (STREAM FULLFILENAME) of STREAM)
|
||||
(CONTRACT.PH DATUM FDEV T))
|
||||
(replace (STREAM DEVICE) of STREAM with FDEV))
|
||||
STREAM])
|
||||
|
||||
(GETFILENAME.PH
|
||||
[LAMBDA (NAME RECOG FDEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
[LAMBDA (NAME RECOG FDEV) (* ; "Edited 25-Apr-2026 16:11 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(* ; "Edited 16-Jan-2022 20:27 by rmk")
|
||||
(PSEUDOHOST.NAME GETFILENAME (NAME RECOG FDEV])
|
||||
|
||||
@@ -413,52 +450,24 @@
|
||||
STREAM ABORTFLG])
|
||||
|
||||
(REOPENFILE.PH
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 25-Jan-2022 12:50 by rmk")
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 26-Apr-2026 10:26 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 12:50 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 11:41 by rmk")
|
||||
(LET ((STREAM (PSEUDOHOST.TARGETVAL REOPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
|
||||
FDEV)))
|
||||
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
|
||||
(CONTRACT.PH DATUM FDEV))
|
||||
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV)
|
||||
(CHANGE (fetch (STREAM FULLFILENAME) of STREAM)
|
||||
(CONTRACT.PH DATUM FDEV T))
|
||||
(replace (STREAM DEVICE) of STREAM with FDEV)
|
||||
STREAM])
|
||||
|
||||
(DELETEFILE.PH
|
||||
[LAMBDA (FILENAME DEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 10:23 by rmk")
|
||||
[LAMBDA (FILENAME DEV) (* ; "Edited 25-Apr-2026 23:41 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(PSEUDOHOST.NAME DELETEFILE (FILENAME DEV])
|
||||
|
||||
(OPENP.PH
|
||||
[LAMBDA (FILENAME ACCESS DEVICE)
|
||||
|
||||
(* ;; "Edited 25-Jun-2022 15:48 by rmk: No longer called. Streams are registered in the pseudohost, not in the target device.")
|
||||
|
||||
(* ;; "Edited 18-Jan-2022 10:29 by rmk")
|
||||
|
||||
(PSEUDOHOST.TARGETVAL OPENP (FILENAME ACCESS DEVICE])
|
||||
|
||||
(UNREGISTERFILE.PH
|
||||
[LAMBDA (DEVICE STREAM) (* ; "Edited 25-Jun-2022 15:07 by rmk")
|
||||
(* ; "Edited 16-Jan-2022 16:47 by rmk")
|
||||
|
||||
(* ;;
|
||||
"This isn't called now because files are now registered in the pseudohost, not the target device.")
|
||||
|
||||
(APPLY* (FETCH (FDEV UNREGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
|
||||
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
|
||||
STREAM])
|
||||
|
||||
(REGISTERFILE.PH
|
||||
[LAMBDA (DEVICE STREAM) (* ; "Edited 25-Jun-2022 15:07 by rmk")
|
||||
(* ; "Edited 16-Jan-2022 16:46 by rmk")
|
||||
|
||||
(* ;; "This isn't called now, because the stream is registered in the pseudohost, not in the target device.")
|
||||
|
||||
(APPLY* (FETCH (FDEV REGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
|
||||
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
|
||||
STREAM])
|
||||
|
||||
(GENERATEFILES.PH
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 17-Jan-2022 20:46 by rmk")
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 25-Apr-2026 23:21 by rmk")
|
||||
(* ; "Edited 17-Jan-2022 20:46 by rmk")
|
||||
|
||||
(* ;; "FDEV is the pseudohost. We will generate from the target directory using its GENFILESTATE, but fiddle the output so that it looks like it is coming from the pseudo host.")
|
||||
|
||||
@@ -473,26 +482,33 @@
|
||||
(CREATE FILEGENOBJ
|
||||
NEXTFILEFN _ (FUNCTION NEXTFILEFN.PH)
|
||||
FILEINFOFN _ (FUNCTION FILEINFOFN.PH)
|
||||
GENFILESTATE _ (LIST FDEV TARGETGENOBJ])
|
||||
GENFILESTATE _ (LIST FDEV TARGETGENOBJ (fetch (FDEV DEVICENAME) of FDEV])
|
||||
|
||||
(GETFILEINFO.PH
|
||||
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 25-Jan-2022 12:43 by rmk")
|
||||
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 22-Apr-2026 18:12 by rmk")
|
||||
(* ; "Edited 20-Apr-2026 08:30 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 12:43 by rmk")
|
||||
(* ; "Edited 17-Jan-2022 18:21 by rmk")
|
||||
(PSEUDOHOST.TARGETVAL GETFILEINFO (STREAM ATTRIBUTE DEVICE])
|
||||
(GETFILEINFO (TRUEFILENAME STREAM)
|
||||
ATTRIBUTE])
|
||||
|
||||
(SETFILEINFO.PH
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 25-Jan-2022 12:37 by rmk")
|
||||
(PSEUDOHOST.TARGETVAL SETFILEINFO (STREAM ATTRIBUTE VALUE DEVICE])
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 25-Apr-2026 15:52 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 12:37 by rmk")
|
||||
(SETFILEINFO (TRUEFILENAME STREAM)
|
||||
ATTRIBUTE VALUE])
|
||||
|
||||
(NEXTFILEFN.PH
|
||||
[LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 17-Jan-2022 21:27 by rmk")
|
||||
[LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 25-Apr-2026 23:21 by rmk")
|
||||
(* ; "Edited 17-Jan-2022 21:27 by rmk")
|
||||
(LET* ((TARGETGENOBJ (CADR GENFILESTATE))
|
||||
(TARGETGENFILESTATE (FETCH GENFILESTATE OF TARGETGENOBJ))
|
||||
(FILENAME (APPLY* (FETCH NEXTFILEFN OF TARGETGENOBJ)
|
||||
TARGETGENFILESTATE NAMEONLY)))
|
||||
(CL:WHEN FILENAME
|
||||
(CL:UNLESS NAMEONLY
|
||||
(SETQ FILENAME (CONTRACT.PH FILENAME (CAR GENFILESTATE)))))
|
||||
(SETQ FILENAME (CONTRACT.PH FILENAME (CAR GENFILESTATE)
|
||||
(CADDR GENFILESTATE)))))
|
||||
FILENAME])
|
||||
|
||||
(FILEINFOFN.PH
|
||||
@@ -500,27 +516,6 @@
|
||||
(APPLY* (FETCH FILEINFOFN OF (CADR GENFILESTATE))
|
||||
(FETCH GENFILESTATE OF (CADR GENFILESTATE))
|
||||
ATTRIBUTE])
|
||||
|
||||
(RENAMEFILE.PH
|
||||
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Jan-2022 09:52 by rmk")
|
||||
(LET ((OLDTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF OLD-DEVICE))
|
||||
(NEWTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF NEW-DEVICE))
|
||||
(NEWTARGETNAME NEW-NAME)
|
||||
RESULT)
|
||||
(CL:WHEN (TYPE? FDEV NEWTARGETDEV) (* ; "NEW-DEVICE is a pseudo host")
|
||||
(SETQ NEWTARGETNAME (EXPAND.PH NEW-NAME NEW-DEVICE)))
|
||||
(SETQ RESULT (APPLY* (FETCH (FDEV RENAMEFILE) OF OLDTARGETDEV)
|
||||
OLDTARGETDEV
|
||||
(EXPAND.PH OLD-NAME OLD-DEVICE)
|
||||
(OR NEWTARGETDEV NEW-DEVICE)
|
||||
NEWTARGETNAME))
|
||||
(CL:WHEN (AND RESULT (NEQ NEWTARGETDEV NEW-DEVICE))
|
||||
(SETQ RESULT (CONTRACT.PH RESULT NEW-DEVICE)))
|
||||
RESULT])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(PSEUDOHOST 'LI LOGINHOST/DIR)
|
||||
)
|
||||
|
||||
(MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)
|
||||
@@ -536,7 +531,7 @@
|
||||
|
||||
(RECORD PHGENFILESTATE (PHDEVICE . TARGETGENFILESTATE))
|
||||
|
||||
(ACCESSFNS TARGETDEVICE ((PREFIXMAP (FETCH (FDEV FDEV3) OF DATUM)
|
||||
(ACCESSFNS TARGETDEVICE ((PREFIXMAPS (FETCH (FDEV FDEV3) OF DATUM)
|
||||
(REPLACE (FDEV FDEV3) OF DATUM WITH NEWVALUE))))
|
||||
)
|
||||
|
||||
@@ -551,14 +546,14 @@
|
||||
(* ;;
|
||||
"Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately")
|
||||
|
||||
`(CONTRACT.PH [APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV)
|
||||
`(CONTRACT.PH [APPLY* (fetch (FDEV ,OPNAME) of (fetch (PHDEVICE TARGETDEV)
|
||||
OF ,DEV))
|
||||
(EXPAND.PH ,(CAR ARGS)
|
||||
,DEV)
|
||||
,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV)
|
||||
,@(SUBST `(fetch (PHDEVICE TARGETDEV) of ,DEV)
|
||||
DEV
|
||||
(CDR ARGS]
|
||||
,DEV])
|
||||
,DEV T])
|
||||
|
||||
(PUTPROPS PSEUDOHOST.TARGETVAL MACRO
|
||||
[TAIL (LET [(OPNAME (CAR TAIL))
|
||||
@@ -576,19 +571,14 @@
|
||||
DEV
|
||||
(CDR ARGS])
|
||||
)
|
||||
|
||||
|
||||
(FILESLOAD (FROM LOADUPS)
|
||||
EXPORTS.ALL)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1331 13754 (PSEUDOHOST 1341 . 7049) (PSEUDOHOSTP 7051 . 7880) (PSEUDOHOSTS 7882 . 9925)
|
||||
(TARGETHOST 9927 . 10796) (TRUEDEVICE 10798 . 11754) (TRUEFILENAME 11756 . 12881) (PSEUDOFILENAME
|
||||
12883 . 13752)) (13782 19797 (EXPAND.PH 13792 . 15045) (CONTRACT.PH 15047 . 17758) (UNSLASHIT 17760 .
|
||||
19506) (GETHOSTINFO.PH 19508 . 19795)) (19798 20699 (CDPSEUDO 19808 . 20697)) (20700 28720 (
|
||||
OPENFILE.PH 20710 . 21783) (GETFILENAME.PH 21785 . 22074) (DIRECTORYNAMEP.PH 22076 . 22700) (
|
||||
CLOSEFILE.PH 22702 . 23169) (REOPENFILE.PH 23171 . 23736) (DELETEFILE.PH 23738 . 24022) (OPENP.PH
|
||||
24024 . 24319) (UNREGISTERFILE.PH 24321 . 24863) (REGISTERFILE.PH 24865 . 25399) (GENERATEFILES.PH
|
||||
25401 . 26445) (GETFILEINFO.PH 26447 . 26749) (SETFILEINFO.PH 26751 . 26950) (NEXTFILEFN.PH 26952 .
|
||||
27498) (FILEINFOFN.PH 27500 . 27775) (RENAMEFILE.PH 27777 . 28718)))))
|
||||
(FILEMAP (NIL (1128 14735 (PSEUDOHOST 1138 . 8248) (PSEUDOHOSTP 8250 . 9169) (PSEUDOHOSTS 9171 . 9532)
|
||||
(TARGETHOST 9534 . 10403) (TRUEDEVICE 10405 . 11361) (TRUEFILENAME 11363 . 12650) (PSEUDOFILENAME
|
||||
12652 . 14064) (PSEUDOFILENAMES 14066 . 14733)) (14736 15885 (CDPSEUDO 14746 . 15883)) (15913 21797 (
|
||||
EXPAND.PH 15923 . 17229) (CONTRACT.PH 17231 . 19713) (UNSLASHIT 19715 . 21461) (GETHOSTINFO.PH 21463
|
||||
. 21795)) (21798 28419 (OPENFILE.PH 21808 . 22933) (GETFILENAME.PH 22935 . 23333) (DIRECTORYNAMEP.PH
|
||||
23335 . 23959) (CLOSEFILE.PH 23961 . 24428) (REOPENFILE.PH 24430 . 25106) (DELETEFILE.PH 25108 . 25392
|
||||
) (GENERATEFILES.PH 25394 . 26588) (GETFILEINFO.PH 26590 . 27111) (SETFILEINFO.PH 27113 . 27422) (
|
||||
NEXTFILEFN.PH 27424 . 28140) (FILEINFOFN.PH 28142 . 28417)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
137
library/SAMEDIR
137
library/SAMEDIR
@@ -1,15 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "31-Oct-2022 13:09:14" {WMEDLEY}<library>SAMEDIR.;4 6221
|
||||
(FILECREATED "27-Apr-2026 21:18:26" {WMEDLEY}<library>SAMEDIR.;6 6540
|
||||
|
||||
:CHANGES-TO (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "25-Apr-2022 09:23:16" {WMEDLEY}<library>SAMEDIR.;3)
|
||||
:CHANGES-TO (FNS CHECKSAMEDIR)
|
||||
|
||||
:PREVIOUS-DATE "31-Oct-2022 13:09:14" {MEDLEY}<library>SAMEDIR.;4)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SAMEDIRCOMS)
|
||||
|
||||
@@ -24,7 +22,8 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(CHECKSAMEDIR
|
||||
[LAMBDA (FILE) (* ; "Edited 31-Oct-2022 13:08 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 27-Apr-2026 21:18 by rmk")
|
||||
(* ; "Edited 31-Oct-2022 13:08 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:16 by rmk")
|
||||
(* ; "Edited 1-Sep-2020 11:40 by rmk:")
|
||||
|
||||
@@ -32,70 +31,75 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
|
||||
(* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.")
|
||||
|
||||
(* ;;
|
||||
"MIGRATIONS may be provided as a global variable, to suppress the askusers. See documentation. ")
|
||||
|
||||
[RESETSAVE (DIRECTORYNAME T)
|
||||
'(PROGN (CNDIR OLDVALUE] (* ;
|
||||
'(PROGN (CNDIR OLDVALUE]
|
||||
(SETQ FILE (ROOTFILENAME FILE)) (* ;
|
||||
"Assumes that MAKEFILE has RESETLST")
|
||||
(PROG ((*UPPER-CASE-FILE-NAMES* NIL)
|
||||
(DATES (GET (SETQ FILE (ROOTFILENAME FILE))
|
||||
'FILEDATES))
|
||||
HOST/DIR HOST DIR NEWV OKHOST/DIRS)
|
||||
[OLDFILE (CDAR (LISTP (GET FILE 'FILEDATES]
|
||||
PREVPDIRS HOST/DIR NEWV OKHOST/DIRS OLDDIR)
|
||||
(CL:UNLESS OLDFILE (RETURN))
|
||||
|
||||
(* ;; "Only the first previor location matters. If we moved it, we don't want to move it back.")
|
||||
|
||||
(SETQ OLDDIR (HOST&DIRECTORYFIELD OLDFILE))
|
||||
|
||||
(* ;; "PREVPDIRS is a list of all possible pseudohost synonyms for the previous location of FILE. Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory")
|
||||
|
||||
(SETQ PREVPDIRS (PSEUDOFILENAMES OLDDIR)) (* ;
|
||||
"Any pseudohost or migrating pseudohost is good")
|
||||
(SETQ OKHOST/DIRS (APPEND (for M in MIGRATIONS when (CL:MEMBER (CAR M)
|
||||
PREVPDIRS :TEST
|
||||
(FUNCTION STRING-EQUAL))
|
||||
collect (CDR M))
|
||||
PREVPDIRS))
|
||||
AGAIN
|
||||
(OR (LISTP DATES)
|
||||
(RETURN)) (* ;
|
||||
"RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory")
|
||||
[SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T)))
|
||||
(MKLIST (CDR (OR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL)
|
||||
(ASSOC (TRUEFILENAME HOST/DIR)
|
||||
MIGRATIONS :TEST 'STRING-EQUAL)
|
||||
(ASSOC (PSEUDOFILENAME HOST/DIR)
|
||||
MIGRATIONS :TEST 'STRING-EQUAL]
|
||||
(COND
|
||||
([for OLDFILE in DATES bind HOST DIR
|
||||
never (OR (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL)
|
||||
(CL:MEMBER (TRUEFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE)))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL)
|
||||
(CL:MEMBER (PSEUDOFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE)))
|
||||
OKHOST/DIRS :TEST 'STRING-EQUAL]
|
||||
(* ; "Come here on new directory")
|
||||
(SETQ HOST/DIR (DIRECTORYNAME T)) (* ;
|
||||
"Current directory, maybe newly connected")
|
||||
(if (NOT (CL:MEMBER HOST/DIR OKHOST/DIRS :TEST (FUNCTION STRING-EQUAL)))
|
||||
then
|
||||
(* ;; "The file would go somewhere new. Is that what the user really wants?")
|
||||
|
||||
(* ;; "The file is going somewhere it has never been before. ")
|
||||
(SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written"
|
||||
FILE
|
||||
"in your connected directory"
|
||||
HOST/DIR
|
||||
"-- write it out anyway")
|
||||
`[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR OLDDIR]
|
||||
(C "Make file on other directory: ")
|
||||
(Y ,(CONCAT "Yes, write it here")
|
||||
(CHARACTER (CHARCODE EOL)))
|
||||
(N ,(CONCAT "No, abort MAKEFILE")
|
||||
(CHARACTER (CHARCODE EOL]
|
||||
NIL NIL '(NOECHOFLG T))
|
||||
(Y (RETURN))
|
||||
(N (ERROR!))
|
||||
(C (SETQ HOST/DIR NIL))
|
||||
(O (* ;
|
||||
"Choose DATE directory above, switch in NLSETQ below, switch back in RESETSAVE above")
|
||||
(TERPRI T))
|
||||
(SHOULDNT))
|
||||
(CL:WHEN [NLSETQ (CNDIR (OR HOST/DIR (READ T T]
|
||||
(RETURN))
|
||||
(GO AGAIN)
|
||||
elseif (AND (SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY OLDFILE)))
|
||||
(NOT (STRING-EQUAL NEWV OLDFILE)))
|
||||
then
|
||||
(* ;; "A newer version appeared while the user was editing this file.")
|
||||
|
||||
(* ;; "Check that that is really what the user wants.")
|
||||
(* ;; "Ask if he should over-write it.")
|
||||
|
||||
(SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE
|
||||
"in your connected directory"
|
||||
HOST/DIR "-- write it out anyway")
|
||||
`[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR (
|
||||
HOST&DIRECTORYFIELD
|
||||
(CDAR DATES]
|
||||
(C "Make file on other directory: ")
|
||||
(Y ,(CONCAT "Yes, write it here")
|
||||
(CHARACTER (CHARCODE EOL)))
|
||||
(N ,(CONCAT "No, abort MAKEFILE")
|
||||
(CHARACTER (CHARCODE EOL]
|
||||
NIL NIL '(NOECHOFLG T))
|
||||
(Y (RETURN))
|
||||
(N (ERROR!))
|
||||
(C (SETQ HOST/DIR))
|
||||
(O (TERPRI T))
|
||||
(SHOULDNT))
|
||||
[NLSETQ (CNDIR (OR HOST/DIR (READ T T]
|
||||
(GO AGAIN))
|
||||
([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES]
|
||||
(NOT (STRING-EQUAL NEWV (CDAR DATES]
|
||||
|
||||
(* ;; "A newer version appeared while the user was editing this file.")
|
||||
|
||||
(* ;; "Ask if he should over-write it.")
|
||||
|
||||
(SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES)
|
||||
"is not the most recent version (version"
|
||||
(FILENAMEFIELD.STRING NEWV 'VERSION)
|
||||
"has since appeared)."
|
||||
"Do you want to make the file anyway"))
|
||||
(Y)
|
||||
(N (ERROR!))
|
||||
(SHOULDNT])
|
||||
(SELECTQ (ASKUSER 15 'Y (LIST OLDFILE "is not the most recent version (version"
|
||||
(FILENAMEFIELD.STRING NEWV 'VERSION)
|
||||
"has since appeared)."
|
||||
"Do you want to make the file anyway"))
|
||||
(Y)
|
||||
(N (ERROR!))
|
||||
(SHOULDNT])
|
||||
|
||||
(HOST&DIRECTORYFIELD
|
||||
[LAMBDA (FILENAME) (* ; "Edited 31-Oct-2022 13:03 by rmk")
|
||||
@@ -120,7 +124,6 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation.
|
||||
|
||||
(GLOBALVARS MIGRATIONS)
|
||||
)
|
||||
(PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (731 5838 (CHECKSAMEDIR 741 . 5249) (HOST&DIRECTORYFIELD 5251 . 5836)))))
|
||||
(FILEMAP (NIL (641 6256 (CHECKSAMEDIR 651 . 5667) (HOST&DIRECTORYFIELD 5669 . 6254)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
|
||||
|
||||
(FILECREATED "31-Mar-2026 09:01:05" {WMEDLEY}<library>UNICODE-TABLES.;22 44782
|
||||
(FILECREATED "26-Apr-2026 10:44:13" {MEDLEY}<library>UNICODE-TABLES.;23 44829
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS XCCS-CHARSETS)
|
||||
:CHANGES-TO (VARS UNICODE-TABLESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "22-Feb-2026 10:44:33" {WMEDLEY}<library>UNICODE-TABLES.;20)
|
||||
:PREVIOUS-DATE "31-Mar-2026 09:01:05" {MEDLEY}<library>UNICODE-TABLES.;22)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODE-TABLESCOMS)
|
||||
@@ -16,7 +16,7 @@
|
||||
(* ;; "This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. ")
|
||||
|
||||
(COMS (* ; "Read Unicode mapping files")
|
||||
(INITVARS (UNICODEDIRECTORIES NIL))
|
||||
[INITVARS (UNICODEDIRECTORIES '({MEDLEY}/unicode/xerox/]
|
||||
(GLOBALVARS UNICODEDIRECTORIES)
|
||||
(VARS XCCS-CHARSETS)
|
||||
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING))
|
||||
@@ -56,7 +56,7 @@
|
||||
(* ; "Read Unicode mapping files")
|
||||
|
||||
|
||||
(RPAQ? UNICODEDIRECTORIES NIL)
|
||||
(RPAQ? UNICODEDIRECTORIES '({MEDLEY}/unicode/xerox/))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS UNICODEDIRECTORIES)
|
||||
@@ -792,12 +792,12 @@
|
||||
UNICODE-EXPORTS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3929 12651 (READ-UNICODE-MAPPING-FILENAMES 3939 . 8408) (READ-UNICODE-MAPPING 8410 .
|
||||
12649)) (12718 19526 (MAKE-UNICODE-TRANSLATION-TABLES 12728 . 15488) (GET-MCCS-UNICODE-MAPPING 15490
|
||||
. 16510) (INVERT-UNICODE-MAPPING 16512 . 18305) (XCCSTOMCCS-MAPPING 18307 . 19524)) (19527 26150 (
|
||||
ALL-UNICODE-MAPPINGS 19537 . 24813) (XCCSJAPANESECHARSETS 24815 . 26148)) (26195 36957 (
|
||||
WRITE-UNICODE-MAPPING 26205 . 29949) (WRITE-UNICODE-INCLUDED 29951 . 34263) (
|
||||
WRITE-UNICODE-MAPPING-HEADER 34265 . 35513) (WRITE-UNICODE-MAPPING-FILENAME 35515 . 36955)) (36958
|
||||
37634 (XCCS-UTF8-AFTER-OPEN 36968 . 37632)) (40159 42248 (UTF8HEXSTRING 40169 . 42246)) (42275 44317 (
|
||||
SHOWCHARS 42285 . 44315)))))
|
||||
(FILEMAP (NIL (3976 12698 (READ-UNICODE-MAPPING-FILENAMES 3986 . 8455) (READ-UNICODE-MAPPING 8457 .
|
||||
12696)) (12765 19573 (MAKE-UNICODE-TRANSLATION-TABLES 12775 . 15535) (GET-MCCS-UNICODE-MAPPING 15537
|
||||
. 16557) (INVERT-UNICODE-MAPPING 16559 . 18352) (XCCSTOMCCS-MAPPING 18354 . 19571)) (19574 26197 (
|
||||
ALL-UNICODE-MAPPINGS 19584 . 24860) (XCCSJAPANESECHARSETS 24862 . 26195)) (26242 37004 (
|
||||
WRITE-UNICODE-MAPPING 26252 . 29996) (WRITE-UNICODE-INCLUDED 29998 . 34310) (
|
||||
WRITE-UNICODE-MAPPING-HEADER 34312 . 35560) (WRITE-UNICODE-MAPPING-FILENAME 35562 . 37002)) (37005
|
||||
37681 (XCCS-UTF8-AFTER-OPEN 37015 . 37679)) (40206 42295 (UTF8HEXSTRING 40216 . 42293)) (42322 44364 (
|
||||
SHOWCHARS 42332 . 44362)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user