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

Rmk175 offline font construction (#2555)

Browse Source 
* Medleyfont format updated to version 2, revised and more complete fonts deployed in fonts/medleydisplayfonts/
* Rename AFONT to ACFONT, include STRIKE formats
* FILESETS:  Add MCCSFONTS to loadup
* MCCSFONTS:  New file that isolates all of the legacy font translations previously spread in other files (MCCS)
* Medleyfont display fonts created offline using new file library/IMPORTFONTS
* LLCHAR:  Add \MAXCHARSET=65535, \MAXCHAR etc.
* git ignores internal/fonts/**

* MEDLEYDIR: Define the pseudohost {MEDLEY} whose prefix set to the current value of MEDLEYDIR whenever system restarts
* (MEDLEYDIR xxx) entries in MEDLEY-INIT-VARS removed in favor of {MEDLEY}xxx
* Add cdm command to connect to {MEDLEY} and its subdirectories
This commit is contained in:
rmkaplan
2026-05-11 12:08:05 -07:00
committed by GitHub
parent bbf9f73cda
commit 5aa79ebb06
350 changed files with 4374 additions and 3377 deletions
Download Patch File Download Diff File Expand all files Collapse all files

373
sources/AFONT → sources/ACFONT
View File

@@ -1,36 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
(FILECREATED "22-Jul-2025 23:20:06" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;15 27510
(FILECREATED "15-Apr-2026 09:04:48" {WMEDLEY}<sources>ACFONT.;11 42920
:EDIT-BY rmk
:CHANGES-TO (VARS AFONTCOMS)
:CHANGES-TO (VARS ACFONTCOMS)
:PREVIOUS-DATE "21-Jul-2025 00:14:04"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;14)
:PREVIOUS-DATE "13-Apr-2026 09:00:05" {WMEDLEY}<sources>ACFONT.;10)
(PRETTYCOMPRINT AFONTCOMS)
(PRETTYCOMPRINT ACFONTCOMS)
(RPAQQ AFONTCOMS
(RPAQQ ACFONTCOMS
[
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
(* ;; "AC and STRIKE font file support. ")
(XCL:FILE-ENVIRONMENTS "AFONT")
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX))
(FNS ACFONT.FILEP ACFONT.GETCHARSET \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST
\ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \FACECODE \FAMILYCODE)
(ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET])
(PROP FILETYPE ACFONT)
[APPENDVARS (DISPLAYCHARSETFNS '(AC ACFONT.FILEP ACFONT.GETCHARSET]
(COMS (* ; "STRIKE format files")
(FNS STRIKEFONT.FILEP STRIKEFONT.GETCHARSET WRITESTRIKEFONTFILE STRIKECSINFO)
(APPENDVARS (DISPLAYCHARSETFNS '(STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET])
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
(* ;; "AC and STRIKE font file support. ")
(XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL"
:READTABLE "INTERLISP"
:COMPILER :COMPILE-FILE)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
@@ -78,7 +75,9 @@
4))))])
(ACFONT.GETCHARSET
[LAMBDA (STRM CHARSET) (* ; "Edited 14-Jul-2025 19:50 by rmk")
[LAMBDA (STRM CHARSET FONT) (* ; "Edited 28-Mar-2026 23:02 by rmk")
(* ; "Edited 27-Mar-2026 07:59 by rmk")
(* ; "Edited 14-Jul-2025 19:50 by rmk")
(* ; "Edited 17-May-2025 10:15 by rmk")
(* ;;
@@ -87,36 +86,31 @@
(\READACFONTFILE STRM])
(\READACFONTBOXES
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48")
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48")
(* ;
 "GETACCHARSPECS returns (bbox bboy bbdx bbdy)")
(* ;
 "if bbdx and bbdy are both zero, then treat it as a space.")
(SETFILEPTR FILE 48) (* ;
 "Move to the start of AC file's width info.")
(for X from STARTCHAR to ENDCHAR collect (* ;
 "Now collect the 4 bounding box values into a list")
(create BOUNDINGBOX
RASTERWIDTHX _ (PROG1 (\WIN FILE)
RASTERWIDTHX ← (PROG1 (\WIN FILE)
(* ;
 "Read a fraction, and truncate it to an integer # of raster bits")
(\WIN FILE))
RASTERWIDTHY _ (PROG1 (\WIN FILE)
(\WIN FILE))
RASTERWIDTHY ← (PROG1 (\WIN FILE)
(* ;
 "Read a fraction, and truncate it to an integer # of raster bits")
(\WIN FILE))
BBOX _ (SIGNED (\WIN FILE)
(\WIN FILE))
BBOX ← (SIGNED (\WIN FILE)
BITSPERWORD)
BBOY _ (SIGNED (\WIN FILE)
BBOY ← (SIGNED (\WIN FILE)
BITSPERWORD)
BBDX _ (SIGNED (\WIN FILE)
BBDX ← (SIGNED (\WIN FILE)
BITSPERWORD)
BBDY _ (SIGNED (\WIN FILE)
BBDY ← (SIGNED (\WIN FILE)
BITSPERWORD])
(\READACFONTFILE
@@ -129,8 +123,8 @@
(PROG [FBBLIST STARTCHAR ENDCHAR CHARWIDTHLIST CHARIMAGEWIDTHLIST OFFSETS WIDTHS IMAGEWIDTHS
FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST DUMMYCHAROFFSET DUMMYWIDTH
(CSINFO (create CHARSETINFO
IMAGEWIDTHS _ (\CREATECSINFOELEMENT)
LEFTKERN _ (\CREATEKERNELEMENT]
IMAGEWIDTHS ← (\CREATECSINFOELEMENT)
LEFTKERN ← (\CREATEKERNELEMENT]
(CL:UNLESS (GETSTREAM STRM 'INPUT T)
[RESETSAVE (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD))
`(PROGN (CLOSEF? OLDVALUE])
@@ -215,7 +209,7 @@
of FBBLIST]
[replace CHARSETBITMAP of CSINFO with (SETQ CHARBITMAP
(BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET
(for (X _ STARTCHAR)
(for (X ← STARTCHAR)
to ENDCHAR
sum (\FGETWIDTH
IMAGEWIDTHS
@@ -226,7 +220,7 @@
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETOFFSET OFFSETS I DUMMYCHAROFFSET))
(SETQ STARTWORDLIST (\ACCHARPOSLIST STRM STARTCHAR ENDCHAR))
(bind (DESTLEFT _ 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST
(bind (DESTLEFT ← 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST
as STARTWORD in STARTWORDLIST as CHARWIDTH in CHARWIDTHLIST
do (PROG (RASTERINFO BBOX BBBITMAP BBBMBASE)(* ;
 "\ACCHARPOSLIST returns NIL if no raster exists for the code")
@@ -296,19 +290,18 @@
(RETURN CSINFO)))])
(\ACCHARIMAGELIST
[LAMBDA (BOXLIST) (* jds "15-Jun-85 11:37")
(* ;; "Returns a list of the ESCAPEMENTS (ie how far to move after printng this character) for each char in the font.")
[LAMBDA (BOXLIST) (* jds "15-Jun-85 11:37")
(* ;; "Returns a list of the ESCAPEMENTS (ie how far to move after printng this character) for each char in the font.")
(for BOX in BOXLIST collect (fetch (BOUNDINGBOX RASTERWIDTHX) of BOX])
(\ACCHARWIDTHLIST
[LAMBDA (BOXLIST FBBOX) (* jds " 4-Dec-84 16:05")
[LAMBDA (BOXLIST FBBOX) (* jds " 4-Dec-84 16:05")
(* ;
 "GETACCHARSPECS returns (bbox bboy bbdx bbdy)")
(* ;
 "if bbdx and bbdy are both zero, then treat it as a space.")
(for BOX in BOXLIST bind (STARTWORD BBOX BBOY BBDX BBDY)
collect (SETQ BBOX (fetch BBOX of BOX))
(SETQ BBOY (fetch BBOY of BOX))
@@ -318,7 +311,6 @@
((AND (ZEROP BBDX)
(ZEROP BBDY)) (* ;
 "we've found a Space. Smash in a quarter of the maximum width. Maybe should be an explicit em?")
(IMAX 2 (FOLDLO (IPLUS 2 (fetch (FONTBOUNDINGBOX FBBBDX) of FBBOX))
4)))
(T (COND
@@ -327,14 +319,12 @@
(T (IPLUS BBDX (IMAX 0 BBOX])
(\GETFBB
[LAMBDA (BOXLIST) (* jds "17-May-85 10:22")
[LAMBDA (BOXLIST) (* jds "17-May-85 10:22")
(* ;
 "Read a font bounding box from an AC file")
(PROG (RESULTLIST CHARCOUNT BBLIST MAXBBOX MAXBBOY MINBBOX MINBBOY MAXSUMBBOXBBDX MAXSUMBBOYBBDY
(PROG (RESULTLIST CHARCOUNT BBLIST MAXBBOX MAXBBOY MINBBOX MINBBOY MAXSUMBBOXBBDX MAXSUMBBOYBBDY
BBOX BBOY BBDX BBDY) (* ;
 "\GETFBB returns the fbbdx fbbdy fbbox fbboy of an acfont")
(SETQ MINBBOX 32767)
(SETQ MINBBOY 32767)
(SETQ MAXBBOX -32768)
@@ -347,11 +337,9 @@
(SETQ BBDY (fetch (BOUNDINGBOX BBDY) of BOX))
(* ;
 "GETACCHARSPECS returns bbox bboy bbdx bbdy")
(COND
[(IEQP BBDY -1) (* ;
 "This character doesn't exist. Create a dummy bounding box for it")
(SETQ BBLIST '(0 0 0 -1]
(T (COND
((IGREATERP BBOX MAXBBOX)
@@ -375,25 +363,22 @@
(SETQ MAXSUMBBOYBBDY (IPLUS BBOY BBDY]
(* ;
 "\GETFBB returns the fbbdx fbbdy fbbox fbboy of an acfont")
(RETURN (create FONTBOUNDINGBOX
FBBBDX _ (IDIFFERENCE MAXSUMBBOXBBDX MINBBOX)
FBBBDY _ (IDIFFERENCE MAXSUMBBOYBBDY MINBBOY)
FBBBOX _ MINBBOX
FBBBOY _ MINBBOY])
FBBBDX ← (IDIFFERENCE MAXSUMBBOXBBDX MINBBOX)
FBBBDY ← (IDIFFERENCE MAXSUMBBOYBBDY MINBBOY)
FBBBOX ← MINBBOX
FBBBOY ← MINBBOY])
(\ACCHARPOSLIST
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "10-NOV-83 20:19")
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "10-NOV-83 20:19")
(* ;
 "\ACCHARPOSLIST returns the word position of the raster for the nth character of the file")
[SETFILEPTR FILE (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR]
(bind HIWORD LOWORD [DIRECTORYSTART _ (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR]
(bind HIWORD LOWORD [DIRECTORYSTART ← (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR]
first (SETFILEPTR FILE DIRECTORYSTART) for X from STARTCHAR to ENDCHAR
collect (SETQ HIWORD (\WIN FILE))
(SETQ LOWORD (\WIN FILE)) (* ;
 "If the position of the acchar is given as -1,-1 then the raster does not exist so return nil")
(COND
((AND (IEQP HIWORD 65535)
(IEQP LOWORD 65535))
@@ -404,13 +389,13 @@
(\ACROTATECHAR
[LAMBDA (BITMAP) (* ; "Edited 28-Jul-87 18:49 by Snow")
(* ;; "(prog (new.bitmap (width (|fetch| (bitmap bitmapwidth) |of| bitmap)) (height (|fetch| (bitmap bitmapheight) |of| bitmap))) (setq new.bitmap (bitmapcreate height width)) (|for| y |from| 0 |to| (sub1 height) |do| (|for| x |from| 0 |to| (sub1 width) |bind| (y1 _ (idifference (sub1 height) y)) |do| (bitmapbit new.bitmap y1 x (bitmapbit bitmap x y)))) (return new.bitmap))")
(* ;; "(prog (new.bitmap (width (|fetch| (bitmap bitmapwidth) |of| bitmap)) (height (|fetch| (bitmap bitmapheight) |of| bitmap))) (setq new.bitmap (bitmapcreate height width)) (|for| y |from| 0 |to| (sub1 height) |do| (|for| x |from| 0 |to| (sub1 width) |bind| (y1 ← (idifference (sub1 height) y)) |do| (bitmapbit new.bitmap y1 x (bitmapbit bitmap x y)))) (return new.bitmap))")
(ROTATE-BITMAP-LEFT BITMAP])
(\FACECODE
[LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16")
[LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16")
(IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
(REGULAR 0)
(COMPRESSED 6)
@@ -427,13 +412,13 @@
(SHOULDNT])
(\FAMILYCODE
[LAMBDA (FAMILY WSTRM) (* rmk%: "11-Sep-84 10:54")
(* ;; "Returns the family CODE for FAMILY in a standard widths file, leaving the file positioned at the beginning of the next file entry. Returns NIL if FAMILY not found. If FAMILY is T, returns the code for the first family in the index.")
[LAMBDA (FAMILY WSTRM) (* rmk%: "11-Sep-84 10:54")
(* ;; "Returns the family CODE for FAMILY in a standard widths file, leaving the file positioned at the beginning of the next file entry. Returns NIL if FAMILY not found. If FAMILY is T, returns the code for the first family in the index.")
(SETFILEPTR WSTRM 0)
(bind TYPE CODE LENGTH (NCHARS _ (NCHARS FAMILY))
(NEXT _ 0)
(bind TYPE CODE LENGTH (NCHARS ← (NCHARS FAMILY))
(NEXT ← 0)
do (SETFILEPTR WSTRM NEXT)
(SETQ TYPE (\BIN WSTRM))
(SETQ LENGTH (\BIN WSTRM))
@@ -448,16 +433,264 @@
(for I from 1 to NCHARS always (EQ (\BIN WSTRM)
(NTHCHARCODE FAMILY I]
(SETFILEPTR WSTRM NEXT) (* ; "Move file to next entry")
(RETURN CODE))))
(0 (RETURN NIL))
NIL])
)
(ADDTOVAR DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET))
(PUTPROPS ACFONT FILETYPE CL:COMPILE-FILE)
(APPENDTOVAR DISPLAYCHARSETFNS '(AC ACFONT.FILEP ACFONT.GETCHARSET))
(* ; "STRIKE format files")
(DEFINEQ
(STRIKEFONT.FILEP
[LAMBDA (FILE) (* ; "Edited 15-May-2025 17:47 by rmk")
(* ;; "If high bit of type is on, then must be strike. If 2nd bit is on, must be strike-index, and we punt. We don't care about the 3rd bit")
(* ;; "first word has high bits (onebit index fixed). Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width. Lisp doesn't care about 'fixed'")
(RESETLST
(CL:UNLESS (OPENP FILE 'INPUT)
[RESETSAVE (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD))
`(PROGN (CLOSEF? OLDVALUE])
(CL:WHEN [MEMB (\WIN FILE)
(CONSTANT (LIST (LLSH 1 15)
(LOGOR (LLSH 1 15)
(LLSH 1 13]
T))])
(STRIKEFONT.GETCHARSET
[LAMBDA (STRM) (* ; "Edited 3-Aug-2025 22:27 by rmk")
(* ; "Edited 1-Aug-2025 23:50 by rmk")
(* ; "Edited 14-Jul-2025 19:52 by rmk")
(* ; "Edited 9-Jun-2025 14:22 by rmk")
(* ; "Edited 12-Jul-2022 09:19 by rmk")
(* ; "Edited 4-Dec-92 12:11 by jds")
(* ;; "STRM has already been determined to be a vanilla strike-format file holding only the desired charset.")
(* ; "returns a charsetinfo")
(RESETLST
(CL:UNLESS (\GETSTREAM STRM 'INPUT T)
[RESETSAVE (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD))
`(PROGN (CLOSEF? OLDVALUE])
(SETFILEPTR STRM 0)
(CL:UNLESS (STRIKEFONT.FILEP STRM)
(ERROR "Not a STRIKE font file" STRM))
(CL:UNLESS (EQ 2 (GETFILEPTR STRM))
(SETFILEPTR STRM 2))
(LET (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
(SETQ CSINFO (create CHARSETINFO))
(SETQ FIRSTCHAR (\WIN STRM)) (* ; "minimum ascii code")
(SETQ LASTCHAR (\WIN STRM)) (* ; "maximum ascii code")
(\WIN STRM) (* ;
 "MaxWidth which isn't used by anyone.")
(\WIN STRM) (* ;
 "number of words in this StrikeBody")
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
(* ;
 "ascent in scan lines (=FBBdy+FBBoy)")
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
(* ; "descent in scan-lines (=FBBoy)")
(\WIN STRM) (* ;
 "offset in bits (<0 for kerning, else 0, =FBBox)")
(SETQ RW (\WIN STRM)) (* ; "raster width of bitmap")
(* ; "height of bitmap")
(* ;; "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.")
(SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
16)
(SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)
16)))
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
HEIGHT))
(\BINS STRM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW HEIGHT)
BYTESPERWORD)) (* ; "read bits into bitmap")
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
(SETQ NUMBCODES (IDIFFERENCE (ADD1 LASTCHAR)
FIRSTCHAR))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(* ;;
 "Initialize the offsets to 0, all but FIRSTCHAR to be replaced with the slug offset")
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
(for I from FIRSTCHAR as J from 1 to NUMBCODES do
(* ;;
 "J starts at 1 because we know that the offset of J=0 is 0 ?")
(\FSETOFFSET OFFSETS I (\WIN STRM)))
(for I (SLUGOFFSET ← (\WIN STRM)) from 0 to \MAXTHINCHAR
when (EQ 0 (\FGETOFFSET OFFSETS I)) unless (EQ I FIRSTCHAR)
do (\FSETOFFSET OFFSETS I SLUGOFFSET) finally (\FSETOFFSET OFFSETS SLUGCHARINDEX
SLUGOFFSET)
(* ;;
 "There's one more so that \FONTRESETCHARWIDTHS can get the slug width, otherwise not necessary")
(\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
(\WIN STRM)))
(* ;; "Initialize the widths to 0")
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
(\FONTRESETCHARWIDTHS CSINFO 0 SLUGCHARINDEX)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS)
of CSINFO))
CSINFO))])
(WRITESTRIKEFONTFILE
[LAMBDA (FONT CHARSET FILE) (* ; "Edited 30-Aug-2025 23:21 by rmk")
(* ; "Edited 28-Aug-2025 15:09 by rmk")
(* ; "Edited 24-Aug-2025 11:39 by rmk")
(* ; "Edited 3-Aug-2025 22:33 by rmk")
(* ; "Edited 22-May-2025 09:53 by rmk")
(* ; "Edited 1-Feb-2025 12:27 by mth")
(* ; "Edited 12-Jul-2022 14:36 by rmk")
(* kbr%: "21-Oct-85 15:08")
(* ;
 "Write strike FILE using info in FONT. ")
(CL:UNLESS (FONTP FONT)
(LISPERROR "ILLEGAL ARG" FONT))
(CL:UNLESS CHARSET (SETQ CHARSET 0))
(CL:UNLESS (AND (IGEQ CHARSET 0)
(ILEQ CHARSET \MAXCHARSET))
(LISPERROR "ILLEGAL ARG" CHARSET))
(LET (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS MAXWIDTH LENGTH RASTERWIDTH SLUGOFFSET OFFSETS)
(SETQ CSINFO (\INSURECHARSETINFO FONT CHARSET))
(CL:UNLESS CSINFO (ERROR "Couldn't find charset " CHARSET))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(SETQ SLUGOFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX))
(* ;; "Find the first and last non-slug characters")
[SETQ FIRSTCHAR (for I from 0 to \MAXTHINCHAR thereis (NEQ SLUGOFFSET (\FGETOFFSET OFFSETS I
]
[SETQ LASTCHAR (for I from \MAXTHINCHAR to 0 by -1 thereis (NEQ SLUGOFFSET (\FGETOFFSET
OFFSETS I]
[SETQ STREAM (OPENSTREAM FILE 'OUTPUT 'NEW '((TYPE BINARY]
(\WOUT STREAM 32768) (* ; "STRIKE HEADER. ")
(\WOUT STREAM FIRSTCHAR)
(\WOUT STREAM LASTCHAR)
(SETQ MAXWIDTH 0)
[for I from 0 to SLUGCHARINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I]
(\WOUT STREAM MAXWIDTH) (* ; "STRIKE BODY. ")
(* ; "Length. ")
(SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP)
of CSINFO)))
(SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
(ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
RASTERWIDTH)))
(\WOUT STREAM LENGTH) (* ;
 "Ascent, Descent, Xoffset (no longer used) and Rasterwidth. ")
(\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
(\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
(\WOUT STREAM 0)
(\WOUT STREAM RASTERWIDTH) (* ; "Bitmap. ")
[\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
0
(ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]
(* ; "Offsets. ")
[for I (OFFSET ← 0) from FIRSTCHAR to LASTCHAR first (\WOUT STREAM OFFSET)
(* ; "Offset of the first char")
do (CL:UNLESS (EQ SLUGOFFSET (\FGETOFFSET OFFSETS I))
(* ;
 "The slug isn't really here in the bitmap")
(ADD OFFSET (\FGETWIDTH WIDTHS I)))
(\WOUT STREAM OFFSET) finally (* ;
 "Offset for the after-slug, for width")
(\WOUT STREAM (IPLUS OFFSET (\FGETWIDTH WIDTHS
SLUGCHARINDEX]
(CLOSEF STREAM])
(STRIKECSINFO
[LAMBDA (CSINFO) (* ; "Edited 27-Apr-89 13:39 by atm")
(* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker but display slower). If (EQ WIDTHS IMAGEWIDTHS), just return original.")
(PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET
DUMMYOFFSET NEWOFFSETS)
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
(if (EQ WIDTHS IMWIDTHS)
then (RETURN CSINFO))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(SETQ OLDBM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256))
(SETQ BMHEIGHT (BITMAPHEIGHT OLDBM))
[SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR
sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I))
then 0
else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
(\FGETWIDTH WIDTHS I]
(* ;; "")
(* ;; "Initialize new offsets vector")
(* ;; "")
(SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET NEWOFFSETS I 0))
(\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR)
BMWIDTH)
(* ;; "")
(* ;; "Adjust bitmap with so width = imagewidth, fill offsets")
(* ;; "")
(SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1))
(SETQ NEWOFFSET 0)
[for I from 0 to 255 do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I))
(if (IEQP DUMMYOFFSET OLDOFFSET)
then (\FSETOFFSET NEWOFFSETS I BMWIDTH)
else (\FSETOFFSET NEWOFFSETS I NEWOFFSET)
(SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
(\FGETWIDTH WIDTHS I)))
(BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH
IMWIDTHS I)
BMHEIGHT
'REPLACE)
(SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH]
(* ;; "")
(* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same")
(* ;; "")
(SETQ WIDTHS (COPYALL WIDTHS))
[for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I (IMAX (\FGETWIDTH WIDTHS I)
(\FGETIMAGEWIDTH IMWIDTHS I]
(RETURN (create CHARSETINFO
WIDTHS ← WIDTHS
OFFSETS ← NEWOFFSETS
IMAGEWIDTHS ← WIDTHS
CHARSETBITMAP ← NEWBM
YWIDTHS ← (fetch (CHARSETINFO YWIDTHS) of CSINFO)
CHARSETASCENT ← (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
CHARSETDESCENT ← (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO])
)
(APPENDTOVAR DISPLAYCHARSETFNS '(STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2626 27417 (ACFONT.FILEP 2636 . 3520) (ACFONT.GETCHARSET 3522 . 3914) (\READACFONTBOXES
3916 . 6143) (\READACFONTFILE 6145 . 18986) (\ACCHARIMAGELIST 18988 . 19345) (\ACCHARWIDTHLIST 19347
. 20613) (\GETFBB 20615 . 23895) (\ACCHARPOSLIST 23897 . 24947) (\ACROTATECHAR 24949 . 25513) (
\FACECODE 25515 . 26109) (\FAMILYCODE 26111 . 27415)))))
(FILEMAP (NIL (2704 27651 (ACFONT.FILEP 2714 . 3598) (ACFONT.GETCHARSET 3600 . 4210) (\READACFONTBOXES
4212 . 6436) (\READACFONTFILE 6438 . 19287) (\ACCHARIMAGELIST 19289 . 19626) (\ACCHARWIDTHLIST 19628
. 20888) (\GETFBB 20890 . 24168) (\ACCHARPOSLIST 24170 . 25216) (\ACROTATECHAR 25218 . 25768) (
\FACECODE 25770 . 26360) (\FAMILYCODE 26362 . 27649)) (27814 42811 (STRIKEFONT.FILEP 27824 . 28712) (
STRIKEFONT.GETCHARSET 28714 . 34304) (WRITESTRIKEFONTFILE 34306 . 39215) (STRIKECSINFO 39217 . 42809))
)))
STOP

BIN
sources/ACFONT.DFASL Normal file
View File

Binary file not shown.

BIN
sources/AFONT.DFASL
View File

Binary file not shown.

15
sources/FILESETS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "23-Feb-2026 10:32:36" {WMEDLEY}<sources>FILESETS.;32 6226
(FILECREATED "26-Apr-2026 11:53:54" {FOO}FILESETS.;37 6268
:EDIT-BY rmk
:CHANGES-TO (VARS 0LISPSET)
:CHANGES-TO (VARS 1LISPSET 0LISPSET)
:PREVIOUS-DATE "23-Feb-2026 09:36:51" {WMEDLEY}<sources>FILESETS.;31)
:PREVIOUS-DATE "16-Apr-2026 09:01:52" {WMEDLEY}<sources>FILESETS.;34)
(PRETTYCOMPRINT FILESETSCOMS)
@@ -50,15 +50,16 @@
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO LLARRAYELT
EXTERNALFORMAT IOCHAR UNICODE-FORMATS IMAGEIO LLBASIC LLGC LLINTERP LLMVS
DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD
DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLREAD LLBIGNUM
MCCS LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
(RPAQQ 1LISPSET
(ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC
AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART
LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY
DSK UFS UFSCALLC PASSWORDS FONT MEDLEYFONTFORMAT APUTDQ COMPATIBILITY DMISC CMLMACROS
CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT LLDISPLAY))
DSK UFS UFSCALLC PASSWORDS PSEUDOHOSTS MEDLEYDIR FONT MEDLEYFONTFORMAT MCCSFONTS APUTDQ
COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS
MAIKOBITBLT MAIKOINIT LLDISPLAY))
(RPAQQ 2LISPSET (MACHINEINDEPENDENT))

2002
sources/FONT
View File

File diff suppressed because it is too large Load Diff

BIN
sources/FONT.LCOM
View File

Binary file not shown.

100
sources/INTERPRESS
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "19-Jan-2026 17:21:17" {WMEDLEY}<sources>INTERPRESS.;105 215365
(FILECREATED "26-Apr-2026 11:31:17" {WMEDLEY}<sources>INTERPRESS.;111 215607
:EDIT-BY rmk
:PREVIOUS-DATE "24-Dec-2025 11:24:31" {WMEDLEY}<sources>INTERPRESS.;104)
:CHANGES-TO (VARS INTERPRESSCOMS)
:PREVIOUS-DATE "18-Mar-2026 09:45:13" {MEDLEY}<sources>INTERPRESS.;107)
(PRETTYCOMPRINT INTERPRESSCOMS)
@@ -95,7 +97,8 @@
(ADDVARS (INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT WD))
[COMS (* ;
 "Interpress fonts; but see MEDLEY-INIT-VARS")
[INITVARS (INTERPRESSFONTDIRECTORIES '(fonts>medleyinterpressfonts> fonts>ipfonts>))
[INITVARS (INTERPRESSFONTDIRECTORIES (LIST "{MEDLEY}<fonts>medleyinterpressfonts>"
"{MEDLEY}<fonts>ipfonts>"))
(INTERPRESSPRINTWHEELFAMILIES '(BOLDPS ELITE LETTERGOTHIC MASTER PICA PSBOLD
SCIENTIFIC SPOKESMAN TITAN TREND TRENDPS
TROJAN VINTAGE))
@@ -3529,7 +3532,8 @@
(* ; "Interpress fonts; but see MEDLEY-INIT-VARS")
(RPAQ? INTERPRESSFONTDIRECTORIES '(fonts>medleyinterpressfonts> fonts>ipfonts>))
(RPAQ? INTERPRESSFONTDIRECTORIES (LIST "{MEDLEY}<fonts>medleyinterpressfonts>"
"{MEDLEY}<fonts>ipfonts>"))
(RPAQ? INTERPRESSPRINTWHEELFAMILIES '(BOLDPS ELITE LETTERGOTHIC MASTER PICA PSBOLD SCIENTIFIC
SPOKESMAN TITAN TREND TRENDPS TROJAN VINTAGE))
@@ -3562,15 +3566,15 @@
FONTTOMCCSFN _ (MCCSMAPFN FONTSPEC])
(\CREATECHARSET.IP
[LAMBDA (FONTSPEC FONT CHARSET) (* ; "Edited 7-Sep-2025 23:23 by rmk")
[LAMBDA (FONTSPEC FONT CHARSET) (* ; "Edited 17-Mar-2026 08:58 by rmk")
(* ; "Edited 7-Sep-2025 23:23 by rmk")
(* ; "Edited 30-Aug-2025 14:24 by rmk")
(* ; "Edited 28-Aug-2025 23:24 by rmk")
(* ; "Edited 26-Aug-2025 23:43 by rmk")
(* ; "Edited 16-Aug-2025 17:46 by rmk")
(* ; "Edited 5-Aug-2025 22:33 by rmk")
(* ; "Edited 23-Jul-2025 13:22 by rmk")
(OR (\READCHARSET FONTSPEC CHARSET FONT)
(CADR (\COERCECHARSET FONTSPEC CHARSET])
(\READCHARSET FONTSPEC CHARSET])
)
(DEFINEQ
@@ -3827,44 +3831,44 @@
(LOADDEF 'BRUSH 'RECORDS 'IMAGEIO)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (16593 22245 (APPENDBYTE.IP 16603 . 16739) (APPENDIDENTIFIER.IP 16741 . 17263) (
APPENDINT.IP 17265 . 17716) (APPENDINTEGER.IP 17718 . 18290) (APPENDLARGEVECTOR.IP 18292 . 19257) (
APPENDNUMBER.IP 19259 . 19728) (APPENDOP.IP 19730 . 20376) (APPENDRATIONAL.IP 20378 . 20871) (
APPENDSEQUENCEDESCRIPTOR.IP 20873 . 22068) (BYTESININT.IP 22070 . 22243)) (22281 62088 (ARCTO.IP 22291
. 23572) (BEGINMASTER.IP 23574 . 23847) (BEGINPAGE.IP 23849 . 24205) (BEGINPREAMBLE.IP 24207 . 24578)
(CLIPRECTANGLE.IP 24580 . 25070) (CONCAT.IP 25072 . 25337) (CONCATT.IP 25339 . 25606) (ENDMASTER.IP
25608 . 26052) (ENDPAGE.IP 26054 . 26431) (ENDPREAMBLE.IP 26433 . 27232) (FGET.IP 27234 . 27537) (
FILLRECTANGLE.IP 27539 . 29867) (FILLTRAJECTORY.IP 29869 . 30504) (FILLNGON.IP 30506 . 32783) (FSET.IP
32785 . 33088) (GETFRAMEVAR.IP 33090 . 33408) (INITIALIZEMASTER.IP 33410 . 34011) (INITIALIZECOLOR.IP
34013 . 35334) (ISET.IP 35336 . 35707) (GETCP.IP 35709 . 36018) (LINETO.IP 36020 . 36625) (
MASKSTROKE.IP 36627 . 36900) (MOVETO.IP 36902 . 37239) (ROTATE.IP 37241 . 37543) (SCALE.IP 37545 .
37848) (SCALE2.IP 37850 . 38187) (SETCOLOR.IP 38189 . 40418) (SETRGB.IP 40420 . 41476) (SETCOLORLV.IP
41478 . 46091) (SETCOLOR16.IP 46093 . 49199) (SETFONT.IP 49201 . 50022) (SETSPACE.IP 50024 . 50336) (
SETXREL.IP 50338 . 51522) (SETX.IP 51524 . 53041) (SETXY.IP 53043 . 54215) (SETXYREL.IP 54217 . 55523)
(SETY.IP 55525 . 56834) (SETYREL.IP 56836 . 57736) (SHOW.IP 57738 . 60998) (TRAJECTORY.IP 61000 .
61398) (TRANS.IP 61400 . 61739) (TRANSLATE.IP 61741 . 62086)) (62119 68209 (\CHANGE-VISIBLE-REGION.IP
62129 . 65790) (\PAPERSIZE.IP 65792 . 66613) (HEADINGOP.IP 66615 . 68207)) (68210 172730 (
DEFINEFONT.IP 68220 . 69194) (FONTNAME.IP 69196 . 70126) (INTERPRESS.BITMAPSCALE 70128 . 70921) (
INTERPRESS.OUTCHARFN 70923 . 77430) (NEWLINE.IP 77432 . 78164) (NEWPAGE.IP 78166 . 83141) (NEWPAGE?.IP
83143 . 83622) (OPENIPSTREAM 83624 . 91975) (SETUPFONTS.IP 91977 . 92969) (SHOWBITMAP.IP 92971 .
97512) (\BITMAPSIZE.IP 97514 . 98291) (SHOWBITMAP1.IP 98293 . 102665) (SHOWSHADE.IP 102667 . 103620) (
\BITBLT.IP 103622 . 107826) (\SCALEDBITBLT.IP 107828 . 111473) (\BLTSHADE.IP 111475 . 112933) (
\CHARWIDTH.IP 112935 . 113385) (\CLOSEIPSTREAM 113387 . 113714) (\DRAWARC.IP 113716 . 114163) (
\DRAWCURVE.IP 114165 . 116602) (\DRAWPOINT.IP 116604 . 117641) (\DSPCOLOR.IP 117643 . 118594) (
ENSURE.RGB 118596 . 119260) (\IPCURVE2 119262 . 132516) (\CLIPCURVELINE.IP 132518 . 137216) (
\DRAWLINE.IP 137218 . 140950) (\CLIPLINE 140952 . 145652) (\DSPBOTTOMMARGIN.IP 145654 . 146070) (
\DSPFONT.IP 146072 . 150832) (\DSPLEFTMARGIN.IP 150834 . 151294) (\DSPLINEFEED.IP 151296 . 151963) (
\DSPRIGHTMARGIN.IP 151965 . 152762) (\DSPSPACEFACTOR.IP 152764 . 153893) (\DSPTOPMARGIN.IP 153895 .
154331) (\DSPXPOSITION.IP 154333 . 155320) (\DSPROTATE.IP 155322 . 155500) (\PUSHSTATE.IP 155502 .
156394) (\POPSTATE.IP 156396 . 157031) (\DEFAULTSTATE.IP 157033 . 157385) (\DSPTRANSLATE.IP 157387 .
157568) (\DSPSCALE2.IP 157570 . 157745) (\DSPYPOSITION.IP 157747 . 158048) (FILLCIRCLE.IP 158050 .
159133) (\FILLPOLYGON.IP 159135 . 160466) (\DRAWPOLYGON.IP 160468 . 166598) (\FIXLINELENGTH.IP 166600
. 167814) (\MOVETO.IP 167816 . 168180) (\SETBRUSH.IP 168182 . 170348) (\STRINGWIDTH.IP 170350 .
170753) (\DSPCLIPPINGREGION.IP 170755 . 171931) (\DSPOPERATION.IP 171933 . 172728)) (172731 174630 (
INTERPRESSFILEP 172741 . 174174) (INTERPRESS.TEDIT 174176 . 174628)) (174821 175576 (IP-TOS 174831 .
175091) (POP-IP-STACK 175093 . 175388) (PUSH-IP-STACK 175390 . 175574)) (175637 176561 (
\CHANGECHARSET.IP 175647 . 176559)) (176562 180178 (\INTERPRESSINIT 176572 . 180176)) (193262 195686 (
INTERPRESSBITMAP 193272 . 195684)) (197983 200604 (\CREATEINTERPRESSFONT 197993 . 199721) (
\CREATECHARSET.IP 199723 . 200602)) (200605 212778 (IPFONT.FILEP 200615 . 200799) (IPFONT.GETCHARSET
200801 . 210899) (\FACECODE 210901 . 211491) (\FAMILYCODE 211493 . 212776)))))
(FILEMAP (NIL (16717 22369 (APPENDBYTE.IP 16727 . 16863) (APPENDIDENTIFIER.IP 16865 . 17387) (
APPENDINT.IP 17389 . 17840) (APPENDINTEGER.IP 17842 . 18414) (APPENDLARGEVECTOR.IP 18416 . 19381) (
APPENDNUMBER.IP 19383 . 19852) (APPENDOP.IP 19854 . 20500) (APPENDRATIONAL.IP 20502 . 20995) (
APPENDSEQUENCEDESCRIPTOR.IP 20997 . 22192) (BYTESININT.IP 22194 . 22367)) (22405 62212 (ARCTO.IP 22415
. 23696) (BEGINMASTER.IP 23698 . 23971) (BEGINPAGE.IP 23973 . 24329) (BEGINPREAMBLE.IP 24331 . 24702)
(CLIPRECTANGLE.IP 24704 . 25194) (CONCAT.IP 25196 . 25461) (CONCATT.IP 25463 . 25730) (ENDMASTER.IP
25732 . 26176) (ENDPAGE.IP 26178 . 26555) (ENDPREAMBLE.IP 26557 . 27356) (FGET.IP 27358 . 27661) (
FILLRECTANGLE.IP 27663 . 29991) (FILLTRAJECTORY.IP 29993 . 30628) (FILLNGON.IP 30630 . 32907) (FSET.IP
32909 . 33212) (GETFRAMEVAR.IP 33214 . 33532) (INITIALIZEMASTER.IP 33534 . 34135) (INITIALIZECOLOR.IP
34137 . 35458) (ISET.IP 35460 . 35831) (GETCP.IP 35833 . 36142) (LINETO.IP 36144 . 36749) (
MASKSTROKE.IP 36751 . 37024) (MOVETO.IP 37026 . 37363) (ROTATE.IP 37365 . 37667) (SCALE.IP 37669 .
37972) (SCALE2.IP 37974 . 38311) (SETCOLOR.IP 38313 . 40542) (SETRGB.IP 40544 . 41600) (SETCOLORLV.IP
41602 . 46215) (SETCOLOR16.IP 46217 . 49323) (SETFONT.IP 49325 . 50146) (SETSPACE.IP 50148 . 50460) (
SETXREL.IP 50462 . 51646) (SETX.IP 51648 . 53165) (SETXY.IP 53167 . 54339) (SETXYREL.IP 54341 . 55647)
(SETY.IP 55649 . 56958) (SETYREL.IP 56960 . 57860) (SHOW.IP 57862 . 61122) (TRAJECTORY.IP 61124 .
61522) (TRANS.IP 61524 . 61863) (TRANSLATE.IP 61865 . 62210)) (62243 68333 (\CHANGE-VISIBLE-REGION.IP
62253 . 65914) (\PAPERSIZE.IP 65916 . 66737) (HEADINGOP.IP 66739 . 68331)) (68334 172854 (
DEFINEFONT.IP 68344 . 69318) (FONTNAME.IP 69320 . 70250) (INTERPRESS.BITMAPSCALE 70252 . 71045) (
INTERPRESS.OUTCHARFN 71047 . 77554) (NEWLINE.IP 77556 . 78288) (NEWPAGE.IP 78290 . 83265) (NEWPAGE?.IP
83267 . 83746) (OPENIPSTREAM 83748 . 92099) (SETUPFONTS.IP 92101 . 93093) (SHOWBITMAP.IP 93095 .
97636) (\BITMAPSIZE.IP 97638 . 98415) (SHOWBITMAP1.IP 98417 . 102789) (SHOWSHADE.IP 102791 . 103744) (
\BITBLT.IP 103746 . 107950) (\SCALEDBITBLT.IP 107952 . 111597) (\BLTSHADE.IP 111599 . 113057) (
\CHARWIDTH.IP 113059 . 113509) (\CLOSEIPSTREAM 113511 . 113838) (\DRAWARC.IP 113840 . 114287) (
\DRAWCURVE.IP 114289 . 116726) (\DRAWPOINT.IP 116728 . 117765) (\DSPCOLOR.IP 117767 . 118718) (
ENSURE.RGB 118720 . 119384) (\IPCURVE2 119386 . 132640) (\CLIPCURVELINE.IP 132642 . 137340) (
\DRAWLINE.IP 137342 . 141074) (\CLIPLINE 141076 . 145776) (\DSPBOTTOMMARGIN.IP 145778 . 146194) (
\DSPFONT.IP 146196 . 150956) (\DSPLEFTMARGIN.IP 150958 . 151418) (\DSPLINEFEED.IP 151420 . 152087) (
\DSPRIGHTMARGIN.IP 152089 . 152886) (\DSPSPACEFACTOR.IP 152888 . 154017) (\DSPTOPMARGIN.IP 154019 .
154455) (\DSPXPOSITION.IP 154457 . 155444) (\DSPROTATE.IP 155446 . 155624) (\PUSHSTATE.IP 155626 .
156518) (\POPSTATE.IP 156520 . 157155) (\DEFAULTSTATE.IP 157157 . 157509) (\DSPTRANSLATE.IP 157511 .
157692) (\DSPSCALE2.IP 157694 . 157869) (\DSPYPOSITION.IP 157871 . 158172) (FILLCIRCLE.IP 158174 .
159257) (\FILLPOLYGON.IP 159259 . 160590) (\DRAWPOLYGON.IP 160592 . 166722) (\FIXLINELENGTH.IP 166724
. 167938) (\MOVETO.IP 167940 . 168304) (\SETBRUSH.IP 168306 . 170472) (\STRINGWIDTH.IP 170474 .
170877) (\DSPCLIPPINGREGION.IP 170879 . 172055) (\DSPOPERATION.IP 172057 . 172852)) (172855 174754 (
INTERPRESSFILEP 172865 . 174298) (INTERPRESS.TEDIT 174300 . 174752)) (174945 175700 (IP-TOS 174955 .
175215) (POP-IP-STACK 175217 . 175512) (PUSH-IP-STACK 175514 . 175698)) (175761 176685 (
\CHANGECHARSET.IP 175771 . 176683)) (176686 180302 (\INTERPRESSINIT 176696 . 180300)) (193386 195810 (
INTERPRESSBITMAP 193396 . 195808)) (198173 200846 (\CREATEINTERPRESSFONT 198183 . 199911) (
\CREATECHARSET.IP 199913 . 200844)) (200847 213020 (IPFONT.FILEP 200857 . 201041) (IPFONT.GETCHARSET
201043 . 211141) (\FACECODE 211143 . 211733) (\FAMILYCODE 211735 . 213018)))))
STOP

BIN
sources/INTERPRESS.LCOM
View File

Binary file not shown.

51
sources/LLBIGNUM
View File

@@ -1,23 +1,21 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Jan-99 21:45:52" {DSK}<disk>disk3>lispcore3.0>sources>LLBIGNUM.;2 41438
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
changes to%: (FNS \INITBIGNUMS)
(FILECREATED "17-Apr-2026 09:00:35" {MEDLEY}<sources>LLBIGNUM.;2 41059
previous date%: "19-Jan-93 10:44:45" {DSK}<disk>disk3>lispcore3.0>sources>LLBIGNUM.;1)
:EDIT-BY rmk
:CHANGES-TO (VARS LLBIGNUMCOMS)
:PREVIOUS-DATE " 1-Jan-99 21:45:52" {MEDLEY}<sources>LLBIGNUM.;1)
(* ; "
Copyright (c) 1985, 1986, 1987, 1990, 1993, 1999 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LLBIGNUMCOMS)
(RPAQQ LLBIGNUMCOMS
(RPAQQ LLBIGNUMCOMS
[(COMS (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BIGNUM))
(INITRECORDS BIGNUM)
(CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14))
(\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA)))
[DECLARE%: EVAL@COMPILE (ADDVARS (CHARACTERNAMES (INFINITY 8551]
(ADDVARS (GLOBALVARS MIN.INTEGER MAX.INTEGER \BIG.0 \BIG.1)))
(COMS (* ; "entries")
(FNS \BIGNUM.COMPARE \BIGNUM.DIFFERENCE \BIGNUM.INTEGERLENGTH \BIGNUM.LOGAND
@@ -40,7 +38,7 @@ Copyright (c) 1985, 1986, 1987, 1990, 1993, 1999 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE
(DATATYPE BIGNUM (ELEMENTS)
(INIT (DEFPRINT 'BIGNUM 'BIGNUM.DEFPRINT)))
(INIT (DEFPRINT 'BIGNUM 'BIGNUM.DEFPRINT)))
)
(/DECLAREDATATYPE 'BIGNUM '(POINTER)
@@ -67,10 +65,6 @@ Copyright (c) 1985, 1986, 1987, 1990, 1993, 1999 by Venue & Xerox Corporation.
(CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14))
(\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA)))
)
(DECLARE%: EVAL@COMPILE
(ADDTOVAR CHARACTERNAMES (INFINITY 8551))
)
(ADDTOVAR GLOBALVARS MIN.INTEGER MAX.INTEGER \BIG.0 \BIG.1)
@@ -1134,20 +1128,19 @@ Copyright (c) 1985, 1986, 1987, 1990, 1993, 1999 by Venue & Xerox Corporation.
(\INITBIGNUMS)
)
(PUTPROPS LLBIGNUM COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993 1999))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2909 9796 (\BIGNUM.COMPARE 2919 . 3420) (\BIGNUM.DIFFERENCE 3422 . 3650) (
\BIGNUM.INTEGERLENGTH 3652 . 3819) (\BIGNUM.LOGAND 3821 . 4589) (\BIGNUM.LOGOR 4591 . 5324) (
\BIGNUM.LOGXOR 5326 . 6213) (\BIGNUM.PLUS 6215 . 6432) (\BIGNUM.LSH 6434 . 8017) (\BIGNUM.TIMES 8019
. 8238) (\BIGNUM.QUOTIENT 8240 . 9178) (\BIGNUM.REMAINDER 9180 . 9552) (\BIGNUM.TO.FLOAT 9554 . 9794)
) (9797 10175 (FINITEP 9807 . 9993) (INFINITEP 9995 . 10173)) (10211 40300 (\BIGNUM.TO.INT 10221 .
10473) (\BN.2TH 10475 . 10859) (\BN.ABS 10861 . 11066) (\BN.DIFFERENCE 11068 . 11218) (\BN.DIVIDE
11220 . 16135) (\BN.FLOAT 16137 . 19004) (\BN.IGNN 19006 . 19392) (BIGNUM.DEFPRINT 19394 . 22989) (
\BN.INTEGERLENGTH 22991 . 23418) (\BN.LOGAND 23420 . 23956) (\BN.LOGANDC2 23958 . 24510) (\BN.LOGOR
24512 . 24825) (\BN.LOGXOR 24827 . 25143) (\BN.MINUS 25145 . 25500) (\BN.PLUS2 25502 . 26588) (
\BN.SIGN 26590 . 27036) (\BN.TIMES2 27038 . 29091) (\BN.COMPAREN 29093 . 30382) (\BN.D2TH 30384 .
31579) (\BN.FROM.FIXP 31581 . 32143) (\BN.ICANON 32145 . 33362) (\BN.IDIVIDE 33364 . 33525) (\BN.ISUM0
33527 . 34192) (\BN.ISUM1 34194 . 34927) (\BN.MADD 34929 . 35708) (\BN.TO.FIXP 35710 . 36321) (
\BN.NZEROS 36323 . 36480) (\BN.QRS 36482 . 37289) (\BN.SIGN 37291 . 37737) (\BN.TH2B 37739 . 38222) (
\BN.TH2D 38224 . 40298)) (40301 41091 (\INITBIGNUMS 40311 . 41089)))))
(FILEMAP (NIL (2620 9507 (\BIGNUM.COMPARE 2630 . 3131) (\BIGNUM.DIFFERENCE 3133 . 3361) (
\BIGNUM.INTEGERLENGTH 3363 . 3530) (\BIGNUM.LOGAND 3532 . 4300) (\BIGNUM.LOGOR 4302 . 5035) (
\BIGNUM.LOGXOR 5037 . 5924) (\BIGNUM.PLUS 5926 . 6143) (\BIGNUM.LSH 6145 . 7728) (\BIGNUM.TIMES 7730
. 7949) (\BIGNUM.QUOTIENT 7951 . 8889) (\BIGNUM.REMAINDER 8891 . 9263) (\BIGNUM.TO.FLOAT 9265 . 9505)
) (9508 9886 (FINITEP 9518 . 9704) (INFINITEP 9706 . 9884)) (9922 40011 (\BIGNUM.TO.INT 9932 . 10184)
(\BN.2TH 10186 . 10570) (\BN.ABS 10572 . 10777) (\BN.DIFFERENCE 10779 . 10929) (\BN.DIVIDE 10931 .
15846) (\BN.FLOAT 15848 . 18715) (\BN.IGNN 18717 . 19103) (BIGNUM.DEFPRINT 19105 . 22700) (
\BN.INTEGERLENGTH 22702 . 23129) (\BN.LOGAND 23131 . 23667) (\BN.LOGANDC2 23669 . 24221) (\BN.LOGOR
24223 . 24536) (\BN.LOGXOR 24538 . 24854) (\BN.MINUS 24856 . 25211) (\BN.PLUS2 25213 . 26299) (
\BN.SIGN 26301 . 26747) (\BN.TIMES2 26749 . 28802) (\BN.COMPAREN 28804 . 30093) (\BN.D2TH 30095 .
31290) (\BN.FROM.FIXP 31292 . 31854) (\BN.ICANON 31856 . 33073) (\BN.IDIVIDE 33075 . 33236) (\BN.ISUM0
33238 . 33903) (\BN.ISUM1 33905 . 34638) (\BN.MADD 34640 . 35419) (\BN.TO.FIXP 35421 . 36032) (
\BN.NZEROS 36034 . 36191) (\BN.QRS 36193 . 37000) (\BN.SIGN 37002 . 37448) (\BN.TH2B 37450 . 37933) (
\BN.TH2D 37935 . 40009)) (40012 40802 (\INITBIGNUMS 40022 . 40800)))))
STOP

BIN
sources/LLBIGNUM.LCOM
View File

Binary file not shown.

45
sources/LLCHAR
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "24-Aug-2025 11:50:57" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLCHAR.;14 104478
(FILECREATED "28-Mar-2026 08:50:21" {WMEDLEY}<sources>LLCHAR.;16 104725
:EDIT-BY rmk
:CHANGES-TO (VARS LLCHARCOMS)
:PREVIOUS-DATE "28-Apr-2022 08:52:36"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLCHAR.;13)
:PREVIOUS-DATE "24-Aug-2025 11:50:57" {WMEDLEY}<sources>LLCHAR.;14)
(PRETTYCOMPRINT LLCHARCOMS)
@@ -45,7 +43,9 @@
(CONSTANTS (\CHARMASK 255)
(\MAXTHINCHAR 255)
(\MAXFATCHAR 65535)
(\MAXCHARSET 255)
(\MAXCHARSET 65535)
(\MAXCHAR (LOGOR (LLSH \MAXCHARSET 8)
\MAXTHINCHAR))
(%#STRINGPWORDS 4))
(MACROS \NATOMCHARS \NSTRINGCHARS)))
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
@@ -1730,7 +1730,10 @@
(RPAQQ \MAXFATCHAR 65535)
(RPAQQ \MAXCHARSET 255)
(RPAQQ \MAXCHARSET 65535)
(RPAQ \MAXCHAR (LOGOR (LLSH \MAXCHARSET 8)
\MAXTHINCHAR))
(RPAQQ %#STRINGPWORDS 4)
@@ -1738,7 +1741,9 @@
(CONSTANTS (\CHARMASK 255)
(\MAXTHINCHAR 255)
(\MAXFATCHAR 65535)
(\MAXCHARSET 255)
(\MAXCHARSET 65535)
(\MAXCHAR (LOGOR (LLSH \MAXCHARSET 8)
\MAXTHINCHAR))
(%#STRINGPWORDS 4))
)
(DECLARE%: EVAL@COMPILE
@@ -1844,16 +1849,16 @@
(PUTPROPS LLCHAR FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4108 74294 (ALLOCSTRING 4118 . 6141) (MKATOM 6143 . 6778) (SUBATOM 6780 . 8650) (
CHARACTER 8652 . 9656) (\PARSE.NUMBER 9658 . 25378) (\INVALID.DOTTED.SYMBOL 25380 . 25875) (
\INVALID.INTEGER 25877 . 27329) (\MKINTEGER 27331 . 30038) (MKSTRING 30040 . 32183) (
\PRINDATUM.TO.STRING 32185 . 38363) (BKSYSBUF 38365 . 39899) (NCHARS 39901 . 41601) (NTHCHARCODE 41603
. 43649) (RPLCHARCODE 43651 . 44712) (\RPLCHARCODE 44714 . 46249) (NTHCHAR 46251 . 46444) (RPLSTRING
46446 . 49657) (SUBSTRING 49659 . 52582) (GNC 52584 . 52757) (GNCCODE 52759 . 53527) (GLC 53529 .
53702) (GLCCODE 53704 . 54469) (STREQUAL 54471 . 56585) (STRING.EQUAL 56587 . 60925) (STRINGP 60927 .
61078) (CHCON1 61080 . 61867) (U-CASE 61869 . 65096) (L-CASE 65098 . 68958) (U-CASEP 68960 . 69534) (
\SMASHABLESTRING 69536 . 69998) (\MAKEWRITABLESTRING 70000 . 70436) (\SMASHSTRING 70438 . 74144) (
\FATTENSTRING 74146 . 74292)) (74479 79641 (\GETBASESTRING 74489 . 75143) (\PUTBASESTRING 75145 .
77884) (\PUTBASESTRINGFAT 77886 . 78632) (GetBcplString 78634 . 79299) (SetBcplString 79301 . 79639))
(100978 103792 (%%COPY-ONED-ARRAY 100988 . 102838) (%%COPY-STRING-TO-ARRAY 102840 . 103790)))))
(FILEMAP (NIL (4182 74368 (ALLOCSTRING 4192 . 6215) (MKATOM 6217 . 6852) (SUBATOM 6854 . 8724) (
CHARACTER 8726 . 9730) (\PARSE.NUMBER 9732 . 25452) (\INVALID.DOTTED.SYMBOL 25454 . 25949) (
\INVALID.INTEGER 25951 . 27403) (\MKINTEGER 27405 . 30112) (MKSTRING 30114 . 32257) (
\PRINDATUM.TO.STRING 32259 . 38437) (BKSYSBUF 38439 . 39973) (NCHARS 39975 . 41675) (NTHCHARCODE 41677
. 43723) (RPLCHARCODE 43725 . 44786) (\RPLCHARCODE 44788 . 46323) (NTHCHAR 46325 . 46518) (RPLSTRING
46520 . 49731) (SUBSTRING 49733 . 52656) (GNC 52658 . 52831) (GNCCODE 52833 . 53601) (GLC 53603 .
53776) (GLCCODE 53778 . 54543) (STREQUAL 54545 . 56659) (STRING.EQUAL 56661 . 60999) (STRINGP 61001 .
61152) (CHCON1 61154 . 61941) (U-CASE 61943 . 65170) (L-CASE 65172 . 69032) (U-CASEP 69034 . 69608) (
\SMASHABLESTRING 69610 . 70072) (\MAKEWRITABLESTRING 70074 . 70510) (\SMASHSTRING 70512 . 74218) (
\FATTENSTRING 74220 . 74366)) (74553 79715 (\GETBASESTRING 74563 . 75217) (\PUTBASESTRING 75219 .
77958) (\PUTBASESTRINGFAT 77960 . 78706) (GetBcplString 78708 . 79373) (SetBcplString 79375 . 79713))
(101225 104039 (%%COPY-ONED-ARRAY 101235 . 103085) (%%COPY-STRING-TO-ARRAY 103087 . 104037)))))
STOP

BIN
sources/LLCHAR.LCOM
View File

Binary file not shown.

103
sources/LLDISPLAY
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED " 2-Sep-2025 22:54:03" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;50 272104
(FILECREATED "28-Apr-2026 00:08:21" {WMEDLEY}<sources>LLDISPLAY.;54 272196
:EDIT-BY rmk
:CHANGES-TO (FNS \SLOWBLTCHAR)
:CHANGES-TO (FNS INITIALIZEDISPLAYSTREAMS)
:PREVIOUS-DATE " 2-Sep-2025 22:41:14"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;49)
:PREVIOUS-DATE "28-Apr-2026 00:04:31" {WMEDLEY}<sources>LLDISPLAY.;53)
(PRETTYCOMPRINT LLDISPLAYCOMS)
@@ -4579,7 +4577,10 @@
(DEFINEQ
(INITIALIZEDISPLAYSTREAMS
[LAMBDA NIL (* ; "Edited 18-Aug-2025 12:15 by rmk")
[LAMBDA NIL (* ; "Edited 28-Apr-2026 00:08 by rmk")
(* ; "Edited 15-Apr-2026 00:25 by rmk")
(* ; "Edited 31-Mar-2026 17:52 by rmk")
(* ; "Edited 18-Aug-2025 12:15 by rmk")
(* ; "Edited 6-Jul-2025 12:57 by rmk")
(* lmm " 7-Jan-86 16:51")
(SETQ WHOLEDISPLAY (create REGION))
@@ -4589,15 +4590,13 @@
(* ;; "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded. This does not use FONTCREATE, so it doesn't depend on the argument checking and incore cache retrieval ")
[SETQ \GUARANTEEDDISPLAYFONT (\CREATEDISPLAYFONT (MAKEFONTSPEC 'GACHA 10 '(MEDIUM REGULAR REGULAR
)
0
'DISPLAY]
(SETQ \GUARANTEEDDISPLAYFONT (MEDLEYFONT.READ.FONT
"{MEDLEY}<fonts>medleydisplayfonts>GACHA10-MRR.MEDLEYDISPLAYFONT"
0))
(* ;;
 "For some reason, charset 0 has to be instantiated, otherwise there is a divide by 0 in the loadup")
(\CREATECHARSET 0 \GUARANTEEDDISPLAYFONT)
(SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT (LIST 1 \GUARANTEEDDISPLAYFONT])
)
(DECLARE%: DOCOPY DONTEVAL@LOAD
@@ -4622,44 +4621,44 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (20613 23281 (\FBITMAPBIT 20623 . 21083) (\FBITMAPBIT.UFN 21085 . 22104) (
\NEWPAGE.DISPLAY 22106 . 22241) (INITBITMASKS 22243 . 23279)) (25206 25715 (\CreateCursorBitMap 25216
. 25713)) (25832 85635 (BITBLT 25842 . 36232) (BLTSHADE 36234 . 37012) (\BITBLTSUB 37014 . 47149) (
\GETPILOTBBTSCRATCHBM 47151 . 47766) (BITMAPCOPY 47768 . 48344) (BITMAPCREATE 48346 . 49906) (
BITMAPBIT 49908 . 58295) (BITMAPEQUAL 58297 . 59759) (BLTCHAR 59761 . 60377) (\BLTCHAR 60379 . 60881)
(\MEDW.BLTCHAR 60883 . 65761) (\CHANGECHARSET.DISPLAY 65763 . 67997) (\INDICATESTRING 67999 . 69195) (
\SLOWBLTCHAR 69197 . 75890) (TEXTUREP 75892 . 76162) (INVERT.TEXTURE 76164 . 76438) (
INVERT.TEXTURE.BITMAP 76440 . 77975) (BITMAPWIDTH 77977 . 78349) (BITMAPHEIGHT 78351 . 78727) (
READBITMAP 78729 . 81239) (\INSUREBITSPERPIXEL 81241 . 81536) (MAXIMUMCOLOR 81538 . 81679) (
OPPOSITECOLOR 81681 . 81860) (MAXIMUMSHADE 81862 . 82073) (OPPOSITESHADE 82075 . 82254) (\MEDW.BITBLT
82256 . 85633)) (85636 87065 (\READBINARYBITMAP 85646 . 86284) (\PRINTBINARYBITMAP 86286 . 87063)) (
87067 92253 (FINISH-READING-BITMAP 87067 . 92253)) (93375 93856 (BITMAPBIT.EXPANDER 93385 . 93854)) (
93857 142391 (\BITBLT.DISPLAY 93867 . 117106) (\BITBLT.BITMAP 117108 . 126207) (\BITBLT.MERGE 126209
. 128462) (\BLTSHADE.DISPLAY 128464 . 135564) (\BLTSHADE.BITMAP 135566 . 142389)) (142392 151712 (
\BITBLT.BITMAP.SLOW 142402 . 151710)) (151713 168094 (\PUNT.BLTSHADE.BITMAP 151723 . 158819) (
\PUNT.BITBLT.BITMAP 158821 . 168092)) (168095 171535 (\SCALEDBITBLT.DISPLAY 168105 . 169738) (
\BACKCOLOR.DISPLAY 169740 . 171533)) (175390 177663 (DISPLAYSTREAMP 175400 . 176008) (DSPSOURCETYPE
176010 . 177019) (DSPXOFFSET 177021 . 177340) (DSPYOFFSET 177342 . 177661)) (177664 191859 (
DSPDESTINATION 177674 . 180777) (DSPTEXTURE 180779 . 180941) (\DISPLAYSTREAMINCRXPOSITION 180943 .
181230) (\SFFixDestination 181232 . 182410) (\SFFixClippingRegion 182412 . 184584) (\SFFixFont 184586
. 185636) (\SFFIXLINELENGTH 185638 . 187134) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 187136 . 188949
) (\SFFixY 188951 . 191857)) (191860 195707 (\SIMPLE.DSPCREATE 191870 . 192420) (\COMMON.DSPCREATE
192422 . 195705)) (195808 198002 (\MEDW.XOFFSET 195818 . 196959) (\MEDW.YOFFSET 196961 . 198000)) (
198003 205933 (\DSPCLIPPINGREGION.DISPLAY 198013 . 198759) (\DSPFONT.DISPLAY 198761 . 201135) (
\DISPLAY.PILOTBITBLT 201137 . 201286) (\DSPLINEFEED.DISPLAY 201288 . 201859) (\DSPLEFTMARGIN.DISPLAY
201861 . 202592) (\DSPOPERATION.DISPLAY 202594 . 203618) (\DSPRIGHTMARGIN.DISPLAY 203620 . 204465) (
\DSPXPOSITION.DISPLAY 204467 . 205324) (\DSPYPOSITION.DISPLAY 205326 . 205931)) (210121 215157 (
TTYDISPLAYSTREAM 210131 . 215155)) (215460 216490 (DSPSCROLL 215470 . 216170) (PAGEHEIGHT 216172 .
216488)) (216535 219557 (\DSPRESET.DISPLAY 216545 . 219555)) (219593 220116 (\MAYBE-DRIBBLE-CHAR
219593 . 220116)) (220117 240755 (\DSPPRINTCHAR 220127 . 227965) (\DSPPRINTCR/LF 227967 . 240753)) (
240756 241348 (\TTYBACKGROUND 240766 . 241346)) (241349 244636 (DSPBACKUP 241359 . 244634)) (244820
245076 (COLORDISPLAYP 244830 . 245074)) (245077 247148 (DISPLAYBEFOREEXIT 245087 . 245913) (
DISPLAYAFTERENTRY 245915 . 247146)) (247520 252052 (\DSPCLIPTRANSFORMX 247530 . 248119) (
\DSPCLIPTRANSFORMY 248121 . 248846) (\DSPTRANSFORMREGION 248848 . 249380) (\DSPUNTRANSFORMY 249382 .
249642) (\DSPUNTRANSFORMX 249644 . 249904) (\OFFSETCLIPPINGREGION 249906 . 252050)) (253366 255953 (
UPDATESCREENDIMENSIONS 253376 . 254005) (\CreateScreenBitMap 254007 . 255951)) (256512 269671 (
\CoerceToDisplayDevice 256522 . 256935) (\CREATEDISPLAY 256937 . 258777) (DISPLAYSTREAMINIT 258779 .
261923) (\STARTDISPLAY 261925 . 264836) (\MOVE.WINDOWS.ONTO.SCREEN 264838 . 267030) (
\UPDATE.PBT.RASTERWIDTHS 267032 . 268814) (\STOPDISPLAY 268816 . 269308) (\DEFINEDISPLAYINFO 269310 .
269669)) (270279 271729 (INITIALIZEDISPLAYSTREAMS 270289 . 271727)))))
(FILEMAP (NIL (20543 23211 (\FBITMAPBIT 20553 . 21013) (\FBITMAPBIT.UFN 21015 . 22034) (
\NEWPAGE.DISPLAY 22036 . 22171) (INITBITMASKS 22173 . 23209)) (25136 25645 (\CreateCursorBitMap 25146
. 25643)) (25762 85565 (BITBLT 25772 . 36162) (BLTSHADE 36164 . 36942) (\BITBLTSUB 36944 . 47079) (
\GETPILOTBBTSCRATCHBM 47081 . 47696) (BITMAPCOPY 47698 . 48274) (BITMAPCREATE 48276 . 49836) (
BITMAPBIT 49838 . 58225) (BITMAPEQUAL 58227 . 59689) (BLTCHAR 59691 . 60307) (\BLTCHAR 60309 . 60811)
(\MEDW.BLTCHAR 60813 . 65691) (\CHANGECHARSET.DISPLAY 65693 . 67927) (\INDICATESTRING 67929 . 69125) (
\SLOWBLTCHAR 69127 . 75820) (TEXTUREP 75822 . 76092) (INVERT.TEXTURE 76094 . 76368) (
INVERT.TEXTURE.BITMAP 76370 . 77905) (BITMAPWIDTH 77907 . 78279) (BITMAPHEIGHT 78281 . 78657) (
READBITMAP 78659 . 81169) (\INSUREBITSPERPIXEL 81171 . 81466) (MAXIMUMCOLOR 81468 . 81609) (
OPPOSITECOLOR 81611 . 81790) (MAXIMUMSHADE 81792 . 82003) (OPPOSITESHADE 82005 . 82184) (\MEDW.BITBLT
82186 . 85563)) (85566 86995 (\READBINARYBITMAP 85576 . 86214) (\PRINTBINARYBITMAP 86216 . 86993)) (
86997 92183 (FINISH-READING-BITMAP 86997 . 92183)) (93305 93786 (BITMAPBIT.EXPANDER 93315 . 93784)) (
93787 142321 (\BITBLT.DISPLAY 93797 . 117036) (\BITBLT.BITMAP 117038 . 126137) (\BITBLT.MERGE 126139
. 128392) (\BLTSHADE.DISPLAY 128394 . 135494) (\BLTSHADE.BITMAP 135496 . 142319)) (142322 151642 (
\BITBLT.BITMAP.SLOW 142332 . 151640)) (151643 168024 (\PUNT.BLTSHADE.BITMAP 151653 . 158749) (
\PUNT.BITBLT.BITMAP 158751 . 168022)) (168025 171465 (\SCALEDBITBLT.DISPLAY 168035 . 169668) (
\BACKCOLOR.DISPLAY 169670 . 171463)) (175320 177593 (DISPLAYSTREAMP 175330 . 175938) (DSPSOURCETYPE
175940 . 176949) (DSPXOFFSET 176951 . 177270) (DSPYOFFSET 177272 . 177591)) (177594 191789 (
DSPDESTINATION 177604 . 180707) (DSPTEXTURE 180709 . 180871) (\DISPLAYSTREAMINCRXPOSITION 180873 .
181160) (\SFFixDestination 181162 . 182340) (\SFFixClippingRegion 182342 . 184514) (\SFFixFont 184516
. 185566) (\SFFIXLINELENGTH 185568 . 187064) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 187066 . 188879
) (\SFFixY 188881 . 191787)) (191790 195637 (\SIMPLE.DSPCREATE 191800 . 192350) (\COMMON.DSPCREATE
192352 . 195635)) (195738 197932 (\MEDW.XOFFSET 195748 . 196889) (\MEDW.YOFFSET 196891 . 197930)) (
197933 205863 (\DSPCLIPPINGREGION.DISPLAY 197943 . 198689) (\DSPFONT.DISPLAY 198691 . 201065) (
\DISPLAY.PILOTBITBLT 201067 . 201216) (\DSPLINEFEED.DISPLAY 201218 . 201789) (\DSPLEFTMARGIN.DISPLAY
201791 . 202522) (\DSPOPERATION.DISPLAY 202524 . 203548) (\DSPRIGHTMARGIN.DISPLAY 203550 . 204395) (
\DSPXPOSITION.DISPLAY 204397 . 205254) (\DSPYPOSITION.DISPLAY 205256 . 205861)) (210051 215087 (
TTYDISPLAYSTREAM 210061 . 215085)) (215390 216420 (DSPSCROLL 215400 . 216100) (PAGEHEIGHT 216102 .
216418)) (216465 219487 (\DSPRESET.DISPLAY 216475 . 219485)) (219523 220046 (\MAYBE-DRIBBLE-CHAR
219523 . 220046)) (220047 240685 (\DSPPRINTCHAR 220057 . 227895) (\DSPPRINTCR/LF 227897 . 240683)) (
240686 241278 (\TTYBACKGROUND 240696 . 241276)) (241279 244566 (DSPBACKUP 241289 . 244564)) (244750
245006 (COLORDISPLAYP 244760 . 245004)) (245007 247078 (DISPLAYBEFOREEXIT 245017 . 245843) (
DISPLAYAFTERENTRY 245845 . 247076)) (247450 251982 (\DSPCLIPTRANSFORMX 247460 . 248049) (
\DSPCLIPTRANSFORMY 248051 . 248776) (\DSPTRANSFORMREGION 248778 . 249310) (\DSPUNTRANSFORMY 249312 .
249572) (\DSPUNTRANSFORMX 249574 . 249834) (\OFFSETCLIPPINGREGION 249836 . 251980)) (253296 255883 (
UPDATESCREENDIMENSIONS 253306 . 253935) (\CreateScreenBitMap 253937 . 255881)) (256442 269601 (
\CoerceToDisplayDevice 256452 . 256865) (\CREATEDISPLAY 256867 . 258707) (DISPLAYSTREAMINIT 258709 .
261853) (\STARTDISPLAY 261855 . 264766) (\MOVE.WINDOWS.ONTO.SCREEN 264768 . 266960) (
\UPDATE.PBT.RASTERWIDTHS 266962 . 268744) (\STOPDISPLAY 268746 . 269238) (\DEFINEDISPLAYINFO 269240 .
269599)) (270209 271821 (INITIALIZEDISPLAYSTREAMS 270219 . 271819)))))
STOP

91
sources/LLDISPLAY.LCOM
View File

@@ -1,12 +1,9 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED " 2-Sep-2025 22:54:03" ("compiled on "
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;50) " 2-Sep-2025 22:44:30"
"COMPILE-FILEd" in "FULL 2-Sep-2025 ..." dated " 2-Sep-2025 22:44:39")
(FILECREATED " 2-Sep-2025 22:54:03"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;50 272104 :EDIT-BY rmk
:CHANGES-TO (FNS \SLOWBLTCHAR) :PREVIOUS-DATE " 2-Sep-2025 22:41:14"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;49)
(FILECREATED "28-Apr-2026 00:08:21" ("compiled on " {WMEDLEY}<sources>LLDISPLAY.;54)
"28-Apr-2026 00:01:36" "COMPILE-FILEd" in "FULL 28-Apr-2026 ..." dated "28-Apr-2026 00:01:44")
(FILECREATED "28-Apr-2026 00:08:21" {WMEDLEY}<sources>LLDISPLAY.;54 272196 :EDIT-BY rmk :CHANGES-TO (
FNS INITIALIZEDISPLAYSTREAMS) :PREVIOUS-DATE "28-Apr-2026 00:04:31" {WMEDLEY}<sources>LLDISPLAY.;53)
(RPAQQ LLDISPLAYCOMS ((DECLARE%: DONTCOPY (EXPORT (RECORDS PILOTBBT \DISPLAYDATA DISPLAYSTATE
DISPLAYINFO) (MACROS \GETDISPLAYDATA))) (* ;
"User-visible records are on ADISPLAY --- must be init'ed here") (INITRECORDS BITMAP PILOTBBT REGION
@@ -196,7 +193,7 @@ BLTCHAR :D8
(42 \DISPLAYDATA 35 STREAM 24 OUTPUT)
()
\BLTCHAR :D8
(P 0 A0152 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM)
(P 0 A0175 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
\MEDW.BLTCHAR :D8
@@ -209,11 +206,12 @@ BLTCHAR :D8
(256 \EM.DISPINTERRUPT 191 \TOPWDS 175 \EM.DISPINTERRUPT 167 \EM.DISPINTERRUPT 132 PILOTBBT)
()
\CHANGECHARSET.DISPLAY :D8
(P 8 \INTERRUPTABLE P 6 BM P 5 CSINFO P 4 PBT I 1 CHARSET I 0 DISPLAYDATA) ¦ @É*@É HÉAàÐɵHÉAàAH
IJÐK¿K"@MÉ¿@MÉ¿@MÉ0¿@A>¿MɾLNÈàààànÿÿåÍ¿@È'MÈ
ð—@È@MÈ ð©@M
¿°'NÉNÈ@ÉBÚÐ_¿LOÒÍ¿LOÓÍh(122 \SFFixY 35 \CREATECHARSET)
(157 PILOTBBT 145 PILOTBBT 24 FONTDESCRIPTOR)
(P 9 \INTERRUPTABLE P 7 BM P 6 CSINFO P 5 PBT I 1 CHARSET I 0 DISPLAYDATA) 
@É*@É AHÈ djð“¿nÿÿñ²NHdÈ djð“¿nÿÿkعÉIàÐɵXHÉHÈ djð“¿nÿÿkØàH JKÐL¿L°)HÉAàÐɵHÉAàAH
JKÐL¿L" @NÉ¿@NÉ¿@NÉ0¿@A>¿NÉ_¿MOÈàààànÿÿåÍ¿@È'NÈ
ð—@È@NÈ ð©@N
¿°)OÉOÈ@ÉBÚÐ_¿MOÒÍ¿MOÓÍh(221 \SFFixY 131 \CREATECHARSET 90 \BUILDSLUGCSINFO)
(258 PILOTBBT 246 PILOTBBT 120 FONTDESCRIPTOR 71 FONTDESCRIPTOR 63 FONTDESCRIPTOR 35 FONTDESCRIPTOR 15 FONTDESCRIPTOR)
()
\INDICATESTRINGA0001 :D8
(NAME SI::*UNWIND-PROTECT* I 0 SI::*CLEANUP-FORMS* F 0 SI::*RESETFORMS* F 1 CHARCODE) Hgd gi
@@ -225,18 +223,18 @@ BLTCHAR :D8
(75 ^ 52 %# 16 SI::RESETUNWIND)
( 81 "" 58 "")
\SLOWBLTCHAR :D8
(P 18 CSINFO P 17 HEIGHTMOVED P 16 YPOS P 15 SOFTCURSORUP P 14 DISPINTERRUPT P 13 SOURCEBIT P 12 WIDTH P 11 DESTBIT P 10 PILOTBBT P 9 CURX P 8 RIGHT P 7 LEFT P 6 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 22 \SOFTCURSORP F 23 \SOFTCURSORUPP F 24 \CURSORDESTINATION F 25 \SCREENBITMAPS) n`@lÿåYAÉ0ZdÉ È Xdj𢱈€ JÉ_JÉIÐÈØ^JÉñ²l A
¿JÉ_JÉIÐÈؾJN¿OJÉØ_¿JÈ"dOñ¢¿O_¿JÈ#NJÉØ»dKñ‘¿K_¿JÉ*_¿OOñ¢±OÈ jð’±O_¿OOÙ_¿JÉIÐÈOØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W,²-W.´ hA
W0ð_²`È_¿`jÍ¿¿A`ð³hA
W2–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±Ð0JÉ_ ¿JÉIÐÈ_"¿JÉ @ã½\ÉMàÐɵ#LÉMàML
O&O(ÐO*¿O*_$¿HdlZð²;¿AO O"Ø
¿O$ÉjJÉIÐÈAJÉO$È
ÙkØO O$È
O$È ØO" °Hnð²8AO O"Ù
¿O$ÉjJÉIÐÈAJÉO$È ÙJÉO$È
O$È ØO" ‰o h(618 ERROR 607 BKBITBLT 565 \DSPYPOSITION.DISPLAY 546 BKBITBLT 503 \DSPYPOSITION.DISPLAY 465 \CREATECHARSET 397 \SOFTCURSORUPCURRENT 362 \TOTOPWDS 352 DSPDESTINATION 335 \SOFTCURSORDOWN 304 DSPDESTINATION 285 SHOULDNT 55 \DSPPRINTCR/LF)
(454 FONTDESCRIPTOR 403 \EM.DISPINTERRUPT 342 \TOPWDS 326 \EM.DISPINTERRUPT 316 \EM.DISPINTERRUPT 113 \DISPLAYDATA 83 \DISPLAYDATA)
( 613 "Not implemented to rotate by other than 0, 90 or 270")
(P 19 CSINFO P 18 HEIGHTMOVED P 17 YPOS P 16 SOFTCURSORUP P 15 DISPINTERRUPT P 14 SOURCEBIT P 13 WIDTH P 12 DESTBIT P 11 PILOTBBT P 10 CURX P 9 RIGHT P 8 LEFT P 7 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 26 \SOFTCURSORP F 27 \SOFTCURSORUPP F 28 \CURSORDESTINATION F 29 \SCREENBITMAPS) Øp@lÿåYAÉ0ZdÉ È Xdjð¢±<EFBFBD>€JÉ_JÉIÐÈØ_JÉñ²l A
¿JÉ_JÉIÐÈØ_¿JO¿OJÉØ_¿JÈ"dOñ¢¿O_¿JÈ#OJÉØ»dKñ‘¿K_¿JÉ*_¿OOñ¢±OÈ jð’±O_¿OOÙ_¿JÉIÐÈOØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W4²-W6´ hA
W8ð_ ²`È_¿`jÍ¿¿A`ð³hA
W:–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿O Ÿ¿`OÍ¿±50JÉ_"¿JÉIÐÈ_$¿JÉ @ã¾½NMÈ djð“¿nÿÿñ²RMdÈ djð“¿nÿÿkؼÉLàÐɵ`MÉMÈ djð“¿nÿÿkØàM O(O*ÐO,¿O,°-MÉNàÐɵ#MÉNàNM
O.O0ÐO2¿O2_&¿HdlZð²;¿AO"O$Ø
¿O&ÉjJÉIÐÈAJÉO&È
ÙkØO"O&È
O&È ØO$ °Hnð²8AO"O$Ù
¿O&ÉjJÉIÐÈAJÉO&È ÙJÉO&È
O&È ØO$ ‰o h(724 ERROR 713 BKBITBLT 671 \DSPYPOSITION.DISPLAY 652 BKBITBLT 609 \DSPYPOSITION.DISPLAY 571 \CREATECHARSET 526 \BUILDSLUGCSINFO 402 \SOFTCURSORUPCURRENT 367 \TOTOPWDS 357 DSPDESTINATION 340 \SOFTCURSORDOWN 309 DSPDESTINATION 290 SHOULDNT 56 \DSPPRINTCR/LF)
(560 FONTDESCRIPTOR 507 FONTDESCRIPTOR 499 FONTDESCRIPTOR 471 FONTDESCRIPTOR 451 FONTDESCRIPTOR 408 \EM.DISPINTERRUPT 347 \TOPWDS 331 \EM.DISPINTERRUPT 321 \EM.DISPINTERRUPT 118 \DISPLAYDATA 87 \DISPLAYDATA)
( 719 "Not implemented to rotate by other than 0, 90 or 270")
TEXTUREP :D8
(I 0 OBJECT) @d3 ³ô@Èkð´@NIL
(18 BITMAP 10 BITMAP)
@@ -289,7 +287,7 @@ OPPOSITESHADE :D8
NIL
()
\MEDW.BITBLT :D8
(P 9 A0155 P 8 A0154 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0153 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS) 
(P 9 A0178 P 8 A0177 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0176 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS) 
 @ ³C ªo ¿@òZ@²WCi
Cgh É0HÉ2ÉHºHÉ2@ABCDEFGGGGGABlJ±–Cô‚±¯C´‚±¨@i
!@gh É0AIÉصABIÉصBKÉ2ÉJ_¿KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO±Þ@
@@ -455,11 +453,11 @@ Q
(145 ERASE 138 INVERT 121 INVERT 110 PAINT 99 ERASE 86 \DISPLAYDATA 77 \DISPLAYDATA 53 INVERT 43 INPUT 32 \DISPLAYDATA 23 \DISPLAYDATA 16 STREAM 5 OUTPUT)
()
DSPXOFFSET :D8
(P 0 A0169 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM)
(P 0 A0192 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
DSPYOFFSET :D8
(P 0 A0170 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM)
(P 0 A0193 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
DSPDESTINATION :D8
@@ -544,13 +542,13 @@ A
(23 \DISPLAYDATA 16 STREAM 5 OUTPUT)
( 63 " is not a REGION.")
\DSPFONT.DISPLAY :D8
(P 4 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) ‹@@É0ZdÉ YA²sAhdd@i µJÉ giA
µ o XIð³CJH ¿JjHÈ
Ù¿JHÉɵHÉjH
[¿KÉÈ ÍA¿@J
(135 \SFFixFont 116 \CREATECHARSET 66 ERROR 54 FONTCOPY 35 FONTCREATE)
(107 FONTDESCRIPTOR 87 FONTDESCRIPTOR 45 NOERROR 17 \DISPLAYDATA 8 STREAM)
( 61 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER")
(P 5 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) ò P@É0ZdÉ YA¢±ÙAhdd@i µJÉ giA
µ o XI𒱧JH ¿JjHÈ
Ù¿JjHÈ djð“¿nÿÿñ²QHdÈ djð“¿nÿÿkØ»ÉKàÐɵOHÉHÈ djð“¿nÿÿkØàH NOÐO¿O°HÉɵHÉjH
\¿LÉÈ ÍA¿@J
(238 \SFFixFont 219 \CREATECHARSET 180 \BUILDSLUGCSINFO 68 ERROR 56 FONTCOPY 37 FONTCREATE)
(210 FONTDESCRIPTOR 161 FONTDESCRIPTOR 153 FONTDESCRIPTOR 125 FONTDESCRIPTOR 105 FONTDESCRIPTOR 91 FONTDESCRIPTOR 47 NOERROR 17 \DISPLAYDATA 8 STREAM)
( 63 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER")
\DISPLAY.PILOTBITBLT :D8
(I 1 N I 0 PILOTBBT) @AvNIL
NIL
@@ -772,10 +770,10 @@ NIL
NIL
()
\CREATEDISPLAY :D8
(P 0 FDEV I 0 DISPLAYNAME F 2 *DEFAULT-EXTERNALFORMAT*) ] `d@¿djÏ¿djÏ¿djÏ0¿dg¿dg¿dgD¿dg¿dg^¿dgF¿dg¿dgb¿dg`¿dg¿dg¿dg
¿dg ¿dg¿dg,¿dg.¿dg0¿dgT¿dg>¿dg@¿gh¹dI¿dRh¿dgR¿dgP¿dgN¿dgH¿dgB¿dg<¿dg:¿dg*¿dg ¿dg¿dg¿dg¿X@H
H(345 \DEFINEDEVICE)
(334 \GENERIC.RENAMEFILE 325 NILL 316 NILL 307 NILL 298 NILL 289 \GENERIC.READP 280 \ILLEGAL.DEVICEOP 271 NILL 262 \GENERIC.CHARSET 253 \ILLEGAL.DEVICEOP 244 \IS.NOT.RANDACCESSP 235 \IS.NOT.RANDACCESSP 216 OFF 208 \NONPAGEDBOUTS 199 \ILLEGAL.DEVICEOP 190 \PAGEDBACKFILEPTR 181 \ILLEGAL.DEVICEOP 172 \DSPPRINTCHAR 163 \ILLEGAL.DEVICEOP 154 NILL 145 NILL 136 NILL 127 \CREATEDISPLAYA0023 118 \CREATEDISPLAYA0021 109 \ILLEGAL.DEVICEOP 100 NILL 91 \GENERATENOFILES 82 NILL 73 \ILLEGAL.DEVICEOP 64 \CREATEDISPLAYA0014 55 NILL 46 NILL 37 NILL 7 |FDEVTYPE#|)
(P 0 FDEV I 0 DISPLAYNAME) a `d@¿djÏ¿djÏ¿djÏ0¿dg¿dg¿dgD¿dg¿dg^¿dgF¿dg¿dgb¿dg`¿dg¿dg¿dg
¿dg ¿dg¿dg,¿dg.¿dg0¿dgT¿dg>¿dg@¿gh¹dI¿d`h¿dgR¿dgP¿dgN¿dgH¿dgB¿dg<¿dg:¿dg*¿dg ¿dg¿dg¿dg¿X@H
H(349 \DEFINEDEVICE)
(338 \GENERIC.RENAMEFILE 329 NILL 320 NILL 311 NILL 302 NILL 293 \GENERIC.READP 284 \ILLEGAL.DEVICEOP 275 NILL 266 \GENERIC.CHARSET 257 \ILLEGAL.DEVICEOP 248 \IS.NOT.RANDACCESSP 239 \IS.NOT.RANDACCESSP 230 *DEFAULT-EXTERNALFORMAT* 216 OFF 208 \NONPAGEDBOUTS 199 \ILLEGAL.DEVICEOP 190 \PAGEDBACKFILEPTR 181 \ILLEGAL.DEVICEOP 172 \DSPPRINTCHAR 163 \ILLEGAL.DEVICEOP 154 NILL 145 NILL 136 NILL 127 \CREATEDISPLAYA0023 118 \CREATEDISPLAYA0021 109 \ILLEGAL.DEVICEOP 100 NILL 91 \GENERATENOFILES 82 NILL 73 \ILLEGAL.DEVICEOP 64 \CREATEDISPLAYA0014 55 NILL 46 NILL 37 NILL 7 |FDEVTYPE#|)
()
DISPLAYSTREAMINIT :D8
(P 2 TTYFONTHEIGHT P 1 TTYHEIGHT P 0 TTYFONT I 0 N F 3 TtyDisplayStream) «chS
@@ -815,13 +813,12 @@ NIL
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted))
(ADDTOVAR GLOBALVARS WHOLESCREEN)
INITIALIZEDISPLAYSTREAMS :D8
(F 0 \GUARANTEEDDISPLAYFONT F 1 DEFAULTFONT) eodnÿdh`ld
gl
ojg  cjP
gkPh
c(96 FONTCLASS 81 \CREATECHARSET 72 \CREATEDISPLAYFONT 67 MAKEFONTSPEC 38 BITMAPCREATE)
(86 DEFAULTFONT 61 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY)
( 55 (MEDIUM REGULAR REGULAR) 4 -16383)
(F 0 \GUARANTEEDDISPLAYFONT F 1 DEFAULTFONT) Lodnÿdh`ld
oj
cgkPh
c(71 FONTCLASS 54 MEDLEYFONT.READ.FONT 38 BITMAPCREATE)
(61 DEFAULTFONT 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY)
( 48 "{MEDLEY}<fonts>medleydisplayfonts>GACHA10-MRR.MEDLEYDISPLAYFONT" 4 -16383)
(RPAQQ \DisplayStarted NIL)
(RPAQQ \LastTTYLines 12)
(INITIALIZEDISPLAYSTREAMS)

76
sources/LLREAD
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "20-Sep-2025 14:18:31" {WMEDLEY}<sources>LLREAD.;123 99281
(FILECREATED "29-Apr-2026 22:56:18" {MEDLEY}<sources>LLREAD.;128 100032
:EDIT-BY rmk
:CHANGES-TO (VARS LLREADCOMS)
(FNS CHARSET.ENCODE)
:PREVIOUS-DATE "24-Aug-2025 11:47:11" {WMEDLEY}<sources>LLREAD.;122)
:PREVIOUS-DATE "17-Apr-2026 17:06:49" {MEDLEY}<sources>LLREAD.;127)
(PRETTYCOMPRINT LLREADCOMS)
@@ -40,7 +39,9 @@
(ALISTS (CHARACTERNAMES Page Form FF Rubout Del Null Escape Esc Bell Tab Backspace Bs
Newline CR EOL Return Tenexeol Space Sp Linefeed LF Zero One Two Three
Four Five Six Seven Eight Nine INFINITY EMQUAD ENQUAD THINSPACE
FIGURESPACE LEFT-DOUBLEQUOTE RIGHT-DOUBLEQUOTE EMDASH)
HAIRSPACE FIGURESPACE LEFT-DOUBLEQUOTE RIGHT-DOUBLEQUOTE EMDASH ENDASH
Union Intersection And Or Contourintegral Integral Summation Product
Radical All Exists Member INFINITY Notmember Minus)
(CHARACTERSETNAMES Meta Function Greek Cyrillic Hira Hiragana Kata Katakana
Kanji)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES)
@@ -1486,7 +1487,8 @@
(ERROR "BAD CHARACTER SPECIFICATION" C])
(CHARCODE.ENCODE
[LAMBDA (CODE OCTALCHARS NONCHARIDENTITY) (* ; "Edited 13-Aug-2025 08:54 by rmk")
[LAMBDA (CODE OCTALCHARS NONCHARIDENTITY) (* ; "Edited 17-Apr-2026 17:05 by rmk")
(* ; "Edited 13-Aug-2025 08:54 by rmk")
(* ; "Edited 7-Aug-2025 11:10 by rmk")
(* ; "Edited 23-Apr-2025 19:08 by rmk")
(* ; "Edited 26-Mar-2025 10:37 by rmk")
@@ -1518,6 +1520,10 @@
then (CL:IF NONCHARIDENTITY
CODE
(\ILLEGAL.ARG CODE))
elseif OCTALCHARS
then (CONCAT (OCTALSTRING (LRSH CODE 8))
","
(OCTALSTRING (LOGAND CODE 255)))
elseif [CAR (find CN in CHARACTERNAMES suchthat (if (CHARCODEP (CADR CN))
then (IEQP CODE (CADR CN))
else (IEQP CODE (CHARCODE.DECODE (CADR CN]
@@ -1528,10 +1534,8 @@
(SETQ CSETNAME (if [CAR (find CN in CHARACTERSETNAMES
suchthat (STRING.EQUAL CHARSET (CADR CN]
else (OCTALSTRING CHARSET)))
[SETQ CHARNAME (if OCTALCHARS
then (OCTALSTRING CHAR)
else (CAR (for CC in CHARACTERNAMES when (EQ CHAR (CADR CC))
smallest (NCHARS (CAR CC]
[SETQ CHARNAME (CAR (for CC in CHARACTERNAMES when (EQ CHAR (CADR CC))
smallest (NCHARS (CAR CC]
(CL:WHEN (STREQUAL CHARNAME "Tenexeol") (* ;
 "Put (%"^_%" Tenexeol) in CHARACTERNAMES ?")
(SETQ CHARNAME "^_"))
@@ -1551,8 +1555,7 @@
(SETQ CHARNAME (CL:IF (IGEQ CHAR 128)
(CONCAT "#" ASCIINAME)
ASCIINAME)))
(CL:IF (AND (ZEROP CHARSET)
(NOT OCTALCHARS))
(CL:IF (ZEROP CHARSET)
CHARNAME
(CONCAT CSETNAME "," CHARNAME))])
@@ -1723,10 +1726,27 @@
(EMQUAD "357,55")
(ENQUAD "357,54")
(THINSPACE "357,57")
(HAIRSPACE "356,043")
(FIGURESPACE "357,56")
(LEFT-DOUBLEQUOTE "0,252")
(RIGHT-DOUBLEQUOTE "0,272")
(EMDASH "357,045"))
(EMDASH "357,045")
(ENDASH "357,044")
(Union "357,127")
(Intersection "357,126")
(And "357,266")
(Or "357,267")
(Contourintegral "357,166")
(Integral "357,165")
(Summation "357,172")
(Product "357,173")
(Radical "357,174")
(All "357,265")
(Exists "357,264")
(Member "357,112")
(INFINITY "41,147")
(Notmember "357,113")
(Minus "356,055"))
(ADDTOVAR CHARACTERSETNAMES (Meta 1)
(Function 2)
@@ -1840,19 +1860,19 @@
(ADDTOVAR LAMA CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3828 12272 (LASTC 3838 . 4144) (PEEKC 4146 . 4534) (PEEKCCODE 4536 . 4947) (RATOM 4949
. 6030) (READ 6032 . 6592) (READC 6594 . 7235) (READCCODE 7237 . 7996) (READP 7998 . 8550) (
SETREADMACROFLG 8552 . 8851) (SKIPSEPRCODES 8853 . 9933) (SKIPSEPRS 9935 . 10321) (SKREAD 10323 .
12270)) (12318 20927 (CL:READ 12328 . 12877) (CL:READ-PRESERVING-WHITESPACE 12879 . 13601) (
CL:READ-DELIMITED-LIST 13603 . 14518) (CL:PARSE-INTEGER 14520 . 20925)) (21020 33497 (RSTRING 21030 .
21762) (READ-EXTENDED-TOKEN 21764 . 25636) (\RSTRING2 25638 . 33495)) (33533 64266 (\TOP-LEVEL-READ
33543 . 35526) (\SUBREAD 35528 . 60682) (\SUBREADCONCAT 60684 . 61307) (\ORIG-READ.SYMBOL 61309 .
62377) (\ORIG-INVALID.SYMBOL 62379 . 63278) (\APPLYREADMACRO 63280 . 63696) (INREADMACROP 63698 .
64264)) (64425 64600 (READQUOTE 64435 . 64598)) (64625 76529 (READVBAR 64635 . 65966) (READHASHMACRO
65968 . 71778) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71780 . 72000) (DIGITBASEP 72002 . 72736) (
READNUMBERINBASE 72738 . 74624) (ESTIMATE-DIMENSIONALITY 74626 . 74951) (SKIP.HASH.COMMENT 74953 .
75921) (CMLREAD.FEATURE.PARSER 75923 . 76527)) (76573 77839 (CHARACTER.READ 76583 . 77837)) (77872
89790 (CHARCODE.DECODE 77882 . 83051) (CHARCODE.ENCODE 83053 . 87495) (CHARCODEP 87497 . 88026) (
CHARSET.DECODE 88028 . 88976) (CHARSET.ENCODE 88978 . 89788)) (89791 94287 (HEXNUM? 89801 . 92144) (
OCTALNUM? 92146 . 92959) (HEXSTRING 92961 . 94285)))))
(FILEMAP (NIL (3984 12428 (LASTC 3994 . 4300) (PEEKC 4302 . 4690) (PEEKCCODE 4692 . 5103) (RATOM 5105
. 6186) (READ 6188 . 6748) (READC 6750 . 7391) (READCCODE 7393 . 8152) (READP 8154 . 8706) (
SETREADMACROFLG 8708 . 9007) (SKIPSEPRCODES 9009 . 10089) (SKIPSEPRS 10091 . 10477) (SKREAD 10479 .
12426)) (12474 21083 (CL:READ 12484 . 13033) (CL:READ-PRESERVING-WHITESPACE 13035 . 13757) (
CL:READ-DELIMITED-LIST 13759 . 14674) (CL:PARSE-INTEGER 14676 . 21081)) (21176 33653 (RSTRING 21186 .
21918) (READ-EXTENDED-TOKEN 21920 . 25792) (\RSTRING2 25794 . 33651)) (33689 64422 (\TOP-LEVEL-READ
33699 . 35682) (\SUBREAD 35684 . 60838) (\SUBREADCONCAT 60840 . 61463) (\ORIG-READ.SYMBOL 61465 .
62533) (\ORIG-INVALID.SYMBOL 62535 . 63434) (\APPLYREADMACRO 63436 . 63852) (INREADMACROP 63854 .
64420)) (64581 64756 (READQUOTE 64591 . 64754)) (64781 76685 (READVBAR 64791 . 66122) (READHASHMACRO
66124 . 71934) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71936 . 72156) (DIGITBASEP 72158 . 72892) (
READNUMBERINBASE 72894 . 74780) (ESTIMATE-DIMENSIONALITY 74782 . 75107) (SKIP.HASH.COMMENT 75109 .
76077) (CMLREAD.FEATURE.PARSER 76079 . 76683)) (76729 77995 (CHARACTER.READ 76739 . 77993)) (78028
90031 (CHARCODE.DECODE 78038 . 83207) (CHARCODE.ENCODE 83209 . 87736) (CHARCODEP 87738 . 88267) (
CHARSET.DECODE 88269 . 89217) (CHARSET.ENCODE 89219 . 90029)) (90032 94528 (HEXNUM? 90042 . 92385) (
OCTALNUM? 92387 . 93200) (HEXSTRING 93202 . 94526)))))
STOP

BIN
sources/LLREAD.LCOM
View File

Binary file not shown.

1163
sources/MCCS
View File

File diff suppressed because it is too large Load Diff

BIN
sources/MCCS.LCOM
View File

Binary file not shown.

1280
sources/MCCSFONTS Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
sources/MCCSFONTS.LCOM Normal file
View File

Binary file not shown.

178
sources/MEDLEYDIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "31-Jan-2026 23:43:06" {WMEDLEY}<sources>MEDLEYDIR.;44 16074
(FILECREATED "26-Apr-2026 20:46:52" {WMEDLEY}<sources>MEDLEYDIR.;61 15717
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYDIR)
:CHANGES-TO (VARS MEDLEYDIRCOMS)
:PREVIOUS-DATE "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43)
:PREVIOUS-DATE "26-Apr-2026 14:56:00" {WMEDLEY}<sources>MEDLEYDIR.;60)
(PRETTYCOMPRINT MEDLEYDIRCOMS)
@@ -16,17 +16,21 @@
(* ;; "set up initialization for file paths relative to where Medley is installed. This assumes that the environment variable MEDLEYDIR is set (usually by the ./run-medley script) to the (unix path) and all of the other directories variables are set relative to that (by MEDLEY-INIT-VARS)")
(FNS MEDLEY-INIT-VARS MEDLEYDIR MEDLEYSUBSTDIR SET-SYSOUT-COMMIT)
[INITVARS (MEDLEYDIR)
[INITVARS (MEDLEYDIR (MEDLEYDIR))
(\SAVE.MEDLEYDIR)
(SYSOUTCOMMITS (OR (AND (BOUNDP 'SYSOUTCOMMITS)
SYSOUTCOMMITS)
(LIST (LIST 'MEDLEY NIL]
(* ;; "PSEUDOHOSTS comes before MEDLEYDIR in the loadup.")
(P (PSEUDOHOST 'MEDLEY MEDLEYDIR))
(ADDVARS (AROUNDEXITFNS MEDLEY-INIT-VARS))
(* ;; "**WARNING** The EVALed expressions get run early in the lodup.")
(* ;; "The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout. But the FONT cache variables have to be specified here, because FONT is in the INIT and the resetting to NOBIND would wipe out these entries even if they were already correct in the init sysout.")
(* ;; "The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout.")
[INITVARS (MEDLEY-INIT-VARS '((\FONTEXISTS?-CACHE NIL RESET)
(\FONTSAVAILABLEFILECACHE NIL RESET)
@@ -40,28 +44,17 @@
(IRM.DINFOGRAPH)
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES
))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV
"LOGINDIR")
(UNIX-GETENV
"HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
LHD)
RESET)
(LOGINHOST/DIR
(LET [(LHD (DIRECTORYNAME (PACKFILENAME 'HOST 'DSK
'BODY
(OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME"]
(PSEUDOHOST 'LI LHD)
LHD)
RESET)
(USERGREETFILES [LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
RESET)
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts"
"fonts/displayfonts")
NIL NIL T))
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts"
)
NIL NIL T))
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
NIL NIL T))
(UNICODEDIRECTORIES (MEDLEYDIR '("unicode/xerox")
NIL NIL T))
(XCL::*WHERE-IS-CASH-FILES* (MEDLEYDIR '("loadups")
"whereis.hash" NIL T))
(LOADUPSDIRECTORIES (MEDLEYDIR '("loadups")
@@ -78,7 +71,8 @@
(DEFINEQ
(MEDLEY-INIT-VARS
[LAMBDA (EVENT) (* ; "Edited 22-Nov-2022 20:38 by FGH")
[LAMBDA (EVENT) (* ; "Edited 15-Apr-2026 16:44 by rmk")
(* ; "Edited 22-Nov-2022 20:38 by FGH")
(* ; "Edited 21-Nov-2022 17:31 by FGH")
(* ; "Edited 21-Nov-2022 15:39 by frank")
(* ; "Edited 21-Nov-2022 14:33 by FGH")
@@ -105,6 +99,7 @@
(* ;;
 "Any old values, restore them, substituting the new MEDLEYDIR")
(PSEUDOHOST 'MEDLEY MEDLEYDIR)
(PROG (OLDMD NEWMD SAME TMP)
(IF (EQ \SAVE.MEDLEYDIR T)
THEN (* ; " Already restored")
@@ -139,7 +134,8 @@
NIL])
(MEDLEYDIR
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 31-Jan-2026 23:42 by rmk")
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 16-Apr-2026 11:06 by rmk")
(* ; "Edited 31-Jan-2026 23:42 by rmk")
(* ; "Edited 23-Aug-2025 17:21 by lmm")
(* ; "Edited 18-Aug-2025 11:15 by FGH")
(* ; "Edited 29-Jun-2023 22:48 by rmk")
@@ -149,55 +145,60 @@
(* ;; "RMK: MEDLEYDIR defaults to DSK")
(COND
((NULL DIRNAME) (* ;
 "Call to (MEDLEYDIR) or (MEDLEYDIR NIL ...) just set it ")
(if (OR (NOT (BOUNDP 'MEDLEYDIR))
(NOT MEDLEYDIR))
then (SETQ MEDLEYDIR (DIRECTORYNAME (if (SETQ MEDLEYDIR (UNIX-GETENV "MEDLEYDIR"))
then (PACKFILENAME 'BODY MEDLEYDIR 'HOST
'DSK)
else T)))
elseif (STRPOS "/" MEDLEYDIR)
then (SETQ MEDLEYDIR (DIRECTORYNAME MEDLEYDIR))
else MEDLEYDIR))
((LISTP DIRNAME)
(if (NULL DIRNAME)
then (* ;
 "Call to (MEDLEYDIR) or (MEDLEYDIR NIL ...) just set it--Don't want MEDLEYDIR to be {MEDLEY}.")
(if (OR (NOT (BOUNDP 'MEDLEYDIR))
(NOT MEDLEYDIR))
then (SETQ MEDLEYDIR (DIRECTORYNAME (if (SETQ MEDLEYDIR (UNIX-GETENV "MEDLEYDIR"))
then (PACKFILENAME 'BODY MEDLEYDIR
'HOST
'DSK)
else T)))
elseif (STRPOS "/" MEDLEYDIR)
then (SETQ MEDLEYDIR (DIRECTORYNAME MEDLEYDIR))
else MEDLEYDIR)
else (LET (MED)
[SETQ MED (COND
((LISTP DIRNAME)
(* ;; "(MEDLEYDIR a list -- recurse")
(* ;; "(MEDLEYDIR a list -- recurse")
(for X Y in DIRNAME when (SETQ Y (MEDLEYDIR X FILENAME OUTPUT NOERROR)) collect Y))
[FILENAME
(for X Y in DIRNAME when (SETQ Y (MEDLEYDIR X FILENAME OUTPUT NOERROR))
collect Y))
[FILENAME
(* ;; " if FILENAME, find it as a file. ")
(* ;; " if FILENAME, find it as a file. ")
(if (NULL (SETQ DIRNAME (MEDLEYDIR DIRNAME NIL OUTPUT NOERROR)))
then (OR NOERROR (SHOULDNT))
NIL
else (SETQ FILENAME (CONCAT DIRNAME FILENAME))
(if OUTPUT
then FILENAME
else (OR (INFILEP FILENAME)
(if NOERROR
then NIL
else (ERROR "No such medley file" FILENAME]
((EQUAL DIRNAME "login") (* ; "special case for login dir")
(DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME")
DIRNAME)))
[(EQUAL DIRNAME "loadups") (* ; "special case for loadups dir")
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY¬LOADUPS¬DIR"))
(DIRECTORYNAME (CONCAT (MEDLEYDIR)
"loadups" ">")
NIL OUTPUT)
(if NOERROR
then NIL
else (ERROR "Cannot find medley loadups directory" (MEDLEYDIR]
(T (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
DIRNAME ">")
NIL OUTPUT)
(if NOERROR
then NIL
else (ERROR "No such medley directory" DIRNAME])
(if (NULL (SETQ DIRNAME (MEDLEYDIR DIRNAME NIL OUTPUT NOERROR)))
then (OR NOERROR (SHOULDNT))
NIL
else (SETQ FILENAME (CONCAT DIRNAME FILENAME))
(if OUTPUT
then FILENAME
else (OR (INFILEP FILENAME)
(if NOERROR
then NIL
else (ERROR "No such medley file" FILENAME]
((EQUAL DIRNAME "login") (* ; "special case for login dir")
(DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME")
DIRNAME)))
[(EQUAL DIRNAME "loadups") (* ; "special case for loadups dir")
(OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY¬LOADUPS¬DIR"))
(DIRECTORYNAME (CONCAT (MEDLEYDIR)
"loadups" ">")
NIL OUTPUT)
(if NOERROR
then NIL
else (ERROR "Cannot find medley loadups directory" (MEDLEYDIR]
(T (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
DIRNAME ">")
NIL OUTPUT)
(if NOERROR
then NIL
else (ERROR "No such medley directory" DIRNAME]
(CL:WHEN MED (PSEUDOFILENAME MED])
(MEDLEYSUBSTDIR
[LAMBDA (OLD NEW BODY) (* ;
@@ -227,7 +228,7 @@
SYSOUTCOMMITS])
)
(RPAQ? MEDLEYDIR )
(RPAQ? MEDLEYDIR (MEDLEYDIR))
(RPAQ? \SAVE.MEDLEYDIR )
@@ -235,6 +236,13 @@
SYSOUTCOMMITS)
(LIST (LIST 'MEDLEY NIL))))
(* ;; "PSEUDOHOSTS comes before MEDLEYDIR in the loadup.")
(PSEUDOHOST 'MEDLEY MEDLEYDIR)
(ADDTOVAR AROUNDEXITFNS MEDLEY-INIT-VARS)
@@ -245,7 +253,7 @@
(* ;;
"The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout. But the FONT cache variables have to be specified here, because FONT is in the INIT and the resetting to NOBIND would wipe out these entries even if they were already correct in the init sysout."
"The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout."
)
@@ -258,24 +266,16 @@
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
(IRM.DINFOGRAPH)
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (PACKFILENAME 'HOST 'DSK 'BODY (OR (UNIX-GETENV
"LOGINDIR")
(UNIX-GETENV
"HOME"]
(PSEUDOHOST 'LI LHD)
LHD)
RESET)
(USERGREETFILES [LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
RESET)
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts" "fonts/displayfonts")
NIL NIL T))
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")
NIL NIL T))
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
NIL NIL T))
(UNICODEDIRECTORIES (MEDLEYDIR '("unicode/xerox")
NIL NIL T))
(XCL::*WHERE-IS-CASH-FILES* (MEDLEYDIR '("loadups")
"whereis.hash" NIL T))
(LOADUPSDIRECTORIES (MEDLEYDIR '("loadups")
@@ -285,6 +285,6 @@
(ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (5324 13336 (MEDLEY-INIT-VARS 5334 . 8812) (MEDLEYDIR 8814 . 12136) (MEDLEYSUBSTDIR
12138 . 13116) (SET-SYSOUT-COMMIT 13118 . 13334)))))
(FILEMAP (NIL (4215 13446 (MEDLEY-INIT-VARS 4225 . 7856) (MEDLEYDIR 7858 . 12246) (MEDLEYSUBSTDIR
12248 . 13226) (SET-SYSOUT-COMMIT 13228 . 13444)))))
STOP

BIN
sources/MEDLEYDIR.LCOM
View File

Binary file not shown.

612
sources/MEDLEYFONTFORMAT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "14-Feb-2026 00:39:34" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;250 60733
(FILECREATED " 5-May-2026 11:06:05" {MEDLEY}<sources>MEDLEYFONTFORMAT.;317 67145
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET MEDLEYFONT.READ.CHARSET)
:CHANGES-TO (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.FILENAME)
:PREVIOUS-DATE "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249)
:PREVIOUS-DATE " 4-May-2026 14:58:55" {MEDLEY}<sources>MEDLEYFONTFORMAT.;316)
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
@@ -18,8 +18,8 @@
(* ;; "Main public entries")
(FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP
MEDLEYFONT.FILEP)
(FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.GETCHARSET.INTERNAL
MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP MEDLEYFONT.FILEP MEDLEYFONT.FILEVERSION)
(* ;; "Reading")
@@ -59,191 +59,222 @@
(DEFINEQ
(MEDLEYFONT.WRITE.FONT
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 20-Jan-2026 22:36 by rmk")
[LAMBDA (FONT FILE OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 30-Mar-2026 12:55 by rmk")
(* ; "Edited 25-Mar-2026 10:48 by rmk")
(* ; "Edited 22-Mar-2026 18:19 by rmk")
(* ; "Edited 21-Mar-2026 15:32 by rmk")
(* ; "Edited 18-Mar-2026 23:16 by rmk")
(* ; "Edited 20-Jan-2026 22:36 by rmk")
(* ; "Edited 2-Sep-2025 23:01 by rmk")
(* ; "Edited 15-Jul-2025 16:43 by rmk")
(* ; "Edited 9-Jul-2025 09:32 by rmk")
(* ; "Edited 19-Jun-2025 10:59 by rmk")
(* ; "Edited 9-Jun-2025 12:17 by rmk")
(* ; "Edited 25-May-2025 20:48 by rmk")
(* ; "Edited 23-May-2025 14:59 by rmk")
(* ; "Edited 22-May-2025 09:58 by rmk")
(* ; "Edited 16-May-2025 20:17 by rmk")
(* ; "Edited 14-May-2025 17:45 by rmk")
(* ;; "This writes all of the information in the fontdescriptor FONT, this doesn't allow for selecting a subset of character sets to write. The information allows all of the current CHARSETINFOs to be reconstructed when the font is read. An uninstantiated charset (CSINFO is NIL) will be read as NIL, and the CSINFO for an empty charset (CSINFO is CSSLUGP) will be installed as the font's slug. The reader can select a subset of the charsets for MEDLEYFONT.GETCHARSET to read. ")
(SETQ FONT (FONTCREATE FONT))
(SETQ FILE (MEDLEYFONT.FILENAME FILE FONT CHARSETNOS))
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
(MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS)
(LET ((CHARSETLOCS (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT 0))
(FONTCHARENCODING (FONTPROP FONT 'CHARENCODING))
(*READTABLE* (FIND-READTABLE "INTERLISP"))
CSVECTORPTRLOC CSVECTORLOC FILECHARSETS)
(CL:WITH-OPEN-FILE
(STREAM (MEDLEYFONT.FILENAME FILE)
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
(MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS FONT)
(* ;; "Figure out the actual non empty/sluggish charsets that will be wrtitten.")
(* ;; "Right after the header, leave bytes for the maxcharset and a pointer to either the charset dispatch vector or a single-charset. Ptr is before fontproperties, vector is after, so MEDLEYFONT.GETCHARSET can skip the font stuff.")
(SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET
when (OR (NULL CHARSETNOS)
(MEMB CSNO CHARSETNOS))
when (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO))
(CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT))
(MEDLEYFONT.WRITE.ITEM STREAM 'MAXCHARSET (MAXCHARSET FONT))
(LET ((CHARSETLOCS (CL:MAKE-ARRAY (ADD1 (MAXCHARSET FONT))
:INITIAL-ELEMENT 0))
(FONTCHARENCODING (FONTPROP FONT 'CHARENCODING))
(*READTABLE* (FIND-READTABLE "INTERLISP"))
CSVECTORPTRLOC CSLOC SINGLECS)
[SETQ SINGLECS (AND (ILEQ (FONTPROP FONT 'NINSTANTIATEDCHARSETS)
1)
(OR (EQ 0 (FONTPROP FONT 'NEMPTYCHARSETS))
(EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS]
(SETQ CSVECTORPTRLOC (GETFILEPTR STREAM))
(\FIXPOUT STREAM 0) (* ;
 "Space for the pointer to the charset info")
(MEDLEYFONT.WRITE.FONTPROPS STREAM FONT)
(PRINTOUT STREAM "CHARSET LOCATIONS" T) (* ; "Signpost for debugging")
(SETQ CSLOC (GETFILEPTR STREAM))
(SETFILEPTR STREAM CSVECTORPTRLOC) (* ;
 "Store the address of the charset info")
(\FIXPOUT STREAM (CL:IF SINGLECS
(IMINUS CSLOC)
CSLOC)) (* ; "Negative for single")
(SETFILEPTR STREAM CSLOC)
[if SINGLECS
then
(* ;; "At most one instantiated, others are either all uninstantiated or all empty, no need for the vector")
(* ;; "Right after the header, leave 4 bytes for the pointer to the charset dispatch vector. If writing a single charset, we store the negative of the byte location so we can still easily skip the font properties without writing the whole vector. The byte in front of the single charset holds its number.")
(if [SETQ SINGLECS (find CSNO CSINFO from 0 to (MAXCHARSET FONT)
suchthat (AND (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
(NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO]
then (\FIXPOUT STREAM SINGLECS) (* ;
 "Charsetno prefix as cell, not byte")
(\BOUT STREAM (CL:IF (EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS))
1
2)) (* ; "All others")
(MEDLEYFONT.WRITE.CHARSET FONT SINGLECS STREAM NOINDIRECTS)
else
(* ;;
 "Fake charset meaning all the same: -1 if all empty, -2 if all uninstantiated.")
(* ;; "")
(\FIXPOUT STREAM (CL:IF (EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS))
-1
-2)))
else
(* ;; "Allocate the vector space")
(SETQ CSVECTORPTRLOC (GETFILEPTR STREAM)) (* ;
 "Ptr is before fontproperties, vector is after")
(\FIXPOUT STREAM 0)
(MEDLEYFONT.WRITE.FONTPROPS STREAM FONT)
(if (CDR FILECHARSETS)
then (PRINTOUT STREAM "CHARSET LOCATIONS" T)
(* ;
 "Allocate the vector space if multiple")
(SETQ CSVECTORLOC (GETFILEPTR STREAM))
(for I from 0 to \MAXCHARSET do (\FIXPOUT STREAM 0))
(TERPRI STREAM)
(for CSNO in FILECHARSETS do
(for CSNO from 0 to (MAXCHARSET FONT) do (\FIXPOUT STREAM 0))
(for CSNO CSINFO from 0 to (MAXCHARSET FONT) when (SETQ CSINFO (\GETCHARSETINFO
FONT CSNO))
do
(* ;; "LOC remains zero if the charset is NIL=uninstantiated. Could have initialized array to -1, flipped to zero here if uninstantiated")
(* ;;
 "LOC remains zero for missing charsets, slug properties are determined by font-level properties.")
(CL:SETF (CL:SVREF CHARSETLOCS CSNO)
(GETFILEPTR STREAM))
(MEDLEYFONT.WRITE.CHARSET FONT CSNO STREAM
NOINDIRECTS))
(SETFILEPTR STREAM CSVECTORLOC)
(for CSNO from 0 to \MAXCHARSET do (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS
CSNO)))
else
(* ;; "Only one. The %"vector%" is the charset byte immediately before the charset, the sign bit tells the tale.")
(SETQ CSVECTORLOC (IMINUS (GETFILEPTR STREAM)))
(BOUT STREAM (CAR FILECHARSETS))
(MEDLEYFONT.WRITE.CHARSET FONT (CAR FILECHARSETS)
STREAM NOINDIRECTS))
(SETFILEPTR STREAM CSVECTORPTRLOC)
(\FIXPOUT STREAM CSVECTORLOC) (* ;
 "Pointer to the charset dispatch vector--or negative of actual location for a singleton")
(FULLNAME STREAM])
(if (fetch (CHARSETINFO CSSLUGP) of CSINFO)
then (CL:SETF (CL:SVREF CHARSETLOCS CSNO)
-1)
else (CL:SETF (CL:SVREF CHARSETLOCS CSNO)
(GETFILEPTR STREAM))
(MEDLEYFONT.WRITE.CHARSET FONT CSNO STREAM NOINDIRECTS)))
(SETFILEPTR STREAM CSLOC) (* ; "Fill in the vector")
(for CSNO from 0 to (MAXCHARSET FONT) do (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS CSNO
]
(FULLNAME STREAM])
(MEDLEYFONT.GETCHARSET
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk")
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 15-Apr-2026 13:29 by rmk")
(* ; "Edited 12-Apr-2026 22:14 by rmk")
(* ; "Edited 6-Apr-2026 09:45 by rmk")
(* ; "Edited 30-Mar-2026 08:42 by rmk")
(* ; "Edited 24-Mar-2026 00:04 by rmk")
(* ; "Edited 21-Mar-2026 15:28 by rmk")
(* ; "Edited 17-Mar-2026 11:42 by rmk")
(* ; "Edited 14-Feb-2026 00:36 by rmk")
(* ; "Edited 9-Oct-2025 15:18 by rmk")
(* ; "Edited 3-Sep-2025 11:32 by rmk")
(* ; "Edited 15-Jul-2025 17:09 by rmk")
(* ; "Edited 9-Jul-2025 15:45 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information. FONT is provided so that properties of the fontdescriptor can be read through this interface--ottherwise the fontcreate function of each device might have to also have a list of functions to try.")
(* ;; "If open, assume its a medleyfont stream, that the initial %"Medley...%" has been checked, FONT is consistent with information in the file, and we are positioned after the header information, at the location of CSLOC.")
(CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(SETQ CHARSET (CHARSET.DECODE CHARSET))
(RESETLST
(CL:UNLESS (\GETSTREAM STREAM 'INPUT T)
[RESETSAVE (SETQ STREAM (OPENSTREAM STREAM 'INPUT))
`(PROGN (CLOSEF? OLDVALUE]
(CL:UNLESS (MEDLEYFONT.FILEP STREAM) (* ;
 "Checks and positions, if reopening.")
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))))
(LET ((CSVECTORLOC (\FIXPIN STREAM))
CSLOC)
(if (thereis CS from 0 to \MAXTHINCHAR suchthat (\GETCHARSETINFO FONT CS))
then
(* ;; "Font fields have been initialized, just update for this charset")
`(PROGN (CLOSEF? OLDVALUE])
(MEDLEYFONT.FILEVERSION STREAM 1)
(MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET)
(MEDLEYFONT.GETCHARSET.INTERNAL STREAM CHARSET FONT (\FIXPIN STREAM)))])
(for P VAL in (MEDLEYFONT.READ.FONTPROPS STREAM)
do (SETQ VAL (CADR P))
(SELECTQ (CAR VAL)
(\SFAscent (change (fetch (FONTDESCRIPTOR \SFAscent) of FONT)
(IMAX VAL DATUM)))
(\SFDescent (change (fetch (FONTDESCRIPTOR \SFDescent) of FONT)
(IMAX VAL DATUM)))
(\SFHeight (fetch (FONTDESCRIPTOR \SFHeight) of FONT))
NIL))
else
(* ;; "First charset, probably 0: establish the overall font properties. ")
(MEDLEYFONT.GETCHARSET.INTERNAL
[LAMBDA (STREAM CHARSET FONT CSLOC) (* ; "Edited 15-Apr-2026 11:09 by rmk")
(* ; "Edited 12-Apr-2026 14:04 by rmk")
(* ; "Edited 29-Mar-2026 22:42 by rmk")
(MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT))
(replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL)
(* ;; "Caller guarantees STREAM and CSLOC as the location of the charset info. CHARSET is less than (MAXCHARSTE FONT).")
(* ;;
 "One charset doesn't %"complete%" a complete font--maybe that's only an incore property? ")
(if (IGREATERP CHARSET (fetch (FONTDESCRIPTOR MAXCHARSET) of FONT))
then (SLUGCSINFO FONT)
else (LET (CSINFO FILECHARSET ALLOTHERS)
(if (ILESSP CSLOC 0)
then
(* ;;
 "File contains at most one instantiated charset, others are either all empty or all uninstantiated")
(* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
(SETFILEPTR STREAM (IMINUS CSLOC))
(SETQ FILECHARSET (\FIXPIN STREAM))
(SETQ ALLOTHERS (BIN STREAM)) (* ; "If not the one we wanted")
[SELECTQ FILECHARSET
(-1 (* ; "All empty")
(SLUGCSINFO FONT))
(-2 (* ; "All uninstantiated")
NIL)
(PROGN (if (IEQP CHARSET FILECHARSET)
then (MEDLEYFONT.READ.CHARSET STREAM CHARSET)
elseif (EQ 1 ALLOTHERS)
then (SLUGCSINFO FONT]
else
(* ;;
 "CSLOC points to the vector, what does it say about the requested CHARSET?")
(CL:WHEN (if (ILESSP CSVECTORLOC 0)
then
(* ;; "File contains only one charset. Is it the one we want? If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(EQ CHARSET (BIN STREAM))
else
(* ;; "The vector-entry points to the one we want. Is it there?")
(SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
(CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM)))
(SETFILEPTR STREAM CSLOC)))
(MEDLEYFONT.READ.CHARSET STREAM CHARSET FONT))))])
(SETFILEPTR STREAM (IPLUS CSLOC (UNFOLD CHARSET BYTESPERCELL)))
(SELECTQ (SETQ CSLOC (\FIXPIN STREAM))
(0 NIL)
(-1 (SLUGCSINFO FONT))
(PROGN (SETFILEPTR STREAM CSLOC)
(MEDLEYFONT.READ.CHARSET STREAM CHARSET FONT])
(MEDLEYFONT.CHARSET?
[LAMBDA (FILE CHARSET) (* ; "Edited 15-Jul-2025 15:21 by rmk")
[LAMBDA (FILE CHARSET) (* ; "Edited 16-Mar-2026 00:31 by rmk")
(* ; "Edited 15-Jul-2025 15:21 by rmk")
(* ; "Edited 25-May-2025 20:53 by rmk")
(* ; "Edited 21-May-2025 11:35 by rmk")
(* ; "Edited 17-May-2025 11:29 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(* ;; "If CHARSET, returns CHARSET if FILE contains a non-slug entry for CHARSET. If not CHARSET, returns the list of non-slug charsets in FILE.")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
(ERROR "Not a MEDLEYFONT file" FILE))
(LET ((CSVECTORLOC (\FIXPIN STREAM)))
(CL:WHEN (if (ILESSP CSVECTORLOC 0)
then
(* ;; "File contains only one charse, is it the one we want? ")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(EQ CHARSET (BIN STREAM))
else (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
(NEQ 0 (\FIXPIN STREAM)))
CHARSET])
(SETQ CHARSET (CHARSET.DECODE CHARSET))
(LET [(CHARSETS (MEDLEYFONT.GETFILEPROP FILE 'CHARSETS]
(CL:IF CHARSET
(CAR (MEMB CHARSET CHARSETS))
CHARSETS)])
(MEDLEYFONT.GETFILEPROP
[LAMBDA (FILE PROP) (* ; "Edited 27-Aug-2025 17:12 by rmk")
[LAMBDA (FILE PROP) (* ; "Edited 4-May-2026 09:57 by rmk")
(* ; "Edited 16-Apr-2026 22:30 by rmk")
(* ; "Edited 15-Apr-2026 00:19 by rmk")
(* ; "Edited 12-Apr-2026 19:31 by rmk")
(* ; "Edited 31-Mar-2026 14:43 by rmk")
(* ; "Edited 28-Mar-2026 22:59 by rmk")
(* ; "Edited 24-Mar-2026 10:56 by rmk")
(* ; "Edited 20-Mar-2026 13:23 by rmk")
(* ; "Edited 27-Aug-2025 17:12 by rmk")
(* ; "Edited 15-Jul-2025 20:21 by rmk")
(* ; "Edited 10-Jul-2025 17:50 by rmk")
(* ; "Edited 25-May-2025 20:53 by rmk")
(* ; "Edited 21-May-2025 11:36 by rmk")
(* ; "Edited 17-May-2025 19:07 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(CL:UNLESS (OR (LITATOM FILE)
(STRINGP FILE))
[SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE)
'SPEC])
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(LET (HEADERPROPS CSVECTORLOC)
(* ; "Edited 17-May-2025 19:07 by rmk")
(SETQ FILE (OR (MEDLEYFONT.FILENAME FILE)
(ERROR "FILE NOT FOUND" FILE)))
(CL:WITH-OPEN-FILE (STREAM (OR (MEDLEYFONT.FILENAME FILE)
FILE)
:DIRECTION :INPUT)
(LET (HEADERPROPS CSLOC SINGLECS MAXCHARSET)
(CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM))
(ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM)))
(SETQ CSVECTORLOC (\FIXPIN STREAM))
(SETQ MAXCHARSET (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET))
(SETQ CSLOC (\FIXPIN STREAM))
(SELECTQ PROP
(OTHERPROPS (CDDR HEADERPROPS))
(DATE (CADR HEADERPROPS))
(MAXCHARSET MAXCHARSET)
(FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))
(CHARSETS (if (ILESSP CSVECTORLOC 0)
(CHARSETS (* ; "Skips slugs and indirects")
(if (ILESSP CSLOC 0)
then
(* ;; "File contains only one charset ")
(* ;; "File contains only one instantiated charset ")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(CONS (BIN STREAM))
else (SETFILEPTR STREAM CSVECTORLOC)
(for CS from 0 to \MAXCHARSET unless (EQ 0 (\FIXPIN STREAM))
collect CS)))
(SETFILEPTR STREAM (IMINUS CSLOC))
(SETQ SINGLECS (\FIXPIN STREAM))
(CL:WHEN (IGEQ SINGLECS 0)
(CONS SINGLECS))
else (SETFILEPTR STREAM CSLOC)
(for CS from 0 to MAXCHARSET when (IGREATERP (\FIXPIN STREAM)
0) collect CS)))
(INDIRECTS
(* ;;
 "These are fully spelled out FONTSPECS, no need to fill in defaults")
(CADR (ASSOC 'ICS (MEDLEYFONT.READ.FONTPROPS STREAM))))
(ERROR "Unknown MEDLEYFONT property"])
(MEDLEYFONT.FILEP
[LAMBDA (FILE) (* ; "Edited 6-Jul-2025 11:44 by rmk")
[LAMBDA (FILE) (* ; "Edited 30-Mar-2026 11:58 by rmk")
(* ; "Edited 29-Mar-2026 10:50 by rmk")
(* ; "Edited 24-Mar-2026 00:55 by rmk")
(* ; "Edited 6-Jul-2025 11:44 by rmk")
(* ; "Edited 10-Jun-2025 18:19 by rmk")
(* ; "Edited 8-Jun-2025 22:55 by rmk")
(* ; "Edited 25-May-2025 20:54 by rmk")
@@ -258,7 +289,7 @@
(* ;; "If FILE is an open stream, it is left open. Otherwise it is opened and closed.")
(RESETLST
[LET (STREAM VERSION DATE)
[LET (STREAM)
[if (\GETSTREAM FILE 'INPUT T)
then (SETQ STREAM FILE)
else (RESETSAVE (SETQ STREAM (OPENSTREAM FILE 'INPUT))
@@ -266,11 +297,26 @@
(CL:UNLESS (ZEROP (GETFILEPTR STREAM))
(SETFILEPTR STREAM 0))
(CL:WHEN (for C in (CONSTANT (CHCON "Medley font")) always (EQ C (READCCODE STREAM)))
[CAR (NLSETQ [CL:WHEN (EQ 0 (SETQ VERSION (MEDLEYFONT.READ.ITEM STREAM 'VERSION]
`(,(FULLNAME STREAM)
,(MEDLEYFONT.READ.ITEM STREAM 'DATE)
,VERSION
,@(MEDLEYFONT.READ.ITEM STREAM 'OTHERFONTPROPS])])])
(* ;; "This sticks the file's MAXCHARSET on the stream, so MEDLEYFONT.GETCHARSET can do a bounds check even without decoding all the other font information. ")
[CAR (NLSETQ `([VERSION ,(MKATOM (MEDLEYFONT.READ.ITEM STREAM 'VERSION]
(FILE ,(FULLNAME STREAM))
[DATE ,(MEDLEYFONT.READ.ITEM STREAM 'DATE]
,@(MEDLEYFONT.READ.ITEM STREAM 'OTHERFONTPROPS])])])
(MEDLEYFONT.FILEVERSION
[LAMBDA (FILE REQUIRED) (* ; "Edited 17-Apr-2026 09:32 by rmk")
(* ; "Edited 4-Apr-2026 00:10 by rmk")
(* ; "Edited 30-Mar-2026 12:08 by rmk")
(* ; "Edited 29-Mar-2026 11:21 by rmk")
(LET* [(PROPS (OR (MEDLEYFONT.FILEP FILE)
(ERROR "Not a Medley font" FILE)))
(FILEVERSION (CADR (ASSOC 'VERSION PROPS]
(CL:WHEN (AND REQUIRED (NEQ REQUIRED FILEVERSION))
(ERROR (CONCAT "Medley font version is " FILEVERSION ", " REQUIRED " is required")
FILE))
FILEVERSION])
)
@@ -280,97 +326,82 @@
(DEFINEQ
(MEDLEYFONT.READ.FONT
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
[LAMBDA (FILE CHARSETS NOERROR DIRECTORY) (* ; "Edited 5-May-2026 11:05 by rmk")
(* ; "Edited 15-Apr-2026 00:50 by rmk")
(* ; "Edited 12-Apr-2026 00:30 by rmk")
(* ; "Edited 6-Apr-2026 09:07 by rmk")
(* ; "Edited 4-Apr-2026 15:29 by rmk")
(* ; "Edited 31-Mar-2026 22:53 by rmk")
(* ; "Edited 30-Mar-2026 12:08 by rmk")
(* ; "Edited 26-Mar-2026 23:23 by rmk")
(* ; "Edited 25-Mar-2026 00:07 by rmk")
(* ; "Edited 21-Mar-2026 00:31 by rmk")
(* ; "Edited 18-Mar-2026 23:51 by rmk")
(* ; "Edited 17-Mar-2026 10:16 by rmk")
(* ; "Edited 2-Mar-2026 20:40 by rmk")
(* ; "Edited 20-Jan-2026 22:31 by rmk")
(* ; "Edited 31-Aug-2025 14:42 by rmk")
(* ; "Edited 15-Jul-2025 20:20 by rmk")
(* ; "Edited 9-Jul-2025 00:06 by rmk")
(* ; "Edited 6-Jul-2025 11:45 by rmk")
(SETQ FONT (CL:IF FONT
(FONTCREATE FONT)
(create FONTDESCRIPTOR)))
(SETQ FILE (MEDLEYFONT.FILENAME FILE FONT))
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))
(LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))
CSVECTORLOC NOTFOUND SINGLECSNO)
(SETQ CSVECTORLOC (\FIXPIN STREAM)) (* ;
 "Byte location of the charset dispatch vector")
(* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
(* ;; "Returns a font descriptor containing the requested charsets from FILE. If FILE is a FONTSPEC, it is coerced to a standard font name on DIRECTORY.")
(SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT))
(CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty")
[if (ILESSP CSVECTORLOC 0)
then
(* ;;
 "File contains only one charset and it's the one we want. Its CHARSET number is in the first byte.")
(* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(SETQ SINGLECSNO (BIN STREAM))
(CL:WHEN CHARSETNOS
(CL:UNLESS (AND (EQ SINGLECSNO (CAR CHARSETNOS))
(NULL (CDR CHARSETNOS)))
(ERROR (CONCAT FILE
" does not contain information for charsets "
(REMOVE SINGLECSNO CHARSETNOS)))))
(\SETCHARSETINFO FONT SINGLECSNO (MEDLEYFONT.READ.CHARSET STREAM
SINGLECSNO))
else
(* ;;
 "Gather all of the CSLOCS before reading, so that we always move forward")
(for CSNO CSLOC
in (OR CHARSETNOS (for I from 0 to \MAXCHARSET collect I))
eachtime (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CSNO
BYTESPERCELL)))
(SETQ CSLOC (\FIXPIN STREAM))
(CL:WHEN (ZEROP CSLOC)
(push NOTFOUND CSNO)) unless (ZEROP CSLOC)
collect (CONS CSNO CSLOC)
finally (CL:WHEN (AND CHARSETNOS NOTFOUND)
(ERROR FILE (CONCAT
" does not contain information for charsets "
(DREVERSE NOTFOUND))))
(for X CS in $$VAL do (SETQ CSNO (CAR X))
(SETFILEPTR STREAM (CDR X))
(\SETCHARSETINFO FONT CSNO (
 MEDLEYFONT.READ.CHARSET
STREAM CSNO])
FONT])
(CL:WHEN [OR (MEMB CHARSETS '(NIL ALL))
(SETQ CHARSETS (SORT (CHARSET.DECODE (MKLIST CHARSETS)
NOERROR]
(RESETLST
(LET ((FILENAME (MEDLEYFONT.FILENAME FILE DIRECTORY))
STREAM FONT CSLOC MAXCHARSET) (* ;
 "CL:OPEN-FILE doesn't exist in the init")
(if FILENAME
then [RESETSAVE (SETQ STREAM (OPENSTREAM FILENAME 'INPUT))
'(PROGN (CLOSEF? OLDVALUE]
(MEDLEYFONT.FILEVERSION STREAM 1)
(SETQ MAXCHARSET (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET))
(SETQ CSLOC (\FIXPIN STREAM)) (* ;
 "CSLOC here so MEDLEYFONT.GETCHARSET can skip over the font stuff.")
(SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM))
(for CSNO from 0 to MAXCHARSET while CHARSETS
when (if (EQ CHARSETS 'ALL)
elseif (EQ CSNO (CAR CHARSETS))
then (pop CHARSETS))
do (\SETCHARSETINFO FONT CSNO (MEDLEYFONT.GETCHARSET.INTERNAL STREAM
CSNO FONT CSLOC)))
FONT
elseif NOERROR
then NIL
else (ERROR "FONT FILE NOT FOUND" FILE)))))])
(MEDLEYFONT.READ.CHARSET
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk")
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 4-May-2026 12:38 by rmk")
(* ; "Edited 30-Apr-2026 08:56 by rmk")
(* ; "Edited 14-Apr-2026 22:32 by rmk")
(* ; "Edited 12-Apr-2026 13:59 by rmk")
(* ; "Edited 30-Mar-2026 08:36 by rmk")
(* ; "Edited 22-Mar-2026 00:21 by rmk")
(* ; "Edited 17-Mar-2026 10:00 by rmk")
(* ; "Edited 14-Feb-2026 00:36 by rmk")
(* ; "Edited 4-Sep-2025 10:39 by rmk")
(* ; "Edited 28-Aug-2025 15:27 by rmk")
(* ; "Edited 26-Aug-2025 23:36 by rmk")
(* ; "Edited 17-Aug-2025 13:01 by rmk")
(* ; "Edited 15-Jul-2025 11:27 by rmk")
(* ; "Edited 9-Jul-2025 19:33 by rmk")
(* ; "Edited 6-Jul-2025 10:11 by rmk")
(* ; "Edited 25-May-2025 20:54 by rmk")
(* ; "Edited 23-May-2025 11:01 by rmk")
(* ; "Edited 21-May-2025 16:25 by rmk")
(* ; "Edited 16-May-2025 20:19 by rmk")
(* ; "Edited 14-May-2025 10:43 by rmk")
(* ; "Edited 12-May-2025 07:55 by rmk")
(* ;; "FONT is only needed for the \READCHARSET call below that interprets an INDIRECT and leads to a recursiving invocation of MEDLEYFONT.GETCHARSET and this function. It is the font descriptor provided at the top-level call. ")
(MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ;
(* ;
 "Throwaway for looking with text editor")
(LET (CSNO INDIRECT)
(CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM STREAM 'CHARSET]
(LET (CSNO)
(CL:UNLESS [EQ CHARSET (SETQ CSNO (MKATOM (MEDLEYFONT.READ.ITEM STREAM 'CS]
(ERROR "Charset mismatch" (LIST CHARSET CSNO)))
(if (EQ 'INDIRECTCHARSET (CAR (MEDLEYFONT.PEEK.ITEM STREAM)))
(if (EQ 'ICS (CAR (MEDLEYFONT.PEEK.ITEM STREAM)))
then
(* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ")
(* ;; "Indirect: Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). The indirect source is in the same directory and has the same extension as the starting file.")
(SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET))
(\READCHARSET INDIRECT CHARSET FONT)
(MEDLEYFONT.GETCHARSET (MEDLEYFONT.FILENAME (MAKEFONTSPEC (MEDLEYFONT.READ.ITEM
STREAM
'ICS)
NIL NIL NIL NIL
(FONTPROP FONT 'DEVICESPEC))
(FULLNAME STREAM))
CHARSET FONT)
else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO
WIDTHS _ NIL
OFFSETS _ NIL)) eachtime (SETQ PAIR
@@ -516,20 +547,31 @@
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
(MEDLEYFONT.READ.VERIFIEDFONT
[LAMBDA (STREAM FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
[LAMBDA (STREAM FONT) (* ; "Edited 15-Apr-2026 23:16 by rmk")
(* ; "Edited 12-Apr-2026 12:51 by rmk")
(* ; "Edited 28-Mar-2026 17:03 by rmk")
(* ; "Edited 23-Mar-2026 11:37 by rmk")
(* ; "Edited 19-Mar-2026 11:48 by rmk")
(* ; "Edited 18-Mar-2026 08:18 by rmk")
(* ; "Edited 2-Mar-2026 20:40 by rmk")
(* ; "Edited 20-Jan-2026 22:31 by rmk")
(* ; "Edited 2-Sep-2025 23:52 by rmk")
(* ; "Edited 12-Aug-2025 17:57 by rmk")
(* ; "Edited 10-Jun-2025 20:57 by rmk")
(* ; "Edited 21-May-2025 22:55 by rmk")
(* ; "Edited 19-May-2025 17:42 by rmk")
(* ; "Edited 16-May-2025 10:28 by rmk")
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)))
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))
(FONT (create FONTDESCRIPTOR
FONTCHARSETVECTOR _ NIL)))
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
(SELECTQ (CAR P)
(FONTDEVICE (replace (FONTDESCRIPTOR FONTDEVICE) of FONT
with VAL))
(FONTCOMPLETEP (replace (FONTDESCRIPTOR FONTCOMPLETEP)
of FONT with VAL))
(FONTCOERCEDP (replace (FONTDESCRIPTOR FONTCOERCEDP)
of FONT with VAL))
(FONTFAMILY (replace (FONTDESCRIPTOR FONTFAMILY) of FONT
with VAL))
(FONTSIZE (replace (FONTDESCRIPTOR FONTSIZE) of FONT
@@ -544,6 +586,8 @@
with VAL))
(ROTATION (replace (FONTDESCRIPTOR ROTATION) of FONT
with VAL))
(MAXCHARSET (replace (FONTDESCRIPTOR MAXCHARSET) of FONT
with VAL))
(FONTSLUGWIDTH (replace (FONTDESCRIPTOR FONTSLUGWIDTH)
of FONT with VAL))
(FONTTOMCCSFN (replace (FONTDESCRIPTOR FONTTOMCCSFN)
@@ -556,24 +600,25 @@
of FONT with VAL))
(FONTSCALE (replace (FONTDESCRIPTOR FONTSCALE) of FONT
with VAL))
(\SFFACECODE (replace (FONTDESCRIPTOR \SFFACECODE)
of FONT with VAL))
(FONTAVGCHARWIDTH
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT
with VAL))
(FONTCHARENCODING
(replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT
with VAL))
(FONTCHARSETVECTOR
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT
with VAL))
(FONTHASLEFTKERNS
(replace (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT
with VAL))
(FONTEXTRAFIELD2
(replace (FONTDESCRIPTOR FONTEXTRAFIELD2) of FONT
with VAL))
(INDIRECTS (* ; "Only a file prop"))
(\SFFACECODE (* ; "to be deprecated"))
(HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P")))
(replace (FONTDESCRIPTOR FONTFILENAME) of FONT with (PSEUDOFILENAME (FULLNAME STREAM)))
(* ;
 "PSEUDOFILENAME so that a deployed fontfile is redirected in a new sysout/makesys environment ")
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT with (\CREATEFONTCHARSETVECTOR FONT))
FONT])
)
@@ -584,7 +629,9 @@
(DEFINEQ
(MEDLEYFONT.WRITE.CHARSET
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-Sep-2025 11:41 by rmk")
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-May-2026 11:53 by rmk")
(* ; "Edited 1-Apr-2026 09:20 by rmk")
(* ; "Edited 4-Sep-2025 11:41 by rmk")
(* ; "Edited 30-Aug-2025 23:44 by rmk")
(* ; "Edited 28-Aug-2025 21:00 by rmk")
(* ; "Edited 9-Jul-2025 19:14 by rmk")
@@ -593,10 +640,9 @@
(* ; "Edited 16-May-2025 20:18 by rmk")
(* ; "Edited 13-May-2025 23:26 by rmk")
(LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET))
CSCHARENCODING)
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET))
(* ; "For human file-scan")
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSET CHARSET)
CSCHARENCODING INDIRECT)
(MEDLEYFONT.WRITE.ITEM STREAM 'CS (MKSTRING CHARSET))
(* ; "String for human file-scan")
(CL:UNLESS (OR (NULL CSINFO)
(fetch (CHARSETINFO CSSLUGP) of CSINFO))
(* ;
@@ -604,12 +650,21 @@
(* ;; "Copy the fonts charencoding down to each charset info so that it is available when the charsetinfo is read. The fontdescriptor isn't available at that point and coercion could lead to fonts of different encodings. At least this would make it possible to fix things up.")
(if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT))
(if (CL:UNLESS NOINDIRECTS
(SETQ INDIRECT (INDIRECTCHARSETP CSINFO FONT)))
then
(* ;;
 "This charset is is taken entirely from on another file, no need to copy it to this file.")
(* ;; "This charset is is taken entirely from another file, no need to copy it to this file. Leave off the redundant FONTSPEC stuff")
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE)
(MEDLEYFONT.WRITE.ITEM STREAM 'ICS (LIST* (fetch (FONTSPEC FSFAMILY)
of INDIRECT)
(fetch (FONTSPEC FSSIZE) of INDIRECT)
(fetch (FONTSPEC FSFACE) of INDIRECT)
(CL:UNLESS
(EQ (FONTPROP FONT 'ROTATION)
(fetch (FONTSPEC FSROTATION)
of INDIRECT))
(fetch (FONTSPEC FSROTATION)
of INDIRECT)))
NIL
'PRINT)
else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS)
@@ -774,7 +829,12 @@
(TERPRI STREAM))])
(MEDLEYFONT.WRITE.FONTPROPS
[LAMBDA (STREAM FONT) (* ; "Edited 12-Aug-2025 17:55 by rmk")
[LAMBDA (STREAM FONT) (* ; "Edited 4-May-2026 09:57 by rmk")
(* ; "Edited 31-Mar-2026 14:53 by rmk")
(* ; "Edited 23-Mar-2026 11:52 by rmk")
(* ; "Edited 19-Mar-2026 11:48 by rmk")
(* ; "Edited 18-Mar-2026 08:17 by rmk")
(* ; "Edited 12-Aug-2025 17:55 by rmk")
(* ; "Edited 10-Jun-2025 20:50 by rmk")
(* ; "Edited 25-May-2025 20:50 by rmk")
(* ; "Edited 22-May-2025 10:31 by rmk")
@@ -785,7 +845,7 @@
(* ;; "HPRINT would be obvious, but it would get charsetvector etc.")
(* ;; "Exclude FONTCHARSETVECTOR and \SFFACECODE")
(* ;; "Exclude FONTCHARSETVECTOR ")
(* ;; "Write even NIL values for default overerides")
@@ -793,6 +853,8 @@
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTCOMPLETEP (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTCOERCEDP (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTFAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTSIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
@@ -807,6 +869,8 @@
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'MAXCHARSET (fetch (FONTDESCRIPTOR MAXCHARSET) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTSLUGWIDTH (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTTOMCCSFN (fetch (FONTDESCRIPTOR FONTTOMCCSFN) of FONT)
@@ -827,53 +891,54 @@
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTHASLEFTKERNS (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTEXTRAFIELD2 (fetch (FONTDESCRIPTOR FONTEXTRAFIELD2)
of FONT)
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTS (for CS CSINFO INDIRECT (FSPEC _ (FONTPROP FONT
'DEVICESPEC))
from 0 to (MAXCHARSET FONT)
when (SETQ CSINFO (\GETCHARSETINFO FONT CS))
when (SETQ INDIRECT (CHARSETPROP CSINFO 'SOURCE))
unless (EQUAL FSPEC INDIRECT)
unless (MEMBER INDIRECT $$VAL)
do (push $$VAL INDIRECT))
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'STOP T])
(MEDLEYFONT.WRITE.HEADER
[LAMBDA (STREAM OTHERFONTPROPS) (* ; "Edited 25-May-2025 20:51 by rmk")
[LAMBDA (STREAM OTHERFONTPROPS FONT) (* ; "Edited 29-Mar-2026 10:45 by rmk")
(* ; "Edited 24-Mar-2026 00:55 by rmk")
(* ; "Edited 25-May-2025 20:51 by rmk")
(* ; "Edited 16-May-2025 20:20 by rmk")
(* ; "Edited 14-May-2025 17:01 by rmk")
(* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others")
(PRINTOUT STREAM "Medley font" T)
(MEDLEYFONT.WRITE.ITEM STREAM 'VERSION 0)
(MEDLEYFONT.WRITE.ITEM STREAM 'VERSION "1")
(MEDLEYFONT.WRITE.ITEM STREAM 'DATE (DATE))
(MEDLEYFONT.WRITE.ITEM STREAM 'OTHERFONTPROPS OTHERFONTPROPS T])
)
(DEFINEQ
(MEDLEYFONT.FILENAME
[LAMBDA (FILE FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 23-Jan-2026 15:10 by rmk")
(* ; "Edited 20-Jan-2026 17:39 by rmk")
[LAMBDA (FILE DIRECTORY) (* ; "Edited 5-May-2026 11:02 by rmk")
(* ; "Edited 4-May-2026 09:01 by rmk")
(* ; "Edited 30-Apr-2026 08:54 by rmk")
(* ; "Edited 15-Apr-2026 00:41 by rmk")
(* ; "Edited 23-Jan-2026 15:10 by rmk")
(* ; "Edited 7-Oct-2025 11:50 by rmk")
(* ; "Edited 4-Sep-2025 08:48 by rmk")
(* ; "Edited 10-Jun-2025 11:02 by rmk")
(* ; "Edited 25-May-2025 21:25 by rmk")
(* ; "Edited 19-May-2025 17:42 by rmk")
(* ; "Edited 16-May-2025 14:09 by rmk")
(LET [(FONTSPEC (AND FONT (\FONT.CHECKARGS FONT NIL NIL NIL NIL T]
(CL:UNLESS EXTENSION (* ;
 "EXTENSION may be needed for DIRECTORY below")
(SETQ EXTENSION (OR (FILENAMEFIELD FILE 'EXTENSION)
(CONCAT "MEDLEY" (OR (AND FONTSPEC (fetch (FONTSPEC FSDEVICE)
of FONTSPEC))
(ERROR "Font device not known"))
"FONT"))))
(PACKFILENAME.STRING `(BODY ,FILE ,@(UNPACKFILENAME.STRING (AND FONTSPEC
(\FONTFILENAME FONTSPEC NIL
NIL NIL CHARSET)))
DIRECTORY
,(OR DIRECTORY (FILENAMEFIELD FILE 'DIRECTORY)
(PSEUDOFILENAME (CONCAT (MEDLEYDIR)
"fonts/"
(L-CASE EXTENSION)
"s")))
EXTENSION
,EXTENSION])
(* ; "Edited 10-Jun-2025 11:02 by rmk")
(CL:WHEN (\GETSTREAM FILE 'INPUT T)
(SETQ FILE (FULLNAME FILE)))
(CL:WHEN DIRECTORY (* ; "Keep the host/directory.")
(SETQ DIRECTORY (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY DIRECTORY)))
(if (type? FONTSPEC FILE)
then (SETQ FILE (\FONT.CHECKARGS FILE NIL NIL NIL NIL T))
(CL:UNLESS DIRECTORY
[SETQ DIRECTORY (CAR (MKLIST (FONTDEVICEPROP FILE 'FONTDIRECTORIES])
(PACKFILENAME 'DIRECTORY DIRECTORY 'BODY (\FONTFILENAME FILE))
elseif FILE
then (* ; "File name")
(PACKFILENAME 'BODY FILE 'DIRECTORY DIRECTORY])
)
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
@@ -924,11 +989,12 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2152 16901 (MEDLEYFONT.WRITE.FONT 2162 . 7217) (MEDLEYFONT.GETCHARSET 7219 . 11360) (
MEDLEYFONT.CHARSET? 11362 . 12831) (MEDLEYFONT.GETFILEPROP 12833 . 14933) (MEDLEYFONT.FILEP 14935 .
16899)) (16927 39618 (MEDLEYFONT.READ.FONT 16937 . 21473) (MEDLEYFONT.READ.CHARSET 21475 . 27190) (
MEDLEYFONT.READ.ITEM 27192 . 33341) (MEDLEYFONT.PEEK.ITEM 33343 . 34205) (MEDLEYFONT.READ.FONTPROPS
34207 . 34672) (MEDLEYFONT.READ.VERIFIEDFONT 34674 . 39616)) (39644 57481 (MEDLEYFONT.WRITE.CHARSET
39654 . 44216) (MEDLEYFONT.WRITE.ITEM 44218 . 53271) (MEDLEYFONT.WRITE.FONTPROPS 53273 . 56826) (
MEDLEYFONT.WRITE.HEADER 56828 . 57479)) (57482 59848 (MEDLEYFONT.FILENAME 57492 . 59846)))))
(FILEMAP (NIL (2199 20663 (MEDLEYFONT.WRITE.FONT 2209 . 8612) (MEDLEYFONT.GETCHARSET 8614 . 10695) (
MEDLEYFONT.GETCHARSET.INTERNAL 10697 . 12950) (MEDLEYFONT.CHARSET? 12952 . 13830) (
MEDLEYFONT.GETFILEPROP 13832 . 17396) (MEDLEYFONT.FILEP 17398 . 19826) (MEDLEYFONT.FILEVERSION 19828
. 20661)) (20689 44110 (MEDLEYFONT.READ.FONT 20699 . 24534) (MEDLEYFONT.READ.CHARSET 24536 . 30297) (
MEDLEYFONT.READ.ITEM 30299 . 36448) (MEDLEYFONT.PEEK.ITEM 36450 . 37312) (MEDLEYFONT.READ.FONTPROPS
37314 . 37779) (MEDLEYFONT.READ.VERIFIEDFONT 37781 . 44108)) (44136 64607 (MEDLEYFONT.WRITE.CHARSET
44146 . 49791) (MEDLEYFONT.WRITE.ITEM 49793 . 58846) (MEDLEYFONT.WRITE.FONTPROPS 58848 . 63732) (
MEDLEYFONT.WRITE.HEADER 63734 . 64605)) (64608 66260 (MEDLEYFONT.FILENAME 64618 . 66258)))))
STOP

BIN
sources/MEDLEYFONTFORMAT.LCOM
View File

Binary file not shown.